URL
https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k
[/] [or1k/] [trunk/] [insight/] [tk/] [tests/] [unixWm.test] - Rev 1765
Compare with Previous | Blame | View Log
# This file is a Tcl script to test out Tk's interactions with
# the window manager, including the "wm" command. It is organized
# in the standard fashion for Tcl tests.
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-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: unixWm.test,v 1.1.1.1 2002-01-16 10:26:00 markom Exp $
if {$tcl_platform(platform) != "unix"} {
return
}
if {[string compare test [info procs test]] == 1} {
source defs
}
proc sleep ms {
global x
after $ms {set x 1}
vwait x
}
# Procedure to set up a collection of top-level windows
proc makeToplevels {} {
foreach i [winfo child .] {
destroy $i
}
foreach i {.raise1 .raise2 .raise3} {
toplevel $i
wm geom $i 150x100+0+0
update
}
}
set i 1
foreach geom {+20+80 +80+20 +0+0} {
catch {destroy .t}
test unixWm-1.$i {initial window position} {
toplevel .t -width 200 -height 150
wm geom .t $geom
update
wm geom .t
} 200x150$geom
incr i
}
# The tests below are tricky because window managers don't all move
# windows correctly. Try one motion and compute the window manager's
# error, then factor this error into the actual tests. In other words,
# this just makes sure that things are consistent between moves.
set i 1
catch {destroy .t}
toplevel .t -width 100 -height 150
wm geom .t +200+200
update
wm geom .t +150+150
update
scan [wm geom .t] %dx%d+%d+%d width height x y
set xerr [expr 150-$x]
set yerr [expr 150-$y]
foreach geom {+20+80 +80+20 +0+0 -0-0 +0-0 -0+0 -10-5 -10+5 +10-5} {
test unixWm-2.$i {moving window while mapped} {
wm geom .t $geom
update
scan [wm geom .t] %dx%d%1s%d%1s%d width height xsign x ysign y
format "%s%d%s%d" $xsign [eval expr $x$xsign$xerr] $ysign \
[eval expr $y$ysign$yerr]
} $geom
incr i
}
set i 1
foreach geom {+20+80 +80+20 +0+0 -0-0 +0-0 -0+0 -10-5 -10+5 +10-5} {
test unixWm-3.$i {moving window while iconified} {
wm iconify .t
sleep 200
wm geom .t $geom
update
wm deiconify .t
scan [wm geom .t] %dx%d%1s%d%1s%d width height xsign x ysign y
format "%s%d%s%d" $xsign [eval expr $x$xsign$xerr] $ysign \
[eval expr $y$ysign$yerr]
} $geom
incr i
}
set i 1
foreach geom {+20+80 +100+40 +0+0} {
test unixWm-4.$i {moving window while withdrawn} {
wm withdraw .t
sleep 200
wm geom .t $geom
update
wm deiconify .t
wm geom .t
} 100x150$geom
incr i
}
test unixWm-5.1 {compounded state changes} {nonPortable} {
catch {destroy .t}
toplevel .t -width 200 -height 100
wm geometry .t +100+100
update
wm withdraw .t
wm deiconify .t
list [winfo ismapped .t] [wm state .t]
} {1 normal}
test unixWm-5.2 {compounded state changes} {nonPortable} {
catch {destroy .t}
toplevel .t -width 200 -height 100
wm geometry .t +100+100
update
wm withdraw .t
wm deiconify .t
wm withdraw .t
list [winfo ismapped .t] [wm state .t]
} {0 withdrawn}
test unixWm-5.3 {compounded state changes} {nonPortable} {
catch {destroy .t}
toplevel .t -width 200 -height 100
wm geometry .t +100+100
update
wm iconify .t
wm deiconify .t
wm iconify .t
wm deiconify .t
list [winfo ismapped .t] [wm state .t]
} {1 normal}
test unixWm-5.4 {compounded state changes} {nonPortable} {
catch {destroy .t}
toplevel .t -width 200 -height 100
wm geometry .t +100+100
update
wm iconify .t
wm deiconify .t
wm iconify .t
list [winfo ismapped .t] [wm state .t]
} {0 iconic}
test unixWm-5.5 {compounded state changes} {nonPortable} {
catch {destroy .t}
toplevel .t -width 200 -height 100
wm geometry .t +100+100
update
wm iconify .t
wm withdraw .t
list [winfo ismapped .t] [wm state .t]
} {0 withdrawn}
test unixWm-5.6 {compounded state changes} {nonPortable} {
catch {destroy .t}
toplevel .t -width 200 -height 100
wm geometry .t +100+100
update
wm iconify .t
wm withdraw .t
wm deiconify .t
list [winfo ismapped .t] [wm state .t]
} {1 normal}
test unixWm-5.7 {compounded state changes} {nonPortable} {
catch {destroy .t}
toplevel .t -width 200 -height 100
wm geometry .t +100+100
update
wm withdraw .t
wm iconify .t
list [winfo ismapped .t] [wm state .t]
} {0 iconic}
catch {destroy .t}
toplevel .t -width 200 -height 100
wm geom .t +10+10
wm minsize .t 1 1
update
test unixWm-6.1 {size changes} {
.t config -width 180 -height 150
update
wm geom .t
} 180x150+10+10
test unixWm-6.2 {size changes} {
wm geom .t 250x60
.t config -width 170 -height 140
update
wm geom .t
} 250x60+10+10
test unixWm-6.3 {size changes} {
wm geom .t 250x60
.t config -width 170 -height 140
wm geom .t {}
update
wm geom .t
} 170x140+10+10
test unixWm-6.4 {size changes} {nonPortable} {
wm minsize .t 1 1
update
puts stdout "Please resize window \"t\" with the mouse (but don't move it!),"
puts -nonewline stdout "then hit return: "
flush stdout
gets stdin
update
set width [winfo width .t]
set height [winfo height .t]
.t config -width 230 -height 110
update
incr width -[winfo width .t]
incr height -[winfo height .t]
wm geom .t {}
update
set w2 [winfo width .t]
set h2 [winfo height .t]
.t config -width 114 -height 261
update
list $width $height $w2 $h2 [wm geom .t]
} {0 0 230 110 114x261+10+10}
# I don't know why the wait below is needed, but without it the test
# fails under twm.
sleep 200
test unixWm-6.5 {window initially iconic} {nonPortable} {
catch {destroy .t}
toplevel .t -width 100 -height 30
wm geometry .t +0+0
wm title .t 2
wm iconify .t
update idletasks
wm withdraw .t
wm deiconify .t
list [winfo ismapped .t] [wm state .t]
} {1 normal}
catch {destroy .m}
toplevel .m
wm overrideredirect .m 1
foreach i {{Test label} Another {Yet another} {Last label}} j {1 2 3} {
label .m.$j -text $i
}
wm geometry .m +[expr 100 - [winfo vrootx .]]+[expr 200 - [winfo vrooty .]]
update
test unixWm-7.1 {override_redirect and Tk_MoveTopLevelWindow} {
list [winfo ismapped .m] [wm state .m] [winfo x .m] [winfo y .m]
} {1 normal 100 200}
wm geometry .m +[expr 150 - [winfo vrootx .]]+[expr 210 - [winfo vrooty .]]
update
test unixWm-7.2 {override_redirect and Tk_MoveTopLevelWindow} {
list [winfo ismapped .m] [wm state .m] [winfo x .m] [winfo y .m]
} {1 normal 150 210}
wm withdraw .m
test unixWm-7.3 {override_redirect and Tk_MoveTopLevelWindow} {
list [winfo ismapped .m]
} 0
destroy .m
catch {destroy .t}
test unixWm-8.1 {icon windows} {
catch {destroy .t}
catch {destroy .icon}
toplevel .t -width 100 -height 30
wm geometry .t +0+0
toplevel .icon -width 50 -height 50 -bg red
wm iconwindow .t .icon
list [catch {wm withdraw .icon} msg] $msg
} {1 {can't withdraw .icon: it is an icon for .t}}
test unixWm-8.2 {icon windows} {
catch {destroy .t}
toplevel .t -width 100 -height 30
list [catch {wm iconwindow} msg] $msg
} {1 {wrong # args: should be "wm option window ?arg ...?"}}
test unixWm-8.3 {icon windows} {
catch {destroy .t}
toplevel .t -width 100 -height 30
list [catch {wm iconwindow .t b c} msg] $msg
} {1 {wrong # arguments: must be "wm iconwindow window ?pathName?"}}
test unixWm-8.4 {icon windows} {
catch {destroy .t}
catch {destroy .icon}
toplevel .t -width 100 -height 30
wm geom .t +0+0
set result [wm iconwindow .t]
toplevel .icon -width 50 -height 50 -bg red
wm iconwindow .t .icon
lappend result [wm iconwindow .t] [wm state .icon]
wm iconwindow .t {}
lappend result [wm iconwindow .t] [wm state .icon]
update
lappend result [winfo ismapped .t] [winfo ismapped .icon]
wm iconify .t
update
lappend result [winfo ismapped .t] [winfo ismapped .icon]
} {.icon icon {} withdrawn 1 0 0 0}
test unixWm-8.5 {icon windows} {
catch {destroy .t}
toplevel .t -width 100 -height 30
list [catch {wm iconwindow .t .gorp} msg] $msg
} {1 {bad window path name ".gorp"}}
test unixWm-8.6 {icon windows} {
catch {destroy .t}
toplevel .t -width 100 -height 30
frame .t.icon -width 50 -height 50 -bg red
list [catch {wm iconwindow .t .t.icon} msg] $msg
} {1 {can't use .t.icon as icon window: not at top level}}
test unixWm-8.7 {icon windows} {
catch {destroy .t}
catch {destroy .icon}
toplevel .t -width 100 -height 30
wm geom .t +0+0
toplevel .icon -width 50 -height 50 -bg red
toplevel .icon2 -width 50 -height 50 -bg green
wm iconwindow .t .icon
set result "[wm iconwindow .t] [wm state .icon] [wm state .icon2]"
wm iconwindow .t .icon2
lappend result [wm iconwindow .t] [wm state .icon] [wm state .icon2]
} {.icon icon normal .icon2 withdrawn icon}
catch {destroy .icon2}
test unixWm-8.8 {icon windows} {
catch {destroy .t}
catch {destroy .icon}
toplevel .icon -width 50 -height 50 -bg red
wm geom .icon +0+0
update
set result [winfo ismapped .icon]
toplevel .t -width 100 -height 30
wm geom .t +0+0
tkwait visibility .t ;# Needed to keep tvtwm happy.
wm iconwindow .t .icon
sleep 500
lappend result [winfo ismapped .t] [winfo ismapped .icon]
} {1 1 0}
test unixWm-8.9 {icon windows} {nonPortable} {
# This test is non-portable because some window managers will
# destroy an icon window when it's associated window is destroyed.
catch {destroy .t}
catch {destroy .icon}
toplevel .t -width 100 -height 30
toplevel .icon -width 50 -height 50 -bg red
wm geom .t +0+0
wm iconwindow .t .icon
update
set result "[wm state .icon] [winfo ismapped .t] [winfo ismapped .icon]"
destroy .t
wm geom .icon +0+0
update
lappend result [winfo ismapped .icon] [wm state .icon]
wm deiconify .icon
update
lappend result [winfo ismapped .icon] [wm state .icon]
} {icon 1 0 0 withdrawn 1 normal}
if {[string compare testwrapper [info commands testwrapper]] != 0} {
puts "This application hasn't been compiled with the testwrapper command,"
puts "therefore I am skipping all of these tests."
return
}
test unixWm-9.1 {TkWmMapWindow procedure, client property} {unixOnly} {
catch {destroy .t}
toplevel .t -width 100 -height 50
wm geom .t +0+0
wm client .t Test_String
update
testprop [testwrapper .t] WM_CLIENT_MACHINE
} {Test_String}
test unixWm-9.2 {TkWmMapWindow procedure, command property} {unixOnly} {
catch {destroy .t}
toplevel .t -width 100 -height 50
wm geom .t +0+0
wm command .t "test command"
update
testprop [testwrapper .t] WM_COMMAND
} {test
command
}
test unixWm-9.3 {TkWmMapWindow procedure, iconic windows} {
catch {destroy .t}
toplevel .t -width 100 -height 300 -bg blue
wm geom .t +0+0
wm iconify .t
sleep 500
winfo ismapped .t
} {0}
test unixWm-9.4 {TkWmMapWindow procedure, icon windows} {
catch {destroy .t}
sleep 500
toplevel .t -width 100 -height 50 -bg blue
wm iconwindow . .t
update
set result [winfo ismapped .t]
} {0}
test unixWm-9.5 {TkWmMapWindow procedure, normal windows} {
catch {destroy .t}
toplevel .t -width 200 -height 20
wm geom .t +0+0
update
winfo ismapped .t
} {1}
test unixWm-10.1 {TkWmDeadWindow procedure, canceling UpdateGeometry idle handler} {
catch {destroy .t}
toplevel .t -width 100 -height 50
wm geom .t +0+0
update
.t configure -width 200 -height 100
destroy .t
} {}
test unixWm-10.2 {TkWmDeadWindow procedure, destroying menubar} {unixOnly} {
catch {destroy .t}
catch {destroy .f}
toplevel .t -width 300 -height 200 -bd 2 -relief raised
wm geom .t +0+0
update
frame .f -width 400 -height 30 -bd 2 -relief raised -bg green
bind .f <Destroy> {lappend result destroyed}
testmenubar window .t .f
update
set result {}
destroy .t
lappend result [winfo exists .f]
} {destroyed 0}
test unixWm-11.1 {Tk_WmCmd procedure, miscellaneous errors} {
list [catch {wm} msg] $msg
} {1 {wrong # args: should be "wm option window ?arg ...?"}}
test unixWm-11.2 {Tk_WmCmd procedure, miscellaneous errors} {
list [catch {wm foo} msg] $msg
} {1 {wrong # args: should be "wm option window ?arg ...?"}}
test unixWm-11.3 {Tk_WmCmd procedure, miscellaneous errors} {
list [catch {wm foo bogus} msg] $msg
} {1 {bad window path name "bogus"}}
test unixWm-11.4 {Tk_WmCmd procedure, miscellaneous errors} {
catch {destroy .b}
button .b -text hello
list [catch {wm geometry .b} msg] $msg
} {1 {window ".b" isn't a top-level window}}
catch {destroy .t}
catch {destroy .icon}
toplevel .t -width 100 -height 50
wm geom .t +0+0
update
test unixWm-12.1 {Tk_WmCmd procedure, "aspect" option} {
list [catch {wm aspect .t 12} msg] $msg
} {1 {wrong # arguments: must be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"}}
test unixWm-12.2 {Tk_WmCmd procedure, "aspect" option} {
list [catch {wm aspect .t 12 13 14 15 16} msg] $msg
} {1 {wrong # arguments: must be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"}}
test unixWm-12.3 {Tk_WmCmd procedure, "aspect" option} {
set result {}
lappend result [wm aspect .t]
wm aspect .t 3 4 10 2
lappend result [wm aspect .t]
wm aspect .t {} {} {} {}
lappend result [wm aspect .t]
} {{} {3 4 10 2} {}}
test unixWm-12.4 {Tk_WmCmd procedure, "aspect" option} {
list [catch {wm aspect .t bad 14 15 16} msg] $msg
} {1 {expected integer but got "bad"}}
test unixWm-12.5 {Tk_WmCmd procedure, "aspect" option} {
list [catch {wm aspect .t 13 foo 15 16} msg] $msg
} {1 {expected integer but got "foo"}}
test unixWm-12.6 {Tk_WmCmd procedure, "aspect" option} {
list [catch {wm aspect .t 13 14 bar 16} msg] $msg
} {1 {expected integer but got "bar"}}
test unixWm-12.7 {Tk_WmCmd procedure, "aspect" option} {
list [catch {wm aspect .t 13 14 15 baz} msg] $msg
} {1 {expected integer but got "baz"}}
test unixWm-12.8 {Tk_WmCmd procedure, "aspect" option} {
list [catch {wm aspect .t 0 14 15 16} msg] $msg
} {1 {aspect number can't be <= 0}}
test unixWm-12.9 {Tk_WmCmd procedure, "aspect" option} {
list [catch {wm aspect .t 13 0 15 16} msg] $msg
} {1 {aspect number can't be <= 0}}
test unixWm-12.10 {Tk_WmCmd procedure, "aspect" option} {
list [catch {wm aspect .t 13 14 0 16} msg] $msg
} {1 {aspect number can't be <= 0}}
test unixWm-12.11 {Tk_WmCmd procedure, "aspect" option} {
list [catch {wm aspect .t 13 14 15 0} msg] $msg
} {1 {aspect number can't be <= 0}}
test unixWm-13.1 {Tk_WmCmd procedure, "client" option} {
list [catch {wm client .t x y} msg] $msg
} {1 {wrong # arguments: must be "wm client window ?name?"}}
test unixWm-13.2 {Tk_WmCmd procedure, "client" option} {unixOnly} {
set result {}
lappend result [wm client .t]
wm client .t Test_String
lappend result [testprop [testwrapper .t] WM_CLIENT_MACHINE]
wm client .t New
lappend result [wm client .t]
wm client .t {}
lappend result [wm client .t] [testprop [testwrapper .t] WM_CLIENT_MACHINE]
} {{} Test_String New {} {}}
test unixWm-13.3 {Tk_WmCmd procedure, "client" option, unmapped window} {
catch {destroy .t2}
toplevel .t2
wm client .t2 Test_String
wm client .t2 {}
wm client .t2 Test_String
destroy .t2
} {}
test unixWm-14.1 {Tk_WmCmd procedure, "colormapwindows" option} {
list [catch {wm colormapwindows .t 12 13} msg] $msg
} {1 {wrong # arguments: must be "wm colormapwindows window ?windowList?"}}
test unixWm-14.2 {Tk_WmCmd procedure, "colormapwindows" option} {
catch {destroy .t2}
toplevel .t2 -width 200 -height 200 -colormap new
wm geom .t2 +0+0
frame .t2.a -width 100 -height 30
frame .t2.b -width 100 -height 30 -colormap new
pack .t2.a .t2.b -side top
update
set x [wm colormapwindows .t2]
frame .t2.c -width 100 -height 30 -colormap new
pack .t2.c -side top
update
list $x [wm colormapwindows .t2]
} {{.t2.b .t2} {.t2.b .t2.c .t2}}
test unixWm-14.3 {Tk_WmCmd procedure, "colormapwindows" option} {
list [catch {wm col . "a \{"} msg] $msg
} {1 {unmatched open brace in list}}
test unixWm-14.4 {Tk_WmCmd procedure, "colormapwindows" option} {
list [catch {wm colormapwindows . foo} msg] $msg
} {1 {bad window path name "foo"}}
test unixWm-14.5 {Tk_WmCmd procedure, "colormapwindows" option} {
catch {destroy .t2}
toplevel .t2 -width 200 -height 200 -colormap new
wm geom .t2 +0+0
frame .t2.a -width 100 -height 30
frame .t2.b -width 100 -height 30
frame .t2.c -width 100 -height 30
pack .t2.a .t2.b .t2.c -side top
wm colormapwindows .t2 {.t2.c .t2 .t2.a}
wm colormapwindows .t2
} {.t2.c .t2 .t2.a}
test unixWm-14.6 {Tk_WmCmd procedure, "colormapwindows" option} {
catch {destroy .t2}
toplevel .t2 -width 200 -height 200
wm geom .t2 +0+0
frame .t2.a -width 100 -height 30
frame .t2.b -width 100 -height 30
frame .t2.c -width 100 -height 30
pack .t2.a .t2.b .t2.c -side top
wm colormapwindows .t2 {.t2.b .t2.a}
wm colormapwindows .t2
} {.t2.b .t2.a}
test unixWm-14.7 {Tk_WmCmd procedure, "colormapwindows" option} {
catch {destroy .t2}
toplevel .t2 -width 200 -height 200 -colormap new
wm geom .t2 +0+0
set x [wm colormapwindows .t2]
wm colormapwindows .t2 {}
list $x [wm colormapwindows .t2]
} {{} {}}
catch {destroy .t2}
test unixWm-15.1 {Tk_WmCmd procedure, "command" option} {
list [catch {wm command .t 12 13} msg] $msg
} {1 {wrong # arguments: must be "wm command window ?value?"}}
test unixWm-15.2 {Tk_WmCmd procedure, "command" option} {
list [catch {wm command .t 12 13} msg] $msg
} {1 {wrong # arguments: must be "wm command window ?value?"}}
test unixWm-15.3 {Tk_WmCmd procedure, "command" option} {unixOnly} {
set result {}
lappend result [wm command .t]
wm command .t "test command"
lappend result [testprop [testwrapper .t] WM_COMMAND]
wm command .t "new command"
lappend result [wm command .t]
wm command .t {}
lappend result [wm command .t] [testprop [testwrapper .t] WM_COMMAND]
} {{} {test
command
} {new command} {} {}}
test unixWm-15.4 {Tk_WmCmd procedure, "command" option, window not mapped} {
catch {destroy .t2}
toplevel .t2
wm geom .t2 +0+0
wm command .t2 "test command"
wm command .t2 "new command"
wm command .t2 {}
destroy .t2
} {}
test unixWm-15.5 {Tk_WmCmd procedure, "command" option} {
list [catch {wm command .t "a \{b"} msg] $msg
} {1 {unmatched open brace in list}}
test unixWm-16.1 {Tk_WmCmd procedure, "deiconify" option} {
list [catch {wm deiconify .t 12} msg] $msg
} {1 {wrong # arguments: must be "wm deiconify window"}}
test unixWm-16.2 {Tk_WmCmd procedure, "deiconify" option} {
catch {destroy .icon}
toplevel .icon -width 50 -height 50 -bg red
wm iconwindow .t .icon
set result [list [catch {wm deiconify .icon} msg] $msg]
destroy .icon
set result
} {1 {can't deiconify .icon: it is an icon for .t}}
test unixWm-16.3 {Tk_WmCmd procedure, "deiconify" option} {
wm iconify .t
set result {}
lappend result [winfo ismapped .t] [wm state .t]
wm deiconify .t
lappend result [winfo ismapped .t] [wm state .t]
} {0 iconic 1 normal}
test unixWm-17.1 {Tk_WmCmd procedure, "focusmodel" option} {
list [catch {wm focusmodel .t 12 13} msg] $msg
} {1 {wrong # arguments: must be "wm focusmodel window ?active|passive?"}}
test unixWm-17.2 {Tk_WmCmd procedure, "focusmodel" option} {
list [catch {wm focusmodel .t bogus} msg] $msg
} {1 {bad argument "bogus": must be active or passive}}
test unixWm-17.3 {Tk_WmCmd procedure, "focusmodel" option} {
set result {}
lappend result [wm focusmodel .t]
wm focusmodel .t active
lappend result [wm focusmodel .t]
wm focusmodel .t passive
lappend result [wm focusmodel .t]
set result
} {passive active passive}
test unixWm-18.1 {Tk_WmCmd procedure, "frame" option} {
list [catch {wm frame .t 12} msg] $msg
} {1 {wrong # arguments: must be "wm frame window"}}
test unixWm-18.2 {Tk_WmCmd procedure, "frame" option} nonPortable {
expr [wm frame .t] == [winfo id .t]
} {0}
test unixWm-18.3 {Tk_WmCmd procedure, "frame" option} nonPortable {
catch {destroy .t2}
toplevel .t2
wm geom .t2 +0+0
wm overrideredirect .t2 1
update
set result [expr [wm frame .t2] == [winfo id .t2]]
destroy .t2
set result
} {1}
test unixWm-19.1 {Tk_WmCmd procedure, "geometry" option} {
list [catch {wm geometry .t 12 13} msg] $msg
} {1 {wrong # arguments: must be "wm geometry window ?newGeometry?"}}
test unixWm-19.2 {Tk_WmCmd procedure, "geometry" option} nonPortable {
wm geometry .t -1+5
update
wm geometry .t
} {100x50-1+5}
test unixWm-19.3 {Tk_WmCmd procedure, "geometry" option} nonPortable {
wm geometry .t +10-4
update
wm geometry .t
} {100x50+10-4}
test unixWm-19.4 {Tk_WmCmd procedure, "geometry" option} nonPortable {
catch {destroy .t2}
toplevel .t2
wm geom .t2 -5+10
listbox .t2.l -width 30 -height 12 -setgrid 1
pack .t2.l
update
set result [wm geometry .t2]
destroy .t2
set result
} {30x12-5+10}
test unixWm-19.5 {Tk_WmCmd procedure, "geometry" option} nonPortable {
wm geometry .t 150x300+5+6
update
set result {}
lappend result [wm geometry .t]
wm geometry .t {}
update
lappend result [wm geometry .t]
} {150x300+5+6 100x50+5+6}
test unixWm-19.6 {Tk_WmCmd procedure, "geometry" option} {
list [catch {wm geometry .t qrs} msg] $msg
} {1 {bad geometry specifier "qrs"}}
test unixWm-20.1 {Tk_WmCmd procedure, "grid" option} {
list [catch {wm grid .t 12 13} msg] $msg
} {1 {wrong # arguments: must be "wm grid window ?baseWidth baseHeight widthInc heightInc?"}}
test unixWm-20.2 {Tk_WmCmd procedure, "grid" option} {
list [catch {wm grid .t 12 13 14 15 16} msg] $msg
} {1 {wrong # arguments: must be "wm grid window ?baseWidth baseHeight widthInc heightInc?"}}
test unixWm-20.3 {Tk_WmCmd procedure, "grid" option} {
set result {}
lappend result [wm grid .t]
wm grid .t 5 6 20 10
lappend result [wm grid .t]
wm grid .t {} {} {} {}
lappend result [wm grid .t]
} {{} {5 6 20 10} {}}
test unixWm-20.4 {Tk_WmCmd procedure, "grid" option} {
list [catch {wm grid .t bad 10 11 12} msg] $msg
} {1 {expected integer but got "bad"}}
test unixWm-20.5 {Tk_WmCmd procedure, "grid" option} {
list [catch {wm grid .t -1 11 12 13} msg] $msg
} {1 {baseWidth can't be < 0}}
test unixWm-20.6 {Tk_WmCmd procedure, "grid" option} {
list [catch {wm grid .t 10 foo 12 13} msg] $msg
} {1 {expected integer but got "foo"}}
test unixWm-20.7 {Tk_WmCmd procedure, "grid" option} {
list [catch {wm grid .t 10 -11 12 13} msg] $msg
} {1 {baseHeight can't be < 0}}
test unixWm-20.8 {Tk_WmCmd procedure, "grid" option} {
list [catch {wm grid .t 10 11 bar 13} msg] $msg
} {1 {expected integer but got "bar"}}
test unixWm-20.9 {Tk_WmCmd procedure, "grid" option} {
list [catch {wm grid .t 10 11 -2 13} msg] $msg
} {1 {widthInc can't be < 0}}
test unixWm-20.10 {Tk_WmCmd procedure, "grid" option} {
list [catch {wm grid .t 10 11 12 bogus} msg] $msg
} {1 {expected integer but got "bogus"}}
test unixWm-20.11 {Tk_WmCmd procedure, "grid" option} {
list [catch {wm grid .t 10 11 12 -1} msg] $msg
} {1 {heightInc can't be < 0}}
catch {destroy .t}
catch {destroy .icon}
toplevel .t -width 100 -height 50
wm geom .t +0+0
update
test unixWm-21.1 {Tk_WmCmd procedure, "group" option} {
list [catch {wm group .t 12 13} msg] $msg
} {1 {wrong # arguments: must be "wm group window ?pathName?"}}
test unixWm-21.2 {Tk_WmCmd procedure, "group" option} {
list [catch {wm group .t bogus} msg] $msg
} {1 {bad window path name "bogus"}}
test unixWm-21.3 {Tk_WmCmd procedure, "group" option} {unixOnly} {
set result {}
lappend result [wm group .t]
wm group .t .
set bit [format 0x%x [expr 0x40 & [lindex [testprop [testwrapper .t] \
WM_HINTS] 0]]]
lappend result [wm group .t] $bit
wm group .t {}
set bit [format 0x%x [expr 0x40 & [lindex [testprop [testwrapper .t] \
WM_HINTS] 0]]]
lappend result [wm group .t] $bit
} {{} . 0x40 {} 0x0}
test unixWm-21.4 {Tk_WmCmd procedure, "group" option, make window exist} {unixOnly} {
catch {destroy .t2}
toplevel .t2
wm geom .t2 +0+0
wm group .t .t2
set hints [testprop [testwrapper .t] WM_HINTS]
set result [expr [testwrapper .t2] - [lindex $hints 8]]
destroy .t2
set result
} {0}
test unixWm-21.5 {Tk_WmCmd procedure, "group" option, create leader wrapper} {unixOnly} {
catch {destroy .t2}
catch {destroy .t3}
toplevel .t2 -width 120 -height 300
wm geometry .t2 +0+0
toplevel .t3 -width 120 -height 300
wm geometry .t2 +0+0
set result [list [testwrapper .t2]]
wm group .t3 .t2
lappend result [expr {[testwrapper .t2] == ""}]
destroy .t2 .t3
set result
} {{} 0}
test unixWm-22.1 {Tk_WmCmd procedure, "iconbitmap" option} {
list [catch {wm iconbitmap .t 12 13} msg] $msg
} {1 {wrong # arguments: must be "wm iconbitmap window ?bitmap?"}}
test unixWm-22.2 {Tk_WmCmd procedure, "iconbitmap" option} {unixOnly} {
set result {}
lappend result [wm iconbitmap .t]
wm iconbitmap .t questhead
set bit [format 0x%x [expr 0x4 & [lindex [testprop [testwrapper .t] \
WM_HINTS] 0]]]
lappend result [wm iconbitmap .t] $bit
wm iconbitmap .t {}
set bit [format 0x%x [expr 0x4 & [lindex [testprop [testwrapper .t] \
WM_HINTS] 0]]]
lappend result [wm iconbitmap .t] $bit
} {{} questhead 0x4 {} 0x0}
test unixWm-22.3 {Tk_WmCmd procedure, "iconbitmap" option} {
list [catch {wm iconbitmap .t bad-bitmap} msg] $msg
} {1 {bitmap "bad-bitmap" not defined}}
test unixWm-23.1 {Tk_WmCmd procedure, "iconify" option} {
list [catch {wm iconify .t 12} msg] $msg
} {1 {wrong # arguments: must be "wm iconify window"}}
test unixWm-23.2 {Tk_WmCmd procedure, "iconify" option} {
catch {destroy .t2}
toplevel .t2
wm overrideredirect .t2 1
set result [list [catch {wm iconify .t2} msg] $msg]
destroy .t2
set result
} {1 {can't iconify ".t2": override-redirect flag is set}}
test unixWm-23.3 {Tk_WmCmd procedure, "iconify" option} {
catch {destroy .t2}
toplevel .t2
wm geom .t2 +0+0
wm transient .t2 .t
set result [list [catch {wm iconify .t2} msg] $msg]
destroy .t2
set result
} {1 {can't iconify ".t2": it is a transient}}
test unixWm-23.4 {Tk_WmCmd procedure, "iconify" option} {
catch {destroy .t2}
toplevel .t2
wm geom .t2 +0+0
wm iconwindow .t .t2
set result [list [catch {wm iconify .t2} msg] $msg]
destroy .t2
set result
} {1 {can't iconify .t2: it is an icon for .t}}
test unixWm-23.5 {Tk_WmCmd procedure, "iconify" option} {
catch {destroy .t2}
toplevel .t2
wm geom .t2 +0+0
wm iconify .t2
update
set result [winfo ismapped .t2]
destroy .t2
set result
} {0}
test unixWm-23.6 {Tk_WmCmd procedure, "iconify" option} {
catch {destroy .t2}
toplevel .t2
wm geom .t2 -0+0
update
set result [winfo ismapped .t2]
wm iconify .t2
lappend result [winfo ismapped .t2]
destroy .t2
set result
} {1 0}
test unixWm-24.1 {Tk_WmCmd procedure, "iconmask" option} {
list [catch {wm iconmask .t 12 13} msg] $msg
} {1 {wrong # arguments: must be "wm iconmask window ?bitmap?"}}
test unixWm-24.2 {Tk_WmCmd procedure, "iconmask" option} {unixOnly} {
set result {}
lappend result [wm iconmask .t]
wm iconmask .t questhead
set bit [format 0x%x [expr 0x20 & [lindex [testprop [testwrapper .t] \
WM_HINTS] 0]]]
lappend result [wm iconmask .t] $bit
wm iconmask .t {}
set bit [format 0x%x [expr 0x20 & [lindex [testprop [testwrapper .t] \
WM_HINTS] 0]]]
lappend result [wm iconmask .t] $bit
} {{} questhead 0x20 {} 0x0}
test unixWm-24.3 {Tk_WmCmd procedure, "iconmask" option} {
list [catch {wm iconmask .t bogus} msg] $msg
} {1 {bitmap "bogus" not defined}}
test unixWm-25.1 {Tk_WmCmd procedure, "iconname" option} {
list [catch {wm icon .t} msg] $msg
} {1 {unknown or ambiguous option "icon": must be aspect, client, command, deiconify, focusmodel, frame, geometry, grid, group, iconbitmap, iconify, iconmask, iconname, iconposition, iconwindow, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, state, title, transient, or withdraw}}
test unixWm-25.2 {Tk_WmCmd procedure, "iconname" option} {
list [catch {wm iconname .t 12 13} msg] $msg
} {1 {wrong # arguments: must be "wm iconname window ?newName?"}}
test unixWm-25.3 {Tk_WmCmd procedure, "iconname" option} {unixOnly} {
set result {}
lappend result [wm iconname .t]
wm iconname .t test_name
lappend result [wm iconname .t] [testprop [testwrapper .t] WM_ICON_NAME]
wm iconname .t {}
lappend result [wm iconname .t] [testprop [testwrapper .t] WM_ICON_NAME]
} {{} test_name test_name {} {}}
test unixWm-26.1 {Tk_WmCmd procedure, "iconposition" option} {
list [catch {wm iconposition .t 12} msg] $msg
} {1 {wrong # arguments: must be "wm iconposition window ?x y?"}}
test unixWm-26.2 {Tk_WmCmd procedure, "iconposition" option} {
list [catch {wm iconposition .t 12 13 14} msg] $msg
} {1 {wrong # arguments: must be "wm iconposition window ?x y?"}}
test unixWm-26.3 {Tk_WmCmd procedure, "iconposition" option} {unixOnly} {
set result {}
lappend result [wm iconposition .t]
wm iconposition .t 10 15
set prop [testprop [testwrapper .t] WM_HINTS]
lappend result [wm iconposition .t] [lindex $prop 5] [lindex $prop 6]
lappend result [format 0x%x [expr 0x10 & [lindex $prop 0]]]
wm iconposition .t {} {}
set bit [format 0x%x [expr 0x10 & [lindex [testprop [testwrapper .t] \
WM_HINTS] 0]]]
lappend result [wm iconposition .t] $bit
} {{} {10 15} 0xa 0xf 0x10 {} 0x0}
test unixWm-26.4 {Tk_WmCmd procedure, "iconposition" option} {
list [catch {wm iconposition .t bad 13} msg] $msg
} {1 {expected integer but got "bad"}}
test unixWm-26.5 {Tk_WmCmd procedure, "iconposition" option} {
list [catch {wm iconposition .t 13 lousy} msg] $msg
} {1 {expected integer but got "lousy"}}
test unixWm-27.1 {Tk_WmCmd procedure, "iconwindow" option} {
list [catch {wm iconwindow .t 12 13} msg] $msg
} {1 {wrong # arguments: must be "wm iconwindow window ?pathName?"}}
test unixWm-27.2 {Tk_WmCmd procedure, "iconwindow" option} {unixOnly} {
catch {destroy .icon}
toplevel .icon -width 50 -height 50 -bg green
set result {}
lappend result [wm iconwindow .t]
wm iconwindow .t .icon
set prop [testprop [testwrapper .t] WM_HINTS]
lappend result [wm iconwindow .t] [wm state .icon]
lappend result [format 0x%x [expr 0x8 & [lindex $prop 0]]]
lappend result [expr [testwrapper .icon] == [lindex $prop 4]]
wm iconwindow .t {}
set bit [format 0x%x [expr 0x8 & [lindex [testprop [testwrapper .t] \
WM_HINTS] 0]]]
lappend result [wm iconwindow .t] [wm state .icon] $bit
destroy .icon
set result
} {{} .icon icon 0x8 1 {} withdrawn 0x0}
test unixWm-27.3 {Tk_WmCmd procedure, "iconwindow" option} {
list [catch {wm iconwindow .t bogus} msg] $msg
} {1 {bad window path name "bogus"}}
test unixWm-27.4 {Tk_WmCmd procedure, "iconwindow" option} {
catch {destroy .b}
button .b -text Help
set result [list [catch {wm iconwindow .t .b} msg] $msg]
destroy .b
set result
} {1 {can't use .b as icon window: not at top level}}
test unixWm-27.5 {Tk_WmCmd procedure, "iconwindow" option} {
catch {destroy .icon}
toplevel .icon -width 50 -height 50 -bg green
catch {destroy .t2}
toplevel .t2
wm geom .t2 -0+0
wm iconwindow .t2 .icon
set result [list [catch {wm iconwindow .t .icon} msg] $msg]
destroy .t2
destroy .icon
set result
} {1 {.icon is already an icon for .t2}}
test unixWm-27.6 {Tk_WmCmd procedure, "iconwindow" option, changing icons} {
catch {destroy .icon}
catch {destroy .icon2}
toplevel .icon -width 50 -height 50 -bg green
toplevel .icon2 -width 50 -height 50 -bg red
set result {}
wm iconwindow .t .icon
lappend result [wm state .icon] [wm state .icon2]
wm iconwindow .t .icon2
lappend result [wm state .icon] [wm state .icon2]
destroy .icon .icon2
set result
} {icon normal withdrawn icon}
test unixWm-27.7 {Tk_WmCmd procedure, "iconwindow" option, withdrawing icon} {
catch {destroy .icon}
toplevel .icon -width 50 -height 50 -bg green
wm geometry .icon +0+0
update
set result {}
lappend result [wm state .icon] [winfo viewable .icon]
wm iconwindow .t .icon
lappend result [wm state .icon] [winfo viewable .icon]
destroy .icon
set result
} {normal 1 icon 0}
test unixWm-28.1 {Tk_WmCmd procedure, "maxsize" option} {
list [catch {wm maxsize} msg] $msg
} {1 {wrong # args: should be "wm option window ?arg ...?"}}
test unixWm-28.2 {Tk_WmCmd procedure, "maxsize" option} {
list [catch {wm maxsize . a} msg] $msg
} {1 {wrong # arguments: must be "wm maxsize window ?width height?"}}
test unixWm-28.3 {Tk_WmCmd procedure, "maxsize" option} {
list [catch {wm maxsize . a b c} msg] $msg
} {1 {wrong # arguments: must be "wm maxsize window ?width height?"}}
test unixWm-28.4 {Tk_WmCmd procedure, "maxsize" option} {nonPortable} {
wm maxsize .t
} {1137 870}
test unixWm-28.5 {Tk_WmCmd procedure, "maxsize" option} {
list [catch {wm maxsize . x 100} msg] $msg
} {1 {expected integer but got "x"}}
test unixWm-28.6 {Tk_WmCmd procedure, "maxsize" option} {
list [catch {wm maxsize . 100 bogus} msg] $msg
} {1 {expected integer but got "bogus"}}
test unixWm-28.7 {Tk_WmCmd procedure, "maxsize" option} {
wm maxsize .t 200 150
wm maxsize .t
} {200 150}
test unixWm-28.8 {Tk_WmCmd procedure, "maxsize" option} {nonPortable} {
# Not portable, because some window managers let applications override
# minsize and maxsize.
wm maxsize .t 200 150
wm geom .t 300x200
update
list [winfo width .t] [winfo height .t]
} {200 150}
catch {destroy .t}
catch {destroy .icon}
toplevel .t -width 100 -height 50
wm geom .t +0+0
update
test unixWm-29.1 {Tk_WmCmd procedure, "minsize" option} {
list [catch {wm minsize} msg] $msg
} {1 {wrong # args: should be "wm option window ?arg ...?"}}
test unixWm-29.2 {Tk_WmCmd procedure, "minsize" option} {
list [catch {wm minsize . a} msg] $msg
} {1 {wrong # arguments: must be "wm minsize window ?width height?"}}
test unixWm-29.3 {Tk_WmCmd procedure, "minsize" option} {
list [catch {wm minsize . a b c} msg] $msg
} {1 {wrong # arguments: must be "wm minsize window ?width height?"}}
test unixWm-29.4 {Tk_WmCmd procedure, "minsize" option} {
wm minsize .t
} {1 1}
test unixWm-29.5 {Tk_WmCmd procedure, "minsize" option} {
list [catch {wm minsize . x 100} msg] $msg
} {1 {expected integer but got "x"}}
test unixWm-29.6 {Tk_WmCmd procedure, "minsize" option} {
list [catch {wm minsize . 100 bogus} msg] $msg
} {1 {expected integer but got "bogus"}}
test unixWm-29.7 {Tk_WmCmd procedure, "minsize" option} {
wm minsize .t 200 150
wm minsize .t
} {200 150}
test unixWm-29.8 {Tk_WmCmd procedure, "minsize" option} {nonPortable} {
# Not portable, because some window managers let applications override
# minsize and maxsize.
wm minsize .t 150 100
wm geom .t 50x50
update
list [winfo width .t] [winfo height .t]
} {150 100}
catch {destroy .t}
catch {destroy .icon}
toplevel .t -width 100 -height 50
wm geom .t +0+0
update
test unixWm-30.1 {Tk_WmCmd procedure, "overrideredirect" option} {
list [catch {wm overrideredirect .t 1 2} msg] $msg
} {1 {wrong # arguments: must be "wm overrideredirect window ?boolean?"}}
test unixWm-30.2 {Tk_WmCmd procedure, "overrideredirect" option} {
list [catch {wm overrideredirect .t boo} msg] $msg
} {1 {expected boolean value but got "boo"}}
test unixWm-30.3 {Tk_WmCmd procedure, "overrideredirect" option} {
set result {}
lappend result [wm overrideredirect .t]
wm overrideredirect .t true
lappend result [wm overrideredirect .t]
wm overrideredirect .t off
lappend result [wm overrideredirect .t]
} {0 1 0}
test unixWm-31.1 {Tk_WmCmd procedure, "positionfrom" option} {
list [catch {wm positionfrom .t 1 2} msg] $msg
} {1 {wrong # arguments: must be "wm positionfrom window ?user/program?"}}
test unixWm-31.2 {Tk_WmCmd procedure, "positionfrom" option} {unixOnly} {
set result {}
lappend result [wm positionfrom .t]
wm positionfrom .t program
update
set bit [format 0x%x [expr 0x5 & [lindex [testprop [testwrapper .t] \
WM_NORMAL_HINTS] 0]]]
lappend result [wm positionfrom .t] $bit
wm positionfrom .t user
update
set bit [format 0x%x [expr 0x5 & [lindex [testprop [testwrapper .t] \
WM_NORMAL_HINTS] 0]]]
lappend result [wm positionfrom .t] $bit
} {user program 0x4 user 0x1}
test unixWm-31.3 {Tk_WmCmd procedure, "positionfrom" option} {
list [catch {wm positionfrom .t none} msg] $msg
} {1 {bad argument "none": must be program or user}}
test unixWm-32.1 {Tk_WmCmd procedure, "protocol" option} {
list [catch {wm protocol .t 1 2 3} msg] $msg
} {1 {wrong # arguments: must be "wm protocol window ?name? ?command?"}}
test unixWm-32.2 {Tk_WmCmd procedure, "protocol" option} {
wm protocol .t {foo a} {a b c}
wm protocol .t bar {test script for bar}
set result [wm protocol .t]
wm protocol .t {foo a} {}
wm protocol .t bar {}
set result
} {bar {foo a}}
test unixWm-32.3 {Tk_WmCmd procedure, "protocol" option} {unixOnly} {
set result {}
lappend result [wm protocol .t]
set x {}
foreach i [testprop [testwrapper .t] WM_PROTOCOLS] {
lappend x [winfo atomname $i]
}
lappend result $x
wm protocol .t foo {test script}
wm protocol .t bar {test script}
set x {}
foreach i [testprop [testwrapper .t] WM_PROTOCOLS] {
lappend x [winfo atomname $i]
}
lappend result [wm protocol .t] $x
wm protocol .t foo {}
wm protocol .t bar {}
set x {}
foreach i [testprop [testwrapper .t] WM_PROTOCOLS] {
lappend x [winfo atomname $i]
}
lappend result [wm protocol .t] $x
} {{} WM_DELETE_WINDOW {bar foo} {WM_DELETE_WINDOW bar foo} {} WM_DELETE_WINDOW}
test unixWm-32.4 {Tk_WmCmd procedure, "protocol" option} {
set result {}
wm protocol .t foo {a b c}
wm protocol .t bar {test script for bar}
lappend result [wm protocol .t foo] [wm protocol .t bar]
wm protocol .t foo {}
wm protocol .t bar {}
lappend result [wm protocol .t foo] [wm protocol .t bar]
} {{a b c} {test script for bar} {} {}}
test unixWm-32.5 {Tk_WmCmd procedure, "protocol" option} {
wm protocol .t foo {a b c}
wm protocol .t foo {test script}
set result [wm protocol .t foo]
wm protocol .t foo {}
set result
} {test script}
test unixWm-33.1 {Tk_WmCmd procedure, "resizable" option} {
list [catch {wm resizable . a} msg] $msg
} {1 {wrong # arguments: must be "wm resizable window ?width height?"}}
test unixWm-33.2 {Tk_WmCmd procedure, "resizable" option} {
list [catch {wm resizable . a b c} msg] $msg
} {1 {wrong # arguments: must be "wm resizable window ?width height?"}}
test unixWm-33.3 {Tk_WmCmd procedure, "resizable" option} {
list [catch {wm resizable .foo a b c} msg] $msg
} {1 {bad window path name ".foo"}}
test unixWm-33.4 {Tk_WmCmd procedure, "resizable" option} {
list [catch {wm resizable . x 1} msg] $msg
} {1 {expected boolean value but got "x"}}
test unixWm-33.5 {Tk_WmCmd procedure, "resizable" option} {
list [catch {wm resizable . 0 gorp} msg] $msg
} {1 {expected boolean value but got "gorp"}}
test unixWm-33.6 {Tk_WmCmd procedure, "resizable" option} {
catch {destroy .t2}
toplevel .t2 -width 200 -height 100
wm geom .t2 +0+0
set result ""
lappend result [wm resizable .t2]
wm resizable .t2 1 0
lappend result [wm resizable .t2]
wm resizable .t2 no off
lappend result [wm resizable .t2]
wm resizable .t2 false true
lappend result [wm resizable .t2]
destroy .t2
set result
} {{1 1} {1 0} {0 0} {0 1}}
test unixWm-34.1 {Tk_WmCmd procedure, "sizefrom" option} {
list [catch {wm sizefrom .t 1 2} msg] $msg
} {1 {wrong # arguments: must be "wm sizefrom window ?user|program?"}}
test unixWm-34.2 {Tk_WmCmd procedure, "sizefrom" option} {unixOnly} {
set result {}
lappend result [wm sizefrom .t]
wm sizefrom .t program
update
set bit [format 0x%x [expr 0xa & [lindex [testprop [testwrapper .t] \
WM_NORMAL_HINTS] 0]]]
lappend result [wm sizefrom .t] $bit
wm sizefrom .t user
update
set bit [format 0x%x [expr 0xa & [lindex [testprop [testwrapper .t] \
WM_NORMAL_HINTS] 0]]]
lappend result [wm sizefrom .t] $bit
} {{} program 0x8 user 0x2}
test unixWm-34.3 {Tk_WmCmd procedure, "sizefrom" option} {
list [catch {wm sizefrom .t none} msg] $msg
} {1 {bad argument "none": must be program or user}}
test unixWm-35.1 {Tk_WmCmd procedure, "state" option} {
list [catch {wm state .t 1} msg] $msg
} {1 {wrong # arguments: must be "wm state window"}}
test unixWm-35.2 {Tk_WmCmd procedure, "state" option} {
set result {}
catch {destroy .t2}
toplevel .t2 -width 120 -height 300
wm geometry .t2 +0+0
lappend result [wm state .t2]
update
lappend result [wm state .t2]
wm withdraw .t2
lappend result [wm state .t2]
wm iconify .t2
lappend result [wm state .t2]
wm deiconify .t2
lappend result [wm state .t2]
destroy .t2
set result
} {normal normal withdrawn iconic normal}
test unixWm-36.1 {Tk_WmCmd procedure, "title" option} {
list [catch {wm title .t 1 2} msg] $msg
} {1 {wrong # arguments: must be "wm title window ?newTitle?"}}
test unixWm-36.2 {Tk_WmCmd procedure, "title" option} {unixOnly} {
set result {}
lappend result [wm title .t] [testprop [testwrapper .t] WM_NAME]
wm title .t "Test window"
set bit [format 0x%x [expr 0xa & [lindex [testprop [testwrapper .t] \
WM_NORMAL_HINTS] 0]]]
lappend result [wm title .t] [testprop [testwrapper .t] WM_NAME]
} {t t {Test window} {Test window}}
test unixWm-37.1 {Tk_WmCmd procedure, "transient" option} {
list [catch {wm transient .t 1 2} msg] $msg
} {1 {wrong # arguments: must be "wm transient window ?master?"}}
test unixWm-37.2 {Tk_WmCmd procedure, "transient" option} {
list [catch {wm transient .t foo} msg] $msg
} {1 {bad window path name "foo"}}
test unixWm-37.3 {Tk_WmCmd procedure, "transient" option} {unixOnly} {
set result {}
catch {destroy .t2}
toplevel .t2 -width 120 -height 300
wm geometry .t2 +0+0
update
lappend result [wm transient .t2] \
[testprop [testwrapper .t2] WM_TRANSIENT_FOR]
wm transient .t2 .t
set transient [testprop [testwrapper .t2] WM_TRANSIENT_FOR]
lappend result [wm transient .t2] [expr [testwrapper .t] - $transient]
wm transient .t2 {}
lappend result [wm transient .t2] \
[testprop [testwrapper .t2] WM_TRANSIENT_FOR]
destroy .t2
set result
} {{} {} .t 0 {} 0x0}
test unixWm-37.4 {Tk_WmCmd procedure, "transient" option, create master wrapper} {unixOnly} {
catch {destroy .t2}
catch {destroy .t3}
toplevel .t2 -width 120 -height 300
wm geometry .t2 +0+0
toplevel .t3 -width 120 -height 300
wm geometry .t2 +0+0
set result [list [testwrapper .t2]]
wm transient .t3 .t2
lappend result [expr {[testwrapper .t2] == ""}]
destroy .t2 .t3
set result
} {{} 0}
test unixWm-38.1 {Tk_WmCmd procedure, "withdraw" option} {
list [catch {wm withdraw .t 1} msg] $msg
} {1 {wrong # arguments: must be "wm withdraw window"}}
test unixWm-38.2 {Tk_WmCmd procedure, "withdraw" option} {
catch {destroy .t2}
toplevel .t2 -width 120 -height 300
wm geometry .t2 +0+0
wm iconwindow .t .t2
set result [list [catch {wm withdraw .t2} msg] $msg]
destroy .t2
set result
} {1 {can't withdraw .t2: it is an icon for .t}}
test unixWm-38.3 {Tk_WmCmd procedure, "withdraw" option} {
set result {}
wm withdraw .t
lappend result [wm state .t] [winfo ismapped .t]
wm deiconify .t
lappend result [wm state .t] [winfo ismapped .t]
} {withdrawn 0 normal 1}
test unixWm-39.1 {Tk_WmCmd procedure, miscellaneous} {
list [catch {wm unknown .t} msg] $msg
} {1 {unknown or ambiguous option "unknown": must be aspect, client, command, deiconify, focusmodel, frame, geometry, grid, group, iconbitmap, iconify, iconmask, iconname, iconposition, iconwindow, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, state, title, transient, or withdraw}}
catch {destroy .t}
catch {destroy .icon}
test unixWm-40.1 {Tk_SetGrid procedure, set grid dimensions before turning on grid} {nonPortable} {
catch {destroy .t}
toplevel .t
wm geometry .t 30x10+0+0
listbox .t.l -height 20 -width 20 -setgrid 1
pack .t.l -fill both -expand 1
update
wm geometry .t
} {30x10+0+0}
test unixWm-40.2 {Tk_SetGrid procedure, turning on grid when dimensions already set} {
catch {destroy .t}
toplevel .t
wm geometry .t 200x100+0+0
listbox .t.l -height 20 -width 20
pack .t.l -fill both -expand 1
update
.t.l configure -setgrid 1
update
wm geometry .t
} {20x20+0+0}
test unixWm-41.1 {ConfigureEvent procedure, internally generated size changes} {
catch {destroy .t}
toplevel .t -width 400 -height 150
wm geometry .t +0+0
tkwait visibility .t
set result {}
lappend result [winfo width .t] [winfo height .t]
.t configure -width 200 -height 300
sleep 500
lappend result [winfo width .t] [winfo height .t]
} {400 150 200 300}
test unixWm-41.2 {ConfigureEvent procedure, menubars} {unixOnly} {
catch {destroy .t}
toplevel .t -width 300 -height 200 -bd 2 -relief raised
wm geom .t +0+0
update
set x [winfo rootx .t]
set y [winfo rooty .t]
frame .t.m -bd 2 -relief raised -height 20
testmenubar window .t .t.m
update
set result {}
bind .t <Configure> {
if {"%W" == ".t"} {
lappend result "%W: %wx%h"
}
}
bind .t.m <Configure> {lappend result "%W: %wx%h"}
wm geometry .t 200x300
update
lappend result [expr [winfo rootx .t.m] - $x] \
[expr [winfo rooty .t.m] - $y] \
[winfo width .t.m] [winfo height .t.m] \
[expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y] \
[winfo width .t] [winfo height .t]
} {{.t.m: 200x20} {.t: 200x300} 0 0 200 20 0 20 200 300}
test unixWm-41.3 {ConfigureEvent procedure, synthesized Configure events} {
catch {destroy .t}
toplevel .t -width 400 -height 150
wm geometry .t +0+0
tkwait visibility .t
set result {no event}
bind .t <Configure> {set result "configured: %w %h"}
wm geometry .t +10+20
update
set result
} {configured: 400 150}
test unixWm-41.4 {ConfigureEvent procedure, synthesized Configure events} {
catch {destroy .t}
toplevel .t -width 400 -height 150
wm geometry .t +0+0
tkwait visibility .t
set result {no event}
bind .t <Configure> {set result "configured: %w %h"}
wm geometry .t 130x200
update
set result
} {configured: 130 200}
# No tests for ReparentEvent or ComputeReparentGeometry; I can't figure
# out how to exercise these procedures reliably.
test unixWm-42.1 {WrapperEventProc procedure, map and unmap events} {
catch {destroy .t}
toplevel .t -width 400 -height 150
wm geometry .t +0+0
tkwait visibility .t
set result {}
bind .t <Map> {set x "mapped"}
bind .t <Unmap> {set x "unmapped"}
set x {no event}
wm iconify .t
lappend result $x [winfo ismapped .t]
set x {no event}
wm deiconify .t
lappend result $x [winfo ismapped .t]
} {unmapped 0 mapped 1}
test unixWm-43.1 {TopLevelReqProc procedure, embedded in same process} {
catch {destroy .t}
toplevel .t -width 200 -height 200
wm geom .t +0+0
frame .t.f -container 1 -bd 2 -relief raised
place .t.f -x 20 -y 10
tkwait visibility .t.f
toplevel .t2 -use [winfo id .t.f] -width 30 -height 20 -bg blue
tkwait visibility .t2
set result {}
.t2 configure -width 70 -height 120
update
lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f]
lappend result [winfo width .t2] [winfo height .t2]
# destroy .t2
set result
} {70 120 70 120}
test unixWm-43.2 {TopLevelReqProc procedure, resize causes window to move} \
{nonPortable} {
catch {destroy .t}
toplevel .t -width 200 -height 200
wm geom .t +0+0
update
wm geom .t -0-0
update
set x [winfo x .t]
set y [winfo y .t]
.t configure -width 300 -height 150
update
list [expr [winfo x .t] - $x] [expr [winfo y .t] - $y] \
[winfo width .t] [winfo height .t]
} {-100 50 300 150}
test unixWm-44.1 {UpdateGeometryInfo procedure, width/height computation} {
catch {destroy .t}
toplevel .t -width 100 -height 200
wm geometry .t +30+40
wm overrideredirect .t 1
tkwait visibility .t
.t configure -width 180 -height 20
update
list [winfo width .t] [winfo height .t]
} {180 20}
test unixWm-44.2 {UpdateGeometryInfo procedure, width/height computation} {
catch {destroy .t}
toplevel .t -width 80 -height 60
wm grid .t 5 4 10 12
wm geometry .t +30+40
wm overrideredirect .t 1
tkwait visibility .t
wm geometry .t 10x2
update
list [winfo width .t] [winfo height .t]
} {130 36}
test unixWm-44.3 {UpdateGeometryInfo procedure, width/height computation} {
catch {destroy .t}
toplevel .t -width 80 -height 60
wm grid .t 5 4 10 12
wm geometry .t +30+40
wm overrideredirect .t 1
tkwait visibility .t
wm geometry .t 1x10
update
list [winfo width .t] [winfo height .t]
} {40 132}
test unixWm-44.4 {UpdateGeometryInfo procedure, width/height computation} {
catch {destroy .t}
toplevel .t -width 100 -height 200
wm geometry .t +30+40
wm overrideredirect .t 1
tkwait visibility .t
wm geometry .t 300x150
update
list [winfo width .t] [winfo height .t]
} {300 150}
test unixWm-44.5 {UpdateGeometryInfo procedure, negative width} {
catch {destroy .t}
toplevel .t -width 80 -height 60
wm grid .t 18 7 10 12
wm geometry .t +30+40
wm overrideredirect .t 1
tkwait visibility .t
wm geometry .t 5x8
update
list [winfo width .t] [winfo height .t]
} {1 72}
test unixWm-44.6 {UpdateGeometryInfo procedure, negative height} {
catch {destroy .t}
toplevel .t -width 80 -height 60
wm grid .t 18 7 10 12
wm geometry .t +30+40
wm overrideredirect .t 1
tkwait visibility .t
wm geometry .t 20x1
update
list [winfo width .t] [winfo height .t]
} {100 1}
test unixWm-44.7 {UpdateGeometryInfo procedure, computing position} {
catch {destroy .t}
toplevel .t -width 80 -height 60
wm geometry .t +5-10
wm overrideredirect .t 1
tkwait visibility .t
list [winfo x .t] [winfo y .t]
} "5 [expr [winfo screenheight .t] - 70]"
test unixWm-44.8 {UpdateGeometryInfo procedure, computing position} {
catch {destroy .t}
toplevel .t -width 80 -height 60
wm geometry .t -30+2
wm overrideredirect .t 1
tkwait visibility .t
list [winfo x .t] [winfo y .t]
} "[expr [winfo screenwidth .t] - 110] 2"
test unixWm-44.9 {UpdateGeometryInfo procedure, updating fixed dimensions} {unixOnly} {
catch {destroy .t}
toplevel .t -width 80 -height 60
wm resizable .t 0 0
wm geometry .t +0+0
tkwait visibility .t
.t configure -width 180 -height 20
update
set property [testprop [testwrapper .t] WM_NORMAL_HINTS]
list [expr [lindex $property 5]] [expr [lindex $property 6]] \
[expr [lindex $property 7]] [expr [lindex $property 8]]
} {180 20 180 20}
test unixWm-44.10 {UpdateGeometryInfo procedure, menubar changing} {
catch {destroy .t}
toplevel .t -width 80 -height 60
wm resizable .t 0 0
wm geometry .t +0+0
tkwait visibility .t
.t configure -width 180 -height 50
frame .t.m -bd 2 -relief raised -width 100 -height 50
testmenubar window .t .t.m
update
.t configure -height 70
.t.m configure -height 30
list [update] [destroy .t]
} {{} {}}
test unixWm-45.1 {UpdateSizeHints procedure, grid information} {unixOnly} {
catch {destroy .t}
toplevel .t -width 80 -height 60
wm grid .t 6 10 10 5
wm minsize .t 2 4
wm maxsize .t 30 40
wm geometry .t +0+0
tkwait visibility .t
set property [testprop [testwrapper .t] WM_NORMAL_HINTS]
list [expr [lindex $property 5]] [expr [lindex $property 6]] \
[expr [lindex $property 7]] [expr [lindex $property 8]] \
[expr [lindex $property 9]] [expr [lindex $property 10]]
} {40 30 320 210 10 5}
test unixWm-45.2 {UpdateSizeHints procedure} {unixOnly} {
catch {destroy .t}
toplevel .t -width 80 -height 60
wm minsize .t 30 40
wm maxsize .t 200 500
wm geometry .t +0+0
tkwait visibility .t
set property [testprop [testwrapper .t] WM_NORMAL_HINTS]
list [expr [lindex $property 5]] [expr [lindex $property 6]] \
[expr [lindex $property 7]] [expr [lindex $property 8]] \
[expr [lindex $property 9]] [expr [lindex $property 10]]
} {30 40 200 500 1 1}
test unixWm-45.3 {UpdateSizeHints procedure, grid with menu} {
catch {destroy .t}
toplevel .t -width 80 -height 60
frame .t.menu -height 23 -width 50
testmenubar window .t .t.menu
wm grid .t 6 10 10 5
wm minsize .t 2 4
wm maxsize .t 30 40
wm geometry .t +0+0
tkwait visibility .t
set property [testprop [testwrapper .t] WM_NORMAL_HINTS]
list [winfo height .t] \
[expr [lindex $property 5]] [expr [lindex $property 6]] \
[expr [lindex $property 7]] [expr [lindex $property 8]] \
[expr [lindex $property 9]] [expr [lindex $property 10]]
} {60 40 53 320 233 10 5}
test unixWm-45.4 {UpdateSizeHints procedure, not resizable with menu} {
catch {destroy .t}
toplevel .t -width 80 -height 60
frame .t.menu -height 23 -width 50
testmenubar window .t .t.menu
wm resizable .t 0 0
wm geometry .t +0+0
tkwait visibility .t
set property [testprop [testwrapper .t] WM_NORMAL_HINTS]
list [winfo height .t] \
[expr [lindex $property 5]] [expr [lindex $property 6]] \
[expr [lindex $property 7]] [expr [lindex $property 8]] \
[expr [lindex $property 9]] [expr [lindex $property 10]]
} {60 80 83 80 83 1 1}
# I don't know how to test WaitForConfigureNotify.
test unixWm-46.1 {WaitForEvent procedure, use of modal timeout} {
catch {destroy .t}
toplevel .t -width 200 -height 200
wm geom .t +0+0
update
wm iconify .t
set x no
after 0 {set x yes}
wm deiconify .t
set result $x
update
list $result $x
} {no yes}
test unixWm-47.1 {WaitRestrictProc procedure} {
catch {destroy .t}
toplevel .t -width 300 -height 200
frame .t.f -bd 2 -relief raised
place .t.f -x 20 -y 30 -width 100 -height 20
wm geometry .t +0+0
tkwait visibility .t
set result {}
bind .t.f <Configure> {lappend result {configure on .t.f}}
bind .t <Map> {lappend result {map on .t}}
bind .t <Unmap> {lappend result {unmap on .t}; bind .t <Unmap> {}}
bind .t <Button> {lappend result {button %b on .t}}
event generate .t.f <Configure> -when tail
event generate .t <Configure> -when tail
event generate .t <Button> -button 3 -when tail
event generate .t <Map> -when tail
lappend result iconify
wm iconify .t
lappend result done
update
set result
} {iconify {unmap on .t} done {configure on .t.f} {button 3 on .t} {map on .t}}
# I don't know how to test WaitTimeoutProc, WaitForMapNotify, or UpdateHints.
catch {destroy .t}
toplevel .t -width 300 -height 200
wm geometry .t +0+0
tkwait visibility .t
test unixWm-48.1 {ParseGeometry procedure} {
wm geometry .t =100x120
update
list [winfo width .t] [winfo height .t]
} {100 120}
test unixWm-48.2 {ParseGeometry procedure} {
list [catch {wm geometry .t =10zx120} msg] $msg
} {1 {bad geometry specifier "=10zx120"}}
test unixWm-48.3 {ParseGeometry procedure} {
list [catch {wm geometry .t x120} msg] $msg
} {1 {bad geometry specifier "x120"}}
test unixWm-48.4 {ParseGeometry procedure} {
list [catch {wm geometry .t =100x120a} msg] $msg
} {1 {bad geometry specifier "=100x120a"}}
test unixWm-48.5 {ParseGeometry procedure} {
list [catch {wm geometry .t z} msg] $msg
} {1 {bad geometry specifier "z"}}
test unixWm-48.6 {ParseGeometry procedure} {
list [catch {wm geometry .t +20&} msg] $msg
} {1 {bad geometry specifier "+20&"}}
test unixWm-48.7 {ParseGeometry procedure} {
list [catch {wm geometry .t +-} msg] $msg
} {1 {bad geometry specifier "+-"}}
test unixWm-48.8 {ParseGeometry procedure} {
list [catch {wm geometry .t +20a} msg] $msg
} {1 {bad geometry specifier "+20a"}}
test unixWm-48.9 {ParseGeometry procedure} {
list [catch {wm geometry .t +20-} msg] $msg
} {1 {bad geometry specifier "+20-"}}
test unixWm-48.10 {ParseGeometry procedure} {
list [catch {wm geometry .t +20+10z} msg] $msg
} {1 {bad geometry specifier "+20+10z"}}
test unixWm-48.11 {ParseGeometry procedure} {
catch {wm geometry .t +-10+20}
} {0}
test unixWm-48.12 {ParseGeometry procedure} {
catch {wm geometry .t +30+-10}
} {0}
test unixWm-48.13 {ParseGeometry procedure, resize causes window to move} {
catch {destroy .t}
toplevel .t -width 200 -height 200
wm geom .t +0+0
update
wm geom .t -0-0
update
set x [winfo x .t]
set y [winfo y .t]
wm geometry .t 150x300
update
list [expr [winfo x .t] - $x] [expr [winfo y .t] - $y] \
[winfo width .t] [winfo height .t]
} {50 -100 150 300}
test unixWm-49.1 {Tk_GetRootCoords procedure} {
catch {destroy .t}
toplevel .t -width 300 -height 200
frame .t.f -width 150 -height 100 -bd 2 -relief raised
place .t.f -x 150 -y 120
frame .t.f.f -width 20 -height 20 -bd 2 -relief raised
place .t.f.f -x 10 -y 20
wm overrideredirect .t 1
wm geometry .t +40+50
tkwait visibility .t
list [winfo rootx .t.f.f] [winfo rooty .t.f.f]
} {202 192}
test unixWm-49.2 {Tk_GetRootCoords procedure, menubars} {unixOnly} {
catch {destroy .t}
toplevel .t -width 300 -height 200 -bd 2 -relief raised
wm geom .t +0+0
update
set x [winfo rootx .t]
set y [winfo rooty .t]
frame .t.m -bd 2 -relief raised -width 100 -height 30
frame .t.m.f -width 20 -height 10 -bd 2 -relief raised
place .t.m.f -x 50 -y 5
frame .t.f -width 20 -height 30 -bd 2 -relief raised
place .t.f -x 10 -y 30
testmenubar window .t .t.m
update
list [expr [winfo rootx .t.m.f] - $x] [expr [winfo rooty .t.m.f] - $y] \
[expr [winfo rootx .t.f] - $x] [expr [winfo rooty .t.f] - $y]
} {52 7 12 62}
foreach w [winfo children .] {
catch {destroy $w}
}
wm iconify .
test unixWm-50.1 {Tk_CoordsToWindow procedure, finding a toplevel, x-coords} {
eval destroy [winfo children .]
toplevel .t -width 300 -height 400 -bg green
wm geom .t +40+0
tkwait visibility .t
toplevel .t2 -width 100 -height 80 -bg red
wm geom .t2 +140+200
tkwait visibility .t2
raise .t2
set x [winfo rootx .t]
set y [winfo rooty .t]
list [winfo containing [expr $x - 30] [expr $y + 250]] \
[winfo containing [expr $x - 1] [expr $y + 250]] \
[winfo containing $x [expr $y + 250]] \
[winfo containing [expr $x + 99] [expr $y + 250]] \
[winfo containing [expr $x + 100] [expr $y + 250]] \
[winfo containing [expr $x + 199] [expr $y + 250]] \
[winfo containing [expr $x + 200] [expr $y + 250]] \
[winfo containing [expr $x + 220] [expr $y + 250]]
} {{} {} .t {} .t2 .t2 {} .t}
test unixWm-50.2 {Tk_CoordsToWindow procedure, finding a toplevel, y-coords and overrideredirect} {
eval destroy [winfo children .]
toplevel .t -width 300 -height 400 -bg yellow
wm geom .t +0+50
tkwait visibility .t
toplevel .t2 -width 100 -height 80 -bg blue
wm overrideredirect .t2 1
wm geom .t2 +100+200
tkwait visibility .t2
raise .t2
set x [winfo rootx .t]
set y [winfo rooty .t]
set y2 [winfo rooty .t2]
list [winfo containing [expr $x +150] 10] \
[winfo containing [expr $x +150] [expr $y - 1]] \
[winfo containing [expr $x +150] $y] \
[winfo containing [expr $x +150] [expr $y2 - 1]] \
[winfo containing [expr $x +150] $y2] \
[winfo containing [expr $x +150] [expr $y2 + 79]] \
[winfo containing [expr $x +150] [expr $y2 + 80]] \
[winfo containing [expr $x +150] [expr $y + 450]]
} {{} {} .t .t .t2 .t2 .t {}}
test unixWm-50.3 {Tk_CoordsToWindow procedure, finding a toplevel with embedding} {
eval destroy [winfo children .]
toplevel .t -width 300 -height 400 -bg blue
wm geom .t +0+50
frame .t.f -container 1
place .t.f -x 150 -y 50
tkwait visibility .t.f
setupbg
dobg "
wm withdraw .
toplevel .x -width 100 -height 80 -use [winfo id .t.f] -bg yellow
tkwait visibility .x"
set result [dobg {
set x [winfo rootx .x]
set y [winfo rooty .x]
list [winfo containing [expr $x - 1] [expr $y + 50]] \
[winfo containing $x [expr $y +50]]
}]
set x [winfo rootx .t]
set y [winfo rooty .t]
lappend result [winfo containing [expr $x + 200] [expr $y + 49]] \
[winfo containing [expr $x + 200] [expr $y +50]]
} {{} .x .t .t.f}
cleanupbg
test unixWm-50.4 {Tk_CoordsToWindow procedure, window in other application} {
catch {destroy .t}
catch {interp delete slave}
toplevel .t -width 200 -height 200 -bg green
wm geometry .t +0+0
tkwait visibility .t
interp create slave
load {} tk slave
slave eval {wm geometry . 200x200+0+0; tkwait visibility .}
set result [list [winfo containing 100 100] \
[slave eval {winfo containing 100 100}]]
interp delete slave
set result
} {{} .}
test unixWm-50.5 {Tk_CoordsToWindow procedure, handling menubars} {unixOnly} {
eval destroy [winfo children .]
toplevel .t -width 300 -height 400 -bd 2 -relief raised
frame .t.f -width 150 -height 120 -bg green
place .t.f -x 10 -y 150
wm geom .t +0+50
frame .t.menu -width 100 -height 30 -bd 2 -relief raised
frame .t.menu.f -width 40 -height 20 -bg purple
place .t.menu.f -x 30 -y 10
testmenubar window .t .t.menu
tkwait visibility .t.menu
update
set x [winfo rootx .t]
set y [winfo rooty .t]
list [winfo containing $x [expr $y - 31]] \
[winfo containing $x [expr $y - 30]] \
[winfo containing [expr $x + 50] [expr $y - 19]] \
[winfo containing [expr $x + 50] [expr $y - 18]] \
[winfo containing [expr $x + 50] $y] \
[winfo containing [expr $x + 11] [expr $y + 152]] \
[winfo containing [expr $x + 12] [expr $y + 152]]
} {{} .t.menu .t.menu .t.menu.f .t .t .t.f}
test unixWm-50.6 {Tk_CoordsToWindow procedure, embedding within one app.} {
eval destroy [winfo children .]
toplevel .t -width 300 -height 400 -bg orange
wm geom .t +0+50
frame .t.f -container 1
place .t.f -x 150 -y 50
tkwait visibility .t.f
toplevel .t2 -width 100 -height 80 -bg green -use [winfo id .t.f]
tkwait visibility .t2
update
set x [winfo rootx .t]
set y [winfo rooty .t]
list [winfo containing [expr $x +149] [expr $y + 80]] \
[winfo containing [expr $x +150] [expr $y +80]] \
[winfo containing [expr $x +249] [expr $y +80]] \
[winfo containing [expr $x +250] [expr $y +80]]
} {.t .t2 .t2 .t}
test unixWm-50.7 {Tk_CoordsToWindow procedure, more basics} {
catch {destroy .t}
toplevel .t -width 300 -height 400 -bg green
wm geom .t +0+0
frame .t.f -width 100 -height 200 -bd 2 -relief raised
place .t.f -x 100 -y 100
frame .t.f.f -width 100 -height 200 -bd 2 -relief raised
place .t.f.f -x 0 -y 100
tkwait visibility .t.f.f
set x [expr [winfo rootx .t] + 150]
set y [winfo rooty .t]
list [winfo containing $x [expr $y + 50]] \
[winfo containing $x [expr $y + 150]] \
[winfo containing $x [expr $y + 250]] \
[winfo containing $x [expr $y + 350]] \
[winfo containing $x [expr $y + 450]]
} {.t .t.f .t.f.f .t {}}
test unixWm-50.8 {Tk_CoordsToWindow procedure, more basics} {
catch {destroy .t}
toplevel .t -width 400 -height 300 -bg green
wm geom .t +0+0
frame .t.f -width 200 -height 100 -bd 2 -relief raised
place .t.f -x 100 -y 100
frame .t.f.f -width 200 -height 100 -bd 2 -relief raised
place .t.f.f -x 100 -y 0
update
set x [winfo rooty .t]
set y [expr [winfo rooty .t] + 150]
list [winfo containing [expr $x + 50] $y] \
[winfo containing [expr $x + 150] $y] \
[winfo containing [expr $x + 250] $y] \
[winfo containing [expr $x + 350] $y] \
[winfo containing [expr $x + 450] $y]
} {.t .t.f .t.f.f .t {}}
test unixWm-50.9 {Tk_CoordsToWindow procedure, unmapped windows} {
catch {destroy .t}
catch {destroy .t2}
sleep 500 ;# Give window manager time to catch up.
toplevel .t -width 200 -height 200 -bg green
wm geometry .t +0+0
tkwait visibility .t
toplevel .t2 -width 200 -height 200 -bg red
wm geometry .t2 +0+0
tkwait visibility .t2
set result [list [winfo containing 100 100]]
wm iconify .t2
lappend result [winfo containing 100 100]
} {.t2 .t}
test unixWm-50.10 {Tk_CoordsToWindow procedure, unmapped windows} {
catch {destroy .t}
toplevel .t -width 200 -height 200 -bg green
wm geometry .t +0+0
frame .t.f -width 150 -height 150 -bd 2 -relief raised
place .t.f -x 25 -y 25
tkwait visibility .t.f
set result [list [winfo containing 100 100]]
place forget .t.f
update
lappend result [winfo containing 100 100]
} {.t.f .t}
eval destroy [winfo children .]
wm deiconify .
# No tests for UpdateVRootGeometry, Tk_GetVRootGeometry,
# Tk_MoveToplevelWindow, UpdateWmProtocols, or TkWmProtocolEventProc.
test unixWm-51.1 {TkWmRestackToplevel procedure, basic tests} {nonPortable} {
makeToplevels
update
raise .raise1
winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
} .raise1
test unixWm-51.2 {TkWmRestackToplevel procedure, basic tests} {nonPortable} {
makeToplevels
update
raise .raise2
winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
} .raise2
test unixWm-51.3 {TkWmRestackToplevel procedure, basic tests} {nonPortable} {
makeToplevels
update
raise .raise3
raise .raise2
raise .raise1 .raise3
set result [winfo containing [winfo rootx .raise1] \
[winfo rooty .raise1]]
destroy .raise2
sleep 500
list $result [winfo containing [winfo rootx .raise1] \
[winfo rooty .raise1]]
} {.raise2 .raise1}
test unixWm-51.4 {TkWmRestackToplevel procedure, basic tests} {nonPortable} {
makeToplevels
raise .raise2
raise .raise1
lower .raise3 .raise1
set result [winfo containing 100 100]
destroy .raise1
sleep 500
lappend result [winfo containing 100 100]
} {.raise1 .raise3}
test unixWm-51.5 {TkWmRestackToplevel procedure, basic tests} {nonPortable} {
makeToplevels
update
raise .raise2
raise .raise1
raise .raise3
frame .raise1.f1
frame .raise1.f1.f2
lower .raise3 .raise1.f1.f2
set result [winfo containing [winfo rootx .raise1] \
[winfo rooty .raise1]]
destroy .raise1
sleep 500
list $result [winfo containing [winfo rootx .raise2] \
[winfo rooty .raise2]]
} {.raise1 .raise3}
foreach w [winfo children .] {
catch {destroy $w}
}
test unixWm-51.6 {TkWmRestackToplevel procedure, window to be stacked isn't mapped} {
catch {destroy .t}
toplevel .t -width 200 -height 200 -bg green
wm geometry .t +0+0
tkwait visibility .t
catch {destroy .t2}
toplevel .t2 -width 200 -height 200 -bg red
wm geometry .t2 +0+0
winfo containing 100 100
} {.t}
test unixWm-51.7 {TkWmRestackToplevel procedure, other window isn't mapped} {
foreach w {.t .t2 .t3} {
catch {destroy $w}
toplevel $w -width 200 -height 200 -bg green
wm geometry $w +0+0
}
raise .t .t2
update
set result [list [winfo containing 100 100]]
lower .t3
lappend result [winfo containing 100 100]
} {.t3 .t}
test unixWm-51.8 {TkWmRestackToplevel procedure, overrideredirect windows} {
catch {destroy .t}
toplevel .t -width 200 -height 200 -bg green
wm overrideredirect .t 1
wm geometry .t +0+0
tkwait visibility .t
catch {destroy .t2}
toplevel .t2 -width 200 -height 200 -bg red
wm overrideredirect .t2 1
wm geometry .t2 +0+0
tkwait visibility .t2
# Need to use vrootx and vrooty to make tests work correctly with
# virtual root window measures managers: overrideredirect windows
# come up at (0,0) in display coordinates, not virtual root
# coordinates.
set x [expr 100-[winfo vrootx .]]
set y [expr 100-[winfo vrooty .]]
set result [list [winfo containing $x $y]]
raise .t
lappend result [winfo containing $x $y]
raise .t2
lappend result [winfo containing $x $y]
} {.t2 .t .t2}
test unixWm-51.9 {TkWmRestackToplevel procedure, other window overrideredirect} {
foreach w {.t .t2 .t3} {
catch {destroy $w}
toplevel $w -width 200 -height 200 -bg green
wm overrideredirect $w 1
wm geometry $w +0+0
tkwait visibility $w
}
lower .t3 .t2
update
# Need to use vrootx and vrooty to make tests work correctly with
# virtual root window measures managers: overrideredirect windows
# come up at (0,0) in display coordinates, not virtual root
# coordinates.
set x [expr 100-[winfo vrootx .]]
set y [expr 100-[winfo vrooty .]]
set result [list [winfo containing $x $y]]
lower .t2
lappend result [winfo containing $x $y]
} {.t2 .t3}
test unixWm-51.10 {TkWmRestackToplevel procedure, don't move window that's already in the right place} {
makeToplevels
raise .raise1
set time [lindex [time {raise .raise1}] 0]
expr {$time < 2000000}
} 1
test unixWm-51.11 {TkWmRestackToplevel procedure, don't move window that's already in the right place} {
makeToplevels
set time [lindex [time {lower .raise1}] 0]
expr {$time < 2000000}
} 1
test unixWm-51.12 {TkWmRestackToplevel procedure, don't move window that's already in the right place} {
makeToplevels
set time [lindex [time {raise .raise3 .raise2}] 0]
expr {$time < 2000000}
} 1
test unixWm-51.13 {TkWmRestackToplevel procedure, don't move window that's already in the right place} {
makeToplevels
set time [lindex [time {lower .raise1 .raise2}] 0]
expr {$time < 2000000}
} 1
test unixWm-52.1 {TkWmAddToColormapWindows procedure} {
catch {destroy .t}
toplevel .t -width 200 -height 200 -colormap new -relief raised -bd 2
wm geom .t +0+0
update
wm colormap .t
} {}
test unixWm-52.2 {TkWmAddToColormapWindows procedure} {
catch {destroy .t}
toplevel .t -colormap new -relief raised -bd 2
wm geom .t +0+0
frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2
pack .t.f
update
wm colormap .t
} {.t.f .t}
test unixWm-52.3 {TkWmAddToColormapWindows procedure} {
catch {destroy .t}
toplevel .t -colormap new
wm geom .t +0+0
frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2
pack .t.f
frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2
pack .t.f2
update
wm colormap .t
} {.t.f .t.f2 .t}
test unixWm-52.4 {TkWmAddToColormapWindows procedure} {
catch {destroy .t}
toplevel .t -colormap new
wm geom .t +0+0
frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2
pack .t.f
update
wm colormapwindows .t .t.f
frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2
pack .t.f2
update
wm colormapwindows .t
} {.t.f}
test unixWm-53.1 {TkWmRemoveFromColormapWindows procedure} {
catch {destroy .t}
toplevel .t -colormap new
wm geom .t +0+0
frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2
pack .t.f
frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2
pack .t.f2
update
destroy .t.f2
wm colormap .t
} {.t.f .t}
test unixWm-53.2 {TkWmRemoveFromColormapWindows procedure} {
catch {destroy .t}
toplevel .t -colormap new
wm geom .t +0+0
frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2
pack .t.f
frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2
pack .t.f2
update
wm colormapwindows .t .t.f2
destroy .t.f2
wm colormap .t
} {}
test unixWm-54.1 {TkpMakeMenuWindow procedure, setting save_under} {
catch {destroy .t}
catch {destroy .m}
toplevel .t -width 300 -height 200 -bd 2 -relief raised
bind .t <Expose> {set x exposed}
wm geom .t +0+0
update
menu .m
.m add command -label First
.m add command -label Second
.m add command -label Third
.m post 30 30
update
set x {no event}
destroy .m
set x
} {no event}
test unixWm-54.2 {TkpMakeMenuWindow procedure, setting override_redirect} {
catch {destroy .m}
menu .m
.m add command -label First
.m add command -label Second
.m add command -label Third
.m post 30 30
update
set result [wm overrideredirect .m]
destroy .m
set result
} {1}
# No tests for TkGetPointerCoords, CreateWrapper, or GetMaxSize.
test unixWm-55.1 {TkUnixSetMenubar procedure} {unixOnly} {
catch {destroy .t}
toplevel .t -width 300 -height 200 -bd 2 -relief raised
wm geom .t +0+0
update
frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green
testmenubar window .t .t.f
update
list [winfo ismapped .t.f] [winfo geometry .t.f] \
[expr [winfo rootx .t] - [winfo rootx .t.f]] \
[expr [winfo rooty .t] - [winfo rooty .t.f]]
} {1 300x30+0+0 0 30}
test unixWm-55.2 {TkUnixSetMenubar procedure, removing menubar} {unixOnly} {
catch {destroy .t}
catch {destroy .f}
toplevel .t -width 300 -height 200 -bd 2 -relief raised
wm geom .t +0+0
update
set x [winfo rootx .t]
set y [winfo rooty .t]
frame .f -width 400 -height 30 -bd 2 -relief raised -bg green
testmenubar window .t .f
update
testmenubar window .t {}
update
list [winfo ismapped .f] [winfo geometry .f] \
[expr [winfo rootx .t] - $x] \
[expr [winfo rooty .t] - $y] \
[expr [winfo rootx .] - [winfo rootx .f]] \
[expr [winfo rooty .] - [winfo rooty .f]]
} {0 300x30+0+0 0 0 0 0}
test unixWm-55.3 {TkUnixSetMenubar procedure, removing geometry manager} {unixOnly} {
catch {destroy .t}
toplevel .t -width 300 -height 200 -bd 2 -relief raised
wm geom .t +0+0
update
set x [winfo rootx .t]
set y [winfo rooty .t]
frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green
testmenubar window .t .t.f
update
testmenubar window .t {}
update
set result "[expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y]"
.t.f configure -height 100
update
lappend result [expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y]
} {0 0 0 0}
test unixWm-55.4 {TkUnixSetMenubar procedure, toplevel not yet created} {unixOnly} {
catch {destroy .t}
toplevel .t -width 300 -height 200 -bd 2 -relief raised
frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green
testmenubar window .t .t.f
wm geom .t +0+0
update
list [winfo ismapped .t.f] [winfo geometry .t.f] \
[expr [winfo rootx .t] - [winfo rootx .t.f]] \
[expr [winfo rooty .t] - [winfo rooty .t.f]]
} {1 300x30+0+0 0 30}
test unixWm-55.5 {TkUnixSetMenubar procedure, changing menubar} {unixOnly} {
catch {destroy .t}
catch {destroy .f}
toplevel .t -width 300 -height 200 -bd 2 -relief raised
frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green
wm geom .t +0+0
update
set y [winfo rooty .t]
frame .f -width 400 -height 50 -bd 2 -relief raised -bg green
testmenubar window .t .t.f
update
set result {}
lappend result [winfo ismapped .f] [winfo ismapped .t.f]
lappend result [expr [winfo rooty .t.f] - $y]
testmenubar window .t .f
update
lappend result [winfo ismapped .f] [winfo ismapped .t.f]
lappend result [expr [winfo rooty .f] - $y]
} {0 1 0 1 0 0}
test unixWm-55.6 {TkUnixSetMenubar procedure, changing menubar to self} {unixOnly} {
catch {destroy .t}
toplevel .t -width 300 -height 200 -bd 2 -relief raised
frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green
testmenubar window .t .t.f
wm geom .t +0+0
update
testmenubar window .t .t.f
update
list [winfo ismapped .t.f] [winfo geometry .t.f] \
[expr [winfo rootx .t] - [winfo rootx .t.f]] \
[expr [winfo rooty .t] - [winfo rooty .t.f]]
} {1 300x30+0+0 0 30}
test unixWm-55.7 {TkUnixSetMenubar procedure, unsetting event handler} {unixOnly} {
catch {destroy .t}
catch {destroy .f}
toplevel .t -width 300 -height 200 -bd 2 -relief raised
frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green
frame .f -width 400 -height 40 -bd 2 -relief raised -bg blue
wm geom .t +0+0
update
set y [winfo rooty .t]
testmenubar window .t .t.f
update
set result [expr [winfo rooty .t] - $y]
testmenubar window .t .f
update
lappend result [expr [winfo rooty .t] - $y]
destroy .t.f
update
lappend result [expr [winfo rooty .t] - $y]
} {30 40 40}
test unixWm-56.1 {MenubarDestroyProc procedure} {unixOnly} {
catch {destroy .t}
toplevel .t -width 300 -height 200 -bd 2 -relief raised
wm geom .t +0+0
update
set y [winfo rooty .t]
frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green
testmenubar window .t .t.f
update
set result [expr [winfo rooty .t] - $y]
destroy .t.f
update
lappend result [expr [winfo rooty .t] - $y]
} {30 0}
test unixWm-57.1 {MenubarReqProc procedure} {unixOnly} {
catch {destroy .t}
toplevel .t -width 300 -height 200 -bd 2 -relief raised
wm geom .t +0+0
update
set x [winfo rootx .t]
set y [winfo rooty .t]
frame .t.f -width 400 -height 10 -bd 2 -relief raised -bg green
testmenubar window .t .t.f
update
set result "[expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y]"
.t.f configure -height 100
update
lappend result [expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y]
} {0 10 0 100}
test unixWm-57.2 {MenubarReqProc procedure} {unixOnly} {
catch {destroy .t}
toplevel .t -width 300 -height 200 -bd 2 -relief raised
wm geom .t +0+0
update
set x [winfo rootx .t]
set y [winfo rooty .t]
frame .t.f -width 400 -height 20 -bd 2 -relief raised -bg green
testmenubar window .t .t.f
update
set result "[expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y]"
.t.f configure -height 0
update
lappend result [expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y]
} {0 20 0 1}
# Test exit processing and cleanup:
test unixWm-58.1 {exit processing} {
catch {removeFile script}
set fd [open script w]
puts $fd {
update
exit
}
close $fd
if {[catch {exec $tktest script -geometry 10x10+0+0} msg]} {
set error 1
} else {
set error 0
}
list $error $msg
} {0 {}}
test unixWm-58.2 {exit processing} {
catch {removeFile script}
set fd [open script w]
puts $fd {
interp create x
x eval {set argc 2}
x eval {set argv "-geometry 10x10+0+0"}
x eval {load {} Tk}
update
exit
}
close $fd
if {[catch {exec $tktest script -geometry 10x10+0+0} msg]} {
set error 1
} else {
set error 0
}
list $error $msg
} {0 {}}
test unixWm-58.3 {exit processing} {
catch {removeFile script}
set fd [open script w]
puts $fd {
interp create x
x eval {set argc 2}
x eval {set argv "-geometry 10x10+0+0"}
x eval {load {} Tk}
x eval {
button .b -text hello
bind .b <Destroy> foo
}
x alias foo destroy_x
proc destroy_x {} {interp delete x}
update
exit
}
close $fd
if {[catch {exec $tktest script -geometry 10x10+0+0} msg]} {
set error 1
} else {
set error 0
}
list $error $msg
} {0 {}}
catch {destroy .t}
concat {}