1# This file is a Tcl script to test out the procedures in the file 
2# tkUnixEmbed.c.  It is organized in the standard fashion for Tcl
3# tests.
4#
5# Copyright (c) 1996-1997 Sun Microsystems, Inc.
6# Copyright (c) 1998-1999 by Scriptics Corporation.
7# All rights reserved.
8#
9# RCS: @(#) $Id: unixEmbed.test,v 1.11 2002/07/13 21:52:34 dgp Exp $
10
11package require tcltest 2.1
12namespace import -force tcltest::configure
13namespace import -force tcltest::testsDirectory
14configure -testdir [file join [pwd] [file dirname [info script]]]
15configure -loadfile [file join [testsDirectory] constraints.tcl]
16tcltest::loadTestedCommands
17
18setupbg
19dobg {wm withdraw .}
20
21# eatColors --
22# Creates a toplevel window and allocates enough colors in it to
23# use up all the slots in the colormap.
24#
25# Arguments:
26# w -		Name of toplevel window to create.
27
28proc eatColors {w} {
29    catch {destroy $w}
30    toplevel $w
31    wm geom $w +0+0
32    canvas $w.c -width 400 -height 200 -bd 0
33    pack $w.c
34    for {set y 0} {$y < 8} {incr y} {
35	for {set x 0} {$x < 40} {incr x} {
36	    set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
37	    $w.c create rectangle [expr 10*$x] [expr 20*$y] \
38		    [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
39		    -fill $color
40	}
41    }
42    update
43}
44
45# colorsFree --
46#
47# Returns 1 if there appear to be free colormap entries in a window,
48# 0 otherwise.
49#
50# Arguments:
51# w -			Name of window in which to check.
52# red, green, blue -	Intensities to use in a trial color allocation
53#			to see if there are colormap entries free.
54
55proc colorsFree {w {red 31} {green 245} {blue 192}} {
56    set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
57    expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
58	    && ([lindex $vals 2]/256 == $blue)
59}
60
61test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} unix {
62    catch {destroy .t}
63    list [catch {toplevel .t -use xyz} msg] $msg
64} {1 {expected integer but got "xyz"}}
65test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} unix {
66    catch {destroy .t}
67    list [catch {toplevel .t -use 47} msg] $msg
68} {1 {couldn't create child of window "47"}}
69test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} {unix nonPortable} {
70    catch {destroy .t}
71    catch {destroy .x}
72    toplevel .t -colormap new
73    wm geometry .t +0+0
74    eatColors .t.t
75    frame .t.f -container 1
76    toplevel .x -use [winfo id .t.f]
77    set result [colorsFree .x]
78    destroy .t
79    set result
80} {0}
81test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} {unix nonPortable} {
82    catch {destroy .t}
83    catch {destroy .t2}
84    catch {destroy .x}
85    toplevel .t -container 1 -colormap new
86    wm geometry .t +0+0
87    eatColors .t2
88    toplevel .x -use [winfo id .t]
89    set result [colorsFree .x]
90    destroy .t
91    set result
92} {1}
93
94test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} {unix testembed} {
95    deleteWindows
96    frame .f1 -container 1 -width 200 -height 50
97    frame .f2 -container 1 -width 200 -height 50
98    pack .f1 .f2
99    dobg "set w [winfo id .f1]"
100    dobg {
101	eval destroy [winfo child .]
102	toplevel .t -use $w
103	list [testembed] [expr [lindex [lindex [testembed all] 0] 0] - $w]
104    }
105} {{{XXX {} {} .t}} 0}
106test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} {unix testembed} {
107    deleteWindows
108    frame .f1 -container 1 -width 200 -height 50
109    frame .f2 -container 1 -width 200 -height 50
110    pack .f1 .f2
111    dobg "set w1 [winfo id .f1]"
112    dobg "set w2 [winfo id .f2]"
113    dobg {
114	eval destroy [winfo child .]
115	toplevel .t1 -use $w1
116	toplevel .t2 -use $w2
117	testembed
118    }
119} {{XXX {} {} .t2} {XXX {} {} .t1}}
120test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} {unix testembed} {
121    deleteWindows
122    frame .f1 -container 1 -width 200 -height 50
123    frame .f2 -container 1 -width 200 -height 50
124    pack .f1 .f2
125    toplevel .t1 -use [winfo id .f1]
126    toplevel .t2 -use [winfo id .f2]
127    testembed
128} {{XXX .f2 {} .t2} {XXX .f1 {} .t1}}
129
130# Can't think of any way to test the procedures TkpMakeWindow,
131# TkpMakeContainer, or EmbedErrorProc.
132
133test unixEmbed-2.1 {EmbeddedEventProc procedure} {unix testembed} {
134    deleteWindows
135    frame .f1 -container 1 -width 200 -height 50
136    pack .f1
137    dobg "set w1 [winfo id .f1]"
138    dobg {
139	eval destroy [winfo child .]
140	toplevel .t1 -use $w1
141	testembed
142    }
143    destroy .f1
144    update
145    dobg {
146	testembed
147    }
148} {}
149test unixEmbed-2.2 {EmbeddedEventProc procedure} {unix testembed} {
150    deleteWindows
151    frame .f1 -container 1 -width 200 -height 50
152    pack .f1
153    dobg "set w1 [winfo id .f1]"
154    dobg {
155	eval destroy [winfo child .]
156	toplevel .t1 -use $w1
157	testembed
158	destroy .t1
159	testembed
160    }
161} {}
162test unixEmbed-2.3 {EmbeddedEventProc procedure} {unix testembed} {
163    deleteWindows
164    frame .f1 -container 1 -width 200 -height 50
165    pack .f1
166    toplevel .t1 -use [winfo id .f1]
167    update
168    destroy .f1
169    testembed
170} {}
171test unixEmbed-2.4 {EmbeddedEventProc procedure} {unix testembed} {
172    deleteWindows
173    frame .f1 -container 1 -width 200 -height 50
174    pack .f1
175    toplevel .t1 -use [winfo id .f1]
176    update
177    destroy .t1
178    set x [testembed]
179    update
180    list $x [testembed]
181} {{{XXX .f1 {} {}}} {}}
182
183test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} \
184	{unix testembed nonPortable} {
185    deleteWindows
186    frame .f1 -container 1 -width 200 -height 50
187    pack .f1
188    dobg "set w1 [winfo id .f1]"
189    set x [testembed]
190    dobg {
191	eval destroy [winfo child .]
192	toplevel .t1 -use $w1
193	wm withdraw .t1
194    }
195    list $x [testembed]
196} {{{XXX .f1 {} {}}} {{XXX .f1 XXX {}}}}
197test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} unix {
198    deleteWindows
199    toplevel .t1 -container 1
200    wm geometry .t1 +0+0
201    toplevel .t2 -use [winfo id .t1] -bg red
202    update
203    wm geometry .t2
204} {200x200+0+0}
205test unixEmbed-3.2 {ContainerEventProc procedure, disallow position changes} unix {
206    deleteWindows
207    frame .f1 -container 1 -width 200 -height 50
208    pack .f1
209    dobg "set w1 [winfo id .f1]"
210    dobg {
211	eval destroy [winfo child .]
212	toplevel .t1 -use $w1 -bd 2 -relief raised
213	update
214	wm geometry .t1 +30+40
215    }
216    update
217    dobg {
218	wm geometry .t1
219    }
220} {200x200+0+0}
221test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} unix {
222    deleteWindows
223    frame .f1 -container 1 -width 200 -height 50
224    pack .f1
225    dobg "set w1 [winfo id .f1]"
226    dobg {
227	eval destroy [winfo child .]
228	toplevel .t1 -use $w1
229	update
230	wm geometry .t1 300x100+30+40
231    }
232    update
233    dobg {
234	wm geometry .t1
235    }
236} {300x100+0+0}
237test unixEmbed-3.4 {ContainerEventProc procedure, geometry requests} unix {
238    deleteWindows
239    frame .f1 -container 1 -width 200 -height 50
240    pack .f1
241    dobg "set w1 [winfo id .f1]"
242    dobg {
243	eval destroy [winfo child .]
244	toplevel .t1 -use $w1
245    }
246    update
247    dobg {
248	.t1 configure -width 300 -height 80
249    }
250    update
251    list [winfo width .f1] [winfo height .f1] [dobg {wm geometry .t1}]
252} {300 80 300x80+0+0}
253test unixEmbed-3.5 {ContainerEventProc procedure, map requests} unix {
254    deleteWindows
255    frame .f1 -container 1 -width 200 -height 50
256    pack .f1
257    dobg "set w1 [winfo id .f1]"
258    dobg {
259	eval destroy [winfo child .]
260	toplevel .t1 -use $w1
261	set x unmapped
262	bind .t1 <Map> {set x mapped}
263    }
264    update
265    dobg {
266	after 100
267	update
268	set x
269    }
270} {mapped}
271test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} unix {
272    deleteWindows
273    frame .f1 -container 1 -width 200 -height 50
274    pack .f1
275    dobg "set w1 [winfo id .f1]"
276    bind .f1 <Destroy> {set x dead}
277    set x alive
278    dobg {
279	eval destroy [winfo child .]
280	toplevel .t1 -use $w1
281    }
282    update
283    dobg {
284	destroy .t1
285    }
286    update
287    list $x [winfo exists .f1]
288} {dead 0}
289
290test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} unix {
291    deleteWindows
292    frame .f1 -container 1 -width 200 -height 50
293    pack .f1
294    dobg "set w1 [winfo id .f1]"
295    dobg {
296	eval destroy [winfo child .]
297	toplevel .t1 -use $w1
298    }
299    update
300    dobg {
301	.t1 configure -width 180 -height 100
302    }
303    update
304    dobg {
305	winfo geometry .t1
306    }
307} {180x100+0+0}
308test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} {unix testembed} {
309    deleteWindows
310    frame .f1 -container 1 -width 200 -height 50
311    pack .f1
312    dobg "set w1 [winfo id .f1]"
313    dobg {
314	eval destroy [winfo child .]
315	toplevel .t1 -use $w1
316    }
317    update
318    set x [testembed]
319    destroy .f1
320    list $x [testembed]
321} {{{XXX .f1 XXX {}}} {}}
322
323test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} unix {
324    deleteWindows
325    frame .f1 -container 1 -width 200 -height 50
326    pack .f1
327    dobg "set w1 [winfo id .f1]"
328    dobg {
329	eval destroy [winfo child .]
330	toplevel .t1 -use $w1
331	bind .t1 <FocusIn> {lappend x "focus in %W"}
332	bind .t1 <FocusOut> {lappend x "focus out %W"}
333	set x {}
334    }
335    focus -force .f1
336    update
337    dobg {set x}
338} {{focus in .t1}}
339test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} unix {
340    deleteWindows
341    frame .f1 -container 1 -width 200 -height 50
342    pack .f1
343    dobg "set w1 [winfo id .f1]"
344    dobg {
345	eval destroy [winfo child .]
346	toplevel .t1 -use $w1
347    }
348    update
349    dobg {
350	after 200 {destroy .t1}
351    }
352    after 400
353    focus -force .f1
354    update
355} {}
356test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} unix {
357    deleteWindows
358    frame .f1 -container 1 -width 200 -height 50
359    pack .f1
360    dobg "set w1 [winfo id .f1]"
361    dobg {
362	eval destroy [winfo child .]
363	toplevel .t1 -use $w1
364	bind .t1 <FocusIn> {lappend x "focus in %W"}
365	bind .t1 <FocusOut> {lappend x "focus out %W"}
366	set x {}
367    }
368    focus -force .f1
369    update
370    set x [dobg {update; set x}]
371    focus .
372    update
373    list $x [dobg {update; set x}]
374} {{{focus in .t1}} {{focus in .t1} {focus out .t1}}}
375
376test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} unix {
377    deleteWindows
378    frame .f1 -container 1 -width 200 -height 50
379    pack .f1
380    dobg "set w1 [winfo id .f1]"
381    dobg {
382	eval destroy [winfo child .]
383	toplevel .t1 -use $w1
384    }
385    update
386    dobg {
387	bind .t1 <Configure> {lappend x {configure .t1 %w %h}}
388	set x {}
389	.t1 configure -width 300 -height 120
390	update
391	list $x [winfo geom .t1]
392    }
393} {{{configure .t1 300 120}} 300x120+0+0}
394test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} unix {
395    deleteWindows
396    frame .f1 -container 1 -width 200 -height 50
397    place .f1 -width 200 -height 200
398    dobg "set w1 [winfo id .f1]"
399    dobg {
400	eval destroy [winfo child .]
401	toplevel .t1 -use $w1
402    }
403    after 300 {set x done}
404    vwait x
405    dobg {
406	bind .t1 <Configure> {lappend x {configure .t1 %w %h}}
407	set x {}
408	.t1 configure -width 300 -height 120
409	update
410	list $x [winfo geom .t1]
411    }
412} {{{configure .t1 200 200}} 200x200+0+0}
413
414# Can't think up any tests for TkpGetOtherWindow procedure.
415
416test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} unix {
417    deleteWindows
418    frame .f1 -container 1 -width 200 -height 50
419    pack .f1
420    dobg "set w1 [winfo id .f1]"
421    dobg {
422	eval destroy [winfo child .]
423	toplevel .t1 -use $w1
424    }
425    focus -force .
426    bind . <KeyPress> {lappend x {key %A %E}}
427    set x {}
428    set y [dobg {
429	update
430	bind .t1 <KeyPress> {lappend y {key %A}}
431	set y {}
432	event generate .t1 <KeyPress> -keysym a
433	set y
434    }]
435    update
436    bind . <KeyPress> {}
437    list $x $y
438} {{{key a 1}} {}}
439test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} unix {
440    deleteWindows
441    frame .f1 -container 1 -width 200 -height 50
442    pack .f1
443    dobg "set w1 [winfo id .f1]"
444    dobg {
445	eval destroy [winfo child .]
446	toplevel .t1 -use $w1
447    }
448    update
449    focus -force .f1
450    update
451    bind . <KeyPress> {lappend x {key %A}}
452    set x {}
453    set y [dobg {
454	update
455	bind .t1 <KeyPress> {lappend y {key %A}}
456	set y {}
457	event generate .t1 <KeyPress> -keysym b
458	set y
459    }]
460    update
461    bind . <KeyPress> {}
462    list $x $y
463} {{} {{key b}}}
464
465test unixEmbed-8.1 {TkpClaimFocus procedure} unix {
466    deleteWindows
467    frame .f1 -container 1 -width 200 -height 50
468    frame .f2 -width 200 -height 50
469    pack .f1 .f2
470    dobg "set w1 [winfo id .f1]"
471    dobg {
472	eval destroy [winfo child .]
473	toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken
474    }
475    focus -force .f2
476    update
477    list [dobg {
478	focus .t1
479	set x [list [focus]]
480	update
481	after 500
482	update
483	lappend x [focus]
484    }] [focus]
485} {{{} .t1} .f1}
486test unixEmbed-8.2 {TkpClaimFocus procedure} unix {
487    catch {interp delete child}
488    deleteWindows
489    frame .f1 -container 1 -width 200 -height 50
490    frame .f2 -width 200 -height 50
491    pack .f1 .f2
492    interp create child
493    child eval "set argv {-use [winfo id .f1]}"
494    load {} Tk child
495    child eval {
496	. configure -bd 2 -highlightthickness 2 -relief sunken
497    }
498    focus -force .f2
499    update
500    list [child eval {
501	focus .
502	set x [list [focus]]
503	update
504	lappend x [focus]
505    }] [focus]
506} {{{} .} .f1}
507catch {interp delete child}
508
509test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} {unix testembed} {
510    deleteWindows
511    frame .f1 -container 1 -width 200 -height 50
512    frame .f2 -container 1 -width 200 -height 50
513    frame .f3 -container 1 -width 200 -height 50
514    frame .f4 -container 1 -width 200 -height 50
515    pack .f1 .f2 .f3 .f4
516    set x {}
517    lappend x [testembed]
518    foreach w {.f3 .f4 .f1 .f2} {
519	destroy $w
520	lappend x [testembed]
521    }
522    set x
523} {{{XXX .f4 {} {}} {XXX .f3 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f4 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}}} {}}
524test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} {unix testembed} {
525    deleteWindows
526    frame .f1 -container 1 -width 200 -height 50
527    pack .f1
528    dobg "set w1 [winfo id .f1]"
529    dobg {
530	eval destroy [winfo child .]
531	toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken
532	set x {}
533	lappend x [testembed]
534	destroy .t1
535	lappend x [testembed]
536    }
537} {{{XXX {} {} .t1}} {}}
538
539test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix {
540    deleteWindows
541    frame .f1 -container 1 -width 200 -height 50
542    pack .f1
543    toplevel .t1 -use [winfo id .f1] -width 150 -height 80
544    update
545    wm geometry .t1 +40+50
546    update
547    wm geometry .t1
548} {150x80+0+0}
549test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix {
550    deleteWindows
551    frame .f1 -container 1 -width 200 -height 50
552    pack .f1
553    toplevel .t1 -use [winfo id .f1] -width 150 -height 80
554    update
555    wm geometry .t1 70x300+10+20
556    update
557    wm geometry .t1
558} {70x300+0+0}
559
560# cleanup
561deleteWindows
562cleanupbg
563::tcltest::cleanupTests
564return
565
566
567
568
569
570
571
572
573
574
575
576
577
578