diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/bind.test | 164 | ||||
| -rw-r--r-- | tests/button.test | 31 | ||||
| -rw-r--r-- | tests/canvas.test | 437 | ||||
| -rw-r--r-- | tests/cursor.test | 22 | ||||
| -rw-r--r-- | tests/scrollbar.test | 52 |
5 files changed, 370 insertions, 336 deletions
diff --git a/tests/bind.test b/tests/bind.test index 11df00e..3f0d2f9 100644 --- a/tests/bind.test +++ b/tests/bind.test @@ -7,7 +7,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: bind.test,v 1.17 2004/09/01 10:00:03 dkf Exp $ +# RCS: @(#) $Id: bind.test,v 1.18 2004/12/07 10:07:41 dkf Exp $ package require tcltest 2.1 eval tcltest::configure $argv @@ -2365,107 +2365,97 @@ test bind-24.14 {FindSequence procedure: no binding} { list [catch {.b.f bind $i <a>} msg] $msg } {0 {}} -test bind-25.1 {ParseEventDescription procedure} { - list [catch {bind .b \x7 test} msg] $msg -} {1 {bad ASCII character 0x7}} -test bind-25.2 {ParseEventDescription procedure} { - list [catch {bind .b "\x7f" test} msg] $msg -} {1 {bad ASCII character 0x7f}} -test bind-25.3 {ParseEventDescription procedure} { - list [catch {bind .b "\x4" test} msg] $msg -} {1 {bad ASCII character 0x4}} -test bind-25.4 {ParseEventDescription procedure} { +test bind-25.1 {ParseEventDescription procedure} -setup { setup +} -body { bind .b.f a test bind .b.f a -} {test} -test bind-25.5 {ParseEventDescription procedure: virtual} { - list [catch {bind .b <<>> foo} msg] $msg -} {1 {virtual event "<<>>" is badly formed}} -test bind-25.6 {ParseEventDescription procedure: virtual} { - list [catch {bind .b <<Paste foo} msg] $msg -} {1 {missing ">" in virtual binding}} -test bind-25.7 {ParseEventDescription procedure: virtual} { - list [catch {bind .b <<Paste> foo} msg] $msg -} {1 {missing ">" in virtual binding}} -test bind-25.8 {ParseEventDescription procedure: correctly terminate virtual} { - list [catch {bind .b <<Paste>>h foo} msg] $msg -} {1 {virtual events may not be composed}} -test bind-25.9 {ParseEventDescription procedure} { - list [catch {bind .b <> test} msg] $msg -} {1 {no event type or button # or keysym}} -test bind-25.10 {ParseEventDescription procedure: misinterpreted modifier} { +} -result test +test bind-25.2 {ParseEventDescription procedure: misinterpreted modifier} -setup { button .x +} -body { bind .x <Control-M> a bind .x <M-M> b - set x [lsort [bind .x]] + lsort [bind .x] +} -cleanup { destroy .x - set x -} {<Control-Key-M> <Meta-Key-M>} -test bind-25.11 {ParseEventDescription procedure} { +} -result {<Control-Key-M> <Meta-Key-M>} +test bind-25.3 {ParseEventDescription procedure} -setup { catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 +} -body { bind .b.f <a---> {nothing} bind .b.f -} a -test bind-25.12 {ParseEventDescription procedure} { - list [catch {bind .b <a-- test} msg] $msg -} {1 {missing ">" in binding}} -test bind-25.13 {ParseEventDescription procedure} { - list [catch {bind .b <a-b> test} msg] $msg -} {1 {extra characters after detail in binding}} -test bind-25.14 {ParseEventDescription} { - setup - list [catch {bind .b <<abc {puts hi}} msg] $msg -} {1 {missing ">" in virtual binding}} -test bind-25.15 {ParseEventDescription} { - setup - list [catch {bind .b <<abc> {puts hi}} msg] $msg -} {1 {missing ">" in virtual binding}} -test bind-25.16 {ParseEventDescription} { +} -result a +test bind-25.4 {ParseEventDescription} -setup { setup +} -body { bind .b <<Shift-Paste>> {puts hi} bind .b -} {<<Shift-Paste>>} -test bind-25.17 {ParseEventDescription} { - setup - list [catch {event add <<xyz>> <<abc>>} msg] $msg -} {1 {virtual event not allowed in definition of another virtual event}} -foreach check { - {bind-25.1 {<Control- a>} <Control-Key-a>} - {bind-25.2 <Shift-a> <Shift-Key-a>} - {bind-25.3 <Lock-a> <Lock-Key-a>} - {bind-25.4 <Meta---a> <Meta-Key-a>} - {bind-25.5 <M-a> <Meta-Key-a>} - {bind-25.6 <Alt-a> <Alt-Key-a>} - {bind-25.7 <B1-a> <B1-Key-a>} - {bind-25.8 <B2-a> <B2-Key-a>} - {bind-25.9 <B3-a> <B3-Key-a>} - {bind-25.10 <B4-a> <B4-Key-a>} - {bind-25.11 <B5-a> <B5-Key-a>} - {bind-25.12 <Button1-a> <B1-Key-a>} - {bind-25.13 <Button2-a> <B2-Key-a>} - {bind-25.14 <Button3-a> <B3-Key-a>} - {bind-25.15 <Button4-a> <B4-Key-a>} - {bind-25.16 <Button5-a> <B5-Key-a>} - {bind-25.17 <M1-a> <Mod1-Key-a>} - {bind-25.18 <M2-a> <Mod2-Key-a>} - {bind-25.19 <M3-a> <Mod3-Key-a>} - {bind-25.20 <M4-a> <Mod4-Key-a>} - {bind-25.21 <M5-a> <Mod5-Key-a>} - {bind-25.22 <Mod1-a> <Mod1-Key-a>} - {bind-25.23 <Mod2-a> <Mod2-Key-a>} - {bind-25.24 <Mod3-a> <Mod3-Key-a>} - {bind-25.25 <Mod4-a> <Mod4-Key-a>} - {bind-25.26 <Mod5-a> <Mod5-Key-a>} - {bind-25.27 <Double-a> <Double-Key-a>} - {bind-25.28 <Triple-a> <Triple-Key-a>} - {bind-25.29 {<Double 1>} <Double-Button-1>} - {bind-25.30 <Triple-1> <Triple-Button-1>} - {bind-25.31 {<M1-M2 M3-M4 B1-Control-a>} <Control-B1-Mod1-Mod2-Mod3-Mod4-Key-a>} - {bind-25.32 <Extended-Return> <Extended-Key-Return>} +} -result {<<Shift-Paste>>} +# Assorted error cases in event sequence parsing +foreach {testname testinfo} { + bind-25.5 {\x7 {bad ASCII character 0x7}} + bind-25.6 {\x7f {bad ASCII character 0x7f}} + bind-25.7 {\x4 {bad ASCII character 0x4}} + bind-25.8 {<<>> {virtual event "<<>>" is badly formed}} + bind-25.9 {<<Paste {missing ">" in virtual binding}} + bind-25.10 {<<Paste> {missing ">" in virtual binding}} + bind-25.11 {<<Paste>>h {virtual events may not be composed}} + bind-25.12 {<> "no event type or button # or keysym"} + bind-25.13 {<a-- {missing ">" in binding}} + bind-25.14 {<a-b> {extra characters after detail in binding}} + bind-25.15 {<<abc {missing ">" in virtual binding}} + bind-25.16 {<<abc> {missing ">" in virtual binding}} +} { + lassign $testinfo sequence errorMessage + test $testname {ParseEventDescription procedure error cases} \ + -setup { setup } \ + -body [list bind .b $sequence {puts hi}] \ + -returnCodes error -result $errorMessage +} +test bind-25.17 {ParseEventDescription} -setup { + setup +} -returnCodes error -body { + event add <<xyz>> <<abc>> +} -result {virtual event not allowed in definition of another virtual event} +# Modifier canonicalization tests +foreach {name check} { + bind-25.18 {{<Control- a>} <Control-Key-a>} + bind-25.19 {<Shift-a> <Shift-Key-a>} + bind-25.20 {<Lock-a> <Lock-Key-a>} + bind-25.21 {<Meta---a> <Meta-Key-a>} + bind-25.22 {<M-a> <Meta-Key-a>} + bind-25.23 {<Alt-a> <Alt-Key-a>} + bind-25.24 {<B1-a> <B1-Key-a>} + bind-25.25 {<B2-a> <B2-Key-a>} + bind-25.26 {<B3-a> <B3-Key-a>} + bind-25.27 {<B4-a> <B4-Key-a>} + bind-25.28 {<B5-a> <B5-Key-a>} + bind-25.29 {<Button1-a> <B1-Key-a>} + bind-25.30 {<Button2-a> <B2-Key-a>} + bind-25.31 {<Button3-a> <B3-Key-a>} + bind-25.32 {<Button4-a> <B4-Key-a>} + bind-25.33 {<Button5-a> <B5-Key-a>} + bind-25.34 {<M1-a> <Mod1-Key-a>} + bind-25.35 {<M2-a> <Mod2-Key-a>} + bind-25.36 {<M3-a> <Mod3-Key-a>} + bind-25.37 {<M4-a> <Mod4-Key-a>} + bind-25.38 {<M5-a> <Mod5-Key-a>} + bind-25.39 {<Mod1-a> <Mod1-Key-a>} + bind-25.40 {<Mod2-a> <Mod2-Key-a>} + bind-25.41 {<Mod3-a> <Mod3-Key-a>} + bind-25.42 {<Mod4-a> <Mod4-Key-a>} + bind-25.43 {<Mod5-a> <Mod5-Key-a>} + bind-25.44 {<Double-a> <Double-Key-a>} + bind-25.45 {<Triple-a> <Triple-Key-a>} + bind-25.46 {{<Double 1>} <Double-Button-1>} + bind-25.47 {<Triple-1> <Triple-Button-1>} + bind-25.48 {{<M1-M2 M3-M4 B1-Control-a>} + <Control-B1-Mod1-Mod2-Mod3-Mod4-Key-a>} + bind-25.49 {<Extended-Return> <Extended-Key-Return>} } { - lassign $check name shortBind longBind + lassign $check shortBind longBind test $name {modifier names} -setup { catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 diff --git a/tests/button.test b/tests/button.test index 49f117b..d3f93d8 100644 --- a/tests/button.test +++ b/tests/button.test @@ -7,7 +7,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: button.test,v 1.18 2004/12/04 00:04:41 dkf Exp $ +# RCS: @(#) $Id: button.test,v 1.19 2004/12/07 10:07:41 dkf Exp $ package require tcltest 2.1 eval tcltest::configure $argv @@ -112,27 +112,34 @@ foreach test { } { lassign $test name value okResult badValue badResult classes foreach w {.l .b .c .r} hasOption $classes { + set classname [winfo class $w] if {$hasOption} { - test button-1.$i {configuration options} testImageType { - $w configure $name $value - lindex [$w configure $name] 4 - } $okResult + test button-1.$i "configuration option $name for $classname" \ + -constraint testImageType -body " + $w configure $name [list $value] + lindex \[$w configure $name] 4 + " -result $okResult incr i if {$badValue ne ""} { - test button-1.$i {configuration options} testImageType { - list [catch {$w configure $name $badValue} msg] $msg - } [list 1 $badResult] + test button-1.$i "configuration option $name for $classname" \ + -constraint testImageType \ + -body [list $w configure $name $badValue] \ + -returnCodes error -result $badResult + incr i } $w configure $name [lindex [$w configure $name] 3] } else { - test button-1.$i {configuration options} testImageType { - list [catch {$w configure $name $value} msg] $msg - } "1 {unknown option \"$name\"}" + test button-1.$i "configuration option $name for $classname" \ + -constraint testImageType \ + -body [list $w configure $name $value] \ + -returnCodes error -result "unknown option \"$name\"" + incr i } } - incr i } test button-1.$i {configuration options} { + # Additional check to make sure that -selectcolor may be empty in + # checkbox widgets .c configure -selectcolor {} } {} diff --git a/tests/canvas.test b/tests/canvas.test index 49c69e1..323ebaa 100644 --- a/tests/canvas.test +++ b/tests/canvas.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-2000 Ajuba Solutions. # All rights reserved. # -# RCS: @(#) $Id: canvas.test,v 1.21 2004/08/20 08:03:46 dkf Exp $ +# RCS: @(#) $Id: canvas.test,v 1.22 2004/12/07 10:07:41 dkf Exp $ package require tcltest 2.1 eval tcltest::configure $argv @@ -19,58 +19,64 @@ canvas .c pack .c update set i 1 -foreach test { - {-background #ff0000 #ff0000 - non-existent {unknown color name "non-existent"}} - {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-closeenough 24 24.0 - bogus {expected floating-point number but got "bogus"}} - {-confine true 1 silly {expected boolean value but got "silly"}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-height 2.1 2 x42 {bad screen distance "x42"}} - {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} - {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}} - {-highlightthickness 18 18 badValue {bad screen distance "badValue"}} - {-insertbackground #110022 #110022 bogus {unknown color name "bogus"}} - {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}} - {-insertofftime 100 100 3.2 {expected integer but got "3.2"}} - {-insertontime 100 100 3.2 {expected integer but got "3.2"}} - {-insertwidth 1.3 1 6x {bad screen distance "6x"}} - {-relief groove groove - 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}} - {-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}} - {-takefocus "any string" "any string" {} {}} - {-width 402 402 xyz {bad screen distance "xyz"}} - {-xscrollcommand {Some command} {Some command} {} {}} - {-yscrollcommand {Another command} {Another command} {} {}} +foreach {testname testinfo} { + canvas-1.1 {-background #ff0000 #ff0000 + non-existent {unknown color name "non-existent"}} + canvas-1.2 {-bg #ff0000 #ff0000 + non-existent {unknown color name "non-existent"}} + canvas-1.3 {-bd 4 4 badValue {bad screen distance "badValue"}} + canvas-1.4 {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + canvas-1.5 {-closeenough 24 24.0 + bogus {expected floating-point number but got "bogus"}} + canvas-1.6 {-confine true 1 silly {expected boolean value but got "silly"}} + canvas-1.7 {-cursor arrow arrow badValue {bad cursor spec "badValue"}} + canvas-1.8 {-height 2.1 2 x42 {bad screen distance "x42"}} + canvas-1.9 {-highlightbackground #112233 #112233 + ugly {unknown color name "ugly"}} + canvas-1.10 {-highlightcolor #110022 #110022 + bogus {unknown color name "bogus"}} + canvas-1.11 {-highlightthickness 18 18 + badValue {bad screen distance "badValue"}} + canvas-1.12 {-insertbackground #110022 #110022 + bogus {unknown color name "bogus"}} + canvas-1.13 {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}} + canvas-1.14 {-insertofftime 100 100 3.2 {expected integer but got "3.2"}} + canvas-1.15 {-insertontime 100 100 3.2 {expected integer but got "3.2"}} + canvas-1.16 {-insertwidth 1.3 1 6x {bad screen distance "6x"}} + canvas-1.17 {-relief groove groove + 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} + canvas-1.18 {-selectbackground #110022 #110022 + bogus {unknown color name "bogus"}} + canvas-1.19 {-selectborderwidth 1.3 1 + badValue {bad screen distance "badValue"}} + canvas-1.20 {-selectforeground #654321 #654321 + bogus {unknown color name "bogus"}} + canvas-1.21 {-takefocus "any string" "any string" {} {}} + canvas-1.22 {-width 402 402 xyz {bad screen distance "xyz"}} + canvas-1.23 {-xscrollcommand {Some command} {Some command} {} {}} + canvas-1.24 {-yscrollcommand {Another command} {Another command} {} {}} } { - lassign $test name goodValue goodResult badValue badResult - test canvas-1.$i "configuration options: good value for $name" { + lassign $testinfo name goodValue goodResult badValue badResult + test $testname-good "configuration options: good value for $name" { .c configure $name $goodValue lindex [.c configure $name] 4 } $goodResult incr i if {$badValue ne ""} { - test canvas-1.$i "configuration options: bad value for $name" -body { + test $testname-bad "configuration options: bad value for $name" -body { .c configure $name $badValue } -returnCodes error -result $badResult } .c configure $name [lindex [.c configure $name] 3] incr i } - -test canvas-1.40 {configure throws error on bad option} { +test canvas-1.25 {configure throws error on bad option} { set res [list [catch {.c configure -gorp foo}]] .c create rect 10 10 100 100 lappend res [catch {.c configure -gorp foo}] set res } [list 1 1] - catch {destroy .c} canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \ -highlightthickness 0 @@ -191,20 +197,22 @@ test canvas-6.5 {CanvasSetOrigin procedure} { .c canvasy 0 } {55.0} -set l [interp hidden] deleteWindows -test canvas-7.1 {canvas widget vs hidden commands} { +set l [lsort [interp hidden]] +test canvas-7.1 {canvas widget vs hidden commands} -setup { catch {destroy .c} +} -body { canvas .c interp hide {} .c destroy .c - list [winfo children .] [interp hidden] -} [list {} $l] + list [winfo children .] [lsort [interp hidden]] +} -result [list {} $l] -test canvas-8.1 {canvas arc bbox} { +test canvas-8.1 {canvas arc bbox} -setup { catch {destroy .c} canvas .c +} -body { .c create arc -100 10 100 210 -start 10 -extent 50 -style arc -tags arc1 set arcBox [.c bbox arc1] .c create arc 100 10 300 210 -start 10 -extent 50 -style chord -tags arc2 @@ -212,21 +220,23 @@ test canvas-8.1 {canvas arc bbox} { .c create arc 300 10 500 210 -start 10 -extent 50 -style pieslice -tags arc3 set pieBox [.c bbox arc3] list $arcBox $coordBox $pieBox -} {{48 21 100 94} {248 21 300 94} {398 21 500 112}} -test canvas-9.1 {canvas id creation and deletion} { +} -result {{48 21 100 94} {248 21 300 94} {398 21 500 112}} + +test canvas-9.1 {canvas id creation and deletion} -setup { + catch {destroy .c} + canvas .c +} -body { # With Tk 8.0.4 the ids are now stored in a hash table. You # can use this test as a performance test with older versions # by changing the value of size. set size 15 - catch {destroy .c} - set c [canvas .c] for {set i 0} {$i < $size} {incr i} { set x [expr {-10 + 3*$i}] for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { - $c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \ + .c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \ -outline black -fill blue -tags rect - $c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \ + .c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \ -anchor center -tags text } } @@ -235,136 +245,141 @@ test canvas-9.1 {canvas id creation and deletion} { # table changes. set time [lindex [time { - foreach id [$c find withtag all] { - $c lower $id - $c raise $id - $c find withtag $id - $c bind <Return> $id {} - $c delete $id + foreach id [.c find withtag all] { + .c lower $id + .c raise $id + .c find withtag $id + .c bind <Return> $id {} + .c delete $id } }] 0] set x "" } {} -test canvas-10.1 {find items using tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 60 40 80 -fill yellow -tag [list b a] - .c create oval 20 100 40 120 -fill green -tag [list c b] - .c create oval 20 140 40 160 -fill blue -tag [list b] - .c create oval 20 180 40 200 -fill bisque -tag [list a d e] - .c create oval 20 220 40 240 -fill bisque -tag b - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - set res {} - lappend res [.c find withtag {!a}] - lappend res [.c find withtag {b&&c}] - lappend res [.c find withtag {b||c}] - lappend res [.c find withtag {a&&!b}] - lappend res [.c find withtag {!b&&!c}] - lappend res [.c find withtag {d&&a&&c&&b}] - lappend res [.c find withtag {b^a}] - lappend res [.c find withtag {(a&&!b)||(!a&&b)}] - lappend res [.c find withtag { ( a && ! b ) || ( ! a && b ) }] - lappend res [.c find withtag {a&&!(c||d)}] - lappend res [.c find withtag {d&&"tag with spaces"}] - lappend res [.c find withtag "tag with spaces"] -} {{3 4 6 7} {1 3} {1 2 3 4 6} 5 {5 7} 1 {3 4 5 6} {3 4 5 6} {3 4 5 6} 2 7 7} -test canvas-10.2 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {&&c}} err - set err -} {Unexpected operator in tag search expression} -test canvas-10.3 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {!!c}} err - set err -} {Too many '!' in tag search expression} -test canvas-10.4 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {b||}} err - set err -} {Missing tag in tag search expression} -test canvas-10.5 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {b&&(c||)}} err - set err -} {Unexpected operator in tag search expression} -test canvas-10.6 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {d&&""}} err - set err -} {Null quoted tag string in tag search expression} -test canvas-10.7 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag "d&&\"tag with spaces"} err - set err -} {Missing endquote in tag search expression} -test canvas-10.8 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {a&&"tag with spaces"z}} err - set err -} {Invalid boolean operator in tag search expression} -test canvas-10.9 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {a&&b&c}} err - set err -} {Singleton '&' in tag search expression} -test canvas-10.10 {check errors from tag expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list a b c d] - .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - catch {.c find withtag {a||b|c}} err - set err -} {Singleton '|' in tag search expression} -test canvas-10.11 {backward compatility - strange tags that are not expressions} { - catch {destroy .c} - canvas .c - .c create oval 20 20 40 40 -fill red -tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }] - .c find withtag { strange tag(xxx&yyy|zzz) " && \" || ! ^ " } -} {1} -test canvas-10.12 {multple events bound to same tag expr} { - catch {destroy .c} - canvas .c - .c bind {a && b} <Enter> {puts Enter} - .c bind {a && b} <Leave> {puts Leave} -} {} +test canvas-10.1 {find items using tag expressions} -setup { + catch {destroy .c} + canvas .c +} -body { + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 60 40 80 -fill yellow -tag [list b a] + .c create oval 20 100 40 120 -fill green -tag [list c b] + .c create oval 20 140 40 160 -fill blue -tag [list b] + .c create oval 20 180 40 200 -fill bisque -tag [list a d e] + .c create oval 20 220 40 240 -fill bisque -tag b + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] + set res {} + lappend res [.c find withtag {!a}] + lappend res [.c find withtag {b&&c}] + lappend res [.c find withtag {b||c}] + lappend res [.c find withtag {a&&!b}] + lappend res [.c find withtag {!b&&!c}] + lappend res [.c find withtag {d&&a&&c&&b}] + lappend res [.c find withtag {b^a}] + lappend res [.c find withtag {(a&&!b)||(!a&&b)}] + lappend res [.c find withtag { ( a && ! b ) || ( ! a && b ) }] + lappend res [.c find withtag {a&&!(c||d)}] + lappend res [.c find withtag {d&&"tag with spaces"}] + lappend res [.c find withtag "tag with spaces"] +} -result {{3 4 6 7} {1 3} {1 2 3 4 6} 5 {5 7} 1 {3 4 5 6} {3 4 5 6} {3 4 5 6} 2 7 7} +test canvas-10.2 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {&&c} +} -returnCodes error -result {Unexpected operator in tag search expression} +test canvas-10.3 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {!!c} +} -returnCodes error -result {Too many '!' in tag search expression} +test canvas-10.4 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {b||} +} -returnCodes error -result {Missing tag in tag search expression} +test canvas-10.5 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {b&&(c||)} +} -returnCodes error -result {Unexpected operator in tag search expression} +test canvas-10.6 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {d&&""} +} -returnCodes error -result {Null quoted tag string in tag search expression} +test canvas-10.7 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag "d&&\"tag with spaces" +} -returnCodes error -result {Missing endquote in tag search expression} +test canvas-10.8 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {a&&"tag with spaces"z} +} -returnCodes error -result {Invalid boolean operator in tag search expression} +test canvas-10.9 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {a&&b&c} +} -returnCodes error -result {Singleton '&' in tag search expression} +test canvas-10.10 {check errors from tag expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] +} -body { + .c find withtag {a||b|c} +} -returnCodes error -result {Singleton '|' in tag search expression} +test canvas-10.11 {backward compatility - strange tags that are not expressions} -setup { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }] +} -body { + .c find withtag { strange tag(xxx&yyy|zzz) " && \" || ! ^ " } +} -result 1 +test canvas-10.12 {multple events bound to same tag expr} -setup { + catch {destroy .c} + canvas .c +} -body { + .c bind {a && b} <Enter> {puts Enter} + .c bind {a && b} <Leave> {puts Leave} +} -result {} -test canvas-11.1 {canvas poly fill check, bug 5783} { - # This would crash in 8.3.0 and 8.3.1 +test canvas-11.1 {canvas poly fill check, bug 5783} -setup { destroy .c pack [canvas .c] +} -body { + # This would crash in 8.3.0 and 8.3.1 .c create polygon 0 0 100 100 200 50 \ -fill {} -stipple gray50 -outline black -} 1 -test canvas-11.2 {canvas poly overlap fill check, bug 226357} { +} -result 1 +test canvas-11.2 {canvas poly overlap fill check, bug 226357} -setup { destroy .c pack [canvas .c] +} -body { set result {} .c create poly 30 30 90 90 30 90 90 30 lappend result [.c find over 40 40 45 45]; # rect region inc. edge @@ -380,27 +395,29 @@ test canvas-11.2 {canvas poly overlap fill check, bug 226357} { lappend result [.c find over 45 50 45 50]; # outside poly .c itemconfig 1 -width 8 lappend result [.c find over 45 50 45 50]; # outside poly -} {1 1 {} 1 {} 1 1 {} 1 {} 1} +} -result {1 1 {} 1 {} 1 1 {} 1 {} 1} -test canvas-12.1 {canvas mm obj, patch SF-403327, 102471} { +test canvas-12.1 {canvas mm obj, patch SF-403327, 102471} -setup { destroy .c pack [canvas .c] +} -body { set qx [expr {1.+1.}] # qx has type double and no string representation .c scale all $qx 0 1. 1. # qx has now type MMRep and no string representation list $qx [string length $qx] -} {2.0 3} -test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} { +} -result {2.0 3} +test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} -setup { destroy .c pack [canvas .c] +} -body { set val 10 incr val # qx has type double and no string representation .c scale all $val 0 1 1 # qx has now type MMRep and no string representation incr val -} {12} +} -result 12 proc kill_canvas {w} { destroy $w @@ -426,30 +443,42 @@ test canvas-13.1 {canvas delete during event, SF bug-228024} { set ::x } okokokokokokokokokokokokokokokokokokokokokokokokokokokokokok -test canvas-14.1 {canvas scan SF bug 581560} { - destroy .c; canvas .c - list [catch {.c scan} msg] $msg -} {1 {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}} -test canvas-14.2 {canvas scan} { - destroy .c; canvas .c - list [catch {.c scan bogus} msg] $msg -} {1 {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}} -test canvas-14.3 {canvas scan} { - destroy .c; canvas .c - list [catch {.c scan mark} msg] $msg -} {1 {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}} -test canvas-14.4 {canvas scan} { - destroy .c; canvas .c - list [catch {.c scan mark 10 10} msg] $msg -} {0 {}} -test canvas-14.5 {canvas scan} { - destroy .c; canvas .c - list [catch {.c scan mark 10 10 5} msg] $msg -} {1 {wrong # args: should be ".c scan mark x y"}} -test canvas-14.6 {canvas scan} { - destroy .c; canvas .c - list [catch {.c scan dragto 10 10 5} msg] $msg -} {0 {}} +test canvas-14.1 {canvas scan SF bug 581560} -setup { + destroy .c + canvas .c +} -body { + .c scan +} -returnCodes error -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} +test canvas-14.2 {canvas scan} -setup { + destroy .c + canvas .c +} -body { + .c scan bogus +} -returnCodes error -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} +test canvas-14.3 {canvas scan} -setup { + destroy .c + canvas .c +} -body { + .c scan mark +} -returnCodes error -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} +test canvas-14.4 {canvas scan} -setup { + destroy .c + canvas .c +} -body { + .c scan mark 10 10 +} -result {} +test canvas-14.5 {canvas scan} -setup { + destroy .c + canvas .c +} -body { + .c scan mark 10 10 5 +} -returnCodes error -result {wrong # args: should be ".c scan mark x y"} +test canvas-14.6 {canvas scan} -setup { + destroy .c + canvas .c +} -body { + .c scan dragto 10 10 5 +} -result {} set i 0 proc create {w type args} { @@ -458,26 +487,32 @@ proc create {w type args} { foreach type {arc bitmap image line oval polygon rect text window} { incr i test canvas-15.$i "basic types check: $type requires coords" -setup { - destroy .c; canvas .c + destroy .c + canvas .c } -body { .c create $type } -returnCodes error -result [format {wrong # args: should be ".c create %s coords ?arg arg ...?"} $type] incr i test canvas-15.$i "basic coords check: $type coords are paired" -setup { - destroy .c; canvas .c + destroy .c + canvas .c } -match glob -body { .c create $type 0 } -returnCodes error -result "wrong # coordinates: expected*" } -test canvas-16.1 {arc coords check} { - destroy .c; canvas .c +test canvas-16.1 {arc coords check} -setup { + destroy .c + canvas .c +} -body { set id [.c create arc {0 10 20 30} -start 33] .c itemcget $id -start -} {33.0} +} -result {33.0} -test canvas-17.1 {default smooth method handling} { - destroy .c; canvas .c +test canvas-17.1 {default smooth method handling} -setup { + destroy .c + canvas .c +} -body { set id [.c create line {0 0 1 1 2 2 3 3 4 4 5 5 6 6}] set result [.c itemcget $id -smooth] foreach smoother {yes 1 bezier raw r b} { @@ -485,7 +520,7 @@ test canvas-17.1 {default smooth method handling} { lappend result [.c itemcget $id -smooth] } set result -} {0 true true true raw raw true} +} -result {0 true true true raw raw true} destroy .c diff --git a/tests/cursor.test b/tests/cursor.test index 350ee91..ebe58e1 100644 --- a/tests/cursor.test +++ b/tests/cursor.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: cursor.test,v 1.14 2004/06/24 12:45:42 dkf Exp $ +# RCS: @(#) $Id: cursor.test,v 1.15 2004/12/07 10:07:59 dkf Exp $ package require tcltest 2.1 eval tcltest::configure $argv @@ -209,15 +209,15 @@ foreach {testName cursor} { cursor-6.66 tcross cursor-6.67 top_left_arrow cursor-6.68 top_left_corner - cursor-6.68 top_right_corner - cursor-6.69 top_side - cursor-6.70 top_tee - cursor-6.71 trek - cursor-6.72 ul_angle - cursor-6.73 umbrella - cursor-6.74 ur_angle - cursor-6.75 watch - cursor-6.76 xterm + cursor-6.69 top_right_corner + cursor-6.70 top_side + cursor-6.71 top_tee + cursor-6.72 trek + cursor-6.73 ul_angle + cursor-6.74 umbrella + cursor-6.75 ur_angle + cursor-6.76 watch + cursor-6.77 xterm } { test $testName "check cursor-font cursor $cursor" -setup { button .b -text $cursor @@ -242,7 +242,7 @@ foreach {testName cursor} { cursor-7.8 uparrow cursor-7.9 wait } { - test testName "check Windows cursor $cursor" -constraints win -setup { + test $testName "check Windows cursor $cursor" -constraints win -setup { button .b -text $cursor } -body { .b configure -cursor $cursor diff --git a/tests/scrollbar.test b/tests/scrollbar.test index b85c020..718d970 100644 --- a/tests/scrollbar.test +++ b/tests/scrollbar.test @@ -7,7 +7,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: scrollbar.test,v 1.14 2004/06/24 12:45:43 dkf Exp $ +# RCS: @(#) $Id: scrollbar.test,v 1.15 2004/12/07 10:08:00 dkf Exp $ package require tcltest 2.1 eval tcltest::configure $argv @@ -84,43 +84,45 @@ foreach test { {-troughcolor #432 #432 lousy {unknown color name "lousy"}} {-width 32 32 badValue {bad screen distance "badValue"}} } { - set name [lindex $test 0] - test scrollbar-1.1 {configuration options} { - .s configure $name [lindex $test 1] - lindex [.s configure $name] 4 - } [lindex $test 2] + lassign $test name value okResult badValue badResult + # Assume $name is plain; true of all our in-use options! + test scrollbar-1.$i {configuration options} \ + ".s configure $name [list $value]; .s cget $name" $okResult incr i - if {[lindex $test 3] ne ""} { - test scrollbar-1.2 {configuration options} { - list [catch {.s configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] + if {$badValue ne ""} { + test scrollbar-1.$i {configuration options} \ + -body [list .s configure $name $badValue] \ + -returnCodes error -result $badResult + incr i } .s configure $name [lindex [.s configure $name] 3] - incr i } destroy .s -test scrollbar-2.1 {Tk_ScrollbarCmd procedure} { - list [catch {scrollbar} msg] $msg -} {1 {wrong # args: should be "scrollbar pathName ?options?"}} -test scrollbar-2.2 {Tk_ScrollbarCmd procedure} { - list [catch {scrollbar gorp} msg] $msg -} {1 {bad window path name "gorp"}} -test scrollbar-2.3 {Tk_ScrollbarCmd procedure} { +test scrollbar-2.1 {Tk_ScrollbarCmd procedure} -returnCodes error -body { + scrollbar +} -result {wrong # args: should be "scrollbar pathName ?options?"} +test scrollbar-2.2 {Tk_ScrollbarCmd procedure} -body { + scrollbar gorp +} -returnCodes error -result {bad window path name "gorp"} +test scrollbar-2.3 {Tk_ScrollbarCmd procedure} -setup { scrollbar .s - set x "[winfo class .s] [info command .s]" +} -body { + list [winfo class .s] [info command .s] +} -cleanup { destroy .s - set x -} {Scrollbar .s} +} -result {Scrollbar .s} test scrollbar-2.4 {Tk_ScrollbarCmd procedure} { list [catch {scrollbar .s -gorp blah} msg] $msg [winfo exists .s] \ [info command .s] } {1 {unknown option "-gorp"} 0 {}} -test scrollbar-2.5 {Tk_ScrollbarCmd procedure} { - set x [scrollbar .s] +test scrollbar-2.5 {Tk_ScrollbarCmd procedure} -setup { + catch {destroy .s} +} -body { + scrollbar .s +} -cleanup { destroy .s - set x -} {.s} +} -result .s scrollbar .s -orient vertical -command scroll -highlightthickness 2 -bd 2 pack .s -side right -fill y |