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