1#
2# $Id$
3#
4
5package require Tk 8.5
6package require tcltest ; namespace import -force tcltest::*
7loadTestedCommands
8
9proc propagate-geometry {} { update idletasks }
10
11# Basic sanity checks:
12#
13test panedwindow-1.0 "Setup" -body {
14    ttk::panedwindow .pw
15} -result .pw
16
17test panedwindow-1.1 "Make sure empty panedwindow doesn't crash" -body {
18    pack .pw -expand true -fill both
19    update
20}
21
22test panedwindow-1.2 "Add a pane" -body {
23    .pw add [ttk::frame .pw.f1]
24    winfo manager .pw.f1
25} -result "panedwindow"
26
27test panedwindow-1.3 "Steal pane" -body {
28    pack .pw.f1 -side bottom
29    winfo manager .pw.f1
30} -result "pack"
31
32test panedwindow-1.4 "Make sure empty panedwindow still doesn't crash" -body {
33    update
34}
35
36test panedwindow-1.5 "Remanage pane" -body {
37    #XXX .pw insert 0 .pw.f1
38    .pw add .pw.f1
39    winfo manager .pw.f1
40} -result "panedwindow"
41
42test panedwindow-1.6 "Forget pane" -body {
43    .pw forget .pw.f1
44    winfo manager .pw.f1
45} -result ""
46
47test panedwindow-1.7 "Make sure empty panedwindow still still doesn't crash" -body {
48    update
49}
50
51test panedwindow-1.8 "Re-forget pane" -body {
52    .pw forget .pw.f1
53} -returnCodes 1 -result ".pw.f1 is not managed by .pw"
54
55test panedwindow-1.end "Cleanup" -body {
56    destroy .pw
57}
58
59# Resize behavior:
60#
61test panedwindow-2.1 "..." -body {
62    ttk::panedwindow .pw -orient horizontal
63
64    .pw add [listbox .pw.l1]
65    .pw add [listbox .pw.l2]
66    .pw add [listbox .pw.l3]
67    .pw add [listbox .pw.l4]
68
69    pack .pw -expand true -fill both
70    update
71    set w1 [winfo width .]
72
73    # This should make the window shrink:
74    destroy .pw.l2
75
76    update
77    set w2 [winfo width .]
78
79    expr {$w2 < $w1}
80} -result 1
81
82test panedwindow-2.2 "..., cont'd" -body {
83
84    # This should keep the window from shrinking:
85    wm geometry . [wm geometry .]
86
87    set rw2 [winfo reqwidth .pw]
88
89    destroy .pw.l1
90    update
91
92    set w3 [winfo width .]
93    set rw3 [winfo reqwidth .pw]
94
95    expr {$w3 == $w2 && $rw3 < $rw2}
96    # problem: [winfo reqwidth] shrinks, but sashes haven't moved
97    # since we haven't gotten a ConfigureNotify.
98    # How to (a) check for this, and (b) fix it?
99} -result 1
100
101test panedwindow-2.3 "..., cont'd" -body {
102
103    .pw add [listbox .pw.l5]
104    update
105    set rw4 [winfo reqwidth .pw]
106
107    expr {$rw4 > $rw3}
108} -result 1
109
110test panedwindow-2.end "Cleanup" -body { destroy .pw }
111
112#
113# ...
114#
115test panedwindow-3.0 "configure pane" -body {
116    ttk::panedwindow .pw
117    .pw add [listbox .pw.lb1] 
118    .pw add [listbox .pw.lb2] 
119    .pw pane 1 -weight 2
120    .pw pane 1 -weight
121} -result 2
122
123test panedwindow-3.1 "configure pane -- errors" -body {
124    .pw pane 1 -weight -4
125} -returnCodes 1 -match glob -result "-weight must be nonnegative"
126
127test panedwindow-3.2 "add pane -- errors" -body {
128    .pw add [ttk::label .pw.l] -weight -1
129} -returnCodes 1 -match glob -result "-weight must be nonnegative"
130
131
132test panedwindow-3.end "cleanup" -body { destroy .pw }
133
134
135test panedwindow-4.1 "forget" -body {
136    pack [ttk::panedwindow .pw -orient vertical] -expand true -fill both
137    .pw add [label .pw.l1 -text "L1"]
138    .pw add [label .pw.l2 -text "L2"]
139    .pw add [label .pw.l3 -text "L3"]
140    .pw add [label .pw.l4 -text "L4"]
141
142    update
143
144    .pw forget .pw.l1
145    .pw forget .pw.l2
146    .pw forget .pw.l3
147    .pw forget .pw.l4
148    update
149}
150
151test panedwindow-4.2 "forget forgotten" -body {
152    .pw forget .pw.l1
153} -returnCodes 1 -result ".pw.l1 is not managed by .pw"
154
155# checkorder $winlist --
156#	Ensure that Y coordinates windows in $winlist are strictly increasing.
157#
158proc checkorder {winlist} {
159    set pos -1
160    set positions [list]
161    foreach win $winlist {
162    	lappend positions [set nextpos [winfo y $win]]
163	if {$nextpos <= $pos} {
164	    error "window $win out of order ($positions)"
165	}
166	set pos $nextpos
167    }
168}
169
170test panedwindow-4.3 "insert command" -body {
171    .pw insert end .pw.l1
172    .pw insert end .pw.l3
173    .pw insert 1 .pw.l2
174    .pw insert end .pw.l4
175
176    update;
177    checkorder {.pw.l1 .pw.l2 .pw.l3 .pw.l4}
178}
179
180test panedwindow-4.END "cleanup" -body {
181    destroy .pw
182}
183
184# See #1292219
185
186test panedwindow-5.1 "Propagate Map/Unmap state to children" -body {
187    set result [list]
188    pack [ttk::panedwindow .pw]
189    .pw add [ttk::button .pw.b]
190    update
191
192    lappend result [winfo ismapped .pw] [winfo ismapped .pw.b]
193
194    pack forget .pw
195    update
196    lappend result [winfo ismapped .pw] [winfo ismapped .pw.b]
197
198    set result
199} -result [list 1 1 0 0] -cleanup {
200    destroy .pw
201}
202
203### sashpos tests.
204#
205proc sashpositions {pw} {
206    set positions [list]
207    set npanes [llength [winfo children $pw]]
208    for {set i 0} {$i < $npanes - 1} {incr i} {
209    	lappend positions [$pw sashpos $i]
210    }
211    return $positions
212}
213
214test paned-sashpos-setup "Setup for sash position test" -body {
215    ttk::style theme use default
216    ttk::style configure -sashthickness 5
217
218    ttk::panedwindow .pw
219    .pw add [frame .pw.f1 -width 20 -height 20]
220    .pw add [frame .pw.f2 -width 20 -height 20]
221    .pw add [frame .pw.f3 -width 20 -height 20]
222    .pw add [frame .pw.f4 -width 20 -height 20]
223
224    propagate-geometry
225    list [winfo reqwidth .pw] [winfo reqheight .pw]
226} -result [list 20 [expr {20*4 + 5*3}]]
227
228test paned-sashpos-attempt-restore "Attempt to set sash positions" -body {
229    # This is not expected to succeed, since .pw isn't large enough yet.
230    #
231    .pw sashpos 0 30
232    .pw sashpos 1 60
233    .pw sashpos 2 90
234
235    list [winfo reqwidth .pw] [winfo reqheight .pw] [sashpositions .pw]
236} -result [list 20 95 [list 0 5 10]]
237
238test paned-sashpos-restore "Set height then sash positions" -body {
239    # Setting sash positions after setting -height _should_ succeed.
240    #
241    .pw configure -height 120
242    .pw sashpos 0 30
243    .pw sashpos 1 60
244    .pw sashpos 2 90
245    list [winfo reqwidth .pw] [winfo reqheight .pw] [sashpositions .pw]
246} -result [list 20 120 [list 30 60 90]]
247
248test paned-sashpos-cleanup "Clean up" -body { destroy .pw }
249
250test paned-propagation-setup "Setup." -body {
251    ttk::style theme use default
252    ttk::style configure -sashthickness 5
253    wm geometry . {}
254    ttk::panedwindow .pw -orient vertical
255
256    frame .pw.f1 -width 100 -height 50
257    frame .pw.f2 -width 100 -height 50
258
259    list [winfo reqwidth .pw.f1] [winfo reqheight .pw.f1]
260} -result [list 100 50] 
261
262test paned-propagation-1 "Initial request size" -body {
263    .pw add .pw.f1
264    .pw add .pw.f2
265    propagate-geometry
266    list [winfo reqwidth .pw] [winfo reqheight .pw]
267} -result [list 100 105]
268
269test paned-propagation-2 "Slave change before map" -body {
270    .pw.f1 configure -width 200 -height 100
271    propagate-geometry
272    list [winfo reqwidth .pw] [winfo reqheight .pw]
273} -result [list 200 155]
274
275test paned-propagation-3 "Map window" -body {
276    pack .pw -expand true -fill both
277    update
278    list [winfo width .pw] [winfo height .pw] [.pw sashpos 0]
279} -result [list 200 155 100]
280
281test paned-propagation-4 "Slave change after map, off-axis" -body {
282    .pw.f1 configure -width 100 ;# should be granted
283    propagate-geometry
284    list [winfo reqwidth .pw] [winfo reqheight .pw] [.pw sashpos 0]
285} -result [list 100 155 100]
286
287test paned-propagation-5 "Slave change after map, on-axis" -body {
288    .pw.f1 configure -height 50 ;# should be denied
289    propagate-geometry
290    list [winfo reqwidth .pw] [winfo reqheight .pw] [.pw sashpos 0]
291} -result [list 100 155 100]
292
293test paned-propagation-cleanup "Clean up." -body { destroy .pw }
294
295tcltest::cleanupTests
296