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