1# This file is a Tcl script to test out the "place" command.  It is
2# organized in the standard fashion for Tcl tests.
3#
4# Copyright (c) 1995 Sun Microsystems, Inc.
5# Copyright (c) 1998-1999 by Scriptics Corporation.
6# All rights reserved.
7#
8# RCS: @(#) $Id$
9
10package require tcltest 2.1
11eval tcltest::configure $argv
12tcltest::loadTestedCommands
13
14# Used for constraining memory leak tests
15testConstraint memory [llength [info commands memory]]
16
17# XXX - This test file is woefully incomplete.  At present, only a
18# few of the features are tested.
19
20toplevel .t -width 300 -height 200 -bd 0
21wm geom .t +0+0
22frame .t.f -width 154 -height 84 -bd 2 -relief raised
23place .t.f -x 48 -y 38
24frame .t.f2 -width 30 -height 60 -bd 2 -relief raised
25update
26
27test place-1.1 {Tk_PlaceCmd procedure, "info" option} {
28    place .t.f2 -x 0
29    place info .t.f2
30} {-in .t -x 0 -relx 0 -y 0 -rely 0 -width {} -relwidth {} -height {} -relheight {} -anchor nw -bordermode inside}
31test place-1.2 {Tk_PlaceCmd procedure, "info" option} {
32    place .t.f2 -x 1 -y 2 -width 3 -height 4 -relx 0.1 -rely 0.2 \
33	    -relwidth 0.3 -relheight 0.4 -anchor se -in .t.f  \
34	    -bordermode outside
35    place info .t.f2
36} {-in .t.f -x 1 -relx 0.1 -y 2 -rely 0.2 -width 3 -relwidth 0.3 -height 4 -relheight 0.4 -anchor se -bordermode outside}
37test place-1.3 {Tk_PlaceCmd procedure, "info" option} {
38    # Make sure the result is built as a proper list by using a space in parent
39    frame ".t.a b"
40    place .t.f2 -x 1 -y 2 -width {} -height 4 -relx 0.2 -rely 0.2 \
41	    -relwidth 0.3 -relheight {} -anchor w -in ".t.a b"  \
42	    -bordermode ignore
43    set res [place info .t.f2]
44    destroy ".t.a b"
45    set res
46} {-in {.t.a b} -x 1 -relx 0.2 -y 2 -rely 0.2 -width {} -relwidth 0.3 -height 4 -relheight {} -anchor w -bordermode ignore}
47
48test place-2.1 {ConfigureSlave procedure, -height option} {
49    list [catch {place .t.f2 -height abcd} msg] $msg
50} {1 {bad screen distance "abcd"}}
51test place-2.2 {ConfigureSlave procedure, -height option} {
52    place forget .t.f2
53    place .t.f2 -in .t.f -height 40
54    update
55    winfo height .t.f2
56} {40}
57test place-2.3 {ConfigureSlave procedure, -height option} {
58    place forget .t.f2
59    place .t.f2 -in .t.f -height 120
60    update
61    place .t.f2 -height {}
62    update
63    winfo height .t.f2
64} {60}
65
66test place-3.1 {ConfigureSlave procedure, -relheight option} {
67    list [catch {place .t.f2 -relheight abcd} msg] $msg
68} {1 {expected floating-point number but got "abcd"}}
69test place-3.2 {ConfigureSlave procedure, -relheight option} {
70    place forget .t.f2
71    place .t.f2 -in .t.f -relheight .5
72    update
73    winfo height .t.f2
74} {40}
75test place-3.3 {ConfigureSlave procedure, -relheight option} {
76    place forget .t.f2
77    place .t.f2 -in .t.f -relheight .8
78    update
79    place .t.f2 -relheight {}
80    update
81    winfo height .t.f2
82} {60}
83
84test place-4.1 {ConfigureSlave procedure, bad -in options} {
85    place forget .t.f2
86    list [catch {place .t.f2 -in .t.f2} msg] $msg
87} [list 1 "can't place .t.f2 relative to itself"]
88test place-4.2 {ConfigureSlave procedure, bad -in option} {
89    place forget .t.f2
90    list [winfo manager .t.f2] \
91        [catch {place .t.f2 -in .t.f2} err] $err \
92        [winfo manager .t.f2]
93} {{} 1 {can't place .t.f2 relative to itself} {}}
94test place-4.3 {ConfigureSlave procedure, bad -in option} {
95    place forget .t.f2
96    list [catch {place .t.f2 -in .} msg] $msg
97} [list 1 "can't place .t.f2 relative to ."]
98
99test place-5.1 {ConfigureSlave procedure, -relwidth option} {
100    list [catch {place .t.f2 -relwidth abcd} msg] $msg
101} {1 {expected floating-point number but got "abcd"}}
102test place-5.2 {ConfigureSlave procedure, -relwidth option} {
103    place forget .t.f2
104    place .t.f2 -in .t.f -relwidth .5
105    update
106    winfo width .t.f2
107} {75}
108test place-5.3 {ConfigureSlave procedure, -relwidth option} {
109    place forget .t.f2
110    place .t.f2 -in .t.f -relwidth .8
111    update
112    place .t.f2 -relwidth {}
113    update
114    winfo width .t.f2
115} {30}
116
117test place-6.1 {ConfigureSlave procedure, -width option} {
118    list [catch {place .t.f2 -width abcd} msg] $msg
119} {1 {bad screen distance "abcd"}}
120test place-6.2 {ConfigureSlave procedure, -width option} {
121    place forget .t.f2
122    place .t.f2 -in .t.f -width 100
123    update
124    winfo width .t.f2
125} {100}
126test place-6.3 {ConfigureSlave procedure, -width option} {
127    place forget .t.f2
128    place .t.f2 -in .t.f -width 120
129    update
130    place .t.f2 -width {}
131    update
132    winfo width .t.f2
133} {30}
134
135test place-7.1 {ReconfigurePlacement procedure, computing position} {
136    place forget .t.f2
137    place .t.f2 -in .t.f -x -2 -relx .5 -y 3 -rely .4
138    update
139    winfo geometry .t.f2
140} {30x60+123+75}
141test place-7.2 {ReconfigurePlacement procedure, position rounding} {
142    place forget .t.f2
143    place .t.f2 -in .t.f -x -1.4 -y -2.3
144    update
145    winfo geometry .t.f2
146} {30x60+49+38}
147test place-7.3 {ReconfigurePlacement procedure, position rounding} {
148    place forget .t.f2
149    place .t.f2 -in .t.f -x 1.4 -y 2.3
150    update
151    winfo geometry .t.f2
152} {30x60+51+42}
153test place-7.4 {ReconfigurePlacement procedure, position rounding} {
154    place forget .t.f2
155    place .t.f2 -in .t.f -x -1.6 -y -2.7
156    update
157    winfo geometry .t.f2
158} {30x60+48+37}
159test place-7.5 {ReconfigurePlacement procedure, position rounding} {
160    place forget .t.f2
161    place .t.f2 -in .t.f -x 1.6 -y 2.7
162    update
163    winfo geometry .t.f2
164} {30x60+52+43}
165test place-7.6 {ReconfigurePlacement procedure, position rounding} {
166    frame .t.f3 -width 100 -height 100 -bg #f00000 -bd 0
167    place .t.f3 -x 0 -y 0
168    raise .t.f2
169    place forget .t.f2
170    place .t.f2 -in .t.f3 -relx .303 -rely .406 -relwidth .304 -relheight .206
171    update
172    winfo geometry .t.f2
173} {31x20+30+41}
174catch {destroy .t.f3}
175test place-7.7 {ReconfigurePlacement procedure, computing size} {
176    place forget .t.f2
177    place .t.f2 -in .t.f -width 120 -height 89
178    update
179    list [winfo width .t.f2] [winfo height .t.f2]
180} {120 89}
181test place-7.8 {ReconfigurePlacement procedure, computing size} {
182    place forget .t.f2
183    place .t.f2 -in .t.f -relwidth .4 -relheight .5
184    update
185    list [winfo width .t.f2] [winfo height .t.f2]
186} {60 40}
187test place-7.9 {ReconfigurePlacement procedure, computing size} {
188    place forget .t.f2
189    place .t.f2 -in .t.f -width 10 -relwidth .4 -height -4 -relheight .5
190    update
191    list [winfo width .t.f2] [winfo height .t.f2]
192} {70 36}
193test place-7.10 {ReconfigurePlacement procedure, computing size} {
194    place forget .t.f2
195    place .t.f2 -in .t.f -width 10 -relwidth .4 -height -4 -relheight .5
196    place .t.f2 -width {} -relwidth {} -height {} -relheight {}
197    update
198    list [winfo width .t.f2] [winfo height .t.f2]
199} {30 60}
200
201
202test place-8.1 {MasterStructureProc, mapping and unmapping slaves} {
203    place forget .t.f2
204    place forget .t.f
205    place .t.f2 -relx 1.0 -rely 1.0 -anchor sw
206    update
207    set result [winfo ismapped .t.f2]
208    wm iconify .t
209    update
210    lappend result [winfo ismapped .t.f2]
211    place .t.f2 -x 40 -y 30 -relx 0 -rely 0 -anchor nw
212    update
213    lappend result [winfo x .t.f2] [winfo y .t.f2] [winfo ismapped .t.f2]
214    wm deiconify .t
215    update
216    lappend result [winfo ismapped .t.f2]
217} {1 0 40 30 0 1}
218test place-8.2 {MasterStructureProc, mapping and unmapping slaves} {
219    place forget .t.f2
220    place forget .t.f
221    place .t.f -x 0 -y 0 -width 200 -height 100
222    place .t.f2 -in .t.f -relx 1.0 -rely 1.0 -anchor sw -width 50 -height 20
223    update
224    set result [winfo ismapped .t.f2]
225    wm iconify .t
226    update
227    lappend result [winfo ismapped .t.f2]
228    place .t.f2 -x 40 -y 30 -relx 0 -rely 0 -anchor nw
229    update
230    lappend result [winfo x .t.f2] [winfo y .t.f2] [winfo ismapped .t.f2]
231    wm deiconify .t
232    update
233    lappend result [winfo ismapped .t.f2]
234} {1 0 42 32 0 1}
235
236test place-9.1 {PlaceObjCmd} {
237    list [catch {place} msg] $msg
238} [list 1 "wrong # args: should be \"place option|pathName args\""]
239test place-9.2 {PlaceObjCmd} {
240    list [catch {place foo} msg] $msg
241} [list 1 "wrong # args: should be \"place option|pathName args\""]
242test place-9.3 {PlaceObjCmd} {
243    catch {destroy .foo}
244    list [catch {place .foo bar} msg] $msg
245} [list 1 "bad window path name \".foo\""]
246test place-9.4 {PlaceObjCmd} {
247    catch {destroy .foo}
248    list [catch {place bar .foo} msg] $msg
249} [list 1 "bad window path name \".foo\""]
250test place-9.5 {PlaceObjCmd} {
251    catch {destroy .foo}
252    frame .foo
253    set res [list [catch {place badopt .foo} msg] $msg]
254    destroy .foo
255    set res
256} [list 1 "bad option \"badopt\": must be configure, forget, info, or slaves"]
257test place-9.6 {PlaceObjCmd, configure errors} {
258    catch {destroy .foo}
259    frame .foo
260    set res [list [catch {place configure .foo} msg] $msg]
261    destroy .foo
262    set res
263} [list 0 ""]
264test place-9.7 {PlaceObjCmd, configure errors} {
265    catch {destroy .foo}
266    frame .foo
267    set res [list [catch {place configure .foo bar} msg] $msg]
268    destroy .foo
269    set res
270} [list 0 ""]
271test place-9.8 {PlaceObjCmd, configure} {
272    catch {destroy .foo}
273    frame .foo
274    place .foo -x 0 -y 0
275    set res [place configure .foo]
276    destroy .foo
277    set res
278} [list {-anchor {} {} nw nw} {-bordermode {} {} inside inside} {-height {} {} {} {}} {-in {} {} {} .} {-relheight {} {} {} {}} {-relwidth {} {} {} {}} {-relx {} {} 0 0.0} {-rely {} {} 0 0.0} {-width {} {} {} {}} {-x {} {} 0 0} {-y {} {} 0 0}]
279test place-9.9 {PlaceObjCmd, configure} {
280    catch {destroy .foo}
281    frame .foo
282    place .foo -x 0 -y 0
283    set res [place configure .foo -x]
284    destroy .foo
285    set res
286} [list -x {} {} 0 0]
287test place-9.10 {PlaceObjCmd, forget errors} {
288    catch {destroy .foo}
289    frame .foo
290    set res [list [catch {place forget .foo bar} msg] $msg]
291    destroy .foo
292    set res
293} [list 1 "wrong # args: should be \"place forget pathName\""]
294test place-9.11 {PlaceObjCmd, info errors} {
295    catch {destroy .foo}
296    frame .foo
297    set res [list [catch {place info .foo bar} msg] $msg]
298    destroy .foo
299    set res
300} [list 1 "wrong # args: should be \"place info pathName\""]
301test place-9.12 {PlaceObjCmd, slaves errors} {
302    catch {destroy .foo}
303    frame .foo
304    set res [list [catch {place slaves .foo bar} msg] $msg]
305    destroy .foo
306    set res
307} [list 1 "wrong # args: should be \"place slaves pathName\""]
308    
309test place-10.1 {ConfigureSlave} {
310    catch {destroy .foo}
311    frame .foo
312    set res [list [catch {place .foo -badopt} msg] $msg]
313    destroy .foo
314    set res
315} [list 1 "unknown option \"-badopt\""]
316test place-10.2 {ConfigureSlave} {
317    catch {destroy .foo}
318    frame .foo
319    set res [list [catch {place .foo -anchor} msg] $msg]
320    destroy .foo
321    set res
322} [list 1 "value for \"-anchor\" missing"]
323test place-10.3 {ConfigureSlave} {
324    catch {destroy .foo}
325    frame .foo
326    set res [list [catch {place .foo -bordermode j} msg] $msg]
327    destroy .foo
328    set res
329} [list 1 "bad bordermode \"j\": must be inside, outside, or ignore"]
330test place-10.4 {ConfigureSlave} {
331    catch {destroy .foo}
332    frame .foo
333    set res [list [catch {place configure .foo -x 0 -y} msg] $msg]
334    destroy .foo
335    set res
336} [list 1 "value for \"-y\" missing"]
337	
338test place-11.1 {PlaceObjCmd, slaves command} {
339    catch {destroy .foo}
340    frame .foo
341    set res [place slaves .foo]
342    destroy .foo
343    set res
344} {}
345test place-11.2 {PlaceObjCmd, slaves command} {
346    catch {destroy .foo .bar}
347    frame .foo
348    frame .bar
349    place .bar -in .foo
350    set res [place slaves .foo]
351    destroy .foo
352    destroy .bar
353    set res
354} [list .bar]
355
356test place-12.1 {PlaceObjCmd, forget command} {
357    catch {destroy .foo}
358    frame .foo
359    place .foo -width 50 -height 50
360    update
361    set res [winfo ismapped .foo]
362    place forget .foo
363    update
364    lappend res [winfo ismapped .foo]
365    destroy .foo
366    set res
367} [list 1 0]
368
369test place-13.1 {test respect for internalborder} {
370    toplevel .pack
371    wm geometry .pack 200x200
372    frame .pack.l -width 15 -height 10
373    labelframe .pack.lf -labelwidget .pack.l
374    pack .pack.lf -fill both -expand 1
375    frame .pack.lf.f
376    place .pack.lf.f -x 0 -y 0 -relwidth 1.0 -relheight 1.0
377    update
378    set res [list [winfo geometry .pack.lf.f]]
379    .pack.lf configure -labelanchor e -padx 3 -pady 5
380    update
381    lappend res [winfo geometry .pack.lf.f]
382    destroy .pack
383    set res
384} {196x188+2+10 177x186+5+7}
385
386test place-14.1 {memory leak testing} -setup {
387    proc getbytes {} {
388        set lines [split [memory info] "\n"]
389        lindex [lindex $lines 3] 3
390    }
391    # Repeat each body checking that memory does not increase
392    proc stress {args} {
393        set res {}
394        foreach body $args {
395            set end 0
396            for {set i 0} {$i < 5} {incr i} {
397                uplevel 1 $body
398                set tmp $end
399                set end [getbytes]
400            }
401            lappend res [expr {$end - $tmp}]
402        }
403        return $res
404    }
405} -constraints memory -body {
406    # Test all manners of forgetting a slave
407    frame .f
408    frame .f.f
409    stress {
410        place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}]
411        place forget .f.f
412    } {
413        place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}]
414        pack .f.f
415    } {
416        place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}]
417        destroy .f
418        frame .f
419        frame .f.f
420    }
421} -result {0 0 0} -cleanup {
422    destroy .f
423    rename getbytes {}
424    rename stress {}
425}
426
427catch {destroy .t}
428
429# cleanup
430cleanupTests
431return
432