diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/textWind.test | 1190 | ||||
| -rw-r--r-- | tests/unixSelect.test | 414 | ||||
| -rw-r--r-- | tests/visual.test | 564 | ||||
| -rw-r--r-- | tests/visual_bb.test | 56 | ||||
| -rw-r--r-- | tests/winButton.test | 171 | ||||
| -rw-r--r-- | tests/winDialog.test | 447 | ||||
| -rw-r--r-- | tests/winFont.test | 456 | ||||
| -rw-r--r-- | tests/winMenu.test | 1259 | ||||
| -rw-r--r-- | tests/winMsgbox.test | 50 | ||||
| -rw-r--r-- | tests/winWm.test | 320 | ||||
| -rw-r--r-- | tests/window.test | 203 | ||||
| -rw-r--r-- | tests/winfo.test | 600 | ||||
| -rw-r--r-- | tests/xmfbox.test | 109 |
13 files changed, 3817 insertions, 2022 deletions
diff --git a/tests/textWind.test b/tests/textWind.test index a0a0858..1cf0ecc 100644 --- a/tests/textWind.test +++ b/tests/textWind.test @@ -6,10 +6,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: textWind.test,v 1.23 2008/07/23 23:24:25 nijtmans Exp $ +# RCS: @(#) $Id: textWind.test,v 1.24 2008/08/30 21:52:26 aniap Exp $ -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands # Create entries in the option database to be sure that geometry options @@ -19,26 +20,21 @@ option add *Text.borderWidth 2 option add *Text.highlightThickness 2 option add *Text.font {Courier -12} -set fixedFont {Courier -12} -# 15 on XP, 13 on Solaris 8 -set fixedHeight [font metrics $fixedFont -linespace] -# 7 on all platforms -set fixedWidth [font measure $fixedFont m] -# 12 on XP -set fixedAscent [font metrics $fixedFont -ascent] -set fixedDiff [expr {$fixedHeight - 13}] ;# 2 on XP - -catch {destroy .f} -catch {destroy .t} -catch {destroy .t2} +deleteWindows +# Widget used in tests 1.* - 16.* text .t -width 30 -height 6 -bd 2 -highlightthickness 2 pack append . .t {top expand fill} update .t debug on -wm geometry . {} + +# 15 on XP, 13 on Solaris 8 +set fixedHeight [font metrics {Courier -12} -linespace] +set fixedDiff [expr {$fixedHeight - 13}] ;# 2 on XP set color [expr {[winfo depth .t] > 1 ? "green" : "black"}] - + +wm geometry . {} + # The statements below reset the main window; it's needed if the window # manager is mwm to make mwm forget about a previous minimum size setting. @@ -47,206 +43,323 @@ wm minsize . 1 1 wm positionfrom . user wm deiconify . -test textWind-1.1 {basic tests of options} {fonts} { +# ---------------------------------------------------------------------- + +test textWind-1.1 {basic tests of options} -constraints fonts -setup { .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 3 -height 3 -bg $color .t window create 2.2 -window .f update list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] \ - [.t window configure .f -window] -} {1 3x3+19+23 {19 23 3 3} {-window {} {} {} .f}} -test textWind-1.2 {basic tests of options} {fonts} { + [.t window configure .f -window] +} -result {1 3x3+19+23 {19 23 3 3} {-window {} {} {} .f}} +test textWind-1.2 {basic tests of options} -constraints fonts -setup { .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 3 -height 3 -bg $color .t window create 2.2 -window .f -align top update list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] \ - [.t window configure .f -align] -} {1 3x3+19+18 {19 18 3 3} {-align {} {} center top}} -test textWind-1.3 {basic tests of options} { + [.t window configure .f -align] +} -result {1 3x3+19+18 {19 18 3 3} {-align {} {} center top}} +test textWind-1.3 {basic tests of options} -setup { .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" .t window create 2.2 -create "Test script" .t window configure 2.2 -create -} {-create {} {} {} {Test script}} -test textWind-1.4 {basic tests of options} {fonts} { +} -result {-create {} {} {} {Test script}} +test textWind-1.4 {basic tests of options} -constraints fonts -setup { .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 10 -height 20 -bg $color .t window create 2.2 -window .f -padx 5 update list [winfo geom .f] [.t window configure .f -padx] [.t bbox 2.3] -} {10x20+24+18 {-padx {} {} 0 5} {39 21 7 13}} -test textWind-1.5 {basic tests of options} {fonts} { +} -result {10x20+24+18 {-padx {} {} 0 5} {39 21 7 13}} +test textWind-1.5 {basic tests of options} -constraints fonts -setup { .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 10 -height 20 -bg $color .t window create 2.2 -window .f -pady 4 update list [winfo geom .f] [.t window configure .f -pady] [.t bbox 2.31] -} {10x20+19+22 {-pady {} {} 0 4} {19 46 7 13}} -test textWind-1.6 {basic tests of options} {fonts} { +} -result {10x20+19+22 {-pady {} {} 0 4} {19 46 7 13}} +test textWind-1.6 {basic tests of options} -constraints fonts -setup { .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 5 -height 5 -bg $color .t window create 2.2 -window .f -stretch 1 update list [winfo geom .f] [.t window configure .f -stretch] -} {5x13+19+18 {-stretch {} {} 0 1}} +} -result {5x13+19+18 {-stretch {} {} 0 1}} + .t delete 1.0 end .t insert end "This is the first line" -frame .f -width 10 -height 6 -bg $color -.t window create 1.3 -window .f -padx 1 -pady 2 -test textWind-2.1 {TkTextWindowCmd procedure} { - list [catch {.t window} msg] $msg -} {1 {wrong # args: should be ".t window option ?arg ...?"}} -test textWind-2.2 {TkTextWindowCmd procedure, "cget" option} { - list [catch {.t window cget} msg] $msg -} {1 {wrong # args: should be ".t window cget index option"}} -test textWind-2.3 {TkTextWindowCmd procedure, "cget" option} { - list [catch {.t window cget a b c} msg] $msg -} {1 {wrong # args: should be ".t window cget index option"}} -test textWind-2.4 {TkTextWindowCmd procedure, "cget" option} { - list [catch {.t window cget gorp -padx} msg] $msg -} {1 {bad text index "gorp"}} -test textWind-2.5 {TkTextWindowCmd procedure, "cget" option} { - list [catch {.t window cget 1.2 -padx} msg] $msg -} {1 {no embedded window at index "1.2"}} -test textWind-2.6 {TkTextWindowCmd procedure, "cget" option} { - list [catch {.t window cget .f -bogus} msg] $msg -} {1 {unknown option "-bogus"}} -test textWind-2.7 {TkTextWindowCmd procedure, "cget" option} { - list [catch {.t window cget .f -pady} msg] $msg -} {0 2} -test textWind-2.8 {TkTextWindowCmd procedure} { - list [catch {.t window co} msg] $msg -} {1 {wrong # args: should be ".t window configure index ?-option value ...?"}} -test textWind-2.9 {TkTextWindowCmd procedure} { - list [catch {.t window configure gorp} msg] $msg -} {1 {bad text index "gorp"}} -test textWind-2.10 {TkTextWindowCmd procedure} { - .t delete 1.0 end - list [catch {.t window configure 1.0} msg] $msg -} {1 {no embedded window at index "1.0"}} -test textWind-2.11 {TkTextWindowCmd procedure} { +test textWind-2.1 {TkTextWindowCmd procedure} -body { + .t window +} -returnCodes error -result {wrong # args: should be ".t window option ?arg ...?"} +test textWind-2.2 {TkTextWindowCmd procedure, "cget" option} -body { + .t window cget +} -returnCodes error -result {wrong # args: should be ".t window cget index option"} +test textWind-2.3 {TkTextWindowCmd procedure, "cget" option} -body { + .t window cget a b c +} -returnCodes error -result {wrong # args: should be ".t window cget index option"} +test textWind-2.4 {TkTextWindowCmd procedure, "cget" option} -body { + .t window cget gorp -padx +} -returnCodes error -result {bad text index "gorp"} +test textWind-2.5 {TkTextWindowCmd procedure, "cget" option} -body { + .t window cget 1.2 -padx +} -returnCodes error -result {no embedded window at index "1.2"} +test textWind-2.6 {TkTextWindowCmd procedure, "cget" option} -setup { + destroy .f +} -body { + frame .f -width 10 -height 6 -bg $color + .t window create 1.3 -window .f -padx 1 -pady 2 + .t window cget .f -bogus +} -cleanup { + destroy .f +} -returnCodes error -result {unknown option "-bogus"} +test textWind-2.7 {TkTextWindowCmd procedure, "cget" option} -setup { + destroy .f +} -body { + frame .f -width 10 -height 6 -bg $color + .t window create 1.3 -window .f -padx 1 -pady 2 + .t window cget .f -pady +} -cleanup { + destroy .f +} -returnCodes ok -result {2} +test textWind-2.8 {TkTextWindowCmd procedure} -body { + .t window co +} -returnCodes error -result {wrong # args: should be ".t window configure index ?-option value ...?"} +test textWind-2.9 {TkTextWindowCmd procedure} -body { + .t window configure gorp +} -returnCodes error -result {bad text index "gorp"} +test textWind-2.10 {TkTextWindowCmd procedure} -body { + .t delete 1.0 end + .t window configure 1.0 +} -returnCodes error -result {no embedded window at index "1.0"} +test textWind-2.11 {TkTextWindowCmd procedure} -setup { +# I kept this as it "influenced" the test case in previous releases + destroy .f + frame .f -width 10 -height 6 -bg $color + .t window create 1.3 -window .f -padx 1 -pady 2 .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 10 -height 6 -bg $color .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo update - list [catch {.t window configure .f} msg] $msg -} {0 {{-align {} {} center baseline} {-create {} {} {} foo} {-padx {} {} 0 1} {-pady {} {} 0 2} {-stretch {} {} 0 0} {-window {} {} {} .f}}} -test textWind-2.12 {TkTextWindowCmd procedure} { + .t window configure .f +} -cleanup { + destroy .f +} -result {{-align {} {} center baseline} {-create {} {} {} foo} {-padx {} {} 0 1} {-pady {} {} 0 2} {-stretch {} {} 0 0} {-window {} {} {} .f}} +test textWind-2.12 {TkTextWindowCmd procedure} -setup { +# I kept this as it "influenced" the test case in previous releases + destroy .f + frame .f -width 10 -height 6 -bg $color + .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 10 -height 6 -bg $color .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo update list [.t window configure .f -padx 33] [.t window configure .f -padx] -} {{} {-padx {} {} 0 33}} -test textWind-2.13 {TkTextWindowCmd procedure} { +} -cleanup { + destroy .f +} -result {{} {-padx {} {} 0 33}} +test textWind-2.13 {TkTextWindowCmd procedure} -setup { +# I kept this as it "influenced" the test case in previous releases + destroy .f + frame .f -width 10 -height 6 -bg $color + .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 10 -height 6 -bg $color .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 update list [.t window configure .f -padx 14 -pady 15] \ - [.t window configure .f -padx] [.t window configure .f -pady] -} {{} {-padx {} {} 0 14} {-pady {} {} 0 15}} -test textWind-2.14 {TkTextWindowCmd procedure} { - list [catch {.t window create} msg] $msg -} {1 {wrong # args: should be ".t window create index ?-option value ...?"}} -test textWind-2.15 {TkTextWindowCmd procedure} { - list [catch {.t window create gorp} msg] $msg -} {1 {bad text index "gorp"}} -test textWind-2.16 {TkTextWindowCmd procedure, don't insert after end} { + [.t window configure .f -padx] [.t window configure .f -pady] +} -cleanup { + destroy .f +} -result {{} {-padx {} {} 0 14} {-pady {} {} 0 15}} +test textWind-2.14 {TkTextWindowCmd procedure} -setup { + .t delete 1.0 end +} -body { + .t window create +} -returnCodes error -result {wrong # args: should be ".t window create index ?-option value ...?"} +test textWind-2.15 {TkTextWindowCmd procedure} -setup { + .t delete 1.0 end +} -body { + .t window create gorp +} -returnCodes error -result {bad text index "gorp"} +test textWind-2.16 {TkTextWindowCmd procedure, don't insert after end} -setup { +# I kept this as it "influenced" the test case in previous releases + destroy .f + frame .f -width 10 -height 6 -bg $color + .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 .t delete 1.0 end +} -body { .t insert end "Line 1\nLine 2" frame .f -width 20 -height 10 -bg $color .t window create end -window .f .t index .f -} {2.6} -test textWind-2.17 {TkTextWindowCmd procedure} { +} -result {2.6} +test textWind-2.17 {TkTextWindowCmd procedure} -setup { .t delete 1.0 end +} -body { list [catch {.t window create 1.0} msg] $msg [.t window configure 1.0] -} {0 {} {{-align {} {} center center} {-create {} {} {} {}} {-padx {} {} 0 0} {-pady {} {} 0 0} {-stretch {} {} 0 0} {-window {} {} {} {}}}} -test textWind-2.18 {TkTextWindowCmd procedure} { +} -result {0 {} {{-align {} {} center center} {-create {} {} {} {}} {-padx {} {} 0 0} {-pady {} {} 0 0} {-stretch {} {} 0 0} {-window {} {} {} {}}}} +test textWind-2.18 {TkTextWindowCmd procedure} -setup { +# I kept this as it "influenced" the test case in previous releases + destroy .f + frame .f -width 20 -height 10 -bg $color + .t window create end -window .f + .t delete 1.0 end +} -body { + frame .f -width 10 -height 6 -bg $color + .t window create 1.0 -window .f -gorp stupid +} -returnCodes error -result {unknown option "-gorp"} +test textWind-2.19 {TkTextWindowCmd procedure} -setup { +# I kept this as it "influenced" the test case in previous releases + destroy .f + frame .f -width 20 -height 10 -bg $color + .t window create end -window .f + .t delete 1.0 end +} -body { + frame .f -width 10 -height 6 -bg $color + catch {.t window create 1.0 -window .f -gorp stupid} + list [winfo exists .f] [.t index 1.end] [catch {.t index .f}] +} -result {0 1.0 1} +test textWind-2.20 {TkTextWindowCmd procedure} -setup { .t delete 1.0 end + destroy .f +} -body { frame .f -width 10 -height 6 -bg $color - list [catch {.t window create 1.0 -window .f -gorp stupid} msg] $msg \ - [winfo exists .f] [.t index 1.end] [catch {.t index .f}] -} {1 {unknown option "-gorp"} 0 1.0 1} -test textWind-2.19 {TkTextWindowCmd procedure} { + .t window create 1.0 -gorp -window .f stupid +} -returnCodes error -result {unknown option "-gorp"} +test textWind-2.21 {TkTextWindowCmd procedure} -setup { .t delete 1.0 end - catch {destroy .f} + destroy .f +} -body { frame .f -width 10 -height 6 -bg $color - list [catch {.t window create 1.0 -gorp -window .f stupid} msg] $msg \ - [winfo exists .f] [.t index 1.end] [catch {.t index .f}] -} {1 {unknown option "-gorp"} 1 1.0 1} -test textWind-2.20 {TkTextWindowCmd procedure} { - list [catch {.t window c} msg] $msg -} {1 {ambiguous window option "c": must be cget, configure, create, or names}} + catch {.t window create 1.0 -gorp -window .f stupid} + list [winfo exists .f] [.t index 1.end] [catch {.t index .f}] +} -result {1 1.0 1} +test textWind-2.22 {TkTextWindowCmd procedure} -setup { + .t delete 1.0 end +} -body { + .t window c +} -returnCodes error -result {ambiguous window option "c": must be cget, configure, create, or names} destroy .f -test textWind-2.21 {TkTextWindowCmd procedure, "names" option} { - list [catch {.t window names foo} msg] $msg -} {1 {wrong # args: should be ".t window names"}} -test textWind-2.22 {TkTextWindowCmd procedure, "names" option} { +test textWind-2.23 {TkTextWindowCmd procedure, "names" option} -setup { + .t delete 1.0 end +} -body { + .t window names foo +} -returnCodes error -result {wrong # args: should be ".t window names"} +test textWind-2.24 {TkTextWindowCmd procedure, "names" option} -setup { .t delete 1.0 end +} -body { .t window names -} {} -test textWind-2.23 {TkTextWindowCmd procedure, "names" option} { +} -result {} +test textWind-2.25 {TkTextWindowCmd procedure, "names" option} -setup { .t delete 1.0 end + destroy .f .f2 .t.f .t.f2 +} -body { foreach i {.f .f2 .t.f .t.f2} { - frame $i -width 20 -height 20 - .t window create end -window $i + frame $i -width 20 -height 20 + .t window create end -window $i } - set result [.t window names] + lsort [.t window names] +} -cleanup { destroy .f .f2 .t.f .t.f2 - lsort $result -} {.f .f2 .t.f .t.f2} +} -result {.f .f2 .t.f .t.f2} -test textWind-3.1 {EmbWinConfigure procedure} { - .t delete 1.0 end + +test textWind-3.1 {EmbWinConfigure procedure} -setup { + destroy .f +} -body { frame .f -width 10 -height 6 -bg $color .t window create 1.0 -window .f - list [catch {.t window configure 1.0 -foo bar} msg] $msg -} {1 {unknown option "-foo"}} -test textWind-3.2 {EmbWinConfigure procedure} {fonts} { - .t delete 1.0 end + .t window configure 1.0 -foo bar +} -cleanup { + destroy .f +} -returnCodes error -result {unknown option "-foo"} +test textWind-3.2 {EmbWinConfigure procedure} -constraints fonts -setup { + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 10 -height 20 -bg $color .t window create 1.3 -window .f update .t window configure 1.3 -window {} update - list [catch {.t index .f} msg] $msg [winfo ismapped .f] [.t bbox 1.4] -} {1 {bad text index ".f"} 0 {26 5 7 13}} -catch {destroy .f} -test textWind-3.3 {EmbWinConfigure procedure} {fonts} { - .t delete 1.0 end + .t index .f +} -cleanup { + destroy .f +} -returnCodes error -result {bad text index ".f"} +test textWind-3.3 {EmbWinConfigure procedure} -constraints fonts -setup { + destroy .f +} -body { + .t insert 1.0 "Some sample text" + frame .f -width 10 -height 20 -bg $color + .t window create 1.3 -window .f + update + .t window configure 1.3 -window {} + update + catch {.t index .f} + list [winfo ismapped .f] [.t bbox 1.4] +} -cleanup { + destroy .f +} -result {0 {26 5 7 13}} +test textWind-3.4 {EmbWinConfigure procedure} -constraints fonts -setup { + destroy .t.f +} -body { .t insert 1.0 "Some sample text" frame .t.f -width 10 -height 20 -bg $color .t window create 1.3 -window .t.f update .t window configure 1.3 -window {} update - list [catch {.t index .t.f} msg] $msg [winfo ismapped .t.f] [.t bbox 1.4] -} {1 {bad text index ".t.f"} 0 {26 5 7 13}} -catch {destroy .t.f} -test textWind-3.4 {EmbWinConfigure procedure} {fonts} { - .t delete 1.0 end + .t index .t.f +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad text index ".t.f"} +test textWind-3.5 {EmbWinConfigure procedure} -constraints fonts -setup { + destroy .t.f +} -body { + .t insert 1.0 "Some sample text" + frame .t.f -width 10 -height 20 -bg $color + .t window create 1.3 -window .t.f + update + .t window configure 1.3 -window {} + update + catch {.t index .t.f} + list [winfo ismapped .t.f] [.t bbox 1.4] +} -cleanup { + destroy .t.f +} -result {0 {26 5 7 13}} +test textWind-3.6 {EmbWinConfigure procedure} -constraints fonts -setup { + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 10 -height 20 -bg $color .t window create 1.3 @@ -254,89 +367,143 @@ test textWind-3.4 {EmbWinConfigure procedure} {fonts} { .t window configure 1.3 -window .f update list [catch {.t index .f} msg] $msg [winfo ismapped .f] [.t bbox 1.4] -} {0 1.3 1 {36 8 7 13}} -test textWind-3.5 {EmbWinConfigure procedure} { - .t delete 1.0 end +} -cleanup { + destroy .f +} -result {0 1.3 1 {36 8 7 13}} +test textWind-3.7 {EmbWinConfigure procedure} -setup { + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f frame .f.f -width 15 -height 20 -bg $color pack .f.f - list [catch {.t window create 1.3 -window .f.f} msg] $msg -} {1 {can't embed .f.f in .t}} -catch {destroy .f} -test textWind-3.6 {EmbWinConfigure procedure} { - .t delete 1.0 end + .t window create 1.3 -window .f.f +} -cleanup { + destroy .f +} -returnCodes error -result {can't embed .f.f in .t} +test textWind-3.8 {EmbWinConfigure procedure} -setup { + destroy .t2 +} -body { .t insert 1.0 "Some sample text" toplevel .t2 -width 20 -height 10 -bg $color .t window create 1.3 - list [catch {.t window configure 1.3 -window .t2} msg] $msg \ - [.t window configure 1.3 -window] -} {1 {can't embed .t2 in .t} {-window {} {} {} {}}} -catch {destroy .t2} -test textWind-3.7 {EmbWinConfigure procedure} { - .t delete 1.0 end + .t window configure 1.3 -window .t2 +} -cleanup { + destroy .t2 +} -returnCodes error -result {can't embed .t2 in .t} +test textWind-3.9 {EmbWinConfigure procedure} -setup { + destroy .t2 +} -body { + .t insert 1.0 "Some sample text" + toplevel .t2 -width 20 -height 10 -bg $color + .t window create 1.3 + catch {.t window configure 1.3 -window .t2} + .t window configure 1.3 -window +} -cleanup { + destroy .t2 +} -result {-window {} {} {} {}} +test textWind-3.10 {EmbWinConfigure procedure} -setup { + .t delete 1.0 end +} -body { .t insert 1.0 "Some sample text" .t window create 1.3 - list [catch {.t window configure 1.3 -window .t} msg] $msg -} {1 {can't embed .t in .t}} -test textWind-3.8 {EmbWinConfigure procedure} { + .t window configure 1.3 -window .t +} -returnCodes error -result {can't embed .t in .t} +test textWind-3.11 {EmbWinConfigure procedure} -setup { + .t delete 1.0 end +} -body { # This test checks for various errors when the text claims # a window away from itself. - .t delete 1.0 end .t insert 1.0 "Some sample text" button .t.b -text "Hello!" .t window create 1.4 -window .t.b .t window create 1.6 -window .t.b update .t index .t.b -} {1.6} +} -result {1.6} + .t delete 1.0 end frame .f -width 10 -height 20 -bg $color .t window create 1.0 -window .f -test textWind-4.1 {AlignParseProc and AlignPrintProc procedures} { +test textWind-4.1 {AlignParseProc and AlignPrintProc procedures} -body { .t window configure 1.0 -align baseline .t window configure 1.0 -align -} {-align {} {} center baseline} -test textWind-4.2 {AlignParseProc and AlignPrintProc procedures} { +} -result {-align {} {} center baseline} +test textWind-4.2 {AlignParseProc and AlignPrintProc procedures} -body { .t window configure 1.0 -align bottom .t window configure 1.0 -align -} {-align {} {} center bottom} -test textWind-4.3 {AlignParseProc and AlignPrintProc procedures} { +} -result {-align {} {} center bottom} +test textWind-4.3 {AlignParseProc and AlignPrintProc procedures} -body { .t window configure 1.0 -align center .t window configure 1.0 -align -} {-align {} {} center center} -test textWind-4.4 {AlignParseProc and AlignPrintProc procedures} { +} -result {-align {} {} center center} +test textWind-4.4 {AlignParseProc and AlignPrintProc procedures} -body { .t window configure 1.0 -align top .t window configure 1.0 -align -} {-align {} {} center top} -test textWind-4.5 {AlignParseProc and AlignPrintProc procedures} { +} -result {-align {} {} center top} +test textWind-4.5 {AlignParseProc and AlignPrintProc procedures} -body { + .t window configure 1.0 -align top + .t window configure 1.0 -align gorp +} -returnCodes error -result {bad align "gorp": must be baseline, bottom, center, or top} +test textWind-4.6 {AlignParseProc and AlignPrintProc procedures} -body { .t window configure 1.0 -align top - list [catch {.t window configure 1.0 -align gorp} msg] $msg \ - [.t window configure 1.0 -align] -} {1 {bad align "gorp": must be baseline, bottom, center, or top} {-align {} {} center top}} + catch {.t window configure 1.0 -align gorp} + .t window configure 1.0 -align +} -result {-align {} {} center top} + -test textWind-5.1 {EmbWinStructureProc procedure} {fonts} { +test textWind-5.1 {EmbWinStructureProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 10 -height 20 -bg $color .t window create 1.2 -window .f update destroy .f - list [catch {.t index .f} msg] $msg [.t bbox 1.2] [.t bbox 1.3] -} {1 {bad text index ".f"} {19 11 0 0} {19 5 7 13}} -test textWind-5.2 {EmbWinStructureProc procedure} {fonts} { + .t index .f +} -returnCodes error -result {bad text index ".f"} +test textWind-5.2 {EmbWinStructureProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { + .t insert 1.0 "Some sample text" + frame .f -width 10 -height 20 -bg $color + .t window create 1.2 -window .f + update + destroy .f + catch {.t index .f} + list [.t bbox 1.2] [.t bbox 1.3] +} -result {{19 11 0 0} {19 5 7 13}} +test textWind-5.3 {EmbWinStructureProc procedure} -constraints fonts -setup { + .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 10 -height 20 -bg $color .t window create 1.2 -align bottom .t window configure 1.2 -window .f update destroy .f - list [catch {.t index .f} msg] $msg [.t bbox 1.2] [.t bbox 1.3] -} {1 {bad text index ".f"} {19 18 0 0} {19 5 7 13}} -test textWind-5.3 {EmbWinStructureProc procedure} {fonts} { + .t index .f +} -returnCodes error -result {bad text index ".f"} +test textWind-5.4 {EmbWinStructureProc procedure} -constraints fonts -setup { + .t delete 1.0 end +} -body { + .t insert 1.0 "Some sample text" + frame .f -width 10 -height 20 -bg $color + .t window create 1.2 -align bottom + .t window configure 1.2 -window .f + update + destroy .f + catch {.t index .f} + list [.t bbox 1.2] [.t bbox 1.3] +} -result {{19 18 0 0} {19 5 7 13}} +test textWind-5.5 {EmbWinStructureProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" .t window create 1.2 -create {frame .f -width 10 -height 20 -bg $color} update @@ -344,21 +511,31 @@ test textWind-5.3 {EmbWinStructureProc procedure} {fonts} { destroy .f update list [catch {.t index .f} msg] $msg [.t bbox 1.2] [.t bbox 1.3] -} {0 1.2 {19 6 20 10} {39 5 7 13}} +} -result {0 1.2 {19 6 20 10} {39 5 7 13}} + -test textWind-6.1 {EmbWinRequestProc procedure} {fonts} { +test textWind-6.1 {EmbWinRequestProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f + set result {} +} -body { .t insert 1.0 "Some sample text" frame .f -width 10 -height 20 -bg $color .t window create 1.2 -window .f - set result {} lappend result [.t bbox 1.2] [.t bbox 1.3] .f configure -width 25 -height 30 lappend result [.t bbox 1.2] [.t bbox 1.3] -} {{19 5 10 20} {29 8 7 13} {19 5 25 30} {44 13 7 13}} +} -cleanup { + destroy .f +} -result {{19 5 10 20} {29 8 7 13} {19 5 25 30} {44 13 7 13}} -test textWind-7.1 {EmbWinLostSlaveProc procedure} {textfonts} { + +test textWind-7.1 {EmbWinLostSlaveProc procedure} -constraints { + textfonts +} -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 10 -height 20 -bg $color .t window create 1.2 -window .f @@ -366,9 +543,15 @@ test textWind-7.1 {EmbWinLostSlaveProc procedure} {textfonts} { place .f -in .t -x 100 -y 50 update list [winfo geom .f] [.t bbox 1.2] -} [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]] -test textWind-7.2 {EmbWinLostSlaveProc procedure} {textfonts} { +} -cleanup { + destroy .f +} -result [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]] +test textWind-7.2 {EmbWinLostSlaveProc procedure} -constraints { + textfonts +} -setup { .t delete 1.0 end + destroy .t.f +} -body { .t insert 1.0 "Some sample text" frame .t.f -width 10 -height 20 -bg $color .t window create 1.2 -window .t.f @@ -376,76 +559,124 @@ test textWind-7.2 {EmbWinLostSlaveProc procedure} {textfonts} { place .t.f -x 100 -y 50 update list [winfo geom .t.f] [.t bbox 1.2] -} [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]] -catch {destroy .f} -catch {destroy .t.f} +} -cleanup { + destroy .t.f +} -result [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]] -test textWind-8.1 {EmbWinDeleteProc procedure} {fonts} { + +test textWind-8.1 {EmbWinDeleteProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 10 -height 20 -bg $color .t window create 1.2 -window .f bind .f <Destroy> {set x destroyed} set x XXX .t delete 1.2 - list $x [.t bbox 1.2] [.t bbox 1.3] [catch {.t index .f} msg] $msg \ - [winfo exists .f] -} {destroyed {19 5 7 13} {26 5 7 13} 1 {bad text index ".f"} 0} + list $x [.t bbox 1.2] [.t bbox 1.3] [winfo exists .f] +} -result {destroyed {19 5 7 13} {26 5 7 13} 0} +test textWind-8.2 {EmbWinDeleteProc procedure} -constraints fonts -setup { + .t delete 1.0 end + destroy .f +} -body { + .t insert 1.0 "Some sample text" + frame .f -width 10 -height 20 -bg $color + .t window create 1.2 -window .f + bind .f <Destroy> {set x destroyed} + set x XXX + .t delete 1.2 + .t index .f +} -returnCodes error -result {bad text index ".f"} -test textWind-9.1 {EmbWinCleanupProc procedure} { + +test textWind-9.1 {EmbWinCleanupProc procedure} -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text\nA second line." frame .f -width 10 -height 20 -bg $color .t window create 2.3 -window .f .t delete 1.5 2.1 .t index .f -} 1.7 +} -cleanup { + destroy .f +} -result {1.7} -proc bgerror args { - global msg - set msg $args -} -test textWind-10.1 {EmbWinLayoutProc procedure} { +test textWind-10.1 {EmbWinLayoutProc procedure} -setup { .t delete 1.0 end - .t insert 1.0 "Some sample text" destroy .f +} -body { + .t insert 1.0 "Some sample text" .t window create 1.5 -create { - frame .f -width 10 -height 20 -bg $color + frame .f -width 10 -height 20 -bg $color } update list [winfo exists .f] [winfo width .f] [winfo height .f] [.t index .f] -} {1 10 20 1.5} -test textWind-10.2 {EmbWinLayoutProc procedure, error in creating window} {fonts} { - .t delete 1.0 end +} -cleanup { + destroy .f +} -result {1 10 20 1.5} +test textWind-10.2 {EmbWinLayoutProc procedure, error in creating window} -constraints { + fonts +} -setup { + .t delete 1.0 end + proc bgerror args { + global msg + set msg $args + } +} -body { .t insert 1.0 "Some sample text" - .t window create 1.5 -create { - error "couldn't create window" + .t window create 1.5 -create { + error "couldn't create window" } set msg xyzzy update list $msg [.t bbox 1.5] -} {{{couldn't create window}} {40 11 0 0}} -test textWind-10.3 {EmbWinLayoutProc procedure, error in creating window} {fonts} { - .t delete 1.0 end +} -cleanup { + rename bgerror {} +} -result {{{couldn't create window}} {40 11 0 0}} +test textWind-10.3 {EmbWinLayoutProc procedure, error in creating window} -constraints { + fonts +} -setup { + .t delete 1.0 end + proc bgerror args { + global msg + set msg $args + } +} -body { .t insert 1.0 "Some sample text" .t window create 1.5 -create { - concat gorp + concat gorp } set msg xyzzy update list $msg [.t bbox 1.5] -} {{{bad window path name "gorp"}} {40 11 0 0}} -proc bgerror args { - global msg - if {[lsearch -exact $msg $args] == -1} { - lappend msg $args +} -cleanup { + rename bgerror {} +} -result {{{bad window path name "gorp"}} {40 11 0 0}} + .t delete 1.0 end + destroy .t.f + proc bgerror args { + global msg + if {[lsearch -exact $msg $args] == -1} { + lappend msg $args + } } -} -test textWind-10.4 {EmbWinLayoutProc procedure, error in creating window} {textfonts} { - .t delete 1.0 end + +test textWind-10.4 {EmbWinLayoutProc procedure, error in creating window} -constraints { + textfonts +} -setup { + .t delete 1.0 end + destroy .t.f + proc bgerror args { + global msg + if {[lsearch -exact $msg $args] == -1} { + lappend msg $args + } + } +} -body { .t insert 1.0 "Some sample text" - catch {destroy .t.f} set msg {} after idle { .t window create 1.5 -create { @@ -455,68 +686,116 @@ test textWind-10.4 {EmbWinLayoutProc procedure, error in creating window} {textf } set count 0 while {([llength $msg] < 2) && ($count < 100)} { - update ; incr count; .t bbox 1.5 ; after 10 + update + incr count + .t bbox 1.5 + after 10 } lappend msg [.t bbox 1.5] [winfo exists .t.f.f] -} [list {{can't embed .t.f.f relative to .t}} {{window name "f" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0] 1] -test textWind-10.4.1 {EmbWinLayoutProc procedure, error in creating window} {textfonts} { - .t delete 1.0 end +} -cleanup { + destroy .t.f + rename bgerror {} +} -result [list {{can't embed .t.f.f relative to .t}} {{window name "f" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0] 1] +test textWind-10.5 {EmbWinLayoutProc procedure, error in creating window} -constraints { + textfonts +} -setup { + .t delete 1.0 end + destroy .t.f + proc bgerror args { + global msg + if {[lsearch -exact $msg $args] == -1} { + lappend msg $args + } + } +} -body { .t insert 1.0 "Some sample text" - catch {destroy .t.f} .t window create 1.5 -create { - frame .t.f - frame .t.f.f -width 10 -height 20 -bg $color + frame .t.f + frame .t.f.f -width 10 -height 20 -bg $color } set msg {} update idletasks lappend msg [winfo exists .t.f.f] -} [list {{can't embed .t.f.f relative to .t}} 1] +} -cleanup { + destroy .t.f + rename bgerror {} +} -result {{{can't embed .t.f.f relative to .t}} 1} catch {destroy .t.f} -test textWind-10.5 {EmbWinLayoutProc procedure, error in creating window} {textfonts} { - .t delete 1.0 end +test textWind-10.6 {EmbWinLayoutProc procedure, error in creating window} -constraints { + textfonts +} -setup { + .t delete 1.0 end + proc bgerror args { + global msg + if {[lsearch -exact $msg $args] == -1} { + lappend msg $args + } + } +} -body { .t insert 1.0 "Some sample text" .t window create 1.5 -create { - concat .t + concat .t } set msg {} update lappend msg [.t bbox 1.5] -} [list {{can't embed .t relative to .t}} [list 40 [expr {11+$fixedDiff/2}] 0 0]] -test textWind-10.6 {EmbWinLayoutProc procedure, error in creating window} {textfonts} { - .t delete 1.0 end +} -cleanup { + rename bgerror {} +} -result [list {{can't embed .t relative to .t}} [list 40 [expr {11+$fixedDiff/2}] 0 0]] +test textWind-10.7 {EmbWinLayoutProc procedure, error in creating window} -constraints { + textfonts +} -setup { + .t delete 1.0 end + destroy .t2 + proc bgerror args { + global msg + if {[lsearch -exact $msg $args] == -1} { + lappend msg $args + } + } +} -body { .t insert 1.0 "Some sample text" - catch {destroy .t2} .t window create 1.5 -create { - toplevel .t2 -width 100 -height 150 - wm geom .t2 +0+0 - concat .t2 + toplevel .t2 -width 100 -height 150 + wm geom .t2 +0+0 + concat .t2 } set msg {} update lappend msg [.t bbox 1.5] -} [list {{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0]] -test textWind-10.6.1 {EmbWinLayoutProc procedure, error in creating window} { - .t delete 1.0 end +} -cleanup { + rename bgerror {} +} -result [list {{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0]] +test textWind-10.8 {EmbWinLayoutProc procedure, error in creating window} -setup { + .t delete 1.0 end + destroy .t2 + proc bgerror args { + global msg + if {[lsearch -exact $msg $args] == -1} { + lappend msg $args + } + } +} -body { .t insert 1.0 "Some sample text" - catch {destroy .t2} .t window create 1.5 -create { - toplevel .t2 -width 100 -height 150 - wm geom .t2 +0+0 - concat .t2 + toplevel .t2 -width 100 -height 150 + wm geom .t2 +0+0 + concat .t2 } set msg {} update set i 0 while {[llength $msg] == 1 && [incr i] < 200} { update } - set msg -} {{{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}}} + return $msg +} -cleanup { + destroy .t2 + rename bgerror {} +} -result {{{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}}} -proc bgerror args { - global msg - set msg $args -} -test textWind-10.7 {EmbWinLayoutProc procedure, steal window from self} { +test textWind-10.9 {EmbWinLayoutProc procedure, steal window from self} -setup { .t delete 1.0 end + destroy .t.b +} -body { .t insert 1.0 ABCDEFGHIJKLMNOP button .t.b -text "Hello!" .t window create 1.5 -window .t.b @@ -524,64 +803,104 @@ test textWind-10.7 {EmbWinLayoutProc procedure, steal window from self} { .t window create 1.3 -create {concat .t.b} update .t index .t.b -} {1.3} -catch {destroy .t2} -test textWind-10.8 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} { - .t configure -wrap char +} -cleanup { + destroy .t.b +} -result {1.3} +test textWind-10.10 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints { + fonts +} -setup { .t delete 1.0 end + destroy .f +} -body { + .t configure -wrap char .t insert 1.0 "Some sample text" frame .f -width 125 -height 20 -bg $color -bd 2 -relief raised .t window create 1.12 -window .f list [.t bbox .f] [.t bbox 1.13] -} {{89 5 126 20} {5 25 7 13}} -test textWind-10.9 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} { - .t configure -wrap char +} -cleanup { + destroy .f +} -result {{89 5 126 20} {5 25 7 13}} +test textWind-10.11 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints { + fonts +} -setup { .t delete 1.0 end + destroy .f +} -body { + .t configure -wrap char .t insert 1.0 "Some sample text" frame .f -width 126 -height 20 -bg $color -bd 2 -relief raised .t window create 1.12 -window .f update list [.t bbox .f] [.t bbox 1.13] -} {{89 5 126 20} {5 25 7 13}} -test textWind-10.10 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} { - .t configure -wrap char +} -cleanup { + destroy .f +} -result {{89 5 126 20} {5 25 7 13}} +test textWind-10.12 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints { + fonts +} -setup { .t delete 1.0 end + destroy .f +} -body { + .t configure -wrap char .t insert 1.0 "Some sample text" frame .f -width 127 -height 20 -bg $color -bd 2 -relief raised .t window create 1.12 -window .f update list [.t bbox .f] [.t bbox 1.13] -} {{5 18 127 20} {132 21 7 13}} -test textWind-10.11 {EmbWinLayoutProc procedure, doesn't fit on line} { - .t configure -wrap none +} -cleanup { + destroy .f +} -result {{5 18 127 20} {132 21 7 13}} +test textWind-10.13 {EmbWinLayoutProc procedure, doesn't fit on line} -setup { .t delete 1.0 end + destroy .f +} -body { + .t configure -wrap none .t insert 1.0 "Some sample text" frame .f -width 130 -height 20 -bg $color -bd 2 -relief raised .t window create 1.12 -window .f update list [.t bbox .f] [.t bbox 1.13] -} {{89 5 126 20} {}} -test textWind-10.12 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} { - .t configure -wrap none +} -cleanup { + destroy .f +} -result {{89 5 126 20} {}} +test textWind-10.14 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints { + fonts +} -setup { .t delete 1.0 end + destroy .f +} -body { + .t configure -wrap none .t insert 1.0 "Some sample text" frame .f -width 130 -height 220 -bg $color -bd 2 -relief raised .t window create 1.12 -window .f update list [.t bbox .f] [.t bbox 1.13] -} {{89 5 126 78} {}} -test textWind-10.13 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} { - .t configure -wrap char +} -cleanup { + destroy .f +} -result {{89 5 126 78} {}} +test textWind-10.15 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints { + fonts +} -setup { .t delete 1.0 end + destroy .f +} -body { + .t configure -wrap char .t insert 1.0 "Some sample text" frame .f -width 250 -height 220 -bg $color -bd 2 -relief raised .t window create 1.12 -window .f update list [.t bbox .f] [.t bbox 1.13] -} {{5 18 210 65} {}} +} -cleanup { + destroy .f +} -result {{5 18 210 65} {}} + -test textWind-11.1 {EmbWinDisplayProc procedure, geometry transforms} { +test textWind-11.1 {EmbWinDisplayProc procedure, geometry transforms} -setup { .t delete 1.0 end + destroy .f + place forget .t + pack .t +} -body { .t insert 1.0 "Some sample text" pack forget .t place .t -x 30 -y 50 @@ -589,11 +908,16 @@ test textWind-11.1 {EmbWinDisplayProc procedure, geometry transforms} { .t window create 1.12 -window .f update winfo geom .f -} {30x20+119+55} -place forget .t -pack .t -test textWind-11.2 {EmbWinDisplayProc procedure, geometry transforms} { - .t delete 1.0 end +} -cleanup { + destroy .f + place forget .t +} -result {30x20+119+55} +test textWind-11.2 {EmbWinDisplayProc procedure, geometry transforms} -setup { + .t delete 1.0 end + destroy .t.f + place forget .t + pack .t +} -body { .t insert 1.0 "Some sample text" pack forget .t place .t -x 30 -y 50 @@ -601,11 +925,17 @@ test textWind-11.2 {EmbWinDisplayProc procedure, geometry transforms} { .t window create 1.12 -window .t.f update winfo geom .t.f -} {30x20+89+5} -place forget .t -pack .t -test textWind-11.3 {EmbWinDisplayProc procedure, configuration optimization} { +} -cleanup { + destroy .t.f + place forget .t + pack .t +} -result {30x20+89+5} +test textWind-11.3 {EmbWinDisplayProc procedure, configuration optimization} -setup { .t delete 1.0 end + destroy .f + place forget .t + pack .t +} -body { .t insert 1.0 "Some sample text" frame .f -width 30 -height 20 -bg $color .t window create 1.12 -window .f @@ -615,10 +945,18 @@ test textWind-11.3 {EmbWinDisplayProc procedure, configuration optimization} { .t delete 1.0 .t insert 1.0 "X" update - set x -} {no configures} -test textWind-11.4 {EmbWinDisplayProc procedure, horizontal scrolling} {fonts} { - .t delete 1.0 end + return $x +} -cleanup { + destroy .f + place forget .t + pack .t +} -result {no configures} +test textWind-11.4 {EmbWinDisplayProc procedure, horizontal scrolling} -constraints { + fonts +} -setup { + .t delete 1.0 end + destroy .f .f2 +} -body { .t insert 1.0 "xyzzy\nFirst window here: " .t configure -wrap none frame .f -width 30 -height 20 -bg $color @@ -631,9 +969,15 @@ test textWind-11.4 {EmbWinDisplayProc procedure, horizontal scrolling} {fonts} { .t xview scroll 5 units update list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] [winfo ismapped .f2] -} {1 30x20+103+18 {103 18 30 20} 0} -test textWind-11.5 {EmbWinDisplayProc procedure, horizontal scrolling} {fonts} { - .t delete 1.0 end +} -cleanup { + destroy .f .f2 +} -result {1 30x20+103+18 {103 18 30 20} 0} +test textWind-11.5 {EmbWinDisplayProc procedure, horizontal scrolling} -constraints { + fonts +} -setup { + .t delete 1.0 end + destroy .f .f2 +} -body { .t insert 1.0 "xyzzy\nFirst window here: " .t configure -wrap none frame .f -width 30 -height 20 -bg $color @@ -647,11 +991,16 @@ test textWind-11.5 {EmbWinDisplayProc procedure, horizontal scrolling} {fonts} { .t xview scroll 25 units update list [winfo ismapped .f] [winfo ismapped .f2] [winfo geom .f2] [.t bbox .f2] -} {0 1 40x10+119+23 {119 23 40 10}} +} -cleanup { + destroy .f .f2 +} -result {0 1 40x10+119+23 {119 23 40 10}} .t configure -wrap char -test textWind-12.1 {EmbWinUndisplayProc procedure, mapping/unmapping} { + +test textWind-12.1 {EmbWinUndisplayProc procedure, mapping/unmapping} -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 30 -height 20 -bg $color .t window create 1.2 -window .f @@ -671,74 +1020,114 @@ test textWind-12.1 {EmbWinUndisplayProc procedure, mapping/unmapping} { .t configure -wrap none .t insert 1.0 "Enough text to make the line run off-screen" update - set x -} {created mapped modified replaced unmapped mapped off-screen unmapped} + return $x +} -cleanup { + destroy .f +} -result {created mapped modified replaced unmapped mapped off-screen unmapped} + -test textWind-13.1 {EmbWinBboxProc procedure} { +test textWind-13.1 {EmbWinBboxProc procedure} -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align top -padx 2 -pady 1 update list [winfo geom .f] [.t bbox .f] -} {5x5+21+6 {21 6 5 5}} -test textWind-13.2 {EmbWinBboxProc procedure} {fonts} { +} -cleanup { + destroy .f +} -result {5x5+21+6 {21 6 5 5}} +test textWind-13.2 {EmbWinBboxProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align center -padx 2 -pady 1 update list [winfo geom .f] [.t bbox .f] -} {5x5+21+9 {21 9 5 5}} -test textWind-13.3 {EmbWinBboxProc procedure} {fonts} { +} -cleanup { + destroy .f +} -result {5x5+21+9 {21 9 5 5}} +test textWind-13.3 {EmbWinBboxProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align baseline -padx 2 -pady 1 update list [winfo geom .f] [.t bbox .f] -} {5x5+21+10 {21 10 5 5}} -test textWind-13.4 {EmbWinBboxProc procedure} {fonts} { +} -cleanup { + destroy .f +} -result {5x5+21+10 {21 10 5 5}} +test textWind-13.4 {EmbWinBboxProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align bottom -padx 2 -pady 1 update list [winfo geom .f] [.t bbox .f] -} {5x5+21+12 {21 12 5 5}} -test textWind-13.5 {EmbWinBboxProc procedure} {fonts} { +} -cleanup { + destroy .f +} -result {5x5+21+12 {21 12 5 5}} +test textWind-13.5 {EmbWinBboxProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align top -padx 2 -pady 1 -stretch 1 update list [winfo geom .f] [.t bbox .f] -} {5x11+21+6 {21 6 5 11}} -test textWind-13.6 {EmbWinBboxProc procedure} {fonts} { +} -cleanup { + destroy .f +} -result {5x11+21+6 {21 6 5 11}} +test textWind-13.6 {EmbWinBboxProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align center -padx 2 -pady 1 -stretch 1 update list [winfo geom .f] [.t bbox .f] -} {5x11+21+6 {21 6 5 11}} -test textWind-13.7 {EmbWinBboxProc procedure} {fonts} { +} -cleanup { + destroy .f +} -result {5x11+21+6 {21 6 5 11}} +test textWind-13.7 {EmbWinBboxProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align baseline -padx 2 -pady 1 -stretch 1 update list [winfo geom .f] [.t bbox .f] -} {5x9+21+6 {21 6 5 9}} -test textWind-13.8 {EmbWinBboxProc procedure} {fonts} { +} -cleanup { + destroy .f +} -result {5x9+21+6 {21 6 5 9}} +test textWind-13.8 {EmbWinBboxProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align bottom -padx 2 -pady 1 -stretch 1 update list [winfo geom .f] [.t bbox .f] -} {5x11+21+6 {21 6 5 11}} -test textWind-13.9 {EmbWinBboxProc procedure, spacing options} {fonts} { +} -cleanup { + destroy .f +} -result {5x11+21+6 {21 6 5 11}} +test textWind-13.9 {EmbWinBboxProc procedure, spacing options} -constraints { + fonts +} -setup { + .t delete 1.0 end + destroy .f +} -body { .t configure -spacing1 5 -spacing3 2 .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -746,11 +1135,15 @@ test textWind-13.9 {EmbWinBboxProc procedure, spacing options} {fonts} { .t window create 1.2 -window .f -align center -padx 2 -pady 1 update list [winfo geom .f] [.t bbox .f] -} {5x5+21+14 {21 14 5 5}} -.t configure -spacing1 0 -spacing2 0 -spacing3 0 +} -cleanup { + destroy .f +} -result {5x5+21+14 {21 14 5 5}} + -test textWind-14.1 {EmbWinDelayedUnmap procedure} { +test textWind-14.1 {EmbWinDelayedUnmap procedure} -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 30 -height 20 -bg $color .t window create 1.2 -window .f @@ -762,11 +1155,14 @@ test textWind-14.1 {EmbWinDelayedUnmap procedure} { .t window configure .f -window {} lappend x updated update - set x -} {modified removed unmapped updated} -catch {destroy .f} -test textWind-14.2 {EmbWinDelayedUnmap procedure} { + return $x +} -cleanup { + destroy .f +} -result {modified removed unmapped updated} +test textWind-14.2 {EmbWinDelayedUnmap procedure} -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 30 -height 20 -bg $color .t window create 1.2 -window .f @@ -778,10 +1174,14 @@ test textWind-14.2 {EmbWinDelayedUnmap procedure} { .t delete .f lappend x updated update - set x -} {modified deleted updated} -test textWind-14.3 {EmbWinDelayedUnmap procedure} { + return $x +} -cleanup { + destroy .f +} -result {modified deleted updated} +test textWind-14.3 {EmbWinDelayedUnmap procedure} -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text\nAnother line\n3\n4\n5\n6\n7\n8\n9" frame .f -width 30 -height 20 -bg $color .t window create 1.2 -window .f @@ -790,9 +1190,13 @@ test textWind-14.3 {EmbWinDelayedUnmap procedure} { set result [winfo ismapped .f] update ; after 10 list $result [winfo ismapped .f] -} {1 0} -test textWind-14.4 {EmbWinDelayedUnmap procedure} { +} -cleanup { + destroy .f +} -result {1 0} +test textWind-14.4 {EmbWinDelayedUnmap procedure} -setup { .t delete 1.0 end + destroy .t.f +} -body { .t insert 1.0 "Some sample text\nAnother line\n3\n4\n5\n6\n7\n8\n9" frame .t.f -width 30 -height 20 -bg $color .t window create 1.2 -window .t.f @@ -801,27 +1205,38 @@ test textWind-14.4 {EmbWinDelayedUnmap procedure} { set result [winfo ismapped .t.f] update list $result [winfo ismapped .t.f] -} {1 0} -catch {destroy .t.f} -catch {destroy .f} +} -cleanup { + destroy .t.f +} -result {1 0} -test textWind-15.1 {TkTextWindowIndex procedure} { - list [catch {.t index .foo} msg] $msg -} {1 {bad text index ".foo"}} -test textWind-15.2 {TkTextWindowIndex procedure} {fonts} { - .t configure -wrap none + +test textWind-15.1 {TkTextWindowIndex procedure} -setup { .t delete 1.0 end +} -body { + .t index .foo +} -returnCodes error -result {bad text index ".foo"} +test textWind-15.2 {TkTextWindowIndex procedure} -constraints fonts -setup { + .t delete 1.0 end + destroy .f +} -body { + .t configure -spacing1 0 -spacing2 0 -spacing3 0 \ + -wrap none .t insert 1.0 "Some sample text" frame .f -width 30 -height 20 -bg $color .t window create 1.6 -window .f .t tag add a 1.1 .t tag add a 1.3 list [.t index .f] [.t bbox 1.7] -} {1.6 {77 8 7 13}} +} -cleanup { + destroy .f +} -result {1.6 {77 8 7 13}} -test textWind-16.1 {EmbWinTextStructureProc procedure} { - .t configure -wrap none + +test textWind-16.1 {EmbWinTextStructureProc procedure} -setup { .t delete 1.0 end + destroy .f +} -body { + .t configure -wrap none .t insert 1.0 "Some sample text" frame .f -width 30 -height 20 -bg $color .t window create 1.6 -window .f @@ -829,11 +1244,15 @@ test textWind-16.1 {EmbWinTextStructureProc procedure} { pack forget .t update winfo ismapped .f -} 0 -pack .t -test textWind-16.2 {EmbWinTextStructureProc procedure} { - .t configure -wrap none - .t delete 1.0 end +} -cleanup { + pack .t +} -result 0 +test textWind-16.2 {EmbWinTextStructureProc procedure} -setup { + .t delete 1.0 end + destroy .f .f2 +} -body { + .t configure -spacing1 0 -spacing2 0 -spacing3 0 \ + -wrap none .t insert 1.0 "Some sample text" frame .f -width 30 -height 20 -bg $color .t window create 1.6 -window .f @@ -844,21 +1263,26 @@ test textWind-16.2 {EmbWinTextStructureProc procedure} { pack .f2 -before .t update lappend result [winfo geom .f] [.t bbox .f] -} {30x20+47+5 {47 5 30 20} 30x20+47+35 {47 5 30 20}} -catch {destroy .f2} -test textWind-16.3 {EmbWinTextStructureProc procedure} { - .t configure -wrap none +} -cleanup { + destroy .f .f2 +} -result {30x20+47+5 {47 5 30 20} 30x20+47+35 {47 5 30 20}} +test textWind-16.3 {EmbWinTextStructureProc procedure} -setup { .t delete 1.0 end +} -body { + .t configure -wrap none .t insert 1.0 "Some sample text" .t window create 1.6 update pack forget .t update -} {} -pack .t -test textWind-16.4 {EmbWinTextStructureProc procedure} { - .t configure -wrap none +} -cleanup { + pack .t +} -result {} +test textWind-16.4 {EmbWinTextStructureProc procedure} -setup { .t delete 1.0 end +} -body { + .t configure -spacing1 0 -spacing2 0 -spacing3 0 \ + -wrap none .t insert 1.0 "Some sample text" frame .t.f -width 30 -height 20 -bg $color .t window create 1.6 -window .t.f @@ -866,13 +1290,15 @@ test textWind-16.4 {EmbWinTextStructureProc procedure} { pack forget .t update list [winfo ismapped .t.f] [.t bbox .t.f] -} {1 {47 5 30 20}} -pack .t +} -cleanup { + pack .t +} -result {1 {47 5 30 20}} -test textWind-17.1 {peer widgets and embedded windows} { - catch {destroy .t .tt} + +test textWind-17.1 {peer widgets and embedded windows} -setup { + destroy .t .tt .f +} -body { pack [text .t] - .t delete 1.0 end .t insert end "Line 1" frame .f -width 20 -height 10 -bg blue .t window create 1.3 -window .f @@ -881,12 +1307,12 @@ test textWind-17.1 {peer widgets and embedded windows} { update ; update destroy .t .tt winfo exists .f -} {0} +} -result {0} -test textWind-17.2 {peer widgets and embedded windows} { - catch {destroy .t .f} +test textWind-17.2 {peer widgets and embedded windows} -setup { + destroy .t .f .tt +} -body { pack [text .t] - .t delete 1.0 end .t insert end "Line 1\nLine 2" frame .f -width 20 -height 10 -bg blue .t window create 1.4 -window .f @@ -897,10 +1323,11 @@ test textWind-17.2 {peer widgets and embedded windows} { .tt.t insert 1.0 "foo" update destroy .tt -} {} +} -result {} -test textWind-17.3 {peer widget and -create} { - catch {destroy .t} +test textWind-17.3 {peer widget and -create} -setup { + destroy .t .tt +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -910,10 +1337,12 @@ test textWind-17.3 {peer widget and -create} { .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue} update destroy .t .tt -} {} +} -result {} -test textWind-17.4 {peer widget deleted one window shouldn't delete others} { - catch {destroy .t .tt} +test textWind-17.4 {peer widget deleted one window shouldn't delete others} -setup { + destroy .t .tt + set res {} +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -922,14 +1351,16 @@ test textWind-17.4 {peer widget deleted one window shouldn't delete others} { .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue} update ; update destroy .tt - set res {} lappend res [.t get 1.2] update lappend res [.t get 1.2] -} {{} {}} +} -cleanup { + destroy .t +} -result {{} {}} -test textWind-17.5 {peer widget window configuration} { - catch {destroy .t .tt} +test textWind-17.5 {peer widget window configuration} -setup { + destroy .t .tt +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -937,13 +1368,14 @@ test textWind-17.5 {peer widget window configuration} { pack [.t peer create .tt.t] .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue} update ; update - set res [list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window]] + list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window] +} -cleanup { destroy .tt .t - set res -} {.t.f .tt.t.f} +} -result {.t.f .tt.t.f} -test textWind-17.6 {peer widget window configuration} { - catch {destroy .t .tt} +test textWind-17.6 {peer widget window configuration} -setup { + destroy .t .tt +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -951,14 +1383,15 @@ test textWind-17.6 {peer widget window configuration} { pack [.t peer create .tt.t] .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue} update ; update - set res [list [.t window configure 1.2 -window] \ - [.tt.t window configure 1.2 -window]] + list [.t window configure 1.2 -window] \ + [.tt.t window configure 1.2 -window] +} -cleanup { destroy .tt .t - set res -} {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} +} -result {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} -test textWind-17.7 {peer widget window configuration} { - catch {destroy .t .tt} +test textWind-17.7 {peer widget window configuration} -setup { + destroy .t .tt +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -966,13 +1399,14 @@ test textWind-17.7 {peer widget window configuration} { pack [.t peer create .tt.t] .t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue] update ; update - set res [list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window]] + list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window] +} -cleanup { destroy .tt .t - set res -} {.t.f {}} +} -result {.t.f {}} -test textWind-17.8 {peer widget window configuration} { - catch {destroy .t .tt} +test textWind-17.8 {peer widget window configuration} -setup { + destroy .t .tt +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -980,14 +1414,15 @@ test textWind-17.8 {peer widget window configuration} { pack [.t peer create .tt.t] .t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue] update ; update - set res [list [.t window configure 1.2 -window] \ - [.tt.t window configure 1.2 -window]] + list [.t window configure 1.2 -window] \ + [.tt.t window configure 1.2 -window] +} -cleanup { destroy .tt .t - set res -} {{-window {} {} {} .t.f} {-window {} {} {} {}}} +} -result {{-window {} {} {} .t.f} {-window {} {} {} {}}} -test textWind-17.8a {peer widget window configuration} { - catch {destroy .t .tt} +test textWind-17.9 {peer widget window configuration} -setup { + destroy .t .tt +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -996,14 +1431,14 @@ test textWind-17.8a {peer widget window configuration} { .t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue] update ; update .tt.t window configure 1.2 -window [frame .tt.t.f -width 10 -height 20 -bg red] - set res [list [.t window configure 1.2 -window] \ - [.tt.t window configure 1.2 -window]] + list [.t window configure 1.2 -window] [.tt.t window configure 1.2 -window] +} -cleanup { destroy .tt .t - set res -} {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} +} -result {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} -test textWind-17.9 {peer widget window configuration} { - catch {destroy .t .tt} +test textWind-17.10 {peer widget window configuration} -setup { + destroy .t .tt +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -1017,15 +1452,14 @@ test textWind-17.9 {peer widget window configuration} { .tt.t window configure 1.2 -window {} .t window configure 1.2 -window {} set res [list [.t window configure 1.2 -window] \ - [.tt.t window configure 1.2 -window]] + [.tt.t window configure 1.2 -window]] update lappend res [.t window configure 1.2 -window] \ - [.tt.t window configure 1.2 -window] + [.tt.t window configure 1.2 -window] +} -cleanup { destroy .tt .t - set res -} {{-window {} {} {} {}} {-window {} {} {} {}} {-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} +} -result {{-window {} {} {} {}} {-window {} {} {} {}} {-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} -catch {destroy .t} option clear # cleanup diff --git a/tests/unixSelect.test b/tests/unixSelect.test index 78decc4..08268b6 100644 --- a/tests/unixSelect.test +++ b/tests/unixSelect.test @@ -9,10 +9,11 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unixSelect.test,v 1.10 2004/06/24 12:45:44 dkf Exp $ +# RCS: @(#) $Id: unixSelect.test,v 1.11 2008/08/30 21:52:26 aniap Exp $ -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands global longValue selValue selInfo @@ -25,7 +26,7 @@ proc handler {type offset count} { lappend selInfo $type $offset $count set numBytes [expr {[string length $selValue] - $offset}] if {$numBytes <= 0} { - return "" + return "" } string range $selValue $offset [expr $numBytes+$offset] } @@ -33,18 +34,18 @@ proc handler {type offset count} { proc errIncrHandler {type offset count} { global selValue selInfo pass if {$offset == 4000} { - if {$pass == 0} { - # Just sizing the selection; don't do anything here. - set pass 1 - } else { - # Fetching the selection; wait long enough to cause a timeout. - after 6000 - } + if {$pass == 0} { + # Just sizing the selection; don't do anything here. + set pass 1 + } else { + # Fetching the selection; wait long enough to cause a timeout. + after 6000 + } } lappend selInfo $type $offset $count set numBytes [expr {[string length $selValue] - $offset}] if {$numBytes <= 0} { - return "" + return "" } string range $selValue $offset [expr $numBytes+$offset] } @@ -59,23 +60,23 @@ proc badHandler {path type offset count} { lappend selInfo $path $type $offset $count set numBytes [expr {[string length $selValue] - $offset}] if {$numBytes <= 0} { - return "" + return "" } string range $selValue $offset [expr $numBytes+$offset] } proc reallyBadHandler {path type offset count} { global selValue selInfo pass if {$offset == 4000} { - if {$pass == 0} { - set pass 1 - } else { - selection handle -type $type $path {} - } + if {$pass == 0} { + set pass 1 + } else { + selection handle -type $type $path {} + } } lappend selInfo $path $type $offset $count set numBytes [expr {[string length $selValue] - $offset}] if {$numBytes <= 0} { - return "" + return "" } string range $selValue $offset [expr $numBytes+$offset] } @@ -91,10 +92,10 @@ after 1500 proc setup {{path .f1} {display {}}} { catch {destroy $path} if {$display == {}} { - frame $path + frame $path } else { - toplevel $path -screen $display - wm geom $path +0+0 + toplevel $path -screen $display + wm geom $path +0+0 } selection own $path } @@ -106,255 +107,358 @@ foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j } -test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} unix { +# ---------------------------------------------------------------------- + +test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} -constraints { + unix +} -setup { + destroy .e setupbg - entry .e - pack .e +} -body { + pack [entry .e] update .e insert 0 [encoding convertfrom identity \u00fcber] .e selection range 0 end - set result [dobg {string bytelength [selection get]}] + dobg {string bytelength [selection get]} +} -cleanup { cleanupbg destroy .e - set result -} {5} -test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} unix { +} -result {5} + +test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 \u00fc\u0444 - .e selection range 0 end + pack [entry .e] + update + .e insert 0 \u00fc\u0444 + .e selection range 0 end } set x [selection get] - cleanupbg list [string equal \u00fc? $x] \ - [string length $x] [string bytelength $x] -} {1 2 3} -test unixSelect-1.4 {TkSelGetSelection procedure: simple i18n text, iso2022} unix { + [string length $x] [string bytelength $x] +} -cleanup { + cleanupbg +} -result {1 2 3} + +test unixSelect-1.3 {TkSelGetSelection procedure: simple i18n text, iso2022} -constraints { + unix +} -setup { setupbg setup +} -body { selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \ - {handler COMPOUND_TEXT} + {handler COMPOUND_TEXT} selection own . set selValue \u00fc\u0444 set selInfo {} set result [dobg { - set x [selection get -type COMPOUND_TEXT] - list [string equal \u00fc\u0444 $x] \ - [string length $x] [string bytelength $x] + set x [selection get -type COMPOUND_TEXT] + list [string equal \u00fc\u0444 $x] \ + [string length $x] [string bytelength $x] }] - cleanupbg lappend result $selInfo -} {1 2 4 {COMPOUND_TEXT 0 4000}} -test unixSelect-1.5 {TkSelGetSelection procedure: INCR i18n text, iso2022} unix { +} -cleanup { + cleanupbg +} -result {1 2 4 {COMPOUND_TEXT 0 4000}} +test unixSelect-1.4 {TkSelGetSelection procedure: INCR i18n text, iso2022} -constraints { + unix +} -setup { + setupbg + setup +} -body { # This test is subtle. The selection ends up getting fetched twice by # Tk: once to compute the length, and again to actually send the data. # The first time through, we don't convert the data to ISO2022, so the # buffer boundaries end up being different in the two passes. - - setupbg - setup selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \ - {handler COMPOUND_TEXT} + {handler COMPOUND_TEXT} selection own . set selValue [string repeat x 3999]\u00fc\u0444[string repeat x 3999] set selInfo {} set result [dobg { - set x [selection get -type COMPOUND_TEXT] - list [string equal \ - [string repeat x 3999]\u00fc\u0444[string repeat x 3999] $x] \ - [string length $x] [string bytelength $x] + set x [selection get -type COMPOUND_TEXT] + list [string equal \ + [string repeat x 3999]\u00fc\u0444[string repeat x 3999] $x] \ + [string length $x] [string bytelength $x] }] - cleanupbg lappend result $selInfo -} {1 8000 8002 {COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3999 COMPOUND_TEXT 7998 4000 COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3998 COMPOUND_TEXT 7997 4000}} -test unixSelect-1.6 {TkSelGetSelection procedure: simple i18n text, iso2022} unix { +} -cleanup { + cleanupbg +} -result {1 8000 8002 {COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3999 COMPOUND_TEXT 7998 4000 COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3998 COMPOUND_TEXT 7997 4000}} + +test unixSelect-1.5 {TkSelGetSelection procedure: simple i18n text, iso2022} -constraints { + unix +} -setup { setupbg setup +} -body { selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \ - {handler COMPOUND_TEXT} + {handler COMPOUND_TEXT} selection own . set selValue \u00fc\u0444 set selInfo {} set result [dobg { - set x [selection get -type COMPOUND_TEXT] - list [string equal \u00fc\u0444 $x] \ - [string length $x] [string bytelength $x] + set x [selection get -type COMPOUND_TEXT] + list [string equal \u00fc\u0444 $x] \ + [string length $x] [string bytelength $x] }] - cleanupbg lappend result $selInfo -} {1 2 4 {COMPOUND_TEXT 0 4000}} -test unixSelect-1.7 {TkSelGetSelection procedure: INCR i18n text} unix { +} -cleanup { + cleanupbg +} -result {1 2 4 {COMPOUND_TEXT 0 4000}} + +test unixSelect-1.6 {TkSelGetSelection procedure: INCR i18n text} -constraints { + unix +} -setup { setupbg +} -body { dobg "entry .e; pack .e; update .e insert 0 \[encoding convertfrom identity \\u00fcber\]$longValue .e selection range 0 end" - set result [string bytelength [selection get]] + string bytelength [selection get] +} -cleanup { cleanupbg - set result -} [expr {5 + [string bytelength $longValue]}] -test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} unix { +} -result [expr {5 + [string bytelength $longValue]}] + +test unixSelect-1.7 {TkSelGetSelection procedure: INCR i18n text} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 [string repeat x 3999]\u00fc - .e selection range 0 end + pack [entry .e] + update + .e insert 0 [string repeat x 3999]\u00fc + .e selection range 0 end } set x [selection get] - cleanupbg list [string equal [string repeat x 3999]\u00fc $x] \ - [string length $x] [string bytelength $x] -} {1 4000 4001} -test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} unix { + [string length $x] [string bytelength $x] +} -cleanup { + cleanupbg +} -result {1 4000 4001} + +test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 \u00fc[string repeat x 3999] - .e selection range 0 end + pack [entry .e] + update + .e insert 0 \u00fc[string repeat x 3999] + .e selection range 0 end } set x [selection get] - cleanupbg list [string equal \u00fc[string repeat x 3999] $x] \ - [string length $x] [string bytelength $x] -} {1 4000 4001} -test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text} unix { + [string length $x] [string bytelength $x] +} -cleanup { + cleanupbg +} -result {1 4000 4001} + +test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 [string repeat x 3999]\u00fc[string repeat x 4000] - .e selection range 0 end + pack [entry .e] + update + .e insert 0 [string repeat x 3999]\u00fc[string repeat x 4000] + .e selection range 0 end } set x [selection get] - cleanupbg list [string equal [string repeat x 3999]\u00fc[string repeat x 4000] $x] \ - [string length $x] [string bytelength $x] -} {1 8000 8001} + [string length $x] [string bytelength $x] +} -cleanup { + cleanupbg +} -result {1 8000 8001} # Now some tests to make sure that the right thing is done when # transferring UTF8 selections, to prevent [Bug 614650] and its ilk # from rearing its ugly head again. -test unixSelect-1.11 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { + +test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 [string repeat x 3999]\u00fc - .e selection range 0 end + pack [entry .e] + update + .e insert 0 [string repeat x 3999]\u00fc + .e selection range 0 end } set x [selection get -type UTF8_STRING] - cleanupbg list [string equal [string repeat x 3999]\u00fc $x] \ - [string length $x] [string bytelength $x] -} {1 4000 4001} -test unixSelect-1.12 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { + [string length $x] [string bytelength $x] +} -cleanup { + cleanupbg +} -result {1 4000 4001} + +test unixSelect-1.11 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 \u00fc[string repeat x 3999] - .e selection range 0 end + pack [entry .e] + update + .e insert 0 \u00fc[string repeat x 3999] + .e selection range 0 end } set x [selection get -type UTF8_STRING] - cleanupbg list [string equal \u00fc[string repeat x 3999] $x] \ - [string length $x] [string bytelength $x] -} {1 4000 4001} -test unixSelect-1.13 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { + [string length $x] [string bytelength $x] +} -cleanup { + cleanupbg +} -result {1 4000 4001} + +test unixSelect-1.12 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 [string repeat x 3999]\u00fc[string repeat x 4000] - .e selection range 0 end + pack [entry .e] + update + .e insert 0 [string repeat x 3999]\u00fc[string repeat x 4000] + .e selection range 0 end } set x [selection get -type UTF8_STRING] - cleanupbg list [string equal [string repeat x 3999]\u00fc[string repeat x 4000] $x] \ - [string length $x] [string bytelength $x] -} {1 8000 8001} -test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} unix { + [string length $x] [string bytelength $x] +} -cleanup { + cleanupbg +} -result {1 8000 8001} + +test unixSelect-1.13 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints { + unix +} -setup { + destroy .e setupbg - entry .e - pack .e +} -body { + pack [entry .e] update .e insert 0 [encoding convertfrom identity \u00fcber\u0444] .e selection range 0 end - set result [dobg {string bytelength [selection get -type UTF8_STRING]}] - cleanupbg + dobg {string bytelength [selection get -type UTF8_STRING]} +} -cleanup { destroy .e - set result -} {5} -test unixSelect-1.15 {TkSelGetSelection procedure: simple i18n text, utf-8} unix { + cleanupbg +} -result {5} + +test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 \u00fc\u0444 - .e selection range 0 end + pack [entry .e] + update + .e insert 0 \u00fc\u0444 + .e selection range 0 end } set x [selection get -type UTF8_STRING] - cleanupbg list [string equal \u00fc\u0444 $x] \ - [string length $x] [string bytelength $x] -} {1 2 4} -test unixSelect-1.16 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { + [string length $x] [string bytelength $x] +} -cleanup { + cleanupbg +} -result {1 2 4} + +test unixSelect-1.15 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 [string repeat [string repeat \u00c4\u00e4 50]\n 21] - .e selection range 0 end + pack [entry .e] + update + .e insert 0 [string repeat [string repeat \u00c4\u00e4 50]\n 21] + .e selection range 0 end } set x [selection get -type UTF8_STRING] - cleanupbg list [string equal [string repeat [string repeat \u00c4\u00e4 50]\n 21] $x] \ - [string length $x] [string bytelength $x] -} {1 2121 4221} -test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { + [string length $x] [string bytelength $x] +} -cleanup { + cleanupbg +} -result {1 2121 4221} + +test unixSelect-1.16 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 i[string repeat [string repeat \u00c4\u00e4 50]\n 21] - .e selection range 0 end + pack [entry .e] + update + .e insert 0 i[string repeat [string repeat \u00c4\u00e4 50]\n 21] + .e selection range 0 end } set x [selection get -type UTF8_STRING] - cleanupbg list [string equal i[string repeat [string repeat \u00c4\u00e4 50]\n 21] $x] \ - [string length $x] [string bytelength $x] -} {1 2122 4222} -test unixSelect-1.18 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { + [string length $x] [string bytelength $x] +} -cleanup { + cleanupbg +} -result {1 2122 4222} + +test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - text .t; pack .t; update - .t insert 1.0 [string repeat [string repeat \u00c4\u00e4 50]\n 21] - # Has to be selected in a separate stage - .t tag add sel 1.0 21.end+1c + pack [text .t] + update + .t insert 1.0 [string repeat [string repeat \u00c4\u00e4 50]\n 21] + # Has to be selected in a separate stage + .t tag add sel 1.0 21.end+1c } after 10 set x [selection get -type UTF8_STRING] - cleanupbg list [string equal [string repeat [string repeat \u00c4\u00e4 50]\n 21] $x] \ - [string length $x] [string bytelength $x] -} {1 2121 4221} -test unixSelect-1.19 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { + [string length $x] [string bytelength $x] +} -cleanup { + cleanupbg +} -result {1 2121 4221} + +test unixSelect-1.18 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - text .t; pack .t; update - .t insert 1.0 i[string repeat [string repeat \u00c4\u00e4 50]\n 21] - # Has to be selected in a separate stage - .t tag add sel 1.0 21.end+1c + pack [text .t] + update + .t insert 1.0 i[string repeat [string repeat \u00c4\u00e4 50]\n 21] + # Has to be selected in a separate stage + .t tag add sel 1.0 21.end+1c } after 10 set x [selection get -type UTF8_STRING] - cleanupbg list [string equal i[string repeat [string repeat \u00c4\u00e4 50]\n 21] $x] \ - [string length $x] [string bytelength $x] -} {1 2122 4222} -test unixSelect-1.20 {Automatic UTF8_STRING support for selection handle} unix { + [string length $x] [string bytelength $x] +} -cleanup { + cleanupbg +} -result {1 2122 4222} + +test unixSelect-1.19 {Automatic UTF8_STRING support for selection handle} -constraints { + unix +} -setup { + destroy .l +} -body { # See Bug #666346 "Selection handling crashes under KDE 3.0" - label .l + label .l selection handle .l [list handler STRING] set selValue "This is the selection value" selection own .l - set result [selection get -type UTF8_STRING] + selection get -type UTF8_STRING +} -cleanup { destroy .l - set result -} "This is the selection value" +} -result {This is the selection value} # cleanup cleanupTests diff --git a/tests/visual.test b/tests/visual.test index b54a8e6..61f5001 100644 --- a/tests/visual.test +++ b/tests/visual.test @@ -7,10 +7,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: visual.test,v 1.10 2004/06/17 22:38:57 dkf Exp $ +# RCS: @(#) $Id: visual.test,v 1.11 2008/08/30 21:52:26 aniap Exp $ -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands update @@ -20,7 +21,7 @@ update # use up all the slots in the colormap. # # Arguments: -# w - Name of toplevel window to create. +# w - Name of toplevel window to create. proc eatColors {w} { catch {destroy $w} @@ -29,12 +30,12 @@ proc eatColors {w} { 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 - } + 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 } @@ -45,14 +46,14 @@ proc eatColors {w} { # 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. +# 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) + && ([lindex $vals 2]/256 == $blue) } # If more than one visual type is available for the screen, pick one @@ -63,233 +64,500 @@ set avail [winfo visualsavailable .] set other {} if {[llength $avail] > 1} { foreach visual $avail { - if {$visual != $default} { - set other $visual - break - } + if {$visual != $default} { + set other $visual + break + } } } testConstraint haveOtherVisual [expr {$other ne ""}] testConstraint havePseudocolorVisual [string match *pseudocolor* $avail] testConstraint haveMultipleVisuals [expr {[llength $avail] > 1}] -test visual-1.1 {Tk_GetVisual, copying from other window} { - list [catch {toplevel .t -visual .foo.bar} msg] $msg -} {1 {bad window path name ".foo.bar"}} -test visual-1.2 {Tk_GetVisual, copying from other window} {haveOtherVisual nonPortable} { - catch {destroy .t1} - catch {destroy .t2} +# ---------------------------------------------------------------------- + +test visual-1.1 {Tk_GetVisual, copying from other window} -body { + toplevel .t -visual .foo.bar +} -returnCodes error -result {bad window path name ".foo.bar"} +test visual-1.2 {Tk_GetVisual, copying from other window} -constraints { + haveOtherVisual nonPortable +} -setup { + deleteWindows +} -body { toplevel .t1 -width 250 -height 100 -visual $other wm geom .t1 +0+0 toplevel .t2 -width 200 -height 80 -visual .t1 wm geom .t2 +5+5 concat "[winfo visual .t2] [winfo depth .t2]" -} $other -test visual-1.3 {Tk_GetVisual, copying from other window} haveOtherVisual { - catch {destroy .t1} - catch {destroy .t2} +} -cleanup { + deleteWindows +} -result $other +test visual-1.3 {Tk_GetVisual, copying from other window} -constraints { + haveOtherVisual +} -setup { + deleteWindows +} -body { toplevel .t1 -width 250 -height 100 -visual $other wm geom .t1 +0+0 toplevel .t2 -width 200 -height 80 -visual . wm geom .t2 +5+5 concat "[winfo visual .t2] [winfo depth .t2]" -} $default +} -cleanup { + deleteWindows +} -result $default # Make sure reference count is incremented when copying visual (the # following test will cause the colormap to be freed prematurely if # the reference count isn't incremented). -test visual-1.4 {Tk_GetVisual, colormap reference count} haveOtherVisual { - catch {destroy .t1} - catch {destroy .t2} +test visual-1.4 {Tk_GetVisual, colormap reference count} -constraints { + haveOtherVisual +} -setup { + deleteWindows +} -body { toplevel .t1 -width 250 -height 100 -visual $other wm geom .t1 +0+0 - set result [list [catch {toplevel .t2 -gorp 80 -visual .t1} msg] $msg] + set result [toplevel .t2 -gorp 80 -visual .t1] update - set result -} {1 {unknown option "-gorp"}} -test visual-1.5 {Tk_GetVisual, default colormap} { - catch {destroy .t1} + return $result +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown option "-gorp"} +test visual-1.5 {Tk_GetVisual, default colormap} -setup { + deleteWindows +} -body { toplevel .t1 -width 250 -height 100 -visual default wm geometry .t1 +0+0 update concat "[winfo visual .t1] [winfo depth .t1]" -} $default +} -cleanup { + deleteWindows +} -result $default + + +test visual-2.1 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.2 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.3 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.4 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.5 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.6 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.7 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.8 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.9 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.10 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.11 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.12 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.13 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.14 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.15 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.16 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.17 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 32} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 32} -set i 1 -foreach visual $avail { - test visual-2.$i {Tk_GetVisual, different visual types} {nonPortable} { - catch {destroy .t1} - toplevel .t1 -width 250 -height 100 -visual $visual - wm geometry .t1 +0+0 - update - concat "[winfo visual .t1] [winfo depth .t1]" - } $visual - incr i -} -test visual-3.1 {Tk_GetVisual, parsing visual string} { - catch {destroy .t1} +test visual-3.1 {Tk_GetVisual, parsing visual string} -setup { + deleteWindows +} -body { toplevel .t1 -width 250 -height 100 \ - -visual "[winfo visual .][winfo depth .]" + -visual "[winfo visual .][winfo depth .]" wm geometry .t1 +0+0 update concat "[winfo visual .t1] [winfo depth .t1]" -} $default -test visual-3.2 {Tk_GetVisual, parsing visual string} { - catch {destroy .t1} - list [catch { - toplevel .t1 -width 250 -height 100 -visual goop20 - wm geometry .t1 +0+0 - } msg] $msg -} {1 {unknown or ambiguous visual name "goop20": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}} -test visual-3.3 {Tk_GetVisual, parsing visual string} { - catch {destroy .t1} - list [catch { - toplevel .t1 -width 250 -height 100 -visual d - wm geometry .t1 +0+0 - } msg] $msg -} {1 {unknown or ambiguous visual name "d": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}} -test visual-3.4 {Tk_GetVisual, parsing visual string} { - catch {destroy .t1} - list [catch { - toplevel .t1 -width 250 -height 100 -visual static - wm geometry .t1 +0+0 - } msg] $msg -} {1 {unknown or ambiguous visual name "static": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}} -test visual-3.5 {Tk_GetVisual, parsing visual string} { - catch {destroy .t1} - list [catch { - toplevel .t1 -width 250 -height 100 -visual "pseudocolor 48x" - wm geometry .t1 +0+0 - } msg] $msg -} {1 {expected integer but got "48x"}} +} -cleanup { + deleteWindows +} -result $default +test visual-3.2 {Tk_GetVisual, parsing visual string} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual goop20 + wm geometry .t1 +0+0 +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown or ambiguous visual name "goop20": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default} +test visual-3.3 {Tk_GetVisual, parsing visual string} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual d + wm geometry .t1 +0+0 +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown or ambiguous visual name "d": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default} +test visual-3.4 {Tk_GetVisual, parsing visual string} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual static + wm geometry .t1 +0+0 +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown or ambiguous visual name "static": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default} +test visual-3.5 {Tk_GetVisual, parsing visual string} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual "pseudocolor 48x" + wm geometry .t1 +0+0 +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "48x"} -test visual-4.1 {Tk_GetVisual, numerical visual id} -setup { - catch {destroy .t1} - catch {destroy .t2} - catch {destroy .t3} + +test visual-4.1 {Tk_GetVisual, numerical visual id} -constraints { + haveOtherVisual nonPortable +} -setup { + deleteWindows toplevel .t1 -width 250 -height 100 -visual $other wm geom .t1 +0+0 toplevel .t2 -width 200 -height 80 -visual [winfo visual .] wm geom .t2 +5+5 toplevel .t3 -width 150 -height 250 -visual [winfo visual .t1] wm geom .t3 +10+10 -} -constraints {haveOtherVisual nonPortable} -body { +} -body { set v1 [list [winfo visualid .t2] [winfo visualid .t3]] set v2 [list [winfo visualid .] [winfo visualid .t1]] expr {$v1 eq $v2 ? "OK" : "[list $v1] ne [list $v2]"} -} -result OK -cleanup { - destroy .t1 .t2 .t3 -} -test visual-4.2 {Tk_GetVisual, numerical visual id} { - catch {destroy .t1} - list [catch {toplevel .t1 -visual 12xyz} msg] $msg -} {1 {bad X identifier for visual: "12xyz"}} -test visual-4.3 {Tk_GetVisual, numerical visual id} { - catch {destroy .t1} - list [catch {toplevel .t1 -visual 1291673} msg] $msg -} {1 {couldn't find an appropriate visual}} +} -cleanup { + deleteWindows +} -result OK +test visual-4.2 {Tk_GetVisual, numerical visual id} -setup { + deleteWindows +} -body { + toplevel .t1 -visual 12xyz +} -cleanup { + deleteWindows +} -returnCodes error -result {bad X identifier for visual: "12xyz"} +test visual-4.3 {Tk_GetVisual, numerical visual id} -setup { + deleteWindows +} -body { + toplevel .t1 -visual 1291673 +} -cleanup { + deleteWindows +} -returnCodes error -result {couldn't find an appropriate visual} + -test visual-5.1 {Tk_GetVisual, no matching visual} !havePseudocolorVisual { - catch {destroy .t1} - list [catch { - toplevel .t1 -width 250 -height 100 -visual "pseudocolor 8" - wm geometry .t1 +0+0 - } msg] $msg -} {1 {couldn't find an appropriate visual}} +test visual-5.1 {Tk_GetVisual, no matching visual} -constraints { + !havePseudocolorVisual +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual "pseudocolor 8" + wm geometry .t1 +0+0 +} -cleanup { + deleteWindows +} -returnCodes error -result {couldn't find an appropriate visual} -test visual-6.1 {Tk_GetVisual, no matching visual} {havePseudocolorVisual haveMultipleVisuals nonPortable} { - catch {destroy .t1} + +test visual-6.1 {Tk_GetVisual, no matching visual} -constraints { + havePseudocolorVisual haveMultipleVisuals nonPortable +} -setup { + deleteWindows +} -body { toplevel .t1 -width 250 -height 100 -visual "best" wm geometry .t1 +0+0 update winfo visual .t1 -} {pseudocolor} +} -cleanup { + deleteWindows +} -result {pseudocolor} + # These tests are non-portable due to variations in how many colors # are already in use on the screen. - -if {[testConstraint defaultPseudocolor8]} { +test visual-7.1 {Tk_GetColormap, "new"} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { eatColors .t1 -} -test visual-7.1 {Tk_GetColormap, "new"} {defaultPseudocolor8 nonPortable} { toplevel .t2 -width 30 -height 20 wm geom .t2 +0+0 update colorsFree .t2 -} {0} -test visual-7.2 {Tk_GetColormap, "new"} {defaultPseudocolor8 nonPortable} { - catch {destroy .t2} +} -cleanup { + deleteWindows +} -result {0} +test visual-7.2 {Tk_GetColormap, "new"} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { + eatColors .t1 toplevel .t2 -width 30 -height 20 -colormap new wm geom .t2 +0+0 update colorsFree .t2 -} {1} -test visual-7.3 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 nonPortable} { - catch {destroy .t2} +} -cleanup { + deleteWindows +} -result {1} +test visual-7.3 {Tk_GetColormap, copy from other window} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { + eatColors .t1 toplevel .t3 -width 400 -height 50 -colormap new wm geom .t3 +0+0 - catch {destroy .t2} toplevel .t2 -width 30 -height 20 -colormap .t3 wm geom .t2 +0+0 update destroy .t3 colorsFree .t2 -} {1} -test visual-7.4 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 nonPortable} { - catch {destroy .t2} +} -cleanup { + deleteWindows +} -result {1} +test visual-7.4 {Tk_GetColormap, copy from other window} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { + eatColors .t1 toplevel .t3 -width 400 -height 50 -colormap new wm geom .t3 +0+0 - catch {destroy .t2} toplevel .t2 -width 30 -height 20 -colormap . wm geom .t2 +0+0 update destroy .t3 colorsFree .t2 -} {0} -test visual-7.5 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 nonPortable} { - catch {destroy .t1} - list [catch { - toplevel .t1 -width 400 -height 50 -colormap .choke.lots - } msg] $msg -} {1 {bad window path name ".choke.lots"}} -test visual-7.6 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 haveOtherVisual nonPortable} { - catch {destroy .t1} - catch {destroy .t2} +} -cleanup { + deleteWindows +} -result {0} +test visual-7.5 {Tk_GetColormap, copy from other window} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 400 -height 50 -colormap .choke.lots +} -cleanup { + deleteWindows +} -returnCodes error -result {bad window path name ".choke.lots"} +test visual-7.6 {Tk_GetColormap, copy from other window} -constraints { + defaultPseudocolor8 haveOtherVisual nonPortable +} -setup { + deleteWindows +} -body { toplevel .t1 -width 300 -height 150 -visual $other wm geometry .t1 +0+0 - list [catch {toplevel .t2 -width 400 -height 50 -colormap .t1} msg] $msg -} {1 {can't use colormap for .t1: incompatible visuals}} -if {[testConstraint defaultPseudocolor8]} { - catch {destroy .t1} - catch {destroy .t2} -} + toplevel .t2 -width 400 -height 50 -colormap .t1 +} -cleanup { + deleteWindows +} -returnCodes error -result {can't use colormap for .t1: incompatible visuals} + -test visual-8.1 {Tk_FreeColormap procedure} { +test visual-8.1 {Tk_FreeColormap procedure} -setup { deleteWindows +} -body { toplevel .t1 -width 300 -height 180 -colormap new wm geometry .t1 +0+0 foreach i {.t2 .t3 .t4} { - toplevel $i -width 250 -height 150 -colormap .t1 - wm geometry $i +0+0 + toplevel $i -width 250 -height 150 -colormap .t1 + wm geometry $i +0+0 } destroy .t1 destroy .t3 destroy .t4 update -} {} -test visual-8.2 {Tk_FreeColormap procedure} haveOtherVisual { +} -cleanup { deleteWindows +} -result {} +test visual-8.2 {Tk_FreeColormap procedure} -constraints haveOtherVisual -setup { + deleteWindows +} -body { toplevel .t1 -width 300 -height 180 -visual $other wm geometry .t1 +0+0 foreach i {.t2 .t3 .t4} { - toplevel $i -width 250 -height 150 -visual $other - wm geometry $i +0+0 + toplevel $i -width 250 -height 150 -visual $other + wm geometry $i +0+0 } destroy .t2 destroy .t3 destroy .t4 update -} {} +} -cleanup { + deleteWindows +} -result {} + deleteWindows rename eatColors {} @@ -298,3 +566,7 @@ rename colorsFree {} # cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End:
\ No newline at end of file diff --git a/tests/visual_bb.test b/tests/visual_bb.test index a465d64..729a3fe 100644 --- a/tests/visual_bb.test +++ b/tests/visual_bb.test @@ -6,12 +6,14 @@ # at the window to make sure it appears as expected. Individual tests # are kept in separate ".tcl" files in this directory. # -# RCS: @(#) $Id: visual_bb.test,v 1.8 2003/04/01 21:07:00 dgp Exp $ +# RCS: @(#) $Id: visual_bb.test,v 1.9 2008/08/30 21:52:26 aniap Exp $ -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands + set auto_path ". $auto_path" wm title . "Visual Tests for Tk" @@ -23,8 +25,8 @@ proc runTest {file} { global testNum test "2.$testNum" "testing $file" {userInteraction} { - uplevel \#0 source [file join [testsDirectory] $file] - concat "" + uplevel \#0 source [file join [testsDirectory] $file] + concat "" } {} incr testNum } @@ -40,7 +42,9 @@ proc end {} { set ::EndOfVisualTests 1 } -test 1.1 "running visual tests" {userInteraction} { +# ---------------------------------------------------------------------- + +test 1.1 {running visual tests} -constraints userInteraction -body { #------------------------------------------------------- # The code below create the main window, consisting of a # menu bar and a message explaining the basic operation @@ -49,8 +53,8 @@ test 1.1 "running visual tests" {userInteraction} { frame .menu -relief raised -borderwidth 1 message .msg -font {Times 18} -relief raised -width 4i \ - -borderwidth 1 -text "This application provides a collection of visual tests for the Tk toolkit. Each menu entry invokes a test, which displays information on the screen. You can then verify visually that the information is being displayed in the correct way. The tests under the \"Postscript\" menu exercise the Postscript-generation capabilities of canvas widgets." - + -borderwidth 1 -text "This application provides a collection of visual tests for the Tk toolkit. Each menu entry invokes a test, which displays information on the screen. You can then verify visually that the information is being displayed in the correct way. The tests under the \"Postscript\" menu exercise the Postscript-generation capabilities of canvas widgets." + pack .menu -side top -fill x pack .msg -side bottom -expand yes -fill both @@ -62,40 +66,40 @@ test 1.1 "running visual tests" {userInteraction} { menubutton .menu.file -text "File" -menu .menu.file.m menu .menu.file.m .menu.file.m add command -label "Quit" -command end - + menubutton .menu.group1 -text "Group 1" -menu .menu.group1.m menu .menu.group1.m .menu.group1.m add command -label "Canvas arcs" -command {runTest arc.tcl} .menu.group1.m add command -label "Beveled borders in text widgets" \ - -command {runTest bevel.tcl} + -command {runTest bevel.tcl} .menu.group1.m add command -label "Colormap management" \ - -command {runTest cmap.tcl} + -command {runTest cmap.tcl} .menu.group1.m add command -label "Label/button geometry" \ - -command {runTest butGeom.tcl} + -command {runTest butGeom.tcl} .menu.group1.m add command -label "Label/button colors" \ - -command {runTest butGeom2.tcl} - + -command {runTest butGeom2.tcl} + menubutton .menu.ps -text "Canvas Postscript" -menu .menu.ps.m menu .menu.ps.m .menu.ps.m add command -label "Rectangles and other graphics" \ - -command {runTest canvPsGrph.tcl} + -command {runTest canvPsGrph.tcl} .menu.ps.m add command -label "Text" \ - -command {runTest canvPsText.tcl} + -command {runTest canvPsText.tcl} .menu.ps.m add command -label "Bitmaps" \ - -command {runTest canvPsBmap.tcl} + -command {runTest canvPsBmap.tcl} .menu.ps.m add command -label "Images" \ - -command {runTest canvPsImg.tcl} + -command {runTest canvPsImg.tcl} .menu.ps.m add command -label "Arcs" \ - -command {runTest canvPsArc.tcl} - + -command {runTest canvPsArc.tcl} + pack .menu.file .menu.group1 .menu.ps -side left -padx 1m - + # Set up for keyboard-based menu traversal - + bind . <Any-FocusIn> { - if {("%d" == "NotifyVirtual") && ("%m" == "NotifyNormal")} { - focus .menu - } + if {("%d" == "NotifyVirtual") && ("%m" == "NotifyNormal")} { + focus .menu + } } tk_menuBar .menu .menu.file .menu.group1 .menu.ps @@ -105,7 +109,7 @@ test 1.1 "running visual tests" {userInteraction} { bind Canvas <1> {%W delete [%W find closest %x %y]} concat "" -} {} +} -result {} if {![testConstraint userInteraction]} { cleanupTests diff --git a/tests/winButton.test b/tests/winButton.test index 1ffcc2f..a383433 100644 --- a/tests/winButton.test +++ b/tests/winButton.test @@ -8,79 +8,93 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winButton.test,v 1.12 2007/05/11 12:10:19 patthoyts Exp $ +# RCS: @(#) $Id: winButton.test,v 1.13 2008/08/30 21:52:26 aniap Exp $ -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands proc bogusTrace args { error "trace aborted" } -catch {unset value} -catch {unset value2} option clear eval image delete [image names] -if {[testConstraint testImageType]} { - image create test image1 -} -label .l -text Label -button .b -text Button -checkbutton .c -text Checkbutton -radiobutton .r -text Radiobutton -pack .l .b .c .r -update -test winbutton-1.1 {TkpComputeButtonGeometry procedure} {testImageType win} { +# ---------------------------------------------------------------------- + +test winbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints { + testImageType win +} -setup { deleteWindows +} -body { image create test image1 image1 changed 0 0 0 0 60 40 label .b1 -image image1 -bd 4 -padx 0 -pady 2 button .b2 -image image1 -bd 4 -padx 0 -pady 2 - checkbutton .b3 -image image1 -bd 4 -padx 1 -pady 1 -font {{MS Sans Serif} 8} - radiobutton .b4 -image image1 -bd 4 -padx 2 -pady 0 -font {{MS Sans Serif} 8} + checkbutton .b3 -image image1 -bd 4 -padx 1 -pady 1 \ + -font {{MS Sans Serif} 8} + radiobutton .b4 -image image1 -bd 4 -padx 2 -pady 0 \ + -font {{MS Sans Serif} 8} pack .b1 .b2 .b3 .b4 update # with patch 463234 with native L&F enabled, this returns: # {68 48 70 50 88 50 88 50} list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {68 48 70 50 90 52 90 52} -test winbutton-1.2 {TkpComputeButtonGeometry procedure} win { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { deleteWindows + image delete image1 +} -result {68 48 70 50 90 52 90 52} + +test winbutton-1.2 {TkpComputeButtonGeometry procedure} -constraints win -setup { + deleteWindows +} -body { label .b1 -bitmap question -bd 3 -padx 0 -pady 2 button .b2 -bitmap question -bd 3 -padx 0 -pady 2 - checkbutton .b3 -bitmap question -bd 3 -padx 1 -pady 1 -font {{MS Sans Serif} 8} - radiobutton .b4 -bitmap question -bd 3 -padx 2 -pady 0 -font {{MS Sans Serif} 8} + checkbutton .b3 -bitmap question -bd 3 -padx 1 -pady 1 \ + -font {{MS Sans Serif} 8} + radiobutton .b4 -bitmap question -bd 3 -padx 2 -pady 0 \ + -font {{MS Sans Serif} 8} pack .b1 .b2 .b3 .b4 update # with patch 463234 with native L&F enabled, this returns: # {23 33 25 35 43 35 43 35} list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {23 33 25 35 45 37 45 37} -test winbutton-1.3 {TkpComputeButtonGeometry procedure} win { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { deleteWindows +} -result {23 33 25 35 45 37 45 37} + +test winbutton-1.3 {TkpComputeButtonGeometry procedure} -constraints win -setup { + deleteWindows +} -body { label .b1 -bitmap question -bd 3 -highlightthickness 4 button .b2 -bitmap question -bd 3 -highlightthickness 0 checkbutton .b3 -bitmap question -bd 3 -highlightthickness 1 \ - -indicatoron 0 + -indicatoron 0 radiobutton .b4 -bitmap question -bd 3 -indicatoron false pack .b1 .b2 .b3 .b4 update # with patch 463234 with native L&F enabled, this returns: # {31 41 23 33 25 35 25 35} list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {31 41 23 33 27 37 27 37} -test winbutton-1.4 {TkpComputeButtonGeometry procedure} {win nonPortable} { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { + deleteWindows +} -result {31 41 23 33 27 37 27 37} + +test winbutton-1.4 {TkpComputeButtonGeometry procedure} -constraints { + win nonPortable +} -setup { deleteWindows +} -body { label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -font {{MS Sans Serif} 8} button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -font {{MS Sans Serif} 8} checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -font {{MS Sans Serif} 8} @@ -88,26 +102,46 @@ test winbutton-1.4 {TkpComputeButtonGeometry procedure} {win nonPortable} { pack .b1 .b2 .b3 .b4 update list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {58 24 67 33 88 30 90 28} -test winbutton-1.5 {TkpComputeButtonGeometry procedure} {win nonPortable} { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { + deleteWindows +} -result {58 24 67 33 88 30 90 28} + +test winbutton-1.5 {TkpComputeButtonGeometry procedure} -constraints { + win nonPortable +} -setup { deleteWindows - label .l1 -text "This is a long string that will wrap around on several lines.\n\nIt also has a blank line (above)." -wraplength 1.5i -padx 0 -pady 0 +} -body { + label .l1 -wraplength 1.5i -padx 0 -pady 0 \ + -text "This is a long string that will wrap around on several lines.\n\nIt also has a blank line (above)." pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] -} {178 84} -test winbutton-1.6 {TkpComputeButtonGeometry procedure} {win nonPortable} { +} -cleanup { deleteWindows - label .l1 -text "This is a long string without wrapping.\n\nIt also has a blank line (above)." -padx 0 -pady 0 +} -result {178 84} + +test winbutton-1.6 {TkpComputeButtonGeometry procedure} -constraints { + win nonPortable +} -setup { + deleteWindows +} -body { + label .l1 -padx 0 -pady 0 \ + -text "This is a long string without wrapping.\n\nIt also has a blank line (above)." pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] -} {222 52} -test winbutton-1.7 {TkpComputeButtonGeometry procedure} {win nonPortable} { +} -cleanup { + deleteWindows +} -result {222 52} + +test winbutton-1.7 {TkpComputeButtonGeometry procedure} -constraints { + win nonPortable +} -setup { deleteWindows +} -body { label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10 button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5 checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -width 20 -height 2 @@ -115,33 +149,50 @@ test winbutton-1.7 {TkpComputeButtonGeometry procedure} {win nonPortable} { pack .b1 .b2 .b3 .b4 update list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {74 24 67 97 174 46 64 28} -test winbutton-1.8 {TkpComputeButtonGeometry procedure} {win nonPortable} { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { + deleteWindows +} -result {74 24 67 97 174 46 64 28} + +test winbutton-1.8 {TkpComputeButtonGeometry procedure} -constraints { + win nonPortable +} -setup { deleteWindows +} -body { label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \ - -highlightthickness 4 + -highlightthickness 4 button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 \ - -highlightthickness 0 + -highlightthickness 0 checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 \ - -highlightthickness 1 -indicatoron no + -highlightthickness 1 -indicatoron no radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -indicatoron 0 pack .b1 .b2 .b3 .b4 update list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {66 32 65 31 69 31 71 29} -test winbutton-1.9 {TkpComputeButtonGeometry procedure} win { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { deleteWindows +} -result {66 32 65 31 69 31 71 29} + +test winbutton-1.9 {TkpComputeButtonGeometry procedure} -constraints win -setup { + deleteWindows +} -body { button .b2 -bitmap question -default normal list [winfo reqwidth .b2] [winfo reqheight .b2] -} {23 33} +} -cleanup { + deleteWindows +} -result {23 33} # cleanup deleteWindows cleanupTests return + +# Local variables: +# mode: tcl +# End: + diff --git a/tests/winDialog.test b/tests/winDialog.test index 219255b..c2c7b35 100644 --- a/tests/winDialog.test +++ b/tests/winDialog.test @@ -7,10 +7,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 1998-1999 ActiveState Corporation. # -# RCS: @(#) $Id: winDialog.test,v 1.17 2008/05/13 12:39:28 patthoyts Exp $ +# RCS: @(#) $Id: winDialog.test,v 1.18 2008/08/30 21:52:26 aniap Exp $ -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands if {[testConstraint testwinevent]} { @@ -35,12 +36,12 @@ proc then {cmd} { proc afterbody {} { if {$::tk_dialog == 0} { - if {[incr ::iter_after] > 30} { - set ::dialogresult ">30 iterations waiting on tk_dialog" - return - } - after 150 {afterbody} - return + if {[incr ::iter_after] > 30} { + set ::dialogresult ">30 iterations waiting on tk_dialog" + return + } + after 150 {afterbody} + return } uplevel #0 {set dialogresult [eval $command]} } @@ -58,7 +59,9 @@ proc SetText {button text} { return [testwinevent $::tk_dialog $button WM_SETTEXT $text] } -test winDialog-1.1.0 {Tk_ChooseColorObjCmd} -constraints { +# ---------------------------------------------------------------------- + +test winDialog-1.1 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { start {tk_chooseColor} @@ -66,7 +69,7 @@ test winDialog-1.1.0 {Tk_ChooseColorObjCmd} -constraints { Click cancel } } -result {0} -test winDialog-1.1.1 {Tk_ChooseColorObjCmd} -constraints { +test winDialog-1.2 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { start {set clr [tk_chooseColor -initialcolor "#ff9933"]} @@ -75,7 +78,7 @@ test winDialog-1.1.1 {Tk_ChooseColorObjCmd} -constraints { } list $x $clr } -result {0 {}} -test winDialog-1.1.2 {Tk_ChooseColorObjCmd} -constraints { +test winDialog-1.3 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { start {set clr [tk_chooseColor -initialcolor "#ff9933"]} @@ -84,9 +87,11 @@ test winDialog-1.1.2 {Tk_ChooseColorObjCmd} -constraints { } list $x $clr } -result [list 0 "#ff9933"] -test winDialog-1.1.3 {Tk_ChooseColorObjCmd: -title} -constraints { +test winDialog-1.4 {Tk_ChooseColorObjCmd: -title} -constraints { testwinevent -} -setup {unset a x} -body { +} -setup { + catch {unset a x} +} -body { set x {} start {set clr [tk_chooseColor -initialcolor "#ff9933" -title "Hello"]} then { @@ -98,9 +103,11 @@ test winDialog-1.1.3 {Tk_ChooseColorObjCmd: -title} -constraints { } lappend x $clr } -result [list Hello 0 "#ff9933"] -test winDialog-1.1.4 {Tk_ChooseColorObjCmd: -title} -constraints { +test winDialog-1.5 {Tk_ChooseColorObjCmd: -title} -constraints { testwinevent -} -setup {unset a x} -body { +} -setup { + catch {unset a x} +} -body { set x {} start { set clr [tk_chooseColor -initialcolor "#ff9933" \ @@ -115,9 +122,11 @@ test winDialog-1.1.4 {Tk_ChooseColorObjCmd: -title} -constraints { } lappend x $clr } -result [list "\u041f\u0440\u0438\u0432\u0435\u0442" 0 "#ff9933"] -test winDialog-1.1.5 {Tk_ChooseColorObjCmd: -parent} -constraints { +test winDialog-1.6 {Tk_ChooseColorObjCmd: -parent} -constraints { testwinevent -} -setup {unset a x} -body { +} -setup { + catch {unset a x} +} -body { start {set clr [tk_chooseColor -initialcolor "#ff9933" -parent .]} set x {} then { @@ -131,285 +140,360 @@ test winDialog-1.1.5 {Tk_ChooseColorObjCmd: -parent} -constraints { } list $x $clr } -result [list 1 "#ff9933"] -test winDialog-1.1.6 {Tk_ChooseColorObjCmd: -parent} -constraints { +test winDialog-1.7 {Tk_ChooseColorObjCmd: -parent} -constraints { testwinevent } -body { tk_chooseColor -initialcolor "#ff9933" -parent .xyzzy12 } -returnCodes error -match glob -result {bad window path name*} -test winDialog-2.1 {ColorDlgHookProc} {emptyTest nt} { -} {} -test winDialog-3.1 {Tk_GetOpenFileObjCmd} {nt testwinevent} { +test winDialog-2.1 {ColorDlgHookProc} -constraints {emptyTest nt} -body {} + + +test winDialog-3.1 {Tk_GetOpenFileObjCmd} -constraints { + nt testwinevent +} -body { start {tk_getOpenFile} then { - set x [GetText 2] - Click 2 + set x [GetText 2] + Click 2 } - set x -} {Cancel} + return $x +} -result {Cancel} -test winDialog-4.1 {Tk_GetSaveFileObjCmd} {nt testwinevent} { + +test winDialog-4.1 {Tk_GetSaveFileObjCmd} -constraints { + nt testwinevent +} -body { start {tk_getSaveFile} then { - set x [GetText 2] - Click 2 + set x [GetText 2] + Click 2 } - set x -} {Cancel} + return $x +} -result {Cancel} -test winDialog-5.1 {GetFileName: no arguments} {nt testwinevent} { +test winDialog-5.1 {GetFileName: no arguments} -constraints { + nt testwinevent +} -body { start {tk_getOpenFile -title Open} then { - Click cancel + Click cancel } -} {0} -test winDialog-5.2 {GetFileName: one argument} {nt} { - list [catch {tk_getOpenFile -foo} msg] $msg -} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}} -test winDialog-5.4 {GetFileName: many arguments} {nt testwinevent} { +} -result {0} +test winDialog-5.2 {GetFileName: one argument} -constraints { + nt +} -body { + tk_getOpenFile -foo +} -returnCodes error -result {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable} +test winDialog-5.3 {GetFileName: many arguments} -constraints { + nt testwinevent +} -body { start {tk_getOpenFile -initialdir c:/ -parent . -title test -initialfile foo} then { - Click cancel + Click cancel } -} {0} -test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} {nt} { - list [catch {tk_getOpenFile -foo bar -abc} msg] $msg -} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}} -test winDialog-5.6 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} {nt testwinevent} { +} -result {0} +test winDialog-5.4 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} -constraints { + nt +} -body { + tk_getOpenFile -foo bar -abc +} -returnCodes error -result {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable} +test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} -constraints { + nt testwinevent +} -body { start {tk_getOpenFile -title bar} then { - Click cancel + Click cancel } -} {0} -test winDialog-5.7 {GetFileName: valid option, but missing value} {nt} { - list [catch {tk_getOpenFile -initialdir bar -title} msg] $msg -} {1 {value for "-title" missing}} -test winDialog-5.8 {GetFileName: extension begins with .} {nt testwinevent} { +} -result {0} +test winDialog-5.6 {GetFileName: valid option, but missing value} -constraints { + nt +} -body { + tk_getOpenFile -initialdir bar -title +} -returnCodes error -result {value for "-title" missing} +test winDialog-5.7 {GetFileName: extension begins with .} -constraints { + nt testwinevent +} -body { # if (string[0] == '.') { -# string++; +# string++; # } start {set x [tk_getSaveFile -defaultextension .foo -title Save]} then { - SetText 0x480 bar - Click 1 + SetText 0x480 bar + Click 1 } string totitle $x -} [string totitle [file join [pwd] bar.foo]] -test winDialog-5.9 {GetFileName: extension doesn't begin with .} {nt testwinevent} { +} -result [string totitle [file join [pwd] bar.foo]] +test winDialog-5.8 {GetFileName: extension doesn't begin with .} -constraints { + nt testwinevent +} -body { start {set x [tk_getSaveFile -defaultextension foo -title Save]} then { - SetText 0x480 bar - Click 1 + SetText 0x480 bar + Click 1 } string totitle $x -} [string totitle [file join [pwd] bar.foo]] -test winDialog-5.10 {GetFileName: file types} {nt testwinevent} { -# case FILE_TYPES: +} -result [string totitle [file join [pwd] bar.foo]] +test winDialog-5.9 {GetFileName: file types} -constraints { + nt testwinevent +} -body { +# case FILE_TYPES: start {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo} then { - set x [GetText 0x470] - Click cancel + set x [GetText 0x470] + Click cancel } - set x -} {foo files (*.foo)} -test winDialog-5.11 {GetFileName: file types: MakeFilter() fails} {nt} { -# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK) + return $x +} -result {foo files (*.foo)} +test winDialog-5.10 {GetFileName: file types: MakeFilter() fails} -constraints { + nt +} -body { +# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK) - list [catch {tk_getSaveFile -filetypes {{"foo" .foo FOO}}} msg] $msg -} {1 {bad Macintosh file type "FOO"}} -test winDialog-5.12 {GetFileName: initial directory} {nt testwinevent} { -# case FILE_INITDIR: + tk_getSaveFile -filetypes {{"foo" .foo FOO}} +} -returnCodes error -result {bad Macintosh file type "FOO"} +test winDialog-5.11 {GetFileName: initial directory} -constraints { + nt testwinevent +} -body { +# case FILE_INITDIR: start {set x [tk_getSaveFile -initialdir c:/ -initialfile "12x 455" -title Foo]} then { - Click 1 - } - set x -} {C:/12x 455} -test winDialog-5.13 {GetFileName: initial directory: Tcl_TranslateFilename()} \ - {nt} { -# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) - - list [catch {tk_getOpenFile -initialdir ~12x/455} msg] $msg -} {1 {user "12x" doesn't exist}} -test winDialog-5.14 {GetFileName: initial file} {nt testwinevent} { -# case FILE_INITFILE: + Click 1 + } + return $x +} -result {C:/12x 455} +test winDialog-5.12 {GetFileName: initial directory: Tcl_TranslateFilename()} -constraints { + nt +} -body { +# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) + + tk_getOpenFile -initialdir ~12x/455 +} -returnCodes error -result {user "12x" doesn't exist} +test winDialog-5.13 {GetFileName: initial file} -constraints { + nt testwinevent +} -body { +# case FILE_INITFILE: start {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]} then { - Click 1 + Click 1 } string totitle $x -} [string totitle [file join [pwd] "12x 456"]] -test winDialog-5.15 {GetFileName: initial file: Tcl_TranslateFileName()} {nt} { -# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) - list [catch {tk_getOpenFile -initialfile ~12x/455} msg] $msg -} {1 {user "12x" doesn't exist}} -test winDialog-5.16 {GetFileName: initial file: long name} {nt testwinevent} { +} -result [string totitle [file join [pwd] "12x 456"]] +test winDialog-5.14 {GetFileName: initial file: Tcl_TranslateFileName()} -constraints { + nt +} -body { +# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) + tk_getOpenFile -initialfile ~12x/455 +} -returnCodes error -result {user "12x" doesn't exist} +test winDialog-5.15 {GetFileName: initial file: long name} -constraints { + nt testwinevent +} -body { start { set dialogresult [catch { tk_getSaveFile -initialfile [string repeat a 1024] -title Long } x] } then { - Click 1 + Click 1 } list $dialogresult [string match "invalid filename *" $x] -} {1 1} -test winDialog-5.17 {GetFileName: parent} {nt} { -# case FILE_PARENT: +} -result {1 1} +test winDialog-5.16 {GetFileName: parent} -constraints { + nt +} -body { +# case FILE_PARENT: toplevel .t set x 0 start {tk_getOpenFile -parent .t -title Parent; set x 1} then { - destroy .t + destroy .t } - set x -} {1} -test winDialog-5.18 {GetFileName: title} {nt testwinevent} { -# case FILE_TITLE: - + return $x +} -result {1} +test winDialog-5.17 {GetFileName: title} -constraints { + nt testwinevent +} -body { +# case FILE_TITLE: + start {tk_getOpenFile -title Narf} then { - Click 2 + Click 2 } -} {0} -test winDialog-5.19 {GetFileName: no filter specified} {nt testwinevent} { -# if (ofn.lpstrFilter == NULL) +} -result {0} +test winDialog-5.18 {GetFileName: no filter specified} -constraints { + nt testwinevent +} -body { +# if (ofn.lpstrFilter == NULL) - start {tk_getOpenFile -title Filter} + start {tk_getOpenFile -title Filter} then { - set x [GetText 0x470] - Click 2 - } - set x -} {All Files (*.*)} -test winDialog-5.20 {GetFileName: parent HWND doesn't yet exist} {nt} { -# if (Tk_WindowId(parent) == None) + set x [GetText 0x470] + Click 2 + } + return $x +} -result {All Files (*.*)} +test winDialog-5.19 {GetFileName: parent HWND doesn't yet exist} -constraints { + nt +} -setup { + destroy .t +} -body { +# if (Tk_WindowId(parent) == None) toplevel .t start {tk_getOpenFile -parent .t -title Open} then { - destroy .t + destroy .t } -} {} -test winDialog-5.21 {GetFileName: parent HWND already exists} {nt} { +} -result {} +test winDialog-5.20 {GetFileName: parent HWND already exists} -constraints { + nt +} -setup { + destroy .t +} -body { toplevel .t update start {tk_getOpenFile -parent .t -title Open} then { - destroy .t + destroy .t } -} {} -test winDialog-5.22 {GetFileName: call GetOpenFileName} {nt testwinevent} { -# winCode = GetOpenFileName(&ofn); - +} -result {} +test winDialog-5.21 {GetFileName: call GetOpenFileName} -constraints { + nt testwinevent +} -body { +# winCode = GetOpenFileName(&ofn); + start {tk_getOpenFile -title Open} then { - set x [GetText 1] - Click 2 + set x [GetText 1] + Click 2 } - set x -} {&Open} -test winDialog-5.23 {GetFileName: call GetSaveFileName} {nt testwinevent} { -# winCode = GetSaveFileName(&ofn); + return $x +} -result {&Open} +test winDialog-5.22 {GetFileName: call GetSaveFileName} -constraints { + nt testwinevent +} -body { +# winCode = GetSaveFileName(&ofn); start {tk_getSaveFile -title Save} then { - set x [GetText 1] - Click 2 + set x [GetText 1] + Click 2 } - set x -} {&Save} -test winDialog-5.24 {GetFileName: convert \ to /} {nt testwinevent} { + return $x +} -result {&Save} +test winDialog-5.23 {GetFileName: convert \ to /} -constraints { + nt testwinevent +} -body { start {set x [tk_getSaveFile -title Back]} then { - SetText 0x480 "c:\\12x 457" - Click 1 + SetText 0x480 "c:\\12x 457" + Click 1 } - set x -} {c:/12x 457} -test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} {nt} { + return $x +} -result {c:/12x 457} +test winDialog-5.24 {GetFileName: file types: MakeFilter() succeeds} -constraints { + nt +} -body { # MacOS type that is correct, but has embedded nulls. start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0}}}}]} then { - Click 2 + Click 2 } - set x -} {0} -test winDialog-5.26 {GetFileName: file types: MakeFilter() succeeds} {nt} { + return $x +} -result {0} +test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} -constraints { + nt +} -body { # MacOS type that is correct, but has embedded high-bit chars. start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\u2022\u2022\u2022\u2022}}}}]} then { - Click 2 + Click 2 } - set x -} {0} + return $x +} -result {0} + + +test winDialog-6.1 {MakeFilter} -constraints {emptyTest nt} -body {} + -test winDialog-6.1 {MakeFilter} {emptyTest nt} {} {} +test winDialog-7.1 {Tk_MessageBoxObjCmd} -constraints {emptyTest nt} -body {} -test winDialog-7.1 {Tk_MessageBoxObjCmd} {emptyTest nt} {} {} -test winDialog-8.1 {OFNHookProc} {emptyTest nt} {} {} +test winDialog-8.1 {OFNHookProc} -constraints {emptyTest nt} -body {} + ## The Tk_ChooseDirectoryObjCmd hang on the static build of Windows ## because somehow the GetOpenFileName ends up a noop in the static ## build. ## -test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} {nt testwinevent} { +test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} -constraints { + nt testwinevent +} -body { start {tk_chooseDirectory} then { - Click cancel + Click cancel } -} {0} -test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} {nt} { - list [catch {tk_chooseDirectory -foo} msg] $msg -} {1 {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}} -test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} {nt testwinevent} { +} -result {0} +test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} -constraints { + nt +} -body { + tk_chooseDirectory -foo +} -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title} +test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} -constraints { + nt testwinevent +} -body { start { - tk_chooseDirectory -initialdir c:/ -mustexist 1 -parent . -title test + tk_chooseDirectory -initialdir c:/ -mustexist 1 -parent . -title test } then { - Click cancel - } -} {0} -test winDialog-9.4 {Tk_ChooseDirectoryObjCmd:\ - Tcl_GetIndexFromObj() != TCL_OK} {nt} { - list [catch {tk_chooseDirectory -foo bar -abc} msg] $msg -} {1 {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}} -test winDialog-9.5 {Tk_ChooseDirectoryObjCmd:\ - Tcl_GetIndexFromObj() == TCL_OK} {nt testwinevent} { + Click cancel + } +} -result {0} +test winDialog-9.4 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() != TCL_OK} -constraints { + nt +} -body { + tk_chooseDirectory -foo bar -abc +} -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title} +test winDialog-9.5 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() == TCL_OK} -constraints { + nt testwinevent +} -body { start {tk_chooseDirectory -title bar} then { - Click cancel + Click cancel } -} {0} -test winDialog-9.6 {Tk_ChooseDirectoryObjCmd:\ - valid option, but missing value} {nt} { - list [catch {tk_chooseDirectory -initialdir bar -title} msg] $msg -} {1 {value for "-title" missing}} -test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} {nt testwinevent} { -# case DIR_INITIAL: +} -result {0} +test winDialog-9.6 {Tk_ChooseDirectoryObjCmd: valid option, but missing value} -constraints { + nt +} -body { + tk_chooseDirectory -initialdir bar -title +} -returnCodes error -result {value for "-title" missing} +test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} -constraints { + nt testwinevent +} -body { +# case DIR_INITIAL: start {set x [tk_chooseDirectory -initialdir c:/ -title Foo]} then { - Click 1 + Click 1 } string tolower [set x] -} {c:/} -test winDialog-9.8 {Tk_ChooseDirectoryObjCmd:\ - initial directory: Tcl_TranslateFilename()} {nt} { -# if (Tcl_TranslateFileName(interp, string, -# &utfDirString) == NULL) - - list [catch {tk_chooseDirectory -initialdir ~12x/455} msg] $msg -} {1 {user "12x" doesn't exist}} +} -result {c:/} +test winDialog-9.8 {Tk_ChooseDirectoryObjCmd: initial directory: Tcl_TranslateFilename()} -constraints { + nt +} -body { +# if (Tcl_TranslateFileName(interp, string, +# &utfDirString) == NULL) + + tk_chooseDirectory -initialdir ~12x/455 +} -returnCodes error -result {user "12x" doesn't exist} if {[testConstraint testwinevent]} { catch {testwinevent debug 0} @@ -418,3 +502,8 @@ if {[testConstraint testwinevent]} { # cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End: + diff --git a/tests/winFont.test b/tests/winFont.test index 82d0c36..4491de0 100644 --- a/tests/winFont.test +++ b/tests/winFont.test @@ -1,50 +1,30 @@ -# This file is a Tcl script to test out the procedures in tkWinFont.c. +# This file is a Tcl script to test out the procedures in tkWinFont.c. # It is organized in the standard fashion for Tcl tests. # # Many of these tests are visually oriented and cannot be checked # programmatically (such as "does an underlined font appear to be # underlined?"); these tests attempt to exercise the code in question, -# but there are no results that can be checked. +# but there are no results that can be checked. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winFont.test,v 1.11 2004/12/04 00:04:43 dkf Exp $ +# RCS: @(#) $Id: winFont.test,v 1.12 2008/08/30 21:52:26 aniap Exp $ -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands -catch {destroy .b} -catch {font delete xyz} -toplevel .b -wm geometry .b +0+0 -update idletasks - -set courier {Courier 14} -set cx [font measure $courier 0] - -label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font systemfixed -pack .b.l -canvas .b.c -closeenough 0 - -set t [.b.c create text 0 0 -anchor nw -just left -font $courier] -pack .b.c -update - -set ax [winfo reqwidth .b.l] -set ay [winfo reqheight .b.l] -proc getsize {} { - update - return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" -} - -test winfont-1.1 {TkpGetNativeFont procedure: not native} win { - list [catch {font measure {} xyz} msg] $msg -} {1 {font "" doesn't exist}} -test winfont-1.2 {TkpGetNativeFont procedure: native} win { +test winfont-1.1 {TkpGetNativeFont procedure: not native} -constraints { + win +} -body { + catch {font delete xyz} + font measure {} xyz +} -returnCodes error -result {font "" doesn't exist} +test winfont-1.2 {TkpGetNativeFont procedure: native} -constraints win -body { font measure ansifixed 0 font measure ansi 0 font measure device 0 @@ -52,135 +32,363 @@ test winfont-1.2 {TkpGetNativeFont procedure: native} win { font measure systemfixed 0 font measure system 0 set x {} -} {} - -test winfont-2.1 {TkpGetFontFromAttributes procedure: pointsize} win { - expr [font actual {-size -10} -size]>0 -} {1} -test winfont-2.2 {TkpGetFontFromAttributes procedure: pointsize} win { - expr [font actual {-family Arial} -size]>0 -} {1} -test winfont-2.3 {TkpGetFontFromAttributes procedure: normal weight} win { +} -result {} + + +test winfont-2.1 {TkpGetFontFromAttributes procedure: pointsize} -constraints { + win +} -body { + expr {[font actual {-size -10} -size] > 0} +} -result {1} +test winfont-2.2 {TkpGetFontFromAttributes procedure: pointsize} -constraints { + win +} -body { + expr {[font actual {-family Arial} -size] > 0} +} -result {1} +test winfont-2.3 {TkpGetFontFromAttributes procedure: normal weight} -constraints { + win +} -body { font actual {-weight normal} -weight -} {normal} -test winfont-2.4 {TkpGetFontFromAttributes procedure: bold weight} win { +} -result {normal} +test winfont-2.4 {TkpGetFontFromAttributes procedure: bold weight} -constraints { + win +} -body { font actual {-weight bold} -weight -} {bold} -test winfont-2.5 {TkpGetFontFromAttributes procedure: no family} win { +} -result {bold} +test winfont-2.5 {TkpGetFontFromAttributes procedure: no family} -constraints { + win +} -body { catch {expr {[font actual {-size 10} -size]}} -} 0 -test winfont-2.6 {TkpGetFontFromAttributes procedure: family} win { +} -result 0 +test winfont-2.6 {TkpGetFontFromAttributes procedure: family} -constraints { + win +} -body { font actual {-family Arial} -family -} {Arial} -test winfont-2.7 {TkpGetFontFromAttributes procedure: Times fonts} win { +} -result {Arial} +test winfont-2.7 {TkpGetFontFromAttributes procedure: Times fonts} -constraints { + win +} -setup { set x {} +} -body { lappend x [font actual {-family "Times"} -family] lappend x [font actual {-family "New York"} -family] lappend x [font actual {-family "Times New Roman"} -family] -} {{Times New Roman} {Times New Roman} {Times New Roman}} -test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} win { +} -result {{Times New Roman} {Times New Roman} {Times New Roman}} +test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} -constraints { + win +} -setup { set x {} +} -body { lappend x [font actual {-family "Courier"} -family] lappend x [font actual {-family "Monaco"} -family] lappend x [font actual {-family "Courier New"} -family] -} {{Courier New} {Courier New} {Courier New}} -test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} win { +} -result {{Courier New} {Courier New} {Courier New}} +test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} -constraints { + win +} -setup { set x {} +} -body { lappend x [font actual {-family "Helvetica"} -family] lappend x [font actual {-family "Geneva"} -family] lappend x [font actual {-family "Arial"} -family] -} {Arial Arial Arial} -test winfont-2.10 {TkpGetFontFromAttributes procedure: fallback} win { +} -result {Arial Arial Arial} +test winfont-2.10 {TkpGetFontFromAttributes procedure: fallback} -constraints { + win +} -body { # No way to get it to fail! Any font name is acceptable. -} {} +} -result {} -test winfont-3.1 {TkpDeleteFont procedure} win { + +test winfont-3.1 {TkpDeleteFont procedure} -constraints win -body { + catch {font delete xyz} font actual {-family xyz} set x {} -} {} +} -result {} + -test winfont-4.1 {TkpGetFontFamilies procedure} win { +test winfont-4.1 {TkpGetFontFamilies procedure} -constraints win -body { font families set x {} -} {} - -test winfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} win { - .b.l config -wrap 0 -text "000000" - getsize -} "[expr $ax*6] $ay" -test winfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} win { - .b.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" - getsize -} "[expr $ax*256] $ay" -test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} win { - .b.l config -wrap [expr $ax*10] -text "00000000" - getsize -} "[expr $ax*8] $ay" -test winfont-5.4 {Tk_MeasureChars procedure: not all chars fit} win { - .b.l config -wrap [expr $ax*6] -text "00000000" - getsize -} "[expr $ax*6] [expr $ay*2]" -test winfont-5.5 {Tk_MeasureChars procedure: include last partial char} win { - .b.c dchars $t 0 end - .b.c insert $t 0 "0000" - .b.c index $t @[expr int($cx*2.5)],1 -} {2} -test winfont-5.6 {Tk_MeasureChars procedure: at least one char on line} win { - .b.l config -text "000000" -wrap 1 - getsize -} "$ax [expr $ay*6]" -test winfont-5.7 {Tk_MeasureChars procedure: whole words} win { - .b.l config -wrap [expr $ax*8] -text "000000 0000" - getsize -} "[expr $ax*6] [expr $ay*2]" -test winfont-5.8 {Tk_MeasureChars procedure: already saw space in line} win { - .b.l config -wrap [expr $ax*12] -text "000000 0000000" - getsize -} "[expr $ax*7] [expr $ay*2]" -test winfont-5.9 {Tk_MeasureChars procedure: internal spaces significant} win { - .b.l config -wrap [expr $ax*12] -text "000 00 00000" - getsize -} "[expr $ax*7] [expr $ay*2]" -test winfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} win { - .b.l config -wrap [expr $ax*12] -text "0000000000000000" - getsize -} "[expr $ax*12] [expr $ay*2]" -test winfont-5.11 {Tk_MeasureChars procedure: check for kerning} \ - {win nonPortable} { - set font [.b.l cget -font] - .b.l config -font {{MS Sans Serif} 8} -text "W" - set width [winfo reqwidth .b.l] - .b.l config -text "XaYoYaKaWx" +} -result {} + +destroy .t +toplevel .t +wm geometry .t +0+0 +update idletasks +label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font systemfixed +pack .t.l +canvas .t.c -closeenough 0 + +set courier {Courier 14} +set cx [font measure $courier 0] +set t [.t.c create text 0 0 -anchor nw -just left -font $courier] +pack .t.c +update + +set ax [winfo reqwidth .t.l] +set ay [winfo reqheight .t.l] +proc getsize {} { + update + return "[winfo reqwidth .t.l] [winfo reqheight .t.l]" +} + +test winfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap 0 -text "000000" + list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \ + [expr {[winfo reqheight .t.l] eq $ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" + list [expr {[winfo reqwidth .t.l] eq 256*$ax}] \ + [expr {[winfo reqheight .t.l] eq $ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap [expr $ax*10] -text "00000000" + list [expr {[winfo reqwidth .t.l] eq 8*$ax}] \ + [expr {[winfo reqheight .t.l] eq $ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.4 {Tk_MeasureChars procedure: not all chars fit} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap [expr $ax*6] -text "00000000" + list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \ + [expr {[winfo reqheight .t.l] eq 2*$ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.5 {Tk_MeasureChars procedure: include last partial char} -constraints { + win +} -setup { + destroy .t.c +} -body { + canvas .t.c -closeenough 0 + set t [.t.c create text 0 0 -anchor nw -just left -font $courier] + pack .t.c + update + + .t.c dchars $t 0 end + .t.c insert $t 0 "0000" + .t.c index $t @[expr int($cx*2.5)],1 +} -cleanup { + destroy .t.c +} -result {2} + +test winfont-5.6 {Tk_MeasureChars procedure: at least one char on line} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -text "000000" -wrap 1 + list [expr {[winfo reqwidth .t.l] eq $ax}] \ + [expr {[winfo reqheight .t.l] eq 6*$ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.7 {Tk_MeasureChars procedure: whole words} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap [expr $ax*8] -text "000000 0000" + list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \ + [expr {[winfo reqheight .t.l] eq 2*$ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.8 {Tk_MeasureChars procedure: already saw space in line} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap [expr $ax*12] -text "000000 0000000" + list [expr {[winfo reqwidth .t.l] eq 7*$ax}] \ + [expr {[winfo reqheight .t.l] eq 2*$ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.9 {Tk_MeasureChars procedure: internal spaces significant} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap [expr $ax*12] -text "000 00 00000" + list [expr {[winfo reqwidth .t.l] eq 7*$ax}] \ + [expr {[winfo reqheight .t.l] eq 2*$ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap [expr $ax*12] -text "0000000000000000" + list [expr {[winfo reqwidth .t.l] eq 12*$ax}] \ + [expr {[winfo reqheight .t.l] eq 2*$ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.11 {Tk_MeasureChars procedure: check for kerning} -constraints { + win nonPortable +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + + set font [.t.l cget -font] + .t.l config -font {{MS Sans Serif} 8} -text "W" + set width [winfo reqwidth .t.l] + .t.l config -text "XaYoYaKaWx" set x [lindex [getsize] 0] - .b.l config -font $font + .t.l config -font $font expr $x < ($width*10) -} 1 +} -cleanup { + destroy .t.l +} -result {1} -test winfont-6.1 {Tk_DrawChars procedure: loop test} win { - .b.l config -text "a" + +test winfont-6.1 {Tk_DrawChars procedure: loop test} -constraints win -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + .t.l config -text "a" update -} {} +} -cleanup { + destroy .t.l +} -result {} + -test winfont-7.1 {AllocFont procedure: use old font} win { +test winfont-7.1 {AllocFont procedure: use old font} -constraints win -setup { + destroy .c +} -setup { + catch {font delete xyz} +} -body { font create xyz - catch {destroy .c} button .c -font xyz font configure xyz -family times update destroy .c font delete xyz -} {} -test winfont-7.2 {AllocFont procedure: extract info from logfont} win { +} -result {} +test winfont-7.2 {AllocFont procedure: extract info from logfont} -constraints { + win +} -body { font actual {arial 10 bold italic underline overstrike} -} {-family Arial -size 10 -weight bold -slant italic -underline 1 -overstrike 1} -test winfont-7.3 {AllocFont procedure: extract info from textmetric} win { +} -result {-family Arial -size 10 -weight bold -slant italic -underline 1 -overstrike 1} +test winfont-7.3 {AllocFont procedure: extract info from textmetric} -constraints { + win +} -body { font metric {arial 10 bold italic underline overstrike} -fixed -} {0} -test winfont-7.4 {AllocFont procedure: extract info from textmetric} win { +} -result {0} +test winfont-7.4 {AllocFont procedure: extract info from textmetric} -constraints { + win +} -body { font metric systemfixed -fixed -} {1} +} -result {1} # cleanup -destroy .b cleanupTests return + +# Local variables: +# mode: tcl +# End: + diff --git a/tests/winMenu.test b/tests/winMenu.test index ff3296b..813d4c5 100644 --- a/tests/winMenu.test +++ b/tests/winMenu.test @@ -7,142 +7,185 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winMenu.test,v 1.10 2007/05/09 12:52:44 das Exp $ +# RCS: @(#) $Id: winMenu.test,v 1.11 2008/08/30 21:52:26 aniap Exp $ -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands -test winMenu-1.1 {GetNewID} win { - catch {destroy .m1} - list [catch {menu .m1} msg] $msg [destroy .m1] -} {0 .m1 {}} +test winMenu-1.1 {GetNewID} -constraints win -setup { + destroy .m1 +} -body { + menu .m1 +} -cleanup { + destroy .m1 +} -returnCodes ok -result {.m1} +test winMenu-1.2 {GetNewID} -constraints win -setup { + destroy .m1 +} -body { + menu .m1 + destroy .m1 +} -result {} + + # Basically impossible to test menu IDs wrapping. -test winMenu-2.1 {FreeID} win { - catch {destroy .m1} +test winMenu-2.1 {FreeID} -constraints win -setup { + destroy .m1 +} -body { menu .m1 - list [catch {destroy .m1} msg] $msg -} {0 {}} + destroy .m1 +} -returnCodes ok -test winMenu-3.1 {TkpNewMenu} win { - catch {destroy .m1} + +test winMenu-3.1 {TkpNewMenu} -constraints win -setup { + destroy .m1 +} -body { list [catch {menu .m1} msg] $msg [catch {destroy .m1} msg2] $msg2 -} {0 .m1 0 {}} -test winMenu-3.2 {TkpNewMenu} win { - catch {destroy .m1} +} -result {0 .m1 0 {}} +test winMenu-3.2 {TkpNewMenu} -constraints win -setup { + destroy .m1 +} -body { . configure -menu "" menu .m1 .m1 add command -label "foo" list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [catch {destroy .m1} msg2] $msg2 -} {0 {} {} 0 {}} +} -result {0 {} {} 0 {}} + -test winMenu-4.1 {TkpDestroyMenu} win { - catch {destroy .m1} +test winMenu-4.1 {TkpDestroyMenu} -constraints win -setup { + destroy .m1 +} -body { menu .m1 - list [catch {destroy .m1} msg] $msg -} {0 {}} -test winMenu-4.2 {TkpDestroyMenu - help menu} win { - catch {destroy .m1} + destroy .m1 +} -returnCodes ok +test winMenu-4.2 {TkpDestroyMenu - help menu} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -menu .m1.system . configure -menu .m1 list [catch {destroy .m1.system} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} +} -result {0 {} {} {}} + -test winMenu-5.1 {TkpDestroyMenuEntry} win { - catch {destroy .m1} +test winMenu-5.1 {TkpDestroyMenuEntry} -constraints win -setup { + destroy .m1 +} -body { . configure -menu "" menu .m1 .m1 add command -label "test" update idletasks list [catch {.m1 delete 1} msg] $msg [destroy .m1] -} {0 {} {}} +} -result {0 {} {}} -test winMenu-6.1 {GetEntryText} win { - catch {destroy .m1} + +test winMenu-6.1 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { list [catch {menu .m1} msg] $msg [destroy .m1] -} {0 .m1 {}} -test winMenu-6.2 {GetEntryText} {testImageType win} { - catch {destroy .m1} +} -result {0 .m1 {}} +test winMenu-6.2 {GetEntryText} -constraints { + testImageType win +} -setup { + destroy .m1 +} -body { catch {image delete image1} menu .m1 image create test image1 list [catch {.m1 add command -image image1} msg] $msg [destroy .m1] [image delete image1] -} {0 {} {} {}} -test winMenu-6.3 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {} {}} +test winMenu-6.3 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -bitmap questhead} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.4 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.4 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.5 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.5 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "foo"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.6 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.6 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "This string has one & in it"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.7 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.7 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "The & should be underlined." -underline 4} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.8 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.8 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "The * should be underlined." -underline 4} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.9 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.9 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "foo" -accel "bar"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.10 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.10 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "This string has one & in it" -accel "bar"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.11 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.11 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "The & should be underlined." -underline 4 -accel "bar"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.12 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.12 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "The * should be underlined." -underline 4 -accel "bar"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.13 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.13 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "foo" -accel "&bar"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.14 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.14 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "This string has one & in it" -accel "&bar"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.15 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.15 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "The & should be underlined." -underline 4 -accel "&bar"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.16 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.16 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "The * should be underlined." -underline 4 -accel "&bar"} msg] $msg [destroy .m1] -} {0 {} {}} +} -result {0 {} {}} -test winMenu-7.1 {ReconfigureWindowsMenu - system menu item removal} win { - catch {destroy .m1} +test winMenu-7.1 {ReconfigureWindowsMenu - system menu item removal} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -menu .m1.system menu .m1.system @@ -150,103 +193,140 @@ test winMenu-7.1 {ReconfigureWindowsMenu - system menu item removal} win { update idletasks .m1.system add command -label bar list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test winMenu-7.2 {ReconfigureWindowsMenu - menu item removal} win { - catch {destroy .m1} +} -result {0 {} {} {}} +test winMenu-7.2 {ReconfigureWindowsMenu - menu item removal} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label Hello update idletasks .m1 add command -label foo list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.3 {ReconfigureWindowsMenu - zero items} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.3 {ReconfigureWindowsMenu - zero items} -constraints win -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label Hello .m1 delete Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.4 {ReconfigureWindowsMenu - one item} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.4 {ReconfigureWindowsMenu - one item} -constraints win -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.5 {ReconfigureWindowsMenu - two items} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.5 {ReconfigureWindowsMenu - two items} -constraints win -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label One .m1 add command -label Two list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.6 {ReconfigureWindowsMenu - separator item} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.6 {ReconfigureWindowsMenu - separator item} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add separator list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.7 {ReconfigureWindowsMenu - non-text item} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.7 {ReconfigureWindowsMenu - non-text item} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.8 {ReconfigureWindowsMenu - disabled item} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.8 {ReconfigureWindowsMenu - disabled item} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label Hello -state disabled list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.9 {ReconfigureWindowsMenu - non-selected checkbutton} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.9 {ReconfigureWindowsMenu - non-selected checkbutton} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add checkbutton -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.10 {ReconfigureWindowsMenu - non-selected radiobutton} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.10 {ReconfigureWindowsMenu - non-selected radiobutton} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add radiobutton -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.11 {ReconfigureWindowsMenu - selected checkbutton} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.11 {ReconfigureWindowsMenu - selected checkbutton} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add checkbutton -label Hello .m1 invoke Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.12 {ReconfigureWindowsMenu - selected radiobutton} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.12 {ReconfigureWindowsMenu - selected radiobutton} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add radiobutton -label Hello .m1 invoke Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.13 {ReconfigureWindowsMenu - cascade missing} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.13 {ReconfigureWindowsMenu - cascade missing} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.14 {ReconfigureWindowsMenu - cascade} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.14 {ReconfigureWindowsMenu - cascade} -constraints win -setup { + destroy .m1 +} -body { catch {destroy .m2} menu .m1 -tearoff 0 menu .m2 .m1 add cascade -menu .m2 -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] [destroy .m2] -} {0 {} {} {}} -test winMenu-7.15 {ReconfigureWindowsMenu - menubar without system menu} win { - catch {destroy .m1} +} -result {0 {} {} {}} +test winMenu-7.15 {ReconfigureWindowsMenu - menubar without system menu} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -menu .m1.file menu .m1.file -tearoff 0 . configure -menu .m1 list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test winMenu-7.16 {ReconfigureWindowsMenu - system menu already created} win { - catch {destroy .m1} +} -result {0 {} {} {}} +test winMenu-7.16 {ReconfigureWindowsMenu - system menu already created} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -menu .m1.system menu .m1.system -tearoff 0 @@ -254,17 +334,23 @@ test winMenu-7.16 {ReconfigureWindowsMenu - system menu already created} win { update idletasks .m1.system add command -label Hello list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test winMenu-7.17 {ReconfigureWindowsMenu - system menu update pending} win { - catch {destroy .m1} +} -result {0 {} {} {}} +test winMenu-7.17 {ReconfigureWindowsMenu - system menu update pending} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -menu .m1.system menu .m1.system -tearoff 0 . configure -menu .m1 list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test winMenu-7.18 {ReconfigureWindowsMenu - system menu update not pending} win { - catch {destroy .m1} +} -result {0 {} {} {}} +test winMenu-7.18 {ReconfigureWindowsMenu - system menu update not pending} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -menu .m1.system menu .m1.system -tearoff 0 @@ -272,521 +358,717 @@ test winMenu-7.18 {ReconfigureWindowsMenu - system menu update not pending} win update idletasks . configure -menu .m1 list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test winMenu-7.19 {ReconfigureWindowsMenu - column break} win { - catch {destroy .m1} +} -result {0 {} {} {}} +test winMenu-7.19 {ReconfigureWindowsMenu - column break} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label one .m1 add command -label two -columnbreak 1 list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} +} -result {0 {} {}} + #Don't know how to generate nested post menus -test winMenu-8.1 {TkpPostMenu} win { - catch {destroy .m1} + +test winMenu-8.1 {TkpPostMenu} -constraints win -setup { + destroy .m1 +} -body { menu .m1 -postcommand "blork" - list [catch {.m1 post 40 40} msg] $msg [destroy .m1] -} {1 {invalid command name "blork"} {}} -test winMenu-8.2 {TkpPostMenu} win { - catch {destroy .m1} + .m1 post 40 40 +} -returnCodes error -result {invalid command name "blork"} +test winMenu-8.2 {TkpPostMenu} -constraints win -setup { + destroy .m1 +} -body { + menu .m1 -postcommand "blork" + .m1 post 40 40 + destroy .m1 +} -returnCodes error -result {invalid command name "blork"} +test winMenu-8.3 {TkpPostMenu} -constraints win -setup { + destroy .m1 +} -body { menu .m1 -postcommand "destroy .m1" list [.m1 post 40 40] [winfo exists .m1] -} {{} 0} -test winMenu-8.3 {TkpPostMenu - popup menu} {win userInteraction} { - catch {destroy .m1} +} -result {{} 0} +test winMenu-8.4 {TkpPostMenu - popup menu} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-8.3: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] -} {{} {}} -test winMenu-8.4 {TkpPostMenu - menu button} {win userInteraction} { - catch {destroy .mb} +} -result {{} {}} +test winMenu-8.5 {TkpPostMenu - menu button} -constraints { + win userInteraction +} -setup { + destroy .mb +} -body { menubutton .mb -text test -menu .mb.menu menu .mb.menu .mb.menu add command -label "winMenu-8.4 - Hit ESCAPE." pack .mb - list [tk::MbPost .mb] [destroy .m1] -} {{} {}} -test winMenu-8.5 {TkpPostMenu - update not pending} {win userInteraction} { - catch {destroy .m1} + list [tk::MbPost .mb] [destroy .mb] +} -result {{} {}} +test winMenu-8.6 {TkpPostMenu - update not pending} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-8.5 - Hit ESCAPE." update idletasks list [catch {.m1 post 40 40} msg] $msg [destroy .m1] -} {0 {} {}} +} -result {0 {} {}} -test winMenu-9.1 {TkpMenuNewEntry} win { - catch {destroy .m1} + +test winMenu-9.1 {TkpMenuNewEntry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command} msg] $msg [destroy .m1] -} {0 {} {}} +} -result {0 {} {}} + -test winMenu-10.1 {TkwinMenuProc} {win userInteraction} { - catch {destroy .m1} +test winMenu-10.1 {TkwinMenuProc} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-10.1: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] -} {{} {}} +} -result {{} {}} + # Can't generate a WM_INITMENU without a Tk menu yet. -test winMenu-11.1 {TkWinHandleMenuEvent - WM_INITMENU} {win userInteraction} { - catch {destroy .m1} + +test winMenu-11.1 {TkWinHandleMenuEvent - WM_INITMENU} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 -postcommand "set foo test" .m1 add command -label "winMenu-11.1: Hit ESCAPE." list [.m1 post 40 40] [set foo] [unset foo] [destroy .m1] -} {test test {} {}} -test winMenu-11.2 {TkWinHandleMenuEvent - WM_COMMAND} {win userInteraction} { - catch {destroy .m1} +} -result {test test {} {}} +test winMenu-11.2 {TkWinHandleMenuEvent - WM_COMMAND} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 .m1 add checkbutton -variable foo -label "winMenu-11.2: Please select this menu item." list [.m1 post 40 40] [update] [set foo] [unset foo] [destroy .m1] -} {{} {} 1 {} {}} -test winMenu-11.3 {TkWinHandleMenuEvent - WM_COMMAND} {win userInteraction} { - catch {destroy .m1} +} -result {{} {} 1 {} {}} +test winMenu-11.3 {TkWinHandleMenuEvent - WM_COMMAND} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { catch {unset foo} proc bgerror {args} { - global foo errorInfo - set foo [list $args $errorInfo] + global foo errorInfo + set foo [list $args $errorInfo] } menu .m1 .m1 add command -command {error 1} -label "winMenu-11.2: Please select this menu item." list [.m1 post 40 40] [update] [set foo] [unset foo] [destroy .m1] -} {{} {} {1 {1 +} -result {{} {} {1 {1 while executing "error 1" (menu invoke)}} {} {}} + # Can't test WM_MENUCHAR -test winMenu-11.4 {TkWinHandleMenuEvent - WM_MEASUREITEM} {win userInteraction} { - catch {destroy .m1} + +test winMenu-11.4 {TkWinHandleMenuEvent - WM_MEASUREITEM} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-11.3: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] -} {{} {}} -test winMenu-11.5 {TkWinHandleMenuEvent - WM_MEASUREITEM} {win userInteraction} { - catch {destroy .m1} +} -result {{} {}} +test winMenu-11.5 {TkWinHandleMenuEvent - WM_MEASUREITEM} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label "winMenu-11.4: Hit ESCAPE" -hidemargin 1 list [.m1 post 40 40] [destroy .m1] -} {{} {}} -test winMenu-11.6 {TkWinHandleMenuEvent - WM_DRAWITEM} {win userInteraction} { - catch {destroy .m1} +} -result {{} {}} +test winMenu-11.6 {TkWinHandleMenuEvent - WM_DRAWITEM} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-11.5: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] -} {{} {}} -test winMenu-11.7 {TkWinHandleMenuEvent - WM_DRAWITEM - item disabled} \ - {win userInteraction} { - catch {destroy .m1} +} -result {{} {}} +test winMenu-11.7 {TkWinHandleMenuEvent - WM_DRAWITEM - item disabled} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-11.6: Hit ESCAPE." -state disabled list [.m1 post 40 40] [destroy .m1] -} {{} {}} -test winMenu-11.8 {TkWinHandleMenuEvent - WM_INITMENU - not pending} \ - {win userInteraction} { - catch {destroy .m1} +} -result {{} {}} +test winMenu-11.8 {TkWinHandleMenuEvent - WM_INITMENU - not pending} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label "winMenu-11.7: Hit ESCAPE" update idletasks list [catch {.m1 post 40 40} msg] $msg [destroy .m1] -} {0 {} {}} +} -result {0 {} {}} -test winMenu-12.1 {TkpSetWindowMenuBar} win { - catch {destroy .m1} + +test winMenu-12.1 {TkpSetWindowMenuBar} -constraints win -setup { + destroy .m1 +} -body { . configure -menu "" menu .m1 .m1 add command -label foo list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [catch {destroy .m1} msg2] $msg2 -} {0 {} {} 0 {}} -test winMenu-12.2 {TkpSetWindowMenuBar} win { - catch {destroy .m1} +} -result {0 {} {} 0 {}} +test winMenu-12.2 {TkpSetWindowMenuBar} -constraints win -setup { + destroy .m1 +} -body { . configure -menu "" menu .m1 .m1 add command -label foo . configure -menu .m1 list [catch {. configure -menu ""} msg] $msg [catch {destroy .m1} msg2] $msg2 -} {0 {} 0 {}} -test winMenu-12.3 {TkpSetWindowMenuBar - no update pending} win { - catch {destroy .m1} +} -result {0 {} 0 {}} +test winMenu-12.3 {TkpSetWindowMenuBar - no update pending} -constraints { + win +} -setup { + destroy .m1 +} -body { . configure -menu "" menu .m1 -tearoff 0 .m1 add command -label foo update idletasks list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} +} -result {0 {} {} {}} + + +test winMenu-13.1 {TkpSetMainMenubar - nothing to do} -constraints { + emptyTest win +} -body {} -test winMenu-13.1 {TkpSetMainMenubar - nothing to do} {emptyTest win} {} {} -test winMenu-14.1 {GetMenuIndicatorGeometry} win { - catch {destroy .m1} +test winMenu-14.1 {GetMenuIndicatorGeometry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test winMenu-14.2 {GetMenuIndicatorGeometry} win { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok +test winMenu-14.2 {GetMenuIndicatorGeometry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo -hidemargin 1 - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok -test winMenu-15.1 {GetMenuAccelGeometry} win { - catch {destroy .m1} + +test winMenu-15.1 {GetMenuAccelGeometry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label foo -accel Ctrl+U - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test winMenu-15.2 {GetMenuAccelGeometry} win { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok +test winMenu-15.2 {GetMenuAccelGeometry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test winMenu-15.3 {GetMenuAccelGeometry} win { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok +test winMenu-15.3 {GetMenuAccelGeometry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -accel "Ctrl+U" - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok + -test winMenu-16.1 {GetTearoffEntryGeometry} {win userInteraction} { - catch {destroy .m1} +test winMenu-16.1 {GetTearoffEntryGeometry} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-19.1: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] -} {{} {}} +} -result {{} {}} -test winMenu-17.1 {GetMenuSeparatorGeometry} win { - catch {destroy .m1} + +test winMenu-17.1 {GetMenuSeparatorGeometry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add separator - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok + # Currently, the only callers to DrawWindowsSystemBitmap want things # centered vertically, and either centered or right aligned horizontally. -test winMenu-18.1 {DrawWindowsSystemBitmap - center aligned} win { - catch {destroy .m1} +test winMenu-18.1 {DrawWindowsSystemBitmap - center aligned} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo .m1 invoke foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-18.2 {DrawWindowsSystemBitmap - right aligned} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-18.2 {DrawWindowsSystemBitmap - right aligned} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} +} -result {{} {}} + -test winMenu-19.1 {DrawMenuEntryIndicator - not checkbutton or radiobutton} \ - win { - catch {destroy .m1} +test winMenu-19.1 {DrawMenuEntryIndicator - not checkbutton or radiobutton} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-19.2 {DrawMenuEntryIndicator - not selected} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-19.2 {DrawMenuEntryIndicator - not selected} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-19.3 {DrawMenuEntryIndicator - checkbutton} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-19.3 {DrawMenuEntryIndicator - checkbutton} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo .m1 invoke foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-19.4 {DrawMenuEntryIndicator - radiobutton} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-19.4 {DrawMenuEntryIndicator - radiobutton} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add radiobutton -label foo .m1 invoke foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-19.5 {DrawMenuEntryIndicator - disabled} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-19.5 {DrawMenuEntryIndicator - disabled} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo .m1 invoke foo .m1 entryconfigure foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-19.6 {DrawMenuEntryIndicator - indicator not on} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-19.6 {DrawMenuEntryIndicator - indicator not on} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo -indicatoron 0 .m1 invoke foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} +} -result {{} {}} -test winMenu-20.1 {DrawMenuEntryAccelerator - disabled} win { - catch {destroy .m1} + +test winMenu-20.1 {DrawMenuEntryAccelerator - disabled} -constraints win -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground red .m1 add command -label foo -accel "Ctrl+U" -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-20.2 {DrawMenuEntryAccelerator - normal text} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-20.2 {DrawMenuEntryAccelerator - normal text} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -accel "Ctrl+U" set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-20.3 {DrawMenuEntryAccelerator - disabled, no disabledforeground} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-20.3 {DrawMenuEntryAccelerator - disabled, no disabledforeground} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground "" .m1 add command -label foo -accel "Ctrl+U" -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-20.4 {DrawMenuEntryAccelerator - cascade, drawArrow true} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-20.4 {DrawMenuEntryAccelerator - cascade, drawArrow true} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-20.5 {DrawMenuEntryAccelerator - cascade, drawArrow false} \ - {win userInteraction} { - catch {destroy .m1} +} -result {{} {}} +test winMenu-20.5 {DrawMenuEntryAccelerator - cascade, drawArrow false} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label "winMenu-23.5: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] -} {{} {}} +} -result {{} {}} + -test winMenu-21.1 {DrawMenuSeparator} win { - catch {destroy .m1} +test winMenu-21.1 {DrawMenuSeparator} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add separator set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} +} -result {{} {}} + -test winMenu-22.1 {DrawMenuUnderline} win { - catch {destroy .m1} +test winMenu-22.1 {DrawMenuUnderline} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -underline 0 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} +} -result {{} {}} -test winMenu-23.1 {Don't know how to test MenuKeyBindProc} \ - {win emptyTest} {} {} -test winMenu-24.1 {TkpInitializeMenuBindings called at boot time} \ - {win emptyTest} {} {} -test winMenu-25.1 {DrawMenuEntryLabel - normal} win { - catch {destroy .m1} +test winMenu-23.1 {Don't know how to test MenuKeyBindProc} -constraints { + win emptyTest +} -body {} + + +test winMenu-24.1 {TkpInitializeMenuBindings called at boot time} -constraints { + win emptyTest +} -body {} + + +test winMenu-25.1 {DrawMenuEntryLabel - normal} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-25.2 {DrawMenuEntryLabel - disabled with fg} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-25.2 {DrawMenuEntryLabel - disabled with fg} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground red .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-25.3 {DrawMenuEntryLabel - disabled with no fg} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-25.3 {DrawMenuEntryLabel - disabled with no fg} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground "" .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} +} -result {{} {}} + -test winMenu-26.1 {TkpComputeMenubarGeometry} win { - catch {destroy .m1} +test winMenu-26.1 {TkpComputeMenubarGeometry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label File list [. configure -menu .m1] [. configure -menu ""] [destroy .m1] -} {{} {} {}} +} -result {{} {} {}} -test winMenu-27.1 {DrawTearoffEntry} {win userInteraction} { - catch {destroy .m1} + +test winMenu-27.1 {DrawTearoffEntry} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-24.4: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] -} {{} {}} +} -result {{} {}} + -test winMenu-28.1 {TkpConfigureMenuEntry - update pending} win { - catch {destroy .m1} +test winMenu-28.1 {TkpConfigureMenuEntry - update pending} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label Hello list [catch {.m1 add command -label Two} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-28.2 {TkpConfigureMenuEntry - update not pending} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-28.2 {TkpConfigureMenuEntry - update not pending} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label One update idletasks list [catch {.m1 add command -label Two} msg] $msg [destroy .m1] -} {0 {} {}} +} -result {0 {} {}} + -test winMenu-29.1 {TkpDrawMenuEntry - gc for active and not strict motif} win { - catch {destroy .m1} +test winMenu-29.1 {TkpDrawMenuEntry - gc for active and not strict motif} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test winMenu-29.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -activeforeground red set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test winMenu-29.3 {TkpDrawMenuEntry - gc for active and strict motif} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.3 {TkpDrawMenuEntry - gc for active and strict motif} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 set tk_strictMotif 1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] [set tk_strictMotif 0] -} {{} {} 0} -test winMenu-29.4 \ - {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} \ - win { - catch {destroy .m1} +} -result {{} {} 0} +test winMenu-29.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground blue .m1 add command -label foo -state disabled -background red set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground blue .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground "" .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.7 {TkpDrawMenuEntry - gc for normal - custom entry} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.7 {TkpDrawMenuEntry - gc for normal - custom entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -foreground red set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.8 {TkpDrawMenuEntry - gc for normal} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.8 {TkpDrawMenuEntry - gc for normal} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.9 {TkpDrawMenuEntry - gc for indicator - custom entry} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.9 {TkpDrawMenuEntry - gc for indicator - custom entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo -selectcolor orange .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.10 {TkpDrawMenuEntry - gc for indicator} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.10 {TkpDrawMenuEntry - gc for indicator} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.11 {TkpDrawMenuEntry - border - custom entry} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.11 {TkpDrawMenuEntry - border - custom entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -activebackground green set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test winMenu-29.12 {TkpDrawMenuEntry - border} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.12 {TkpDrawMenuEntry - border} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test winMenu-29.13 {TkpDrawMenuEntry - active border - strict motif} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.13 {TkpDrawMenuEntry - active border - strict motif} -constraints { + win +} -setup { + destroy .m1 +} -body { set tk_strictMotif 1 menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] [set tk_strictMotif 0] -} {{} {} 0} -test winMenu-29.14 {TkpDrawMenuEntry - active border - custom entry} win { - catch {destroy .m1} +} -result {{} {} 0} +test winMenu-29.14 {TkpDrawMenuEntry - active border - custom entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -activeforeground yellow set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test winMenu-29.15 {TkpDrawMenuEntry - active border} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.15 {TkpDrawMenuEntry - active border} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test winMenu-29.16 {TkpDrawMenuEntry - font - custom entry} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.16 {TkpDrawMenuEntry - font - custom entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -font "Helvectica 72" set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.17 {TkpDrawMenuEntry - font} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.17 {TkpDrawMenuEntry - font} -constraints win -setup { + destroy .m1 +} -body { menu .m1 -font "Courier 72" .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.18 {TkpDrawMenuEntry - separator} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.18 {TkpDrawMenuEntry - separator} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add separator set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.19 {TkpDrawMenuEntry - standard} win { - catch {destroy .mb} +} -result {{} {}} +test winMenu-29.19 {TkpDrawMenuEntry - standard} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.20 {TkpDrawMenuEntry - disabled cascade item} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.20 {TkpDrawMenuEntry - disabled cascade item} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label File -menu .m1.file menu .m1.file @@ -794,160 +1076,211 @@ test winMenu-29.20 {TkpDrawMenuEntry - disabled cascade item} win { .m1 entryconfigure File -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.21 {TkpDrawMenuEntry - indicator} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.21 {TkpDrawMenuEntry - indicator} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label winMenu-31.20 .m1 invoke winMenu-31.20 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.22 {TkpDrawMenuEntry - indicator} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.22 {TkpDrawMenuEntry - indicator} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label winMenu-31.21 -hidemargin 1 .m1 invoke winMenu-31.21 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} +} -result {{} {}} -test winMenu-30.1 {GetMenuLabelGeometry - image} {testImageType win} { - catch {destroy .m1} + +test winMenu-30.1 {GetMenuLabelGeometry - image} -constraints { + testImageType win +} -setup { + destroy .m1 catch {image delete image1} +} -body { menu .m1 image create test image1 .m1 add command -image image1 list [update idletasks] [destroy .m1] [image delete image1] -} {{} {} {}} -test winMenu-30.2 {GetMenuLabelGeometry - bitmap} win { - catch {destroy .m1} +} -result {{} {} {}} +test winMenu-30.2 {GetMenuLabelGeometry - bitmap} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -bitmap questhead list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-30.3 {GetMenuLabelGeometry - no text} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-30.3 {GetMenuLabelGeometry - no text} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-30.4 {GetMenuLabelGeometry - text} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-30.4 {GetMenuLabelGeometry - text} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "This is a test." list [update idletasks] [destroy .m1] -} {{} {}} +} -result {{} {}} + -test winMenu-31.1 {DrawMenuEntryBackground} win { - catch {destroy .m1} +test winMenu-31.1 {DrawMenuEntryBackground} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-31.2 {DrawMenuEntryBackground} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-31.2 {DrawMenuEntryBackground} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] $tearoff activate 0 list [update] [destroy .m1] -} {{} {}} +} -result {{} {}} -test winMenu-32.1 {TkpComputeStandardMenuGeometry - no entries} win { - catch {destroy .m1} + +test winMenu-32.1 {TkpComputeStandardMenuGeometry - no entries} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.2 {TkpComputeStandardMenuGeometry - one entry} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.2 {TkpComputeStandardMenuGeometry - one entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "one" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.3 {TkpComputeStandardMenuGeometry - more than one entry} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.3 {TkpComputeStandardMenuGeometry - more than one entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "one" .m1 add command -label "two" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.4 {TkpComputeStandardMenuGeometry - separator} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.4 {TkpComputeStandardMenuGeometry - separator} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add separator list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unix nonUnixUserInteraction} { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.5 {TkpComputeStandardMenuGeometry - tearoff entry} -constraints { + unix nonUnixUserInteraction +} -setup { + destroy .mb +} -body { menubutton .mb -text "test" -menu .mb.m menu .mb.m .mb.m add command -label test pack .mb catch {tk::MbPost .mb} list [update] [destroy .mb] -} {{} {}} -test winMenu-32.6 {TkpComputeStandardMenuGeometry - standard label geometry} \ - win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.6 {TkpComputeStandardMenuGeometry - standard label geometry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.7 {TkpComputeStandardMenuGeometry - different font for entry} \ - win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.7 {TkpComputeStandardMenuGeometry - different font for entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -font "Helvetica 12" .m1 add command -label "test" -font "Courier 12" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.8 {TkpComputeStandardMenuGeometry - second entry larger} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.8 {TkpComputeStandardMenuGeometry - second entry larger} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" .m1 add command -label "test test" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.9 {TkpComputeStandardMenuGeometry - first entry larger} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.9 {TkpComputeStandardMenuGeometry - first entry larger} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test test" .m1 add command -label "test" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.10 {TkpComputeStandardMenuGeometry - accelerator} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.10 {TkpComputeStandardMenuGeometry - accelerator} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" -accel "Ctrl+S" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.11 {TkpComputeStandardMenuGeometry - second accel larger} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.11 {TkpComputeStandardMenuGeometry - second accel larger} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" -accel "1" .m1 add command -label "test" -accel "1 1" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.12 {TkpComputeStandardMenuGeometry - second accel smaller} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.12 {TkpComputeStandardMenuGeometry - second accel smaller} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" -accel "1 1" .m1 add command -label "test" -accel "1" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.13 {TkpComputeStandardMenuGeometry - indicator} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.13 {TkpComputeStandardMenuGeometry - indicator} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label test .m1 invoke 1 list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.14 \ - {TkpComputeStandardMenuGeometry - second indicator less or equal} \ - {testImageType win} { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.14 {TkpComputeStandardMenuGeometry - second indicator less or equal} -constraints { + testImageType win +} -setup { + destroy .m1 catch {image delete image1} +} -body { image create test image1 menu .m1 .m1 add checkbutton -image image1 @@ -955,11 +1288,13 @@ test winMenu-32.14 \ .m1 add checkbutton -label test .m1 invoke 2 list [update idletasks] [destroy .m1] [image delete image1] -} {{} {} {}} -test winMenu-32.15 {TkpComputeStandardMenuGeometry - second indicator larger} \ - {testImageType unix} { - catch {destroy .m1} +} -result {{} {} {}} +test winMenu-32.15 {TkpComputeStandardMenuGeometry - second indicator larger} -constraints { + testImageType unix +} -setup { + destroy .m1 catch {image delete image1} +} -body { image create test image1 menu .m1 .m1 add checkbutton -image image1 @@ -967,31 +1302,42 @@ test winMenu-32.15 {TkpComputeStandardMenuGeometry - second indicator larger} \ .m1 add checkbutton -label test .m1 invoke 2 list [update idletasks] [destroy .m1] [image delete image1] -} {{} {} {}} -test winMenu-32.16 {TkpComputeStandardMenuGeometry - zero sized menus} win { - catch {destroy .m1} +} -result {{} {} {}} +test winMenu-32.16 {TkpComputeStandardMenuGeometry - zero sized menus} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.17 {TkpComputeStandardMenuGeometry - first column bigger} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.17 {TkpComputeStandardMenuGeometry - first column bigger} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label one .m1 add command -label two .m1 add command -label three -columnbreak 1 list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.18 {TkpComputeStandardMenuGeometry - second column bigger} \ - win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.18 {TkpComputeStandardMenuGeometry - second column bigger} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label one .m1 add command -label two -columnbreak 1 .m1 add command -label three list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.19 {TkpComputeStandardMenuGeometry - three columns} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.19 {TkpComputeStandardMenuGeometry - three columns} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label one .m1 add command -label two -columnbreak 1 @@ -999,19 +1345,22 @@ test winMenu-32.19 {TkpComputeStandardMenuGeometry - three columns} win { .m1 add command -label four .m1 add command -label five -columnbreak 1 .m1 add command -label six - list [update idletasks] [destroy .m1] -} {{} {}} + list [update idletasks] [destroy .m1] +} -result {{} {}} + -test winMenu-33.1 {TkpNotifyTopLevelCreate - no menu yet} win { - catch {destroy .t2} - catch {destroy .m1} +test winMenu-33.1 {TkpNotifyTopLevelCreate - no menu yet} -constraints { + win +} -setup { + destroy .m1 .t2 +} -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 list [update idletasks] [destroy .t2] -} {{} {}} -test winMenu-33.2 {TkpNotifyTopLevelCreate - menu} win { - catch {destroy .t2} - catch {destroy .m1} +} -result {{} {}} +test winMenu-33.2 {TkpNotifyTopLevelCreate - menu} -constraints win -setup { + destroy .m1 .t2 +} -body { menu .m1 menu .m1.system .m1 add cascade -menu .m1.system @@ -1020,11 +1369,19 @@ test winMenu-33.2 {TkpNotifyTopLevelCreate - menu} win { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 list [update idletasks] [destroy .m1] [destroy .t2] -} {{} {} {}} +} -result {{} {} {}} + -test winMenu-34.1 {TkpMenuInit called at boot time} {emptyTest win} {} {} +test winMenu-34.1 {TkpMenuInit called at boot time} -constraints { + emptyTest win +} -body {} # cleanup deleteWindows cleanupTests return + +# Local variables: +# mode: tcl +# End: + diff --git a/tests/winMsgbox.test b/tests/winMsgbox.test index 85fd44d..e0dab81 100644 --- a/tests/winMsgbox.test +++ b/tests/winMsgbox.test @@ -2,10 +2,11 @@ # # Copyright (c) 2007 Pat Thoyts <patthoyts@users.sourceforge.net> # -# RCS: @(#) $Id: winMsgbox.test,v 1.2 2007/12/13 15:27:55 dgp Exp $ +# RCS: @(#) $Id: winMsgbox.test,v 1.3 2008/08/30 21:52:26 aniap Exp $ -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands testConstraint getwindowinfo [expr {[llength [info command ::testgetwindowinfo]] > 0}] @@ -40,7 +41,7 @@ proc GetWindowInfo {title button} { # ------------------------------------------------------------------------- -test winMsgbox-1.0 {tk_messageBox ok} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.1 {tk_messageBox ok} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -51,7 +52,7 @@ test winMsgbox-1.0 {tk_messageBox ok} -constraints {win getwindowinfo} -setup { wm deiconify . } -result {ok} -test winMsgbox-1.1 {tk_messageBox okcancel} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.2 {tk_messageBox okcancel} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -62,7 +63,7 @@ test winMsgbox-1.1 {tk_messageBox okcancel} -constraints {win getwindowinfo} -se wm deiconify . } -result {ok} -test winMsgbox-1.2 {tk_messageBox okcancel} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.3 {tk_messageBox okcancel} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -73,7 +74,7 @@ test winMsgbox-1.2 {tk_messageBox okcancel} -constraints {win getwindowinfo} -se wm deiconify . } -result {cancel} -test winMsgbox-1.3 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.4 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -84,7 +85,7 @@ test winMsgbox-1.3 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup wm deiconify . } -result {yes} -test winMsgbox-1.4 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.5 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -95,7 +96,7 @@ test winMsgbox-1.4 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup wm deiconify . } -result {no} -test winMsgbox-1.5 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.6 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -106,7 +107,7 @@ test winMsgbox-1.5 {tk_messageBox abortretryignore} -constraints {win getwindowi wm deiconify . } -result {abort} -test winMsgbox-1.6 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.7 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -117,7 +118,7 @@ test winMsgbox-1.6 {tk_messageBox abortretryignore} -constraints {win getwindowi wm deiconify . } -result {retry} -test winMsgbox-1.7 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.8 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -128,7 +129,7 @@ test winMsgbox-1.7 {tk_messageBox abortretryignore} -constraints {win getwindowi wm deiconify . } -result {ignore} -test winMsgbox-1.8 {tk_messageBox retrycancel} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.9 {tk_messageBox retrycancel} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -139,7 +140,7 @@ test winMsgbox-1.8 {tk_messageBox retrycancel} -constraints {win getwindowinfo} wm deiconify . } -result {retry} -test winMsgbox-1.9 {tk_messageBox retrycancel} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.10 {tk_messageBox retrycancel} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -150,7 +151,7 @@ test winMsgbox-1.9 {tk_messageBox retrycancel} -constraints {win getwindowinfo} wm deiconify . } -result {cancel} -test winMsgbox-1.10 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.11 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -161,7 +162,7 @@ test winMsgbox-1.10 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} wm deiconify . } -result {yes} -test winMsgbox-1.11 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.12 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -172,7 +173,7 @@ test winMsgbox-1.11 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} wm deiconify . } -result {no} -test winMsgbox-1.12 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.13 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -185,7 +186,7 @@ test winMsgbox-1.12 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} # ------------------------------------------------------------------------- -test winMsgbox-2.0 {tk_messageBox message} -constraints {win getwindowinfo} -setup { +test winMsgbox-2.1 {tk_messageBox message} -constraints {win getwindowinfo} -setup { wm iconify . unset -nocomplain info } -body { @@ -200,7 +201,7 @@ test winMsgbox-2.0 {tk_messageBox message} -constraints {win getwindowinfo} -set wm deiconify . } -result [list ok "message"] -test winMsgbox-2.1 {tk_messageBox message (long)} -constraints { +test winMsgbox-2.2 {tk_messageBox message (long)} -constraints { win getwindowinfo } -setup { wm iconify . @@ -217,7 +218,7 @@ test winMsgbox-2.1 {tk_messageBox message (long)} -constraints { wm deiconify . } -result [list ok [string repeat Ab 80]] -test winMsgbox-2.2 {tk_messageBox message (unicode)} -constraints { +test winMsgbox-2.3 {tk_messageBox message (unicode)} -constraints { win getwindowinfo } -setup { wm iconify . @@ -234,7 +235,7 @@ test winMsgbox-2.2 {tk_messageBox message (unicode)} -constraints { wm deiconify . } -result [list ok "\u041f\u043e\u0438\u0441\u043a\u0020\u0441\u0442\u0440\u0430\u043d\u0438\u0446"] -test winMsgbox-2.3 {tk_messageBox message (empty)} -constraints { +test winMsgbox-2.4 {tk_messageBox message (empty)} -constraints { win getwindowinfo } -setup { wm iconify . @@ -250,7 +251,9 @@ test winMsgbox-2.3 {tk_messageBox message (empty)} -constraints { wm deiconify . } -result [list ok ""] -test winMsgbox-3.0 {tk_messageBox detail (sourceforge bug #1692927)} -constraints { +# ------------------------------------------------------------------------- + +test winMsgbox-3.1 {tk_messageBox detail (sourceforge bug #1692927)} -constraints { win getwindowinfo } -setup { wm iconify . @@ -267,7 +270,7 @@ test winMsgbox-3.0 {tk_messageBox detail (sourceforge bug #1692927)} -constraint wm deiconify . } -result [list ok "Hello\n\nPleased to meet you"] -test winMsgbox-3.1 {tk_messageBox detail (unicode)} -constraints { +test winMsgbox-3.2 {tk_messageBox detail (unicode)} -constraints { win getwindowinfo } -setup { wm iconify . @@ -296,4 +299,5 @@ return # Local variables: # mode: tcl # indent-tabs-mode: nil -# End:
\ No newline at end of file +# End: + diff --git a/tests/winWm.test b/tests/winWm.test index 13ab984..5267b28 100644 --- a/tests/winWm.test +++ b/tests/winWm.test @@ -9,39 +9,28 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winWm.test,v 1.19 2008/07/23 23:24:24 nijtmans Exp $ +# RCS: @(#) $Id: winWm.test,v 1.20 2008/08/30 21:52:26 aniap Exp $ -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands -# Measure the height of a single menu line -toplevel .t -frame .t.f -width 100 -height 50 -pack .t.f -menu .t.m -.t.m add command -label "thisisreallylong" -.t configure -menu .t.m -wm geometry .t -0-0 -update -set menuheight [winfo y .t] -.t.m add command -label "thisisreallylong" -wm geometry .t -0-0 -update -set menuheight [expr {$menuheight - [winfo y .t]}] -destroy .t - -test winWm-1.1 {TkWmMapWindow} win { +test winWm-1.1 {TkWmMapWindow} -constraints win -setup { + destroy .t +} -body { toplevel .t wm override .t 1 wm geometry .t +0+0 update - set result [list [winfo rootx .t] [winfo rooty .t]] + list [winfo rootx .t] [winfo rooty .t] +} -cleanup { destroy .t - set result -} {0 0} -test winWm-1.2 {TkWmMapWindow} win { +} -result {0 0} +test winWm-1.2 {TkWmMapWindow} -constraints win -setup { + destroy .t +} -body { toplevel .t wm transient .t . update @@ -49,40 +38,47 @@ test winWm-1.2 {TkWmMapWindow} win { update wm deiconify . update - catch {wm iconify .t} msg + wm iconify .t +} -cleanup { destroy .t - set msg -} {can't iconify ".t": it is a transient} -test winWm-1.3 {TkWmMapWindow} win { +} -returnCodes error -result {can't iconify ".t": it is a transient} +test winWm-1.3 {TkWmMapWindow} -constraints win -setup { + destroy .t +} -body { toplevel .t update toplevel .t2 update - set result [expr {[winfo x .t] != [winfo x .t2]}] + expr {[winfo x .t] != [winfo x .t2]} +} -cleanup { destroy .t .t2 - set result -} 1 -test winWm-1.4 {TkWmMapWindow} win { +} -result 1 +test winWm-1.4 {TkWmMapWindow} -constraints win -setup { + destroy .t +} -body { toplevel .t wm geometry .t +10+10 update toplevel .t2 wm geometry .t2 +40+10 update - set result [list [winfo x .t] [winfo x .t2]] + list [winfo x .t] [winfo x .t2] +} -cleanup { destroy .t .t2 - set result -} {10 40} -test winWm-1.5 {TkWmMapWindow} win { +} -result {10 40} +test winWm-1.5 {TkWmMapWindow} -constraints win -setup { + destroy .t +} -body { toplevel .t wm iconify .t update - set result [wm state .t] - destroy .t - set result -} iconic + wm state .t +} -result {iconic} + -test winWm-2.1 {TkpWmSetState} win { +test winWm-2.1 {TkpWmSetState} -constraints win -setup { + destroy .t +} -body { toplevel .t wm geometry .t 150x50+10+10 update @@ -93,10 +89,12 @@ test winWm-2.1 {TkpWmSetState} win { wm deiconify .t update lappend result [wm state .t] +} -cleanup { + destroy .t +} -result {normal iconic normal} +test winWm-2.2 {TkpWmSetState} -constraints win -setup { destroy .t - set result -} {normal iconic normal} -test winWm-2.2 {TkpWmSetState} win { +} -body { toplevel .t wm geometry .t 150x50+10+10 update @@ -108,12 +106,14 @@ test winWm-2.2 {TkpWmSetState} win { update lappend result [wm state .t] wm deiconify .t - update + update lappend result [wm state .t] +} -cleanup { + destroy .t +} -result {normal withdrawn iconic normal} +test winWm-2.3 {TkpWmSetState} -constraints win -setup { destroy .t - set result -} {normal withdrawn iconic normal} -test winWm-2.3 {TkpWmSetState} win { +} -body { toplevel .t wm geometry .t 150x50+10+10 update @@ -125,13 +125,15 @@ test winWm-2.3 {TkpWmSetState} win { update lappend result [wm state .t] wm state .t normal - update + update lappend result [wm state .t] +} -cleanup { + destroy .t +} -result {normal withdrawn iconic normal} +test winWm-2.4 {TkpWmSetState} -constraints win -setup { destroy .t - set result -} {normal withdrawn iconic normal} -test winWm-2.4 {TkpWmSetState} win { set result {} +} -body { toplevel .t wm geometry .t 150x50+10+10 update @@ -145,11 +147,16 @@ test winWm-2.4 {TkpWmSetState} win { wm deiconify .t update lappend result [list [wm state .t] [wm geometry .t]] +} -cleanup { destroy .t - set result -} {{normal 150x50+10+10} {iconic 150x50+10+10} {iconic 150x50+10+10} {normal 200x50+10+10}} +} -result {{normal 150x50+10+10} {iconic 150x50+10+10} {iconic 150x50+10+10} {normal 200x50+10+10}} -test winWm-3.1 {ConfigureTopLevel: window geometry propagation} win { + +test winWm-3.1 {ConfigureTopLevel: window geometry propagation} -constraints { + win +} -setup { + destroy .t +} -body { toplevel .t wm geometry .t +0+0 button .t.b @@ -163,13 +170,30 @@ test winWm-3.1 {ConfigureTopLevel: window geometry propagation} win { update pack .t.b update - set x [expr {$x == [winfo x .t.b]}] + expr {$x == [winfo x .t.b]} +} -cleanup { + destroy .t +} -result 1 + + +test winWm-4.1 {ConfigureTopLevel: menu resizing} -constraints win -setup { + destroy .t +} -body { + toplevel .t + frame .t.f -width 100 -height 50 + pack .t.f + menu .t.m + .t.m add command -label "thisisreallylong" + .t configure -menu .t.m + wm geometry .t -0-0 + update + set menuheight [winfo y .t] + .t.m add command -label "thisisreallylong" + wm geometry .t -0-0 + update + set menuheight [expr {$menuheight - [winfo y .t]}] destroy .t - set x -} 1 -test winWm-4.1 {ConfigureTopLevel: menu resizing} win { - set result {} toplevel .t frame .t.f -width 150 -height 50 -background red pack .t.f @@ -180,18 +204,21 @@ test winWm-4.1 {ConfigureTopLevel: menu resizing} win { .t.m add command -label foo .t configure -menu .t.m update - set result [expr {$y - [winfo y .t]}] + expr {$y - [winfo y .t] eq $menuheight + 1} +} -cleanup { destroy .t - set result -} [expr {$menuheight + 1}] +} -result 1 + # This test works on 8.0p2 but has not worked on anything since 8.2. # It would be very strange to have a windows application increase the size # of the clientarea when a menu wraps so I believe this test to be wrong. # Original result was {50 50 50} new result may depend on the default menu # font -test winWm-5.1 {UpdateGeometryInfo: menu resizing} win { +test winWm-5.1 {UpdateGeometryInfo: menu resizing} -constraints win -setup { + destroy .t set result {} +} -body { toplevel .t frame .t.f -width 150 -height 50 -background red pack .t.f @@ -206,11 +233,12 @@ test winWm-5.1 {UpdateGeometryInfo: menu resizing} win { .t.m add command -label "thisisreallylong" update lappend result [winfo height .t] +} -cleanup { + destroy .t +} -result {50 50 31} +test winWm-5.2 {UpdateGeometryInfo: menu resizing} -constraints win -setup { destroy .t - - set result -} {50 50 31} -test winWm-5.2 {UpdateGeometryInfo: menu resizing} win { +} -body { set result {} toplevel .t frame .t.f -width 150 -height 50 -background red @@ -228,29 +256,41 @@ test winWm-5.2 {UpdateGeometryInfo: menu resizing} win { lappend result [winfo height .t] lappend result [expr {$y - [winfo rooty .t]}] destroy .t - set result -} {50 50 0} + return $result +} -cleanup { + destroy .t +} -result {50 50 0} -test winWm-6.1 {wm attributes} win { +test winWm-6.1 {wm attributes} -constraints win -setup { destroy .t +} -body { toplevel .t wm attributes .t -} {-alpha 1.0 -transparentcolor {} -disabled 0 -fullscreen 0 -toolwindow 0 -topmost 0} -test winWm-6.2 {wm attributes} win { +} -cleanup { + destroy .t +} -result {-alpha 1.0 -transparentcolor {} -disabled 0 -fullscreen 0 -toolwindow 0 -topmost 0} +test winWm-6.2 {wm attributes} -constraints win -setup { destroy .t +} -body { toplevel .t wm attributes .t -disabled -} {0} -test winWm-6.3 {wm attributes} win { - # This isn't quite the correct error message yet, but it works. +} -cleanup { + destroy .t +} -result {0} +test winWm-6.3 {wm attributes} -constraints win -setup { destroy .t +} -body { + # This isn't quite the correct error message yet, but it works. toplevel .t - list [catch {wm attributes .t -foo} msg] $msg -} {1 {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-fullscreen ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"}} + wm attributes .t -foo +} -cleanup { + destroy .t +} -returnCodes error -result {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-fullscreen ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"} -test winWm-6.4 {wm attributes -alpha} win { - # Expect this to return all 1.0 {} on pre-2K/XP +test winWm-6.4 {wm attributes -alpha} -constraints win -setup { destroy .t +} -body { + # Expect this to return all 1.0 {} on pre-2K/XP toplevel .t set res [wm attributes .t -alpha] # we don't return on set yet @@ -260,72 +300,94 @@ test winWm-6.4 {wm attributes -alpha} win { lappend res [wm attributes .t -alpha] lappend res [wm attributes .t -alpha 100] lappend res [wm attributes .t -alpha] - set res -} {1.0 {} 0.5 {} 0.0 {} 1.0} + return $res +} -cleanup { + destroy .t +} -result {1.0 {} 0.5 {} 0.0 {} 1.0} -test winWm-6.5 {wm attributes -alpha} win { +test winWm-6.5 {wm attributes -alpha} -constraints win -setup { destroy .t +} -body { toplevel .t - list [catch {wm attributes .t -alpha foo} msg] $msg -} {1 {expected floating-point number but got "foo"}} + wm attributes .t -alpha foo +} -cleanup { + destroy .t +} -returnCodes error -result {expected floating-point number but got "foo"} -test winWm-6.6 {wm attributes -alpha} win { - # This test is just to show off -alpha +test winWm-6.6 {wm attributes -alpha} -constraints win -setup { destroy .t +} -body { + # This test is just to show off -alpha toplevel .t wm attributes .t -alpha 0.2 pack [label .t.l -text "Alpha Toplevel" -font "Helvetica 18 bold"] tk::PlaceWindow .t center update if {$::tcl_platform(osVersion) >= 5.0} { - for {set i 0.2} {$i < 0.99} {set i [expr {$i+0.02}]} { - wm attributes .t -alpha $i - update idle - after 20 - } - for {set i 0.99} {$i > 0.2} {set i [expr {$i-0.02}]} { - wm attributes .t -alpha $i - update idle - after 20 - } + for {set i 0.2} {$i < 0.99} {set i [expr {$i+0.02}]} { + wm attributes .t -alpha $i + update idle + after 20 + } + for {set i 0.99} {$i > 0.2} {set i [expr {$i-0.02}]} { + wm attributes .t -alpha $i + update idle + after 20 + } } -} {} +} -cleanup { + destroy .t +} -result {} -test winWm-6.7 {wm attributes -transparentcolor} win { - # Expect this to return all "" on pre-2K/XP +test winWm-6.7 {wm attributes -transparentcolor} -constraints win -setup { destroy .t - toplevel .t set res {} +} -body { + # Expect this to return all "" on pre-2K/XP + toplevel .t lappend res [wm attributes .t -transparentcolor] # we don't return on set yet lappend res [wm attributes .t -trans black] lappend res [wm attributes .t -trans] lappend res [wm attributes .t -trans "#FFFFFF"] lappend res [wm attributes .t -trans] +} -cleanup { destroy .t - set res -} [list {} {} black {} "#FFFFFF"] +} -result [list {} {} black {} "#FFFFFF"] -test winWm-6.8 {wm attributes -transparentcolor} win { +test winWm-6.8 {wm attributes -transparentcolor} -constraints win -setup { + destroy .t +} -body { destroy .t toplevel .t - list [catch {wm attributes .t -tr foo} msg] $msg -} {1 {unknown color name "foo"}} + wm attributes .t -tr foo +} -cleanup { + destroy .t +} -returnCodes error -result {unknown color name "foo"} -test winWm-7.1 {deiconify on an unmapped toplevel\ - will raise the window and set the focus} win { + +test winWm-7.1 {deiconify on an unmapped toplevel will raise \ + the window and set the focus} -constraints { + win +} -setup { destroy .t +} -body { toplevel .t lower .t focus -force . wm deiconify .t update list [wm stackorder .t isabove .] [focus] -} {1 .t} +} -cleanup { + destroy .t +} -result {1 .t} test winWm-7.2 {deiconify on an already mapped toplevel\ - will raise the window and set the focus} win { + will raise the window and set the focus} -constraints { + win +} -setup { destroy .t +} -body { toplevel .t lower .t update @@ -333,9 +395,13 @@ test winWm-7.2 {deiconify on an already mapped toplevel\ wm deiconify .t update list [wm stackorder .t isabove .] [focus] -} {1 .t} +} -cleanup { + destroy .t +} -result {1 .t} -test winWm-7.3 {UpdateWrapper must maintain Z order} win { +test winWm-7.3 {UpdateWrapper must maintain Z order} -constraints win -setup { + destroy .t +} -body { destroy .t toplevel .t lower .t @@ -344,10 +410,13 @@ test winWm-7.3 {UpdateWrapper must maintain Z order} win { wm resizable .t 0 0 update list $res [wm stackorder .t isbelow .] -} {1 1} +} -cleanup { + destroy .t +} -result {1 1} -test winWm-7.4 {UpdateWrapper must maintain focus} win { +test winWm-7.4 {UpdateWrapper must maintain focus} -constraints win -setup { destroy .t +} -body { toplevel .t focus -force .t update @@ -355,23 +424,34 @@ test winWm-7.4 {UpdateWrapper must maintain focus} win { wm resizable .t 0 0 update list $res [focus] -} {.t .t} +} -cleanup { + destroy .t +} -result {.t .t} -test winWm-8.1 {Tk_WmCmd procedure, "iconphoto" option} win { - list [catch {wm iconph .} msg] $msg -} {1 {wrong # args: should be "wm iconphoto window ?-default? image ?image ...?"}} -test winWm-8.2 {Tk_WmCmd procedure, "iconphoto" option} win { + +test winWm-8.1 {Tk_WmCmd procedure, "iconphoto" option} -constraints win -body { + wm iconph . +} -returnCodes error -result {wrong # args: should be "wm iconphoto window ?-default? image ?image ...?"} +test winWm-8.2 {Tk_WmCmd procedure, "iconphoto" option} -constraints win -setup { destroy .t +} -body { toplevel .t image create photo blank16 -width 16 -height 16 image create photo blank32 -width 32 -height 32 # This should just make blank icons for the window wm iconphoto .t blank16 blank32 image delete blank16 blank32 -} {} +} -cleanup { + destroy .t +} -result {} destroy .t # cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End: + diff --git a/tests/window.test b/tests/window.test index 6d5d9aa..e5b10f6 100644 --- a/tests/window.test +++ b/tests/window.test @@ -5,42 +5,51 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: window.test,v 1.12 2004/06/24 12:45:44 dkf Exp $ +# RCS: @(#) $Id: window.test,v 1.13 2008/08/30 21:52:26 aniap Exp $ -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands +namespace import ::tk::test::loadTkCommand -namespace import -force ::tk::test::loadTkCommand update # XXX This file is woefully incomplete. Right now it only tests # a few parts of a few procedures in tkWindow.c -test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} { +# ---------------------------------------------------------------------- + +test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} -setup { + destroy .t +} -body { proc bgerror msg { - global x errorInfo - set x [list $msg $errorInfo] + global x errorInfo + set x [list $msg $errorInfo] } + set x unchanged - catch {destroy .t} frame .t -width 100 -height 50 place .t -x 10 -y 10 bind .t <Destroy> {button .t.b -text hello; pack .t.b} update destroy .t update - rename bgerror {} set x -} {{can't create window: parent has been destroyed} {can't create window: parent has been destroyed +} -cleanup { + rename bgerror {} +} -result {{can't create window: parent has been destroyed} {can't create window: parent has been destroyed while executing "button .t.b -text hello" (command bound to event)}} + # Most of the tests below don't produce meaningful results; they # will simply dump core if there are bugs. -test window-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} { +test window-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup { + destroy .t +} -body { toplevel .t -width 300 -height 200 wm geometry .t +0+0 frame .t.f -width 200 -height 200 -relief raised -bd 2 @@ -50,8 +59,10 @@ test window-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} { bind .t.f <Destroy> {destroy .t} update destroy .t.f -} {} -test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} { +} -result {} +test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup { + destroy .t +} -body { toplevel .t -width 300 -height 200 wm geometry .t +0+0 frame .t.f -width 200 -height 200 -relief raised -bd 2 @@ -61,8 +72,10 @@ test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} { bind .t.f.f <Destroy> {destroy .t} update destroy .t.f -} {} -test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} { +} -result {} +test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup { + destroy .f +} -body { frame .f -width 80 -height 120 -relief raised -bd 2 place .f -relx 0.5 -rely 0.5 -anchor center toplevel .f.t -width 300 -height 200 @@ -73,10 +86,11 @@ test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} { place .f.t.f.f -relx 1 -rely 1 -anchor se update destroy .f -} {} +} -result {} -test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} \ - unixOrWin { +test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} -constraints { + unixOrWin +} -body { set code [loadTkCommand] append code { update @@ -85,16 +99,17 @@ test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} \ } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 {}} +} -result {0 {}} -test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} \ - unixOrWin { +test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints { + unixOrWin +} -body { set code [loadTkCommand] append code { toplevel .t @@ -104,16 +119,17 @@ test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} \ } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 {}} +} -result {0 {}} -test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} \ - unixOrWin { +test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints { + unixOrWin +} -body { set code [loadTkCommand] append code { toplevel .t @@ -123,16 +139,17 @@ test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} \ } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 {}} +} -result {0 {}} -test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} \ - unixOrWin { +test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints { + unixOrWin +} -body { set code [loadTkCommand] append code { toplevel .t @@ -143,16 +160,17 @@ test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} \ } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 {}} +} -result {0 {}} -test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \ - unixOrWin { +test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints { + unixOrWin +} -body { set code [loadTkCommand] append code { toplevel .t1 @@ -166,16 +184,17 @@ test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \ } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 {}} +} -result {0 {}} -test window-2.9 {Tk_DestroyWindow, Destroy bindings - evaluated after exit} unixOrWin { +test window-2.9 {Tk_DestroyWindow, Destroy bindings evaluated after exit} -constraints { + unixOrWin +} -body { set code [loadTkCommand] append code { toplevel .t1 @@ -187,17 +206,18 @@ test window-2.9 {Tk_DestroyWindow, Destroy bindings } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 {Destroy .t2 +} -result {0 {Destroy .t2 Destroy .t1}} -test window-2.10 {Tk_DestroyWindow, Destroy binding - evaluated once} unixOrWin { +test window-2.10 {Tk_DestroyWindow, Destroy binding evaluated once} -constraints { + unixOrWin +} -body { set code [loadTkCommand] append code { update @@ -210,16 +230,17 @@ test window-2.10 {Tk_DestroyWindow, Destroy binding } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 {Destroy .}} +} -result {0 {Destroy .}} -test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} \ - unixOrWin { +test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} -constraints { + unixOrWin +} -body { set code [loadTkCommand] append code { toplevel .t1 @@ -237,17 +258,20 @@ test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} \ } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 YES} +} -result {0 YES} -test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ - {unix testmenubar} { - catch {destroy .t} + +test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints { + unix testmenubar +} -setup { + destroy .t +} -body { toplevel .t -width 300 -height 200 wm geometry .t +0+0 pack [entry .t.e] @@ -255,10 +279,14 @@ test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ testmenubar window .t .t.f update # If stacking order isn't handle properly, generates an X error. -} {} -test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} \ - {unix testmenubar} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {} +test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints { + unix testmenubar +} -setup { + destroy .t +} -body { toplevel .t -width 300 -height 200 wm geometry .t +0+0 pack [entry .t.e] @@ -269,23 +297,39 @@ test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} \ testmenubar window .t .t.f update # If stacking order isn't handled properly, generates an X error. -} {} +} -cleanup { + destroy .t +} -result {} + -test window-4.1 {Tk_NameToWindow procedure} {testmenubar} { - catch {destroy .t} - list [catch {winfo geometry .t} msg] $msg -} {1 {bad window path name ".t"}} -test window-4.2 {Tk_NameToWindow procedure} {testmenubar} { - catch {destroy .t} +test window-4.1 {Tk_NameToWindow procedure} -constraints { + testmenubar +} -setup { + destroy .t +} -body { + winfo geometry .t +} -cleanup { + destroy .t +} -returnCodes error -result {bad window path name ".t"} +test window-4.2 {Tk_NameToWindow procedure} -constraints { + testmenubar +} -setup { + destroy .t +} -body { frame .t -width 100 -height 50 place .t -x 10 -y 10 update - list [catch {winfo geometry .t} msg] $msg -} {0 100x50+10+10} + winfo geometry .t +} -cleanup { + destroy .t +} -returnCodes ok -result {100x50+10+10} + -test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ - {unix testmenubar} { - catch {destroy .t} +test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints { + unix testmenubar +} -setup { + destroy .t +} -body { toplevel .t -width 300 -height 200 wm geometry .t +0+0 pack [entry .t.e] @@ -296,8 +340,15 @@ test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ lower .t.e2 .t.f update # If stacking order isn't handled properly, generates an X error. -} {} +} -cleanup { + destroy .t +} -result {} + # cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End:
\ No newline at end of file diff --git a/tests/winfo.test b/tests/winfo.test index 0b2b9d6..6754ca3 100644 --- a/tests/winfo.test +++ b/tests/winfo.test @@ -6,10 +6,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winfo.test,v 1.15 2007/12/13 15:27:55 dgp Exp $ +# RCS: @(#) $Id: winfo.test,v 1.16 2008/08/30 21:52:26 aniap Exp $ -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands # eatColors -- @@ -17,22 +18,22 @@ tcltest::loadTestedCommands # use up all the slots in the colormap. # # Arguments: -# w - Name of toplevel window to create. -# options - Options for w, such as "-colormap new". +# w - Name of toplevel window to create. +# options - Options for w, such as "-colormap new". proc eatColors {w {options ""}} { - catch {destroy $w} + destroy $w eval toplevel $w $options 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 - } + 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 } @@ -40,57 +41,69 @@ proc eatColors {w {options ""}} { # XXX - This test file is woefully incomplete. At present, only a # few of the winfo options are tested. -test winfo-1.1 {"winfo atom" command} { - list [catch {winfo atom} msg] $msg -} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}} -test winfo-1.2 {"winfo atom" command} { - list [catch {winfo atom a b} msg] $msg -} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}} -test winfo-1.3 {"winfo atom" command} { - list [catch {winfo atom a b c d} msg] $msg -} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}} -test winfo-1.4 {"winfo atom" command} { - list [catch {winfo atom -displayof geek foo} msg] $msg -} {1 {bad window path name "geek"}} -test winfo-1.5 {"winfo atom" command} { +# ---------------------------------------------------------------------- + +test winfo-1.1 {"winfo atom" command} -body { + winfo atom +} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"} +test winfo-1.2 {"winfo atom" command} -body { + winfo atom a b +} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"} +test winfo-1.3 {"winfo atom" command} -body { + winfo atom a b c d +} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"} +test winfo-1.4 {"winfo atom" command} -body { + winfo atom -displayof geek foo +} -returnCodes error -result {bad window path name "geek"} +test winfo-1.5 {"winfo atom" command} -body { winfo atom PRIMARY -} 1 -test winfo-1.6 {"winfo atom" command} { +} -result 1 +test winfo-1.6 {"winfo atom" command} -body { winfo atom -displayof . PRIMARY -} 1 - -test winfo-2.1 {"winfo atomname" command} { - list [catch {winfo atomname} msg] $msg -} {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}} -test winfo-2.2 {"winfo atomname" command} { - list [catch {winfo atomname a b} msg] $msg -} {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}} -test winfo-2.3 {"winfo atomname" command} { - list [catch {winfo atomname a b c d} msg] $msg -} {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}} -test winfo-2.4 {"winfo atomname" command} { - list [catch {winfo atomname -displayof geek foo} msg] $msg -} {1 {bad window path name "geek"}} -test winfo-2.5 {"winfo atomname" command} { - list [catch {winfo atomname 44215} msg] $msg -} {1 {no atom exists with id "44215"}} -test winfo-2.6 {"winfo atomname" command} { +} -result 1 + + +test winfo-2.1 {"winfo atomname" command} -body { + winfo atomname +} -returnCodes error -result {wrong # args: should be "winfo atomname ?-displayof window? id"} +test winfo-2.2 {"winfo atomname" command} -body { + winfo atomname a b +} -returnCodes error -result {wrong # args: should be "winfo atomname ?-displayof window? id"} +test winfo-2.3 {"winfo atomname" command} -body { + winfo atomname a b c d +} -returnCodes error -result {wrong # args: should be "winfo atomname ?-displayof window? id"} +test winfo-2.4 {"winfo atomname" command} -body { + winfo atomname -displayof geek foo +} -returnCodes error -result {bad window path name "geek"} +test winfo-2.5 {"winfo atomname" command} -body { + winfo atomname 44215 +} -returnCodes error -result {no atom exists with id "44215"} +test winfo-2.6 {"winfo atomname" command} -body { winfo atomname 2 -} SECONDARY -test winfo-2.7 {"winfo atom" command} { +} -result SECONDARY +test winfo-2.7 {"winfo atom" command} -body { winfo atomname -displayof . 2 -} SECONDARY - -test winfo-3.1 {"winfo colormapfull" command} defaultPseudocolor8 { - list [catch {winfo colormapfull} msg] $msg -} {1 {wrong # args: should be "winfo colormapfull window"}} -test winfo-3.2 {"winfo colormapfull" command} defaultPseudocolor8 { - list [catch {winfo colormapfull a b} msg] $msg -} {1 {wrong # args: should be "winfo colormapfull window"}} -test winfo-3.3 {"winfo colormapfull" command} defaultPseudocolor8 { - list [catch {winfo colormapfull foo} msg] $msg -} {1 {bad window path name "foo"}} -test winfo-3.4 {"winfo colormapfull" command} {unix defaultPseudocolor8} { +} -result SECONDARY + + +test winfo-3.1 {"winfo colormapfull" command} -constraints { + defaultPseudocolor8 +} -body { + winfo colormapfull +} -returnCodes error -result {wrong # args: should be "winfo colormapfull window"} +test winfo-3.2 {"winfo colormapfull" command} -constraints { + defaultPseudocolor8 +} -body { + winfo colormapfull a b +} -returnCodes error -result {wrong # args: should be "winfo colormapfull window"} +test winfo-3.3 {"winfo colormapfull" command} -constraints { + defaultPseudocolor8 +} -body { + winfo colormapfull foo +} -returnCodes error -result {bad window path name "foo"} +test winfo-3.4 {"winfo colormapfull" command} -constraints { + unix defaultPseudocolor8 +} -body { eatColors .t {-colormap new} set result [list [winfo colormapfull .] [winfo colormapfull .t]] .t.c delete 34 @@ -101,69 +114,103 @@ test winfo-3.4 {"winfo colormapfull" command} {unix defaultPseudocolor8} { lappend result [winfo colormapfull .t] destroy .t.c lappend result [winfo colormapfull .t] -} {0 1 0 0 1 0} -catch {destroy .t} - -toplevel .t -width 550 -height 400 -frame .t.f -width 80 -height 60 -bd 2 -relief raised -place .t.f -x 50 -y 50 -wm geom .t +0+0 -update -test winfo-4.1 {"winfo containing" command} { - list [catch {winfo containing 22} msg] $msg -} {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}} -test winfo-4.2 {"winfo containing" command} { - list [catch {winfo containing a b c} msg] $msg -} {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}} -test winfo-4.3 {"winfo containing" command} { - list [catch {winfo containing a b c d e} msg] $msg -} {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}} -test winfo-4.4 {"winfo containing" command} { - list [catch {winfo containing -displayof geek 25 30} msg] $msg -} {1 {bad window path name "geek"}} -test winfo-4.5 {"winfo containing" command} { +} -cleanup { + destroy .t +} -result {0 1 0 0 1 0} + + + +test winfo-4.1 {"winfo containing" command} -body { + winfo containing 22 +} -returnCodes error -result {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"} +test winfo-4.2 {"winfo containing" command} -body { + winfo containing a b c +} -returnCodes error -result {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"} +test winfo-4.3 {"winfo containing" command} -body { + winfo containing a b c d e +} -returnCodes error -result {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"} +test winfo-4.4 {"winfo containing" command} -body { + winfo containing -displayof geek 25 30 +} -returnCodes error -result {bad window path name "geek"} +test winfo-4.5 {"winfo containing" command} -body { +} -setup { + destroy .t +} -body { + toplevel .t -width 550 -height 400 + frame .t.f -width 80 -height 60 -bd 2 -relief raised + place .t.f -x 50 -y 50 + wm geom .t +0+0 + update + raise .t winfo containing [winfo rootx .t.f] [winfo rooty .t.f] -} .t.f -test winfo-4.6 {"winfo containing" command} {nonPortable} { +} -cleanup { + destroy .t +} -result .t.f +test winfo-4.6 {"winfo containing" command} -constraints { + nonPortable +} -setup { + destroy .t +} -body { + toplevel .t -width 550 -height 400 + frame .t.f -width 80 -height 60 -bd 2 -relief raised + place .t.f -x 50 -y 50 + wm geom .t +0+0 + update + winfo containing [expr [winfo rootx .t.f]-1] [expr [winfo rooty .t.f]-1] -} .t -test winfo-4.7 {"winfo containing" command} { +} -cleanup { + destroy .t +} -result .t +test winfo-4.7 {"winfo containing" command} -setup { + destroy .t +} -body { + toplevel .t -width 550 -height 400 + frame .t.f -width 80 -height 60 -bd 2 -relief raised + place .t.f -x 50 -y 50 + wm geom .t +0+0 + update + set x [winfo containing -display .t.f [expr [winfo rootx .t]+600] \ - [expr [winfo rooty .t.f]+450]] + [expr [winfo rooty .t.f]+450]] expr {($x == ".") || ($x == "")} -} {1} -destroy .t - -test winfo-5.1 {"winfo interps" command} { - list [catch {winfo interps a} msg] $msg -} {1 {wrong # args: should be "winfo interps ?-displayof window?"}} -test winfo-5.2 {"winfo interps" command} { - list [catch {winfo interps a b c} msg] $msg -} {1 {wrong # args: should be "winfo interps ?-displayof window?"}} -test winfo-5.3 {"winfo interps" command} { - list [catch {winfo interps -displayof geek} msg] $msg -} {1 {bad window path name "geek"}} -test winfo-5.4 {"winfo interps" command} unix { - expr [lsearch -exact [winfo interps] [tk appname]] >= 0 -} {1} -test winfo-5.5 {"winfo interps" command} unix { - expr [lsearch -exact [winfo interps -displayof .] [tk appname]] >= 0 -} {1} - -test winfo-6.1 {"winfo exists" command} { - list [catch {winfo exists} msg] $msg -} {1 {wrong # args: should be "winfo exists window"}} -test winfo-6.2 {"winfo exists" command} { - list [catch {winfo exists a b} msg] $msg -} {1 {wrong # args: should be "winfo exists window"}} -test winfo-6.3 {"winfo exists" command} { +} -cleanup { + destroy .t +} -result {1} + + +test winfo-5.1 {"winfo interps" command} -body { + winfo interps a +} -returnCodes error -result {wrong # args: should be "winfo interps ?-displayof window?"} +test winfo-5.2 {"winfo interps" command} -body { + winfo interps a b c +} -returnCodes error -result {wrong # args: should be "winfo interps ?-displayof window?"} +test winfo-5.3 {"winfo interps" command} -body { + winfo interps -displayof geek +} -returnCodes error -result {bad window path name "geek"} +test winfo-5.4 {"winfo interps" command} -constraints unix -body { + expr {[lsearch -exact [winfo interps] [tk appname]] >= 0} +} -result {1} +test winfo-5.5 {"winfo interps" command} -constraints unix -body { + expr {[lsearch -exact [winfo interps -displayof .] [tk appname]] >= 0} +} -result {1} + + +test winfo-6.1 {"winfo exists" command} -body { + winfo exists +} -returnCodes error -result {wrong # args: should be "winfo exists window"} +test winfo-6.2 {"winfo exists" command} -body { + winfo exists a b +} -returnCodes error -result {wrong # args: should be "winfo exists window"} +test winfo-6.3 {"winfo exists" command} -body { winfo exists gorp -} {0} -test winfo-6.4 {"winfo exists" command} { +} -result {0} +test winfo-6.4 {"winfo exists" command} -body { winfo exists . -} {1} -test winfo-6.5 {"winfo exists" command} { +} -result {1} +test winfo-6.5 {"winfo exists" command} -setup { + destroy .b +} -body { button .b -text "Test button" set x [winfo exists .b] pack .b @@ -171,78 +218,113 @@ test winfo-6.5 {"winfo exists" command} { bind .b <Destroy> {lappend x [winfo exists .x]} destroy .b lappend x [winfo exists .x] -} {1 0 0} - -catch {destroy .b} -button .b -text "Help" -update -test winfo-7.1 {"winfo pathname" command} { - list [catch {winfo pathname} msg] $msg -} {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}} -test winfo-7.2 {"winfo pathname" command} { - list [catch {winfo pathname a b} msg] $msg -} {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}} -test winfo-7.3 {"winfo pathname" command} { - list [catch {winfo pathname a b c d} msg] $msg -} {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}} -test winfo-7.4 {"winfo pathname" command} { - list [catch {winfo pathname -displayof geek 25} msg] $msg -} {1 {bad window path name "geek"}} -test winfo-7.5 {"winfo pathname" command} { - list [catch {winfo pathname xyz} msg] $msg -} {1 {expected integer but got "xyz"}} -test winfo-7.6 {"winfo pathname" command} { - list [catch {winfo pathname 224} msg] $msg -} {1 {window id "224" doesn't exist in this application}} -test winfo-7.7 {"winfo pathname" command} { +} -result {1 0 0} + + +test winfo-7.1 {"winfo pathname" command} -body { + winfo pathname +} -returnCodes error -result {wrong # args: should be "winfo pathname ?-displayof window? id"} +test winfo-7.2 {"winfo pathname" command} -body { + winfo pathname a b +} -returnCodes error -result {wrong # args: should be "winfo pathname ?-displayof window? id"} +test winfo-7.3 {"winfo pathname" command} -body { + winfo pathname a b c d +} -returnCodes error -result {wrong # args: should be "winfo pathname ?-displayof window? id"} +test winfo-7.4 {"winfo pathname" command} -body { + winfo pathname -displayof geek 25 +} -returnCodes error -result {bad window path name "geek"} +test winfo-7.5 {"winfo pathname" command} -body { + winfo pathname xyz +} -returnCodes error -result {expected integer but got "xyz"} +test winfo-7.6 {"winfo pathname" command} -body { + winfo pathname 224 +} -returnCodes error -result {window id "224" doesn't exist in this application} +test winfo-7.7 {"winfo pathname" command} -setup { + destroy .b + button .b -text "Help" + update +} -body { winfo pathname -displayof .b [winfo id .] -} {.} -test winfo-7.8 {"winfo pathname" command} {unix testwrapper} { +} -cleanup { + destroy .b +} -result {.} +test winfo-7.8 {"winfo pathname" command} -constraints { + unix testwrapper +} -body { winfo pathname [testwrapper .] -} {} +} -result {} + -test winfo-8.1 {"winfo pointerx" command} { +test winfo-8.1 {"winfo pointerx" command} -setup { + destroy .b + button .b -text "Help" + update +} -body { + catch [winfo pointerx .b] +} -body { catch [winfo pointerx .b] -} 1 -test winfo-8.2 {"winfo pointery" command} { +} -result 1 +test winfo-8.2 {"winfo pointery" command} -setup { + destroy .b + button .b -text "Help" + update +} -body { catch [winfo pointery .b] -} 1 -test winfo-8.3 {"winfo pointerxy" command} { +} -body { + catch [winfo pointerx .b] +} -result 1 +test winfo-8.3 {"winfo pointerxy" command} -setup { + destroy .b + button .b -text "Help" + update +} -body { catch [winfo pointerxy .b] -} 1 - -test winfo-9.1 {"winfo viewable" command} { - list [catch {winfo viewable} msg] $msg -} {1 {wrong # args: should be "winfo viewable window"}} -test winfo-9.2 {"winfo viewable" command} { - list [catch {winfo viewable foo} msg] $msg -} {1 {bad window path name "foo"}} -test winfo-9.3 {"winfo viewable" command} { +} -body { + catch [winfo pointerx .b] +} -result 1 + + +test winfo-9.1 {"winfo viewable" command} -body { + winfo viewable +} -returnCodes error -result {wrong # args: should be "winfo viewable window"} +test winfo-9.2 {"winfo viewable" command} -body { + winfo viewable foo +} -returnCodes error -result {bad window path name "foo"} +test winfo-9.3 {"winfo viewable" command} -body { winfo viewable . -} {1} -test winfo-9.4 {"winfo viewable" command} { +} -result {1} +test winfo-9.4 {"winfo viewable" command} -body { wm iconify . winfo viewable . -} {0} -wm deiconify . -test winfo-9.5 {"winfo viewable" command} { +} -cleanup { + wm deiconify . +} -result {0} +test winfo-9.5 {"winfo viewable" command} -setup { + deleteWindows +} -body { frame .f1 -width 100 -height 100 -relief raised -bd 2 place .f1 -x 0 -y 0 frame .f1.f2 -width 50 -height 50 -relief raised -bd 2 place .f1.f2 -x 0 -y 0 update list [winfo viewable .f1] [winfo viewable .f1.f2] -} {1 1} -test winfo-9.6 {"winfo viewable" command} { +} -cleanup { + deleteWindows +} -result {1 1} +test winfo-9.6 {"winfo viewable" command} -setup { deleteWindows +} -body { frame .f1 -width 100 -height 100 -relief raised -bd 2 frame .f1.f2 -width 50 -height 50 -relief raised -bd 2 place .f1.f2 -x 0 -y 0 update list [winfo viewable .f1] [winfo viewable .f1.f2] -} {0 0} -test winfo-9.7 {"winfo viewable" command} { +} -cleanup { deleteWindows +} -result {0 0} +test winfo-9.7 {"winfo viewable" command} -setup { + deleteWindows +} -body { frame .f1 -width 100 -height 100 -relief raised -bd 2 place .f1 -x 0 -y 0 frame .f1.f2 -width 50 -height 50 -relief raised -bd 2 @@ -250,121 +332,155 @@ test winfo-9.7 {"winfo viewable" command} { update wm iconify . list [winfo viewable .f1] [winfo viewable .f1.f2] -} {0 0} -wm deiconify . -deleteWindows +} -cleanup { + wm deiconify . + deleteWindows +} -result {0 0} + + +test winfo-10.1 {"winfo visualid" command} -body { + winfo visualid +} -returnCodes error -result {wrong # args: should be "winfo visualid window"} +test winfo-10.2 {"winfo visualid" command} -body { + winfo visualid gorp +} -returnCodes error -result {bad window path name "gorp"} +test winfo-10.3 {"winfo visualid" command} -body { + expr {2 + [winfo visualid .] - [winfo visualid .]} +} -result {2} -test winfo-10.1 {"winfo visualid" command} { - list [catch {winfo visualid} msg] $msg -} {1 {wrong # args: should be "winfo visualid window"}} -test winfo-10.2 {"winfo visualid" command} { - list [catch {winfo visualid gorp} msg] $msg -} {1 {bad window path name "gorp"}} -test winfo-10.3 {"winfo visualid" command} { - expr 2+[winfo visualid .]-[winfo visualid .] -} {2} - -test winfo-11.1 {"winfo visualid" command} { - list [catch {winfo visualsavailable} msg] $msg -} {1 {wrong # args: should be "winfo visualsavailable window ?includeids?"}} -test winfo-11.2 {"winfo visualid" command} { - list [catch {winfo visualsavailable gorp} msg] $msg -} {1 {bad window path name "gorp"}} -test winfo-11.3 {"winfo visualid" command} { - list [catch {winfo visualsavailable . includeids foo} msg] $msg -} {1 {wrong # args: should be "winfo visualsavailable window ?includeids?"}} -test winfo-11.4 {"winfo visualid" command} { + +test winfo-11.1 {"winfo visualid" command} -body { + winfo visualsavailable +} -returnCodes error -result {wrong # args: should be "winfo visualsavailable window ?includeids?"} +test winfo-11.2 {"winfo visualid" command} -body { + winfo visualsavailable gorp +} -returnCodes error -result {bad window path name "gorp"} +test winfo-11.3 {"winfo visualid" command} -body { + winfo visualsavailable . includeids foo +} -returnCodes error -result {wrong # args: should be "winfo visualsavailable window ?includeids?"} +test winfo-11.4 {"winfo visualid" command} -body { llength [lindex [winfo visualsa .] 0] -} {2} -test winfo-11.5 {"winfo visualid" command} { +} -result {2} +test winfo-11.5 {"winfo visualid" command} -body { llength [lindex [winfo visualsa . includeids] 0] -} {3} -test winfo-11.6 {"winfo visualid" command} { +} -result {3} +test winfo-11.6 {"winfo visualid" command} -body { set x [lindex [lindex [winfo visualsa . includeids] 0] 2] expr $x + 2 - $x -} {2} +} -result {2} + + +test winfo-12.1 {GetDisplayOf procedure} -body { + winfo atom - foo x +} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"} +test winfo-12.2 {GetDisplayOf procedure} -body { + winfo atom -d bad_window x +} -returnCodes error -result {bad window path name "bad_window"} -test winfo-12.1 {GetDisplayOf procedure} { - list [catch {winfo atom - foo x} msg] $msg -} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}} -test winfo-12.2 {GetDisplayOf procedure} { - list [catch {winfo atom -d bad_window x} msg] $msg -} {1 {bad window path name "bad_window"}} # Some embedding tests -# +# +test winfo-13.1 {root coordinates of embedded toplevel} -setup { + deleteWindows +} -body { + frame .con -container 1 + pack .con -expand yes -fill both + toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0 + button .emb.b + pack .emb.b -expand yes -fill both + update -proc MakeEmbed {} { + expr {[winfo rootx .emb] == [winfo rootx .con] \ + && [winfo rooty .emb] == [winfo rooty .con]} +} -cleanup { + deleteWindows +} -result {1} +test winfo-13.2 {destroying embedded toplevel} -setup { + deleteWindows +} -body { frame .con -container 1 pack .con -expand yes -fill both toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0 button .emb.b pack .emb.b -expand yes -fill both update -} -test winfo-13.1 {root coordinates of embedded toplevel} { - MakeEmbed - set z [expr [winfo rootx .emb] == [winfo rootx .con] && \ - [winfo rooty .emb] == [winfo rooty .con]] - destroy .emb - destroy .con - set z -} {1} -test winfo-13.2 {destroying embedded toplevel} { + destroy .emb update - expr [winfo exists .emb.b] || [winfo exists .con] -} 0 + expr {[winfo exists .emb.b] || [winfo exists .con]} +} -cleanup { + deleteWindows +} -result 0 -deleteWindows +test winfo-13.3 {destroying container window} -setup { + deleteWindows +} -body { + frame .con -container 1 + pack .con -expand yes -fill both + toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0 + button .emb.b + pack .emb.b -expand yes -fill both + update -test winfo-13.3 {destroying container window} { - MakeEmbed destroy .con update - set z [expr [winfo exists .emb.b] || [winfo exists .emb]] - catch {destroy .emb} - catch {destroy .con} - set z -} 0 + expr {[winfo exists .emb.b] || [winfo exists .emb]} +} -cleanup { + deleteWindows +} -result 0 -deleteWindows +test winfo-13.4 {[winfo containing] with embedded windows} -setup { + deleteWindows +} -body { + frame .con -container 1 + pack .con -expand yes -fill both + toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0 + button .emb.b + pack .emb.b -expand yes -fill both + update -test winfo-13.4 {[winfo containing] with embedded windows} { - MakeEmbed button .b pack .b -expand yes -fill both update + string compare .emb.b \ + [winfo containing [winfo rootx .emb.b] [winfo rooty .emb.b]] +} -cleanup { + deleteWindows +} -result 0 - set z [string compare \ - [winfo containing [winfo rootx .emb.b] [winfo rooty .emb.b]] .emb.b] - catch {destroy .con} - catch {destroy .emb} - set z -} 0 -test winfo-14.1 {usage} { - list [catch {winfo ismapped} msg] $msg -} {1 {wrong # args: should be "winfo ismapped window"}} +test winfo-14.1 {usage} -body { + winfo ismapped +} -returnCodes error -result {wrong # args: should be "winfo ismapped window"} -test winfo-14.2 {usage} { - list [catch {winfo ismapped . .} msg] $msg -} {1 {wrong # args: should be "winfo ismapped window"}} +test winfo-14.2 {usage} -body { + winfo ismapped . . +} -returnCodes error -result {wrong # args: should be "winfo ismapped window"} -test winfo-14.3 {initially unmapped} { - catch {destroy .t} +test winfo-14.3 {initially unmapped} -setup { + destroy .t +} -body { toplevel .t winfo ismapped .t -} 0 +} -cleanup { + destroy .t +} -result 0 -test winfo-14.4 {mapped at idle time} { - catch {destroy .t} +test winfo-14.4 {mapped at idle time} -setup { + destroy .t +} -body { toplevel .t update idletasks winfo ismapped .t -} 1 +} -cleanup { + destroy .t +} -result 1 deleteWindows # cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End:
\ No newline at end of file diff --git a/tests/xmfbox.test b/tests/xmfbox.test index 7f6c3fe..896599f 100644 --- a/tests/xmfbox.test +++ b/tests/xmfbox.test @@ -1,4 +1,4 @@ -# xmfbox.test -- +# xmfbox.test -- # # This file is a Tcl script to test the file dialog that's used # when the tk_strictMotif flag is set. Because the file dialog @@ -10,91 +10,106 @@ # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. # -# RCS: @(#) $Id: xmfbox.test,v 1.10 2004/06/24 12:45:45 dkf Exp $ +# RCS: @(#) $Id: xmfbox.test,v 1.11 2008/08/30 21:52:26 aniap Exp $ -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands set testPWD [pwd] -catch {unset foo} - catch {unset data foo} proc cleanup {} { global testPWD set err0 [catch { - cd $testPWD + cd $testPWD } msg0] set err1 [catch { - if [file exists ./~nosuchuser1] { - file delete ./~nosuchuser1 - } + if [file exists ./~nosuchuser1] { + file delete ./~nosuchuser1 + } } msg1] set err2 [catch { - if [file exists ./~nosuchuser2] { - file delete ./~nosuchuser2 - } + if [file exists ./~nosuchuser2] { + file delete ./~nosuchuser2 + } } msg2] set err3 [catch { - if [file exists ./~nosuchuser3] { - file delete ./~nosuchuser3 - } + if [file exists ./~nosuchuser3] { + file delete ./~nosuchuser3 + } } msg3] set err4 [catch { - if [file exists ./~nosuchuser4] { - file delete ./~nosuchuser4 - } + if [file exists ./~nosuchuser4] { + file delete ./~nosuchuser4 + } } msg4] if {$err0 || $err1 || $err2 || $err3 || $err4} { - error [list $msg0 $msg1 $msg2 $msg3 $msg4] + error [list $msg0 $msg1 $msg2 $msg3 $msg4] } catch {unset foo} - catch {destroy .foo} + destroy .foo } -test xmfbox-1.1 {tk::MotifFDialog_Create, -parent switch} unix { +# ---------------------------------------------------------------------- + +test xmfbox-1.1 {tk::MotifFDialog_Create, -parent switch} -constraints { + unix +} -setup { catch {unset foo} +} -body { set x [tk::MotifFDialog_Create foo open {-parent .}] - catch {destroy $x} - set x -} .foo +} -cleanup { + destroy $x +} -result {.foo} -test xmfbox-1.2 {tk::MotifFDialog_Create, -parent switch} unix { +test xmfbox-1.2 {tk::MotifFDialog_Create, -parent switch} -constraints { + unix +} -setup { catch {unset foo} + deleteWindows +} -body { toplevel .bar wm geometry .bar +0+0 set x [tk::MotifFDialog_Create foo open {-parent .bar}] - catch {destroy $x} - catch {destroy .bar} - set x -} .bar.foo +} -cleanup { + destroy $x + destroy .bar +} -result {.bar.foo} -test xmfbox-2.1 {tk::MotifFDialog_InterpFilter, ~ in dir names} unix { + +test xmfbox-2.1 {tk::MotifFDialog_InterpFilter, ~ in dir names} -constraints { + unix +} -body { cleanup file mkdir ./~nosuchuser1 set x [tk::MotifFDialog_Create foo open {}] $::tk::dialog::file::foo(fEnt) delete 0 end $::tk::dialog::file::foo(fEnt) insert 0 [pwd]/~nosuchuser1 set kk [tk::MotifFDialog_InterpFilter $x] -} [list $testPWD/~nosuchuser1 *] +} -result "$testPWD/~nosuchuser1 *" -test xmfbox-2.2 {tk::MotifFDialog_InterpFilter, ~ in file names} unix { +test xmfbox-2.2 {tk::MotifFDialog_InterpFilter, ~ in file names} -constraints { + unix +} -body { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] $::tk::dialog::file::foo(fEnt) delete 0 end $::tk::dialog::file::foo(fEnt) insert 0 [pwd]/~nosuchuser1 set kk [tk::MotifFDialog_InterpFilter $x] -} [list $testPWD ./~nosuchuser1] +} -result "$testPWD ./~nosuchuser1" -test xmfbox-2.3 {tk::MotifFDialog_Update, ~ in file names} unix { +test xmfbox-2.3 {tk::MotifFDialog_Update, ~ in file names} -constraints { + unix +} -body { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] @@ -103,17 +118,21 @@ test xmfbox-2.3 {tk::MotifFDialog_Update, ~ in file names} unix { tk::MotifFDialog_InterpFilter $x tk::MotifFDialog_Update $x $::tk::dialog::file::foo(fList) get end -} ~nosuchuser1 +} -result {~nosuchuser1} -test xmfbox-2.4 {tk::MotifFDialog_LoadFile, ~ in file names} unix { +test xmfbox-2.4 {tk::MotifFDialog_LoadFile, ~ in file names} -constraints { + unix +} -body { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] set i [lsearch [$::tk::dialog::file::foo(fList) get 0 end] ~nosuchuser1] expr {$i >= 0} -} 1 +} -result 1 -test xmfbox-2.5 {tk::MotifFDialog_BrowseFList, ~ in file names} unix { +test xmfbox-2.5 {tk::MotifFDialog_BrowseFList, ~ in file names} -constraints { + unix +} -body { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] @@ -122,9 +141,11 @@ test xmfbox-2.5 {tk::MotifFDialog_BrowseFList, ~ in file names} unix { $::tk::dialog::file::foo(fList) selection set $i tk::MotifFDialog_BrowseFList $x $::tk::dialog::file::foo(sEnt) get -} $testPWD/~nosuchuser1 +} -result "$testPWD/~nosuchuser1" -test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} unix { +test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} -constraints { + unix +} -body { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] @@ -135,9 +156,13 @@ test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} unix { tk::MotifFDialog_ActivateFList $x list $::tk::dialog::file::foo(selectPath) \ $::tk::dialog::file::foo(selectFile) $tk::Priv(selectFilePath) -} [list $testPWD ~nosuchuser1 $testPWD/~nosuchuser1] +} -result "$testPWD ~nosuchuser1 $testPWD/~nosuchuser1" # cleanup cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End:
\ No newline at end of file |