diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | tests/canvWind.test | 45 | ||||
| -rw-r--r-- | tests/menubut.test | 814 | ||||
| -rw-r--r-- | tests/raise.test | 203 | ||||
| -rw-r--r-- | tests/unixButton.test | 196 | ||||
| -rw-r--r-- | tests/unixEmbed.test | 598 | ||||
| -rw-r--r-- | tests/winClipboard.test | 100 |
7 files changed, 1341 insertions, 624 deletions
@@ -1,3 +1,12 @@ +2008-08-18 Ania Pawelczyk <aniap@users.sourceforge.net> + + * tests/canvWind.test: Update to tcltest2 + * tests/menubut.test: + * tests/raise.test: + * tests/unixButton.test: + * tests/unixEmbed.test: + * tests/winClipboard.test: + 2008-08-17 Ania Pawelczyk <aniap@users.sourceforge.net> * tests/focus.test: Update to tcltest2 diff --git a/tests/canvWind.test b/tests/canvWind.test index 1b07e3f..5115f34 100644 --- a/tests/canvWind.test +++ b/tests/canvWind.test @@ -6,14 +6,16 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: canvWind.test,v 1.6 2004/05/23 17:34:48 dkf Exp $ +# RCS: @(#) $Id: canvWind.test,v 1.7 2008/08/18 16:09:10 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} { - catch {destroy .t} +test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} -setup { + destroy .t +} -body { toplevel .t canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \ -relief sunken -xscrollincrement 1 -yscrollincrement 1 \ @@ -39,9 +41,13 @@ test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} { .t.c yview scroll -1 units update lappend x [list [winfo ismapped $f] [winfo y $f]] -} {{1 23} {1 -29} {0 -29} {1 225} {0 225}} -test canvWind-1.2 {DisplayWinItem, windows off-screen vertically} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {{1 23} {1 -29} {0 -29} {1 225} {0 225}} + +test canvWind-1.2 {DisplayWinItem, windows off-screen vertically} -setup { + destroy .t +} -body { toplevel .t canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \ -relief sunken -xscrollincrement 1 -yscrollincrement 1 \ @@ -67,9 +73,13 @@ test canvWind-1.2 {DisplayWinItem, windows off-screen vertically} { .t.c yview scroll -1 units update lappend x [list [winfo ismapped $f] [winfo y $f]] -} {{1 3} {1 -49} {0 -49} {1 205} {0 205}} -test canvWind-1.3 {DisplayWinItem, windows off-screen horizontally} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {{1 3} {1 -49} {0 -49} {1 205} {0 205}} + +test canvWind-1.3 {DisplayWinItem, windows off-screen horizontally} -setup { + destroy .t +} -body { toplevel .t canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \ -relief sunken -xscrollincrement 1 -yscrollincrement 1 \ @@ -95,9 +105,13 @@ test canvWind-1.3 {DisplayWinItem, windows off-screen horizontally} { .t.c xview scroll -1 units update lappend x [list [winfo ismapped $f] [winfo x $f]] -} {{1 23} {1 -59} {0 -59} {1 275} {0 275}} -test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {{1 23} {1 -59} {0 -59} {1 275} {0 275}} + +test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} -setup { + destroy .t +} -body { toplevel .t canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \ -relief sunken -xscrollincrement 1 -yscrollincrement 1 \ @@ -123,8 +137,9 @@ test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} { .t.c xview scroll -1 units update lappend x [list [winfo ismapped $f] [winfo x $f]] -} {{1 3} {1 -79} {0 -79} {1 255} {0 255}} -catch {destroy .t} +} -cleanup { + destroy .t +} -result {{1 3} {1 -79} {0 -79} {1 255} {0 255}} # cleanup cleanupTests diff --git a/tests/menubut.test b/tests/menubut.test index 6613af1..4932c31 100644 --- a/tests/menubut.test +++ b/tests/menubut.test @@ -6,15 +6,16 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: menubut.test,v 1.11 2008/07/23 23:24:25 nijtmans Exp $ +# RCS: @(#) $Id: menubut.test,v 1.12 2008/08/18 16:09:10 aniap Exp $ # XXX This test file is woefully incomplete right now. If any part # XXX of a procedure has tests then the whole procedure has tests, # XXX but many procedures have no tests. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test # Create entries in the option database to be sure that geometry options # like border width have predictable values. @@ -26,318 +27,735 @@ option add *Button.borderWidth 2 option add *Button.highlightThickness 2 option add *Button.font {Helvetica -12 bold} -eval image delete [image names] -if {[testConstraint testImageType]} { + +menubutton .mb -text "Test" +pack .mb +update +test menubutton-1.1 {configuration options} -body { + .mb configure -activebackground #012345 + .mb cget -activebackground +} -cleanup { + .mb configure -activebackground [lindex [.mb configure -activebackground] 3] +} -result {#012345} +test menubutton-1.2 {configuration options} -body { + .mb configure -activebackground non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test menubutton-1.3 {configuration options} -body { + .mb configure -activeforeground #ff0000 + .mb cget -activeforeground +} -cleanup { + .mb configure -activeforeground [lindex [.mb configure -activeforeground] 3] +} -result {#ff0000} +test menubutton-1.4 {configuration options} -body { + .mb configure -activeforeground non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test menubutton-1.5 {configuration options} -body { + .mb configure -anchor nw + .mb cget -anchor +} -cleanup { + .mb configure -anchor [lindex [.mb configure -anchor] 3] +} -result {nw} +test menubutton-1.6 {configuration options} -body { + .mb configure -anchor bogus +} -returnCodes error -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center} +test menubutton-1.7 {configuration options} -body { + .mb configure -background #ff0000 + .mb cget -background +} -cleanup { + .mb configure -background [lindex [.mb configure -background] 3] +} -result {#ff0000} +test menubutton-1.8 {configuration options} -body { + .mb configure -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test menubutton-1.9 {configuration options} -body { + .mb configure -bd 4 + .mb cget -bd +} -cleanup { + .mb configure -bd [lindex [.mb configure -bd] 3] +} -result {4} +test menubutton-1.10 {configuration options} -body { + .mb configure -bd badValue +} -returnCodes error -result {bad screen distance "badValue"} +test menubutton-1.11 {configuration options} -body { + .mb configure -bg #ff0000 + .mb cget -bg +} -cleanup { + .mb configure -bg [lindex [.mb configure -bg] 3] +} -result {#ff0000} +test menubutton-1.12 {configuration options} -body { + .mb configure -bg non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test menubutton-1.13 {configuration options} -body { + .mb configure -bitmap questhead + .mb cget -bitmap +} -cleanup { + .mb configure -bitmap [lindex [.mb configure -bitmap] 3] +} -result {questhead} +test menubutton-1.14 {configuration options} -body { + .mb configure -bitmap badValue +} -returnCodes error -result {bitmap "badValue" not defined} +test menubutton-1.15 {configuration options} -body { + .mb configure -borderwidth 1.3 + .mb cget -borderwidth +} -cleanup { + .mb configure -borderwidth [lindex [.mb configure -borderwidth] 3] +} -result {1} +test menubutton-1.16 {configuration options} -body { + .mb configure -borderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test menubutton-1.17 {configuration options} -body { + .mb configure -cursor arrow + .mb cget -cursor +} -cleanup { + .mb configure -cursor [lindex [.mb configure -cursor] 3] +} -result {arrow} +test menubutton-1.18 {configuration options} -body { + .mb configure -cursor badValue +} -returnCodes error -result {bad cursor spec "badValue"} +test menubutton-1.19 {configuration options} -body { + .mb configure -direction below + .mb cget -direction +} -cleanup { + .mb configure -direction [lindex [.mb configure -direction] 3] +} -result {below} +test menubutton-1.20 {configuration options} -body { + .mb configure -direction badValue +} -returnCodes error -result {bad direction "badValue": must be above, below, flush, left, or right} +test menubutton-1.21 {configuration options} -body { + .mb configure -disabledforeground #00ff00 + .mb cget -disabledforeground +} -cleanup { + .mb configure -disabledforeground [lindex [.mb configure -disabledforeground] 3] +} -result {#00ff00} +test menubutton-1.22 {configuration options} -body { + .mb configure -disabledforeground xyzzy +} -returnCodes error -result {unknown color name "xyzzy"} +test menubutton-1.23 {configuration options} -body { + .mb configure -fg #110022 + .mb cget -fg +} -cleanup { + .mb configure -fg [lindex [.mb configure -fg] 3] +} -result {#110022} +test menubutton-1.24 {configuration options} -body { + .mb configure -fg bogus +} -returnCodes error -result {unknown color name "bogus"} +test menubutton-1.25 {configuration options} -body { + .mb configure -font {Helvetica 12} + .mb cget -font +} -cleanup { + .mb configure -font [lindex [.mb configure -font] 3] +} -result {Helvetica 12} +test menubutton-1.26 {configuration options} -body { + .mb configure -foreground #110022 + .mb cget -foreground +} -cleanup { + .mb configure -foreground [lindex [.mb configure -foreground] 3] +} -result {#110022} +test menubutton-1.27 {configuration options} -body { + .mb configure -foreground bogus +} -returnCodes error -result {unknown color name "bogus"} +test menubutton-1.28 {configuration options} -body { + .mb configure -height 18 + .mb cget -height +} -cleanup { + .mb configure -height [lindex [.mb configure -height] 3] +} -result {18} +test menubutton-1.29 {configuration options} -body { + .mb configure -height 20.0 +} -returnCodes error -result {expected integer but got "20.0"} +test menubutton-1.30 {configuration options} -body { + .mb configure -highlightbackground #112233 + .mb cget -highlightbackground +} -cleanup { + .mb configure -highlightbackground [lindex [.mb configure -highlightbackground] 3] +} -result {#112233} +test menubutton-1.31 {configuration options} -body { + .mb configure -highlightbackground ugly +} -returnCodes error -result {unknown color name "ugly"} +test menubutton-1.32 {configuration options} -body { + .mb configure -highlightcolor #110022 + .mb cget -highlightcolor +} -cleanup { + .mb configure -highlightcolor [lindex [.mb configure -highlightcolor] 3] +} -result {#110022} +test menubutton-1.33 {configuration options} -body { + .mb configure -highlightcolor bogus +} -returnCodes error -result {unknown color name "bogus"} +test menubutton-1.34 {configuration options} -body { + .mb configure -highlightthickness 18 + .mb cget -highlightthickness +} -cleanup { + .mb configure -highlightthickness [lindex [.mb configure -highlightthickness] 3] +} -result {18} +test menubutton-1.35 {configuration options} -body { + .mb configure -highlightthickness badValue +} -returnCodes error -result {bad screen distance "badValue"} +test menubutton-1.36 {configuration options} -constraints { + testImageType +} -setup { + catch {image delete image1} + image create test image1 +} -body { + .mb configure -image image1 + .mb cget -image +} -cleanup { + .mb configure -image [lindex [.mb configure -image] 3] image create test image1 -} +} -result {image1} +test menubutton-1.37 {configuration options} -setup { + catch {image delete bogus} +} -body { + .mb configure -image bogus +} -cleanup { + .mb configure -image [lindex [.mb configure -image] 3] +} -returnCodes error -result {image "bogus" doesn't exist} +test menubutton-1.38 {configuration options} -body { + .mb configure -indicatoron yes + .mb cget -indicatoron +} -cleanup { + .mb configure -indicatoron [lindex [.mb configure -indicatoron] 3] +} -result {1} +test menubutton-1.39 {configuration options} -body { + .mb configure -indicatoron no_way +} -returnCodes error -result {expected boolean value but got "no_way"} +test menubutton-1.40 {configuration options} -body { + .mb configure -justify right + .mb cget -justify +} -cleanup { + .mb configure -justify [lindex [.mb configure -justify] 3] +} -result {right} +test menubutton-1.41 {configuration options} -body { + .mb configure -justify bogus +} -returnCodes error -result {bad justification "bogus": must be left, right, or center} +test menubutton-1.42 {configuration options} -body { + .mb configure -menu {any old string} + .mb cget -menu +} -cleanup { + .mb configure -menu [lindex [.mb configure -menu] 3] +} -result {any old string} +test menubutton-1.43 {configuration options} -body { + .mb configure -padx 12 + .mb cget -padx +} -cleanup { + .mb configure -padx [lindex [.mb configure -padx] 3] +} -result {12} +test menubutton-1.44 {configuration options} -body { + .mb configure -padx 420x +} -returnCodes error -result {bad screen distance "420x"} +test menubutton-1.45 {configuration options} -body { + .mb configure -pady 12 + .mb cget -pady +} -cleanup { + .mb configure -pady [lindex [.mb configure -pady] 3] +} -result {12} +test menubutton-1.46 {configuration options} -body { + .mb configure -pady 420x +} -returnCodes error -result {bad screen distance "420x"} +test menubutton-1.47 {configuration options} -body { + .mb configure -relief groove + .mb cget -relief +} -cleanup { + .mb configure -relief [lindex [.mb configure -relief] 3] +} -result {groove} +test menubutton-1.48 {configuration options} -body { + .mb configure -relief 1.5 +} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} +test menubutton-1.49 {configuration options} -body { + .mb configure -state normal + .mb cget -state +} -cleanup { + .mb configure -state [lindex [.mb configure -state] 3] +} -result {normal} +test menubutton-1.50 {configuration options} -body { + .mb configure -state bogus +} -returnCodes error -result {bad state "bogus": must be active, disabled, or normal} +test menubutton-1.51 {configuration options} -body { + .mb configure -takefocus {any string} + .mb cget -takefocus +} -cleanup { + .mb configure -takefocus [lindex [.mb configure -takefocus] 3] +} -result {any string} +test menubutton-1.52 {configuration options} -body { + .mb configure -text {Sample text} + .mb cget -text +} -cleanup { + .mb configure -text [lindex [.mb configure -text] 3] +} -result {Sample text} +test menubutton-1.53 {configuration options} -body { + .mb configure -textvariable i + .mb cget -textvariable +} -cleanup { + .mb configure -textvariable [lindex [.mb configure -textvariable] 3] +} -result {i} +test menubutton-1.54 {configuration options} -body { + .mb configure -underline 5 + .mb cget -underline +} -cleanup { + .mb configure -underline [lindex [.mb configure -underline] 3] +} -result {5} +test menubutton-1.55 {configuration options} -body { + .mb configure -underline 3p +} -returnCodes error -result {expected integer but got "3p"} +test menubutton-1.56 {configuration options} -body { + .mb configure -width 402 + .mb cget -width +} -cleanup { + .mb configure -width [lindex [.mb configure -width] 3] +} -result {402} +test menubutton-1.57 {configuration options} -body { + .mb configure -width 3p +} -returnCodes error -result {expected integer but got "3p"} +test menubutton-1.58 {configuration options} -body { + .mb configure -wraplength 100 + .mb cget -wraplength +} -cleanup { + .mb configure -wraplength [lindex [.mb configure -wraplength] 3] +} -result {100} +test menubutton-1.59 {configuration options} -body { + .mb configure -wraplength 6x +} -returnCodes error -result {bad screen distance "6x"} + + +deleteWindows menubutton .mb -text "Test" pack .mb update -set i 1 -foreach test { - {-activebackground #012345 #012345 non-existent - {unknown color name "non-existent"}} - {-activeforeground #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-anchor nw nw bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}} - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} - {-bitmap questhead questhead badValue {bitmap "badValue" not defined}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-direction below below badValue {bad direction "badValue": must be above, below, flush, left, or right}} - {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}} - {-fg #110022 #110022 bogus {unknown color name "bogus"}} - {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}} - {-foreground #110022 #110022 bogus {unknown color name "bogus"}} - {-height 18 18 20.0 {expected integer but got "20.0"}} - {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} - {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}} - {-highlightthickness 18 18 badValue {bad screen distance "badValue"}} - {-image image1 image1 bogus {image "bogus" doesn't exist}} - {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}} - {-justify right right bogus {bad justification "bogus": must be left, right, or center}} - {-menu "any old string" "any old string" {} {}} - {-padx 12 12 420x {bad screen distance "420x"}} - {-pady 12 12 420x {bad screen distance "420x"}} - {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - {-state normal normal bogus {bad state "bogus": must be active, disabled, or normal}} - {-takefocus "any string" "any string" {} {}} - {-text "Sample text" {Sample text} {} {}} - {-textvariable i i {} {}} - {-underline 5 5 3p {expected integer but got "3p"}} - {-width 402 402 3p {expected integer but got "3p"}} - {-wraplength 100 100 6x {bad screen distance "6x"}} -} { - set name [lindex $test 0] - test menubutton-1.$i {configuration options} testImageType { - .mb configure $name [lindex $test 1] - lindex [.mb configure $name] 4 - } [lindex $test 2] - incr i - if {[lindex $test 3] != ""} { - test menubutton-1.$i {configuration options} { - list [catch {.mb configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] - } - .mb configure $name [lindex [.mb configure $name] 3] - incr i -} - -test menubutton-2.1 {Tk_MenubuttonCmd procedure} { - list [catch {menubutton} msg] $msg -} {1 {wrong # args: should be "menubutton pathName ?-option value ...?"}} -test menubutton-2.2 {Tk_MenubuttonCmd procedure} { - list [catch {menubutton foo} msg] $msg -} {1 {bad window path name "foo"}} -test menubutton-2.3 {Tk_MenubuttonCmd procedure} { +test menubutton-2.1 {Tk_MenubuttonCmd procedure} -body { + menubutton +} -returnCodes error -result {wrong # args: should be "menubutton pathName ?-option value ...?"} +test menubutton-2.2 {Tk_MenubuttonCmd procedure} -body { + menubutton foo +} -returnCodes error -result {bad window path name "foo"} +test menubutton-2.3 {Tk_MenubuttonCmd procedure} -body { catch {destroy .mb} menubutton .mb winfo class .mb -} {Menubutton} -test menubutton-2.4 {Tk_ButtonCmd procedure} { - catch {destroy .mb} - list [catch {menubutton .mb -gorp foo} msg] $msg [winfo exists .mb] -} {1 {unknown option "-gorp"} 0} +} -result {Menubutton} +test menubutton-2.4 {Tk_ButtonCmd procedure} -setup { + destroy .mb +} -body { + menubutton .mb -gorp foo +} -returnCodes error -result {unknown option "-gorp"} +test menubutton-2.5 {Tk_ButtonCmd procedure} -setup { + destroy .mb +} -body { + catch {menubutton .mb -gorp foo} + winfo exists .mb +} -result 0 -catch {destroy .mb} + +deleteWindows menubutton .mb -text "Test Menu" pack .mb -test menubutton-3.1 {MenuButtonWidgetCmd procedure} { - list [catch {.mb} msg] $msg -} {1 {wrong # args: should be ".mb option ?arg ...?"}} -test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.mb c} msg] $msg -} {1 {ambiguous option "c": must be cget or configure}} -test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.mb cget} msg] $msg -} {1 {wrong # args: should be ".mb cget option"}} -test menubutton-3.4 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.mb cget a b} msg] $msg -} {1 {wrong # args: should be ".mb cget option"}} -test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.mb cget -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} { +test menubutton-3.1 {MenuButtonWidgetCmd procedure} -body { + .mb +} -returnCodes error -result {wrong # args: should be ".mb option ?arg ...?"} +test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} -body { + .mb c +} -returnCodes error -result {ambiguous option "c": must be cget or configure} +test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} -body { + .mb cget +} -returnCodes error -result {wrong # args: should be ".mb cget option"} +test menubutton-3.4 {ButtonWidgetCmd procedure, "cget" option} -body { + .mb cget a b +} -returnCodes error -result {wrong # args: should be ".mb cget option"} +test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} -body { + .mb cget -gorp +} -returnCodes error -result {unknown option "-gorp"} +test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} -body { .mb configure -highlightthickness 3 .mb cget -highlightthickness -} {3} -test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} { +} -result {3} +test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} -body { llength [.mb configure] -} {33} -test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} { - list [catch {.mb configure -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test menubutton-3.9 {ButtonWidgetCmd procedure, "configure" option} { - list [catch {.mb co -bg #ffffff -fg} msg] $msg -} {1 {value for "-fg" missing}} -test menubutton-3.10 {ButtonWidgetCmd procedure, "configure" option} { +} -result {33} +test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} -body { + .mb configure -gorp +} -returnCodes error -result {unknown option "-gorp"} +test menubutton-3.9 {ButtonWidgetCmd procedure, "configure" option} -body { + .mb co -bg #ffffff -fg +} -returnCodes error -result {value for "-fg" missing} +test menubutton-3.10 {ButtonWidgetCmd procedure, "configure" option} -body { .mb configure -fg #123456 .mb configure -bg #654321 lindex [.mb configure -fg] 4 -} {#123456} -test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} { - list [catch {.mb foobar} msg] $msg -} {1 {bad option "foobar": must be cget or configure}} +} -result {#123456} +test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} -body { + .mb foobar +} -returnCodes error -result {bad option "foobar": must be cget or configure} +deleteWindows # XXX Need to add tests for several procedures here. The tests for XXX # XXX ConfigureMenuButton aren't complete either. XXX -test menubutton-4.1 {ConfigureMenuButton procedure} { - catch {destroy .mb1} +test menubutton-4.1 {ConfigureMenuButton procedure} -setup { + deleteWindows +} -body { button .mb1 -text "Menubutton 1" - list [catch {.mb1 configure -width 1i} msg] $msg $errorInfo -} {1 {expected integer but got "1i"} {expected integer but got "1i" + .mb1 configure -width 1i +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "1i"} +test menubutton-4.2 {ConfigureMenuButton procedure} -setup { + deleteWindows +} -body { + button .mb1 -text "Menubutton 1" + catch {.mb1 configure -width 1i} + return $errorInfo +} -cleanup { + deleteWindows +} -result {expected integer but got "1i" (processing -width option) invoked from within -".mb1 configure -width 1i"}} -test menubutton-4.2 {ConfigureMenuButton procedure} { - catch {destroy .mb1} +".mb1 configure -width 1i"} + +test menubutton-4.3 {ConfigureMenuButton procedure} -setup { + deleteWindows +} -body { + button .mb1 -text "Menubutton 1" + .mb1 configure -height 0.5c +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "0.5c"} +test menubutton-4.4 {ConfigureMenuButton procedure} -setup { + deleteWindows +} -body { button .mb1 -text "Menubutton 1" - list [catch {.mb1 configure -height 0.5c} msg] $msg $errorInfo -} {1 {expected integer but got "0.5c"} {expected integer but got "0.5c" + catch {.mb1 configure -height 0.5c} + return $errorInfo +} -cleanup { + deleteWindows +} -result {expected integer but got "0.5c" (processing -height option) invoked from within -".mb1 configure -height 0.5c"}} -test menubutton-4.3 {ConfigureMenuButton procedure} { - catch {destroy .mb1} +".mb1 configure -height 0.5c"} + +test menubutton-4.5 {ConfigureMenuButton procedure} -setup { + deleteWindows +} -body { button .mb1 -bitmap questhead - list [catch {.mb1 configure -width abc} msg] $msg $errorInfo -} {1 {bad screen distance "abc"} {bad screen distance "abc" + .mb1 configure -width abc +} -cleanup { + deleteWindows +} -returnCodes error -result {bad screen distance "abc"} +test menubutton-4.6 {ConfigureMenuButton procedure} -setup { + deleteWindows +} -body { + button .mb1 -bitmap questhead + catch {.mb1 configure -width abc} + return $errorInfo +} -cleanup { + deleteWindows +} -result {bad screen distance "abc" (processing -width option) invoked from within -".mb1 configure -width abc"}} -test menubutton-4.4 {ConfigureMenuButton procedure} testImageType { - catch {destroy .mb1} +".mb1 configure -width abc"} + +test menubutton-4.7 {ConfigureMenuButton procedure} -constraints { + testImageType +} -setup { + deleteWindows + eval image delete [image names] +} -body { + image create test image1 + button .mb1 -image image1 + .mb1 configure -height 0.5x +} -cleanup { + deleteWindows + eval image delete [image names] +} -returnCodes error -result {bad screen distance "0.5x"} +test menubutton-4.8 {ConfigureMenuButton procedure} -constraints { + testImageType +} -setup { + deleteWindows eval image delete [image names] +} -body { image create test image1 button .mb1 -image image1 - list [catch {.mb1 configure -height 0.5x} msg] $msg $errorInfo -} {1 {bad screen distance "0.5x"} {bad screen distance "0.5x" + catch {.mb1 configure -height 0.5x} + return $errorInfo +} -cleanup { + deleteWindows + eval image delete [image names] +} -result {bad screen distance "0.5x" (processing -height option) invoked from within -".mb1 configure -height 0.5x"}} -test menubutton-4.5 {ConfigureMenuButton procedure} {nonPortable fonts} { - catch {destroy .mb1} +".mb1 configure -height 0.5x"} + +test menubutton-4.9 {ConfigureMenuButton procedure} -constraints { + nonPortable fonts +} -setup { + deleteWindows +} -body { button .mb1 -text "Sample text" -width 10 -height 2 pack .mb1 set result "[winfo reqwidth .mb1] [winfo reqheight .mb1]" .mb1 configure -bitmap questhead lappend result [winfo reqwidth .mb1] [winfo reqheight .mb1] -} {102 46 20 12} -test menubutton-4.6 {ConfigureMenuButton procedure - bad direction} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {102 46 20 12} + +test menubutton-4.10 {ConfigureMenuButton procedure - bad direction} -setup { + deleteWindows +} -body { menubutton .mb -text "Test" - list [catch {.mb configure -direction badValue} msg] $msg \ - [.mb cget -direction] [destroy .mb] -} {1 {bad direction "badValue": must be above, below, flush, left, or right} below {}} + .mb configure -direction badValue +} -cleanup { + deleteWindows +} -returnCodes error -result {bad direction "badValue": must be above, below, flush, left, or right} +test menubutton-4.11 {ConfigureMenuButton procedure - bad direction} -setup { + deleteWindows +} -body { + menubutton .mb -text "Test" + catch {.mb configure -direction badValue} + list [.mb cget -direction] [destroy .mb] +} -cleanup { + deleteWindows +} -result {below {}} + + # XXX Need to add tests for several procedures here. XXX -test menubutton-5.1 {MenuButtonEventProc procedure} { +test menubutton-5.1 {MenuButtonEventProc procedure} -setup { deleteWindows + set x {} +} -body { menubutton .mb1 -bg #543210 rename .mb1 .mb2 - set x {} lappend x [winfo children .] lappend x [.mb2 cget -bg] destroy .mb1 lappend x [info command .mb*] [winfo children .] -} {.mb1 #543210 {} {}} +} -cleanup { + deleteWindows +} -result {.mb1 #543210 {} {}} + -test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} { +test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} -setup { deleteWindows +} -body { menubutton .mb1 rename .mb1 {} list [info command .mb*] [winfo children .] -} {{} {}} +} -cleanup { + deleteWindows +} -result {{} {}} -test menubutton-7.1 {ComputeMenuButtonGeometry procedure} testImageType { - catch {destroy .mb} + +test menubutton-7.1 {ComputeMenuButtonGeometry procedure} -constraints { + testImageType +} -setup { + deleteWindows + image create test image1 +} -body { menubutton .mb -image image1 -bd 4 -highlightthickness 0 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {38 23} -test menubutton-7.2 {ComputeMenuButtonGeometry procedure} testImageType { - catch {destroy .mb} +} -cleanup { + deleteWindows + eval image delete [image names] +} -result {38 23} +test menubutton-7.2 {ComputeMenuButtonGeometry procedure} -constraints { + testImageType +} -setup { + deleteWindows + image create test image1 +} -body { menubutton .mb -image image1 -bd 1 -highlightthickness 2 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {36 21} -test menubutton-7.3 {ComputeMenuButtonGeometry procedure} testImageType { - catch {destroy .mb} +} -cleanup { + deleteWindows + eval image delete [image names] +} -result {36 21} +test menubutton-7.3 {ComputeMenuButtonGeometry procedure} -constraints { + testImageType +} -setup { + deleteWindows + image create test image1 +} -body { menubutton .mb -image image1 -bd 0 -highlightthickness 2 -padx 5 -pady 5 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {34 19} -test menubutton-7.4 {ComputeMenuButtonGeometry procedure} testImageType { - catch {destroy .mb} +} -cleanup { + deleteWindows + eval image delete [image names] +} -result {34 19} +test menubutton-7.4 {ComputeMenuButtonGeometry procedure} -constraints { + testImageType +} -setup { + deleteWindows + image create test image1 +} -body { menubutton .mb -image image1 -bd 2 -relief raised -width 40 \ - -highlightthickness 2 + -highlightthickness 2 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {48 23} -test menubutton-7.5 {ComputeMenuButtonGeometry procedure} testImageType { - catch {destroy .mb} +} -cleanup { + deleteWindows + eval image delete [image names] +} -result {48 23} +test menubutton-7.5 {ComputeMenuButtonGeometry procedure} -constraints { + testImageType +} -setup { + deleteWindows + image create test image1 +} -body { menubutton .mb -image image1 -bd 2 -relief raised -height 30 \ - -highlightthickness 2 + -highlightthickness 2 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {38 38} -test menubutton-7.6 {ComputeMenuButtonGeometry procedure} { - catch {destroy .mb} +} -cleanup { + deleteWindows + eval image delete [image names] +} -result {38 38} +test menubutton-7.6 {ComputeMenuButtonGeometry procedure} -setup { + deleteWindows +} -body { menubutton .mb -bitmap question -bd 2 -relief raised \ - -highlightthickness 2 + -highlightthickness 2 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {25 35} -test menubutton-7.7 {ComputeMenuButtonGeometry procedure} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {25 35} +test menubutton-7.7 {ComputeMenuButtonGeometry procedure} -setup { + deleteWindows +} -body { menubutton .mb -bitmap question -bd 2 -relief raised -width 40 \ - -highlightthickness 1 + -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {46 33} -test menubutton-7.8 {ComputeMenuButtonGeometry procedure} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {46 33} +test menubutton-7.8 {ComputeMenuButtonGeometry procedure} -setup { + deleteWindows +} -body { menubutton .mb -bitmap question -bd 2 -relief raised -height 50 \ - -highlightthickness 1 + -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {23 56} -test menubutton-7.9 {ComputeMenuButtonGeometry procedure} {fonts} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {23 56} +test menubutton-7.9 {ComputeMenuButtonGeometry procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { menubutton .mb -text String -bd 2 -relief raised -padx 0 -pady 0 \ - -highlightthickness 1 + -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {42 20} -test menubutton-7.10 {ComputeMenuButtonGeometry procedure} {fonts} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {42 20} +test menubutton-7.10 {ComputeMenuButtonGeometry procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { menubutton .mb -text String -bd 2 -relief raised -width 20 \ - -padx 0 -pady 0 -highlightthickness 1 + -padx 0 -pady 0 -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {146 20} -test menubutton-7.11 {ComputeMenuButtonGeometry procedure} {fonts} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {146 20} +test menubutton-7.11 {ComputeMenuButtonGeometry procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { menubutton .mb -text String -bd 2 -relief raised -height 2 \ - -padx 0 -pady 0 -highlightthickness 1 + -padx 0 -pady 0 -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {42 34} -test menubutton-7.12 {ComputeMenuButtonGeometry procedure} {fonts} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {42 34} +test menubutton-7.12 {ComputeMenuButtonGeometry procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { menubutton .mb -text String -bd 2 -relief raised -padx 10 -pady 5 \ - -highlightthickness 1 + -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {62 30} -test menubutton-7.13 {ComputeMenuButtonGeometry procedure} {nonPortable fonts} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {62 30} +test menubutton-7.13 {ComputeMenuButtonGeometry procedure} -constraints { + nonPortable fonts +} -setup { + deleteWindows +} -body { menubutton .mb -text String -bd 2 -relief raised \ - -highlightthickness 1 -indicatoron 1 + -highlightthickness 1 -indicatoron 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {78 28} -test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {testImageType unix nonPortable} { +} -cleanup { + deleteWindows +} -result {78 28} +test menubutton-7.14 {ComputeMenuButtonGeometry procedure} -constraints { + testImageType unix nonPortable +} -setup { + deleteWindows + image create test image1 +} -body { # The following test is non-portable because the indicator's pixel # size varies to maintain constant absolute size. - catch {destroy .mb} menubutton .mb -image image1 -bd 2 -relief raised \ - -highlightthickness 2 -indicatoron 1 + -highlightthickness 2 -indicatoron 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {64 23} -test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {testImageType win nonPortable} { +} -cleanup { + deleteWindows + eval image delete [image names] +} -result {64 23} +test menubutton-7.15 {ComputeMenuButtonGeometry procedure} -constraints { + testImageType win nonPortable +} -setup { + deleteWindows + image create test image1 +} -body { # The following test is non-portable because the indicator's pixel # size varies to maintain constant absolute size. - catch {destroy .mb} menubutton .mb -image image1 -bd 2 -relief raised \ - -highlightthickness 2 -indicatoron 1 + -highlightthickness 2 -indicatoron 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {65 23} +} -cleanup { + deleteWindows + eval image delete [image names] +} -result {65 23} -set l [interp hidden] -deleteWindows -test menubutton-8.1 {menubutton vs hidden commands} { - catch {destroy .mb} +test menubutton-8.1 {menubutton vs hidden commands} -body { + set l [interp hidden] + deleteWindows menubutton .mb interp hide {} .mb destroy .mb - list [winfo children .] [interp hidden] -} [list {} $l] + set res1 [list [winfo children .] [interp hidden]] + set res2 [list {} $l] + expr {$res1 eq $res2} +} -result 1 + + -eval image delete [image names] deleteWindows option clear # cleanup cleanupTests return + + + diff --git a/tests/raise.test b/tests/raise.test index cdd525d..2431264 100644 --- a/tests/raise.test +++ b/tests/raise.test @@ -8,21 +8,22 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: raise.test,v 1.10 2004/06/17 22:38:57 dkf Exp $ +# RCS: @(#) $Id: raise.test,v 1.11 2008/08/18 16:09:10 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test # Procedure to create a bunch of overlapping windows, which should # make it easy to detect differences in order. proc raise_setup {} { foreach i [winfo child .raise] { - destroy $i - } + destroy $i + } foreach i {a b c d e} { - label .raise.$i -text $i -relief raised -bd 2 + label .raise.$i -text $i -relief raised -bd 2 } place .raise.a -x 20 -y 60 -width 60 -height 80 place .raise.b -x 60 -y 60 -width 60 -height 80 @@ -61,149 +62,173 @@ proc raise_makeToplevels {} { toplevel .raise wm geom .raise 250x200+0+0 -test raise-1.1 {preserve creation order} { + +test raise-1.1 {preserve creation order} -body { raise_setup tkwait visibility .raise.e raise_getOrder -} {d d d b c e e e} -test raise-1.2 {preserve creation order} testmakeexist { +} -result {d d d b c e e e} +test raise-1.2 {preserve creation order} -constraints testmakeexist -body { raise_setup testmakeexist .raise.a update raise_getOrder -} {d d d b c e e e} -test raise-1.3 {preserve creation order} testmakeexist { +} -result {d d d b c e e e} +test raise-1.3 {preserve creation order} -constraints testmakeexist -body { raise_setup testmakeexist .raise.c update raise_getOrder -} {d d d b c e e e} -test raise-1.4 {preserve creation order} testmakeexist { +} -result {d d d b c e e e} +test raise-1.4 {preserve creation order} -constraints testmakeexist -body { raise_setup testmakeexist .raise.e update raise_getOrder -} {d d d b c e e e} -test raise-1.5 {preserve creation order} testmakeexist { +} -result {d d d b c e e e} +test raise-1.5 {preserve creation order} -constraints testmakeexist -body { raise_setup testmakeexist .raise.d .raise.c .raise.b update raise_getOrder -} {d d d b c e e e} +} -result {d d d b c e e e} -test raise-2.1 {raise internal windows before creation} { + +test raise-2.1 {raise internal windows before creation} -body { raise_setup raise .raise.a update raise_getOrder -} {a d d a c a e e} -test raise-2.2 {raise internal windows before creation} { +} -result {a d d a c a e e} +test raise-2.2 {raise internal windows before creation} -body { raise_setup raise .raise.c update raise_getOrder -} {d d c b c e e c} -test raise-2.3 {raise internal windows before creation} { +} -result {d d c b c e e c} +test raise-2.3 {raise internal windows before creation} -body { raise_setup raise .raise.e update raise_getOrder -} {d d d b c e e e} -test raise-2.4 {raise internal windows before creation} { +} -result {d d d b c e e e} +test raise-2.4 {raise internal windows before creation} -body { raise_setup raise .raise.e .raise.a update raise_getOrder -} {d d d b c e b c} -test raise-2.5 {raise internal windows before creation} { +} -result {d d d b c e b c} +test raise-2.5 {raise internal windows before creation} -body { raise_setup raise .raise.a .raise.d update raise_getOrder -} {a d d a c e e e} +} -result {a d d a c e e e} + -test raise-3.1 {raise internal windows after creation} { +test raise-3.1 {raise internal windows after creation} -body { raise_setup update raise .raise.a .raise.d raise_getOrder -} {a d d a c e e e} -test raise-3.2 {raise internal windows after creation} testmakeexist { +} -result {a d d a c e e e} +test raise-3.2 {raise internal windows after creation} -constraints { + testmakeexist +} -body { raise_setup testmakeexist .raise.a .raise.b raise .raise.a .raise.b update raise_getOrder -} {d d d a c e e e} -test raise-3.3 {raise internal windows after creation} testmakeexist { +} -result {d d d a c e e e} +test raise-3.3 {raise internal windows after creation} -constraints { + testmakeexist +} -body { raise_setup testmakeexist .raise.a .raise.d raise .raise.a .raise.b update raise_getOrder -} {d d d a c e e e} -test raise-3.4 {raise internal windows after creation} testmakeexist { +} -result {d d d a c e e e} +test raise-3.4 {raise internal windows after creation} -constraints { + testmakeexist +} -body { raise_setup testmakeexist .raise.a .raise.c .raise.d raise .raise.a .raise.b update raise_getOrder -} {d d d a c e e e} +} -result {d d d a c e e e} -test raise-4.1 {raise relative to nephews} { + +test raise-4.1 {raise relative to nephews} -body { raise_setup update frame .raise.d.child raise .raise.a .raise.d.child raise_getOrder -} {a d d a c e e e} -test raise-4.2 {raise relative to nephews} { +} -result {a d d a c e e e} +test raise-4.2 {raise relative to nephews} -setup { + destroy .raise2 +} -body { raise_setup update frame .raise2 - list [catch {raise .raise.a .raise2} msg] $msg -} {1 {can't raise ".raise.a" above ".raise2"}} -catch {destroy .raise2} + raise .raise.a .raise2 +} -cleanup { + destroy .raise2 +} -returnCodes error -result {can't raise ".raise.a" above ".raise2"} -test raise-5.1 {lower internal windows} { + +test raise-5.1 {lower internal windows} -body { raise_setup update lower .raise.d raise_getOrder -} {a b c b c e e e} -test raise-5.2 {lower internal windows} { +} -result {a b c b c e e e} +test raise-5.2 {lower internal windows} -body { raise_setup update lower .raise.d .raise.b raise_getOrder -} {d b c b c e e e} -test raise-5.3 {lower internal windows} { +} -result {d b c b c e e e} +test raise-5.3 {lower internal windows} -body { raise_setup update lower .raise.a .raise.e raise_getOrder -} {a d d a c e e e} -test raise-5.4 {lower internal windows} { +} -result {a d d a c e e e} +test raise-5.4 {lower internal windows} -setup { + destroy .raise2 +} -body { raise_setup update frame .raise2 - list [catch {lower .raise.a .raise2} msg] $msg -} {1 {can't lower ".raise.a" below ".raise2"}} -catch {destroy .raise2} + lower .raise.a .raise2 +} -cleanup { + destroy .raise2 +} -returnCodes error -result {can't lower ".raise.a" below ".raise2"} -test raise-6.1 {raise/lower toplevel windows} {nonPortable} { + +test raise-6.1 {raise/lower toplevel windows} -constraints { + nonPortable +} -body { raise_makeToplevels update raise .raise1 winfo containing [winfo rootx .raise1] [winfo rooty .raise1] -} .raise1 -test raise-6.2 {raise/lower toplevel windows} {nonPortable} { +} -result {.raise1} +test raise-6.2 {raise/lower toplevel windows} -constraints { + nonPortable +} -body { raise_makeToplevels update raise .raise2 winfo containing [winfo rootx .raise1] [winfo rooty .raise1] -} .raise2 -test raise-6.3 {raise/lower toplevel windows} {nonPortable} { +} -result {.raise2} +test raise-6.3 {raise/lower toplevel windows} -constraints { + nonPortable +} -body { raise_makeToplevels update raise .raise3 @@ -216,8 +241,10 @@ test raise-6.3 {raise/lower toplevel windows} {nonPortable} { after 500 list $result [winfo containing [winfo rootx .raise1] \ [winfo rooty .raise1]] -} {.raise2 .raise1} -test raise-6.4 {raise/lower toplevel windows} {nonPortable} { +} -result {.raise2 .raise1} +test raise-6.4 {raise/lower toplevel windows} -constraints { + nonPortable +} -body { raise_makeToplevels update raise .raise2 @@ -232,14 +259,18 @@ test raise-6.4 {raise/lower toplevel windows} {nonPortable} { after 500 list $result [winfo containing [winfo rootx .raise2] \ [winfo rooty .raise2]] -} {.raise1 .raise3} -test raise-6.5 {raise/lower toplevel windows} {nonPortable} { +} -result {.raise1 .raise3} +test raise-6.5 {raise/lower toplevel windows} -constraints { + nonPortable +} -body { raise_makeToplevels raise .raise1 set time [lindex [time {raise .raise1}] 0] expr {$time < 2000000} -} 1 -test raise-6.6 {raise/lower toplevel windows} {nonPortable} { +} -result 1 +test raise-6.6 {raise/lower toplevel windows} -constraints { + nonPortable +} -body { raise_makeToplevels update raise .raise2 @@ -255,35 +286,37 @@ test raise-6.6 {raise/lower toplevel windows} {nonPortable} { after 500 list $result [winfo containing [winfo rootx .raise2] \ [winfo rooty .raise2]] -} {.raise1 .raise3} +} -result {.raise1 .raise3} + -test raise-7.1 {errors in raise/lower commands} { - list [catch {raise} msg] $msg -} {1 {wrong # args: should be "raise window ?aboveThis?"}} -test raise-7.2 {errors in raise/lower commands} { - list [catch {raise a b c} msg] $msg -} {1 {wrong # args: should be "raise window ?aboveThis?"}} -test raise-7.3 {errors in raise/lower commands} { - list [catch {raise badName} msg] $msg -} {1 {bad window path name "badName"}} -test raise-7.4 {errors in raise/lower commands} { - list [catch {raise . badName2} msg] $msg -} {1 {bad window path name "badName2"}} -test raise-7.5 {errors in raise/lower commands} { - list [catch {lower} msg] $msg -} {1 {wrong # args: should be "lower window ?belowThis?"}} -test raise-7.6 {errors in raise/lower commands} { - list [catch {lower a b c} msg] $msg -} {1 {wrong # args: should be "lower window ?belowThis?"}} -test raise-7.7 {errors in raise/lower commands} { - list [catch {lower badName3} msg] $msg -} {1 {bad window path name "badName3"}} -test raise-7.8 {errors in raise/lower commands} { - list [catch {lower . badName4} msg] $msg -} {1 {bad window path name "badName4"}} +test raise-7.1 {errors in raise/lower commands} -body { + raise +} -returnCodes error -result {wrong # args: should be "raise window ?aboveThis?"} +test raise-7.2 {errors in raise/lower commands} -body { + raise a b c +} -returnCodes error -result {wrong # args: should be "raise window ?aboveThis?"} +test raise-7.3 {errors in raise/lower commands} -body { + raise badName +} -returnCodes error -result {bad window path name "badName"} +test raise-7.4 {errors in raise/lower commands} -body { + raise . badName2 +} -returnCodes error -result {bad window path name "badName2"} +test raise-7.5 {errors in raise/lower commands} -body { + lower +} -returnCodes error -result {wrong # args: should be "lower window ?belowThis?"} +test raise-7.6 {errors in raise/lower commands} -body { + lower a b c +} -returnCodes error -result {wrong # args: should be "lower window ?belowThis?"} +test raise-7.7 {errors in raise/lower commands} -body { + lower badName3 +} -returnCodes error -result {bad window path name "badName3"} +test raise-7.8 {errors in raise/lower commands} -body { + lower . badName4 +} -returnCodes error -result {bad window path name "badName4"} deleteWindows # cleanup cleanupTests return + diff --git a/tests/unixButton.test b/tests/unixButton.test index 30ce8ee..14ff0e5 100644 --- a/tests/unixButton.test +++ b/tests/unixButton.test @@ -8,11 +8,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixButton.test,v 1.7 2003/04/01 21:06:55 dgp Exp $ +# RCS: @(#) $Id: unixButton.test,v 1.8 2008/08/18 16:09:10 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test # Create entries in the option database to be sure that geometry options # like border width have predictable values. @@ -34,19 +35,14 @@ option add *Radiobutton.font {Helvetica -12 bold} proc bogusTrace args { error "trace aborted" } -catch {unset value} -catch {unset value2} -eval image delete [image names] -label .l -text Label -button .b -text Button -checkbutton .c -text Checkbutton -radiobutton .r -text Radiobutton -pack .l .b .c .r -update -test unixbutton-1.1 {TkpComputeButtonGeometry procedure} {unix testImageType} { +test unixbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints { + unix testImageType +} -setup { deleteWindows + eval image delete [image names] +} -body { image create test image1 image1 changed 0 0 0 0 60 40 label .b1 -image image1 -bd 4 -padx 0 -pady 2 @@ -56,12 +52,18 @@ test unixbutton-1.1 {TkpComputeButtonGeometry procedure} {unix testImageType} { 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] -} {68 48 74 54 112 52 112 52} -test unixbutton-1.2 {TkpComputeButtonGeometry procedure} unix { + [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 74 54 112 52 112 52} +test unixbutton-1.2 {TkpComputeButtonGeometry procedure} -constraints { + unix +} -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 @@ -69,27 +71,37 @@ test unixbutton-1.2 {TkpComputeButtonGeometry procedure} unix { 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] -} {23 33 29 39 54 37 54 37} -test unixbutton-1.3 {TkpComputeButtonGeometry procedure} unix { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { + deleteWindows +} -result {23 33 29 39 54 37 54 37} +test unixbutton-1.3 {TkpComputeButtonGeometry procedure} -constraints { + unix +} -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 -highlightthickness 1 \ - -indicatoron false + -indicatoron false 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] -} {31 41 25 35 25 35 25 35} -test unixbutton-1.4 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { deleteWindows +} -result {31 41 25 35 25 35 25 35} +test unixbutton-1.4 {TkpComputeButtonGeometry procedure} -constraints { + unix nonPortable fonts +} -setup { + deleteWindows +} -body { label .b1 -text Xagqpim -padx 0 -pady 2 -font {Helvetica -18 bold} button .b2 -text Xagqpim -padx 0 -pady 2 -font {Helvetica -18 bold} checkbutton .b3 -text Xagqpim -padx 1 -pady 1 -font {Helvetica -18 bold} @@ -97,26 +109,41 @@ test unixbutton-1.4 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts 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] -} {82 29 88 35 114 31 121 29} -test unixbutton-1.5 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { + deleteWindows +} -result {82 29 88 35 114 31 121 29} +test unixbutton-1.5 {TkpComputeButtonGeometry procedure} -constraints { + unix nonPortable fonts +} -setup { deleteWindows +} -body { 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 pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] -} {136 88} -test unixbutton-1.6 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { +} -cleanup { deleteWindows +} -result {136 88} +test unixbutton-1.6 {TkpComputeButtonGeometry procedure} -constraints { + unix nonPortable fonts +} -setup { + deleteWindows +} -body { label .l1 -text "This is a long string without wrapping.\n\nIt also has a blank line (above)." -padx 0 -pady 0 pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] -} {231 46} -test unixbutton-1.7 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { +} -cleanup { + deleteWindows +} -result {231 46} +test unixbutton-1.7 {TkpComputeButtonGeometry procedure} -constraints { + unix nonPortable fonts +} -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 @@ -124,73 +151,102 @@ test unixbutton-1.7 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts 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 22 60 84 168 38 61 22} -test unixbutton-1.8 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { deleteWindows +} -result {74 22 60 84 168 38 61 22} +test unixbutton-1.8 {TkpComputeButtonGeometry procedure} -constraints { + unix nonPortable fonts +} -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] -} {62 30 56 24 58 22 62 22} -test unixbutton-1.9 {TkpComputeButtonGeometry procedure} unix { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { + deleteWindows +} -result {62 30 56 24 58 22 62 22} +test unixbutton-1.9 {TkpComputeButtonGeometry procedure} -constraints { + unix +} -setup { deleteWindows +} -body { button .b2 -bitmap question -default active list [winfo reqwidth .b2] [winfo reqheight .b2] -} {37 47} -test unixbutton-1.10 {TkpComputeButtonGeometry procedure} unix { +} -cleanup { deleteWindows +} -result {37 47} +test unixbutton-1.10 {TkpComputeButtonGeometry procedure} -constraints { + unix +} -setup { + deleteWindows +} -body { button .b2 -bitmap question -default normal list [winfo reqwidth .b2] [winfo reqheight .b2] -} {37 47} -test unixbutton-1.11 {TkpComputeButtonGeometry procedure} unix { +} -cleanup { + deleteWindows +} -result {37 47} +test unixbutton-1.11 {TkpComputeButtonGeometry procedure} -constraints { + unix +} -setup { deleteWindows +} -body { button .b2 -bitmap question -default disabled list [winfo reqwidth .b2] [winfo reqheight .b2] -} {27 37} +} -cleanup { + deleteWindows +} -result {27 37} -test unixbutton-2.1 {disabled coloring check, bug 669595} unix { - # this was just a visual bug, but at least this shows the visual + +test unixbutton-2.1 {disabled coloring check, bug 669595} -constraints { + unix +} -setup { deleteWindows + catch {unset value} +} -body { + # this was just a visual bug, but at least this shows the visual set on 1 set off 0 label .l -text "The following widgets should\ - \nshow significant visible diffs\ - \nfor selected vs unselected." + \nshow significant visible diffs\ + \nfor selected vs unselected." checkbutton .cb0 -anchor w -state disabled \ - -text Unselected -variable off + -text Unselected -variable off checkbutton .cb1 -anchor w -state disabled \ - -text Selected -variable on + -text Selected -variable on checkbutton .cb2 -anchor w -state disabled \ - -text Unselected -variable off -disabledforeground "" + -text Unselected -variable off -disabledforeground "" checkbutton .cb3 -anchor w -state disabled \ - -text Selected -variable on -disabledforeground "" + -text Selected -variable on -disabledforeground "" radiobutton .rb0 -anchor w -state disabled \ - -text Unselected -variable off + -text Unselected -variable off radiobutton .rb1 -anchor w -state disabled \ - -text Selected -variable on -value 1 + -text Selected -variable on -value 1 radiobutton .rb2 -anchor w -state disabled \ - -text Unselected -variable off -disabledforeground "" + -text Unselected -variable off -disabledforeground "" radiobutton .rb3 -anchor w -state disabled \ - -text Selected -variable on -value 1 -disabledforeground "" + -text Selected -variable on -value 1 -disabledforeground "" pack .l .cb0 .cb1 .cb2 .cb3 .rb0 .rb1 .rb2 .rb3 -side top -fill x after 400 set on -} 1 +} -cleanup { + deleteWindows +} -result 1 -deleteWindows # cleanup cleanupTests return + diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test index 779746f..1360a02 100644 --- a/tests/unixEmbed.test +++ b/tests/unixEmbed.test @@ -6,11 +6,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixEmbed.test,v 1.14 2004/12/04 00:04:42 dkf Exp $ +# RCS: @(#) $Id: unixEmbed.test,v 1.15 2008/08/18 16:09:10 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test setupbg dobg {wm withdraw .} @@ -55,41 +56,53 @@ proc colorsFree {w {red 31} {green 245} {blue 192}} { && ([lindex $vals 2]/256 == $blue) } -test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} unix { - catch {destroy .t} - list [catch {toplevel .t -use xyz} msg] $msg -} {1 {expected integer but got "xyz"}} -test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} unix { - catch {destroy .t} - list [catch {toplevel .t -use 47} msg] $msg -} {1 {couldn't create child of window "47"}} -test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} {unix nonPortable} { - catch {destroy .t} - catch {destroy .x} +test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} -constraints { + unix +} -setup { + deleteWindows +} -body { + toplevel .t -use xyz +} -returnCodes error -result {expected integer but got "xyz"} +test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} -constraints { + unix +} -setup { + deleteWindows +} -body { + toplevel .t -use 47 +} -returnCodes error -result {couldn't create child of window "47"} +test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} -constraints { + unix nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -colormap new wm geometry .t +0+0 eatColors .t.t frame .t.f -container 1 toplevel .x -use [winfo id .t.f] - set result [colorsFree .x] - destroy .t - set result -} {0} -test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} {unix nonPortable} { - catch {destroy .t} - catch {destroy .t2} - catch {destroy .x} + colorsFree .x +} -cleanup { + deleteWindows +} -result {0} +test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} -constraints { + unix nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -container 1 -colormap new wm geometry .t +0+0 eatColors .t2 toplevel .x -use [winfo id .t] - set result [colorsFree .x] - destroy .t - set result -} {1} + colorsFree .x +} -cleanup { + deleteWindows +} -result {1} -test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} {unix testembed} { - deleteWindows +test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 pack .f1 .f2 @@ -99,74 +112,103 @@ test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} {unix te toplevel .t -use $w list [testembed] [expr [lindex [lindex [testembed all] 0] 0] - $w] } -} {{{XXX {} {} .t}} 0} -test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} {unix testembed} { - deleteWindows +} -cleanup { + deleteWindows +} -result {{{XXX {} {} .t}} 0} +test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 pack .f1 .f2 dobg "set w1 [winfo id .f1]" dobg "set w2 [winfo id .f2]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - toplevel .t2 -use $w2 - testembed - } -} {{XXX {} {} .t2} {XXX {} {} .t1}} -test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} {unix testembed} { - deleteWindows + eval destroy [winfo child .] + toplevel .t1 -use $w1 + toplevel .t2 -use $w2 + testembed + } +} -cleanup { + deleteWindows +} -result {{XXX {} {} .t2} {XXX {} {} .t1}} +test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 pack .f1 .f2 toplevel .t1 -use [winfo id .f1] toplevel .t2 -use [winfo id .f2] testembed -} {{XXX .f2 {} .t2} {XXX .f1 {} .t1}} +} -cleanup { + deleteWindows +} -result {{XXX .f2 {} .t2} {XXX .f1 {} .t1}} # Can't think of any way to test the procedures TkpMakeWindow, # TkpMakeContainer, or EmbedErrorProc. -test unixEmbed-2.1 {EmbeddedEventProc procedure} {unix testembed} { - deleteWindows + +test unixEmbed-2.1 {EmbeddedEventProc procedure} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - testembed + eval destroy [winfo child .] + toplevel .t1 -use $w1 + testembed } destroy .f1 update dobg { - testembed + testembed } -} {} -test unixEmbed-2.2 {EmbeddedEventProc procedure} {unix testembed} { - deleteWindows +} -cleanup { + deleteWindows +} -result {} +test unixEmbed-2.2 {EmbeddedEventProc procedure} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - testembed - destroy .t1 - testembed - } -} {} -test unixEmbed-2.3 {EmbeddedEventProc procedure} {unix testembed} { - deleteWindows + eval destroy [winfo child .] + toplevel .t1 -use $w1 + testembed + destroy .t1 + testembed + } +} -cleanup { + deleteWindows +} -result {} +test unixEmbed-2.3 {EmbeddedEventProc procedure} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] update destroy .f1 testembed -} {} -test unixEmbed-2.4 {EmbeddedEventProc procedure} {unix testembed} { - deleteWindows +} -result {} +test unixEmbed-2.4 {EmbeddedEventProc procedure} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] @@ -175,166 +217,221 @@ test unixEmbed-2.4 {EmbeddedEventProc procedure} {unix testembed} { set x [testembed] update list $x [testembed] -} {{{XXX .f1 {} {}}} {}} +} -cleanup { + deleteWindows +} -result {{{XXX .f1 {} {}}} {}} -test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} \ - {unix testembed nonPortable} { - deleteWindows + +test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} -constraints { + unix testembed nonPortable +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" set x [testembed] dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - wm withdraw .t1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 + wm withdraw .t1 } list $x [testembed] -} {{{XXX .f1 {} {}}} {{XXX .f1 XXX {}}}} -test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {{{XXX .f1 {} {}}} {{XXX .f1 XXX {}}}} +test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} -constraints { + unix +} -setup { + deleteWindows +} -body { toplevel .t1 -container 1 wm geometry .t1 +0+0 toplevel .t2 -use [winfo id .t1] -bg red update wm geometry .t2 -} {200x200+0+0} -test unixEmbed-3.2a {ContainerEventProc procedure, disallow position changes} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {200x200+0+0} +test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 -bd 2 -relief raised - update - wm geometry .t1 +30+40 + eval destroy [winfo child .] + toplevel .t1 -use $w1 -bd 2 -relief raised + update + wm geometry .t1 +30+40 } update dobg { - wm geometry .t1 + wm geometry .t1 } -} {200x200+0+0} -test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {200x200+0+0} +test unixEmbed-3.4 {ContainerEventProc procedure, disallow position changes} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - update - wm geometry .t1 300x100+30+40 + eval destroy [winfo child .] + toplevel .t1 -use $w1 + update + wm geometry .t1 300x100+30+40 } update dobg { - wm geometry .t1 + wm geometry .t1 } -} {300x100+0+0} -test unixEmbed-3.4 {ContainerEventProc procedure, geometry requests} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {300x100+0+0} +test unixEmbed-3.5 {ContainerEventProc procedure, geometry requests} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } update dobg { - .t1 configure -width 300 -height 80 + .t1 configure -width 300 -height 80 } update list [winfo width .f1] [winfo height .f1] [dobg {wm geometry .t1}] -} {300 80 300x80+0+0} -test unixEmbed-3.5 {ContainerEventProc procedure, map requests} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {300 80 300x80+0+0} +test unixEmbed-3.6 {ContainerEventProc procedure, map requests} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - set x unmapped - bind .t1 <Map> {set x mapped} + eval destroy [winfo child .] + toplevel .t1 -use $w1 + set x unmapped + bind .t1 <Map> {set x mapped} } update dobg { - after 100 - update - set x + after 100 + update + set x } -} {mapped} -test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {mapped} +test unixEmbed-3.7 {ContainerEventProc procedure, destroy events} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" bind .f1 <Destroy> {set x dead} set x alive dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } update dobg { - destroy .t1 + destroy .t1 } update list $x [winfo exists .f1] -} {dead 0} +} -cleanup { + deleteWindows +} -result {dead 0} -test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} unix { - deleteWindows + +test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } update dobg { - .t1 configure -width 180 -height 100 + .t1 configure -width 180 -height 100 } update dobg { - winfo geometry .t1 + winfo geometry .t1 } -} {180x100+0+0} -test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} {unix testembed} { - deleteWindows +} -cleanup { + deleteWindows +} -result {180x100+0+0} +test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } update set x [testembed] destroy .f1 list $x [testembed] -} {{{XXX .f1 XXX {}}} {}} +} -cleanup { + deleteWindows +} -result {{{XXX .f1 XXX {}}} {}} -test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} unix { - deleteWindows + +test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - bind .t1 <FocusIn> {lappend x "focus in %W"} - bind .t1 <FocusOut> {lappend x "focus out %W"} - set x {} + eval destroy [winfo child .] + toplevel .t1 -use $w1 + bind .t1 <FocusIn> {lappend x "focus in %W"} + bind .t1 <FocusOut> {lappend x "focus out %W"} + set x {} } focus -force .f1 update dobg {set x} -} {{focus in .t1}} -test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {{focus in .t1}} +test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -344,23 +441,28 @@ test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} unix { } update dobg { - after 200 {destroy .t1} + after 200 {destroy .t1} } after 400 focus -force .f1 update -} {} -test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {} +test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - bind .t1 <FocusIn> {lappend x "focus in %W"} - bind .t1 <FocusOut> {lappend x "focus out %W"} - set x {} + eval destroy [winfo child .] + toplevel .t1 -use $w1 + bind .t1 <FocusIn> {lappend x "focus in %W"} + bind .t1 <FocusOut> {lappend x "focus out %W"} + set x {} } focus -force .f1 update @@ -368,79 +470,102 @@ test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} unix { focus . update list $x [dobg {update; set x}] -} {{{focus in .t1}} {{focus in .t1} {focus out .t1}}} +} -cleanup { + deleteWindows +} -result {{{focus in .t1}} {{focus in .t1} {focus out .t1}}} -test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} unix { - deleteWindows + +test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } update dobg { - bind .t1 <Configure> {lappend x {configure .t1 %w %h}} - set x {} - .t1 configure -width 300 -height 120 - update - list $x [winfo geom .t1] + bind .t1 <Configure> {lappend x {configure .t1 %w %h}} + set x {} + .t1 configure -width 300 -height 120 + update + list $x [winfo geom .t1] } -} {{{configure .t1 300 120}} 300x120+0+0} -test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {{{configure .t1 300 120}} 300x120+0+0} +test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 place .f1 -width 200 -height 200 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } after 300 {set x done} vwait x dobg { - bind .t1 <Configure> {lappend x {configure .t1 %w %h}} - set x {} - .t1 configure -width 300 -height 120 - update - list $x [winfo geom .t1] + bind .t1 <Configure> {lappend x {configure .t1 %w %h}} + set x {} + .t1 configure -width 300 -height 120 + update + list $x [winfo geom .t1] } -} {{{configure .t1 200 200}} 200x200+0+0} +} -cleanup { + deleteWindows +} -result {{{configure .t1 200 200}} 200x200+0+0} # Can't think up any tests for TkpGetOtherWindow procedure. -test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} unix { + +test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} -constraints { + unix +} -setup { + deleteWindows +} -body { deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } focus -force . bind . <KeyPress> {lappend x {key %A %E}} set x {} set y [dobg { - update - bind .t1 <KeyPress> {lappend y {key %A}} - set y {} - event generate .t1 <KeyPress> -keysym a - set y + update + bind .t1 <KeyPress> {lappend y {key %A}} + set y {} + event generate .t1 <KeyPress> -keysym a + set y }] update - bind . <KeyPress> {} list $x $y -} {{{key a 1}} {}} -test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} unix { - deleteWindows +} -cleanup { + deleteWindows + bind . <KeyPress> {} +} -result {{{key a 1}} {}} +test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } update focus -force .f1 @@ -448,41 +573,49 @@ test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width bind . <KeyPress> {lappend x {key %A}} set x {} set y [dobg { - update - bind .t1 <KeyPress> {lappend y {key %A}} - set y {} - event generate .t1 <KeyPress> -keysym b - set y + update + bind .t1 <KeyPress> {lappend y {key %A}} + set y {} + event generate .t1 <KeyPress> -keysym b + set y }] update - bind . <KeyPress> {} list $x $y -} {{} {{key b}}} +} -cleanup { + deleteWindows + bind . <KeyPress> {} +} -result {{} {{key b}}} -test unixEmbed-8.1 {TkpClaimFocus procedure} unix { - deleteWindows + +test unixEmbed-8.1 {TkpClaimFocus procedure} -constraints unix -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 frame .f2 -width 200 -height 50 pack .f1 .f2 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken + eval destroy [winfo child .] + toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken } focus -force .f2 update list [dobg { - focus .t1 - set x [list [focus]] - update - after 500 - update - lappend x [focus] + focus .t1 + set x [list [focus]] + update + after 500 + update + lappend x [focus] }] [focus] -} {{{} .t1} .f1} -test unixEmbed-8.2 {TkpClaimFocus procedure} unix { +} -cleanup { + deleteWindows +} -result {{{} .t1} .f1} +test unixEmbed-8.2 {TkpClaimFocus procedure} -constraints unix -setup { + deleteWindows catch {interp delete child} deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 frame .f2 -width 200 -height 50 pack .f1 .f2 @@ -490,21 +623,27 @@ test unixEmbed-8.2 {TkpClaimFocus procedure} unix { child eval "set argv {-use [winfo id .f1]}" load {} Tk child child eval { - . configure -bd 2 -highlightthickness 2 -relief sunken + . configure -bd 2 -highlightthickness 2 -relief sunken } focus -force .f2 update list [child eval { - focus . - set x [list [focus]] - update - lappend x [focus] + focus . + set x [list [focus]] + update + lappend x [focus] }] [focus] -} {{{} .} .f1} +} -cleanup { + deleteWindows +} -result {{{} .} .f1} catch {interp delete child} -test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} {unix testembed} { - deleteWindows + +test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 frame .f3 -container 1 -width 200 -height 50 @@ -513,28 +652,39 @@ test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} {unix testemb set x {} lappend x [testembed] foreach w {.f3 .f4 .f1 .f2} { - destroy $w - lappend x [testembed] + destroy $w + lappend x [testembed] } set x -} {{{XXX .f4 {} {}} {XXX .f3 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f4 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}}} {}} -test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} {unix testembed} { - deleteWindows +} -cleanup { + deleteWindows +} -result {{{XXX .f4 {} {}} {XXX .f3 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f4 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}}} {}} +test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken - set x {} - lappend x [testembed] - destroy .t1 - lappend x [testembed] + eval destroy [winfo child .] + toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken + set x {} + lappend x [testembed] + destroy .t1 + lappend x [testembed] } -} {{{XXX {} {} .t1}} {}} +} -cleanup { + deleteWindows +} -result {{{XXX {} {} .t1}} {}} -test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix { - deleteWindows + +test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] -width 150 -height 80 @@ -542,9 +692,14 @@ test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix wm geometry .t1 +40+50 update wm geometry .t1 -} {150x80+0+0} -test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {150x80+0+0} +test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] -width 150 -height 80 @@ -552,10 +707,13 @@ test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix wm geometry .t1 70x300+10+20 update wm geometry .t1 -} {70x300+0+0} +} -cleanup { + deleteWindows +} -result {70x300+0+0} # cleanup deleteWindows cleanupbg cleanupTests return + diff --git a/tests/winClipboard.test b/tests/winClipboard.test index 7a710fd..13f0349 100644 --- a/tests/winClipboard.test +++ b/tests/winClipboard.test @@ -10,69 +10,97 @@ # Copyright (c) 1998-2000 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winClipboard.test,v 1.14 2004/06/24 12:45:44 dkf Exp $ +# RCS: @(#) $Id: winClipboard.test,v 1.15 2008/08/18 16:09:10 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test # Note that these tests may fail if another application is grabbing the # clipboard (e.g. an X server) -test winClipboard-1.1 {TkSelGetSelection} win { +test winClipboard-1.1 {TkSelGetSelection} -constraints win -setup { clipboard clear - catch {selection get -selection CLIPBOARD} msg - set msg -} {CLIPBOARD selection doesn't exist or form "STRING" not defined} -test winClipboard-1.2 {TkSelGetSelection} {win testclipboard} { +} -body { + selection get -selection CLIPBOARD +} -cleanup { clipboard clear +} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined} + +test winClipboard-1.2 {TkSelGetSelection} -constraints { + win testclipboard +} -setup { + clipboard clear +} -body { clipboard append {} - catch {selection get -selection CLIPBOARD} r1 - catch {testclipboard} r2 - list $r1 $r2 -} {{} {}} -test winClipboard-1.3 {TkSelGetSelection & TkWinClipboardRender} {win testclipboard} { + list [selection get -selection CLIPBOARD] [testclipboard] +} -cleanup { + clipboard clear +} -result {{} {}} + +test winClipboard-1.3 {TkSelGetSelection & TkWinClipboardRender} -constraints { + win testclipboard +} -setup { clipboard clear +} -body { clipboard append abcd update - catch {selection get -selection CLIPBOARD} r1 - catch {testclipboard} r2 - list $r1 $r2 -} {abcd abcd} -test winClipboard-1.4 {TkSelGetSelection & TkWinClipboardRender} {win testclipboard} { + list [selection get -selection CLIPBOARD] [testclipboard] +} -cleanup { clipboard clear +} -result {abcd abcd} + +test winClipboard-1.4 {TkSelGetSelection & TkWinClipboardRender} -constraints { + win testclipboard +} -setup { + clipboard clear +} -body { clipboard append "line 1\nline 2" - catch {selection get -selection CLIPBOARD} r1 - catch {testclipboard} r2 - list $r1 $r2 -} [list "line 1\nline 2" "line 1\r\nline 2"] -test winClipboard-1.5 {TkSelGetSelection & TkWinClipboardRender} {win testclipboard} { + list [selection get -selection CLIPBOARD] [testclipboard] +} -cleanup { + clipboard clear +} -result [list "line 1\nline 2" "line 1\r\nline 2"] + +test winClipboard-1.5 {TkSelGetSelection & TkWinClipboardRender} -constraints { + win testclipboard +} -setup { clipboard clear +} -body { clipboard append "line 1\u00c7\nline 2" - catch {selection get -selection CLIPBOARD} r1 - catch {testclipboard} r2 - list $r1 $r2 -} [list "line 1\u00c7\nline 2" [bytestring "line 1\u00c7\r\nline 2"]] + list [selection get -selection CLIPBOARD] [testclipboard] +} -cleanup { + clipboard clear +} -result [list "line 1\u00c7\nline 2" [bytestring "line 1\u00c7\r\nline 2"]] -test winClipboard-2.1 {TkSelUpdateClipboard reentrancy problem} {win testclipboard} { + +test winClipboard-2.1 {TkSelUpdateClipboard reentrancy problem} -constraints { + win testclipboard +} -setup { clipboard clear +} -body { clipboard append -type OUR_ACTION "action data" clipboard append "string data" update - catch {selection get -selection CLIPBOARD -type OUR_ACTION} r1 - catch {testclipboard} r2 - list $r1 $r2 -} [list "action data" "string data"] -test winClipboard-2.2 {TkSelUpdateClipboard reentrancy problem} {win testclipboard} { + list [selection get -selection CLIPBOARD -type OUR_ACTION] [testclipboard] +} -cleanup { clipboard clear +} -result {{action data} {string data}} + +test winClipboard-2.2 {TkSelUpdateClipboard reentrancy problem} -constraints { + win testclipboard +} -setup { + clipboard clear +} -body { clipboard append -type OUR_ACTION "new data" clipboard append "more data in string" update - catch {testclipboard} r1 - catch {selection get -selection CLIPBOARD -type OUR_ACTION} r2 - list $r1 $r2 -} [list "more data in string" "new data"] + list [testclipboard] [selection get -selection CLIPBOARD -type OUR_ACTION] +} -cleanup { + clipboard clear +} -result {{more data in string} {new data}} # cleanup cleanupTests return + |