path: root/tk8.6/tests/unixEmbed.test

# 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.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test

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} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    toplevel .t -use xyz
} -returnCodes error -result {expected integer but got "xyz"}
test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    toplevel .t -use 47
} -returnCodes error -result {couldn't create child of window "47"}
test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} -constraints {
	unix nonPortable
} -setup {
	deleteWindows
} -body {
    toplevel .t -colormap new
    wm geometry .t +0+0
    eatColors .t.t
    frame .t.f -container 1
    toplevel .x -use [winfo id .t.f]
    colorsFree .x
} -cleanup {
	deleteWindows
} -result {0}
test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} -constraints {
	unix nonPortable
} -setup {
	deleteWindows
} -body {
    toplevel .t -container 1 -colormap new
    wm geometry .t +0+0
    eatColors .t2
    toplevel .x -use [winfo id .t]
    colorsFree .x
} -cleanup {
	deleteWindows
} -result {1}

test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} -constraints {
	unix testembed
} -setup {
	deleteWindows
} -body {
    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]
    }
} -cleanup {
	deleteWindows
} -result {{{XXX {} {} .t}} 0}
test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} -constraints {
	unix testembed
} -setup {
	deleteWindows
} -body {
    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
    }
} -cleanup {
	deleteWindows
} -result {{XXX {} {} .t2} {XXX {} {} .t1}}
test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} -constraints {
	unix testembed
} -setup {
	deleteWindows
} -body {
    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
} -cleanup {
	deleteWindows
} -result {{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} -constraints {
	unix testembed
} -setup {
	deleteWindows
} -body {
    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
    }
} -cleanup {
	deleteWindows
} -result {}
test unixEmbed-2.2 {EmbeddedEventProc procedure} -constraints {
	unix testembed
} -setup {
	deleteWindows
} -body {
    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
    }
} -cleanup {
	deleteWindows
} -result {}
test unixEmbed-2.3 {EmbeddedEventProc procedure} -constraints {
	unix testembed
} -setup {
	deleteWindows
} -body {
    frame .f1 -container 1 -width 200 -height 50
    pack .f1
    toplevel .t1 -use [winfo id .f1]
    update
    destroy .f1
    testembed
} -result {}
test unixEmbed-2.4 {EmbeddedEventProc procedure} -constraints {
	unix testembed
} -setup {
	deleteWindows
} -body {
    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]
} -cleanup {
	deleteWindows
} -result {{{XXX .f1 {} {}}} {}}


test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} -constraints {
    unix testembed nonPortable
} -body {
    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]
} -cleanup {
	deleteWindows
} -result {{{XXX .f1 {} {}}} {{XXX .f1 XXX {}}}}
test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    toplevel .t1 -container 1
    wm geometry .t1 +0+0
    toplevel .t2 -use [winfo id .t1] -bg red
    update
    wm geometry .t2
} -cleanup {
	deleteWindows
} -result {200x200+0+0}
test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    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
    }
} -cleanup {
	deleteWindows
} -result {200x200+0+0}
test unixEmbed-3.4 {ContainerEventProc procedure, disallow position changes} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    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
    }
} -cleanup {
	deleteWindows
} -result {300x100+0+0}
test unixEmbed-3.5 {ContainerEventProc procedure, geometry requests} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    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}]
} -cleanup {
	deleteWindows
} -result {300 80 300x80+0+0}
test unixEmbed-3.6 {ContainerEventProc procedure, map requests} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    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
    }
} -cleanup {
	deleteWindows
} -result {mapped}
test unixEmbed-3.7 {ContainerEventProc procedure, destroy events} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    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]
} -cleanup {
	deleteWindows
} -result {dead 0}


test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    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
    }
} -cleanup {
	deleteWindows
} -result {180x100+0+0}
test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} -constraints {
	unix testembed
} -setup {
	deleteWindows
} -body {
    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]
} -cleanup {
	deleteWindows
} -result {{{XXX .f1 XXX {}}} {}}


test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    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}
} -cleanup {
	deleteWindows
} -result {{focus in .t1}}
test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    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
} -cleanup {
	deleteWindows
} -result {}
test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    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}]
} -cleanup {
	deleteWindows
} -result {{{focus in .t1}} {{focus in .t1} {focus out .t1}}}


test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    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]
    }
} -cleanup {
	deleteWindows
} -result {{{configure .t1 300 120}} 300x120+0+0}
test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    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]
    }
} -cleanup {
	deleteWindows
} -result {{{configure .t1 200 200}} 200x200+0+0}

# Can't think up any tests for TkpGetOtherWindow procedure.


test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    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 . <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
    list $x $y
} -cleanup {
	deleteWindows
    bind . <KeyPress> {}
} -result {{{key a 1}} {}}
test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    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
    list $x $y
} -cleanup {
	deleteWindows
    bind . <KeyPress> {}
} -result {{} {{key b}}}


test unixEmbed-8.1 {TkpClaimFocus procedure} -constraints unix -setup {
	deleteWindows
} -body {
    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]
} -cleanup {
	deleteWindows
} -result {{{} .t1} .f1}
test unixEmbed-8.2 {TkpClaimFocus procedure} -constraints unix -setup {
	deleteWindows
    catch {interp delete child}
    deleteWindows
} -body {
    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]
} -cleanup {
	deleteWindows
} -result {{{} .} .f1}
catch {interp delete child}


test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} -constraints {
	unix testembed
} -setup {
	deleteWindows
} -body {
    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
} -cleanup {
	deleteWindows
} -result {{{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} -constraints {
	unix testembed
} -setup {
	deleteWindows
} -body {
    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]
    }
} -cleanup {
	deleteWindows
} -result {{{XXX {} {} .t1}} {}}


test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    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
} -cleanup {
	deleteWindows
} -result {150x80+0+0}
test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} -constraints {
	unix 
} -setup {
	deleteWindows
} -body {
    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
} -cleanup {
	deleteWindows
} -result {70x300+0+0}

# cleanup
deleteWindows
cleanupbg
cleanupTests
return