diff options
Diffstat (limited to 'tests/unixEmbed.test')
| -rw-r--r-- | tests/unixEmbed.test | 620 |
1 files changed, 620 insertions, 0 deletions
diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test new file mode 100644 index 0000000..ef8ecb9 --- /dev/null +++ b/tests/unixEmbed.test @@ -0,0 +1,620 @@ +# This file is a Tcl script to test out the procedures in the file +# tkUnixEmbed.c. It is organized in the standard fashion for Tcl +# tests. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) unixEmbed.test 1.7 97/08/13 11:13:21 + +if {$tcl_platform(platform) != "unix"} { + return +} + +if {[info procs test] != "test"} { + source defs +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + +setupbg +dobg {wm withdraw .} + +# eatColors -- +# Creates a toplevel window and allocates enough colors in it to +# use up all the slots in the colormap. +# +# Arguments: +# w - Name of toplevel window to create. + +proc eatColors {w} { + catch {destroy $w} + toplevel $w + wm geom $w +0+0 + canvas $w.c -width 400 -height 200 -bd 0 + pack $w.c + for {set y 0} {$y < 8} {incr y} { + for {set x 0} {$x < 40} {incr x} { + set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] + $w.c create rectangle [expr 10*$x] [expr 20*$y] \ + [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ + -fill $color + } + } + update +} + +# colorsFree -- +# +# Returns 1 if there appear to be free colormap entries in a window, +# 0 otherwise. +# +# Arguments: +# w - Name of window in which to check. +# red, green, blue - Intensities to use in a trial color allocation +# to see if there are colormap entries free. + +proc colorsFree {w {red 31} {green 245} {blue 192}} { + set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] + expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ + && ([lindex $vals 2]/256 == $blue) +} + +test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} { + catch {destroy .t} + list [catch {toplevel .t -use xyz} msg] $msg +} {1 {expected integer but got "xyz"}} +test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} { + catch {destroy .t} + list [catch {toplevel .t -use 47} msg] $msg +} {1 {couldn't create child of window "47"}} +test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} { + catch {destroy .t} + catch {destroy .x} + toplevel .t -colormap new + wm geometry .t +0+0 + eatColors .t.t + frame .t.f -container 1 + toplevel .x -use [winfo id .t.f] + set result [colorsFree .x] + destroy .t + set result +} {0} +test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} { + catch {destroy .t} + catch {destroy .t2} + catch {destroy .x} + toplevel .t -container 1 -colormap new + wm geometry .t +0+0 + eatColors .t2 + toplevel .x -use [winfo id .t] + set result [colorsFree .x] + destroy .t + set result +} {1} +test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} { + eval destroy [winfo child .] + frame .f1 -container 1 -width 200 -height 50 + frame .f2 -container 1 -width 200 -height 50 + pack .f1 .f2 + dobg "set w [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t -use $w + list [testembed] [expr [lindex [lindex [testembed all] 0] 0] - $w] + } +} {{{XXX {} {} .t}} 0} +test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} { + eval destroy [winfo child .] + frame .f1 -container 1 -width 200 -height 50 + frame .f2 -container 1 -width 200 -height 50 + pack .f1 .f2 + dobg "set w1 [winfo id .f1]" + dobg "set w2 [winfo id .f2]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + toplevel .t2 -use $w2 + testembed + } +} {{XXX {} {} .t2} {XXX {} {} .t1}} +test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} { + eval destroy [winfo child .] + frame .f1 -container 1 -width 200 -height 50 + frame .f2 -container 1 -width 200 -height 50 + pack .f1 .f2 + toplevel .t1 -use [winfo id .f1] + toplevel .t2 -use [winfo id .f2] + testembed +} {{XXX .f2 {} .t2} {XXX .f1 {} .t1}} + +# Can't think of any way to test the procedures TkpMakeWindow, +# TkpMakeContainer, or EmbedErrorProc. + +test unixEmbed-2.1 {EmbeddedEventProc procedure} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + testembed + } + destroy .f1 + update + dobg { + testembed + } +} {} +test unixEmbed-2.2 {EmbeddedEventProc procedure} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + testembed + destroy .t1 + testembed + } +} {} +test unixEmbed-2.3 {EmbeddedEventProc procedure} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + toplevel .t1 -use [winfo id .f1] + update + destroy .f1 + testembed +} {} +test unixEmbed-2.4 {EmbeddedEventProc procedure} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + toplevel .t1 -use [winfo id .f1] + update + destroy .t1 + set x [testembed] + update + list $x [testembed] +} {{{XXX .f1 {} {}}} {}} + +test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + set x [testembed] + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + wm withdraw .t1 + } + list $x [testembed] +} {{{XXX .f1 {} {}}} {{XXX .f1 XXX {}}}} +test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} { + foreach w [winfo child .] { + catch {destroy $w} + } + toplevel .t1 -container 1 + wm geometry .t1 +0+0 + toplevel .t2 -use [winfo id .t1] -bg red + update + wm geometry .t2 +} {200x200+0+0} +test unixEmbed-3.2 {ContainerEventProc procedure, disallow position changes} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 -bd 2 -relief raised + update + wm geometry .t1 +30+40 + } + update + dobg { + wm geometry .t1 + } +} {200x200+0+0} +test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + update + wm geometry .t1 300x100+30+40 + } + update + dobg { + wm geometry .t1 + } +} {300x100+0+0} +test unixEmbed-3.4 {ContainerEventProc procedure, geometry requests} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + update + dobg { + .t1 configure -width 300 -height 80 + } + update + list [winfo width .f1] [winfo height .f1] [dobg {wm geometry .t1}] +} {300 80 300x80+0+0} +test unixEmbed-3.5 {ContainerEventProc procedure, map requests} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + set x unmapped + bind .t1 <Map> {set x mapped} + } + update + dobg { + after 100 + update + set x + } +} {mapped} +test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + bind .f1 <Destroy> {set x dead} + set x alive + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + update + dobg { + destroy .t1 + } + update + list $x [winfo exists .f1] +} {dead 0} + +test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + update + dobg { + .t1 configure -width 180 -height 100 + } + update + dobg { + winfo geometry .t1 + } +} {180x100+0+0} +test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + update + set x [testembed] + destroy .f1 + list $x [testembed] +} {{{XXX .f1 XXX {}}} {}} + +test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + bind .t1 <FocusIn> {lappend x "focus in %W"} + bind .t1 <FocusOut> {lappend x "focus out %W"} + set x {} + } + focus -force .f1 + update + dobg {set x} +} {{focus in .t1}} +test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + update + dobg { + after 200 {destroy .t1} + } + after 400 + focus -force .f1 + update +} {} +test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + bind .t1 <FocusIn> {lappend x "focus in %W"} + bind .t1 <FocusOut> {lappend x "focus out %W"} + set x {} + } + focus -force .f1 + update + set x [dobg {update; set x}] + focus . + update + list $x [dobg {update; set x}] +} {{{focus in .t1}} {{focus in .t1} {focus out .t1}}} + +test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + update + dobg { + bind .t1 <Configure> {lappend x {configure .t1 %w %h}} + set x {} + .t1 configure -width 300 -height 120 + update + list $x [winfo geom .t1] + } +} {{{configure .t1 300 120}} 300x120+0+0} +test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + place .f1 -width 200 -height 200 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + after 300 {set x done} + vwait x + dobg { + bind .t1 <Configure> {lappend x {configure .t1 %w %h}} + set x {} + .t1 configure -width 300 -height 120 + update + list $x [winfo geom .t1] + } +} {{{configure .t1 200 200}} 200x200+0+0} + +# Can't think up any tests for TkpGetOtherWindow procedure. + +test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + focus -force . + bind . <KeyPress> {lappend x {key %A %E}} + set x {} + set y [dobg { + update + bind .t1 <KeyPress> {lappend y {key %A}} + set y {} + event generate .t1 <KeyPress> -keysym a + set y + }] + update + bind . <KeyPress> {} + list $x $y +} {{{key a 1}} {}} +test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 + } + update + focus -force .f1 + update + bind . <KeyPress> {lappend x {key %A}} + set x {} + set y [dobg { + update + bind .t1 <KeyPress> {lappend y {key %A}} + set y {} + event generate .t1 <KeyPress> -keysym b + set y + }] + update + bind . <KeyPress> {} + list $x $y +} {{} {{key b}}} + +test unixEmbed-8.1 {TkpClaimFocus procedure} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + frame .f2 -width 200 -height 50 + pack .f1 .f2 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken + } + focus -force .f2 + update + list [dobg { + focus .t1 + set x [list [focus]] + update + after 500 + update + lappend x [focus] + }] [focus] +} {{{} .t1} .f1} +test unixEmbed-8.2 {TkpClaimFocus procedure} { + catch {interp delete child} + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + frame .f2 -width 200 -height 50 + pack .f1 .f2 + interp create child + child eval "set argv {-use [winfo id .f1]}" + load {} tk child + child eval { + . configure -bd 2 -highlightthickness 2 -relief sunken + } + focus -force .f2 + update + list [child eval { + focus . + set x [list [focus]] + update + lappend x [focus] + }] [focus] +} {{{} .} .f1} +catch {interp delete child} + +test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + frame .f2 -container 1 -width 200 -height 50 + frame .f3 -container 1 -width 200 -height 50 + frame .f4 -container 1 -width 200 -height 50 + pack .f1 .f2 .f3 .f4 + set x {} + lappend x [testembed] + foreach w {.f3 .f4 .f1 .f2} { + destroy $w + lappend x [testembed] + } + set x +} {{{XXX .f4 {} {}} {XXX .f3 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f4 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}}} {}} +test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + dobg "set w1 [winfo id .f1]" + dobg { + eval destroy [winfo child .] + toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken + set x {} + lappend x [testembed] + destroy .t1 + lappend x [testembed] + } +} {{{XXX {} {} .t1}} {}} + +test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + toplevel .t1 -use [winfo id .f1] -width 150 -height 80 + update + wm geometry .t1 +40+50 + update + wm geometry .t1 +} {150x80+0+0} +test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} { + foreach w [winfo child .] { + catch {destroy $w} + } + frame .f1 -container 1 -width 200 -height 50 + pack .f1 + toplevel .t1 -use [winfo id .f1] -width 150 -height 80 + update + wm geometry .t1 70x300+10+20 + update + wm geometry .t1 +} {70x300+0+0} + + +foreach w [winfo child .] { + catch {destroy $w} +} +cleanupbg |