URL
https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k
[/] [or1k/] [trunk/] [insight/] [tk/] [tests/] [unixEmbed.test] - Rev 578
Go to most recent revision | Compare with Previous | Blame | View Log
# 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.
#
# RCS: @(#) $Id: unixEmbed.test,v 1.1.1.1 2002-01-16 10:26:00 markom Exp $
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}
if {[string compare testembed [info commands testembed]] != 0} {
puts "This application hasn't been compiled with the testembed command,"
puts "therefore I am skipping all of these tests."
return
}
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
Go to most recent revision | Compare with Previous | Blame | View Log