# 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. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: unixEmbed.test,v 1.1.1.1 2007/07/10 15:05:18 duncan Exp $ package require tcltest 2.1 namespace import -force tcltest::configure namespace import -force tcltest::testsDirectory configure -testdir [file join [pwd] [file dirname [info script]]] configure -loadfile [file join [testsDirectory] constraints.tcl] tcltest::loadTestedCommands 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} unix { 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} unix { 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} {unix nonPortable} { 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} {unix nonPortable} { 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} {unix testembed} { deleteWindows 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} {unix testembed} { deleteWindows 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} {unix testembed} { deleteWindows 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} {unix testembed} { deleteWindows 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} {unix testembed} { deleteWindows 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} {unix testembed} { deleteWindows 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} {unix testembed} { deleteWindows 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} \ {unix testembed nonPortable} { deleteWindows 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} unix { deleteWindows 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} unix { deleteWindows 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} unix { deleteWindows 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} unix { deleteWindows 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} unix { deleteWindows 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 {set x mapped} } update dobg { after 100 update set x } } {mapped} test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} unix { deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" bind .f1 {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} unix { deleteWindows 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} {unix testembed} { deleteWindows 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} unix { deleteWindows 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 {lappend x "focus in %W"} bind .t1 {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} unix { deleteWindows 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} unix { deleteWindows 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 {lappend x "focus in %W"} bind .t1 {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} unix { deleteWindows 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 {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} unix { deleteWindows 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 {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} unix { deleteWindows 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 . {lappend x {key %A %E}} set x {} set y [dobg { update bind .t1 {lappend y {key %A}} set y {} event generate .t1 -keysym a set y }] update bind . {} list $x $y } {{{key a 1}} {}} test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} unix { deleteWindows 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 . {lappend x {key %A}} set x {} set y [dobg { update bind .t1 {lappend y {key %A}} set y {} event generate .t1 -keysym b set y }] update bind . {} list $x $y } {{} {{key b}}} test unixEmbed-8.1 {TkpClaimFocus procedure} unix { deleteWindows 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} unix { catch {interp delete child} deleteWindows 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} {unix testembed} { deleteWindows 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} {unix testembed} { deleteWindows 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} unix { deleteWindows 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} unix { deleteWindows 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} # cleanup deleteWindows cleanupbg ::tcltest::cleanupTests return