diff options
Diffstat (limited to 'tests')
80 files changed, 5048 insertions, 2416 deletions
diff --git a/tests/arc.tcl b/tests/arc.tcl index 0126c7d..2887047 100644 --- a/tests/arc.tcl +++ b/tests/arc.tcl @@ -52,7 +52,7 @@ set outline black .t.c addtag arc withtag all .t.c addtag circle withtag [.t.c create oval 320 200 340 220 -fill MistyRose3] -.t.c bind arc <Any-Enter> { +.t.c bind arc <Enter> { set prevFill [lindex [.t.c itemconf current -fill] 4] set prevOutline [lindex [.t.c itemconf current -outline] 4] if {($prevFill != "") || ($prevOutline == "")} { @@ -62,9 +62,9 @@ set outline black .t.c itemconf current -outline $outline2 } } -.t.c bind arc <Any-Leave> {.t.c itemconf current -fill $prevFill -outline $prevOutline} +.t.c bind arc <Leave> {.t.c itemconf current -fill $prevFill -outline $prevOutline} -bind .t.c <1> {markarea %x %y} +bind .t.c <Button-1> {markarea %x %y} bind .t.c <B1-Motion> {strokearea %x %y} proc markarea {x y} { @@ -89,11 +89,11 @@ bind .t.c <Control-f> { puts stdout "Overlapping: [.t.c find overl $areaX1 $areaY1 $areaX2 $areaY2]" } -bind .t.c <3> {puts stdout "%x %y"} +bind .t.c <Button-3> {puts stdout "%x %y"} # The code below allows the circle to be move by shift-dragging. -bind .t.c <Shift-1> { +bind .t.c <Shift-Button-1> { set curx %x set cury %y } diff --git a/tests/bell.test b/tests/bell.test index 4f7df97..bbafeac 100644 --- a/tests/bell.test +++ b/tests/bell.test @@ -15,7 +15,7 @@ test bell-1.1 {bell command} -body { } -returnCodes {error} -result {bad option "a": must be -displayof or -nice} test bell-1.2 {bell command} -body { - bell a b + bell a b } -returnCodes {error} -result {bad option "a": must be -displayof or -nice} test bell-1.3 {bell command} -body { diff --git a/tests/bind.test b/tests/bind.test index c6e0a2f..0f91023 100644 --- a/tests/bind.test +++ b/tests/bind.test @@ -297,9 +297,9 @@ test bind-5.1 {Tk_CreateBindingTable procedure} -body { test bind-6.1 {Tk_DeleteBindTable procedure} -body { canvas .t.c - .t.c bind foo <1> {string 1} + .t.c bind foo <Button-1> {string 1} .t.c create rectangle 0 0 100 100 - .t.c bind 1 <2> {string 2} + .t.c bind 1 <Button-2> {string 2} destroy .t.c } -cleanup { destroy .t.c @@ -312,17 +312,17 @@ test bind-7.1 {Tk_CreateBinding procedure: bad binding} -body { } -returnCodes error -result {no event type or button # or keysym} test bind-7.3 {Tk_CreateBinding procedure: append} -body { canvas .t.c - .t.c bind foo <1> "button 1" - .t.c bind foo <1> "+more button 1" - .t.c bind foo <1> + .t.c bind foo <Button-1> "button 1" + .t.c bind foo <Button-1> "+more button 1" + .t.c bind foo <Button-1> } -cleanup { destroy .t.c } -result {button 1 more button 1} test bind-7.4 {Tk_CreateBinding procedure: append to non-existing} -body { canvas .t.c - .t.c bind foo <1> "+button 1" - .t.c bind foo <1> + .t.c bind foo <Button-1> "+button 1" + .t.c bind foo <Button-1> } -cleanup { destroy .t.c } -result {button 1} @@ -356,10 +356,10 @@ test bind-9.3 {Tk_DeleteBinding procedure} -setup { set result {} } -body { frame .t.f -class Test -width 150 -height 100 - foreach i {<1> <Meta-1> <Control-1> <Double-Alt-1>} { + foreach i {<Button-1> <Meta-Button-1> <Control-Button-1> <Double-Alt-Button-1>} { bind .t.f $i "binding for $i" } - foreach i {<Control-1> <Double-Alt-1> <1> <Meta-1>} { + foreach i {<Control-Button-1> <Double-Alt-Button-1> <Button-1> <Meta-Button-1>} { bind .t.f $i {} lappend result [lsort [bind .t.f]] } @@ -393,7 +393,7 @@ test bind-11.1 {Tk_GetAllBindings procedure} -body { } -result {! <<Paste>> <Key-Acircumflex> <Key-Delete> <Key-Linefeed> <Key-Tab> <Key-less> <Key-space> <Meta-Key-a> a \{ ~} test bind-11.2 {Tk_GetAllBindings procedure} -body { frame .t.f - foreach i "<Double-1> <Triple-1> <Meta-Control-a> <Double-Alt-Enter> <1>" { + foreach i "<Double-Button-1> <Triple-Button-1> <Meta-Control-a> <Double-Alt-Enter> <Button-1>" { bind .t.f $i Test } lsort [bind .t.f] @@ -402,7 +402,7 @@ test bind-11.2 {Tk_GetAllBindings procedure} -body { } -result {<Button-1> <Control-Meta-Key-a> <Double-Alt-Enter> <Double-Button-1> <Triple-Button-1>} test bind-11.3 {Tk_GetAllBindings procedure} -body { frame .t.f - foreach i "<Double-Triple-1> abcd a<Leave>b" { + foreach i "<Double-Triple-Button-1> abcd a<Leave>b" { bind .t.f $i Test } lsort [bind .t.f] @@ -417,7 +417,7 @@ test bind-12.1 {Tk_DeleteAllBindings procedure} -body { } -result {} test bind-12.2 {Tk_DeleteAllBindings procedure} -body { frame .t.f -class Test -width 150 -height 100 - foreach i "a b c <Meta-1> <Alt-a> <Control-a>" { + foreach i "a b c <Meta-Button-1> <Alt-a> <Control-a>" { bind .t.f $i x } destroy .t.f @@ -430,23 +430,23 @@ test bind-13.1 {Tk_BindEvent procedure} -setup { update set x {} } -body { - bind Test <KeyPress> {lappend x "%W %K Test KeyPress"} - bind all <KeyPress> {lappend x "%W %K all KeyPress"} + bind Test <Key> {lappend x "%W %K Test Key"} + bind all <Key> {lappend x "%W %K all Key"} bind Test : {lappend x "%W %K Test :"} bind all _ {lappend x "%W %K all _"} bind .t.f : {lappend x "%W %K .t.f :"} - event generate .t.f <Key-colon> - event generate .t.f <Key-plus> - event generate .t.f <Key-underscore> + event generate .t.f <colon> + event generate .t.f <plus> + event generate .t.f <underscore> return $x } -cleanup { destroy .t.f - bind all <KeyPress> {} - bind Test <KeyPress> {} + bind all <Key> {} + bind Test <Key> {} bind all _ {} bind Test : {} -} -result {{.t.f colon .t.f :} {.t.f colon Test :} {.t.f colon all KeyPress} {.t.f plus Test KeyPress} {.t.f plus all KeyPress} {.t.f underscore Test KeyPress} {.t.f underscore all _}} +} -result {{.t.f colon .t.f :} {.t.f colon Test :} {.t.f colon all Key} {.t.f plus Test Key} {.t.f plus all Key} {.t.f underscore Test Key} {.t.f underscore all _}} test bind-13.2 {Tk_BindEvent procedure} -setup { frame .t.f -class Test -width 150 -height 100 @@ -455,16 +455,16 @@ test bind-13.2 {Tk_BindEvent procedure} -setup { update set x {} } -body { - bind Test <KeyPress> {lappend x "%W %K Test press any"; break} - bind all <KeyPress> {continue; lappend x "%W %K all press any"} + bind Test <Key> {lappend x "%W %K Test press any"; break} + bind all <Key> {continue; lappend x "%W %K all press any"} bind .t.f : {lappend x "%W %K .t.f pressed colon"} - event generate .t.f <Key-colon> + event generate .t.f <colon> return $x } -cleanup { destroy .t.f - bind all <KeyPress> {} - bind Test <KeyPress> {} + bind all <Key> {} + bind Test <Key> {} } -result {{.t.f colon .t.f pressed colon} {.t.f colon Test press any}} test bind-13.3 {Tk_BindEvent procedure} -setup { @@ -475,14 +475,14 @@ test bind-13.3 {Tk_BindEvent procedure} -setup { update set x {} } -body { - bind Test <KeyPress> {lappend x "%W %K Test press any"; error Test} + bind Test <Key> {lappend x "%W %K Test press any"; error Test} bind .t.f : {lappend x "%W %K .t.f pressed colon"} - event generate .t.f <Key-colon> + event generate .t.f <colon> update list $x $errorInfo } -cleanup { destroy .t.f - bind Test <KeyPress> {} + bind Test <Key> {} rename bgerror {} } -result {{{.t.f colon .t.f pressed colon} {.t.f colon Test press any}} {Test while executing @@ -491,7 +491,7 @@ test bind-13.3 {Tk_BindEvent procedure} -setup { test bind-13.4 {Tk_BindEvent procedure} -setup { proc foo {} { set x 44 - event generate .t.f <Key-colon> + event generate .t.f <colon> } frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -534,7 +534,7 @@ test bind-13.7 {Tk_BindEvent procedure} -setup { bind .t.f : {lappend x "%W (.t.f binding)"} bind Test : {lappend x "%W (Test binding)"} bind all : {bind .t.f : {}; lappend x "%W (all binding)"} - event generate .t.f <Key-colon> + event generate .t.f <colon> return $x } -cleanup { bind Test : {} @@ -551,7 +551,7 @@ test bind-13.8 {Tk_BindEvent procedure} -setup { bind .t.f : {lappend x "%W (.t.f binding)"} bind Test : {lappend x "%W (Test binding)"} bind all : {destroy .t.f; lappend x "%W (all binding)"} - event generate .t.f <Key-colon> + event generate .t.f <colon> return $x } -cleanup { bind Test : {} @@ -566,14 +566,14 @@ test bind-13.9 {Tk_BindEvent procedure} -setup { update set x {} } -body { - bind .t.f <1> {lappend x "%W z (.t.f <1> binding)"} - bind .t.f <ButtonPress> {lappend x "%W z (.t.f <ButtonPress> binding)"} + bind .t.f <Button-1> {lappend x "%W z (.t.f <Button-1> binding)"} + bind .t.f <Button> {lappend x "%W z (.t.f <Button> binding)"} event generate .t.f <Button-1> event generate .t.f <Button-2> return $x } -cleanup { destroy .t.f -} -result {{.t.f z (.t.f <1> binding)} {.t.f z (.t.f <ButtonPress> binding)}} +} -result {{.t.f z (.t.f <Button-1> binding)} {.t.f z (.t.f <Button> binding)}} test bind-13.10 {Tk_BindEvent procedure: ignore NotifyInferior} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -616,9 +616,9 @@ test bind-13.12 {Tk_BindEvent procedure: collapse repeating modifiers} -setup { } -body { bind .t.f <Key> "lappend x %K%#" bind .t.f <KeyRelease> "lappend x %K%#" - event generate .t.f <Key-Shift_L> -serial 100 -when tail + event generate .t.f <Shift_L> -serial 100 -when tail event generate .t.f <KeyRelease-Shift_L> -serial 101 -when tail - event generate .t.f <Key-Shift_L> -serial 102 -when tail + event generate .t.f <Shift_L> -serial 102 -when tail event generate .t.f <KeyRelease-Shift_L> -serial 103 -when tail update } -cleanup { @@ -936,12 +936,12 @@ test bind-13.33 {Tk_BindEvent procedure: many C bindings cause realloc} -setup { } -body { bindtags .t.f {a b c d e f g h i j k l m n o p} foreach p [bindtags .t.f] { - bind $p <1> "lappend x $p" + bind $p <Button-1> "lappend x $p" } - event generate .t.f <1> + event generate .t.f <Button-1> return $x } -cleanup { - foreach p [bindtags .t.f] {bind $p <1> {}} + foreach p [bindtags .t.f] {bind $p <Button-1> {}} destroy .t.f } -result {a b c d e f g h i j k l m n o p} test bind-13.34 {Tk_BindEvent procedure: multiple tags} -setup { @@ -966,8 +966,8 @@ test bind-13.35 {Tk_BindEvent procedure: execute binding} -setup { update set x {} } -body { - bind .t.f <1> {lappend x 1} - event generate .t.f <1> + bind .t.f <Button-1> {lappend x 1} + event generate .t.f <Button-1> return $x } -cleanup { destroy .t.f @@ -979,13 +979,13 @@ test bind-13.38 {Tk_BindEvent procedure: binding gets to run} -setup { update set x {} } -body { - bind Test <1> {lappend x Test} - bind .t.f <1> {lappend x .t.f} - event generate .t.f <1> + bind Test <Button-1> {lappend x Test} + bind .t.f <Button-1> {lappend x .t.f} + event generate .t.f <Button-1> return $x } -cleanup { destroy .t.f - bind Test <1> {} + bind Test <Button-1> {} } -result {.t.f Test} test bind-13.41 {Tk_BindEvent procedure: continue in script} -setup { frame .t.f -class Test -width 150 -height 100 @@ -1094,7 +1094,7 @@ test bind-15.4 {MatchPatterns procedure, ignoring type mismatches} -setup { focus -force .t.f update } -body { - bind .t.f <Double-1> {set x 1} + bind .t.f <Double-Button-1> {set x 1} set x 0 event generate .t.f <Button-1> event generate .t.f <ButtonRelease-1> @@ -1126,10 +1126,10 @@ test bind-15.6 {MatchPatterns procedure, ignoring type mismatches} -setup { focus -force .t.f update } -body { - bind .t.f <Double-1> {set x 1} + bind .t.f <Double-Button-1> {set x 1} set x 0 event generate .t.f <Button-1> - event generate .t.f <Key-a> + event generate .t.f <a> event generate .t.f <ButtonRelease-1> event generate .t.f <Button-1> event generate .t.f <ButtonRelease-1> @@ -1143,10 +1143,10 @@ test bind-15.7 {MatchPatterns procedure, ignoring type mismatches} -setup { focus -force .t.f update } -body { - bind .t.f <Double-1> {set x 1} + bind .t.f <Double-Button-1> {set x 1} set x 0 event generate .t.f <Button-1> - event generate .t.f <Key-Shift_L> + event generate .t.f <Shift_L> event generate .t.f <ButtonRelease-1> event generate .t.f <Button-1> event generate .t.f <ButtonRelease-1> @@ -1162,9 +1162,9 @@ test bind-15.8 {MatchPatterns procedure, ignoring type mismatches} -setup { } -body { bind .t.f ab {set x 1} set x 0 - event generate .t.f <Key-a> - event generate .t.f <Key-c> - event generate .t.f <Key-b> + event generate .t.f <a> + event generate .t.f <c> + event generate .t.f <b> return $x } -cleanup { destroy .t.f @@ -1177,7 +1177,7 @@ test bind-15.9 {MatchPatterns procedure, modifier checks} -setup { } -body { bind .t.f <M1-M2-Key> {set x 1} set x 0 - event generate .t.f <Key-a> -state 0x18 + event generate .t.f <a> -state 0x18 return $x } -cleanup { destroy .t.f @@ -1190,7 +1190,7 @@ test bind-15.10 {MatchPatterns procedure, modifier checks} -setup { } -body { bind .t.f <M1-M2-Key> {set x 1} set x 0 - event generate .t.f <Key-a> -state 0xfc + event generate .t.f <a> -state 0xfc return $x } -cleanup { destroy .t.f @@ -1203,7 +1203,7 @@ test bind-15.11 {MatchPatterns procedure, modifier checks} -setup { } -body { bind .t.f <M1-M2-Key> {set x 1} set x 0 - event generate .t.f <Key-a> -state 0x8 + event generate .t.f <a> -state 0x8 return $x } -cleanup { destroy .t.f @@ -1220,9 +1220,9 @@ test bind-15.12 {MatchPatterns procedure, ignore modifier presses and releases} # differently on some platforms. bind .t.f aB {set x 1} set x 0 - event generate .t.f <Key-a> - event generate .t.f <Key-Shift_L> - event generate .t.f <Key-b> -state 1 + event generate .t.f <a> + event generate .t.f <Shift_L> + event generate .t.f <b> -state 1 return $x } -cleanup { destroy .t.f @@ -1235,8 +1235,8 @@ test bind-15.13 {MatchPatterns procedure, checking detail} -setup { } -body { bind .t.f ab {set x 1} set x 0 - event generate .t.f <Key-a> - event generate .t.f <Key-c> + event generate .t.f <a> + event generate .t.f <c> return $x } -cleanup { destroy .t.f @@ -1247,7 +1247,7 @@ test bind-15.14 {MatchPatterns procedure, checking "nearby"} -setup { focus -force .t.f update } -body { - bind .t.f <Double-1> {set x 1} + bind .t.f <Double-Button-1> {set x 1} set x 0 event generate .t.f <Button-2> event generate .t.f <ButtonRelease-2> @@ -1264,7 +1264,7 @@ test bind-15.15 {MatchPatterns procedure, checking "nearby"} -setup { focus -force .t.f update } -body { - bind .t.f <Double-1> {set x 1} + bind .t.f <Double-Button-1> {set x 1} set x 0 event generate .t.f <Button-2> event generate .t.f <ButtonRelease-2> @@ -1281,7 +1281,7 @@ test bind-15.16 {MatchPatterns procedure, checking "nearby"} -setup { focus -force .t.f update } -body { - bind .t.f <Double-1> {set x 1} + bind .t.f <Double-Button-1> {set x 1} set x 0 event generate .t.f <Button-2> event generate .t.f <ButtonRelease-2> @@ -1298,7 +1298,7 @@ test bind-15.17 {MatchPatterns procedure, checking "nearby"} -setup { focus -force .t.f update } -body { - bind .t.f <Double-1> {set x 1} + bind .t.f <Double-Button-1> {set x 1} set x 0 event generate .t.f <Button-2> event generate .t.f <ButtonRelease-2> @@ -1315,7 +1315,7 @@ test bind-15.18 {MatchPatterns procedure, checking "nearby"} -setup { focus -force .t.f update } -body { - bind .t.f <Double-1> {set x 1} + bind .t.f <Double-Button-1> {set x 1} set x 0 event generate .t.f <Button-2> event generate .t.f <ButtonRelease-2> @@ -1332,7 +1332,7 @@ test bind-15.19 {MatchPatterns procedure, checking "nearby"} -setup { focus -force .t.f update } -body { - bind .t.f <Double-1> {set x 1} + bind .t.f <Double-Button-1> {set x 1} set x 0 event generate .t.f <Button-2> event generate .t.f <ButtonRelease-2> @@ -1349,7 +1349,7 @@ test bind-15.20 {MatchPatterns procedure, checking "nearby"} -setup { focus -force .t.f update } -body { - bind .t.f <Double-1> {set x 1} + bind .t.f <Double-Button-1> {set x 1} set x 0 event generate .t.f <Button-2> event generate .t.f <ButtonRelease-2> @@ -1366,7 +1366,7 @@ test bind-15.21 {MatchPatterns procedure, checking "nearby"} -setup { focus -force .t.f update } -body { - bind .t.f <Double-1> {set x 1} + bind .t.f <Double-Button-1> {set x 1} set x 0 event generate .t.f <Button-2> event generate .t.f <ButtonRelease-2> @@ -1383,7 +1383,7 @@ test bind-15.22 {MatchPatterns procedure, time wrap-around} -setup { focus -force .t.f update } -body { - bind .t.f <Double-1> {set x 1} + bind .t.f <Double-Button-1> {set x 1} set x 0 event generate .t.f <Button-1> -time -100 event generate .t.f <Button-1> -time 200 @@ -1398,7 +1398,7 @@ test bind-15.23 {MatchPatterns procedure, time wrap-around} -setup { focus -force .t.f update } -body { - bind .t.f <Double-1> {set x 1} + bind .t.f <Double-Button-1> {set x 1} set x 0 event generate .t.f <Button-1> -time -100 event generate .t.f <Button-1> -time 500 @@ -1472,7 +1472,7 @@ test bind-15.27 {MatchPatterns procedure, conflict resolution} -setup { focus -force .t.f update } -body { - bind .t.f <KeyPress> {set x 0} + bind .t.f <Key> {set x 0} bind .t.f 1 {set x 1} set x none event generate .t.f <Key-1> @@ -1486,7 +1486,7 @@ test bind-15.28 {MatchPatterns procedure, conflict resolution} -setup { focus -force .t.f update } -body { - bind .t.f <KeyPress> {set x 0} + bind .t.f <Key> {set x 0} bind .t.f 1 {set x 1} set x none event generate .t.f <Key-2> @@ -1500,7 +1500,7 @@ test bind-15.29 {MatchPatterns procedure, conflict resolution} -setup { focus -force .t.f update } -body { - bind .t.f <KeyPress> {lappend x 0} + bind .t.f <Key> {lappend x 0} bind .t.f 1 {lappend x 1} bind .t.f 21 {lappend x 2} set x none @@ -1517,8 +1517,8 @@ test bind-15.30 {MatchPatterns procedure, conflict resolution} -setup { focus -force .t.f update } -body { - bind .t.f <ButtonPress> {set x 0} - bind .t.f <1> {set x 1} + bind .t.f <Button> {set x 0} + bind .t.f <Button-1> {set x 1} set x none event generate .t.f <Button-1> event generate .t.f <ButtonRelease-1> @@ -1535,7 +1535,7 @@ test bind-15.31 {MatchPatterns procedure, conflict resolution} -setup { } -body { bind .t.f <M1-Key> {set x 0} bind .t.f <M2-Key> {set x 1} - event generate .t.f <Key-a> -state 0x18 + event generate .t.f <a> -state 0x18 return $x } -cleanup { destroy .t.f @@ -1549,7 +1549,7 @@ test bind-15.32 {MatchPatterns procedure, conflict resolution} -setup { bind .t.f <M2-Key> {set x 0} bind .t.f <M1-Key> {set x 1} set x none - event generate .t.f <Key-a> -state 0x18 + event generate .t.f <a> -state 0x18 return $x } -cleanup { destroy .t.f @@ -1561,9 +1561,9 @@ test bind-15.33 {MatchPatterns procedure, conflict resolution} -setup { update set x {} } -body { - bind .t.f <1> {lappend x single} - bind Test <1> {lappend x single(Test)} - bind Test <Double-1> {lappend x double(Test)} + bind .t.f <Button-1> {lappend x single} + bind Test <Button-1> {lappend x single(Test)} + bind Test <Double-Button-1> {lappend x double(Test)} event generate .t.f <Button-1> event generate .t.f <Button-1> event generate .t.f <Button-1> @@ -1571,8 +1571,8 @@ test bind-15.33 {MatchPatterns procedure, conflict resolution} -setup { set x } -cleanup { destroy .t.f - bind Test <1> {} - bind Test <Double-1> {} + bind Test <Button-1> {} + bind Test <Double-Button-1> {} } -result {single single(Test) single double(Test) single double(Test)} @@ -1909,7 +1909,7 @@ test bind-16.26 {ExpandPercents procedure} -setup { focus -force .t.f update } -body { - bind .t.f <1> {set x "%s"} + bind .t.f <Button-1> {set x "%s"} set x none event generate .t.f <Button-1> -state 1402 event generate .t.f <ButtonRelease-1> @@ -2033,18 +2033,18 @@ test bind-16.35 {ExpandPercents procedure} -constraints { set x {} } -body { bind .t.f <Key> {lappend x "%A"} - event generate .t.f <Key-a> - event generate .t.f <Key-A> -state 1 - event generate .t.f <Key-Tab> - event generate .t.f <Key-Return> - event generate .t.f <Key-F1> - event generate .t.f <Key-Shift_L> - event generate .t.f <Key-space> - event generate .t.f <Key-dollar> -state 1 - event generate .t.f <Key-braceleft> -state 1 - event generate .t.f <Key-Multi_key> - event generate .t.f <Key-e> - event generate .t.f <Key-apostrophe> + event generate .t.f <a> + event generate .t.f <A> -state 1 + event generate .t.f <Tab> + event generate .t.f <Return> + event generate .t.f <F1> + event generate .t.f <Shift_L> + event generate .t.f <space> + event generate .t.f <dollar> -state 1 + event generate .t.f <braceleft> -state 1 + event generate .t.f <Multi_key> + event generate .t.f <e> + event generate .t.f <apostrophe> set x } -cleanup { destroy .t.f @@ -2085,14 +2085,14 @@ test bind-16.38 {ExpandPercents procedure} -constraints { set x {} } -body { bind .t.f <Key> {lappend x %K} - event generate .t.f <Key-a> - event generate .t.f <Key-A> -state 1 - event generate .t.f <Key-Tab> - event generate .t.f <Key-F1> - event generate .t.f <Key-Shift_L> - event generate .t.f <Key-space> - event generate .t.f <Key-dollar> -state 1 - event generate .t.f <Key-braceleft> -state 1 + event generate .t.f <a> + event generate .t.f <A> -state 1 + event generate .t.f <Tab> + event generate .t.f <F1> + event generate .t.f <Shift_L> + event generate .t.f <space> + event generate .t.f <dollar> -state 1 + event generate .t.f <braceleft> -state 1 set x } -cleanup { destroy .t.f @@ -2105,7 +2105,7 @@ test bind-16.39 {ExpandPercents procedure} -setup { } -body { bind .t.f <Key> {set x "%N"} set x none - event generate .t.f <Key-space> + event generate .t.f <space> set x } -cleanup { destroy .t.f @@ -2118,7 +2118,7 @@ test bind-16.40 {ExpandPercents procedure} -setup { } -body { bind .t.f <Key> {set x "%S"} set x none - event generate .t.f <Key-space> -subwindow .t + event generate .t.f <space> -subwindow .t set x } -cleanup { destroy .t.f @@ -2191,7 +2191,7 @@ test bind-16.45 {ExpandPercents procedure} -setup { bind Entry <Key> {set y "%M"} bind all <Key> {set z "%M"} set x none; set y none; set z none - event gen .t.e <Key-a> + event gen .t.e <a> list $x $y $z } -cleanup { destroy .t.e @@ -2212,7 +2212,7 @@ test bind-16.46 {ExpandPercents procedure} -setup { bind Entry <Key> {set y "%M"} bind .t.e <Key> {set x "%M"} set x none; set y none; set z none - event gen .t.e <Key-a> + event gen .t.e <a> list $x $y $z } -cleanup { destroy .t.e @@ -2246,13 +2246,13 @@ test bind-17.5 {event command: add 2} -body { } -result {<Button-2> <Control-Key-v>} test bind-17.6 {event command: add with error} -body { - event add <<Paste>> <Control-v> <Button-2> abc <xyz> <1> + event add <<Paste>> <Control-v> <Button-2> abc <xyz> <Button-1> } -cleanup { event delete <<Paste>> } -returnCodes error -result {bad event type or keysym "xyz"} test bind-17.7 {event command: add with error} -body { event delete <<Paste>> - catch {event add <<Paste>> <Control-v> <Button-2> abc <xyz> <1>} + catch {event add <<Paste>> <Control-v> <Button-2> abc <xyz> <Button-1>} lsort [event info <<Paste>>] } -cleanup { event delete <<Paste>> @@ -2263,12 +2263,12 @@ test bind-17.8 {event command: delete} -body { } -returnCodes error -result {wrong # args: should be "event delete virtual ?sequence ...?"} test bind-17.9 {event command: delete many} -body { event delete <<Paste>> - event add <<Paste>> <3> <1> <2> t - event delete <<Paste>> <1> <2> + event add <<Paste>> <Button-3> <Button-1> <Button-2> t + event delete <<Paste>> <Button-1> <Button-2> lsort [event info <<Paste>>] } -cleanup { event delete <<Paste>> - event delete <<Paste>> <3> t + event delete <<Paste>> <Button-3> t } -result {<Button-3> t} test bind-17.10 {event command: delete all} -body { event add <<Paste>> a b @@ -2316,8 +2316,8 @@ test bind-17.16 {event command: generate} -setup { update set x {} } -body { - bind .t.f <1> "lappend x 1" - event generate .t.f <1> + bind .t.f <Button-1> "lappend x 1" + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f @@ -2684,7 +2684,7 @@ test bind-20.2 {GetVirtualEvent procedure: non-existent event} -body { test bind-20.3 {GetVirtualEvent procedure: owns 1} -setup { event delete <<xyz>> } -body { - event add <<xyz>> <Control-Key-v> + event add <<xyz>> <Control-v> event info <<xyz>> } -cleanup { event delete <<xyz>> @@ -2715,7 +2715,7 @@ test bind-21.3 {GetAllVirtualEvents procedure: many events} -body { event add <<xyz>> <Control-v> event add <<xyz>> <Button-2> event add <<abc>> <Control-v> - event add <<def>> <Key-F6> + event add <<def>> <F6> lsort [event info] } -cleanup { event delete <<xyz>> @@ -2784,7 +2784,7 @@ test bind-22.10 {HandleEventGenerate} -setup { set x {} } -body { bind .t.f <Key> {set x "%s %K"} - event generate .t.f <Control-Key-space> + event generate .t.f <Control-space> set x } -cleanup { destroy .t.f @@ -4928,10 +4928,10 @@ test bind-24.5 {FindSequence procedure, multiple bindings} -setup { focus -force .t.f update } -body { - bind .t.f <1> {lappend x single} - bind .t.f <Double-1> {lappend x double} - bind .t.f <Triple-1> {lappend x triple} - bind .t.f <Quadruple-1> {lappend x quadruple} + bind .t.f <Button-1> {lappend x single} + bind .t.f <Double-Button-1> {lappend x double} + bind .t.f <Triple-Button-1> {lappend x triple} + bind .t.f <Quadruple-Button-1> {lappend x quadruple} set x press event generate .t.f <Button-1> event generate .t.f <ButtonRelease-1> @@ -5439,6 +5439,42 @@ test bind-25.49 {modifier names} -setup { destroy .t.f } -result <Extended-Key-Return> +test bind-25.50 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Button6-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B6-Key-a> + +test bind-25.51 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Button7-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B7-Key-a> + +test bind-25.52 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Button8-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B8-Key-a> + +test bind-25.53 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Button9-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B9-Key-a> + test bind-26.1 {event names} -setup { @@ -5772,8 +5808,8 @@ test bind-27.1 {button names} -body { bind .t <Expose-1> foo } -returnCodes error -result {specified button "1" for non-button event} test bind-27.2 {button names} -body { - bind .t <Button-6> foo -} -returnCodes error -result {bad button number "6"} + bind .t <Button-10> foo +} -returnCodes error -result {bad button number "10"} test bind-27.3 {button names} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -5844,6 +5880,62 @@ test bind-27.7 {button names} -setup { } -cleanup { destroy .t.f } -result {<Button-5> {button 5}} +test bind-27.8 {button names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button-6> {lappend x "button 6"} + set x [bind .t.f] + event generate .t.f <Button-6> + event generate .t.f <ButtonRelease-6> + set x +} -cleanup { + destroy .t.f +} -result {<Button-6> {button 6}} +test bind-27.9 {button names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button-7> {lappend x "button 7"} + set x [bind .t.f] + event generate .t.f <Button-7> + event generate .t.f <ButtonRelease-7> + set x +} -cleanup { + destroy .t.f +} -result {<Button-7> {button 7}} +test bind-27.10 {button names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button-8> {lappend x "button 8"} + set x [bind .t.f] + event generate .t.f <Button-8> + event generate .t.f <ButtonRelease-8> + set x +} -cleanup { + destroy .t.f +} -result {<Button-8> {button 8}} +test bind-27.11 {button names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button-9> {lappend x "button 9"} + set x [bind .t.f] + event generate .t.f <Button-9> + event generate .t.f <ButtonRelease-9> + set x +} -cleanup { + destroy .t.f +} -result {<Button-9> {button 9}} test bind-28.1 {keysym names} -body { bind .t <Expose-a> foo @@ -5852,7 +5944,7 @@ test bind-28.2 {keysym names} -body { bind .t <Gorp> foo } -returnCodes error -result {bad event type or keysym "Gorp"} test bind-28.3 {keysym names} -body { - bind .t <Key-Stupid> foo + bind .t <Stupid> foo } -returnCodes error -result {bad event type or keysym "Stupid"} test bind-28.4 {keysym names} -body { frame .t.f -class Test -width 150 -height 100 @@ -5868,10 +5960,10 @@ test bind-28.5 {keysym names} -setup { focus -force .t.f update } -body { - bind .t.f <Key-colon> "lappend x \"keysym received\"" - bind .t.f <Key-underscore> "lappend x {bad binding match}" + bind .t.f <colon> "lappend x \"keysym received\"" + bind .t.f <underscore> "lappend x {bad binding match}" set x [lsort [bind .t.f]] - event generate .t.f <Key-colon> ;# -state 0 + event generate .t.f <colon> ;# -state 0 set x } -cleanup { destroy .t.f @@ -5882,10 +5974,10 @@ test bind-28.6 {keysym names} -setup { focus -force .t.f update } -body { - bind .t.f <Key-Return> "lappend x \"keysym Return\"" - bind .t.f <Key-x> "lappend x {bad binding match}" + bind .t.f <Return> "lappend x \"keysym Return\"" + bind .t.f <x> "lappend x {bad binding match}" set x [lsort [bind .t.f]] - event generate .t.f <Key-Return> -state 0 + event generate .t.f <Return> -state 0 set x } -cleanup { destroy .t.f @@ -5896,10 +5988,10 @@ test bind-28.7 {keysym names} -setup { focus -force .t.f update } -body { - bind .t.f <Key-X> "lappend x \"keysym X\"" - bind .t.f <Key-x> "lappend x {bad binding match}" + bind .t.f <X> "lappend x \"keysym X\"" + bind .t.f <x> "lappend x {bad binding match}" set x [lsort [bind .t.f]] - event generate .t.f <Key-X> -state 1 + event generate .t.f <X> -state 1 set x } -cleanup { destroy .t.f @@ -5910,10 +6002,10 @@ test bind-28.8 {keysym names} -setup { focus -force .t.f update } -body { - bind .t.f <Key-X> "lappend x \"keysym X\"" - bind .t.f <Key-x> "lappend x {bad binding match}" + bind .t.f <X> "lappend x \"keysym X\"" + bind .t.f <x> "lappend x {bad binding match}" set x [lsort [bind .t.f]] - event generate .t.f <Key-X> -state 1 + event generate .t.f <X> -state 1 set x } -cleanup { destroy .t.f @@ -6155,7 +6247,7 @@ test bind-32.2 {detection of double click should not fail} -setup { update set x {} } -body { - event generate .t.f <ButtonPress-1> + event generate .t.f <Button-1> event generate .t.f <ButtonRelease-1> # Simulate a lot of intervening exposure events. The old implementation # that used an event ring overflowed, and the double click was not detected. @@ -6163,7 +6255,7 @@ test bind-32.2 {detection of double click should not fail} -setup { for {set i 0} {$i < 1000} {incr i} { event generate .t.f <Expose> } - event generate .t.f <ButtonPress-1> + event generate .t.f <Button-1> event generate .t.f <ButtonRelease-1> set x } -cleanup { @@ -6175,10 +6267,10 @@ test bind-32.3 {should trigger best match of modifier states} -setup { update set x {} } -body { - bind .t.f <Alt-Control-Key-A> { lappend x "Alt-Control" } - bind .t.f <Shift-Control-Key-A> { lappend x "Shift-Control" } - bind .t.f <Shift-Key-A> { lappend x "Shift" } - event generate .t.f <Alt-Control-Key-A> + bind .t.f <Alt-Control-A> { lappend x "Alt-Control" } + bind .t.f <Shift-Control-A> { lappend x "Shift-Control" } + bind .t.f <Shift-A> { lappend x "Shift" } + event generate .t.f <Alt-Control-A> set x } -cleanup { destroy .t.f @@ -6189,10 +6281,10 @@ test bind-32.4 {should not trigger Double-1} -setup { update set x {} } -body { - bind .t.f <Double-1> { set x "Double" } - event generate .t.f <1> -time current + bind .t.f <Double-Button-1> { set x "Double" } + event generate .t.f <Button-1> -time current after 1000 - event generate .t.f <1> -time current + event generate .t.f <Button-1> -time current set x } -cleanup { destroy .t.f @@ -6203,10 +6295,10 @@ test bind-32.5 {should trigger Quadruple-1} -setup { update set x {} } -body { - bind .t.f <Quadruple-1> { set x "Quadruple" } - bind .t.f <Triple-1> { set x "Triple" } - bind .t.f <Double-1> { set x "Double" } - bind .t.f <1> { set x "Single" } + bind .t.f <Quadruple-Button-1> { set x "Quadruple" } + bind .t.f <Triple-Button-1> { set x "Triple" } + bind .t.f <Double-Button-1> { set x "Double" } + bind .t.f <Button-1> { set x "Single" } # Old implementation triggered "Double", but new implementation # triggers "Quadruple", the latter behavior conforms to other toolkits. event generate .t.f <Button-1> -time 0 @@ -6236,10 +6328,10 @@ test bind-32.7 {test sequences} -setup { update set x {} } -body { - bind .t.f <Double-1> { lappend x "Double" } - bind .t.f <1><1><a> { lappend x "11" } - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Double-Button-1> { lappend x "Double" } + bind .t.f <Button-1><Button-1><a> { lappend x "11" } + event generate .t.f <Button-1> + event generate .t.f <Button-1> event generate .t.f <a> set x } -cleanup { @@ -6251,12 +6343,12 @@ test bind-32.8 {test sequences} -setup { update set x {} } -body { - bind .t.f <a><1><Double-1><1><a> { lappend x "Double" } + bind .t.f <a><Button-1><Double-Button-1><Button-1><a> { lappend x "Double" } event generate .t.f <a> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> event generate .t.f <a> set x } -cleanup { @@ -6268,8 +6360,8 @@ test bind-32.9 {trigger events for modifier keys} -setup { update set x {} } -body { - bind .t.f <Any-Key> { set x "Key" } - event generate .t.f <KeyPress> -keysym Caps_Lock + bind .t.f <Key> { set x "Key" } + event generate .t.f <Key> -keysym Caps_Lock set x } -cleanup { destroy .t.f @@ -6278,14 +6370,14 @@ test bind-32.10 {reset key state when destroying window} -setup { set x {} } -body { pack [frame .t.f]; update; focus -force .t.f - bind .t.f <Key-A> { set x "A" } - event generate .t.f <KeyPress-A> - event generate .t.f <KeyPress-A> + bind .t.f <A> { set x "A" } + event generate .t.f <A> + event generate .t.f <A> destroy .t.f; update pack [frame .t.f]; update; focus -force .t.f - bind .t.f <Key-A> { set x "A" } - bind .t.f <Double-Key-A> { set x "AA" } - event generate .t.f <KeyPress-A> + bind .t.f <A> { set x "A" } + bind .t.f <Double-A> { set x "AA" } + event generate .t.f <A> destroy .t.f set x } -result {A} @@ -6299,7 +6391,7 @@ test bind-32.11 {match detailed virtual} -setup { bind Test <<TestControlButton1>> { set x "Control-Button-1" } bind Test <Button-1> { set x "Button-1" } bind .t.f <Button-1> { set x "Button-1" } - event generate .t.f <Control-ButtonPress-1> + event generate .t.f <Control-Button-1> set x } -cleanup { destroy .t.f @@ -6315,9 +6407,9 @@ test bind-32.12 {don't detect repetition when window has changed} -setup { } -body { bind .t.f <Button-1> { set x "1" } bind .t.f <Double-Button-1> { set x "11" } - event generate .t.f <ButtonPress-1> - event generate .t.g <ButtonPress-1> - event generate .t.f <ButtonPress-1> + event generate .t.f <Button-1> + event generate .t.g <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f @@ -6329,11 +6421,11 @@ test bind-32.13 {don't detect repetition when window has changed} -setup { update set x {} } -body { - bind .t.f <Key-A> { set x "A" } - bind .t.f <Double-Key-A> { set x "AA" } - focus -force .t.f; event generate .t.f <KeyPress-A> - focus -force .t.g; event generate .t.g <KeyPress-A> - focus -force .t.f; event generate .t.f <KeyPress-A> + bind .t.f <A> { set x "A" } + bind .t.f <Double-A> { set x "AA" } + focus -force .t.f; event generate .t.f <A> + focus -force .t.g; event generate .t.g <A> + focus -force .t.f; event generate .t.f <A> set x } -cleanup { destroy .t.f @@ -6345,11 +6437,11 @@ test bind-32.14 {don't detect repetition when window has changed} -setup { update set x {} } -body { - bind .t.f <ButtonPress-1> { set x "1" } - bind .t.f <Double-ButtonPress-1> { set x "11" } - focus -force .t.f; event generate .t.f <ButtonPress-1> - focus -force .t.g; event generate .t.g <ButtonPress-1> - focus -force .t.f; event generate .t.f <ButtonPress-1> + bind .t.f <Button-1> { set x "1" } + bind .t.f <Double-Button-1> { set x "11" } + focus -force .t.f; event generate .t.f <Button-1> + focus -force .t.g; event generate .t.g <Button-1> + focus -force .t.f; event generate .t.f <Button-1> set x } -cleanup { destroy .t.f @@ -6359,14 +6451,14 @@ test bind-32.15 {reset button state when destroying window} -setup { set x {} } -body { pack [frame .t.f]; update; focus -force .t.f - bind .t.f <ButtonPress-1> { set x "1" } - event generate .t.f <ButtonPress-1> - event generate .t.f <ButtonPress-1> + bind .t.f <Button-1> { set x "1" } + event generate .t.f <Button-1> + event generate .t.f <Button-1> destroy .t.f; update pack [frame .t.f]; update; focus -force .t.f - bind .t.f <ButtonPress-1> { set x "1" } - bind .t.f <Double-ButtonPress-1> { set x "11" } - event generate .t.f <ButtonPress-1> + bind .t.f <Button-1> { set x "1" } + bind .t.f <Double-Button-1> { set x "11" } + event generate .t.f <Button-1> destroy .t.f set x } -result {1} @@ -6377,63 +6469,55 @@ test bind-33.1 {prefer longest match} -setup { update set x {} } -body { - bind .t.f <a><1><1> { lappend x "a11" } - bind .t.f <Double-1> { lappend x "Double" } + bind .t.f <a><Button-1><Button-1> { lappend x "a11" } + bind .t.f <Double-Button-1> { lappend x "Double" } event generate .t.f <a> - event generate .t.f <1> - event generate .t.f <1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f } -result {a11} -test bind-33.2 {should prefer most specific event} -setup { +test bind-33.2 {prefer most specific event} -setup { pack [frame .t.f] focus -force .t.f update set x {} } -body { - bind .t.f <Double-1> { lappend x "Double" } - bind .t.f <1><1> { lappend x "11" } - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Double-Button-1> { lappend x "Double" } + bind .t.f <Button-1><Button-1> { lappend x "11" } + event generate .t.f <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f - # This test case shows that old implementation has an issue, because - # it is expected that <Double-1> is matching, this binding - # is more specific. But new implementation will be conform to old, - # and so "11" is the expected result. -} -result {11} -test bind-33.3 {should prefer most specific event} -setup { +} -result {Double} +test bind-33.3 {prefer most specific event} -setup { pack [frame .t.f] focus -force .t.f update set x {} } -body { - bind .t.f <a><Double-1><a> { lappend x "Double" } - bind .t.f <a><1><1><a> { lappend x "11" } + bind .t.f <a><Double-Button-1><a> { lappend x "Double" } + bind .t.f <a><Button-1><Button-1><a> { lappend x "11" } event generate .t.f <a> - event generate .t.f <1> - event generate .t.f <1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> event generate .t.f <a> set x } -cleanup { destroy .t.f - # Also this test case shows that old implementation has an issue, it is - # expected that <a><Double-1><a> is matching, because <Double-1> is more - # specific than <1><1>. But new implementation will be conform to old, - # and so "11" is the expected result. -} -result {11} +} -result {Double} test bind-33.4 {prefer most specific event} -setup { pack [frame .t.f] focus -force .t.f update set x {} } -body { - bind .t.f <1><1> { lappend x "11" } - bind .t.f <Double-1> { lappend x "Double" } - event generate .t.f <1> -time 0 - event generate .t.f <1> -time 1000 + bind .t.f <Button-1><Button-1> { lappend x "11" } + bind .t.f <Double-Button-1> { lappend x "Double" } + event generate .t.f <Button-1> -time 0 + event generate .t.f <Button-1> -time 1000 set x } -cleanup { destroy .t.f @@ -6444,10 +6528,10 @@ test bind-33.5 {prefer most specific event} -setup { update set x {} } -body { - bind .t.f <1><1> { lappend x "11" } - bind .t.f <Double-ButtonPress> { lappend x "Double" } - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Button-1><Button-1> { lappend x "11" } + bind .t.f <Double-Button> { lappend x "Double" } + event generate .t.f <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f @@ -6458,13 +6542,13 @@ test bind-33.6 {prefer most specific event} -setup { update set x {} } -body { - bind .t.f <a><1><1><1><1><a> { lappend x "1111" } - bind .t.f <a><ButtonPress><Double-ButtonPress><ButtonPress><a> { lappend x "Any-Double-Any" } + bind .t.f <a><Button-1><Button-1><Button-1><Button-1><a> { lappend x "1111" } + bind .t.f <a><Button><Double-Button><Button><a> { lappend x "Any-Double-Any" } event generate .t.f <a> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> event generate .t.f <a> set x } -cleanup { @@ -6476,9 +6560,9 @@ test bind-33.7 {prefer most specific event} -setup { update set x {} } -body { - bind .t.f <ButtonPress-1><a> { lappend x "1" } - bind .t.f <ButtonPress><a> { lappend x "Any" } - event generate .t.f <1> + bind .t.f <Button-1><a> { lappend x "1" } + bind .t.f <Button><a> { lappend x "Any" } + event generate .t.f <Button-1> event generate .t.f <a> set x } -cleanup { @@ -6490,10 +6574,10 @@ test bind-33.8 {prefer most specific event} -setup { update set x {} } -body { - bind .t.f <Double-ButtonPress-1><a> { lappend x "1" } - bind .t.f <ButtonPress><ButtonPress><a> { lappend x "Any" } - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Double-Button-1><a> { lappend x "1" } + bind .t.f <Button><Button><a> { lappend x "Any" } + event generate .t.f <Button-1> + event generate .t.f <Button-1> event generate .t.f <a> set x } -cleanup { @@ -6505,13 +6589,13 @@ test bind-33.9 {prefer last in case of homogeneous equal patterns} -setup { update set x {} } -body { - bind .t.f <1><2><2><Double-1> { lappend x "first" } - bind .t.f <1><Double-2><1><1> { lappend x "last" } - event generate .t.f <1> - event generate .t.f <2> - event generate .t.f <2> - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Button-1><Button-2><Button-2><Double-Button-1> { lappend x "first" } + bind .t.f <Button-1><Double-Button-2><Button-1><Button-1> { lappend x "last" } + event generate .t.f <Button-1> + event generate .t.f <Button-2> + event generate .t.f <Button-2> + event generate .t.f <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f @@ -6522,13 +6606,13 @@ test bind-33.10 {prefer last in case of homogeneous equal patterns} -setup { update set x {} } -body { - bind .t.f <1><Double-2><1><1> { lappend x "first" } - bind .t.f <1><2><2><Double-1> { lappend x "last" } - event generate .t.f <1> - event generate .t.f <2> - event generate .t.f <2> - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Button-1><Double-Button-2><Button-1><Button-1> { lappend x "first" } + bind .t.f <Button-1><Button-2><Button-2><Double-Button-1> { lappend x "last" } + event generate .t.f <Button-1> + event generate .t.f <Button-2> + event generate .t.f <Button-2> + event generate .t.f <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f @@ -6539,35 +6623,31 @@ test bind-33.11 {should prefer most specific} -setup { update set x {} } -body { - bind .t.f <2><Double-1><Double-2><Double-1><2><2> { lappend x "first" } - bind .t.f <2><1><1><2><2><Double-1><Double-2> { lappend x "last" } - event generate .t.f <2> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <2> - event generate .t.f <2> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <2> - event generate .t.f <2> + bind .t.f <Button-2><Double-Button-1><Double-Button-2><Double-Button-1><Button-2><Button-2> { lappend x "first" } + bind .t.f <Button-2><Button-1><Button-1><Button-2><Button-2><Double-Button-1><Double-Button-2> { lappend x "last" } + event generate .t.f <Button-2> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-2> + event generate .t.f <Button-2> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-2> + event generate .t.f <Button-2> set x } -cleanup { destroy .t.f - # This test case shows that old implementation has an issue, because - # it is expected that first one is matching, this binding - # is more specific. But new implementation will be conform to old, - # and so "last" is the expected result. -} -result {last} +} -result {first} test bind-33.12 {prefer last in case of homogeneous equal patterns} -setup { pack [frame .t.f] focus -force .t.f update set x {} } -body { - bind .t.f <Control-1><1> { lappend x "first" } - bind .t.f <1><Control-1> { lappend x "last" } - event generate .t.f <Control-1> - event generate .t.f <Control-1> + bind .t.f <Control-Button-1><Button-1> { lappend x "first" } + bind .t.f <Button-1><Control-Button-1> { lappend x "last" } + event generate .t.f <Control-Button-1> + event generate .t.f <Control-Button-1> set x } -cleanup { destroy .t.f @@ -6578,10 +6658,10 @@ test bind-33.13 {prefer last in case of homogeneous equal patterns} -setup { update set x {} } -body { - bind .t.f <1><Control-1> { lappend x "first" } - bind .t.f <Control-1><1> { lappend x "last" } - event generate .t.f <Control-1> - event generate .t.f <Control-1> + bind .t.f <Button-1><Control-1> { lappend x "first" } + bind .t.f <Control-1><Button-1> { lappend x "last" } + event generate .t.f <Control-Button-1> + event generate .t.f <Control-Button-1> set x } -cleanup { destroy .t.f @@ -6595,12 +6675,12 @@ test bind-33.14 {prefer last in case of homogeneous equal patterns} -setup { update set x {} } -body { - bind .t.f <1><ButtonPress><1><ButtonPress> { lappend x "first" } - bind .t.f <ButtonPress><1><ButtonPress><1> { lappend x "last" } - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Button-1><Button><Button-1><Button> { lappend x "first" } + bind .t.f <Button><Button-1><Button><Button-1> { lappend x "last" } + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f @@ -6611,12 +6691,12 @@ test bind-33.15 {prefer last in case of homogeneous equal patterns} -setup { update set x {} } -body { - bind .t.f <ButtonPress><1><ButtonPress><1> { lappend x "first" } - bind .t.f <1><ButtonPress><1><ButtonPress> { lappend x "last" } - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Button><Button-1><Button><Button-1> { lappend x "first" } + bind .t.f <Button-1><Button><Button-1><Button> { lappend x "last" } + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f diff --git a/tests/bitmap.test b/tests/bitmap.test index fea675d..6996f88 100644 --- a/tests/bitmap.test +++ b/tests/bitmap.test @@ -15,7 +15,7 @@ test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} -constraints testbitmap } -body { set x gray25 - lindex $x 0 + lindex $x 0 button .b -bitmap $x lindex $x 0 testbitmap gray25 @@ -54,12 +54,12 @@ test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} -constraints { test bitmap-2.1 {Tk_GetBitmap procedure} -body { button .b1 -bitmap bad_name } -cleanup { - destroy .b1 + destroy .b1 } -returnCodes error -result {bitmap "bad_name" not defined} test bitmap-2.2 {Tk_GetBitmap procedure} -body { button .b1 -bitmap @xyzzy } -cleanup { - destroy .b1 + destroy .b1 } -returnCodes error -result {error reading bitmap file "xyzzy"} test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} -constraints { diff --git a/tests/border.test b/tests/border.test index f610ad8..d6ff5c7 100644 --- a/tests/border.test +++ b/tests/border.test @@ -10,8 +10,8 @@ namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} -constraints { - testborder +test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} -constraints { + testborder } -body { set x orange lindex $x 0 @@ -21,8 +21,8 @@ test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} -constraints } -cleanup { destroy .b1 } -result {{1 0}} -test border-1.2 {Tk_AllocBorderFromObj - discard stale border} -constraints { - testborder +test border-1.2 {Tk_AllocBorderFromObj - discard stale border} -constraints { + testborder } -setup { set result {} } -body { @@ -35,8 +35,8 @@ test border-1.2 {Tk_AllocBorderFromObj - discard stale border} -constraints { } -cleanup { destroy .b1 .b2 } -result {{} {{1 1}}} -test border-1.3 {Tk_AllocBorderFromObj - reuse existing border} -constraints { - testborder +test border-1.3 {Tk_AllocBorderFromObj - reuse existing border} -constraints { + testborder } -setup { set result {} } -body { @@ -49,7 +49,7 @@ test border-1.3 {Tk_AllocBorderFromObj - reuse existing border} -constraints { } -cleanup { destroy .b1 .b2 } -result {{{1 1}} {{2 1}}} -test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} -constraints { +test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} -constraints { testborder pseudocolor8 } -setup { toplevel .t -visual {pseudocolor 8} -colormap new @@ -70,7 +70,7 @@ test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} -constraints destroy .b1 .b2 .t } -result {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}} -test border-2.1 {Tk_Free3DBorder - reference counts} -constraints { +test border-2.1 {Tk_Free3DBorder - reference counts} -constraints { testborder pseudocolor8 } -setup { toplevel .t -visual {pseudocolor 8} -colormap new @@ -94,7 +94,7 @@ test border-2.1 {Tk_Free3DBorder - reference counts} -constraints { } -cleanup { destroy .b1 .b2 .t } -result {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}} -test border-2.2 {Tk_Free3DBorder - unlinking from list} -constraints { +test border-2.2 {Tk_Free3DBorder - unlinking from list} -constraints { testborder pseudocolor8 } -setup { toplevel .t -visual {pseudocolor 8} -colormap new @@ -127,8 +127,9 @@ test border-2.2 {Tk_Free3DBorder - unlinking from list} -constraints { destroy .b .t2 .t3 .t } -result {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}} -test border-3.1 {FreeBorderObjProc} -constraints { - testborder + +test border-3.1 {FreeBorderObjProc} -constraints { + testborder } -setup { set result {} proc copy {s} {return [string index $s 0][string range $s 1 end]} diff --git a/tests/busy.test b/tests/busy.test index cdce30e..001bb6c 100644 --- a/tests/busy.test +++ b/tests/busy.test @@ -23,53 +23,59 @@ test busy-2.1 {tk busy hold} -returnCodes error -body { tk busy hold } -result {wrong # args: should be "tk busy hold window ?option value ...?"} test busy-2.2 {tk busy hold root window} -body { - tk busy hold . + set res [tk busy hold .] update + set res } -cleanup { tk busy forget . -} -result {} +} -result {._Busy} test busy-2.3 {tk busy hold root window with shortcut} -body { - tk busy . + set res [tk busy .] update + set res } -cleanup { tk busy forget . -} -result {} +} -result {._Busy} test busy-2.4 {tk busy hold nested window} -setup { pack [frame .f] } -body { - tk busy hold .f + set res [tk busy hold .f] update + set res } -cleanup { tk busy forget .f destroy .f -} -result {} +} -result {.f_Busy} test busy-2.5 {tk busy hold nested window with shortcut} -setup { pack [frame .f] } -body { - tk busy .f + set res [tk busy .f] update + set res } -cleanup { tk busy forget .f destroy .f -} -result {} +} -result {.f_Busy} test busy-2.6 {tk busy hold toplevel window} -setup { toplevel .f } -body { - tk busy hold .f + set res [tk busy hold .f] update + set res } -cleanup { tk busy forget .f destroy .f -} -result {} +} -result {.f._Busy} test busy-2.7 {tk busy hold toplevel window with shortcut} -setup { toplevel .f } -body { - tk busy .f + set res [tk busy .f] update + set res } -cleanup { tk busy forget .f destroy .f -} -result {} +} -result {.f._Busy} test busy-2.8 {tk busy hold non existing window} -body { tk busy hold .f update @@ -79,17 +85,19 @@ test busy-2.9 {tk busy hold (shortcut) non existing window} -body { update } -returnCodes {error} -result {bad window path name ".f"} test busy-2.10 {tk busy hold root window with cursor} -body { - tk busy hold . -cursor arrow + set res [tk busy hold . -cursor arrow] update + set res } -cleanup { tk busy forget . -} -result {} +} -result {._Busy} test busy-2.11 {tk busy hold (shortcut) root window, cursor} -body { - tk busy . -cursor arrow + set res [tk busy . -cursor arrow] update + set res } -cleanup { tk busy forget . -} -result {} +} -result {._Busy} test busy-2.12 {tk busy hold root window, invalid cursor} -body { tk busy hold . -cursor nonExistingCursor update @@ -473,5 +481,29 @@ test busy-7.9 {tk busy current 2 busy with non matching filter after forget} -se destroy .f1 .f2 } -result {} +test busy-8.1 {tk busy busywindow with a busy toplevel} -body { + toplevel .top + tk busy .top + tk busy busywindow .top +} -cleanup { + tk busy forget .top + destroy .top +} -result {.top._Busy} +test busy-8.2 {tk busy busywindow with a busy widget} -body { + pack [frame .f] + tk busy .f + tk busy busywindow .f +} -cleanup { + tk busy forget .f + destroy .f +} -result {.f_Busy} +test busy-8.3 {tk busy busywindow with a nonexisting widget} -body { + tk busy . + tk busy busywindow .nonExistingWidget +} -cleanup { + tk busy forget . +} -result {} + + ::tcltest::cleanupTests return diff --git a/tests/button.test b/tests/button.test index e5cb1b9..f3292b31 100644 --- a/tests/button.test +++ b/tests/button.test @@ -562,7 +562,7 @@ test button-1.57 {configuration option: "borderwidth" for label} -setup { update } -body { .l configure -borderwidth 1.3 - .l cget -borderwidth + .l cget -borderwidth } -cleanup { destroy .l } -result {1.3} @@ -581,7 +581,7 @@ test button-1.59 {configuration option: "borderwidth" for button} -setup { update } -body { .b configure -borderwidth 1.3 - .b cget -borderwidth + .b cget -borderwidth } -cleanup { destroy .b } -result {1.3} @@ -600,7 +600,7 @@ test button-1.61 {configuration option: "borderwidth" for checkbutton} -setup { update } -body { .c configure -borderwidth 1.3 - .c cget -borderwidth + .c cget -borderwidth } -cleanup { destroy .c } -result {1.3} @@ -619,7 +619,7 @@ test button-1.63 {configuration option: "borderwidth" for radiobutton} -setup { update } -body { .r configure -borderwidth 1.3 - .r cget -borderwidth + .r cget -borderwidth } -cleanup { destroy .r } -result {1.3} @@ -1003,7 +1003,7 @@ test button-1.102 {configuration option: "fg" for radiobutton} -setup { } -returnCodes {error} -result {unknown color name "non-existent"} test button-1.103 {configuration option: "font" for label} -setup { - label .l -borderwidth 2 -highlightthickness 2 + label .l -borderwidth 2 -highlightthickness 2 pack .l update } -body { @@ -1013,7 +1013,7 @@ test button-1.103 {configuration option: "font" for label} -setup { destroy .l } -result {Helvetica -12} test button-1.104 {configuration option: "activebackground" for label} -setup { - label .l -borderwidth 2 -highlightthickness 2 + label .l -borderwidth 2 -highlightthickness 2 pack .l update } -body { @@ -1022,7 +1022,7 @@ test button-1.104 {configuration option: "activebackground" for label} -setup { destroy .l } -returnCodes {error} -result {font "" doesn't exist} test button-1.105 {configuration option: "font" for button} -setup { - button .b -borderwidth 2 -highlightthickness 2 + button .b -borderwidth 2 -highlightthickness 2 pack .b update } -body { @@ -1032,7 +1032,7 @@ test button-1.105 {configuration option: "font" for button} -setup { destroy .b } -result {Helvetica -12} test button-1.106 {configuration option: "activebackground" for button} -setup { - button .b -borderwidth 2 -highlightthickness 2 + button .b -borderwidth 2 -highlightthickness 2 pack .b update } -body { @@ -1041,7 +1041,7 @@ test button-1.106 {configuration option: "activebackground" for button} -setup { destroy .b } -returnCodes {error} -result {font "" doesn't exist} test button-1.107 {configuration option: "font" for checkbutton} -setup { - checkbutton .c -borderwidth 2 -highlightthickness 2 + checkbutton .c -borderwidth 2 -highlightthickness 2 pack .c update } -body { @@ -1051,7 +1051,7 @@ test button-1.107 {configuration option: "font" for checkbutton} -setup { destroy .c } -result {Helvetica -12} test button-1.108 {configuration option: "activebackground" for checkbutton} -setup { - checkbutton .c -borderwidth 2 -highlightthickness 2 + checkbutton .c -borderwidth 2 -highlightthickness 2 pack .c update } -body { @@ -1060,7 +1060,7 @@ test button-1.108 {configuration option: "activebackground" for checkbutton} -se destroy .c } -returnCodes {error} -result {font "" doesn't exist} test button-1.109 {configuration option: "font" for radiobutton} -setup { - radiobutton .r -borderwidth 2 -highlightthickness 2 + radiobutton .r -borderwidth 2 -highlightthickness 2 pack .r update } -body { @@ -1070,7 +1070,7 @@ test button-1.109 {configuration option: "font" for radiobutton} -setup { destroy .r } -result {Helvetica -12} test button-1.110 {configuration option: "activebackground" for radiobutton} -setup { - radiobutton .r -borderwidth 2 -highlightthickness 2 + radiobutton .r -borderwidth 2 -highlightthickness 2 pack .r update } -body { @@ -2669,7 +2669,7 @@ test button-1.270 {configuration options} -body { } -result {} # ex-tests 3.* -test button-2.1 {ButtonCreate - not enough arguments} -body { +test button-2.1 {ButtonCreate - not enough arguments} -body { button } -returnCodes {error} -result {wrong # args: should be "button pathName ?-option value ...?"} @@ -2709,16 +2709,16 @@ test button-2.6 {ButtonCreate - setting class} -body { test button-2.7 {ButtonCreate - bad window name} -body { button foo } -cleanup { - destroy foo + destroy foo } -returnCodes {error} -result {bad window path name "foo"} -######### test ex 3.8 -test button-2.8 {ButtonCreate procedure - error in default option value} -body { +######### test ex 3.8 +test button-2.8 {ButtonCreate procedure - error in default option value} -body { option add *funny.background bogus button .funny } -cleanup { option clear destroy .funny -} -returnCodes {error} -result {unknown color name "bogus"} +} -returnCodes {error} -result {unknown color name "bogus"} test button-2.9 {ButtonCreate procedure - error in default option value} -body { option add *funny.background bogus catch {button .funny} @@ -2731,13 +2731,13 @@ test button-2.9 {ButtonCreate procedure - error in default option value} -body { invoked from within "button .funny"} -test button-2.10 {ButtonCreate procedure - option error} -body { +test button-2.10 {ButtonCreate procedure - option error} -body { button .x -gorp foo } -cleanup { destroy .x -} -returnCodes {error} -result {unknown option "-gorp"} +} -returnCodes {error} -result {unknown option "-gorp"} test button-2.11 {ButtonCreate procedure - option error} -body { - catch {button .x -gorp foo} + catch {button .x -gorp foo} winfo exists .x } -cleanup { destroy .x @@ -2788,13 +2788,13 @@ test button-3.6 {ButtonWidgetCmd procedure, "cget" option} -body { .l cget -disabledforeground } -cleanup { destroy .l -} -returnCodes {ok} -match {glob} -result {*} +} -returnCodes {ok} -match {glob} -result {*} test button-3.7 {ButtonWidgetCmd procedure, "cget" option} -body { button .b .b cget -disabledforeground } -cleanup { destroy .b -} -returnCodes {ok} -match {glob} -result {*} +} -returnCodes {ok} -match {glob} -result {*} test button-3.8 {ButtonWidgetCmd procedure, "cget" option} -body { button .b .b cget -variable @@ -2807,7 +2807,7 @@ test button-3.9 {ButtonWidgetCmd procedure, "cget" option} -body { .c cget -variable } -cleanup { destroy .c -} -returnCodes {ok} -match {glob} -result {*} +} -returnCodes {ok} -match {glob} -result {*} test button-3.10 {ButtonWidgetCmd procedure, "cget" option} -body { checkbutton .c .c cget -value @@ -2820,7 +2820,7 @@ test button-3.11 {ButtonWidgetCmd procedure, "cget" option} -body { .r cget -value } -cleanup { destroy .r -} -returnCodes {ok} -match {glob} -result {*} +} -returnCodes {ok} -match {glob} -result {*} test button-3.12 {ButtonWidgetCmd procedure, "cget" option} -body { radiobutton .r .r cget -onvalue @@ -2840,7 +2840,7 @@ test button-3.14 {ButtonWidgetCmd procedure, "configure" option} -body { llength [.c configure] } -cleanup { destroy .c -} -result {41} +} -result {41} test button-3.15 {ButtonWidgetCmd procedure, "configure" option} -body { button .b .b configure -gorp @@ -2889,7 +2889,7 @@ test button-3.21 {ButtonWidgetCmd procedure, "deselect" option} -body { return $checkvar } -cleanup { destroy .c -} -result {0} +} -result {0} test button-3.22 {ButtonWidgetCmd procedure, "deselect" option} -body { radiobutton .r -variable radiovar -value red set radiovar green @@ -2897,7 +2897,7 @@ test button-3.22 {ButtonWidgetCmd procedure, "deselect" option} -body { return $radiovar } -cleanup { destroy .r -} -result {green} +} -result {green} test button-3.23 {ButtonWidgetCmd procedure, "deselect" option} -body { radiobutton .r -variable radiovar -value red set radiovar red @@ -2905,9 +2905,9 @@ test button-3.23 {ButtonWidgetCmd procedure, "deselect" option} -body { return $radiovar } -cleanup { destroy .r -} -result {} +} -result {} -test button-3.24 {ButtonWidgetCmd procedure, "deselect" option} -body { +test button-3.24 {ButtonWidgetCmd procedure, "deselect" option} -body { checkbutton .c -variable checkvar -onvalue 1 -offvalue 0 set checkvar 1 trace variable checkvar w bogusTrace @@ -2915,7 +2915,7 @@ test button-3.24 {ButtonWidgetCmd procedure, "deselect" option} -body { } -cleanup { destroy .c trace vdelete checkvar w bogusTrace -} -returnCodes {error} -result {can't set "checkvar": trace aborted} +} -returnCodes {error} -result {can't set "checkvar": trace aborted} test button-3.25 {ButtonWidgetCmd procedure, "deselect" option} -body { checkbutton .c -variable checkvar -onvalue 1 -offvalue 0 set checkvar 1 @@ -2937,7 +2937,7 @@ test button-3.26 {ButtonWidgetCmd procedure, "deselect" option} -body { } -cleanup { destroy .r trace vdelete radiovar w bogusTrace -} -match {glob} -returnCodes {error} -result {can't set "radiovar": trace aborted} +} -match {glob} -returnCodes {error} -result {can't set "radiovar": trace aborted} test button-3.27 {ButtonWidgetCmd procedure, "deselect" option} -body { radiobutton .r -variable radiovar -value red set radiovar red @@ -2964,19 +2964,19 @@ test button-3.29 {ButtonWidgetCmd procedure, "flash" option} -body { } -cleanup { destroy .l } -returnCodes {error} -result {bad option "flash": must be cget or configure} -test button-3.30 {ButtonWidgetCmd procedure, "flash" option} -body { +test button-3.30 {ButtonWidgetCmd procedure, "flash" option} -body { button .b catch {.b flash} } -cleanup { destroy .b } -returnCodes {ok} -match {glob} -result {*} -test button-3.31 {ButtonWidgetCmd procedure, "flash" option} -body { +test button-3.31 {ButtonWidgetCmd procedure, "flash" option} -body { checkbutton .c catch {.c flash} } -cleanup { destroy .c } -returnCodes {ok} -match {glob} -result {*} -test button-3.32 {ButtonWidgetCmd procedure, "flash" option} -body { +test button-3.32 {ButtonWidgetCmd procedure, "flash" option} -body { radiobutton .r catch {.r f} } -cleanup { @@ -3060,14 +3060,14 @@ test button-3.42 {ButtonWidgetCmd procedure, "select" option} -body { destroy .c } -result {lovely} test button-3.43 {ButtonWidgetCmd procedure, "select" option} -body { - radiobutton .r -variable radiovar -value red + radiobutton .r -variable radiovar -value red set radiovar green .r select return $radiovar } -cleanup { destroy .r } -result {red} -test button-3.44 {ButtonWidgetCmd procedure, "select" option} -body { +test button-3.44 {ButtonWidgetCmd procedure, "select" option} -body { radiobutton .r -variable radiovar -value red set radiovar yellow trace variable radiovar w bogusTrace @@ -3075,7 +3075,7 @@ test button-3.44 {ButtonWidgetCmd procedure, "select" option} -body { } -cleanup { destroy .r trace vdelete radiovar w bogusTrace -} -returnCodes {error} -result {can't set "radiovar": trace aborted} +} -returnCodes {error} -result {can't set "radiovar": trace aborted} test button-3.45 {ButtonWidgetCmd procedure, "select" option} -body { radiobutton .r -variable radiovar -value red set radiovar yellow @@ -3128,7 +3128,7 @@ test button-3.50 {ButtonWidgetCmd procedure, "toggle" option} -body { } -cleanup { destroy .c } -result {sunshine rain sunshine} -test button-3.51 {ButtonWidgetCmd procedure, "toggle" option} -body { +test button-3.51 {ButtonWidgetCmd procedure, "toggle" option} -body { checkbutton .c -variable checkvar -onvalue xyz -offvalue abc set checkvar xyz trace variable checkvar w bogusTrace @@ -3136,12 +3136,12 @@ test button-3.51 {ButtonWidgetCmd procedure, "toggle" option} -body { } -cleanup { destroy .c trace vdelete checkvar w bogusTrace -} -returnCodes {error} -result {can't set "checkvar": trace aborted} +} -returnCodes {error} -result {can't set "checkvar": trace aborted} test button-3.52 {ButtonWidgetCmd procedure, "toggle" option} -body { checkbutton .c -variable checkvar -onvalue xyz -offvalue abc set checkvar xyz trace variable checkvar w bogusTrace - catch {.c toggle} + catch {.c toggle} list $errorInfo $checkvar } -cleanup { trace vdelete checkvar w bogusTrace @@ -3150,7 +3150,7 @@ test button-3.52 {ButtonWidgetCmd procedure, "toggle" option} -body { while executing * ".c toggle"} abc} -test button-3.53 {ButtonWidgetCmd procedure, "toggle" option} -body { +test button-3.53 {ButtonWidgetCmd procedure, "toggle" option} -body { checkbutton .c -variable checkvar -onvalue xyz -offvalue abc set checkvar abc trace variable checkvar w bogusTrace @@ -3158,12 +3158,12 @@ test button-3.53 {ButtonWidgetCmd procedure, "toggle" option} -body { } -cleanup { trace vdelete checkvar w bogusTrace destroy .c -} -returnCodes {error} -result {can't set "checkvar": trace aborted} +} -returnCodes {error} -result {can't set "checkvar": trace aborted} test button-3.54 {ButtonWidgetCmd procedure, "toggle" option} -body { checkbutton .c -variable checkvar -onvalue xyz -offvalue abc set checkvar abc trace variable checkvar w bogusTrace - catch {.c toggle} + catch {.c toggle} list $errorInfo $checkvar } -cleanup { trace vdelete checkvar w bogusTrace @@ -3174,17 +3174,17 @@ test button-3.54 {ButtonWidgetCmd procedure, "toggle" option} -body { ".c toggle"} xyz} test button-3.55 {ButtonWidgetCmd procedure, "toggle" option} -setup { unset -nocomplain checkvar -} -body { +} -body { checkbutton .c -variable checkvar -onvalue xyz -offvalue abc unset checkvar set checkvar(1) 1 .c toggle } -cleanup { destroy .c -} -returnCodes {error} -result {can't set "checkvar": variable is array} +} -returnCodes {error} -result {can't set "checkvar": variable is array} test button-3.56 {ButtonWidgetCmd procedure, "toggle" option} -setup { unset -nocomplain checkvar -} -body { +} -body { checkbutton .c -variable checkvar -onvalue xyz -offvalue abc unset checkvar set checkvar(1) 1 @@ -3209,22 +3209,22 @@ test button-4.1 {DestroyButton procedure} -constraints { checkbutton .b5 -variable x -text "Checkbutton 5" set x 1 pack .b1 .b2 .b3 .b4 .b5 - update - deleteWindows + update + deleteWindows } -cleanup { destroy .b1 .b2 .b3 .b4 .b5 image delete image1 -} -result {} +} -result {} test button-5.1 {ConfigureButton - textvariable trace} -body { button .b -bd 4 -bg green .b configure -bd 7 -bg red -fg bogus } -cleanup { destroy .b -} -returnCodes {error} -result {unknown color name "bogus"} +} -returnCodes {error} -result {unknown color name "bogus"} test button-5.2 {ConfigureButton - textvariable trace} -body { button .b -bd 4 -bg green - catch {.b configure -bd 7 -bg red -fg bogus} + catch {.b configure -bd 7 -bg red -fg bogus} list [.b cget -bd] [.b cget -bg] } -cleanup { destroy .b @@ -3271,7 +3271,7 @@ test button-5.6 {ConfigureButton - default value for variable} -body { checkbutton .c .c cget -variable } -cleanup { - destroy .c + destroy .c } -result {c} test button-5.7 {ConfigureButton - setting selected state from variable} -body { set x 0 @@ -3305,7 +3305,7 @@ test button-5.10 {ConfigureButton - error in setting variable} -setup { unset -nocomplain x } -body { trace variable x w bogusTrace - radiobutton .r -variable x + radiobutton .r -variable x } -cleanup { destroy .r trace vdelete x w bogusTrace @@ -3342,7 +3342,7 @@ test button-5.14 {ConfigureButton - variable handling} -setup { } -cleanup { trace vdelete x w bogusTrace destroy .r -} -returnCodes {error} -result {can't set "x": trace aborted} +} -returnCodes {error} -result {can't set "x": trace aborted} test button-5.15 {ConfigureButton - variable handling} -setup { unset -nocomplain x } -body { @@ -3355,12 +3355,12 @@ test button-5.15 {ConfigureButton - variable handling} -setup { } -result {foo} #ex 6.14 -test button-5.16 {ConfigureButton - -width option} -body { +test button-5.16 {ConfigureButton - -width option} -body { button .b -text "Button 1" .b configure -width 1i } -cleanup { destroy .b -} -returnCodes {error} -result {expected integer but got "1i"} +} -returnCodes {error} -result {expected integer but got "1i"} test button-5.17 {ConfigureButton - -width option} -body { button .b -text "Button 1" catch {.b configure -width 1i} @@ -3371,15 +3371,15 @@ test button-5.17 {ConfigureButton - -width option} -body { (processing -width option) invoked from within ".b configure -width 1i"} -test button-5.18 {ConfigureButton - -height option} -body { +test button-5.18 {ConfigureButton - -height option} -body { button .b -text "Button 1" .b configure -height 0.5c } -cleanup { destroy .b -} -returnCodes {error} -result {expected integer but got "0.5c"} -test button-5.19 {ConfigureButton - -height option} -body { +} -returnCodes {error} -result {expected integer but got "0.5c"} +test button-5.19 {ConfigureButton - -height option} -body { button .b -text "Button 1" - catch {.b configure -height 0.5c} + catch {.b configure -height 0.5c} return $errorInfo } -cleanup { destroy .b @@ -3393,10 +3393,10 @@ test button-5.20 {ConfigureButton - -width option} -body { .b configure -width abc } -cleanup { destroy .b -} -returnCodes {error} -result {bad screen distance "abc"} +} -returnCodes {error} -result {bad screen distance "abc"} test button-5.21 {ConfigureButton - -width option} -body { button .b -bitmap questhead - catch {.b configure -width abc} + catch {.b configure -width abc} return $errorInfo } -cleanup { destroy .b @@ -3414,7 +3414,7 @@ test button-5.22 {ConfigureButton - -height option} -constraints { } -cleanup { destroy .b image delete image1 -} -returnCodes {error} -result {bad screen distance "0.5x"} +} -returnCodes {error} -result {bad screen distance "0.5x"} test button-5.23 {ConfigureButton - -height option} -constraints { testImageType } -setup { @@ -3422,7 +3422,7 @@ test button-5.23 {ConfigureButton - -height option} -constraints { } -body { #ztestImageType button .b -image image1 - catch {.b configure -height 0.5x} + catch {.b configure -height 0.5x} return $errorInfo } -cleanup { destroy .b @@ -3523,7 +3523,7 @@ test button-7.1 {ButtonCmdDeletedProc procedure} -body { test button-8.1 {TkInvokeButton procedure} -setup { set x 0 -} -body { +} -body { checkbutton .c -variable x set result $x .c invoke @@ -3534,9 +3534,9 @@ test button-8.1 {TkInvokeButton procedure} -setup { destroy .c } -result {0 1 0} -test button-8.2 {TkInvokeButton procedure} -setup { +test button-8.2 {TkInvokeButton procedure} -setup { set x 0 -} -body { +} -body { checkbutton .c -variable x trace variable x w bogusTrace .c invoke @@ -3546,7 +3546,7 @@ test button-8.2 {TkInvokeButton procedure} -setup { } -returnCodes {error} -result {can't set "x": trace aborted} test button-8.3 {TkInvokeButton procedure} -setup { set x 0 -} -body { +} -body { checkbutton .c -variable x trace variable x w bogusTrace catch {.c invoke} @@ -3555,9 +3555,9 @@ test button-8.3 {TkInvokeButton procedure} -setup { destroy .c trace vdelete x w bogusTrace } -result {1} -test button-8.4 {TkInvokeButton procedure} -setup { +test button-8.4 {TkInvokeButton procedure} -setup { set x 1 -} -body { +} -body { checkbutton .c -variable x trace variable x w bogusTrace .c invoke @@ -3567,7 +3567,7 @@ test button-8.4 {TkInvokeButton procedure} -setup { } -returnCodes {error} -result {can't set "x": trace aborted} test button-8.5 {TkInvokeButton procedure} -setup { set x 1 -} -body { +} -body { checkbutton .c -variable x trace variable x w bogusTrace catch {.c invoke} @@ -3579,7 +3579,7 @@ test button-8.5 {TkInvokeButton procedure} -setup { test button-8.6 {TkInvokeButton procedure} -setup { set x 0 -} -body { +} -body { radiobutton .r -variable x -value red set result $x .r invoke @@ -3590,7 +3590,7 @@ test button-8.6 {TkInvokeButton procedure} -setup { destroy .r } -result {0 red red} -test button-8.7 {TkInvokeButton procedure} -body { +test button-8.7 {TkInvokeButton procedure} -body { radiobutton .r -variable x -value red set x green trace variable x w bogusTrace @@ -3599,7 +3599,7 @@ test button-8.7 {TkInvokeButton procedure} -body { destroy .r trace vdelete x w bogusTrace } -returnCodes {error} -result {can't set "x": trace aborted} -test button-8.8 {TkInvokeButton procedure} -body { +test button-8.8 {TkInvokeButton procedure} -body { radiobutton .r -variable x -value red set x green trace variable x w bogusTrace @@ -3754,7 +3754,7 @@ test button-10.2 {ButtonTextVarProc procedure} -setup { } -result {0} test button-11.1 {ButtonImageProc procedure} -constraints { - testImageType + testImageType } -setup { label .l -highlightthickness 0 -font {Helvetica -12 bold} image create test image1 @@ -3788,7 +3788,7 @@ test button-13.1 {size behavior: label} -setup { label .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} set result {} } -body { - .a configure -text Hej + .a configure -text Hej .b configure -text Hej -width 10 -height 1 .c configure -text "" -width 10 -height 1 @@ -3800,14 +3800,14 @@ test button-13.1 {size behavior: label} -setup { lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] } -cleanup { destroy .a .b .c -} -result {1 1 1} +} -result {1 1 1} test button-13.2 {size behavior: label} -setup { label .a -borderwidth 2 -highlightthickness 2 -font {Arial 20} label .b -borderwidth 2 -highlightthickness 2 -font {Arial 20} label .c -borderwidth 2 -highlightthickness 2 -font {Arial 20} set result {} } -body { - .a configure -text Hej + .a configure -text Hej .b configure -text Hej -width 10 -height 1 .c configure -text "" -width 10 -height 1 @@ -3819,7 +3819,7 @@ test button-13.2 {size behavior: label} -setup { lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] } -cleanup { destroy .a .b .c -} -result {1 1 1} +} -result {1 1 1} test button-13.3 {size behavior: button} -setup { button .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} @@ -3827,7 +3827,7 @@ test button-13.3 {size behavior: button} -setup { button .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} set result {} } -body { - .a configure -text Hej + .a configure -text Hej .b configure -text Hej -width 10 -height 1 .c configure -text "" -width 10 -height 1 @@ -3839,14 +3839,14 @@ test button-13.3 {size behavior: button} -setup { lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] } -cleanup { destroy .a .b .c -} -result {1 1 1} +} -result {1 1 1} test button-13.4 {size behavior: button} -setup { button .a -borderwidth 2 -highlightthickness 2 -font {Arial 20} button .b -borderwidth 2 -highlightthickness 2 -font {Arial 20} button .c -borderwidth 2 -highlightthickness 2 -font {Arial 20} set result {} } -body { - .a configure -text Hej + .a configure -text Hej .b configure -text Hej -width 10 -height 1 .c configure -text "" -width 10 -height 1 @@ -3858,7 +3858,7 @@ test button-13.4 {size behavior: button} -setup { lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] } -cleanup { destroy .a .b .c -} -result {1 1 1} +} -result {1 1 1} test button-13.5 {size behavior: radiobutton} -setup { radiobutton .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} @@ -3866,7 +3866,7 @@ test button-13.5 {size behavior: radiobutton} -setup { radiobutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} set result {} } -body { - .a configure -text Hej + .a configure -text Hej .b configure -text Hej -width 10 -height 1 .c configure -text "" -width 10 -height 1 @@ -3878,7 +3878,7 @@ test button-13.5 {size behavior: radiobutton} -setup { lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] } -cleanup { destroy .a .b .c -} -result {1 1 1} +} -result {1 1 1} test button-13.6 {size behavior: radiobutton} -setup { radiobutton .a -borderwidth 2 -highlightthickness 2 -font {Arial 20} @@ -3886,7 +3886,7 @@ test button-13.6 {size behavior: radiobutton} -setup { radiobutton .c -borderwidth 2 -highlightthickness 2 -font {Arial 20} set result {} } -body { - .a configure -text Hej + .a configure -text Hej .b configure -text Hej -width 10 -height 1 .c configure -text "" -width 10 -height 1 @@ -3898,7 +3898,7 @@ test button-13.6 {size behavior: radiobutton} -setup { lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] } -cleanup { destroy .a .b .c -} -result {1 1 1} +} -result {1 1 1} test button-13.7 {size behavior: checkbutton} -setup { checkbutton .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} @@ -3906,7 +3906,7 @@ test button-13.7 {size behavior: checkbutton} -setup { checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} set result {} } -body { - .a configure -text Hej + .a configure -text Hej .b configure -text Hej -width 10 -height 1 .c configure -text "" -width 10 -height 1 @@ -3918,7 +3918,7 @@ test button-13.7 {size behavior: checkbutton} -setup { lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] } -cleanup { destroy .a .b .c -} -result {1 1 1} +} -result {1 1 1} test button-13.8 {size behavior: checkbutton} -setup { checkbutton .a -borderwidth 2 -highlightthickness 2 -font {Arial 20} @@ -3926,7 +3926,7 @@ test button-13.8 {size behavior: checkbutton} -setup { checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Arial 20} set result {} } -body { - .a configure -text Hej + .a configure -text Hej .b configure -text Hej -width 10 -height 1 .c configure -text "" -width 10 -height 1 @@ -3938,7 +3938,7 @@ test button-13.8 {size behavior: checkbutton} -setup { lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] } -cleanup { destroy .a .b .c -} -result {1 1 1} +} -result {1 1 1} test button-14.1 {bug fix: [011706ec42] tk::ButtonInvoke unsafe wrt widget destruction} -body { proc destroy_button {} { @@ -3956,7 +3956,7 @@ test button-14.1 {bug fix: [011706ec42] tk::ButtonInvoke unsafe wrt widget destr update ; # shall not trigger error invalid command name ".top.b" } -cleanup { destroy .top.b .top -} -result {} +} -result {} test button-15.1 {Bug [5d991b822e]} { # Want this not to segfault diff --git a/tests/canvImg.test b/tests/canvImg.test index a5e8e10..bd9edb5 100644 --- a/tests/canvImg.test +++ b/tests/canvImg.test @@ -322,7 +322,7 @@ test canvImg-6.9 {ComputeImageBbox procedure} -constraints testImageType -setup imageCleanup } -result {5 15 35 30} test canvImg-6.10 {ComputeImageBbox procedure} -constraints { - testImageType + testImageType } -setup { image create test foo .c delete all @@ -335,7 +335,7 @@ test canvImg-6.10 {ComputeImageBbox procedure} -constraints { image delete foo } -result {20 15 50 30} test canvImg-6.11 {ComputeImageBbox procedure} -constraints { - testImageType + testImageType } -setup { image create test foo .c delete all @@ -348,7 +348,7 @@ test canvImg-6.11 {ComputeImageBbox procedure} -constraints { image delete foo } -result {20 23 50 38} test canvImg-6.12 {ComputeImageBbox procedure} -constraints { - testImageType + testImageType } -setup { image create test foo .c delete all @@ -731,7 +731,7 @@ if {[tk windowingsystem] == "aqua" && $tcl_platform(osVersion) > 18} { # Aqua >= 10.14 will redraw the entire image. set result_10_1 {{foo display 0 0 30 15}} } else { - set result_10_1 {{foo display 2 4 6 8}} + set result_10_1 {{foo display 2 4 6 8}} } test canvImg-10.1 {TranslateImage procedure} -constraints testImageType -setup { .c delete all @@ -771,7 +771,7 @@ test canvImg-11.1 {TranslateImage procedure} -constraints testImageType -setup { image delete foo } -result {{foo display 0 0 40 50}} test canvImg-11.2 {ImageChangedProc procedure} -constraints { - testImageType + testImageType } -setup { .c delete all } -body { @@ -789,10 +789,10 @@ if {[tk windowingsystem] == "aqua" && $tcl_platform(osVersion) > 18} { # Aqua >= 10.14 will redraw the entire image. set result_11_3 {{foo2 display 0 0 80 60}} } else { - set result_11_3 {{foo2 display 0 0 20 40}} + set result_11_3 {{foo2 display 0 0 20 40}} } test canvImg-11.3 {ImageChangedProc procedure} -constraints { - testImageType + testImageType } -setup { .c delete all update diff --git a/tests/canvMoveto.test b/tests/canvMoveto.test index 79761a4..60eb6f3 100644 --- a/tests/canvMoveto.test +++ b/tests/canvMoveto.test @@ -33,7 +33,7 @@ test canvMoveto-1.5 {Bad args handling for "moveto" command} -body { test canvMoveto-2.1 {Canvas "moveto" command coordinates} { .c moveto test 200 150 .c bbox test -} {200 150 272 232} +} {200 150 272 232} test canvMoveto-2.2 {Canvas "moveto" command, blank y coordinate} { .c moveto test 200 150 .c moveto test 150 {} diff --git a/tests/canvRect.test b/tests/canvRect.test index a2cc51c..ec59e8b 100644 --- a/tests/canvRect.test +++ b/tests/canvRect.test @@ -228,7 +228,7 @@ test canvRect-6.2 {RectToPoint procedure} -body { [expr {[.c find closest 20 25.1] eq $yId}] \ [expr {[.c find closest 20 29.9] eq $yId}] \ [expr {[.c find closest 20 30.1] eq $xId}] - + } -cleanup { .c delete all } -result {1 1 1 1} @@ -250,7 +250,7 @@ test canvRect-6.4 {RectToPoint procedure} -body { list [expr {[.c find closest 20 24.4] eq $xId}] \ [expr {[.c find closest 20 24.6] eq $yId}] \ [expr {[.c find closest 20 30.4] eq $yId}] \ - [expr {[.c find closest 20 30.6] eq $xId}] + [expr {[.c find closest 20 30.6] eq $xId}] } -cleanup { .c delete all } -result {1 1 1 1} @@ -275,18 +275,18 @@ test canvRect-6.6 {RectToPoint procedure} -body { list [expr {[.c find closest 20 23.2] eq $xId}] \ [expr {[.c find closest 20 23.3] eq $yId}] \ [expr {[.c find closest 20 31.7] eq $yId}] \ - [expr {[.c find closest 20 31.8] eq $xId}] + [expr {[.c find closest 20 31.8] eq $xId}] } -cleanup { .c delete all } -result {1 1 1 1} - + test canvRect-6.7 {RectToPoint procedure} -body { - set xId [.c create rectangle 10 20 30 40 -outline {} -fill black] + set xId [.c create rectangle 10 20 30 40 -outline {} -fill black] set yId [.c create rectangle 40 40 50 50 -outline {} -fill black] list [expr {[.c find closest 35 35] eq $xId}] \ [expr {[.c find closest 36 36] eq $yId}] \ [expr {[.c find closest 37 37] eq $yId}] \ - [expr {[.c find closest 38 38] eq $yId}] + [expr {[.c find closest 38 38] eq $yId}] } -cleanup { .c delete all } -result {1 1 1 1} diff --git a/tests/canvas.test b/tests/canvas.test index 697badb..5086389 100644 --- a/tests/canvas.test +++ b/tests/canvas.test @@ -227,6 +227,16 @@ test canvas-2.4 {CanvasWidgetCmd, xview option} -constraints nonPortable -body { update lappend x [.c xview] } -result {{0.6 0.9} {0.66 0.96}} +test canvas-2.5 {CanvasWidgetCmd, raise/lower option, no error on non-existing tags} -setup { + .c create line 0 0 10 10 -tags aline +} -body { + .c raise aline noline + .c raise bline aline + .c lower aline noline + .c lower bline aline +} -cleanup { + .c delete aline +} -result {} catch {destroy .c} # Canvas used in 3.* test cases @@ -340,8 +350,10 @@ test canvas-8.1 {canvas arc bbox} -setup { set coordBox [.c bbox arc2] .c create arc 300 10 500 210 -start 10 -extent 50 -style pieslice -tags arc3 set pieBox [.c bbox arc3] - list $arcBox $coordBox $pieBox -} -result {{48 21 100 94} {248 21 300 94} {398 21 500 112}} + .c create arc 100 200 300 200 -height [expr {(1-0.5*sqrt(3))*200}] -style arc -tags arc4 + set arcSegBox [.c bbox arc4] + list $arcBox $coordBox $pieBox $arcSegBox +} -result {{48 21 100 94} {248 21 300 94} {398 21 500 112} {98 171 302 202}} test canvas-9.1 {canvas id creation and deletion} -setup { catch {destroy .c} @@ -537,10 +549,10 @@ 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 + 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 + # qx has now type MMRep and no string representation list $qx [string length $qx] } -result {2.0 3} test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} -setup { @@ -549,9 +561,9 @@ test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} -setup { } -body { set val 10 incr val - # qx has type double and no string representation + # qx has type double and no string representation .c scale all $val 0 1 1 - # qx has now type MMRep and no string representation + # qx has now type MMRep and no string representation incr val } -result 12 @@ -572,7 +584,7 @@ test canvas-13.1 {canvas delete during event, SF bug-228024} -body { set ::x {} # do this many times to improve chances of triggering the crash for {set i 0} {$i < 30} {incr i} { - event generate .c <1> -x 100 -y 100 + event generate .c <Button-1> -x 100 -y 100 event generate .c <ButtonRelease-1> -x 100 -y 100 } return $::x @@ -727,7 +739,7 @@ test canvas-15.19 "basic coords check: centimeters are larger than pixels" -setu destroy .c canvas .c } -body { - set id [.c create rect 0 0 1cm 1cm] + set id [.c create rect 0 0 1cm 1cm] expr {[lindex [.c coords $id] 2]>1} } -result {1} destroy .c @@ -992,6 +1004,295 @@ test canvas-20.3 {tag deletion - all tags match} -setup { destroy .c } -result {{tagA tagA tagA tagA tagA tagA} {}} +# Procedure used in test cases 20.1 20.2 20.3 +proc matchPixels {pixels expected} { + set matched 1 + foreach pline $pixels eline $expected { + foreach ppixel $pline epixel $eline { + if {$ppixel != $epixel} { + set matched 0 + break + } + } + } + return $matched +} + +test canvas-20.1 {canvas image} -setup { + canvas .c + image create photo testimage +} -body { + .c configure -background #c0c0c0 -scrollregion {0 0 9 9} + .c create rectangle 0 0 0 9 -fill #000080 -outline #000080 + .c image testimage + matchPixels [testimage data] { \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0}} +} -cleanup { + destroy .c + image delete testimage +} -result 1 + +test canvas-20.2 {canvas image with subsample} -setup { + canvas .c + image create photo testimage +} -body { + .c configure -background #c0c0c0 -scrollregion {0 0 9 9} + .c create rectangle 0 0 1 9 -fill #008000 -outline #008000 + .c image testimage 2 + matchPixels [testimage data] { \ + {#008000 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#008000 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#008000 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#008000 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#008000 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0}} +} -cleanup { + destroy .c + image delete testimage +} -result 1 + +test canvas-20.3 {canvas image with subsample and zoom} -setup { + canvas .c + image create photo testimage +} -body { + .c configure -background #c0c0c0 -scrollregion {0 0 9 9} + .c create rectangle 0 0 9 0 -fill #800000 -outline #800000 + .c image testimage 1 2 + matchPixels [testimage data] { \ + {#800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000} \ + {#800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0}} +} -cleanup { + destroy .c + image delete testimage +} -result 1 + +test canvas-21.1 {canvas very small arc} -setup { + catch {destroy .c} + canvas .c +} -body { + # no Inf or NaN must be generated even for very small arcs + .c create arc 0 100 0 100 -height 100 -style arc -outline "" -tags arc1 + set arcBox [.c bbox arc1] + .c create arc 0 100 0 100 -height 100 -style arc -outline blue -tags arc2 + set outlinedArcBox [.c bbox arc2] + set coords [.c coords arc1] + set start [.c itemcget arc1 -start] + set extent [.c itemcget arc1 -extent] + set width [.c itemcget arc1 -width] + set height [.c itemcget arc1 -height] + list $arcBox $outlinedArcBox $coords $start $extent $width $height +} -result {{-1 99 1 101} {-2 98 2 102} {0.0 100.0 0.0 100.0} 0.0 0.0 1.0 0.0} + + +destroy .c +test canvas-21.1 {canvas rotate} -setup { + pack [canvas .c] +} -body { + .c create line 50 50 50 100 100 100 + .c rotate all 75 75 90 + lmap c [.c coords all] {format %.2f $c} +} -cleanup { + destroy .c +} -result {50.00 100.00 100.00 100.00 100.00 50.00} +test canvas-21.2 {canvas rotate} -setup { + pack [canvas .c] +} -body { + .c create line 50 50 50 100 100 100 + .c rotate all 75 75 -10 + lmap c [.c coords all] {format %.2f $c} +} -cleanup { + destroy .c +} -result {54.72 46.04 46.04 95.28 95.28 103.96} +test canvas-21.3 {canvas rotate: syntax} -setup { + pack [canvas .c] +} -body { + .c rotate all 75 75 +} -returnCodes error -cleanup { + destroy .c +} -result {wrong # args: should be ".c rotate tagOrId x y angle"} +test canvas-21.4 {canvas rotate: syntax} -setup { + pack [canvas .c] +} -body { + .c rotate all 75 75 123 123 +} -returnCodes error -cleanup { + destroy .c +} -result {wrong # args: should be ".c rotate tagOrId x y angle"} +test canvas-21.5 {canvas rotate: syntax} -setup { + pack [canvas .c] +} -body { + .c rotate {!} 1 1 1 +} -returnCodes error -cleanup { + destroy .c +} -result {missing tag in tag search expression} +test canvas-21.6 {canvas rotate: syntax} -setup { + pack [canvas .c] +} -body { + .c rotate all x 1 1 +} -returnCodes error -cleanup { + destroy .c +} -result {bad screen distance "x"} +test canvas-21.7 {canvas rotate: syntax} -setup { + pack [canvas .c] +} -body { + .c rotate all 1 x 1 +} -returnCodes error -cleanup { + destroy .c +} -result {bad screen distance "x"} +test canvas-21.8 {canvas rotate: syntax} -setup { + pack [canvas .c] +} -body { + .c rotate all 1 1 x +} -returnCodes error -cleanup { + destroy .c +} -result {expected floating-point number but got "x"} +test canvas-21.9 {canvas rotate: nothing to rotate} -setup { + pack [canvas .c] +} -body { + .c rotate all 75 75 10 +} -cleanup { + destroy .c +} -result {} +test canvas-21.10 {canvas rotate: multiple things to rotate} -setup { + pack [canvas .c] +} -body { + .c create line 50 50 50 100 -tag a + .c create line 50 50 100 50 -tag b + .c rotate all 75 75 45 + list [lmap c [.c coords a] {format %.2f $c}] [lmap c [.c coords b] {format %.2f $c}] +} -cleanup { + destroy .c +} -result {{39.64 75.00 75.00 110.36} {39.64 75.00 75.00 39.64}} + +test canvas-22.1 {canvas rotate: arc item rotation behaviour} -setup { + pack [canvas .c] +} -body { + .c create arc 50 50 75 75 -start 45 -extent 90 + .c rotate all 100 100 90 + list [lmap c [.c coords all] {format %.2f $c}] \ + [lmap o {-start -extent} {.c itemcget all $o}] \ + [.c bbox all] +} -cleanup { + destroy .c +} -result {{50.00 125.00 75.00 150.00} {45.0 90.0} {52 123 73 140}} +test canvas-22.2 {canvas rotate: bitmap item rotation behaviour} -setup { + pack [canvas .c] +} -body { + .c create bitmap 50 50 -bitmap info -anchor se + .c rotate all 100 100 90 + list [lmap c [.c coords all] {format %.2f $c}] \ + [lmap o {-bitmap -anchor} {.c itemcget all $o}] \ + [.c bbox all] +} -cleanup { + destroy .c +} -result {{50.00 150.00} {info se} {42 129 50 150}} +test canvas-22.3 {canvas rotate: image item rotation behaviour} -setup { + pack [canvas .c] + image create photo dummy -width 50 -height 50 +} -body { + .c create image 50 50 -image dummy -anchor se + .c rotate all 100 100 90 + list [lmap c [.c coords all] {format %.2f $c}] \ + [lmap o {-image -anchor} {.c itemcget all $o}] \ + [.c bbox all] +} -cleanup { + destroy .c + image delete dummy +} -result {{50.00 150.00} {dummy se} {0 100 50 150}} +test canvas-22.4 {canvas rotate: line item rotation behaviour} -setup { + pack [canvas .c] +} -body { + .c create line 50 50 75 50 50 75 75 75 + .c rotate all 100 100 90 + list [lmap c [.c coords all] {format %.2f $c}] \ + [lmap o {} {.c itemcget all $o}] \ + [.c bbox all] +} -cleanup { + destroy .c +} -result {{50.00 150.00 50.00 125.00 75.00 150.00 75.00 125.00} {} {48 123 77 152}} +test canvas-22.5 {canvas rotate: oval item rotation behaviour} -setup { + pack [canvas .c] +} -body { + .c create oval 50 50 65 85 + .c rotate all 100 100 90 + list [lmap c [.c coords all] {format %.2f $c}] \ + [lmap o {} {.c itemcget all $o}] \ + [.c bbox all] +} -cleanup { + destroy .c +} -result {{60.00 125.00 75.00 160.00} {} {59 124 76 161}} +test canvas-22.6 {canvas rotate: polygon item rotation behaviour} -setup { + pack [canvas .c] +} -body { + .c create polygon 50 50 75 50 50 75 75 75 + .c rotate all 100 100 90 + list [lmap c [.c coords all] {format %.2f $c}] \ + [lmap o {} {.c itemcget all $o}] \ + [.c bbox all] +} -cleanup { + destroy .c +} -result {{50.00 150.00 50.00 125.00 75.00 150.00 75.00 125.00} {} {48 123 77 152}} +test canvas-22.7 {canvas rotate: rectangle item rotation behaviour} -setup { + pack [canvas .c] +} -body { + .c create rectangle 50 50 75 75 + .c rotate all 100 100 90 + list [lmap c [.c coords all] {format %.2f $c}] \ + [lmap o {} {.c itemcget all $o}] \ + [.c bbox all] +} -cleanup { + destroy .c +} -result {{50.00 125.00 75.00 150.00} {} {49 124 76 151}} +test canvas-22.8 {canvas rotate: text item rotation behaviour} -setup { + pack [canvas .c] +} -body { + .c create text 50 50 -text foo -angle 45 + .c rotate all 100 100 90 + list [lmap c [.c coords all] {format %.2f $c}] \ + [lmap o {-text -angle} {.c itemcget all $o}] + # [.c bbox all] + # No testing of text bounding box; fonts too variable! +} -cleanup { + destroy .c +} -result {{50.00 150.00} {foo 45.0}} +test canvas-22.9 {canvas rotate: window item rotation behaviour} -setup { + pack [canvas .c] +} -body { + .c create window 50 50 -window [frame .c.f -width 25 -height 25] \ + -anchor se + .c rotate all 100 100 90 + list [lmap c [.c coords all] {format %.2f $c}] \ + [lmap o {} {.c itemcget all $o}] \ + [.c bbox all] +} -cleanup { + destroy .c +} -result {{50.00 150.00} {} {25 125 50 150}} + # cleanup imageCleanup cleanupTests diff --git a/tests/choosedir.test b/tests/choosedir.test index f67a721..c6cc632 100644 --- a/tests/choosedir.test +++ b/tests/choosedir.test @@ -26,7 +26,7 @@ proc ToEnterDirsByKey {parent dirs} { proc PressButton {btn} { event generate $btn <Enter> - event generate $btn <1> -x 5 -y 5 + event generate $btn <Button-1> -x 5 -y 5 event generate $btn <ButtonRelease-1> -x 5 -y 5 } @@ -68,7 +68,7 @@ proc SendButtonPress {parent btn type} { event generate $w <Enter> focus $w event generate $button <Enter> - event generate $w <KeyPress> -keysym Return + event generate $w <Key> -keysym Return } } diff --git a/tests/clipboard.test b/tests/clipboard.test index 9689942..81534d5 100644 --- a/tests/clipboard.test +++ b/tests/clipboard.test @@ -180,7 +180,7 @@ test clipboard-4.4 {ClipboardLostSel procedure} -setup { clipboard get } -cleanup { clipboard clear -} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined} +} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined} test clipboard-4.5 {ClipboardLostSel procedure} -setup { clipboard clear } -body { diff --git a/tests/clrpick.test b/tests/clrpick.test index c15308b..0900962 100644 --- a/tests/clrpick.test +++ b/tests/clrpick.test @@ -97,7 +97,7 @@ proc ToChooseColorByKey {parent r g b} { proc PressButton {btn} { event generate $btn <Enter> - event generate $btn <1> -x 5 -y 5 + event generate $btn <Button-1> -x 5 -y 5 event generate $btn <ButtonRelease-1> -x 5 -y 5 } @@ -137,7 +137,7 @@ proc SendButtonPress {parent btn type} { event generate $w <Enter> focus $w event generate $button <Enter> - event generate $w <KeyPress> -keysym Return + event generate $w <Key> -keysym Return } } diff --git a/tests/cmds.test b/tests/cmds.test index fa7e788..caf5afe 100644 --- a/tests/cmds.test +++ b/tests/cmds.test @@ -39,7 +39,7 @@ test cmds-1.5 {tkwait visibility, window gets deleted} -setup { } -body { after 100 {set x deleted; destroy .f} tkwait visibility .f.b -} -returnCodes {error} -result {window ".f.b" was deleted before its visibility changed} +} -returnCodes {error} -result {window ".f.b" was deleted before its visibility changed} test cmds-1.6 {tkwait visibility, window gets deleted} -setup { frame .f button .f.b -text "Test" diff --git a/tests/config.test b/tests/config.test index 833e288..9fd048a 100644 --- a/tests/config.test +++ b/tests/config.test @@ -196,7 +196,7 @@ test config-3.7 {Tk_InitOptions - bad initial value} -constraints { testobjconfig } -body { option add *a.color non-existent - catch {testobjconfig alltypes .a} + catch {testobjconfig alltypes .a} return $errorInfo } -cleanup { killTables @@ -558,7 +558,7 @@ test config-4.41 {DoObjConfig - null color} -constraints testobjconfig -body { killTables } -returnCodes ok test config-4.42 {DoObjConfig - getting rid of old color} -constraints { - testobjconfig + testobjconfig } -body { testobjconfig alltypes .foo -color #333333 .foo configure -color #444444 @@ -566,7 +566,7 @@ test config-4.42 {DoObjConfig - getting rid of old color} -constraints { killTables } -returnCodes ok -result {32} test config-4.43 {DoObjConfig - getting rid of old color} -constraints { - testobjconfig + testobjconfig } -body { testobjconfig alltypes .foo -color #333333 .foo configure -color #444444 @@ -575,7 +575,7 @@ test config-4.43 {DoObjConfig - getting rid of old color} -constraints { killTables } -returnCodes ok -result {#444444} test config-4.44 {DoObjConfig - getting rid of old color} -constraints { - testobjconfig + testobjconfig } -body { testobjconfig alltypes .foo -color #333333 .foo configure -color #444444 @@ -665,13 +665,13 @@ test config-4.54 {DoObjConfig - bitmap} -constraints testobjconfig -body { } -returnCodes ok -result {gray75} test config-4.55 {DoObjConfig - new bitmap} -constraints testobjconfig -body { testobjconfig alltypes .foo -bitmap gray75 - .foo configure -bitmap gray50 + .foo configure -bitmap gray50 } -cleanup { killTables } -returnCodes ok -result {128} test config-4.56 {DoObjConfig - new bitmap} -constraints testobjconfig -body { testobjconfig alltypes .foo -bitmap gray75 - .foo configure -bitmap gray50 + .foo configure -bitmap gray50 .foo cget -bitmap } -cleanup { killTables @@ -745,7 +745,7 @@ test config-4.66 {DoObjConfig - border internal value} -constraints { killTables } -result {#123456} test config-4.67 {DoObjConfig - getting rid of old border} -constraints { - testobjconfig + testobjconfig } -body { testobjconfig alltypes .foo -border #333333 .foo configure -border #444444 @@ -753,7 +753,7 @@ test config-4.67 {DoObjConfig - getting rid of old border} -constraints { killTables } -returnCodes ok -result {256} test config-4.68 {DoObjConfig - getting rid of old border} -constraints { - testobjconfig + testobjconfig } -body { testobjconfig alltypes .foo -border #333333 .foo configure -border #444444 @@ -790,13 +790,13 @@ test config-4.72 {DoObjConfig - relief internal value} -constraints testobjconfi } -result {ridge} test config-4.73 {DoObjConfig - new relief} -constraints testobjconfig -body { testobjconfig alltypes .foo -relief raised - .foo configure -relief flat + .foo configure -relief flat } -cleanup { killTables } -returnCodes ok -result {512} test config-4.74 {DoObjConfig - new relief} -constraints testobjconfig -body { testobjconfig alltypes .foo -relief raised - .foo configure -relief flat + .foo configure -relief flat .foo cget -relief } -cleanup { killTables @@ -915,7 +915,7 @@ test config-4.91 {DoObjConfig - invalid anchor} -constraints testobjconfig -body } -returnCodes error -result {bad anchor "foo": must be n, ne, e, se, s, sw, w, nw, or center} test config-4.92 {DoObjConfig - new anchor} -constraints testobjconfig -body { testobjconfig alltypes .foo -anchor e - .foo configure -anchor n + .foo configure -anchor n } -cleanup { killTables } -returnCodes ok -result {4096} @@ -993,7 +993,7 @@ test config-4.102 {DoObjConfig - window} -constraints testobjconfig -body { } -returnCodes ok -result {.bar} test config-4.103 {DoObjConfig - invalid window} -constraints testobjconfig -body { toplevel .bar - testobjconfig twowindows .foo -window foo + testobjconfig twowindows .foo -window foo } -cleanup { killTables } -returnCodes error -result {bad window path name "foo"} @@ -1205,19 +1205,19 @@ test config-7.3 {Tk_SetOptions - synonym} -constraints testobjconfig -body { test config-7.4 {Tk_SetOptions - missing value} -constraints { testobjconfig } -body { - .a configure -color green -relief + .a configure -color green -relief } -returnCodes error -result {value for "-relief" missing} test config-7.5 {Tk_SetOptions - missing value} -constraints { testobjconfig } -body { - catch {.a configure -color green -relief} + catch {.a configure -color green -relief} .a cget -color } -result {green} test config-7.6 {Tk_SetOptions - saving old values} -constraints { testobjconfig } -body { .a configure -color red -int 7 -relief raised -double 3.14159 - .a csave -color green -int 432 -relief sunken -double 2.0 -color bogus + .a csave -color green -int 432 -relief sunken -double 2.0 -color bogus } -returnCodes error -result {unknown color name "bogus"} test config-7.7 {Tk_SetOptions - saving old values} -constraints { testobjconfig @@ -1230,7 +1230,7 @@ test config-7.7 {Tk_SetOptions - saving old values} -constraints { test config-7.8 {Tk_SetOptions - error in DoObjConfig call} -constraints { testobjconfig } -body { - .a configure -color bogus + .a configure -color bogus } -returnCodes error -result {unknown color name "bogus"} test config-7.9 {Tk_SetOptions - error in DoObjConfig call} -constraints { testobjconfig @@ -1262,7 +1262,7 @@ test config-7.12 {Tk_SetOptions - returning mask} -constraints testobjconfig -bo test config-7.13 {Tk_SetOptions - error in DoObjConfig with custom option} -constraints { testobjconfig } -body { - .a configure -custom bad + .a configure -custom bad } -returnCodes error -result {expected good value, got "BAD"} test config-7.14 {Tk_SetOptions - error in DoObjConfig with custom option} -constraints { testobjconfig diff --git a/tests/cursor.test b/tests/cursor.test index 172c982..8d7ebb0 100644 --- a/tests/cursor.test +++ b/tests/cursor.test @@ -108,7 +108,7 @@ test cursor-2.3 {Tk_GetCursor procedure: cursor specs are lists} -constraints { } -cleanup { destroy .b removeDirectory $wincur(dir) - unset wincur + unset wincur } -result {.b} test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} -constraints { win diff --git a/tests/dialog.test b/tests/dialog.test index 78b6620..2d88103 100644 --- a/tests/dialog.test +++ b/tests/dialog.test @@ -25,7 +25,7 @@ test dialog-2.1 {tk_dialog operation} -setup { update } event generate $btn <Enter> - event generate $btn <1> -x 5 -y 5 + event generate $btn <Button-1> -x 5 -y 5 event generate $btn <ButtonRelease-1> -x 5 -y 5 } } -body { @@ -41,7 +41,7 @@ test dialog-2.2 {tk_dialog operation} -setup { proc HitReturn {w} { event generate $w <Enter> focus -force $w - event generate $w <KeyPress> -keysym Return + event generate $w <Key> -keysym Return } } -body { set x [after 5000 [list set tk::Priv(button) "no response"]] diff --git a/tests/entry.test b/tests/entry.test index 3c80e07..b92c894 100644 --- a/tests/entry.test +++ b/tests/entry.test @@ -16,7 +16,7 @@ proc scroll args { global scrollInfo set scrollInfo $args } -# For trace variable +# For trace variable proc override args { global x set x 12345 @@ -106,7 +106,7 @@ test entry-1.7 {configuration option: "borderwidth" for entry} -setup { update } -body { .e configure -borderwidth 1.3 - .e cget -borderwidth + .e cget -borderwidth } -cleanup { destroy .e } -result {1} @@ -221,7 +221,7 @@ test entry-1.18 {configuration option: "fg" for entry} -setup { } -returnCodes {error} -result {unknown color name "non-existent"} test entry-1.19 {configuration option: "font" for entry} -setup { - entry .e -borderwidth 2 -highlightthickness 2 + entry .e -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -231,7 +231,7 @@ test entry-1.19 {configuration option: "font" for entry} -setup { destroy .e } -result {Helvetica -12} test entry-1.20 {configuration option: "font" for entry} -setup { - entry .e -borderwidth 2 -highlightthickness 2 + entry .e -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -627,6 +627,23 @@ test entry-1.58 {configuration option: "xscrollcommand" for entry} -setup { destroy .e } -result {Some command} +test entry-1.59 {configuration option: "-placeholder"} -setup { + pack [entry .e] +} -body { + .e configure -placeholder {Some text} + .e cget -placeholder +} -cleanup { + destroy .e +} -result {Some text} + +test entry-1.60 {configuration option: "-placeholderforeground"} -setup { + pack [entry .e] +} -body { + .e configure -placeholder {Some text} -placeholderforeground red + .e cget -placeholderforeground +} -cleanup { + destroy .e +} -result {red} test entry-2.1 {Tk_EntryCmd procedure} -body { @@ -662,7 +679,7 @@ test entry-2.5 {Tk_EntryCmd procedure} -body { test entry-3.1 {EntryWidgetCmd procedure} -setup { - entry .e + entry .e pack .e update } -body { @@ -671,7 +688,7 @@ test entry-3.1 {EntryWidgetCmd procedure} -setup { destroy .e } -returnCodes error -result {wrong # args: should be ".e option ?arg ...?"} test entry-3.2 {EntryWidgetCmd procedure, "bbox" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -680,7 +697,7 @@ test entry-3.2 {EntryWidgetCmd procedure, "bbox" widget command} -setup { destroy .e } -returnCodes error -result {wrong # args: should be ".e bbox index"} test entry-3.3 {EntryWidgetCmd procedure, "bbox" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -689,7 +706,7 @@ test entry-3.3 {EntryWidgetCmd procedure, "bbox" widget command} -setup { destroy .e } -returnCodes error -result {wrong # args: should be ".e bbox index"} test entry-3.4 {EntryWidgetCmd procedure, "bbox" widget command} -setup { - entry .e + entry .e pack .e update } -body { @@ -698,7 +715,7 @@ test entry-3.4 {EntryWidgetCmd procedure, "bbox" widget command} -setup { destroy .e } -returnCodes error -result {bad entry index "bogus"} test entry-3.5 {EntryWidgetCmd procedure, "bbox" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -707,7 +724,7 @@ test entry-3.5 {EntryWidgetCmd procedure, "bbox" widget command} -setup { destroy .e } -result [list 5 5 0 $cy] -# Previously the result was count using previousli counted font measurements +# Previously the result was count using previousli counted font measurements # and metrics. It was changed to less verbose solution - the result is the one # that passes fonts constraint (this concerns tests 3.6, 3.7, 3.8, 3.10) test entry-3.6 {EntryWidgetCmd procedure, "bbox" widget command} -constraints { @@ -726,7 +743,7 @@ test entry-3.6 {EntryWidgetCmd procedure, "bbox" widget command} -constraints { test entry-3.7 {EntryWidgetCmd procedure, "bbox" widget command} -constraints { fonts } -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -739,7 +756,7 @@ test entry-3.7 {EntryWidgetCmd procedure, "bbox" widget command} -constraints { test entry-3.8 {EntryWidgetCmd procedure, "bbox" widget command} -constraints { fonts } -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -750,7 +767,7 @@ test entry-3.8 {EntryWidgetCmd procedure, "bbox" widget command} -constraints { destroy .e } -result {31 5 7 13} test entry-3.9 {EntryWidgetCmd procedure, "bbox" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -762,7 +779,7 @@ test entry-3.9 {EntryWidgetCmd procedure, "bbox" widget command} -setup { test entry-3.10 {EntryWidgetCmd procedure, "bbox" widget command} -constraints { fonts } -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -772,28 +789,28 @@ test entry-3.10 {EntryWidgetCmd procedure, "bbox" widget command} -constraints { destroy .e } -result {{5 5 7 13} {12 5 7 13} {75 5 12 13} {122 5 7 13}} test entry-3.11 {EntryWidgetCmd procedure, "cget" widget command} -setup { - entry .e + entry .e } -body { .e cget } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e cget option"} test entry-3.12 {EntryWidgetCmd procedure, "cget" widget command} -setup { - entry .e + entry .e } -body { .e cget a b } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e cget option"} test entry-3.13 {EntryWidgetCmd procedure, "cget" widget command} -setup { - entry .e + entry .e } -body { .e cget -gorp } -cleanup { destroy .e } -returnCodes error -result {unknown option "-gorp"} test entry-3.14 {EntryWidgetCmd procedure, "cget" widget command} -setup { - entry .e + entry .e } -body { .e configure -bd 4 .e cget -bd @@ -801,23 +818,23 @@ test entry-3.14 {EntryWidgetCmd procedure, "cget" widget command} -setup { destroy .e } -result {4} test entry-3.15 {EntryWidgetCmd procedure, "configure" widget command} -setup { - entry .e + entry .e pack .e update } -body { llength [.e configure] } -cleanup { destroy .e -} -result {36} +} -result {38} test entry-3.16 {EntryWidgetCmd procedure, "configure" widget command} -setup { - entry .e + entry .e } -body { .e configure -foo } -cleanup { destroy .e } -returnCodes error -result {unknown option "-foo"} test entry-3.17 {EntryWidgetCmd procedure, "configure" widget command} -setup { - entry .e + entry .e } -body { .e configure -bd 4 .e configure -bg #ffffff @@ -826,28 +843,28 @@ test entry-3.17 {EntryWidgetCmd procedure, "configure" widget command} -setup { destroy .e } -result {4} test entry-3.18 {EntryWidgetCmd procedure, "delete" widget command} -setup { - entry .e + entry .e } -body { .e delete } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"} test entry-3.19 {EntryWidgetCmd procedure, "delete" widget command} -setup { - entry .e + entry .e } -body { .e delete a b c } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"} test entry-3.20 {EntryWidgetCmd procedure, "delete" widget command} -setup { - entry .e + entry .e } -body { .e delete foo } -cleanup { destroy .e } -returnCodes error -result {bad entry index "foo"} test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} -setup { - entry .e + entry .e } -body { .e delete 0 bar } -cleanup { @@ -856,7 +873,7 @@ test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} -setup { test entry-3.22 {EntryWidgetCmd procedure, "delete" widget command} -setup { entry .e pack .e - update + update } -body { .e insert end "01234567890" .e delete 2 4 @@ -865,7 +882,7 @@ test entry-3.22 {EntryWidgetCmd procedure, "delete" widget command} -setup { destroy .e } -result {014567890} test entry-3.23 {EntryWidgetCmd procedure, "delete" widget command} -setup { - entry .e + entry .e } -body { .e insert end "01234567890" .e delete 6 @@ -876,7 +893,7 @@ test entry-3.23 {EntryWidgetCmd procedure, "delete" widget command} -setup { test entry-3.24 {EntryWidgetCmd procedure, "delete" widget command} -setup { entry .e pack .e - update + update set x {} } -body { # UTF @@ -897,7 +914,7 @@ test entry-3.24 {EntryWidgetCmd procedure, "delete" widget command} -setup { test entry-3.25 {EntryWidgetCmd procedure, "delete" widget command} -setup { entry .e pack .e - update + update } -body { .e insert end "01234567890" .e delete 6 5 @@ -908,7 +925,7 @@ test entry-3.25 {EntryWidgetCmd procedure, "delete" widget command} -setup { test entry-3.26 {EntryWidgetCmd procedure, "delete" widget command} -setup { entry .e pack .e - update + update } -body { .e insert end "01234567890" .e configure -state disabled @@ -921,7 +938,7 @@ test entry-3.26 {EntryWidgetCmd procedure, "delete" widget command} -setup { test entry-3.26a {EntryWidgetCmd procedure, "delete" widget command} -setup { entry .e pack .e - update + update } -body { .e insert end "01234567890" .e configure -state readonly @@ -932,28 +949,28 @@ test entry-3.26a {EntryWidgetCmd procedure, "delete" widget command} -setup { destroy .e } -result {01234567890} test entry-3.27 {EntryWidgetCmd procedure, "get" widget command} -setup { - entry .e + entry .e } -body { .e get foo } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e get"} test entry-3.28 {EntryWidgetCmd procedure, "icursor" widget command} -setup { - entry .e + entry .e } -body { .e icursor } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e icursor pos"} test entry-3.29 {EntryWidgetCmd procedure, "icursor" widget command} -setup { - entry .e + entry .e } -body { .e icursor foo } -cleanup { destroy .e } -returnCodes error -result {bad entry index "foo"} test entry-3.30 {EntryWidgetCmd procedure, "icursor" widget command} -setup { - entry .e + entry .e } -body { .e insert end "01234567890" .e icursor 4 @@ -962,21 +979,21 @@ test entry-3.30 {EntryWidgetCmd procedure, "icursor" widget command} -setup { destroy .e } -result {4} test entry-3.31 {EntryWidgetCmd procedure, "index" widget command} -setup { - entry .e + entry .e } -body { .e in } -cleanup { destroy .e } -returnCodes error -result {ambiguous option "in": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, validate, or xview} test entry-3.32 {EntryWidgetCmd procedure, "index" widget command} -setup { - entry .e + entry .e } -body { .e index } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e index string"} test entry-3.33 {EntryWidgetCmd procedure, "index" widget command} -setup { - entry .e + entry .e } -body { .e index foo } -cleanup { @@ -985,7 +1002,7 @@ test entry-3.33 {EntryWidgetCmd procedure, "index" widget command} -setup { test entry-3.34 {EntryWidgetCmd procedure, "index" widget command} -setup { entry .e pack .e - update + update } -body { .e index 0 } -cleanup { @@ -994,7 +1011,7 @@ test entry-3.34 {EntryWidgetCmd procedure, "index" widget command} -setup { test entry-3.35 {EntryWidgetCmd procedure, "index" widget command} -setup { entry .e pack .e - update + update } -body { # UTF .e insert 0 abc\u4e4e\u0153def @@ -1003,21 +1020,21 @@ test entry-3.35 {EntryWidgetCmd procedure, "index" widget command} -setup { destroy .e } -result {3 4 8} test entry-3.36 {EntryWidgetCmd procedure, "insert" widget command} -setup { - entry .e + entry .e } -body { .e insert a } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e insert index text"} test entry-3.37 {EntryWidgetCmd procedure, "insert" widget command} -setup { - entry .e + entry .e } -body { .e insert a b c } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e insert index text"} test entry-3.38 {EntryWidgetCmd procedure, "insert" widget command} -setup { - entry .e + entry .e } -body { .e insert foo Text } -cleanup { @@ -1026,7 +1043,7 @@ test entry-3.38 {EntryWidgetCmd procedure, "insert" widget command} -setup { test entry-3.39 {EntryWidgetCmd procedure, "insert" widget command} -setup { entry .e pack .e - update + update } -body { .e insert end "01234567890" .e insert 3 xxx @@ -1037,7 +1054,7 @@ test entry-3.39 {EntryWidgetCmd procedure, "insert" widget command} -setup { test entry-3.40 {EntryWidgetCmd procedure, "insert" widget command} -setup { entry .e pack .e - update + update } -body { .e insert end "01234567890" .e configure -state disabled @@ -1050,7 +1067,7 @@ test entry-3.40 {EntryWidgetCmd procedure, "insert" widget command} -setup { test entry-3.40a {EntryWidgetCmd procedure, "insert" widget command} -setup { entry .e pack .e - update + update } -body { .e insert end "01234567890" .e configure -state readonly @@ -1061,14 +1078,14 @@ test entry-3.40a {EntryWidgetCmd procedure, "insert" widget command} -setup { destroy .e } -result {01234567890} test entry-3.41 {EntryWidgetCmd procedure, "insert" widget command} -setup { - entry .e + entry .e } -body { .e insert a b c } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e insert index text"} test entry-3.42 {EntryWidgetCmd procedure, "scan" widget command} -setup { - entry .e + entry .e pack .e update } -body { @@ -1079,7 +1096,7 @@ test entry-3.42 {EntryWidgetCmd procedure, "scan" widget command} -setup { test entry-3.43 {EntryWidgetCmd procedure, "scan" widget command} -setup { entry .e pack .e - update + update } -body { .e scan a b c } -cleanup { @@ -1088,7 +1105,7 @@ test entry-3.43 {EntryWidgetCmd procedure, "scan" widget command} -setup { test entry-3.44 {EntryWidgetCmd procedure, "scan" widget command} -setup { entry .e pack .e - update + update } -body { .e scan foobar 20 } -cleanup { @@ -1097,7 +1114,7 @@ test entry-3.44 {EntryWidgetCmd procedure, "scan" widget command} -setup { test entry-3.45 {EntryWidgetCmd procedure, "scan" widget command} -setup { entry .e pack .e - update + update } -body { .e scan mark 20.1 } -cleanup { @@ -1108,7 +1125,7 @@ test entry-3.45 {EntryWidgetCmd procedure, "scan" widget command} -setup { test entry-3.46 {EntryWidgetCmd procedure, "scan" widget command} -constraints { fonts } -setup { - entry .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1121,14 +1138,14 @@ test entry-3.46 {EntryWidgetCmd procedure, "scan" widget command} -constraints { destroy .e } -result {2} test entry-3.47 {EntryWidgetCmd procedure, "select" widget command} -setup { - entry .e + entry .e } -body { .e select } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e selection option ?index?"} test entry-3.48 {EntryWidgetCmd procedure, "select" widget command} -setup { - entry .e + entry .e } -body { .e select foo } -cleanup { @@ -1136,28 +1153,28 @@ test entry-3.48 {EntryWidgetCmd procedure, "select" widget command} -setup { } -returnCodes error -result {bad selection option "foo": must be adjust, clear, from, present, range, or to} test entry-3.49 {EntryWidgetCmd procedure, "select clear" widget command} -setup { - entry .e + entry .e } -body { .e select clear gorp } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e selection clear"} test entry-3.50 {EntryWidgetCmd procedure, "select clear" widget command} -setup { - entry .e + entry .e } -body { .e insert end "0123456789" .e select from 1 .e select to 4 update .e select clear - selection get + selection get } -cleanup { destroy .e } -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined} test entry-3.50.1 {EntryWidgetCmd procedure, "select clear" widget command} -setup { entry .e pack .e - update + update } -body { .e insert end "0123456789" .e select from 1 @@ -1171,7 +1188,7 @@ test entry-3.50.1 {EntryWidgetCmd procedure, "select clear" widget command} -set } -result {.e} test entry-3.51 {EntryWidgetCmd procedure, "selection present" widget command} -setup { - entry .e + entry .e } -body { .e selection present foo } -cleanup { @@ -1180,7 +1197,7 @@ test entry-3.51 {EntryWidgetCmd procedure, "selection present" widget command} - test entry-3.52 {EntryWidgetCmd procedure, "selection present" widget command} -setup { entry .e pack .e - update + update } -body { .e insert end 0123456789 .e select from 3 @@ -1192,7 +1209,7 @@ test entry-3.52 {EntryWidgetCmd procedure, "selection present" widget command} - test entry-3.53 {EntryWidgetCmd procedure, "selection present" widget command} -setup { entry .e pack .e - update + update } -body { .e insert end 0123456789 .e select from 3 @@ -1205,7 +1222,7 @@ test entry-3.53 {EntryWidgetCmd procedure, "selection present" widget command} - test entry-3.54 {EntryWidgetCmd procedure, "selection present" widget command} -setup { entry .e pack .e - update + update } -body { .e insert end 0123456789 .e select from 3 @@ -1344,7 +1361,7 @@ test entry-3.64b {EntryWidgetCmd procedure, "selection to" widget command} -setu } -returnCodes error -result {wrong # args: should be ".e selection to index"} test entry-3.65 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1356,7 +1373,7 @@ test entry-3.65 {EntryWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -result {0.0537634 0.2688172} test entry-3.66 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1365,7 +1382,7 @@ test entry-3.66 {EntryWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -returnCodes error -result {bad entry index "gorp"} test entry-3.67 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1379,7 +1396,7 @@ test entry-3.67 {EntryWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -result {0.107527 0.322581} test entry-3.68 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1388,7 +1405,7 @@ test entry-3.68 {EntryWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -returnCodes error -result {wrong # args: should be ".e xview moveto fraction"} test entry-3.69 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1397,7 +1414,7 @@ test entry-3.69 {EntryWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -returnCodes error -result {expected floating-point number but got "foo"} test entry-3.70 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1409,7 +1426,7 @@ test entry-3.70 {EntryWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -result {0.505376 0.720430} test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1418,9 +1435,9 @@ test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} -setup { .e xview scroll 24 } -cleanup { destroy .e -} -returnCodes error -result {wrong # args: should be ".e xview scroll number units|pages"} +} -returnCodes error -result {wrong # args: should be ".e xview scroll number pages|units"} test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1431,7 +1448,7 @@ test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -returnCodes error -result {expected integer but got "gorp"} test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1444,7 +1461,7 @@ test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -result {0.193548 0.408602} test entry-3.74 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1458,7 +1475,7 @@ test entry-3.74 {EntryWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -result {0.397849 0.612903} test entry-3.75 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1466,13 +1483,13 @@ test entry-3.75 {EntryWidgetCmd procedure, "xview" widget command} -setup { update .e xview 30 update - .e xview scroll 2 units + .e xview scroll 2 units .e index @0 } -cleanup { destroy .e } -result {32} test entry-3.76 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1480,13 +1497,13 @@ test entry-3.76 {EntryWidgetCmd procedure, "xview" widget command} -setup { update .e xview 30 update - .e xview scroll -1 units + .e xview scroll -1 units .e index @0 } -cleanup { destroy .e } -result {29} test entry-3.77 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1495,9 +1512,9 @@ test entry-3.77 {EntryWidgetCmd procedure, "xview" widget command} -setup { .e xview scroll 23 foobars } -cleanup { destroy .e -} -returnCodes error -result {bad argument "foobars": must be units or pages} +} -returnCodes error -result {bad argument "foobars": must be pages or units} test entry-3.78 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1508,7 +1525,7 @@ test entry-3.78 {EntryWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -returnCodes error -result {unknown option "eat": must be moveto or scroll} test entry-3.79 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1522,7 +1539,7 @@ test entry-3.79 {EntryWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -result {0} test entry-3.80 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1534,7 +1551,7 @@ test entry-3.80 {EntryWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -result {73} test entry-3.86 {EntryWidgetCmd procedure, "xview" widget command} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1556,7 +1573,7 @@ test entry-3.86 {EntryWidgetCmd procedure, "xview" widget command} -setup { } -result {0.095745 0.106383 0.117021} test entry-3.82 {EntryWidgetCmd procedure} -setup { - entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1615,7 +1632,7 @@ test entry-5.4 {ConfigureEntry procedure, -textvariable} -setup { } -cleanup { destroy .e trace vdelete x w override - unset x; + unset x; } -result {12345 12345} test entry-5.5 {ConfigureEntry procedure} -setup { @@ -1640,14 +1657,14 @@ test entry-5.5 {ConfigureEntry procedure} -setup { destroy .e1 .e2 } -result {{This is so} {This is so} 1234} test entry-5.6 {ConfigureEntry procedure} -setup { - entry .e + entry .e pack .e } -body { .e insert end "0123456789" .e select from 1 .e select to 5 .e configure -exportselection 0 - selection get + selection get } -cleanup { destroy .e } -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined} @@ -1659,14 +1676,14 @@ test entry-5.6.1 {ConfigureEntry procedure} -setup { .e select from 1 .e select to 5 .e configure -exportselection 0 - catch {selection get} + catch {selection get} list [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {1 5} test entry-5.7 {ConfigureEntry procedure} -setup { - entry .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2 + entry .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e configure -font {Courier -12} -width 4 -xscrollcommand scroll @@ -1684,7 +1701,7 @@ test entry-5.7 {ConfigureEntry procedure} -setup { test entry-5.8 {ConfigureEntry procedure} -constraints { fonts } -setup { - entry .e -borderwidth 2 -highlightthickness 2 + entry .e -borderwidth 2 -highlightthickness 2 pack .e } -body { .e configure -width 0 -font {Helvetica -12} @@ -1739,7 +1756,7 @@ test entry-5.11 {ConfigureEntry procedure} -setup { test entry-6.1 {EntryComputeGeometry procedure} -constraints { fonts } -setup { - entry .e + entry .e pack .e } -body { .e configure -font {Courier -12} -bd 2 -relief raised -width 20 \ @@ -1753,7 +1770,7 @@ test entry-6.1 {EntryComputeGeometry procedure} -constraints { test entry-6.2 {EntryComputeGeometry procedure} -constraints { fonts } -setup { - entry .e + entry .e pack .e } -body { .e configure -font {Courier -12} -bd 2 -relief raised -width 20 \ @@ -1767,7 +1784,7 @@ test entry-6.2 {EntryComputeGeometry procedure} -constraints { test entry-6.3 {EntryComputeGeometry procedure} -constraints { fonts } -setup { - entry .e + entry .e pack .e } -body { .e configure -font {Courier -12} -bd 2 -relief raised -width 20 \ @@ -1779,7 +1796,7 @@ test entry-6.3 {EntryComputeGeometry procedure} -constraints { destroy .e } -result {3 4} test entry-6.4 {EntryComputeGeometry procedure} -setup { - entry .e + entry .e pack .e } -body { .e configure -font {Courier -12} -bd 2 -relief raised -width 5 @@ -1794,7 +1811,7 @@ test entry-6.5 {EntryComputeGeometry procedure} -setup { entry .e -highlightthickness 2 pack .e } -body { - .e configure -font {Courier -12} -bd 2 -relief raised -width 5 + .e configure -font {Courier -12} -bd 2 -relief raised -width 5 .e insert end "01234567890" update .e xview 7 @@ -1808,7 +1825,7 @@ test entry-6.6 {EntryComputeGeometry procedure} -constraints { entry .e -highlightthickness 2 pack .e } -body { - .e configure -font {Courier -12} -bd 2 -relief raised -width 10 + .e configure -font {Courier -12} -bd 2 -relief raised -width 10 .e insert end "01234\t67890" update .e xview 3 @@ -1848,14 +1865,14 @@ test entry-6.9 {EntryComputeGeometry procedure} -constraints { entry .e -highlightthickness 2 pack .e } -body { - .e configure -font {Helvetica -24} -bd 3 -relief raised -width 0 + .e configure -font {Helvetica -24} -bd 3 -relief raised -width 0 update list [winfo reqwidth .e] [winfo reqheight .e] } -cleanup { destroy .e } -result {25 39} test entry-6.10 {EntryComputeGeometry procedure} -constraints { - unix fonts + unix fonts } -setup { entry .e -highlightthickness 2 -font {Helvetica -12} pack .e @@ -1910,7 +1927,7 @@ test entry-6.12 {EntryComputeGeometry procedure} -constraints { test entry-7.1 {InsertChars procedure} -setup { - unset -nocomplain contents + unset -nocomplain contents entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e @@ -1927,8 +1944,8 @@ test entry-7.1 {InsertChars procedure} -setup { } -result {abXXXcde abXXXcde {0.000000 1.000000}} test entry-7.2 {InsertChars procedure} -setup { - unset -nocomplain contents - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + unset -nocomplain contents + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -1999,7 +2016,7 @@ test entry-7.6 {InsertChars procedure} -setup { destroy .e } -result {2 6 2 5} test entry-7.7 {InsertChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e } -body { .e configure -xscrollcommand scroll @@ -2011,7 +2028,7 @@ test entry-7.7 {InsertChars procedure} -setup { destroy .e } -result {7} test entry-7.8 {InsertChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e } -body { .e insert 0 0123456789 @@ -2022,7 +2039,7 @@ test entry-7.8 {InsertChars procedure} -setup { destroy .e } -result {4} test entry-7.9 {InsertChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e } -body { .e insert 0 "This is a very long string" @@ -2034,7 +2051,7 @@ test entry-7.9 {InsertChars procedure} -setup { destroy .e } -result {7} test entry-7.10 {InsertChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e } -body { .e insert 0 "This is a very long string" @@ -2049,7 +2066,7 @@ test entry-7.10 {InsertChars procedure} -setup { test entry-7.11 {InsertChars procedure} -constraints { fonts } -setup { - entry .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e } -body { .e insert 0 "xyzzy" @@ -2062,7 +2079,7 @@ test entry-7.11 {InsertChars procedure} -constraints { test entry-8.1 {DeleteChars procedure} -setup { unset -nocomplain contents - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2078,7 +2095,7 @@ test entry-8.1 {DeleteChars procedure} -setup { } -result {abe abe {0.000000 1.000000}} test entry-8.2 {DeleteChars procedure} -setup { unset -nocomplain contents - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2094,7 +2111,7 @@ test entry-8.2 {DeleteChars procedure} -setup { } -result {cde cde {0.000000 1.000000}} test entry-8.3 {DeleteChars procedure} -setup { unset -nocomplain contents - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2109,7 +2126,7 @@ test entry-8.3 {DeleteChars procedure} -setup { after cancel $timeout } -result {abc abc {0.000000 1.000000}} test entry-8.4 {DeleteChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2125,7 +2142,7 @@ test entry-8.4 {DeleteChars procedure} -setup { destroy .e } -result {1 6 1 5} test entry-8.5 {DeleteChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2141,7 +2158,7 @@ test entry-8.5 {DeleteChars procedure} -setup { destroy .e } -result {1 5 1 4} test entry-8.6 {DeleteChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2157,7 +2174,7 @@ test entry-8.6 {DeleteChars procedure} -setup { destroy .e } -result {1 2 1 5} test entry-8.7 {DeleteChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2171,7 +2188,7 @@ test entry-8.7 {DeleteChars procedure} -setup { destroy .e } -returnCodes error -result {selection isn't in widget .e} test entry-8.8 {DeleteChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2187,7 +2204,7 @@ test entry-8.8 {DeleteChars procedure} -setup { destroy .e } -result {3 4 3 8} test entry-8.9 {DeleteChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e } -body { .e insert 0 0123456789abcde @@ -2200,7 +2217,7 @@ test entry-8.9 {DeleteChars procedure} -setup { destroy .e } -returnCodes error -result {selection isn't in widget .e} test entry-8.10 {DeleteChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2216,7 +2233,7 @@ test entry-8.10 {DeleteChars procedure} -setup { destroy .e } -result {3 5 5 8} test entry-8.11 {DeleteChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2232,7 +2249,7 @@ test entry-8.11 {DeleteChars procedure} -setup { destroy .e } -result {3 8 4 8} test entry-8.12 {DeleteChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2245,7 +2262,7 @@ test entry-8.12 {DeleteChars procedure} -setup { destroy .e } -result {1} test entry-8.13 {DeleteChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2258,7 +2275,7 @@ test entry-8.13 {DeleteChars procedure} -setup { destroy .e } -result {1} test entry-8.14 {DeleteChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2271,7 +2288,7 @@ test entry-8.14 {DeleteChars procedure} -setup { destroy .e } -result {4} test entry-8.15 {DeleteChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2284,7 +2301,7 @@ test entry-8.15 {DeleteChars procedure} -setup { destroy .e } -result {1} test entry-8.16 {DeleteChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2297,7 +2314,7 @@ test entry-8.16 {DeleteChars procedure} -setup { destroy .e } -result {1} test entry-8.17 {DeleteChars procedure} -setup { - entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2310,17 +2327,27 @@ test entry-8.17 {DeleteChars procedure} -setup { destroy .e } -result {4} test entry-8.18 {DeleteChars procedure} -setup { - entry .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2 + entry .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { .e insert 0 "xyzzy" update .e delete 2 4 - winfo reqwidth .e -} -cleanup { - destroy .e -} -result {31} + # To check that deletion actually happened we measure the new width + # of the widget, based on the measuring width of the remaining text ("xyy") + # in the widget. For that purpose we have to mirror the code in tkEntry.c + # for computation of the reqwidth + # note: XPAD corresponds to the hardcoded #define XPAD 1 + set XPAD 1 + set expected [expr { [font measure [.e cget -font] "xyy"] \ + + 2 * ( [.e cget -borderwidth] + \ + [.e cget -highlightthickness] + $XPAD ) } ] + expr {[winfo reqwidth .e] == $expected} +} -cleanup { + destroy .e + unset XPAD expected +} -result {1} test entry-9.1 {EntryValueChanged procedure} -setup { unset -nocomplain x @@ -2341,7 +2368,7 @@ test entry-10.1 {EntrySetValue procedure} -constraints fonts -body { set y ab entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 -width 0 pack .e - .e configure -textvariable x + .e configure -textvariable x .e configure -textvariable y update list [.e get] [winfo reqwidth .e] @@ -2350,7 +2377,7 @@ test entry-10.1 {EntrySetValue procedure} -constraints fonts -body { } -result {ab 24} test entry-10.2 {EntrySetValue procedure, updating selection} -setup { unset -nocomplain x - entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 + entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 pack .e } -body { .e configure -textvariable x @@ -2363,7 +2390,7 @@ test entry-10.2 {EntrySetValue procedure, updating selection} -setup { } -returnCodes error -result {selection isn't in widget .e} test entry-10.3 {EntrySetValue procedure, updating selection} -setup { unset -nocomplain x - entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 + entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 pack .e } -body { .e configure -textvariable x @@ -2376,7 +2403,7 @@ test entry-10.3 {EntrySetValue procedure, updating selection} -setup { } -result {4 7} test entry-10.4 {EntrySetValue procedure, updating selection} -setup { unset -nocomplain x - entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 + entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 pack .e } -body { .e configure -textvariable x @@ -2389,7 +2416,7 @@ test entry-10.4 {EntrySetValue procedure, updating selection} -setup { } -result {4 10} test entry-10.5 {EntrySetValue procedure, updating display position} -setup { unset -nocomplain x - entry .e -highlightthickness 2 -bd 2 + entry .e -highlightthickness 2 -bd 2 pack .e } -body { .e configure -width 10 -font {Courier -12} -textvariable x @@ -2404,7 +2431,7 @@ test entry-10.5 {EntrySetValue procedure, updating display position} -setup { } -result {0} test entry-10.6 {EntrySetValue procedure, updating display position} -setup { unset -nocomplain x - entry .e -highlightthickness 2 -bd 2 + entry .e -highlightthickness 2 -bd 2 pack .e } -body { .e configure -width 10 -font {Courier -12} -textvariable x @@ -2420,7 +2447,7 @@ test entry-10.6 {EntrySetValue procedure, updating display position} -setup { } -result {10} test entry-10.7 {EntrySetValue procedure, updating insertion cursor} -setup { unset -nocomplain x - entry .e -highlightthickness 2 -bd 2 + entry .e -highlightthickness 2 -bd 2 pack .e update } -body { @@ -2435,7 +2462,7 @@ test entry-10.7 {EntrySetValue procedure, updating insertion cursor} -setup { } -result {3} test entry-10.8 {EntrySetValue procedure, updating insertion cursor} -setup { unset -nocomplain x - entry .e -highlightthickness 2 -bd 2 + entry .e -highlightthickness 2 -bd 2 pack .e } -body { .e configure -width 10 -font {Courier -12} -textvariable x @@ -2492,7 +2519,7 @@ test entry-13.1 {GetEntryIndex procedure} -setup { destroy .e } -result {21} test entry-13.2 {GetEntryIndex procedure} -body { - entry .e + entry .e .e index abogus } -cleanup { destroy .e @@ -2583,7 +2610,7 @@ test entry-13.9 {GetEntryIndex procedure} -setup { test entry-13.10 {GetEntryIndex procedure} -constraints x11 -body { -# On unix, when selection is cleared, entry widget's internal +# On unix, when selection is cleared, entry widget's internal # selection range is reset. # Previous settings: entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken @@ -2603,7 +2630,7 @@ test entry-13.10 {GetEntryIndex procedure} -constraints x11 -body { test entry-13.11 {GetEntryIndex procedure} -constraints aquaOrWin32 -body { # On mac and pc, when selection is cleared, entry widget remembers -# last selected range. When selection ownership is restored to +# last selected range. When selection ownership is restored to # entry, the old range will be rehighlighted. # Previous settings: entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken @@ -2620,7 +2647,7 @@ test entry-13.11 {GetEntryIndex procedure} -constraints aquaOrWin32 -body { .e index sel.first } -cleanup { destroy .e -} -result {1} +} -result {1} test entry-13.12 {GetEntryIndex procedure} -constraints x11 -body { # Previous settings: @@ -2639,7 +2666,7 @@ test entry-13.12 {GetEntryIndex procedure} -constraints x11 -body { destroy .e } -returnCodes error -result {selection isn't in widget .e} -# why when string in .e index changed to not beginning with s, +# why when string in .e index changed to not beginning with s, # it behaves differently? test entry-13.12.1 {GetEntryIndex procedure} -constraints unix -body { # Previous settings: @@ -2677,7 +2704,7 @@ test entry-13.13 {GetEntryIndex procedure} -constraints win -body { test entry-13.14 {GetEntryIndex procedure} -constraints win -body { # On mac and pc, when selection is cleared, entry widget remembers -# last selected range. When selection ownership is restored to +# last selected range. When selection ownership is restored to # entry, the old range will be rehighlighted. # Previous settings: entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken @@ -2690,14 +2717,14 @@ test entry-13.14 {GetEntryIndex procedure} -constraints win -body { list [.e index sel.first] [.e index sel.last] # Testing: selection clear .e - selection get + selection get } -cleanup { destroy .e } -returnCodes error -match glob -result {*} test entry-13.14.1 {GetEntryIndex procedure} -constraints win -body { # On mac and pc, when selection is cleared, entry widget remembers -# last selected range. When selection ownership is restored to +# last selected range. When selection ownership is restored to # entry, the old range will be rehighlighted. # Previous settings: entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken @@ -2709,9 +2736,9 @@ test entry-13.14.1 {GetEntryIndex procedure} -constraints win -body { .e select to 6 list [.e index sel.first] [.e index sel.last] # Testing: - selection clear .e - catch {selection get} - .e index sbogus + selection clear .e + catch {selection get} + .e index sbogus } -cleanup { destroy .e } -returnCodes error -match glob -result {*} @@ -2726,7 +2753,7 @@ test entry-13.15 {GetEntryIndex procedure} -body { test entry-13.16 {GetEntryIndex procedure} -constraints fonts -body { entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\ - -font {Courier -12} + -font {Courier -12} pack .e .e insert 0 012345678901234567890 .e xview 4 @@ -2759,7 +2786,7 @@ test entry-13.18 {GetEntryIndex procedure} -constraints fonts -body { } -result {5} test entry-13.19 {GetEntryIndex procedure} -constraints fonts -body { entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\ - -font {Courier -12} + -font {Courier -12} pack .e .e insert 0 012345678901234567890 .e xview 4 @@ -2791,7 +2818,7 @@ test entry-13.21 {GetEntryIndex procedure} -body { destroy .e } -result {9} test entry-13.22 {GetEntryIndex procedure} -setup { - entry .e + entry .e pack .e update } -body { @@ -2801,7 +2828,7 @@ test entry-13.22 {GetEntryIndex procedure} -setup { } -returnCodes error -result {bad entry index "1xyz"} test entry-13.23 {GetEntryIndex procedure} -body { entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\ - -font {Courier -12} + -font {Courier -12} pack .e .e insert 0 012345678901234567890 .e xview 4 @@ -2812,7 +2839,7 @@ test entry-13.23 {GetEntryIndex procedure} -body { } -result {0} test entry-13.24 {GetEntryIndex procedure} -body { entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\ - -font {Courier -12} + -font {Courier -12} pack .e .e insert 0 012345678901234567890 .e xview 4 @@ -2823,7 +2850,7 @@ test entry-13.24 {GetEntryIndex procedure} -body { } -result {12} test entry-13.25 {GetEntryIndex procedure} -body { entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\ - -font {Courier -12} + -font {Courier -12} pack .e .e insert 0 012345678901234567890 .e xview 4 @@ -2872,7 +2899,7 @@ test entry-14.3 {EntryFetchSelection procedure} -setup { } } -body { entry .e - .e insert end $x + .e insert end $x .e select from 0 .e select to end string compare [selection get] $x @@ -2899,7 +2926,7 @@ test entry-16.1 {EntryVisibleRange procedure} -constraints fonts -body { entry .e -width 10 -font {Helvetica -12} pack .e update - .e insert 0 "............................." + .e insert 0 "............................." format {%.6f %.6f} {*}[.e xview] } -cleanup { destroy .e @@ -2998,7 +3025,7 @@ test entry-18.1 {Entry widget vs hiding} -setup { set res1 [list [winfo children .] [interp hidden]] set res2 [list {} $l] expr {$res1 == $res2} -} -result {1} +} -result {1} ## ## Entry widget VALIDATION tests @@ -3352,7 +3379,7 @@ test entry-19.19 {entry widget validation} -setup { -background red -foreground white pack .e set ::e nextdata ;# previous settings - + .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] .e validate list [.e cget -validate] [.e get] $::vVals @@ -3377,7 +3404,7 @@ test entry-19.20 {entry widget validation} -setup { set ::e nextdata ;# previous settings .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] ;# prev .e validate ;# previous settings - + .e configure -validate all set ::e testdata list [.e cget -validate] [.e get] $::e $::vVals diff --git a/tests/event.test b/tests/event.test index a95815e..b4d2ce9 100644 --- a/tests/event.test +++ b/tests/event.test @@ -111,7 +111,7 @@ proc _keypress_lookup {char} { } } -# Lookup and generate a pair of KeyPress and KeyRelease events +# Lookup and generate a pair of Key and KeyRelease events proc _keypress {win key} { set keysym [_keypress_lookup $key] @@ -124,7 +124,7 @@ proc _keypress {win key} { if {[focus] != $win} { focus -force $win } - event generate $win <KeyPress-$keysym> + event generate $win <Key-$keysym> _pause 50 if {[focus] != $win} { focus -force $win @@ -194,10 +194,10 @@ test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} -setup update bind .b <Destroy> { lappend x destroy - event generate .b <1> + event generate .b <Button-1> event generate .b <ButtonRelease-1> } - bind .b <1> { + bind .b <Button-1> { lappend x button } @@ -245,7 +245,7 @@ test event-2.2(keypress) {type into entry widget and then delete some text} -set set e [entry $t.e] pack $e tkwait visibility $e - # Avoid a hang when macOS puts the mouse pointer on the green button + # Avoid a hang when macOS puts the mouse pointer on the green button wm geometry .t +200+100 _keypress_string $e MELLO _keypress $e BackSpace @@ -269,7 +269,7 @@ test event-2.3(keypress) {type into entry widget, triple click, hit Delete key, event generate $e <Enter> for {set i 0} {$i < 3} {incr i} { _pause 100 - event generate $e <ButtonPress-1> + event generate $e <Button-1> _pause 100 event generate $e <ButtonRelease-1> } @@ -323,7 +323,7 @@ test event-2.6(keypress) {type into text widget, triple click, event generate $e <Enter> for {set i 0} {$i < 3} {incr i} { _pause 100 - event generate $e <ButtonPress-1> + event generate $e <Button-1> _pause 100 event generate $e <ButtonRelease-1> } @@ -355,11 +355,11 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests # Click down to set the insert cursor position event generate $e <Enter> - event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y + event generate $e <Button-1> -x $anchor_x -y $anchor_y # Save the position of the insert cursor lappend result [$e index insert] - + # Now drag until selend is highlighted, then click up set current $anchor @@ -381,7 +381,7 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests # Now click and click and drag to the left, over "Tcl/Tk selection" - event generate $e <ButtonPress-1> -x $current_x -y $current_y + event generate $e <Button-1> -x $current_x -y $current_y while {[$e compare $current >= [list $anchor - 4 char]]} { foreach {current_x current_y} [_text_ind_to_x_y $e $current] break @@ -422,11 +422,11 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests # Click down to set the insert cursor position event generate $e <Enter> - event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y + event generate $e <Button-1> -x $anchor_x -y $anchor_y # Save the position of the insert cursor lappend result [$e index insert] - + # Now drag until selend is highlighted, then click up set current $anchor @@ -448,7 +448,7 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests # Now click and click and drag to the left, over "Tcl/Tk selection" - event generate $e <ButtonPress-1> -x $current_x -y $current_y + event generate $e <Button-1> -x $current_x -y $current_y while {$current >= ($anchor - 4)} { foreach {current_x current_y} [_text_ind_to_x_y $e $current] break @@ -487,11 +487,11 @@ test event-4.1(double-click-drag) {click down, click up, click down again, # Click down, release, then click down again event generate $e <Enter> - event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y + event generate $e <Button-1> -x $anchor_x -y $anchor_y _pause 50 event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y _pause 50 - event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y + event generate $e <Button-1> -x $anchor_x -y $anchor_y _pause 50 # Save the highlighted text @@ -558,11 +558,11 @@ test event-4.2(double-click-drag) {click down, click up, click down again, # Click down, release, then click down again event generate $e <Enter> - event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y + event generate $e <Button-1> -x $anchor_x -y $anchor_y _pause 50 event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y _pause 50 - event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y + event generate $e <Button-1> -x $anchor_x -y $anchor_y _pause 50 set result [list] @@ -612,7 +612,7 @@ test event-4.2(double-click-drag) {click down, click up, click down again, deleteWindows } -result {select 11 7 select 4 { select} {Word select} 2} -test event-5.1(triple-click-drag) {Triple click and drag across lines in a +test event-5.1(triple-click-drag) {Triple click and drag across lines in a text widget, this should extend the selection to the new line} -setup { deleteWindows } -body { @@ -630,17 +630,17 @@ test event-5.1(triple-click-drag) {Triple click and drag across lines in a event generate $e <Enter> - event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y + event generate $e <Button-1> -x $anchor_x -y $anchor_y _pause 50 event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y _pause 50 - event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y + event generate $e <Button-1> -x $anchor_x -y $anchor_y _pause 50 event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y _pause 50 - event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y + event generate $e <Button-1> -x $anchor_x -y $anchor_y _pause 50 set result [list] @@ -680,7 +680,7 @@ test event-6.1(button-state) {button press in a window that is then } -body { set t [toplevel .t] - event generate $t <ButtonPress-1> + event generate $t <Button-1> destroy $t set t [toplevel .t] set motion nomotion @@ -719,11 +719,11 @@ test event-7.1(double-click) {A double click on a lone character # Double click near left hand egde of the letter A event generate $e <Enter> - event generate $e <ButtonPress-1> -x $left_x -y $left_y + event generate $e <Button-1> -x $left_x -y $left_y _pause 50 event generate $e <ButtonRelease-1> -x $left_x -y $left_y _pause 50 - event generate $e <ButtonPress-1> -x $left_x -y $left_y + event generate $e <Button-1> -x $left_x -y $left_y _pause 50 event generate $e <ButtonRelease-1> -x $left_x -y $left_y _pause 50 @@ -734,18 +734,18 @@ test event-7.1(double-click) {A double click on a lone character # Clear selection by clicking at 0,0 - event generate $e <ButtonPress-1> -x 0 -y 0 + event generate $e <Button-1> -x 0 -y 0 _pause 50 event generate $e <ButtonRelease-1> -x 0 -y 0 _pause 50 # Double click near right hand edge of the letter A - event generate $e <ButtonPress-1> -x $right_x -y $right_y + event generate $e <Button-1> -x $right_x -y $right_y _pause 50 event generate $e <ButtonRelease-1> -x $right_x -y $right_y _pause 50 - event generate $e <ButtonPress-1> -x $right_x -y $right_y + event generate $e <Button-1> -x $right_x -y $right_y _pause 50 event generate $e <ButtonRelease-1> -x $right_x -y $right_y _pause 50 @@ -785,11 +785,11 @@ test event-7.2(double-click) {A double click on a lone character # Double click near left hand egde of the letter A event generate $e <Enter> - event generate $e <ButtonPress-1> -x $left_x -y $left_y + event generate $e <Button-1> -x $left_x -y $left_y _pause 50 event generate $e <ButtonRelease-1> -x $left_x -y $left_y _pause 50 - event generate $e <ButtonPress-1> -x $left_x -y $left_y + event generate $e <Button-1> -x $left_x -y $left_y _pause 50 event generate $e <ButtonRelease-1> -x $left_x -y $left_y _pause 50 @@ -797,21 +797,21 @@ test event-7.2(double-click) {A double click on a lone character set result [list] lappend result [$e index insert] lappend result [_get_selection $e] - + # Clear selection by clicking at 0,0 - event generate $e <ButtonPress-1> -x 0 -y 0 + event generate $e <Button-1> -x 0 -y 0 _pause 50 event generate $e <ButtonRelease-1> -x 0 -y 0 _pause 50 # Double click near right hand edge of the letter A - event generate $e <ButtonPress-1> -x $right_x -y $right_y + event generate $e <Button-1> -x $right_x -y $right_y _pause 50 event generate $e <ButtonRelease-1> -x $right_x -y $right_y _pause 50 - event generate $e <ButtonPress-1> -x $right_x -y $right_y + event generate $e <Button-1> -x $right_x -y $right_y _pause 50 event generate $e <ButtonRelease-1> -x $right_x -y $right_y _pause 50 @@ -825,7 +825,7 @@ test event-7.2(double-click) {A double click on a lone character } -result {4 A 4 A} test event-8 {event generate with keysyms corresponding to - multi-byte virtual keycodes - bug + multi-byte virtual keycodes - bug e36963bfe8df9f5e528134707a91b9c0051de723} -constraints nonPortable -setup { deleteWindows set res [list ] @@ -834,7 +834,7 @@ test event-8 {event generate with keysyms corresponding to set e [entry $t.e] pack $e tkwait visibility $e - bind $e <KeyPress> {lappend res keycode: %k keysym: %K} + bind $e <Key> {lappend res keycode: %k keysym: %K} focus -force $e update event generate $e <diaeresis> diff --git a/tests/filebox.test b/tests/filebox.test index 0114a07..ee00160 100644 --- a/tests/filebox.test +++ b/tests/filebox.test @@ -48,7 +48,7 @@ proc ToEnterFileByKey {parent fileName fileDir} { proc PressButton {btn} { event generate $btn <Enter> - event generate $btn <1> -x 5 -y 5 + event generate $btn <Button-1> -x 5 -y 5 event generate $btn <ButtonRelease-1> -x 5 -y 5 } @@ -93,7 +93,7 @@ proc SendButtonPress {parent btn type} { event generate $w <Enter> focus $w event generate $button <Enter> - event generate $w <KeyPress> -keysym Return + event generate $w <Key> -keysym Return } } @@ -167,7 +167,7 @@ foreach mode $modes { catch {tk_getOpenFile -foo 1} msg regsub -all , $msg "" options regsub \"-foo\" $options "" options - + foreach option $options { if {[string index $option 0] eq "-"} { test filebox-1.2-$mode$option "tk_getOpenFile command" -body { diff --git a/tests/focus.test b/tests/focus.test index 7a7e5ef..7da289d 100644 --- a/tests/focus.test +++ b/tests/focus.test @@ -64,7 +64,7 @@ bind all <FocusIn> { bind all <FocusOut> { append focusInfo "out %W %d\n" } -bind all <KeyPress> { +bind all <Key> { append focusInfo "press %W %K" } focusSetup @@ -104,7 +104,7 @@ test focus-1.7 {Tk_FocusCmd procedure} -constraints unix -body { focus .gorp a } -returnCodes error -result {bad option ".gorp": must be -displayof, -force, or -lastfor} test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} -constraints { - unix + unix } -setup { destroy .t2 } -body { @@ -130,29 +130,29 @@ test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} -constraints { destroy .t2 } -result {.t2.f2 .t2 .t2} test focus-1.9 {Tk_FocusCmd procedure, -displayof option} -constraints { - unix + unix } -body { focus -displayof } -returnCodes error -result {wrong # args: should be "focus -displayof window"} test focus-1.10 {Tk_FocusCmd procedure, -displayof option} -constraints { - unix + unix } -body { focus -displayof a b } -returnCodes error -result {wrong # args: should be "focus -displayof window"} test focus-1.11 {Tk_FocusCmd procedure, -displayof option} -constraints { - unix + unix } -body { focus -displayof .lousy } -returnCodes error -result {bad window path name ".lousy"} test focus-1.12 {Tk_FocusCmd procedure, -displayof option} -constraints { - unix + unix } -body { focusClear focus .t focus -displayof .t.b3 } -result {} test focus-1.13 {Tk_FocusCmd procedure, -displayof option} -constraints { - unix + unix } -body { focusClear focus -force .t @@ -185,22 +185,22 @@ test focus-1.19 {Tk_FocusCmd procedure, -force option} -constraints unix -body { lappend x [focus] } -result {{} .t.b1} test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} -constraints { - unix + unix } -body { focus -lastfor } -returnCodes error -result {wrong # args: should be "focus -lastfor window"} test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} -constraints { - unix + unix } -body { focus -lastfor 1 2 } -returnCodes error -result {wrong # args: should be "focus -lastfor window"} test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} -constraints { - unix + unix } -body { focus -lastfor who_knows? } -returnCodes error -result {bad window path name "who_knows?"} test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} -constraints { - unix + unix } -body { focusClear focusSetup @@ -209,7 +209,7 @@ test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} -constraints { list [focus -lastfor .] [focus -lastfor .t.b3] } -result {.b .t.b1} test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} -constraints { - unix + unix } -body { focusClear focusSetup @@ -316,7 +316,7 @@ test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} -constraints { event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor set focusInfo {} set x [focus] - event gen . <KeyPress-x> + event gen . <x> list $x $focusInfo } -result {.t.b1 {press .t.b1 x}} test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} -constraints { @@ -617,7 +617,7 @@ test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} -constr destroy .t bind all <FocusIn> {} bind all <FocusOut> {} -bind all <KeyPress> {} +bind all <Key> {} fixfocus diff --git a/tests/font.test b/tests/font.test index d5b41d9..9f279dd 100644 --- a/tests/font.test +++ b/tests/font.test @@ -12,7 +12,8 @@ eval tcltest::configure $argv tcltest::loadTestedCommands # Some tests require support for 4-byte UTF-8 sequences -testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] +testConstraint fullutf [expr {[format %c 0x010000] != "\uFFFD"}] +testConstraint utfcompat [expr {([string length "\U10000"] == 2) && [package vsatisfies [package provide Tcl] 8]}] set defaultfontlist [font names] @@ -143,7 +144,7 @@ test font-4.9 {font command: actual} -constraints {unix noExceed} -body { test font-4.10 {font command: actual} -constraints win -body { # (objc > 3) so objPtr = objv[3 + skip] font actual {-family times} -family -} -result {Times New Roman} +} -result {times} test font-4.11 {font command: bad option} -body { font actual xyz -style } -returnCodes error -result {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike} @@ -153,15 +154,15 @@ test font-4.12 {font command: actual} -body { test font-4.13 {font command: actual} -body { font actual {-family times} -- \udc00 } -match glob -result {*} -test font-4.14 {font command: actual} -constraints win -body { +test font-4.14 {font command: actual} -constraints {utfcompat win} -body { font actual {-family times} -family -- \uD800\uDC00 -} -result {Times New Roman} +} -result {times} test font-4.15 {font command: actual} -body { font actual {-family times} -- \udc00\ud800 } -returnCodes 1 -match glob -result {expected a single character but got "*"} test font-4.16 {font command: actual} -constraints {fullutf win} -body { font actual {-family times} -family -- \U10000 -} -result {Times New Roman} +} -result {times} test font-5.1 {font command: configure} -body { @@ -2360,7 +2361,7 @@ test font-45.1 {TkFontGetAliasList: no match} -body { } -result [font actual {-size 10} -family] test font-45.2 {TkFontGetAliasList: match} -constraints win -body { font actual {times 10} -family -} -result {Times New Roman} +} -result {times} test font-45.3 {TkFontGetAliasList: match} -constraints {noExceed} -body { if {[font actual {{times new roman} 10} -family] eq "Times New Roman"} { # avoid test failure on systems that have a real "times new roman" font diff --git a/tests/frame.test b/tests/frame.test index 88f74f9..77eae31 100644 --- a/tests/frame.test +++ b/tests/frame.test @@ -1,5 +1,5 @@ -# This file is a Tcl script to test out the "frame" and "toplevel" -# commands of Tk. It is organized in the standard fashion for Tcl +# This file is a Tcl script to test out the "frame", "labelframe" and +# "toplevel" commands of Tk. It is organized in the standard fashion for Tcl # tests. # # Copyright (c) 1994 The Regents of the University of California. @@ -9,12 +9,14 @@ package require tcltest 2.2 namespace import ::tcltest::* -eval tcltest::configure $argv +tcltest::configure {*}$argv tcltest::loadTestedCommands +tcltest::testConstraint x11 [expr {[tk windowingsystem] eq "x11"}] + # eatColors -- -# Creates a toplevel window and allocates enough colors in it to -# use up all the slots in the colormap. +# Creates a toplevel window and allocates enough colors in it to use up all +# the slots in an 8-bit colormap. # # Arguments: # w - Name of toplevel window to create. @@ -27,10 +29,10 @@ proc eatColors {w} { pack $w.c for {set y 0} {$y < 8} {incr y} { for {set x 0} {$x < 40} {incr x} { - set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] - $w.c create rectangle [expr 10*$x] [expr 20*$y] \ - [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ - -fill $color + set color [format #%02x%02x%02x [expr {$x*6}] [expr {$y*30}] 0] + $w.c create rectangle [expr {10*$x}] [expr {20*$y}] \ + [expr {10*$x + 10}] [expr {20*$y + 20}] -outline {} \ + -fill $color } } update @@ -38,8 +40,8 @@ proc eatColors {w} { # colorsFree -- # -# Returns 1 if there appear to be free colormap entries in a window, -# 0 otherwise. +# Returns 1 if there appear to be free colormap entries in a window, 0 +# otherwise. # # Arguments: # w - Name of window in which to check. @@ -47,14 +49,36 @@ proc eatColors {w} { # to see if there are colormap entries free. proc colorsFree {w {red 31} {green 245} {blue 192}} { - set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] - expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ - && ([lindex $vals 2]/256 == $blue) + lassign [winfo rgb $w [format "#%02x%02x%02x" $red $green $blue]] r g b + expr {($r/256 == $red) && ($g/256 == $green) && ($b/256 == $blue)} } +# uniq -- +# +# Returns the unique items of a list in the order they first appear. +# +# Arguments: +# list - The list to uniq-ify. +proc uniq {list} { + set d {} + foreach item $list { + dict set d $item {} + } + return [dict keys $d] +} +# optnames -- +# +# Returns the option names out of a list of option details. +# +# Arguments: +# options - The option detail list. +proc optnames {options} { + lsort [lmap desc $options {lindex $desc 0}] +} + test frame-1.1 {frame configuration options} -setup { - deleteWindows + deleteWindows } -body { frame .f -class NewFrame .f configure -class @@ -66,12 +90,11 @@ test frame-1.2 {frame configuration options} -setup { } -body { frame .f -class NewFrame .f configure -class Different -} -cleanup { +} -returnCodes error -cleanup { deleteWindows -} -returnCodes error -result {can't modify -class option after widget is created} - +} -result {can't modify -class option after widget is created} test frame-1.3 {frame configuration options} -setup { - deleteWindows + deleteWindows } -body { frame .f -colormap new .f configure -colormap @@ -83,12 +106,11 @@ test frame-1.4 {frame configuration options} -setup { } -body { frame .f -colormap new .f configure -colormap . -} -cleanup { +} -returnCodes error -cleanup { deleteWindows -} -returnCodes error -result {can't modify -colormap option after widget is created} - +} -result {can't modify -colormap option after widget is created} test frame-1.5 {frame configuration options} -setup { - deleteWindows + deleteWindows } -body { frame .f -visual default .f configure -visual @@ -100,19 +122,18 @@ test frame-1.6 {frame configuration options} -setup { } -body { frame .f -visual default .f configure -visual best -} -cleanup { +} -returnCodes error -cleanup { deleteWindows -} -returnCodes error -result {can't modify -visual option after widget is created} - +} -result {can't modify -visual option after widget is created} test frame-1.7 {frame configuration options} -setup { - deleteWindows + deleteWindows } -body { frame .f -screen bogus } -cleanup { deleteWindows } -returnCodes error -result {unknown option "-screen"} test frame-1.8 {frame configuration options} -setup { - deleteWindows + deleteWindows } -body { frame .f -container true } -cleanup { @@ -127,22 +148,22 @@ test frame-1.9 {frame configuration options} -setup { deleteWindows } -result {-container container Container 0 1} test frame-1.10 {frame configuration options} -setup { - deleteWindows + deleteWindows } -body { frame .f -container bogus } -cleanup { deleteWindows } -returnCodes error -result {expected boolean value but got "bogus"} test frame-1.11 {frame configuration options} -setup { - deleteWindows + deleteWindows } -body { frame .f .f configure -container 1 -} -cleanup { +} -returnCodes error -cleanup { deleteWindows -} -returnCodes error -result {can't modify -container option after widget is created} +} -result {can't modify -container option after widget is created} test frame-1.12 {frame configuration options} -setup { - deleteWindows + deleteWindows } -body { # Make sure all options can be set to the default value frame .f @@ -152,11 +173,11 @@ test frame-1.12 {frame configuration options} -setup { lappend opts [lindex $opt 0] [lindex $opt 4] } } - eval frame .g $opts - destroy .f .g + frame .g {*}$opts } -cleanup { + destroy .f .g deleteWindows -} -result {} +} -result .g destroy .f frame .f @@ -165,7 +186,7 @@ test frame-1.13 {frame configuration options} -body { lindex [.f configure -background] 4 } -cleanup { .f configure -background [lindex [.f configure -background] 3] -} -result {#ff0000} +} -result "#ff0000" test frame-1.14 {frame configuration options} -body { .f configure -background non-existent } -returnCodes error -result {unknown color name "non-existent"} @@ -183,7 +204,7 @@ test frame-1.17 {frame configuration options} -body { lindex [.f configure -bg] 4 } -cleanup { .f configure -bg [lindex [.f configure -bg] 3] -} -result {#00ff00} +} -result "#00ff00" test frame-1.18 {frame configuration options} -body { .f configure -bg non-existent } -returnCodes error -result {unknown color name "non-existent"} @@ -219,7 +240,7 @@ test frame-1.25 {frame configuration options} -body { lindex [.f configure -highlightbackground] 4 } -cleanup { .f configure -highlightbackground [lindex [.f configure -highlightbackground] 3] -} -result {#112233} +} -result "#112233" test frame-1.26 {frame configuration options} -body { .f configure -highlightbackground ugly } -returnCodes error -result {unknown color name "ugly"} @@ -228,7 +249,7 @@ test frame-1.27 {frame configuration options} -body { lindex [.f configure -highlightcolor] 4 } -cleanup { .f configure -highlightcolor [lindex [.f configure -highlightcolor] 3] -} -result {#123456} +} -result "#123456" test frame-1.28 {frame configuration options} -body { .f configure -highlightcolor non-existent } -returnCodes error -result {unknown color name "non-existent"} @@ -265,9 +286,9 @@ test frame-1.35 {frame configuration options} -body { } -cleanup { .f configure -relief [lindex [.f configure -relief] 3] } -result {ridge} -test frame-1.36 {frame configuration options} -body { +test frame-1.36 {frame configuration options} -returnCodes error -body { .f configure -relief badValue -} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} +} -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} test frame-1.37 {frame configuration options} -body { .f configure -takefocus {any string} lindex [.f configure -takefocus] 4 @@ -285,9 +306,8 @@ test frame-1.39 {frame configuration options} -body { } -returnCodes error -result {bad screen distance "badValue"} destroy .f - test frame-2.1 {toplevel configuration options} -setup { - deleteWindows + deleteWindows } -body { toplevel .t -width 200 -height 100 -class NewClass wm geometry .t +0+0 @@ -301,12 +321,11 @@ test frame-2.2 {toplevel configuration options} -setup { toplevel .t -width 200 -height 100 -class NewClass wm geometry .t +0+0 .t configure -class Another -} -cleanup { +} -returnCodes error -cleanup { deleteWindows -} -returnCodes error -result {can't modify -class option after widget is created} - +} -result {can't modify -class option after widget is created} test frame-2.3 {toplevel configuration options} -setup { - deleteWindows + deleteWindows } -body { toplevel .t -width 200 -height 100 -colormap new wm geometry .t +0+0 @@ -320,23 +339,21 @@ test frame-2.4 {toplevel configuration options} -setup { toplevel .t -width 200 -height 100 -colormap new wm geometry .t +0+0 .t configure -colormap . -} -cleanup { +} -returnCodes error -cleanup { deleteWindows -} -returnCodes error -result {can't modify -colormap option after widget is created} - +} -result {can't modify -colormap option after widget is created} test frame-2.5 {toplevel configuration options} -setup { - deleteWindows + deleteWindows } -body { toplevel .t -width 200 -height 100 wm geometry .t +0+0 .t configure -container 1 -} -cleanup { +} -returnCodes error -cleanup { deleteWindows -} -returnCodes error -result {can't modify -container option after widget is created} +} -result {can't modify -container option after widget is created} test frame-2.6 {toplevel configuration options} -setup { deleteWindows } -body { - catch {destroy .t} toplevel .t -width 200 -height 100 wm geometry .t +0+0 catch {.t configure -container 1} @@ -344,34 +361,25 @@ test frame-2.6 {toplevel configuration options} -setup { } -cleanup { deleteWindows } -result {-container container Container 0 0} - test frame-2.7 {toplevel configuration options} -setup { - deleteWindows + deleteWindows } -body { toplevel .t -width 200 -height 100 -colormap bogus } -cleanup { deleteWindows } -returnCodes error -result {bad window path name "bogus"} - - -test frame-2.8 {toplevel configuration options} -constraints { - win -} -setup { - deleteWindows +test frame-2.8 {toplevel configuration options} -constraints win -setup { + deleteWindows } -body { - catch {destroy .t} toplevel .t -width 200 -height 100 wm geometry .t +0+0 .t configure -use 0x44022 } -cleanup { deleteWindows } -returnCodes error -result {window "0x44022" doesn't exist} -test frame-2.9 {toplevel configuration options} -constraints { - win -} -setup { +test frame-2.9 {toplevel configuration options} -constraints win -setup { deleteWindows } -body { - catch {destroy .t} toplevel .t -width 200 -height 100 wm geometry .t +0+0 catch {.t configure -use 0x44022} @@ -379,25 +387,18 @@ test frame-2.9 {toplevel configuration options} -constraints { } -cleanup { deleteWindows } -result {-use use Use {} {}} - -test frame-2.10 {toplevel configuration options} -constraints { - nonwin -} -setup { +test frame-2.10 {toplevel configuration options} -constraints nonwin -setup { deleteWindows } -body { - catch {destroy .t} toplevel .t -width 200 -height 100 wm geometry .t +0+0 .t configure -use 0x44022 } -cleanup { deleteWindows } -returnCodes error -result {can't modify -use option after widget is created} -test frame-2.11 {toplevel configuration options} -constraints { - nonwin -} -setup { - deleteWindows +test frame-2.11 {toplevel configuration options} -constraints nonwin -setup { + deleteWindows } -body { - catch {destroy .t} toplevel .t -width 200 -height 100 wm geometry .t +0+0 catch {.t configure -use 0x44022} @@ -405,11 +406,9 @@ test frame-2.11 {toplevel configuration options} -constraints { } -cleanup { deleteWindows } -result {-use use Use {} {}} - test frame-2.12 {toplevel configuration options} -setup { - deleteWindows + deleteWindows } -body { - catch {destroy .t} toplevel .t -width 200 -height 100 -visual default wm geometry .t +0+0 .t configure -visual @@ -419,58 +418,59 @@ test frame-2.12 {toplevel configuration options} -setup { test frame-2.13 {toplevel configuration options} -setup { deleteWindows } -body { - catch {destroy .t} toplevel .t -width 200 -height 100 -visual default wm geometry .t +0+0 .t configure -visual best -} -cleanup { +} -returnCodes error -cleanup { deleteWindows -} -returnCodes error -result {can't modify -visual option after widget is created} - +} -result {can't modify -visual option after widget is created} test frame-2.14 {toplevel configuration options} -setup { - deleteWindows + deleteWindows } -body { toplevel .t -width 200 -height 100 -visual who_knows? -} -cleanup { +} -returnCodes error -cleanup { + deleteWindows +} -result {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default} +set expectedScreen "" +if {[tcltest::testConstraint haveDISPLAY]} { + set expectedScreen [list -screen screen Screen {} $env(DISPLAY)] +} +test frame-2.15 {toplevel configuration options} -constraints {x11 haveDISPLAY} -setup { deleteWindows -} -returnCodes error -result {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default} -test frame-2.15 {toplevel configuration options} -constraints haveDISPLAY -setup { - deleteWindows } -body { toplevel .t -width 200 -height 100 -screen $env(DISPLAY) wm geometry .t +0+0 - string compare [.t configure -screen] "-screen screen Screen {} $env(DISPLAY)" + .t configure -screen } -cleanup { deleteWindows -} -result {0} -test frame-2.16 {toplevel configuration options} -constraints haveDISPLAY -setup { +} -result $expectedScreen +test frame-2.16 {toplevel configuration options} -constraints {x11 haveDISPLAY} -setup { deleteWindows } -body { toplevel .t -width 200 -height 100 -screen $env(DISPLAY) wm geometry .t +0+0 .t configure -screen another -} -cleanup { +} -returnCodes error -cleanup { deleteWindows -} -returnCodes error -result {can't modify -screen option after widget is created} - +} -result {can't modify -screen option after widget is created} test frame-2.17 {toplevel configuration options} -setup { - deleteWindows + deleteWindows } -body { toplevel .t -width 200 -height 100 -screen bogus } -cleanup { deleteWindows } -returnCodes error -result {couldn't connect to display "bogus"} test frame-2.18 {toplevel configuration options} -setup { - deleteWindows + deleteWindows } -body { toplevel .t -container 1 -width 300 -height 120 wm geometry .t +0+0 toplevel .x -container 1 -use [winfo id .t] -} -cleanup { +} -returnCodes error -cleanup { deleteWindows -} -returnCodes error -result {windows cannot have both the -use and the -container option set} +} -result {windows cannot have both the -use and the -container option set} test frame-2.19 {toplevel configuration options} -setup { - deleteWindows + deleteWindows set opts {} } -body { # Make sure all options can be set to the default value @@ -480,12 +480,11 @@ test frame-2.19 {toplevel configuration options} -setup { lappend opts [lindex $opt 0] [lindex $opt 4] } } - eval toplevel .g $opts - destroy .f .g + toplevel .g {*}$opts } -cleanup { + destroy .f .g deleteWindows -} -result {} - +} -result .g destroy .t toplevel .t -width 300 -height 150 @@ -494,7 +493,7 @@ update test frame-2.20 {toplevel configuration options} -body { .t configure -background #ff0000 lindex [.t configure -background] 4 -} -result {#ff0000} +} -result "#ff0000" test frame-2.21 {toplevel configuration options} -body { .t configure -background non-existent } -returnCodes error -result {unknown color name "non-existent"} @@ -508,7 +507,7 @@ test frame-2.23 {toplevel configuration options} -body { test frame-2.24 {toplevel configuration options} -body { .t configure -bg #00ff00 lindex [.t configure -bg] 4 -} -result {#00ff00} +} -result "#00ff00" test frame-2.25 {toplevel configuration options} -body { .t configure -bg non-existent } -returnCodes error -result {unknown color name "non-existent"} @@ -536,7 +535,7 @@ test frame-2.31 {toplevel configuration options} -body { test frame-2.32 {toplevel configuration options} -body { .t configure -highlightcolor #123456 lindex [.t configure -highlightcolor] 4 -} -result {#123456} +} -result "#123456" test frame-2.33 {toplevel configuration options} -body { .t configure -highlightcolor non-existent } -returnCodes error -result {unknown color name "non-existent"} @@ -565,9 +564,9 @@ test frame-2.40 {toplevel configuration options} -body { .t configure -relief ridge lindex [.t configure -relief] 4 } -result {ridge} -test frame-2.41 {toplevel configuration options} -body { +test frame-2.41 {toplevel configuration options} -returnCodes error -body { .t configure -relief badValue -} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} +} -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} test frame-2.42 {toplevel configuration options} -body { .t configure -width 32 lindex [.t configure -width] 4 @@ -577,12 +576,11 @@ test frame-2.43 {toplevel configuration options} -body { } -returnCodes error -result {bad screen distance "badValue"} destroy .t - -test frame-3.1 {TkCreateFrame procedure} -body { +test frame-3.1 {TkCreateFrame procedure} -returnCodes error -body { frame -} -returnCodes error -result {wrong # args: should be "frame pathName ?-option value ...?"} +} -result {wrong # args: should be "frame pathName ?-option value ...?"} test frame-3.2 {TkCreateFrame procedure} -setup { - deleteWindows + deleteWindows frame .f } -body { .f configure -class @@ -590,7 +588,7 @@ test frame-3.2 {TkCreateFrame procedure} -setup { deleteWindows } -result {-class class Class Frame Frame} test frame-3.3 {TkCreateFrame procedure} -setup { - deleteWindows + deleteWindows toplevel .t wm geometry .t +0+0 } -body { @@ -599,7 +597,7 @@ test frame-3.3 {TkCreateFrame procedure} -setup { deleteWindows } -result {-class class Class Toplevel Toplevel} test frame-3.4 {TkCreateFrame procedure} -setup { - deleteWindows + deleteWindows } -body { toplevel .t -width 350 -class NewClass -bg black -visual default -height 90 wm geometry .t +0+0 @@ -610,11 +608,10 @@ test frame-3.4 {TkCreateFrame procedure} -setup { } -cleanup { deleteWindows } -result {350 black 90} - # Be sure that the -class, -colormap, and -visual options are processed # before configuring the widget. test frame-3.5 {TkCreateFrame procedure} -setup { - deleteWindows + deleteWindows } -body { option add *NewFrame.background #123456 frame .f -class NewFrame @@ -624,7 +621,7 @@ test frame-3.5 {TkCreateFrame procedure} -setup { option clear } -result {#123456} test frame-3.7 {TkCreateFrame procedure} -setup { - deleteWindows + deleteWindows } -body { option add *NewFrame.background #332211 option add *f.class NewFrame @@ -635,7 +632,7 @@ test frame-3.7 {TkCreateFrame procedure} -setup { option clear } -result {NewFrame #332211} test frame-3.8 {TkCreateFrame procedure} -setup { - deleteWindows + deleteWindows } -body { option add *Silly.background #122334 option add *f.Class Silly @@ -648,7 +645,7 @@ test frame-3.8 {TkCreateFrame procedure} -setup { test frame-3.9 {TkCreateFrame procedure, -use option} -constraints { unix } -setup { - deleteWindows + deleteWindows } -body { toplevel .t -container 1 -width 300 -height 120 wm geometry .t +0+0 @@ -658,11 +655,11 @@ test frame-3.9 {TkCreateFrame procedure, -use option} -constraints { [expr {[winfo rooty .x] - [winfo rooty .t]}] \ [winfo width .t] [winfo height .t] } -cleanup { -# This call to update idletasks was added to prevent a crash that was -# observed on OSX 10.12 (Sierra) only. Any change, such as using the -# Development version to make debugging symbols available, adding a print -# statement, or calling update idletasks here, would make the test pass -# with no segfault. + # This call to update idletasks was added to prevent a crash that was + # observed on OSX 10.12 (Sierra) only. Any change, such as using the + # Development version to make debugging symbols available, adding a print + # statement, or calling update idletasks here, would make the test pass + # with no segfault. update idletasks deleteWindows } -result {0 0 140 300} @@ -685,42 +682,40 @@ test frame-3.10 {TkCreateFrame procedure, -use option} -constraints { destroy .t option clear } -result {0 0 140 300} - -# The tests below require specific display characteristics (i.e. that -# they are run on a pseudocolor display of depth 8). Even so, they -# are non-portable: some machines don't seem to ever run out of -# colors. +# The tests below require specific display characteristics (i.e. that they are +# run on a pseudocolor display of depth 8). Even so, they are non-portable: +# some machines don't seem to ever run out of colors. if {[testConstraint defaultPseudocolor8]} { eatColors .t1 } test frame-3.11 {TkCreateFrame procedure} -constraints { - defaultPseudocolor8 nonPortable + defaultPseudocolor8 nonPortable } -setup { - deleteWindows + destroy .t } -body { toplevel .t -width 300 -height 200 -bg #475601 wm geometry .t +0+0 update colorsFree .t } -cleanup { - deleteWindows + destroy .t } -result {0} test frame-3.12 {TkCreateFrame procedure} -constraints { - defaultPseudocolor8 nonPortable + defaultPseudocolor8 nonPortable } -setup { - deleteWindows + destroy .t } -body { toplevel .t -width 300 -height 200 -bg #475601 -colormap new wm geometry .t +0+0 update colorsFree .t } -cleanup { - deleteWindows + destroy .t } -result {1} test frame-3.13 {TkCreateFrame procedure} -constraints { - defaultPseudocolor8 nonPortable + defaultPseudocolor8 nonPortable } -setup { - deleteWindows + destroy .t } -body { option add *t.class Toplevel2 option add *Toplevel2.colormap new @@ -730,12 +725,12 @@ test frame-3.13 {TkCreateFrame procedure} -constraints { option clear colorsFree .t } -cleanup { - deleteWindows + destroy .t } -result {1} test frame-3.14 {TkCreateFrame procedure} -constraints { - defaultPseudocolor8 nonPortable + defaultPseudocolor8 nonPortable } -setup { - deleteWindows + destroy .t } -body { option add *t.class Toplevel3 option add *Toplevel3.Colormap new @@ -745,12 +740,12 @@ test frame-3.14 {TkCreateFrame procedure} -constraints { option clear colorsFree .t } -cleanup { - deleteWindows + destroy .t } -result {1} test frame-3.15 {TkCreateFrame procedure, -use and -colormap} -constraints { defaultPseudocolor8 unix nonPortable } -setup { - deleteWindows + destroy .t } -body { toplevel .t -container 1 -width 300 -height 120 wm geometry .t +0+0 @@ -761,21 +756,21 @@ test frame-3.15 {TkCreateFrame procedure, -use and -colormap} -constraints { destroy .t } -result {0 1} test frame-3.16 {TkCreateFrame procedure} -constraints { - defaultPseudocolor8 nonPortable + defaultPseudocolor8 nonPortable } -setup { - deleteWindows + destroy .t } -body { toplevel .t -width 300 -height 200 -bg #475601 -visual default wm geometry .t +0+0 update colorsFree .t } -cleanup { - deleteWindows + destroy .t } -result {0} test frame-3.17 {TkCreateFrame procedure} -constraints { - defaultPseudocolor8 nonPortable + defaultPseudocolor8 nonPortable } -setup { - deleteWindows + destroy .t } -body { toplevel .t -width 300 -height 200 -bg #475601 -visual default \ -colormap new @@ -783,24 +778,24 @@ test frame-3.17 {TkCreateFrame procedure} -constraints { update colorsFree .t } -cleanup { - deleteWindows + destroy .t } -result {1} test frame-3.18 {TkCreateFrame procedure} -constraints { - defaultPseudocolor8 haveGrayscale8 nonPortable + defaultPseudocolor8 haveGrayscale8 nonPortable } -setup { - deleteWindows + destroy .t } -body { toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 wm geometry .t +0+0 update colorsFree .t 131 131 131 } -cleanup { - deleteWindows + destroy .t } -result {1} test frame-3.19 {TkCreateFrame procedure} -constraints { - defaultPseudocolor8 haveGrayscale8 nonPortable + defaultPseudocolor8 haveGrayscale8 nonPortable } -setup { - deleteWindows + destroy .t } -body { option add *t.class T4 option add *T4.visual {grayscale 8} @@ -810,14 +805,13 @@ test frame-3.19 {TkCreateFrame procedure} -constraints { option clear list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4] } -cleanup { - deleteWindows + destroy .t } -result {1 {grayscale 8}} test frame-3.20 {TkCreateFrame procedure} -constraints { - defaultPseudocolor8 haveGrayscale8 nonPortable + defaultPseudocolor8 haveGrayscale8 nonPortable } -setup { - deleteWindows + destroy .t } -body { - set x ok option add *t.class T5 option add *T5.Visual {grayscale 8} toplevel .t -width 300 -height 200 -bg #434343 @@ -826,27 +820,25 @@ test frame-3.20 {TkCreateFrame procedure} -constraints { option clear list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4] } -cleanup { - deleteWindows + destroy .t } -result {1 {grayscale 8}} test frame-3.21 {TkCreateFrame procedure} -constraints { - defaultPseudocolor8 haveGrayscale8 nonPortable + defaultPseudocolor8 haveGrayscale8 nonPortable } -setup { - deleteWindows + destroy .t } -body { - set x ok toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 wm geometry .t +0+0 update colorsFree .t 131 131 131 } -cleanup { - deleteWindows + destroy .t } -result {1} if {[testConstraint defaultPseudocolor8]} { destroy .t1 } - test frame-3.22 {TkCreateFrame procedure, default dimensions} -setup { - deleteWindows + deleteWindows } -body { toplevel .t wm geometry .t +0+0 @@ -871,22 +863,20 @@ test frame-3.24 {TkCreateFrame procedure} -setup { wm geometry .t +0+0 } -returnCodes error -result {unknown option "-bogus"} - test frame-4.1 {TkCreateFrame procedure} -setup { - deleteWindows + deleteWindows } -body { catch {frame .f -gorp glob} winfo exists .f } -result 0 test frame-4.2 {TkCreateFrame procedure} -setup { - deleteWindows + deleteWindows } -body { list [frame .f -width 200 -height 100] [winfo exists .f] } -cleanup { deleteWindows } -result {.f 1} - frame .f -highlightcolor black test frame-5.1 {FrameWidgetCommand procedure} -body { .f @@ -914,10 +904,9 @@ test frame-5.7 {FrameWidgetCommand procedure, cget option} -setup { } -cleanup { destroy .t } -returnCodes ok -match glob -result * - test frame-5.8 {FrameWidgetCommand procedure, configure option} -body { - llength [.f configure] -} -result {18} + optnames [.f configure] +} -result {-background -backgroundimage -bd -bg -bgimg -borderwidth -class -colormap -container -cursor -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -tile -visual -width} test frame-5.9 {FrameWidgetCommand procedure, configure option} -body { .f configure -gorp } -returnCodes error -result {unknown option "-gorp"} @@ -931,12 +920,12 @@ test frame-5.12 {FrameWidgetCommand procedure} -body { .f swizzle } -returnCodes error -result {bad option "swizzle": must be cget or configure} test frame-5.13 {FrameWidgetCommand procedure, configure option} -body { - llength [. configure] -} -result {21} + optnames [. configure] +} -result {-background -backgroundimage -bd -bg -bgimg -borderwidth -class -colormap -container -cursor -height -highlightbackground -highlightcolor -highlightthickness -menu -padx -pady -relief -screen -takefocus -tile -use -visual -width} destroy .f test frame-6.1 {ConfigureFrame procedure} -setup { - deleteWindows + deleteWindows } -body { frame .f -width 150 list [winfo reqwidth .f] [winfo reqheight .f] @@ -944,7 +933,7 @@ test frame-6.1 {ConfigureFrame procedure} -setup { deleteWindows } -result {150 1} test frame-6.2 {ConfigureFrame procedure} -setup { - deleteWindows + deleteWindows } -body { frame .f -height 97 list [winfo reqwidth .f] [winfo reqheight .f] @@ -952,7 +941,7 @@ test frame-6.2 {ConfigureFrame procedure} -setup { deleteWindows } -result {1 97} test frame-6.3 {ConfigureFrame procedure} -setup { - deleteWindows + deleteWindows } -body { frame .f set result {} @@ -966,7 +955,7 @@ test frame-6.3 {ConfigureFrame procedure} -setup { } -result {1 1 100 180 100 180} test frame-7.1 {FrameEventProc procedure} -setup { - deleteWindows + deleteWindows } -body { frame .frame2 set result [info commands .frame2] @@ -974,7 +963,7 @@ test frame-7.1 {FrameEventProc procedure} -setup { lappend result [info commands .frame2] } -result {.frame2 {}} test frame-7.2 {FrameEventProc procedure} -setup { - deleteWindows + deleteWindows set x {} } -body { frame .f1 -bg #543210 @@ -988,7 +977,7 @@ test frame-7.2 {FrameEventProc procedure} -setup { } -result {.f1 #543210 {} {}} test frame-8.1 {FrameCmdDeletedProc procedure} -setup { - deleteWindows + deleteWindows } -body { frame .f1 rename .f1 {} @@ -997,7 +986,7 @@ test frame-8.1 {FrameCmdDeletedProc procedure} -setup { deleteWindows } -result {{} {}} test frame-8.2 {FrameCmdDeletedProc procedure} -setup { - deleteWindows + deleteWindows } -body { toplevel .f1 -menu .m wm geometry .f1 +0+0 @@ -1012,7 +1001,6 @@ test frame-8.2 {FrameCmdDeletedProc procedure} -setup { # This one fails with the dash-patch!!!! Still don't know why :-( # #test frame-8.3 {FrameCmdDeletedProc procedure} -setup { -# eval destroy [winfo children .] # deleteWindows #} -body { # toplevel .f1 -menu .m @@ -1023,12 +1011,11 @@ test frame-8.2 {FrameCmdDeletedProc procedure} -setup { # update # list [info command .f*] [winfo children .] #} -cleanup { -# eval destroy [winfo children .] # deleteWindows #} -result {{} .m} test frame-9.1 {MapFrame procedure} -setup { - deleteWindows + deleteWindows } -body { toplevel .t -width 100 -height 400 wm geometry .t +0+0 @@ -1039,7 +1026,7 @@ test frame-9.1 {MapFrame procedure} -setup { deleteWindows } -result {0 1} test frame-9.2 {MapFrame procedure} -setup { - deleteWindows + deleteWindows } -body { toplevel .t -width 100 -height 400 wm geometry .t +0+0 @@ -1048,7 +1035,7 @@ test frame-9.2 {MapFrame procedure} -setup { winfo exists .t } -result {0} test frame-9.3 {MapFrame procedure, window deleted while mapping} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -width 200 -height 200 wm geometry .t2 +0+0 @@ -1064,22 +1051,17 @@ test frame-9.3 {MapFrame procedure, window deleted while mapping} -setup { deleteWindows } -result {0} - test frame-10.1 {frame widget vs hidden commands} -setup { - deleteWindows + deleteWindows } -body { - set l [interp hidden] frame .t interp hide {} .t destroy .t - set res1 [list [winfo children .] [interp hidden]] - set res2 [list {} $l] - expr {$res1 eq $res2} -} -result 1 - + list [winfo children .] [lsort [interp hidden]] +} -result [list {} [lsort [interp hidden]]] test frame-11.1 {TkInstallFrameMenu} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade -menu .m1.system @@ -1090,9 +1072,9 @@ test frame-11.1 {TkInstallFrameMenu} -setup { deleteWindows } -result {.t} test frame-11.2 {TkInstallFrameMenu - frame renamed} -setup { - deleteWindows -} -body { + deleteWindows catch {rename foo {}} +} -body { menu .m1 .m1 add cascade -menu .m1.system menu .m1.system -tearoff 0 @@ -1103,9 +1085,8 @@ test frame-11.2 {TkInstallFrameMenu - frame renamed} -setup { deleteWindows } -result {} - test frame-12.1 {FrameWorldChanged procedure} -setup { - deleteWindows + deleteWindows } -body { # Test -bd -padx and -pady frame .f -borderwidth 2 -padx 3 -pady 4 @@ -1117,19 +1098,16 @@ test frame-12.1 {FrameWorldChanged procedure} -setup { deleteWindows } -result {5 6 30 28} test frame-12.2 {FrameWorldChanged procedure} -setup { - deleteWindows + deleteWindows } -body { # Test all -labelanchor positions set font {helvetica 12} labelframe .f -highlightthickness 1 -bd 3 -padx 1 -pady 2 -font $font \ -text "Mupp" - set fh [expr {[font metrics $font -linespace] + 2 - 3}] - set fw [expr {[font measure $font "Mupp"] + 2 - 3}] - if {$fw < 0} {set fw 0} - if {$fh < 0} {set fh 0} + set fh [expr {max([font metrics $font -linespace] + 2 - 3, 0)}] + set fw [expr {max([font measure $font "Mupp"] + 2 - 3, 0)}] place .f -x 0 -y 0 -width 100 -height 100 pack [frame .f.f] -fill both -expand 1 - set result {} foreach lp {nw n ne en e es se s sw ws w wn} { .f configure -labelanchor $lp @@ -1144,16 +1122,17 @@ test frame-12.2 {FrameWorldChanged procedure} -setup { w* {incr expx $fw ; incr expw -$fw} e* {incr expw -$fw} } - lappend result [expr {\ - [winfo x .f.f] == $expx && [winfo y .f.f] == $expy &&\ - [winfo width .f.f] == $expw && [winfo height .f.f] == $exph}] + lappend result [expr { + [winfo x .f.f] == $expx && [winfo y .f.f] == $expy && + [winfo width .f.f] == $expw && [winfo height .f.f] == $exph + }] } return $result } -cleanup { deleteWindows } -result {1 1 1 1 1 1 1 1 1 1 1 1} test frame-12.3 {FrameWorldChanged procedure} -setup { - deleteWindows + deleteWindows } -body { # Check reaction on font change font create myfont -family courier -size 10 @@ -1173,9 +1152,8 @@ test frame-12.3 {FrameWorldChanged procedure} -setup { font delete myfont } -result {0} - test frame-13.1 {labelframe configuration options} -setup { - deleteWindows + deleteWindows } -body { labelframe .f -class NewFrame .f configure -class @@ -1187,32 +1165,32 @@ test frame-13.2 {labelframe configuration options} -setup { } -body { labelframe .f -class NewFrame .f configure -class Different -} -cleanup { +} -returnCodes error -cleanup { deleteWindows -} -returnCodes error -result {can't modify -class option after widget is created} +} -result {can't modify -class option after widget is created} test frame-13.3 {labelframe configuration options} -setup { - deleteWindows + deleteWindows } -body { labelframe .f -colormap new } -cleanup { deleteWindows } -result {.f} test frame-13.4 {labelframe configuration options} -setup { - deleteWindows + deleteWindows } -body { labelframe .f -visual default } -cleanup { deleteWindows } -result {.f} test frame-13.5 {labelframe configuration options} -setup { - deleteWindows + deleteWindows } -body { labelframe .f -screen bogus } -cleanup { deleteWindows } -returnCodes error -result {unknown option "-screen"} test frame-13.6 {labelframe configuration options} -setup { - deleteWindows + deleteWindows } -body { labelframe .f -container true } -cleanup { @@ -1227,21 +1205,20 @@ test frame-13.7 {labelframe configuration options} -setup { deleteWindows } -result {-container container Container 0 1} test frame-13.8 {labelframe configuration options} -setup { - deleteWindows + deleteWindows } -body { labelframe .f -container bogus } -cleanup { deleteWindows } -returnCodes error -result {expected boolean value but got "bogus"} test frame-13.9 {labelframe configuration options} -setup { - deleteWindows + deleteWindows } -body { labelframe .f .f configure -container 1 -} -cleanup { +} -returnCodes error -cleanup { deleteWindows -} -returnCodes error -result {can't modify -container option after widget is created} - +} -result {can't modify -container option after widget is created} destroy .f labelframe .f test frame-13.10 {labelframe configuration options} -body { @@ -1249,9 +1226,9 @@ test frame-13.10 {labelframe configuration options} -body { lindex [.f configure -background] 4 } -cleanup { .f configure -background [lindex [.f configure -background] 3] -} -result {#ff0000} +} -result "#ff0000" test frame-13.11 {labelframe configuration options} -body { - .f configure -background non-existent + .f configure -background non-existent } -returnCodes error -result {unknown color name "non-existent"} test frame-13.12 {labelframe configuration options} -body { .f configure -bd 4 @@ -1260,16 +1237,16 @@ test frame-13.12 {labelframe configuration options} -body { .f configure -bd [lindex [.f configure -bd] 3] } -result {4} test frame-13.13 {labelframe configuration options} -body { - .f configure -bd badValue + .f configure -bd badValue } -returnCodes error -result {bad screen distance "badValue"} test frame-13.14 {labelframe configuration options} -body { .f configure -bg #00ff00 lindex [.f configure -bg] 4 } -cleanup { .f configure -bg [lindex [.f configure -bg] 3] -} -result {#00ff00} +} -result "#00ff00" test frame-13.15 {labelframe configuration options} -body { - .f configure -bg non-existent + .f configure -bg non-existent } -returnCodes error -result {unknown color name "non-existent"} test frame-13.16 {labelframe configuration options} -body { .f configure -borderwidth 1.3 @@ -1278,7 +1255,7 @@ test frame-13.16 {labelframe configuration options} -body { .f configure -borderwidth [lindex [.f configure -borderwidth] 3] } -result {1} test frame-13.17 {labelframe configuration options} -body { - .f configure -borderwidth badValue + .f configure -borderwidth badValue } -returnCodes error -result {bad screen distance "badValue"} test frame-13.18 {labelframe configuration options} -body { .f configure -cursor arrow @@ -1287,16 +1264,16 @@ test frame-13.18 {labelframe configuration options} -body { .f configure -cursor [lindex [.f configure -cursor] 3] } -result {arrow} test frame-13.19 {labelframe configuration options} -body { - .f configure -cursor badValue + .f configure -cursor badValue } -returnCodes error -result {bad cursor spec "badValue"} test frame-13.20 {labelframe configuration options} -body { .f configure -fg #0000ff lindex [.f configure -fg] 4 } -cleanup { .f configure -fg [lindex [.f configure -fg] 3] -} -result {#0000ff} +} -result "#0000ff" test frame-13.21 {labelframe configuration options} -body { - .f configure -fg non-existent + .f configure -fg non-existent } -returnCodes error -result {unknown color name "non-existent"} test frame-13.22 {labelframe configuration options} -body { .f configure -font {courier 8} @@ -1309,9 +1286,9 @@ test frame-13.23 {labelframe configuration options} -body { lindex [.f configure -foreground] 4 } -cleanup { .f configure -foreground [lindex [.f configure -foreground] 3] -} -result {#ff0000} +} -result "#ff0000" test frame-13.24 {labelframe configuration options} -body { - .f configure -foreground non-existent + .f configure -foreground non-existent } -returnCodes error -result {unknown color name "non-existent"} test frame-13.25 {labelframe configuration options} -body { .f configure -height 100 @@ -1320,25 +1297,25 @@ test frame-13.25 {labelframe configuration options} -body { .f configure -height [lindex [.f configure -height] 3] } -result {100} test frame-13.26 {labelframe configuration options} -body { - .f configure -height not_a_number + .f configure -height not_a_number } -returnCodes error -result {bad screen distance "not_a_number"} test frame-13.27 {labelframe configuration options} -body { .f configure -highlightbackground #112233 lindex [.f configure -highlightbackground] 4 } -cleanup { .f configure -highlightbackground [lindex [.f configure -highlightbackground] 3] -} -result {#112233} +} -result "#112233" test frame-13.28 {labelframe configuration options} -body { - .f configure -highlightbackground ugly + .f configure -highlightbackground ugly } -returnCodes error -result {unknown color name "ugly"} test frame-13.29 {labelframe configuration options} -body { .f configure -highlightcolor #123456 lindex [.f configure -highlightcolor] 4 } -cleanup { .f configure -highlightcolor [lindex [.f configure -highlightcolor] 3] -} -result {#123456} +} -result "#123456" test frame-13.30 {labelframe configuration options} -body { - .f configure -highlightcolor non-existent + .f configure -highlightcolor non-existent } -returnCodes error -result {unknown color name "non-existent"} test frame-13.31 {labelframe configuration options} -body { .f configure -highlightthickness 6 @@ -1347,7 +1324,7 @@ test frame-13.31 {labelframe configuration options} -body { .f configure -highlightthickness [lindex [.f configure -highlightthickness] 3] } -result {6} test frame-13.32 {labelframe configuration options} -body { - .f configure -highlightthickness badValue + .f configure -highlightthickness badValue } -returnCodes error -result {bad screen distance "badValue"} test frame-13.33 {labelframe configuration options} -body { .f configure -labelanchor se @@ -1355,9 +1332,9 @@ test frame-13.33 {labelframe configuration options} -body { } -cleanup { .f configure -labelanchor [lindex [.f configure -labelanchor] 3] } -result {se} -test frame-13.34 {labelframe configuration options} -body { - .f configure -labelanchor badValue -} -returnCodes error -result {bad labelanchor "badValue": must be e, en, es, n, ne, nw, s, se, sw, w, wn, or ws} +test frame-13.34 {labelframe configuration options} -returnCodes error -body { + .f configure -labelanchor badValue +} -result {bad labelanchor "badValue": must be e, en, es, n, ne, nw, s, se, sw, w, wn, or ws} test frame-13.35 {labelframe configuration options} -body { .f configure -padx 3 lindex [.f configure -padx] 4 @@ -1365,7 +1342,7 @@ test frame-13.35 {labelframe configuration options} -body { .f configure -padx [lindex [.f configure -padx] 3] } -result {3} test frame-13.36 {labelframe configuration options} -body { - .f configure -padx badValue + .f configure -padx badValue } -returnCodes error -result {bad screen distance "badValue"} test frame-13.37 {labelframe configuration options} -body { .f configure -pady 4 @@ -1374,7 +1351,7 @@ test frame-13.37 {labelframe configuration options} -body { .f configure -pady [lindex [.f configure -pady] 3] } -result {4} test frame-13.38 {labelframe configuration options} -body { - .f configure -pady badValue + .f configure -pady badValue } -returnCodes error -result {bad screen distance "badValue"} test frame-13.39 {labelframe configuration options} -body { .f configure -relief ridge @@ -1382,9 +1359,9 @@ test frame-13.39 {labelframe configuration options} -body { } -cleanup { .f configure -relief [lindex [.f configure -relief] 3] } -result {ridge} -test frame-13.40 {labelframe configuration options} -body { - .f configure -relief badValue -} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} +test frame-13.40 {labelframe configuration options} -returnCodes error -body { + .f configure -relief badValue +} -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} test frame-13.41 {labelframe configuration options} -body { .f configure -takefocus {any string} lindex [.f configure -takefocus] 4 @@ -1404,13 +1381,12 @@ test frame-13.43 {labelframe configuration options} -body { .f configure -width [lindex [.f configure -width] 3] } -result {32} test frame-13.44 {labelframe configuration options} -body { - .f configure -width badValue + .f configure -width badValue } -returnCodes error -result {bad screen distance "badValue"} destroy .f - test frame-14.1 {labelframe labelwidget option} -setup { - deleteWindows + deleteWindows } -body { # Test that label is moved in stacking order label .l -text Mupp -font {helvetica 8} @@ -1425,7 +1401,7 @@ test frame-14.1 {labelframe labelwidget option} -setup { deleteWindows } -result {{.f .l} 54 52} test frame-14.2 {labelframe labelwidget option} -setup { - deleteWindows + deleteWindows } -body { # Test the labelframe's reaction if the label is destroyed label .l -text Aratherlonglabel @@ -1444,7 +1420,7 @@ test frame-14.2 {labelframe labelwidget option} -setup { deleteWindows } -result {.l 12 {} 4} test frame-14.3 {labelframe labelwidget option} -setup { - deleteWindows + deleteWindows } -body { # Test the labelframe's reaction if the label is stolen label .l -text Aratherlonglabel @@ -1463,7 +1439,7 @@ test frame-14.3 {labelframe labelwidget option} -setup { deleteWindows } -result {.l 12 {} 4} test frame-14.4 {labelframe labelwidget option} -setup { - deleteWindows + deleteWindows } -body { # Test the label's reaction if the labelframe is destroyed label .l -text Mupp @@ -1477,7 +1453,7 @@ test frame-14.4 {labelframe labelwidget option} -setup { deleteWindows } -result {labelframe {}} test frame-14.5 {labelframe labelwidget option} -setup { - deleteWindows + deleteWindows } -body { # Test that the labelframe reacts on changes in label label .l -text Aratherlonglabel @@ -1500,12 +1476,12 @@ test frame-14.5 {labelframe labelwidget option} -setup { deleteWindows } -result {12 12 1 12 1} test frame-14.6 {labelframe labelwidget option} -setup { - deleteWindows + deleteWindows } -body { - # Destroying a labelframe with a child label caused a crash - # when not handling mapping of the label correctly. - # This test does not test anything directly, it's just ment - # to catch if the same mistake is made again. + # Destroying a labelframe with a child label caused a crash when not + # handling mapping of the label correctly. + # This test does not test anything directly, it's just ment to catch if + # the same mistake is made again. labelframe .f pack .f label .f.l -text Mupp @@ -1514,14 +1490,298 @@ test frame-14.6 {labelframe labelwidget option} -setup { } -cleanup { deleteWindows } -result {} -deleteWindows -rename eatColors {} -rename colorsFree {} +test frame-15.1 {TIP 262: frame background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 +} -body { + frame .f -width 100 -height 100 + pack .f + list [image inuse gorp] [.f configure -backgroundimage gorp;update] \ + [image inuse gorp] [winfo width .f] [winfo height .f] +} -cleanup { + image delete gorp + deleteWindows +} -result {0 {} 1 100 100} +test frame-15.2 {TIP 262: frame background images} -setup { + deleteWindows + catch {rename gorp ""} +} -body { + frame .f -width 100 -height 100 + pack .f + update + .f configure -backgroundimage gorp +} -returnCodes error -cleanup { + deleteWindows +} -result {image "gorp" doesn't exist} +test frame-15.3 {TIP 262: frame background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 +} -body { + frame .f -width 100 -height 100 -backgroundimage gorp + pack .f + .f configure -tile yes + update + list [.f cget -bgimg] [.f cget -tile] +} -cleanup { + image delete gorp + deleteWindows +} -result {gorp 1} +test frame-15.4 {TIP 262: frame background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 +} -body { + frame .f -width 100 -height 100 -backgroundimage gorp + pack .f + .f configure -tile yes + update + gorp put red -to 15 15 20 20 + update + list [.f cget -bgimg] [.f cget -tile] +} -cleanup { + image delete gorp + deleteWindows +} -result {gorp 1} +test frame-15.5 {TIP 262: frame background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 + set result {} +} -body { + frame .f -width 100 -height 100 -backgroundimage gorp + pack .f + .f configure -tile yes + update + image delete gorp + update + set result [list [.f cget -bgimg] [.f cget -tile]] + image create photo gorp -width 250 -height 250 + update + lappend result [.f cget -backgroundimage] +} -cleanup { + catch {image delete gorp} + deleteWindows +} -result {gorp 1 gorp} +test frame-15.6 {TIP 262: frame background images} -setup { + deleteWindows + set result {} + . configure -width 200 -height 200 +} -constraints testImageType -body { + image create test gorp -variable result + pack [frame .f -width 100 -height 100 -bgimg gorp] + update idletasks; update + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 0 0 30 15}} +test frame-15.6a {TIP 262: frame background images (offsets)} -setup { + deleteWindows + set result {} + . configure -width 200 -height 200 +} -constraints testImageType -body { + image create test gorp -variable result + pack [frame .f -width 10 -height 10 -bgimg gorp] + update idletasks; update + # On MacOS must wait for the test image display procedure to run. + set timer [after 300 {lappend result "timedout"}] + while {"timedout" ni $result && + "gorp display 10 2 10 10" ni $result} { + vwait result + } + after cancel $timer + update idletasks; update + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 10 2 10 10}} +test frame-15.7 {TIP 262: frame background images} -setup { + deleteWindows + set result {} + . configure -width 200 -height 200 +} -constraints testImageType -body { + image create test gorp -variable result + pack [frame .f -width 50 -height 25 -bgimg gorp -tile 1] + update idletasks; update + # On MacOS must wait for the test image display procedure to run. + set timer [after 300 {lappend result "timedout"}] + while {"timedout" ni $result && + "gorp display 0 0 20 10" ni $result} { + vwait result + } + after cancel $timer + if {[lindex $result end] eq "timedout"} { + return [lreplace $result end end] + } + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 0 0 30 15} {gorp display 0 0 30 10} {gorp display 0 0 20 15} {gorp display 0 0 20 10}} +test frame-15.7a {TIP 262: frame background images (offsets)} -setup { + deleteWindows + set result {} + . configure -width 200 -height 200 +} -constraints testImageType -body { + image create test gorp -variable result + pack [frame .f -width 50 -height 25 -bgimg gorp -tile 1 -highlightthick 1] + update idletasks; update + # On MacOS must wait for the test image display procedure to run. + set timer [after 300 {lappend result "timedout"}] + while {"timedout" ni $result && + "gorp display 0 0 18 8" ni $result} { + vwait result + } + after cancel $timer + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 0 0 30 15} {gorp display 0 0 30 8} {gorp display 0 0 18 15} {gorp display 0 0 18 8}} +test frame-15.7b {TIP 262: frame background images (offsets)} -setup { + deleteWindows + set result {} + . configure -width 200 -height 200 +} -constraints testImageType -body { + image create test gorp -variable result + pack [frame .f -width 50 -height 25 -bgimg gorp -tile 1 -bd 2] + update idletasks; update + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 0 0 30 15} {gorp display 0 0 30 6} {gorp display 0 0 16 15} {gorp display 0 0 16 6}} +test frame-15.7c {TIP 262: frame background images (offsets)} -setup { + deleteWindows + set result {} + . configure -width 200 -height 200 +} -constraints testImageType -body { + image create test gorp -variable result + pack [frame .f -width 50 -height 25 -bgimg gorp -tile 1 -bd 2 -highlightthick 1] + update idletasks; update + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 0 0 30 15} {gorp display 0 0 30 4} {gorp display 0 0 14 15} {gorp display 0 0 14 4}} +test frame-15.8 {TIP 262: toplevel background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 +} -body { + toplevel .t -width 100 -height 100 + update + # Used to verify that setting a background image doesn't change the widget size + set w [winfo width .t] + set h [winfo height .t] + list [image inuse gorp] [.t configure -backgroundimage gorp;update] \ + [image inuse gorp] \ + [expr {$w-[winfo width .t]}] [expr {$h-[winfo height .t]}] +} -cleanup { + image delete gorp + deleteWindows +} -result {0 {} 1 0 0} +test frame-15.9 {TIP 262: toplevel background images} -setup { + deleteWindows + catch {rename gorp ""} +} -body { + toplevel .t -width 100 -height 100 + update + .t configure -backgroundimage gorp +} -returnCodes error -cleanup { + deleteWindows +} -result {image "gorp" doesn't exist} +test frame-15.10 {TIP 262: toplevel background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 +} -body { + toplevel .t -width 100 -height 100 -backgroundimage gorp -tile yes + update + list [.t cget -bgimg] [.t cget -tile] +} -cleanup { + image delete gorp + deleteWindows +} -result {gorp 1} +test frame-15.11 {TIP 262: toplevel background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 +} -body { + toplevel .t -width 100 -height 100 -backgroundimage gorp -tile yes + update + gorp put red -to 15 15 20 20 + update + list [.t cget -bgimg] [.t cget -tile] +} -cleanup { + image delete gorp + deleteWindows +} -result {gorp 1} +test frame-15.12 {TIP 262: toplevel background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 + set result {} +} -body { + toplevel .t -width 100 -height 100 -backgroundimage gorp -tile yes + update + image delete gorp + update + set result [list [.t cget -bgimg] [.t cget -tile]] + image create photo gorp -width 250 -height 250 + update + lappend result [.t cget -backgroundimage] +} -cleanup { + catch {image delete gorp} + deleteWindows +} -result {gorp 1 gorp} +test frame-15.13 {TIP 262: toplevel background images} -setup { + deleteWindows + set result {} +} -constraints testImageType -body { + image create test gorp -variable result + toplevel .t -width 100 -height 100 -bgimg gorp + wm overrideredirect .t 1; # Reduce trouble from window managers + update idletasks; update + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 0 0 30 15}} +test frame-15.14 {TIP 262: toplevel background images} -setup { + deleteWindows + set result {} +} -constraints testImageType -body { + image create test gorp -variable result + toplevel .t -width 50 -height 25 -bgimg gorp -tile 1 + wm overrideredirect .t 1; # Reduce trouble from window managers + update idletasks; update + # On MacOS must wait for the test image display procedure to run. + set timer [after 300 {lappend result "timedout"}] + while {"timedout" ni $result && + "gorp display 0 0 20 10" ni $result} { + vwait result + } + after cancel $timer + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 0 0 30 15} {gorp display 0 0 30 10} {gorp display 0 0 20 15} {gorp display 0 0 20 10}} + # cleanup +deleteWindows +apply {cmds {foreach cmd $cmds {rename $cmd {}}}} { + eatColors colorsFree uniq optnames +} + cleanupTests return - - - +# Local Variables: +# mode: tcl +# End: diff --git a/tests/geometry.test b/tests/geometry.test index 13cc515..c10a119 100644 --- a/tests/geometry.test +++ b/tests/geometry.test @@ -270,7 +270,7 @@ test geometry-4.10 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { wm geometry .t +0+0 tkwait visibility .t update - pack [frame .t.f] + pack [frame .t.f] button .t.quit -text Quit -command exit pack .t.quit -in .t.f wm iconify .t diff --git a/tests/grid.test b/tests/grid.test index 62474ff..53f8be5 100644 --- a/tests/grid.test +++ b/tests/grid.test @@ -1825,7 +1825,6 @@ test grid-17.1 {forget and pending idle handlers} -body { set result ok } -result ok - test grid-18.1 {test respect for internalborder} -body { toplevel .pack wm geometry .pack 200x200 @@ -2042,6 +2041,121 @@ test grid-23 {grid configure -in leaked from previous master - bug winfo ismapped .t ; # must return 1 } {1} grid_reset 23 + +test grid-24.1 {<<NoManagedChild>> fires on last grid forget} -setup { + global A + unset -nocomplain A +} -body { + grid [frame .1] + update + bind . <<NoManagedChild>> {set A 1} + grid forget .1 + update + info exists A +} -cleanup { + bind . <<NoManagedChild>> {} + grid_reset 24.1 +} -result {1} +test grid-24.2 {<<NoManagedChild>> fires on last grid remove} -setup { + global A + unset -nocomplain A +} -body { + grid [frame .1] + update + bind . <<NoManagedChild>> {set A 1} + grid remove .1 + update + info exists A +} -cleanup { + bind . <<NoManagedChild>> {} + grid_reset 24.2 +} -result {1} +test grid-24.3 {<<NoManagedChild>> fires on last gridded child destruction} -setup { + global A + unset -nocomplain A +} -body { + grid [frame .1] + update + bind . <<NoManagedChild>> {incr A} + destroy .1 + update + set A +} -cleanup { + bind . <<NoManagedChild>> {} + grid_reset 24.3 +} -result {1} +test grid-24.4 {<Configure> does not fire on last grid forget} -setup { + global A + unset -nocomplain A +} -body { + grid [frame .1] + update + bind . <Configure> {set A 1} + grid forget .1 + update + info exists A +} -cleanup { + bind . <Configure> {} + grid_reset 24.4 +} -result {0} +test grid-24.5 {<Configure> fires on forelast grid forget} -setup { + global A + unset -nocomplain A +} -body { + grid [frame .1] + grid [frame .2] + update + bind . <Configure> {set A 1} + grid forget .1 + update + info exists A +} -cleanup { + bind . <Configure> {} + grid_reset 24.5 +} -result {1} +test grid-24.6 {<<NoManagedChild>> does not fire on forelast grid forget} -setup { + global A + unset -nocomplain A +} -body { + grid [frame .1] + grid [frame .2] + update + bind . <<NoManagedChild>> {set A 1} + grid forget .1 + update + info exists A +} -cleanup { + bind . <<NoManagedChild>> {} + grid_reset 24.6 +} -result {0} +test grid-24.7 {<<NoManagedChild>> does not fire on grid anchor} -setup { + global A + unset -nocomplain A +} -body { + bind . <<NoManagedChild>> {set A 1} + grid anchor . w + update + info exists A +} -cleanup { + grid anchor . nw + bind . <<NoManagedChild>> {} + grid_reset 24.7 +} -result {0} +test grid-24.8 {<<NoManagedChild>> does not fire on last grid forget if propagation is off} -setup { + global A + unset -nocomplain A +} -body { + grid [frame .1] + grid propagate . 0 + update + bind . <<NoManagedChild>> {set A 1} + grid forget .1 + update + info exists A +} -cleanup { + bind . <<NoManagedChild>> {} + grid_reset 24.8 +} -result {0} # cleanup cleanupTests diff --git a/tests/imgListFormat.test b/tests/imgListFormat.test new file mode 100644 index 0000000..331b572 --- /dev/null +++ b/tests/imgListFormat.test @@ -0,0 +1,661 @@ +# This file is a Tcl script to test out the default image data format +# ("list format") implementend in the file tkImgListFormat.c. +# It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 2017 Simon Bachmann +# All rights reserved. +# +# Author: Simon Bachmann (simonbachmann@bluewin.ch) + +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv +tcltest::loadTestedCommands + +imageInit + +# find the teapot.ppm file for use in these tests +set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm] +testConstraint hasTeapotPhoto [file exists $teapotPhotoFile] +# let's see if we have the semi-transparent one as well +set transpTeapotPhotoFile [file join [file dirname [info script]] teapotTransparent.png] +testConstraint hasTranspTeapotPhoto [file exists $transpTeapotPhotoFile] + +# --------------------------------------------------------------------- + + +test imgListFormat-1.1 {ParseFormatOptions: default values} -setup { + image create photo photo1 +} -body { + photo1 put {{red green} {blue black}} + lindex [photo1 data] 1 1 +} -cleanup { + imageCleanup +} -result {#000000} +test imgListFormat-1.2 {ParseFormatOptions: format name as first arg} -setup { + image create photo photo1 +} -body { + photo1 put #1256ef -format {default} -to 0 0 10 10 +} -cleanup { + imageCleanup +} -result {} +test imgListFormat-1.3 {ParseFormatOptions: unknown option} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -bogus} +} -cleanup { + imageCleanup +} -returnCodes error -result {bad format option "-bogus": must be -colorformat} +test imgListFormat-1.4 {ParseFormatOptions: option not allowed} -setup { + image create photo photo1 +} -body { + photo1 put yellow -format {default -colorformat rgb} +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {bad format option "-colorformat": no options allowed} +test imgListFormat-1.5 {ParseFormatOptions: no -colorformat value} -setup { + image create photo photo1 -data black +} -body { + photo1 data -format {default -colorformat} +} -returnCodes error -result {the "-colorformat" option requires a value} +test imgListFormat-1.6 {ParseFormatOptions: bad -colorformat val #1} -setup { + image create photo photo1 +} -body { + photo1 put yellow + photo1 data -format {default -colorformat bogus} +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {bad color format "bogus": must be rgb, rgba, or list} +test imgListFormat-1.7 {ParseFormatOptions: bad -colorformat val #2} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -colorformat tkcolor} +} -returnCodes error -result \ + {bad color format "tkcolor": must be rgb, rgba, or list} +test imgListFormat-1.8 {ParseFormatOptions: bad -colorformat #3} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -colorformat emptystring} +} -returnCodes error -result \ + {bad color format "emptystring": must be rgb, rgba, or list} +test imgListFormat-1.9 {ParseFormatOptions: bad -colorformat #4} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -colorformat rgb-short} +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {bad color format "rgb-short": must be rgb, rgba, or list} +test imgListFormat-1.10 {ParseFormatOptions: bad -colorformat #5} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -colorformat rgba-short} +} -returnCodes error -result \ + {bad color format "rgba-short": must be rgb, rgba, or list} +test imgListFormat-1.11 {valid colorformats} -setup { + image create photo photo1 +} -body { + photo1 put white#78 + set result {} + lappend result [photo1 data -format {default -colorformat rgb}] + lappend result [photo1 data -format {default -colorformat rgba}] + lappend result [photo1 data -format {default -colorformat list}] + set result +} -cleanup { + imageCleanup + unset result +} -result {{{#ffffff}} {{#ffffff78}} {{{255 255 255 120}}}} + +# GetBadOptMsg: only use case already tested with imgListFormat-1.4 + +test imgListFormat-3.1 {StringMatchDef: data is not a list} -body { + testphotostringmatch {not a " proper list} + # " (this comment is here only for editor highlighting) +} -returnCodes error -result {unmatched open quote in list} +# empty data case tested with imgPhoto-4.95 (imgPhoto.test) +test imgListFormat-3.2 {StringMatchDef: \ + list element not a proper list} -body { + testphotostringmatch {{red white} {not "} {blue green}} + # " +} -returnCodes error -result {unmatched open quote in list} +test imgListFormat-3.3 {StringMatchDef: \ + sublists with differen lengths} -body { + testphotostringmatch {{#001122 #334455 #667788} + {#99AABB #CCDDEE} + {#FF0011 #223344 #556677}} +} -returnCodes error -result \ + {invalid row # 1: all rows must have the same number of elements} +test imgListFormat-3.4 {StringMatchDef: base64 data is not parsed as valid \ +} -setup { + image create photo photo1 +} -body { + photo1 put { + iVBORw0KGgoAAAANSUhEUgAAAAIAAAACCA + YAAAEFsT2yAAAABGdBTUEAAYagMeiWXwAA + ABdJREFUCJkFwQEBAAAAgiD6P9pACRoqDk + fUBvt1wUFKAAAAAElFTkSuQmCC + } -format default +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "iVBORw0KGgoAAAANSUhEUgAAAAIAAAACCA"} +test imgListFormat-3.5 {StringMatchDef: valid data} -setup { + image create photo photo1 +} -body { + photo1 put {{blue green} + {yellow magenta} + {#000000 #FFFFFFFF}} + list [image width photo1] [image height photo1] \ + [photo1 get 0 2 -withalpha] +} -cleanup { + imageCleanup +} -result {2 3 {0 0 0 255}} + +# ImgStringRead: most of the error cases cannot be tested with current code, +# as the errors are detected by StringMatchDef +test imgListFormat-4.1 {StringReadDef: use with -format opt} -setup { + image create photo photo1 +} -body { + photo1 put white -format "default" + photo1 get 0 0 +} -cleanup { + imageCleanup +} -result {255 255 255} +test imgListFormat-4.2 {StringReadDef: suboptions to format} -setup { + image create photo photo1 +} -body { + photo1 put white -format {default -bogus} +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {bad format option "-bogus": no options allowed} +test imgListFormat-4.3 {StringReadDef: erroneous non-option argument} -setup { + image create photo photo1 +} -body { + photo1 put orange -format {default bogus} +} -returnCodes error -result {bad format option "bogus": no options allowed} +test imgListFormat-4.4 {StringReadDef: normal use case} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 -file $teapotPhotoFile + image create photo photo2 +} -body { + set imgData [photo1 data] + photo2 put $imgData + string equal [photo1 data] [photo2 data] +} -cleanup { + imageCleanup + unset imgData +} -result {1} +test imgListFormat-4.5 {StringReadDef: correct compositing rule} -constraints { + hasTranspTeapotPhoto +} -setup { + image create photo photo1 -file $transpTeapotPhotoFile + image create photo photo2 +} -body { + photo2 put #FF0000 -to 0 0 50 50 + photo2 put [photo1 data -format {default -colorformat rgba}] -to 10 10 40 40 + list [photo2 get 0 0 -withalpha] [photo2 get 20 25 -withalpha] \ + [photo2 get 49 49 -withalpha] +} -cleanup { + imageCleanup +} -result {{255 0 0 255} {0 78 185 225} {255 0 0 255}} + +test imgListFormat-5.1 {StringWriteDef: format options not a list} -setup { + image create photo photo1 +} -body { + photo1 data -format {default " bogus} + # " +} -cleanup { + imageCleanup +} -returnCodes error -result {unmatched open quote in list} +test imgListFormat-5.2 {StringWriteDef: invalid format option} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -bogus} +} -cleanup { + imageCleanup +} -returnCodes error -result {bad format option "-bogus": must be -colorformat} +test imgListFormat-5.3 {StringWriteDef: non-option arg in format} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -colorformat list bogus} +} -cleanup { + imageCleanup +} -returnCodes error -result {bad format option "bogus": must be -colorformat} +test imgListFormat-5.4 {StringWriteDef: empty image} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -colorformat rgba} +} -cleanup { + imageCleanup +} -result {} +test imgListFormat-5.5 {StirngWriteDef: size of data} -setup { + image create photo photo1 +} -body { + photo1 put blue -to 0 0 35 64 + set imgData [photo1 data] + list [llength [lindex $imgData 0]] [llength $imgData] +} -cleanup { + unset imgData + imageCleanup +} -result {35 64} +test imgListFormat-5.6 {StringWriteDef: test some pixels #1} -constraints { + hasTeapotPhoto +} -setup { + set result {} + image create photo photo1 -file $teapotPhotoFile +} -body { + set imgData [photo1 data] + # note: with [lindex], the coords are inverted (y x) + lappend result [lindex $imgData 0 0] + lappend result [lindex $imgData 3 2] + lappend result [lindex $imgData 107 53] + lappend result [lindex $imgData 203 157] + lappend result [lindex $imgData 255 255] + set result +} -cleanup { + unset result + unset imgData + imageCleanup +} -result {{#135cc0} #135cc0 #a06d52 #e1c8ba #135cc0} +test imgListFormat-5.7 {StringWriteDef: test some pixels #2} -constraints { + hasTeapotPhoto +} -setup { + set result {} + image create photo photo1 -file $teapotPhotoFile +} -body { + set imgData [photo1 data -format {default -colorformat rgba}] + # note: with [lindex], the coords are inverted (y x) + lappend result [lindex $imgData 0 0] + lappend result [lindex $imgData 3 2] + lappend result [lindex $imgData 107 53] + lappend result [lindex $imgData 203 157] + lappend result [lindex $imgData 255 255] + set result +} -cleanup { + unset result + unset imgData + imageCleanup +} -result {{#135cc0ff} #135cc0ff #a06d52ff #e1c8baff #135cc0ff} +test imgListFormat-5.8 {StringWriteDef: test some pixels #3} -constraints { + hasTranspTeapotPhoto +} -setup { + image create photo photo1 -file $transpTeapotPhotoFile +} -body { + set imgData [photo1 data -format {default -colorformat rgb}] + set result {} + lappend result [lindex $imgData 3 2] + lappend result [lindex $imgData 107 53] + lappend result [lindex $imgData 203 157] + set result +} -cleanup { + unset result + unset imgData + imageCleanup +} -result {{#004eb9} #a14100 #ffca9f} +test imgListFormat-5.9 {StringWriteDef: test some pixels #4} -constraints { + hasTranspTeapotPhoto +} -setup { + image create photo photo1 -file $transpTeapotPhotoFile +} -body { + set imgData [photo1 data -format {default -colorformat rgba}] + set result [lindex $imgData 3 2] + lappend result [lindex $imgData 107 53] + lappend result [lindex $imgData 203 157] + set result +} -cleanup { + unset result + unset imgData + imageCleanup +} -result {{#004eb9e1} #a14100aa #ffca9faf} +test imgListFormat-5.10 {StringWriteDef: test some pixels #5} -constraints { + hasTranspTeapotPhoto +} -setup { + image create photo photo1 -file $transpTeapotPhotoFile +} -body { + set imgData [photo1 data -format {default -colorformat list}] + set result {} + lappend result [lindex $imgData 3 2] + lappend result [lindex $imgData 107 53] + lappend result [lindex $imgData 203 157] + set result +} -cleanup { + unset imgData + unset result + imageCleanup +} -result {{0 78 185 225} {161 65 0 170} {255 202 159 175}} + +test imgListFormat-6.1 {ParseColor: empty string} -setup { + image create photo photo1 + set result {} +} -body { + photo1 put {{"" ""} {"" ""}} + lappend result [image width photo1] + lappend result [image height photo1] + lappend result [photo1 get 1 1 -withalpha] + set result +} -cleanup { + unset result + imageCleanup +} -result {2 2 {0 0 0 0}} +test imgListFormat-6.2 {ParseColor: empty string, mixed} -setup { + image create photo photo1 +} -body { + photo1 put {{black white} {{} white}} + list [photo1 get 0 0 -withalpha] [photo1 get 0 1 -withalpha] +} -cleanup { + imageCleanup +} -result {{0 0 0 255} {0 0 0 0}} +test imgListFormat-6.3 {ParseColor: color name too long} -setup { + image create photo photo1 + set longstr {} + for {set i 1} {$i <= 100} {incr i} { + append longstr "z" + } +} -body { + photo1 put [list [list blue] [list $longstr]] +} -cleanup { + imageCleanup + unset longstr +} -returnCodes error -result {invalid color} +test imgListFormat-6.4 {ParseColor: #XXX color, different forms} -setup { + image create photo photo1 +} -body { + photo1 put {{#A123 #334455} {#012 #fffefd#00}} + photo1 data -format {default -colorformat rgba} +} -cleanup { + imageCleanup +} -result {{#aa112233 #334455ff} {#001122ff #fffefd00}} +test imgListFormat-6.5 {ParseColor: list format} -setup { + image create photo photo1 +} -body { + photo1 put [list [list [list 255 255 255]]] + photo1 get 0 0 -withalpha +} -cleanup { + imageCleanup +} -result {255 255 255 255} +test imgListFormat-6.6 {ParseColor: string format} -setup { + image create photo photo1 +} -body { + photo1 put [list [list [list white]]] + photo1 get 0 0 -withalpha +} -cleanup { + imageCleanup +} -result {255 255 255 255} +test imgListFormat-6.7 {ParseColor: invalid color} -setup { + image create photo photo1 +} -body { + photo1 put {{blue red} {green bogus}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "bogus"} +test imgListFormat-6.8 {ParseColor: overall test} -setup { + image create photo photo1 + set result {} +} -body { + photo1 put { + {snow@0.5 snow#80 snow#8 #fffffafafafa@0.5 #fffffabbfacc#8} + {#fffffafffaff#80 #ffffaafaa@.5 #ffffaafaa#8 #ffffaafaa#80 #fee#8} + {#fee#80 #fee@0.5 #fffafa@0.5 #fffafa#8 #fffafa#80} + {{0xff 250 0xfa 128} {255 250 250} #fee8 #fffafa80 snow}} + for {set y 0} {$y < 4} {incr y} { + for {set x 0} {$x < 5} {incr x} { + lappend result [photo1 get $x $y -withalpha] + } + } + set result +} -cleanup { + imageCleanup + unset result +} -result \ +{{255 250 250 128} {255 250 250 128} {255 250 250 136} {255 250 250 128}\ +{255 250 250 136} {255 250 250 128} {255 250 250 128} {255 250 250 136}\ +{255 250 250 128} {255 238 238 136} {255 238 238 128} {255 238 238 128}\ +{255 250 250 128} {255 250 250 136} {255 250 250 128} {255 250 250 128}\ +{255 250 250 255} {255 238 238 136} {255 250 250 128} {255 250 250 255}} + +# Note: these tests were written for an earlier implementation of +# ParseColorAsList. For this reason, their order and layout do not follow the +# current code very well. Test coverage is pretty good, nevertheless. +test imgListFormat-7.1 {ParseColorAsList: invalid list} -setup { + image create photo photo1 +} -body { + photo1 put {{{123 45 67 89} {123 45 " 67}}} + #" +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "123 45 " 67"} +#" +test imgListFormat-7.2 {ParseColorAsList: too few elements in list} -setup { + image create photo photo1 +} -body { + photo1 put {{{0 255 0 255} {0 255}}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "0 255"} +test imgListFormat-7.3 {ParseColorAsList: too many elements in list} -setup { + image create photo photo1 +} -body { + photo1 put {{{0 100 200 255} {0 100 200 255 0}}} +} -returnCodes error -result {invalid color name "0 100 200 255 0"} +test imgListFormat-7.4 {ParseColorAsList: not an integer value} -setup { + image create photo photo1 +} -body { + photo1 put {{{9 0xf3 87 65} {43 21 10 1.0}}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "43 21 10 1.0"} +test imgListFormat-7.5 {ParseColorAsList: negative value in list} -setup { + image create photo photo1 +} -body { + photo1 put {{{121 121 121} {121 121 -1}}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "121 121 -1"} +test imgListFormat-7.6 {ParseColorAsList: value in list too large} -setup { + image create photo photo1 +} -body { + photo1 put {{{0 1 2 3} {254 255 256}}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "254 255 256"} +test imgListFormat-7.7 {ParseColorAsList: suffix not allowed} -setup { + image create photo photo1 +} -body { + photo1 put {{{100 100 100} {100 100 100#FE}}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "100 100 100#FE"} +test imgListFormat-7.8 {ParseColorAsList: valid list form} -setup { + image create photo photo1 +} -body { + photo1 put {{{0x0 0x10 0xfe 0xff} {0 100 254}} + {{30 30 30 0} {1 1 254 1}}} + list [photo1 get 0 0 -withalpha] [photo1 get 1 0 -withalpha] \ + [photo1 get 0 1 -withalpha] [photo1 get 1 1 -withalpha] +} -cleanup { + imageCleanup +} -result {{0 16 254 255} {0 100 254 255} {30 30 30 0} {1 1 254 1}} +test imgListFormat-7.9 {ParseColorAsList: additional spaces in list} -setup { + image create photo photo1 +} -body { + photo1 put { { { 1 2 3} {1 2 3} } { {1 2 3 } { 1 2 3 4 } } } + photo1 data -format {default -colorformat rgba} +} -cleanup { + imageCleanup +} -result {{#010203ff #010203ff} {#010203ff #01020304}} +test imgListFormat-7.10 {ParseColorAsList: list format, string rep} -setup { + image create photo photo1 +} -body { + photo1 put {{"111 222 33 44"}} + photo1 get 0 0 -withalpha +} -cleanup { + imageCleanup +} -result {111 222 33 44} + +test imgListFormat-8.1 {ParseColorAsHex: RGB format} -setup { + image create photo photo1 +} -body { + photo1 put {{#010 #001100}} + photo1 data +} -cleanup { + imageCleanup +} -result {{#001100 #001100}} +test imgListFormat-8.2 {ParseColorAsHex: invalid hex digit} -setup { + image create photo photo1 +} -body { + photo1 put {#ABCD #ABCZ} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "#ABCZ"} +test imgListFormat-8.3 {ParseColorAsHex: RGB with suffix, 8 chars} -setup { + image create photo photo1 +} -body { + photo1 put {{#FFfFFf #AbCdef#0}} + photo1 data +} -cleanup { + imageCleanup +} -result {{#ffffff #abcdef}} +test imgListFormat-8.4 {ParseColor: valid #RGBA color} -setup { + image create photo photo1 +} -body { + photo1 put {{#9bd5020d #7acF}} + list [photo1 get 0 0 -withalpha] [photo1 get 1 0 -withalpha] +} -cleanup { + imageCleanup +} -result {{155 213 2 13} {119 170 204 255}} + +test imgListFormat-9.1 {ParseColorAsStandard: + Tk color, valid suffixes} -setup { + image create photo photo1 + set result {} +} -body { + photo1 put {{blue@0.711 #114433#C} {#8D4#1A magenta}} + lappend result [photo1 get 0 0 -withalpha] + lappend result [photo1 get 1 0 -withalpha] + lappend result [photo1 get 0 1 -withalpha] + lappend result [photo1 get 1 1 -withalpha] + set result +} -cleanup { + unset result + imageCleanup +} -result {{0 0 255 181} {17 68 51 204} {136 221 68 26} {255 0 255 255}} +test imgListFormat-9.2 {ParseColorAsStandard: + Tk color with and w/o suffixes} -setup { + image create photo photo1 + set result {} +} -body { + photo1 put {{#52D8a0 #2B5} {#E47@0.01 maroon#4}} + lappend result [photo1 get 0 0 -withalpha] + lappend result [photo1 get 1 0 -withalpha] + lappend result [photo1 get 0 1 -withalpha] + lappend result [photo1 get 1 1 -withalpha] + set result +} -cleanup { + unset result + imageCleanup +} -result {{82 216 160 255} {34 187 85 255} {238 68 119 3} {128 0 0 68}} +test imgListFormat-9.3 {ParseColorAsStandard: wrong digit count} -setup { + image create photo photo1 +} -body { + photo1 put {{#000 #00}} +} -returnCodes error -result {invalid color name "#00"} +test imgListFormat-9.4 {ParseColorAsStandard: @A suffix, not a float} -setup { + image create photo photo1 +} -body { + photo1 put {{blue@0.5 blue@bogus}} +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {invalid alpha suffix "@bogus": expected floating-point value} +test imgListFormat-9.5 {ParseColorAsStandard: @A, value too low} -setup { + image create photo photo1 +} -body { + photo1 put {green@.1 green@-0.1} +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {invalid alpha suffix "@-0.1": value must be in the range from 0 to 1} +test imgListFormat-9.6 {ParseColorAsStandard: @A, value too high} -setup { + image create photo photo1 +} -body { + photo1 put {#000000@0 #000000@1.0001} +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {invalid alpha suffix "@1.0001": value must be in the range from 0 to 1} +test imgListFormat-9.7 {ParseColorAsStandard: @A suffix, edge values} -setup { + imageCleanup + image create photo photo1 +} -body { + photo1 put {{yellow@1e-22 yellow@0.12352941 yellow@0.12352942 \ + yellow@0.9999999}} + list [photo1 get 0 0 -withalpha] [photo1 get 1 0 -withalpha] \ + [photo1 get 2 0 -withalpha] [photo1 get 3 0 -withalpha] +} -cleanup { + imageCleanup +} -result {{255 255 0 0} {255 255 0 31} {255 255 0 32} {255 255 0 255}} +test imgListFormat-9.8 {ParseColorAsStandard: # suffix, no hex digits} -setup { + image create photo photo1 +} -body { + photo1 put {{black#f} {black#}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid alpha suffix "#"} +test imgListFormat-9.9 {ParseColorAsStandard: + '#' suffix, too many digits} -setup { + image create photo photo1 +} -body { + photo1 put {{#ABC#12 #ABC#123}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid alpha suffix "#123"} +test imgListFormat-9.10 {ParseColorAsStandard: + invalid digit in #X suffix} -setup { + image create photo photo1 +} -body { + photo1 put {#000#a #000#g} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid alpha suffix "#g": expected hex digit} +test imgListFormat-9.11 {ParseColorAsStandard: + invalid digit in #XX suffix} -setup { + image create photo photo1 +} -body { + photo1 put {green#2 green#2W} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid alpha suffix "#2W": expected hex digit} +test imgListFormat-9.12 {ParseColorAsStandard: + invalid color: not a hex digit} -setup { + image create photo photo1 +} -body { + photo1 put {#ABCDEF@.99 #ABCDEG@.99} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "#ABCDEG@.99"} +test imgListFormat-9.13 {ParseColorAsStandard: suffix not allowed #1} -setup { + image create photo photo1 +} -body { + photo1 put {#ABC@.5 #ABCD@0.5} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "#ABCD@0.5"} +test imgListFormat-9.14 {ParseColorAsStandard: suffix not allowed #2} -setup { + image create photo photo1 +} -body { + photo1 put {#1111 #1111#1} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "#1111#1"} + + +# --------------------------------------------------------------------- + +imageFinish + +# cleanup +cleanupTests +return diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test index c45c5fb..b5a91fe 100644 --- a/tests/imgPhoto.test +++ b/tests/imgPhoto.test @@ -10,14 +10,82 @@ # # Author: Paul Mackerras (paulus@cs.anu.edu.au) +# +# This file is somewhat caothic: the order of the tests does not +# really follow the order of the corresponding functions in +# tkImgPhoto.c. Probably, because early versions had only a few tests +# and over time test cases were added in bits and pieces. +# To be noted, also, that this file is not complete: large portions of +# code in tkImgPhoto.c have no test coverage. +# +# To help keeping the overview, the table below lists where to find +# tests for each of the functions in tkImgPhoto.c. The function are +# listed in the order as they appear in the source file. +# + +# +# Function name Tests for function +#-------------------------------------------------------------------------- +# PhotoFormatThreadExitProc no tests +# Tk_Create*PhotoImageFormat no tests +# ImgPhotoCreate imgPhoto-2.* +# ImgPhotoCmd imgPhoto-4.*, imgPhoto-17.* +# GetExtension: no tests +# ParseSubcommandOptions: imgPhoto-1.* +# ImgPhotoConfigureMaster: imgPhoto-3.*, imgPhoto-15.* +# toggleComplexAlphaIfNeeded: no tests +# ImgPhotoDelete: imgPhoto-8.* +# ImgPhotoCmdDeleteProc: imgPhoto-9.* +# ImgPhotoSetSize: no tests +# MatchFileFormat: imgPhoto-18.* +# MatchSringFormat: imgPhoto-19.* +# Tk_FindPhoto: imgPhoto-11.* +# Tk_PhotoPutBlock: imgPhoto-10.*, imgPhoto-16.* +# Tk_PhotoPutZoomedBlock: imgPhoto-12.* +# Tk_DitherPhoto: no tets +# Tk_PhotoBlank: no tests +# Tk_PhotoExpand: no tests +# Tk_PhotoGetSize: no tests +# Tk_PhotoSetSize: no tests +# TkGetPhotoValidRegion: no tests +# ImgGetPhoto: no tests +# Tk_PhotoGetImage no tests +# ImgPostscriptPhoto no tests +# Tk_PhotoPutBlock_NoComposite no tests, probably none needed +# Tk_PhotoPutZoomedBlock_NoComposite no tests, probably none needed +# Tk_PhotoExpand_Panic no tests, probably none needed +# Tk_PhotoPutBlock_Panic no tests, probably none needed +# Tk_PhotoPutZoomedBlock_Panic no tests, probably none needed +# Tk_PhotoSetSize_Panic no tests, probably none needed +#-------------------------------------------------------------------------- +# + +# +# Some tests are not specific to a function in tkImgPhoto.c. They are: +# + +# +# Test name(s) Description +#-------------------------------------------------------------------------- +# imgPhoto-5.* Do not really belong to this file. ImgPhotoGet and +# ImgPhotoFree are defined in tkImgPhInstance.c. +# imgPhoto-6.* Do not really belong to this file. ImgPhotoDisplay +# is defined in tkImgPhInstance.c. +# imgPhoto-7.* Do not really belong to this file. ImgPhotoFree is +# defined in tkImgPhInstance.c. +# imgPhoto-13.* Tests for separation in different interpreters +# imgPhoto-14.* Test GIF format. Would belong to imgGIF.test +# - which does not exist. +# + package require tcltest 2.2 namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands - -# Used for 4.65 - 4.73 tests -# Now for some heftier testing, checking that setting and resetting of pixels' -# transparency status doesn't "leak" with any one-off errors. + +# +# Used for imgPhoto-4.65 - imgPhoto-4.73 +# proc foreachPixel {img xVar yVar script} { upvar 1 $xVar x $yVar y set width [image width $img] @@ -58,7 +126,10 @@ set README [makeFile { # find the teapot.ppm file for use in these tests set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm] testConstraint hasTeapotPhoto [file exists $teapotPhotoFile] - +# let's see if we have the semi-transparent one as well +set transpTeapotPhotoFile [file join [file dirname [info script]] teapotTransparent.png] +testConstraint hasTranspTeapotPhoto [file exists $transpTeapotPhotoFile] + proc base64ok {} { expr { ![catch {package require base64}] @@ -115,7 +186,23 @@ test imgPhoto-1.10 {options for photo images - error case} -body { test imgPhoto-1.11 {options for photo images - error case} -body { image create photo photo1 -format } -returnCodes error -result {value for "-format" missing} - +test imgPhoto-1.12 {option -alpha, normal use} -setup { + image create photo photo1 +} -body { + photo1 put "white" -to 0 0 + photo1 transparency get 0 0 -alpha +} -cleanup { + imageCleanup +} -result {255} +test imgPhoto-1.13 {option -withalpha, normal use} -setup { + image create photo photo1 +} -body { + photo1 put {{blue green}} + photo1 get 1 0 -withalpha +} -cleanup { + imageCleanup +} -result {0 128 0 255} + test imgPhoto-2.1 {ImgPhotoCreate procedure} -setup { imageCleanup } -body { @@ -138,7 +225,7 @@ test imgPhoto-2.2 {ImgPhotoCreate procedure} -setup { # photo1 copy photo2 # set msg # } {couldn't open "bogus.img": no such file or directory} - + test imgPhoto-3.1 {ImgPhotoConfigureMaster procedure} -constraints { hasTeapotPhoto } -body { @@ -174,7 +261,40 @@ test imgPhoto-3.3 {ImgPhotoConfigureMaster procedure} -constraints { destroy .c image delete photo1 } -result {256 256 {10 10 266 266} {300 10 556 266}} - +test imgPhoto-3.4 {ImgPhotoConfigureMaster: -data <ppm>} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 -file $teapotPhotoFile + image create photo photo2 +} -body { + photo2 configure -data [photo1 data -format ppm -from 100 100 120 120] + list [image width photo2] [image height photo2] +} -cleanup { + imageCleanup +} -result {20 20} +test imgPhoto-3.5 {ImgPhotoConfigureMaster: -data <png>} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 -file $teapotPhotoFile + image create photo photo2 +} -body { + photo2 configure -data [photo1 data -format png -from 120 120 140 140] + list [image width photo2] [image height photo2] +} -cleanup { + imageCleanup +} -result {20 20} +test imgPhoto-3.6 {ImgPhotoConfigureMaster: -data <default>} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 -file $teapotPhotoFile + image create photo photo2 +} -body { + photo2 configure -data [photo1 data -from 80 90 100 110] + list [image width photo2] [image height photo2] +} -cleanup { + imageCleanup +} -result {20 20} + test imgPhoto-4.1 {ImgPhotoCmd procedure} -setup { image create photo photo1 } -body { @@ -373,16 +493,19 @@ test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} -constraints { } -cleanup { image delete photo1 photo2 } -result {256 256 49 51 49 51 49 51 10 51 10 10} +# tests for <imageName> data: imgPhoto-4. test imgPhoto-4.22 {ImgPhotoCmd procedure: get option} -constraints { - hasTeapotPhoto + hasTranspTeapotPhoto } -setup { image create photo photo1 } -body { - photo1 read $teapotPhotoFile - list [photo1 get 100 100] [photo1 get 150 100] [photo1 get 100 150] + photo1 read $transpTeapotPhotoFile + list [photo1 get 100 100 -withalpha] \ + [photo1 get 150 100 -withalpha] \ + [photo1 get 100 150] [photo1 get 150 150] } -cleanup { image delete photo1 -} -result {{169 117 90} {172 115 84} {35 35 35}} +} -result {{175 71 0 162} {179 73 0 168} {14 8 0} {0 0 0}} test imgPhoto-4.23 {ImgPhotoCmd procedure: get option} -setup { image create photo photo1 } -body { @@ -400,10 +523,12 @@ test imgPhoto-4.24 {ImgPhotoCmd procedure: get option} -setup { test imgPhoto-4.25 {ImgPhotoCmd procedure: get option} -setup { image create photo photo1 } -body { - photo1 get + photo1 get 0 } -cleanup { image delete photo1 -} -returnCodes error -result {wrong # args: should be "photo1 get x y"} +} -returnCodes error -result \ + {wrong # args: should be "photo1 get x y ?-withalpha?"} +# more test for image get: 4.101-4.102 test imgPhoto-4.26 {ImgPhotoCmd procedure: put option} -setup { image create photo photo1 } -body { @@ -417,22 +542,28 @@ test imgPhoto-4.27 {ImgPhotoCmd procedure: put option} -setup { photo1 put {{white} {white white}} } -returnCodes error -cleanup { image delete photo1 -} -result {all elements of color list must have the same number of elements} +} -result {invalid row # 1: all rows must have the same number of elements} test imgPhoto-4.28 {ImgPhotoCmd procedure: put option} -setup { image create photo photo1 } -body { photo1 put {{blahgle}} } -cleanup { image delete photo1 -} -returnCodes error -result {can't parse color "blahgle"} +} -returnCodes error -result {invalid color name "blahgle"} test imgPhoto-4.29 {ImgPhotoCmd procedure: put option} -setup { image create photo photo1 } -body { - photo1 put -to 10 10 20 20 {{white}} + # SB: odd thing - this test passed with tk 8.6.6, even if the data + # is in the wrong position: + #photo1 put -to 10 10 20 20 {{white}} + + # this is how it's supposed to be: + photo1 put {{white}} -to 10 10 20 20 photo1 get 19 19 } -cleanup { image delete photo1 } -result {255 255 255} +# more tests for image put: 4.90-4.100 test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} -setup { image create photo photo1 } -body { @@ -514,6 +645,7 @@ test imgPhoto-4.39 {ImgPhotoCmd procedure: write option} -setup { } -cleanup { image delete photo1 } -returnCodes error -result {image file format "bogus" is unknown} +# more tests on "imageName write": imgPhoto-17.* test imgPhoto-4.40 {ImgPhotoCmd procedure: transparency option} -setup { image create photo photo1 } -body { @@ -527,21 +659,21 @@ test imgPhoto-4.41 {ImgPhotoCmd procedure: transparency get option} -setup { photo1 transparency get } -returnCodes error -cleanup { image delete photo1 -} -result {wrong # args: should be "photo1 transparency get x y"} +} -result {wrong # args: should be "photo1 transparency get x y ?-option?"} test imgPhoto-4.42 {ImgPhotoCmd procedure: transparency get option} -setup { image create photo photo1 } -body { photo1 transparency get 0 } -returnCodes error -cleanup { image delete photo1 -} -result {wrong # args: should be "photo1 transparency get x y"} +} -result {wrong # args: should be "photo1 transparency get x y ?-option?"} test imgPhoto-4.43 {ImgPhotoCmd procedure: transparency get option} -setup { image create photo photo1 } -body { - photo1 transparency get 0 0 0 + photo1 transparency get 0 0 0 -alpha } -returnCodes error -cleanup { image delete photo1 -} -result {wrong # args: should be "photo1 transparency get x y"} +} -result {wrong # args: should be "photo1 transparency get x y ?-option?"} test imgPhoto-4.44 {ImgPhotoCmd procedure: transparency get option} -setup { image create photo photo1 } -body { @@ -601,34 +733,39 @@ test imgPhoto-4.51 {ImgPhotoCmd procedure: transparency get option} -setup { } -cleanup { image delete photo1 } -result 1 +# more tests for transparency get: 4.65, 4.66, 4.76-4.81 test imgPhoto-4.52 {ImgPhotoCmd procedure: transparency set option} -setup { image create photo photo1 } -body { photo1 transparency set } -returnCodes error -cleanup { image delete photo1 -} -result {wrong # args: should be "photo1 transparency set x y boolean"} +} -result \ + {wrong # args: should be "photo1 transparency set x y newVal ?-option?"} test imgPhoto-4.53 {ImgPhotoCmd procedure: transparency set option} -setup { image create photo photo1 } -body { photo1 transparency set 0 } -returnCodes error -cleanup { image delete photo1 -} -result {wrong # args: should be "photo1 transparency set x y boolean"} +} -result \ + {wrong # args: should be "photo1 transparency set x y newVal ?-option?"} test imgPhoto-4.54 {ImgPhotoCmd procedure: transparency set option} -setup { image create photo photo1 } -body { photo1 transparency set 0 0 } -returnCodes error -cleanup { image delete photo1 -} -result {wrong # args: should be "photo1 transparency set x y boolean"} +} -result \ + {wrong # args: should be "photo1 transparency set x y newVal ?-option?"} test imgPhoto-4.55 {ImgPhotoCmd procedure: transparency set option} -setup { image create photo photo1 } -body { - photo1 transparency set 0 0 0 0 + photo1 transparency set 0 0 0 0 -alpha } -returnCodes error -cleanup { image delete photo1 -} -result {wrong # args: should be "photo1 transparency set x y boolean"} +} -result \ + {wrong # args: should be "photo1 transparency set x y newVal ?-option?"} test imgPhoto-4.56 {ImgPhotoCmd procedure: transparency set option} -setup { image create photo photo1 } -body { @@ -645,6 +782,7 @@ test imgPhoto-4.57 {ImgPhotoCmd procedure: transparency set option} -setup { } -returnCodes error -result {expected integer but got "bogus"} test imgPhoto-4.58 {ImgPhotoCmd procedure: transparency set option} -setup { image create photo photo1 + photo1 put blue } -body { photo1 transparency set 0 0 bogus } -cleanup { @@ -696,6 +834,7 @@ test imgPhoto-4.64 {ImgPhotoCmd procedure: transparency set option} -setup { } -cleanup { image delete photo1 } -result 1 +# more tests for transparency set: 4.67, 4.68, 4.82-4.89 # Now for some heftier testing, checking that setting and resetting of pixels' # transparency status doesn't "leak" with any one-off errors. test imgPhoto-4.65 {ImgPhotoCmd procedure: transparency get option} -setup { @@ -821,7 +960,7 @@ test imgPhoto-4.75 {<photo> read command: filename starting with '-'} -constrain file delete ./-teapotPhotoFile } -result {} test imgPhoto-4.76 {ImgPhotoCmd procedure: copy to same image} -constraints { - hasTeapotPhoto + hasTeapotPhoto } -setup { imageCleanup image create photo photo1 -file $teapotPhotoFile @@ -832,7 +971,411 @@ test imgPhoto-4.76 {ImgPhotoCmd procedure: copy to same image} -constraints { } -cleanup { imageCleanup } -result {} - +test imgPhoto-4.76 {ImgPhotoCmd, transparancy get: too many options} -setup { + image create photo photo1 +} -body { + photo1 put white -to 0 0 1 1 + photo1 transparency get 0 0 -alpha -bogus +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {wrong # args: should be "photo1 transparency get x y ?-option?"} +test imgPhoto-4.77 {ImgPhotoCmd, transparency get: invalid option} -setup { + image create photo photo1 +} -body { + photo1 put white -to 0 0 1 1 + photo1 transparency get 0 0 -bogus +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {unrecognized option "-bogus": must be -alpha} +test imgPhoto-4.78 {ImgPhotoCmd, transparency get: normal use} -setup { + image create photo photo1 +} -body { + photo1 put white -to 0 0 1 1 + set result [photo1 transparency get 0 0] + lappend result [photo1 transparency get 0 0 -alpha] +} -cleanup { + imageCleanup +} -result {0 255} +test imgPhoto-4.79 {ImgPhotoCmd, transparency get: no option} -constraints { + hasTranspTeapotPhoto +} -setup { + image create photo photo1 -file $transpTeapotPhotoFile + set result {} +} -body { + set pixelCoords {{156 239} {76 207} {153 213} {139 43} {75 112}} + foreach coord $pixelCoords { + lappend result [photo1 transparency get {*}$coord] + } + set result +} -cleanup { + imageCleanup +} -result {0 1 0 0 0} +# test imgPhoto-4.80: deleted (was transparency get: -boolean) +test imgPhoto-4.81 {ImgPhotoCmd, transparency get: -alpha} -constraints { + hasTranspTeapotPhoto +} -setup { + image create photo photo1 -file $transpTeapotPhotoFile + set result {} +} -body { + set pixelCoords {{156 239} {76 207} {153 213} {139 43} {75 112}} + foreach coord $pixelCoords { + lappend result [photo1 transparency get {*}$coord -alpha] + } + set result +} -cleanup { + imageCleanup +} -result {255 0 1 254 206} +test imgPhoto-4.82 {ImgPhotoCmd, transparency set: too many opts} -setup { + image create photo photo1 +} -body { + photo1 transparency set 0 0 -alpha -bogus 1 +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {wrong # args: should be "photo1 transparency set x y newVal ?-option?"} +test imgPhoto-4.83 {ImgPhotoCmd, transparency set: invalid opt} -setup { + image create photo photo1 -data black +} -body { + photo1 transparency set 0 0 0 -bogus +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {unrecognized option "-bogus": must be -alpha} +test imgPhoto-4.84 {ImgPhotoCmd, transparency set: invalid newVal} -setup { + image create photo photo1 -data white +} -body { + photo1 transparency set 0 0 bogus -alpha +} -cleanup { + imageCleanup +} -returnCodes error -result {expected integer but got "bogus"} +test imgPhoto-4.85 {ImgPhotoCmd, transparency set: invalid newVal} -setup { + image create photo photo1 -data red +} -body { + photo1 transparency set 0 0 -1 -alpha +} -returnCodes error -result \ + {invalid alpha value "-1": must be integer between 0 and 255} +test imgPhoto-4.86 {ImgPhotoCmd, transparency set: invalid newVal} -setup { + image create photo photo1 -data green +} -body { + photo1 transparency set 0 0 256 -alpha +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {invalid alpha value "256": must be integer between 0 and 255} +test imgPhoto-4.87 {ImgPhotoCmd, transparency set: no opt} -setup { + image create photo photo1 +} -body { + photo1 put white -to 0 0 2 1 + photo1 transparency set 0 0 0 + photo1 transparency set 1 0 1 + list [photo1 transparency get 0 0 -alpha] \ + [photo1 transparency get 1 0 -alpha] +} -cleanup { + imageCleanup +} -result {255 0} +# deleted: test imgPhoto-4.88 {ImgPhotoCmd, transparency set: -boolean} +test imgPhoto-4.89 {ImgPhotoCmd, transparency set: -alpha} -setup { + image create photo photo1 +} -body { + photo1 put white -to 0 0 2 2 + photo1 transparency set 0 0 0 -alpha + photo1 transparency set 1 0 1 -alpha + photo1 transparency set 0 1 254 -alpha + photo1 transparency set 1 1 255 -alpha + list [photo1 transparency get 0 0] [photo1 transparency get 1 0] \ + [photo1 transparency get 0 1] [photo1 transparency get 1 1] +} -cleanup { + imageCleanup +} -result {1 0 0 0} +test imgPhoto-4.90 {ImgPhotoCmd put: existing but not allowed opt} -setup { + image create photo photo1 +} -body { + photo1 put yellow -from 0 0 1 1 +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {unrecognized option "-from": must be -format, or -to} +test imgPhoto-4.91 {ImgPhotoCmd put: invalid option} -setup { + image create photo photo1 +} -body { + photo1 put {{0 1 2 3}} -bogus x +} -returnCodes error -result \ + {unrecognized option "-bogus": must be -format, or -to} +test imgPhoto-4.92 {ImgPhotocmd put: missing data} -setup { + image create photo photo1 +} -body { + photo1 put -to 0 0 +} -returnCodes error -result \ + {wrong # args: should be "photo1 put data ?-option value ...?"} +test imgPhoto-4.93 {ImgPhotoCmd put: data in ppm format} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 -file $teapotPhotoFile + image create photo photo2 +} -body { + set imgdata [photo1 data -format ppm] + photo2 put $imgdata -format ppm + set result {} + if {[image width photo1] != [image width photo2] \ + || [image height photo1] != [image height photo2]} { + lappend result [list [image width photo2] [image height photo2]] + } else { + lappend result 1 + } + foreach point {{206 125} {67 12} {13 46} {19 184}} { + if {[photo1 get {*}$point] ne [photo2 get {*}$point]} { + lappend result [photo2 get {*}$point] + } else { + lappend result 1 + } + } + set result +} -cleanup { + imageCleanup +} -result {1 1 1 1 1} +test imgPhoto-4.94 {ImgPhotoCmd put: unknown format} -setup { + image create photo photo1 +} -body { + photo1 put {no real data} -format bogus +} -cleanup { + imageCleanup +} -returnCodes error -result {image format "bogus" is not supported} +test imgPhoto-4.95 {ImgPhotoCmd put: default fmt, invalid data} -setup { + image create photo photo1 +} -body { + photo1 put {{red green blue} {red " blue}} + #" +} -cleanup { + imageCleanup +} -returnCodes error -result {unmatched open quote in list} +test imgPhoto-4.96 {ImgPhotoCmd put: "default" handler is selected} -setup { + image create photo photo1 + image create photo photo2 + set imgData {{{1 2 3 4} {5 6 7 8} {9 10 11 12}} + {{13 14 15 15} {17 18 19 20} {21 22 23 24}}} +} -body { + photo1 put $imgData + photo2 put $imgData -format default + set result {} + lappend result [list [image width photo1] [image height photo1]] + lappend result [list [image width photo2] [image height photo2]] + lappend result [string equal \ + [photo1 data -format "default -colorformat rgba"] \ + [photo2 data -format "default -colorformat rgba"]] + set result +} -cleanup { + imageCleanup + unset result + unset imgData +} -result {{3 2} {3 2} 1} +test imgPhoto-4.97 {ImgPhotoCmd put: image size} -setup { + image create photo photo1 +} -body { + photo1 put {{red green blue} {blue red green}} + list [image width photo1] [image height photo1] +} -cleanup { + imageCleanup +} -result {3 2} +test imgPhoto-4.98 {ImgPhotoCmd put: -to with 2 coords} -setup { + image create photo photo1 +} -body { + photo1 put {{"alice blue" "blanched almond"} + {"deep sky blue" "ghost white"} + {#AABBCC #AABBCCDD}} -to 5 6 + list [image width photo1] [image height photo1] +} -cleanup { + imageCleanup +} -result {7 9} +test imgPhoto-4.99 {ImgPhotoCmd put: -to with 4 coords} -setup { + image create photo photo1 +} -body { + photo1 put {{#123 #456 #678} {#9AB #CDE #F01}} -to 1 2 20 21 + set result {} + lappend result [photo1 get 19 20 -withalpha] + lappend result [string equal \ + [photo1 data -from 1 2 4 4] [photo1 data -from 4 2 7 4]] + lappend result [string equal \ + [photo1 data -from 10 12 13 14] [photo1 data -from 16 16 19 18]] + set result +} -cleanup { + imageCleanup +} -result {{17 34 51 255} 1 1} +test imgPhoto-4.100 {ImgPhotoCmd put: no changes on empty data} -setup { + image create photo photo1 +} -body { + photo1 put {{brown blue} {cyan coral}} + set imgData [photo1 data] + photo1 put {} + string equal $imgData [photo1 data] +} -cleanup { + imageCleanup +} -result {1} +test imgPhoto-4.101 {ImgPhotoCmd get: too many args} -setup { + image create photo photo1 +} -body { + photo1 get 0 0 -withalpha bogus +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {wrong # args: should be "photo1 get x y ?-withalpha?"} +test imgPhoto-4.102 {ImgPhotoCmd get: invalid option} -setup { + image create photo photo1 +} -body { + photo1 get 0 0 -bogus +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {unrecognized option "-bogus": must be -withalpha} +test imgPhoto-4.103 {ImgPhotoCmd data: accepted opts} -setup { + image create photo photo1 -data black +} -body { + photo1 data -format default -from 0 0 -grayscale -background blue +} -cleanup { + imageCleanup +} -result {{#000000}} +test imgPhoto-4.104 {ImgPhotoCmd data: existing but not accepted opt} -setup { + image create photo photo1 +} -body { + photo1 data -to +} -cleanup { + imageCleanup +} -returnCodes error -result \ +{unrecognized option "-to": must be -background, -format, -from, or -grayscale} +test imgPhoto-4.105 {ImgPhotoCmd data: invalid option} -setup { + image create photo photo1 +} -body { + photo1 data -bogus +} -cleanup { + imageCleanup +} -returnCodes error -result \ +{unrecognized option "-bogus": must be -background, -format, -from, or -grayscale} +test imgPhoto-4.106 {ImgPhotoCmd data: extra arg before options} -setup { + image create photo photo1 +} -body { + photo1 data bogus -grayscale +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {wrong # args: should be "photo1 data ?-option value ...?"} +test imgPhoto-4.107 {ImgPhotoCmd data: extra arg after options} -setup { + image create photo photo1 +} -body { + photo1 data -format default bogus +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {wrong # args: should be "photo1 data ?-option value ...?"} +test imgPhoto-4.108 {ImgPhotoCmd data: invalid -from coords #1} -setup { + image create photo photo1 -data blue +} -body { + photo1 data -from 2 0 +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {coordinates for -from option extend outside image} +test imgPhoto-4.109 {ImgPhotoCmd data: invalid -from coords #2} -setup { + image create photo photo1 -data blue +} -body { + photo1 data -from 0 2 +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {coordinates for -from option extend outside image} +test imgPhoto-4.110 {ImgPhotoCmd data: invalid -from coords #3} -setup { + image create photo photo1 -data blue +} -body { + photo1 data -from 0 0 2 1 +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {coordinates for -from option extend outside image} +test imgPhoto-4.111 {ImgPhotoCmd data: invalid -from coords #4} -setup { + image create photo photo1 -data blue +} -body { + photo1 data -from 0 0 1 2 +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {coordinates for -from option extend outside image} +test imgPhoto-4.112 {ImgPhotoCmd data: -from with 2 coords} -setup { + image create photo photo1 -data { + {black black black black black} + {white white white white white} + {green green green green green}} +} -body { + set imgData [photo1 data -from 2 1] + list [llength [lindex $imgData 0]] [llength $imgData] +} -cleanup { + imageCleanup + unset imgData +} -result {3 2} +test imgPhoto-4.113 {ImgPhotoCmd data: default is rgb format} -setup { + image create photo photo1 -data red +} -body { + photo1 data +} -cleanup { + imageCleanup +} -result {{#ff0000}} +test imgPhoto-4.114 {ImgPhotoCmd data: unknown format} -setup { + image create photo photo1 +} -body { + photo1 data -format bogus +} -cleanup { + imageCleanup +} -returnCodes error -result {image string format "bogus" is unknown} +test imgPhoto-4.115 {ImgPhotoCmd data: rgb colorformat} -setup { + image create photo photo1 -data {{red#a green#b} {blue#c white}} +} -body { + photo1 data -format {default -colorformat rgb} +} -result {{#ff0000 #008000} {#0000ff #ffffff}} +test imgPhoto-4.116 {ImgPhotoCmd data: rgba colorformat} -setup { + image create photo photo1 -data {{red green} {blue white}} +} -body { + photo1 data -format {default -colorformat rgba} +} -result {{#ff0000ff #008000ff} {#0000ffff #ffffffff}} +test imgPhoto-4.117 {ImgPhotoCmd data: list colorformat} -setup { + image create photo photo1 -data {{red#a green} {blue#c white#d}} +} -body { + photo1 data -format {default -colorformat list} +} -result {{{255 0 0 170} {0 128 0 255}} {{0 0 255 204} {255 255 255 221}}} +test imgPhoto-4.118 {ImgPhotoCmd data: using data for new image + results in same image as orignial } -constraints { + hasTeapotPhoto + hasTranspTeapotPhoto +} -setup { + image create photo teapot -file $teapotPhotoFile + teapot copy teapot -from 50 60 70 80 -shrink + image create photo teapotTransp -file $transpTeapotPhotoFile + teapotTransp copy teapotTransp -from 100 110 120 130 -shrink + image create photo photo1 +} -body { + set result {} + # We don't test gif here, as there seems to be a problem with + # <imgName> data and gif format ("too many colors", probably a bug) + foreach fmt {ppm png {default -colorformat rgba} \ + {default -colorformat list}} { + set imgData [teapotTransp data -format $fmt] + photo1 blank + photo1 put $imgData + if { ! [string equal [photo1 data] [teapotTransp data]]} { + lappend result $fmt + } + } + set imgData [teapot data -format default] + photo1 blank + photo1 put $imgData + if { ! [string equal [photo1 data] [teapot data]]} { + lappend result default + } + set result +} -cleanup { + unset imgData + unset result + imageCleanup +} -result {} + test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} -constraints { hasTeapotPhoto } -setup { @@ -855,7 +1398,7 @@ test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} -constraints { } -cleanup { destroy .c } -result {} - + test imgPhoto-6.1 {ImgPhotoDisplay procedure, blank display} -setup { destroy .c pack [canvas .c] @@ -869,7 +1412,7 @@ test imgPhoto-6.1 {ImgPhotoDisplay procedure, blank display} -setup { destroy .c image delete photo1 } -result {} - + test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} -constraints { hasTeapotPhoto } -setup { @@ -930,7 +1473,7 @@ test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} -constraints { destroy .f image delete photo1 } -result {} - + test imgPhoto-8.1 {ImgPhotoDelete procedure} -constraints hasTeapotPhoto -body { image create photo photo2 -file $teapotPhotoFile image delete photo2 @@ -954,7 +1497,7 @@ test imgPhoto-8.3 {ImgPhotoDelete procedure, name cleanup} -body { } -returnCodes error -cleanup { imageCleanup } -result {image "photo2" doesn't exist or is not a photo image} - + test imgPhoto-9.1 {ImgPhotoCmdDeletedProc procedure} -constraints { hasTeapotPhoto } -body { @@ -962,7 +1505,7 @@ test imgPhoto-9.1 {ImgPhotoCmdDeletedProc procedure} -constraints { rename photo2 {} list [lsearch -exact [imageNames] photo2] [catch {photo2 foo} msg] $msg } -result {-1 1 {invalid command name "photo2"}} - + test imgPhoto-10.1 {Tk_ImgPhotoPutBlock procedure} -setup { imageCleanup } -body { @@ -1009,7 +1552,6 @@ test imgPhoto-10.4 {Tk_ImgPhotoPutBlock, empty image} -setup { imageCleanup } -result {0 0} - test imgPhoto-11.1 {Tk_FindPhoto} -setup { imageCleanup } -body { @@ -1019,7 +1561,7 @@ test imgPhoto-11.1 {Tk_FindPhoto} -setup { } -cleanup { imageCleanup } -returnCodes error -result {image "i1" doesn't exist or is not a photo image} - + test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} -constraints hasTeapotPhoto -body { image create photo p3 -file $teapotPhotoFile set result [list [p3 get 50 50] [p3 get 100 100]] @@ -1108,7 +1650,7 @@ test imgPhoto-13.1 {check separation of images in different interpreters} -setup interp delete x1 interp delete x2 } -result T1_data - + test imgPhoto-14.1 {GIF writes work correctly} -setup { set data { R0lGODlhYwA5APcAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgAysnGy8hKzM @@ -1252,7 +1794,7 @@ test imgPhoto-15.1 {photo images can fail to allocate memory gracefully} -constr # free memory available... image create photo -width 32000 -height 32000 } -returnCodes error -result {not enough free memory for image buffer} - + test imgPhoto-16.1 {copying to self doesn't access freed memory} -setup { set i [image create photo] } -body { @@ -1263,7 +1805,7 @@ test imgPhoto-16.1 {copying to self doesn't access freed memory} -setup { } -cleanup { image delete $i } -result {} - + # Check that we can guess our supported output formats [Bug 2983824] test imgPhoto-17.1 {photo write: format guessing from filename} -setup { set i [image create photo -width 3 -height 3] @@ -1302,6 +1844,109 @@ test imgPhoto-17.3 {photo write: format guessing from filename} -setup { image delete $i catch {removeFile $f} } -result "P6\n" +test imgPhoto-17.4 {photo write: default format not supported} -setup { + image create photo photo1 -data {{blue blue} {red red} {green green}} + set f [makeFile {} test.txt] +} -body { + photo1 write $f -format default +} -cleanup { + imageCleanup + catch {removeFile $f} + unset f +} -returnCodes error -result \ + {image file format "default" has no file writing capability} +test imgPhoto-17.5 {photo write: file with extension .default} -setup { + image create photo photo1 -data {{black}} + set f [makeFile {} test.default] +} -body { + photo1 write $f +} -cleanup { + imageCleanup + catch {removeFile $f} + unset f +} -returnCodes error -result \ + {image file format "default" has no file writing capability} + +test imgPhoto-18.1 {MatchFileFormat: "default" format not supported} -setup { + image create photo photo1 + set f [makeFile {} test.txt] +} -body { + photo1 read $f -format default +} -cleanup { + imageCleanup + catch {removeFile $f} + unset f +} -returnCodes error -result {-file option isn't supported for default images} + +test imgPhoto-19.1 {MatchStringFormat: with "-format default"} -setup { + image create photo photo1 +} -body { + photo1 put {{red blue red} {yellow green yellow}} -format default + list [image width photo1] [image height photo1] +} -cleanup { + imageCleanup +} -result {3 2} +test imgPhoto-19.2 {MatchStringFormat: without -format option, + default fmt} -body { + image create photo photo1 + photo1 put {{red} {green}} + list [image width photo1] [image height photo1] +} -cleanup { + imageCleanup +} -result {1 2} +test imgPhoto-19.3 {MatchStringFormat: "-format ppm"} -setup { + image create photo photo1 + image create photo photo2 + photo2 put {cyan cyan} + set imgData [photo2 data -format ppm] +} -body { + photo1 put $imgData -format ppm + list [image width photo1] [image height photo1] +} -cleanup { + unset imgData + imageCleanup +} -result {1 2} +test imgPhoto-19.4 {MatchStringFormat: ppm fmt, without opt} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 -file $teapotPhotoFile + image create photo photo2 +} -body { + set imgData [photo1 data -format ppm] + photo2 put $imgData + list [image width photo2] [image height photo2] +} -cleanup { + imageCleanup + unset imgData +} -result {256 256} +test imgPhoto-19.5 {MatchStirngFormat: unknown -format} -setup { + image create photo photo1 +} -body { + photo1 put {} -format bogus +} -cleanup { + imageCleanup +} -returnCodes error -result {image format "bogus" is not supported} +test imgPhoto-19.6 {MatchStringFormat: invalid data for default} -setup { + image create photo photo1 +} -body { + photo1 put bogus +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "bogus"} +test imgPhoto-19.7 {MatchStringFormat: invalid data for default} -setup { + image create photo photo1 +} -body { + photo1 put bogus -format dEFault +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "bogus"} +test imgPhoto-19.8 {MatchStirngFormat: invalid data for gif} -setup { + image create photo photo1 +} -body { + photo1 put bogus -format giF +} -cleanup { + imageCleanup +} -returnCodes error -result {couldn't recognize image data} # Reject corrupted or truncated image [Bug b601ce3ab1]. # WARNING - tests 18.1-18.9 will cause a segfault on 8.5.19 and lower, diff --git a/tests/imgSVGnano.test b/tests/imgSVGnano.test new file mode 100644 index 0000000..ff7046a --- /dev/null +++ b/tests/imgSVGnano.test @@ -0,0 +1,220 @@ +# This file is a Tcl script to test out the code in tkImgSVGnano.c, which reads +# and write SVG-format image files for photo widgets. The files is organized +# in the standard fashion for Tcl tests. +# +# Copyright (c) 2018 Rene Zaumseil +# All rights reserved. + +package require tcltest 2.2 +namespace import ::tcltest::* +eval tcltest::configure $argv +tcltest::loadTestedCommands +imageInit + +namespace eval svgnano { + variable data + set data(plus) {<svg xmlns="http://www.w3.org/2000/svg" width="100" height="100"> +<path fill="none" stroke="#000000" d="M0 0 h16 v16 h-16 z"/> +<path fill="none" stroke="#000000" d="M8 4 v 8 M4 8 h 8"/> +<circle fill="yellow" stroke="red" cx="10" cy="80" r="10" /> +<ellipse fill="none" stroke="blue" stroke-width="3" cx="60" cy="60" rx="10" ry="20" /> +<line x1="10" y1="90" x2="50" y2="99"/> +<rect fill="none" stroke="green" x="20" y="20" width="60" height="50" rx="3" ry="3"/> +<polyline fill="red" stroke="purple" points="80,10 90,20 85,40"/> +<polygon fill ="yellow" points="80,80 70,85 90,90"/> +</svg>} + set data(bad) {<svg xmlns="http://www.w3.org/2000/svg" width="0" height="0:w +"> +</svg>} + + tcltest::makeFile $data(plus) plus.svg + set data(plusFilePath) [file join [tcltest::configure -tmpdir] plus.svg] + + tcltest::makeFile $data(bad) bad.svg + set data(badFilePath) [file join [tcltest::configure -tmpdir] bad.svg] + +test imgSVGnano-1.1 {reading simple image} -setup { + catch {rename foo ""} +} -body { + image create photo foo -data $data(plus) + list [image width foo] [image height foo] +} -cleanup { + rename foo "" +} -result {100 100} + +test imgSVGnano-1.2 {simple image with options} -setup { + catch {rename foo ""} +} -body { + image create photo foo -data $data(plus) -format {svg -dpi 100 -scale 3} + list [image width foo] [image height foo] +} -cleanup { + rename foo "" +} -result {300 300} + +# test on crash found by Koen Danckaert +test imgSVGnano-1.3 {reformat image options} -setup { + catch {rename foo ""} +} -body { + image create photo foo -data $data(plus) + catch {foo configure -format {svg -scale}} + list {} +} -cleanup { + rename foo "" +} -result {{}} + +test imgSVGnano-1.4 {image options} -setup { + catch {rename foo ""} +} -body { + image create photo foo -data $data(plus) + foo configure -format {svg -scale 2} + foo configure -format {svg -dpi 600} + list [image width foo] [image height foo] +} -cleanup { + rename foo "" +} -result {100 100} +test imgSVGnano-1.5 {reading simple image from file} -setup { + catch {rename foo ""} +} -body { + image create photo foo -file $data(plusFilePath) + list [image width foo] [image height foo] +} -cleanup { + rename foo "" +} -result {100 100} + +test imgSVGnano-1.6 {simple image with options} -setup { + catch {rename foo ""} +} -body { + image create photo foo -file $data(plusFilePath) -format {svg -dpi 100 -scale 3} + list [image width foo] [image height foo] +} -cleanup { + rename foo "" +} -result {300 300} +test imgSVGnano-1.7 {Very small scale gives 1x1 image} -body { + image create photo foo -format "svg -scale 0.000001"\ + -data $data(plus) + list [image width foo] [image height foo] +} -cleanup { + rename foo "" +} -result {1 1} +test imgSVGnano-1.8 {Very small scale gives 1x1 image from file} -body { + image create photo foo -format "svg -scale 0.000001"\ + -file $data(plusFilePath) + list [image width foo] [image height foo] +} -cleanup { + rename foo "" +} -result {1 1} + +test imgSVGnano-2.1 {reading a bad image} -body { + image create photo foo -format svg -data $data(bad) +} -returnCodes error -result {couldn't recognize image data} +test imgSVGnano-2.2 {using bad option} -body { + image create photo foo -data $data(plus) -format {svg -scale 0} +} -returnCodes error -result {-scale value must be positive} +test imgSVGnano-2.3 {using bad option} -body { + image create photo foo -data $data(plus) + foo configure -format {svg 1.0} +} -cleanup { + rename foo "" +} -returnCodes error -result {bad option "1.0": must be -dpi, -scale, -scaletoheight, or -scaletowidth} +test imgSVGnano-2.4 {reading a bad image from file} -body { + image create photo foo -format svg -file $data(badFilePath) +} -returnCodes error -match glob\ + -result {couldn't recognize data in image file "*/bad.svg"} + +# -scaletoheight and -scaletowidth options +test imgSVGnano-3.1 {multiple scale options} -body { + image create photo foo -format "svg -scale 1 -scaletowidth 20"\ + -data $data(bad) +} -returnCodes error -result {only one of -scale, -scaletoheight, -scaletowidth may be given} + +test imgSVGnano-3.2 {no number parameter to -scaletowidth} -body { + image create photo foo -format "svg -scaletowidth invalid"\ + -data $data(plus) +} -returnCodes error -result {expected integer but got "invalid"} + +test imgSVGnano-3.3 {no number parameter to -scaletoheight} -body { + image create photo foo -format "svg -scaletoheight invalid"\ + -data $data(plus) +} -returnCodes error -result {expected integer but got "invalid"} + +test imgSVGnano-3.4 {zero parameter to -scaletowidth} -body { + image create photo foo -format "svg -scaletowidth 0"\ + -data $data(plus) +} -returnCodes error -result {-scaletowidth value must be positive} + +test imgSVGnano-3.5 {zero parameter to -scaletoheight} -body { + image create photo foo -format "svg -scaletoheight 0"\ + -data $data(plus) +} -returnCodes error -result {-scaletoheight value must be positive} + +test imgSVGnano-3.6 {no number parameter to -scaletoheight} -body { + image create photo foo -format "svg -scaletoheight invalid"\ + -data $data(plus) +} -returnCodes error -result {expected integer but got "invalid"} + +test imgSVGnano-3.7 {Option -scaletowidth} -body { + image create photo foo -format "svg -scaletowidth 20"\ + -data $data(plus) + image width foo +} -cleanup { + rename foo "" +} -result {20} + +test imgSVGnano-3.8 {Option -scaletoheight} -body { + image create photo foo -format "svg -scaletoheight 20"\ + -data $data(plus) + image height foo +} -cleanup { + rename foo "" +} -result {20} + +test imgSVGnano-3.10 {change from -scaletoheight to -scale} -body { + set res {} + image create photo foo -format "svg -scaletoheight 16"\ + -data $data(plus) + lappend res [image width foo] [image height foo] + foo configure -format "svg -scale 2" + lappend res [image width foo] [image height foo] +} -cleanup { + rename foo "" + unset res +} -result {16 16 200 200} + +# svg file access +test imgSVGnano-4.1 {reread file on configure -scale} -setup { + catch {rename foo ""} + set res {} +} -body { + image create photo foo -file $data(plusFilePath) + lappend res [image width foo] [image height foo] + foo configure -format "svg -scale 2" + lappend res [image width foo] [image height foo] +} -cleanup { + rename foo "" + unset res +} -result {100 100 200 200} + + +test imgSVGnano-4.2 {error on file not accessible on reread due to configure} -setup { + catch {rename foo ""} + tcltest::makeFile $data(plus) tmpplus.svg + image create photo foo -file [file join [tcltest::configure -tmpdir] tmpplus.svg] + tcltest::removeFile tmpplus.svg +} -body { + foo configure -format "svg -scale 2" +} -cleanup { + rename foo "" + tcltest::removeFile tmpplus.svg +} -returnCodes error -match glob -result {couldn't open "*/tmpplus.svg": no such file or directory} + +};# end of namespace svgnano + +namespace delete svgnano +imageFinish +cleanupTests +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/listbox.test b/tests/listbox.test index 14c5c97..98ec96c 100644 --- a/tests/listbox.test +++ b/tests/listbox.test @@ -724,7 +724,7 @@ test listbox-3.62 {ListboxWidgetCmd procedure, "index" option} -body { } -result 18 test listbox-3.63 {ListboxWidgetCmd procedure, "index" option} -body { .l index 34 -} -result 34 +} -result 18 test listbox-3.64 {ListboxWidgetCmd procedure, "insert" option} -body { .l insert } -returnCodes error -result {wrong # args: should be ".l insert index ?element ...?"} @@ -2112,7 +2112,7 @@ test listbox-10.17 {GetListboxIndex procedure} -setup { .l index 20 } -cleanup { destroy .l -} -result {20} +} -result {12} test listbox-10.18 {GetListboxIndex procedure} -setup { destroy .l } -body { @@ -2132,7 +2132,7 @@ test listbox-10.19 {GetListboxIndex procedure} -setup { .l index -2 } -cleanup { destroy .l -} -result -2 +} -result -1 test listbox-10.20 {GetListboxIndex procedure} -setup { destroy .l } -body { @@ -2143,7 +2143,7 @@ test listbox-10.20 {GetListboxIndex procedure} -setup { .l index 1 } -cleanup { destroy .l -} -result 1 +} -result 0 test listbox-11.1 {ChangeListboxView procedure, boundary conditions for index} -setup { @@ -2666,7 +2666,7 @@ test listbox-21.9 {ListboxListVarProc, test hscrollbar after listvar mod} -setup listbox .l -font $fixed -width 10 -xscrollcommand "record x" -listvar x set log {} pack .l - set timeout [after 500 {set log timeout}] + set timeout [after 500 {set log timeout}] vwait log lappend x "0000000000" update @@ -2684,7 +2684,7 @@ test listbox-21.10 {ListboxListVarProc, test hscrollbar after listvar mod} -setu listbox .l -font $fixed -width 10 -xscrollcommand "record x" -listvar x set log {} pack .l - set timeout [after 500 {set log timeout}] + set timeout [after 500 {set log timeout}] vwait log lappend x "0000000000" update @@ -2764,7 +2764,7 @@ test listbox-21.15 {ListboxListVarProc, update vertical scrollbar} -setup { update set log {} pack .l - set timeout [after 500 {set log timeout}] + set timeout [after 500 {set log timeout}] vwait log update lappend x a b c d e f @@ -2803,7 +2803,7 @@ test listbox-22.1 {UpdateHScrollbar} -setup { listbox .l -font $fixed -width 10 -xscrollcommand "record x" set log {} pack .l - set timeout [after 500 {set log timeout}] + set timeout [after 500 {set log timeout}] vwait log .l insert end "0000000000" update @@ -3156,7 +3156,7 @@ test listbox-31.1 {<<ListboxSelect>> event} -setup { bind .l <<ListboxSelect>> {lappend res [%W curselection]} .l insert end a b c focus -force .l - event generate .l <1> -x 5 -y 5 ; # <<ListboxSelect>> fires + event generate .l <Button-1> -x 5 -y 5 ; # <<ListboxSelect>> fires .l configure -state disabled focus -force .l event generate .l <Control-Home> ; # <<ListboxSelect>> does NOT fire @@ -3179,7 +3179,7 @@ test listbox-31.2 {<<ListboxSelect>> event on lost selection} -setup { bind .l <<ListboxSelect>> {lappend res [list [selection own] [%W curselection]]} .l insert end a b c focus -force .l - event generate .l <1> -x 5 -y 5 ; # <<ListboxSelect>> fires + event generate .l <Button-1> -x 5 -y 5 ; # <<ListboxSelect>> fires selection clear ; # <<ListboxSelect>> fires again update set res diff --git a/tests/main.test b/tests/main.test index 7ab624f..deb0783 100644 --- a/tests/main.test +++ b/tests/main.test @@ -55,7 +55,7 @@ test main-2.2 {Tk_MainEx: -encoding option} -constraints stdio -setup { removeFile script } -result "script {} 0\n0\n" - # Procedure to simulate interactive typing of commands, line by line, + # Procedure to simulate interactive typing of commands, line by line, # for test 2.3 proc type {chan script} { foreach line [split $script \n] { diff --git a/tests/menu.test b/tests/menu.test index a7f5956..5d4884c 100644 --- a/tests/menu.test +++ b/tests/menu.test @@ -29,7 +29,7 @@ test menu-1.4 {Tk_MenuCmd procedure} -body { destroy .m1 menu .m1 } -cleanup { - deleteWindows + deleteWindows } -result {.m1} test menu-1.5 {Tk_MenuCmd - creating menubar} -setup { destroy .m1 @@ -38,19 +38,19 @@ test menu-1.5 {Tk_MenuCmd - creating menubar} -setup { .m1 add cascade -label Test -menu "" list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-1.6 {Tk_MenuCmd procedure menu ref no cascade} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 menu .m1 } -cleanup { - deleteWindows + deleteWindows } -result {.m1} test menu-1.7 {Tk_MenuCmd procedure one clone cascade} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 @@ -58,10 +58,10 @@ test menu-1.7 {Tk_MenuCmd procedure one clone cascade} -setup { .m1 add cascade -menu .m2 menu .m2 } -cleanup { - deleteWindows + deleteWindows } -result {.m2} test menu-1.8 {Tk_MenuCmd procedure two clone cascades} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade -menu .m2 @@ -71,10 +71,10 @@ test menu-1.8 {Tk_MenuCmd procedure two clone cascades} -setup { wm geometry .t3 +0+0 menu .m2 } -cleanup { - deleteWindows + deleteWindows } -result {.m2} test menu-1.9 {Tk_MenuCmd procedure two clone cascades different order} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 @@ -84,10 +84,10 @@ test menu-1.9 {Tk_MenuCmd procedure two clone cascades different order} -setup { wm geometry .t3 +0+0 list [menu .m2] } -cleanup { - deleteWindows + deleteWindows } -result {.m2} test menu-1.10 {Tk_MenuCmd procedure two clone cascades menus last} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 @@ -97,10 +97,10 @@ test menu-1.10 {Tk_MenuCmd procedure two clone cascades menus last} -setup { .m1 add cascade -menu .m2 list [menu .m2] } -cleanup { - deleteWindows + deleteWindows } -result {.m2} test menu-1.11 {Tk_MenuCmd procedure three clones cascades} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 @@ -112,19 +112,19 @@ test menu-1.11 {Tk_MenuCmd procedure three clones cascades} -setup { .m1 add cascade -menu .m2 list [menu .m2] } -cleanup { - deleteWindows + deleteWindows } -result {.m2} test menu-1.12 {Tk_MenuCmd procedure} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 list [menu .m1] } -cleanup { - deleteWindows + deleteWindows } -result {.m1} test menu-1.13 {Tk_MenuCmd procedure} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 @@ -132,10 +132,10 @@ test menu-1.13 {Tk_MenuCmd procedure} -setup { wm geometry .t3 +0+0 list [menu .m1] } -cleanup { - deleteWindows + deleteWindows } -result {.m1} test menu-1.14 {Tk_MenuCmd procedure} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 @@ -145,7 +145,7 @@ test menu-1.14 {Tk_MenuCmd procedure} -setup { wm geometry .t4 +0+0 list [menu .m1] } -cleanup { - deleteWindows + deleteWindows } -result {.m1} # Used for 2.1 - 2.30 tests @@ -175,6 +175,14 @@ test menu-2.6 {configuration options -activeforeground non-existent} -body { .m1 configure -activeforeground non-existent } -returnCodes error -result {unknown color name "non-existent"} +test menu-2.6a {configuration options -activerelief sunken} -body { + .m1 configure -activerelief sunken + .m1 cget -activerelief +} -result {sunken} +test menu-2.6b {configuration options -activerelief badValue} -body { + .m1 configure -activerelief badValue +} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} + test menu-2.7 {configuration options -background #ff0000} -body { .m1 configure -background #ff0000 .m1 cget -background @@ -276,7 +284,7 @@ destroy .m1 # We need to test all of the options with all of the different types of # menu entries. The following code sets up .m1 with 6 items. It then # runs through the 2.31 - 2.228 tests below -# index 0 is tearoff, 1 command, 2 cascade, 3 separator, 4 checkbutton, +# index 0 is tearoff, 1 command, 2 cascade, 3 separator, 4 checkbutton, # 5 radiobutton deleteWindows menu .m1 -tearoff 1 @@ -771,34 +779,34 @@ test menu-2.132 {entry configuration options 5 -image bogus radiobutton} -body { } -returnCodes error -result {image "bogus" doesn't exist} test menu-2.133 {entry configuration options 0 -image {} tearoff} -body { - .m1 entryconfigure 0 -image + .m1 entryconfigure 0 -image } -returnCodes error -result {unknown option "-image"} test menu-2.134 {entry configuration options 1 -image {} command} -setup { .m1 entryconfigure 1 -image {} } -body { - .m1 entryconfigure 1 -image + .m1 entryconfigure 1 -image lindex [.m1 entryconfigure 1 -image] 4 } -result {} test menu-2.135 {entry configuration options 2 -image {} cascade} -setup { .m1 entryconfigure 2 -image {} } -body { - .m1 entryconfigure 2 -image + .m1 entryconfigure 2 -image lindex [.m1 entryconfigure 2 -image] 4 } -result {} test menu-2.136 {entry configuration options 3 -image {} separator} -body { - .m1 entryconfigure 3 -image + .m1 entryconfigure 3 -image } -returnCodes error -result {unknown option "-image"} test menu-2.137 {entry configuration options 4 -image {} checkbutton} -body { - .m1 entryconfigure 4 -image + .m1 entryconfigure 4 -image lindex [.m1 entryconfigure 4 -image] 4 } -result {} test menu-2.138 {entry configuration options 5 -image {} radiobutton} -body { - .m1 entryconfigure 5 -image + .m1 entryconfigure 5 -image lindex [.m1 entryconfigure 5 -image] 4 } -result {} @@ -1052,28 +1060,28 @@ test menu-2.192 {entry configuration options 5 -selectimage bogus radiobutton} - } -returnCodes error -result {image "bogus" doesn't exist} test menu-2.193 {entry configuration options 0 -selectimage {} tearoff} -body { - .m1 entryconfigure 0 -selectimage + .m1 entryconfigure 0 -selectimage } -returnCodes error -result {unknown option "-selectimage"} test menu-2.194 {entry configuration options 1 -selectimage {} command} -body { - .m1 entryconfigure 1 -selectimage + .m1 entryconfigure 1 -selectimage } -returnCodes error -result {unknown option "-selectimage"} test menu-2.195 {entry configuration options 2 -selectimage {} cascade} -body { - .m1 entryconfigure 2 -selectimage + .m1 entryconfigure 2 -selectimage } -returnCodes error -result {unknown option "-selectimage"} test menu-2.196 {entry configuration options 3 -selectimage {} separator} -body { - .m1 entryconfigure 3 -selectimage + .m1 entryconfigure 3 -selectimage } -returnCodes error -result {unknown option "-selectimage"} test menu-2.197 {entry configuration options 4 -selectimage {} checkbutton} -body { - .m1 entryconfigure 4 -selectimage + .m1 entryconfigure 4 -selectimage lindex [.m1 entryconfigure 4 -selectimage] 4 } -result {} test menu-2.198 {entry configuration options 5 -selectimage {} radiobutton} -body { - .m1 entryconfigure 5 -selectimage + .m1 entryconfigure 5 -selectimage lindex [.m1 entryconfigure 5 -selectimage] 4 } -result {} @@ -1225,7 +1233,7 @@ test menu-3.1 {MenuWidgetCmd procedure} -setup { destroy .m1 } -returnCodes error -result {wrong # args: should be ".m1 option ?arg ...?"} test menu-3.2 {MenuWidgetCmd, Tcl_Preserve and Tcl_Release} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -setup { destroy .m1 } -body { @@ -1237,7 +1245,7 @@ test menu-3.2 {MenuWidgetCmd, Tcl_Preserve and Tcl_Release} -constraints { } -returnCodes ok -result {} test menu-3.3 {MenuWidgetCmd procedure, "activate" option} -setup { destroy .m1 -} -body { +} -body { menu .m1 .m1 add command -label "test" .m1 activate @@ -1359,7 +1367,7 @@ test menu-3.18 {MenuWidgetCmd procedure, "configure" option} -setup { llength [.m1 configure] } -cleanup { destroy .m1 -} -result {20} +} -result {21} test menu-3.19 {MenuWidgetCmd procedure, "configure" option} -setup { destroy .m1 } -body { @@ -1414,7 +1422,7 @@ test menu-3.26 {MenuWidgetCmd procedure, "delete" option} -setup { } -body { menu .m1 .m1 add command -label "foo" - .m1 delete 1 0 + .m1 delete 1 0 } -cleanup { destroy .m1 } -result {} @@ -1627,9 +1635,9 @@ test menu-3.50 {MenuWidgetCmd procedure, "post" option} -constraints { nonUnixUserInteraction } -setup { destroy .m1 -} -body { +} -body { menu .m1 - .m1 add command -label "menu-3.53: hit Escape" -command "puts hello" + .m1 add command -label "menu-3.50: hit Escape" -command "puts hello" .m1 post 40 40 } -cleanup { destroy .m1 @@ -1654,9 +1662,9 @@ test menu-3.53 {MenuWidgetCmd procedure, "postcascade" option} -constraints { nonUnixUserInteraction } -setup { destroy .m1 .m2 -} -body { +} -body { menu .m1 - .m1 add command -label "menu-3.56 - hit Escape" + .m1 add command -label "menu-3.53 - hit Escape" menu .m2 .m1 post 40 40 .m1 add cascade -menu .m2 @@ -1756,10 +1764,10 @@ test menu-3.64 {MenuWidgetCmd procedure, "unpost" option} -constraints { nonUnixUserInteraction } -setup { destroy .m1 -} -body { +} -body { menu .m1 - .m1 add command -label "menu-3.68 - hit Escape" - .m1 post 40 40 + .m1 add command -label "menu-3.64 - hit Escape" + .m1 post 40 40 .m1 unpost } -cleanup { destroy .m1 @@ -1813,7 +1821,7 @@ test menu-3.67 {MenuWidgetCmd procedure, bad option} -setup { destroy .m1 } -returnCodes error -result {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, xposition, or yposition} test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} -setup { - deleteWindows + deleteWindows } -body { set t .t set m1 .t.m1 @@ -1831,7 +1839,7 @@ test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} -setup { $t configure -menu "" list [winfo exists $c1] [winfo exists $c2] } -cleanup { - deleteWindows + deleteWindows } -result {1 1} test menu-3.69 {MenuWidgetCmd procedure, "xposition" option} -setup { destroy .m1 @@ -1869,7 +1877,7 @@ test menu-4.2 {TkInvokeMenu: tearoff} -setup { menu .m1 catch {.m1 invoke 0} } -cleanup { - deleteWindows + deleteWindows } -result {0} test menu-4.3 {TkInvokeMenu: checkbutton -on} -setup { destroy .m1 @@ -1898,7 +1906,7 @@ test menu-4.5 {TkInvokeMenu: checkbutton array element} -setup { } -body { catch {unset foo} menu .m1 - .m1 add checkbutton -label "test" -variable foo(1) -onvalue on + .m1 add checkbutton -label "test" -variable foo(1) -onvalue on list [catch {.m1 invoke 1} msg] $msg [catch {set foo(1)} msg2] $msg2 [catch {unset foo} msg3] $msg3 } -cleanup { destroy .m1 @@ -1966,7 +1974,7 @@ test menu-4.11 {TkInvokeMenu} -setup { } -body { menu .m1 .m1 add cascade -label "test" -menu .m1.m2 - list [catch {.m1 invoke 1} msg] $msg + list [catch {.m1 invoke 1} msg] $msg } -cleanup { destroy .m1 } -result {0 {}} @@ -2026,7 +2034,7 @@ test menu-5.5 {DestroyMenuInstance - cascades of cloned menus} -setup { list [destroy .m2] [.m1 entrycget 1 -menu] [. configure -menu ""] [destroy .m1] } -returnCodes ok -result {{} .m2 {} {}} test menu-5.6 {DestroyMenuInstance - cascades of cloned menus} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade -menu .m2 @@ -2122,8 +2130,8 @@ test menu-6.4 {TkDestroyMenu - reentrancy - clones} -setup { .m1 clone .m1.m3 destroy .m1 } -cleanup { - deleteWindows -} -returnCodes ok + deleteWindows +} -returnCodes ok test menu-6.5 {TkDestroyMenu} -setup { destroy .m1 .m2 } -body { @@ -2263,7 +2271,7 @@ test menu-7.4 {UnhookCascadeEntry} -setup { list [destroy .m1] [destroy .m2] } -returnCodes ok -result {{} {}} test menu-7.5 {UnhookCascadeEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .m2 @@ -2274,7 +2282,7 @@ test menu-7.5 {UnhookCascadeEntry} -setup { list [destroy .m1] [destroy .m2 .m3] } -returnCodes ok -result {{} {}} test menu-7.6 {UnhookCascadeEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .m2 @@ -2285,7 +2293,7 @@ test menu-7.6 {UnhookCascadeEntry} -setup { list [destroy .m2] [destroy .m1 .m3] } -returnCodes ok -result {{} {}} test menu-7.7 {UnhookCascadeEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .m2 @@ -2296,7 +2304,7 @@ test menu-7.7 {UnhookCascadeEntry} -setup { list [destroy .m3] [destroy .m1 .m2] } -returnCodes ok -result {{} {}} test menu-7.8 {UnhookCascadeEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .m2 @@ -2350,7 +2358,7 @@ test menu-8.4 {DestroyMenuEntry} -setup { menu .m1 .m1 add checkbutton -variable foo list [.m1 delete 1] [destroy .m1] -} -result {{} {}} +} -result {{} {}} test menu-8.5 {DestroyMenuEntry} -setup { destroy .m1 } -body { @@ -2367,7 +2375,7 @@ test menu-8.6 {DestroyMenuEntry} -setup { list [.m1 delete 1] [.m1 entrycget 1 -label] [destroy .m1] } -result {{} two {}} test menu-8.7 {DestroyMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "one" @@ -2382,9 +2390,9 @@ test menu-9.1 {ConfigureMenu} -setup { destroy .m1 } -body { menu .m1 - list [.m1 configure -postcommand "beep"] [.m1 cget -postcommand] + list [.m1 configure -postcommand "beep"] [.m1 cget -postcommand] } -cleanup { - deleteWindows + deleteWindows } -result {{} beep} test menu-9.2 {ConfigureMenu} -setup { destroy .m1 @@ -2393,7 +2401,7 @@ test menu-9.2 {ConfigureMenu} -setup { .m1 add command -label "test" list [.m1 configure -tearoff 0] [.m1 entrycget 1 -label] } -cleanup { - deleteWindows + deleteWindows } -result {{} test} test menu-9.3 {ConfigureMenu} -setup { destroy .m1 @@ -2401,7 +2409,7 @@ test menu-9.3 {ConfigureMenu} -setup { menu .m1 list [.m1 configure -postcommand "beep"] [.m1 cget -postcommand] } -cleanup { - deleteWindows + deleteWindows } -result {{} beep} test menu-9.4 {ConfigureMenu} -setup { destroy .m1 @@ -2410,7 +2418,7 @@ test menu-9.4 {ConfigureMenu} -setup { .m1 add command -label "test" .m1 configure -fg red } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-9.5 {ConfigureMenu} -setup { destroy .m1 @@ -2420,7 +2428,7 @@ test menu-9.5 {ConfigureMenu} -setup { .m1 add command -label "two" .m1 configure -fg red } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-9.6 {ConfigureMenu} -setup { destroy .m1 @@ -2431,25 +2439,25 @@ test menu-9.6 {ConfigureMenu} -setup { .m1 add command -label "three" .m1 configure -fg red } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-9.7 {ConfigureMenu} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 tearoff list [.m1 configure -fg red] [.m2 cget -fg] } -cleanup { - deleteWindows + deleteWindows } -result {{} red} test menu-9.8 {ConfigureMenu} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 tearoff list [.m2 configure -fg red] [.m1 cget -fg] } -cleanup { - deleteWindows + deleteWindows } -result {{} red} test menu-9.9 {ConfigureMenu} -setup { destroy .m1 @@ -2457,7 +2465,7 @@ test menu-9.9 {ConfigureMenu} -setup { menu .m1 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} @@ -2470,7 +2478,7 @@ test menu-10.1 {PostProcessEntry: array variable} -setup { .m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense" set foo(1) } -cleanup { - deleteWindows + deleteWindows } -result {on} test menu-10.2 {PostProcessEntry: array variable} -setup { destroy .m1 @@ -2480,7 +2488,7 @@ test menu-10.2 {PostProcessEntry: array variable} -setup { .m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense" set foo(1) } -cleanup { - deleteWindows + deleteWindows } -result {off} @@ -2492,7 +2500,7 @@ test menu-11.1 {ConfigureMenuEntry} -setup { .m1 add checkbutton -variable foo -onvalue on -offvalue off -label "Nonsense" list [.m1 entryconfigure 1 -variable bar] [.m1 entrycget 1 -variable] } -cleanup { - deleteWindows + deleteWindows } -result {{} bar} test menu-11.2 {ConfigureMenuEntry} -setup { destroy .m1 @@ -2501,7 +2509,7 @@ test menu-11.2 {ConfigureMenuEntry} -setup { .m1 add command -label "test" list [.m1 entryconfigure 1 -label ""] [.m1 entrycget 1 -label] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-11.3 {ConfigureMenuEntry} -setup { destroy .m1 @@ -2510,135 +2518,135 @@ test menu-11.3 {ConfigureMenuEntry} -setup { .m1 add command list [.m1 entryconfigure 1 -label "test"] [.m1 entrycget 1 -label] } -cleanup { - deleteWindows + deleteWindows } -result {{} test} test menu-11.4 {ConfigureMenuEntry} -setup { - deleteWindows + deleteWindows } -body { - menu .m1 + menu .m1 .m1 add command list [.m1 entryconfigure 1 -accel "S"] [.m1 entrycget 1 -accel] } -cleanup { - deleteWindows + deleteWindows } -result {{} S} test menu-11.5 {ConfigureMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command list [.m1 entryconfigure 1 -label "test"] [.m1 entrycget 1 -label] } -cleanup { - deleteWindows + deleteWindows } -result {{} test} test menu-11.6 {ConfigureMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command .m1 entryconfigure 1 -label "test" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-11.7 {ConfigureMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m2 menu .m1 .m1 add cascade .m1 entryconfigure 1 -label "test" -menu .m2 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-11.8 {ConfigureMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade .m1 entryconfigure 1 -label "test" -menu .m2 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-11.9 {ConfigureMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade -menu .m3 .m1 entryconfigure 1 -label "test" -menu .m2 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-11.10 {ConfigureMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade .m1 entryconfigure 1 -label "test" -menu .m2 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-11.11 {ConfigureMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade -menu .m2 .m1 entryconfigure 1 -label "test" -menu .m2 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-11.12 {ConfigureMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 - menu .m2 + menu .m2 .m2 add cascade -menu .m1 - menu .m3 + menu .m3 .m3 add cascade -menu .m1 - menu .m4 + menu .m4 .m4 add cascade -menu .m1 - menu .m5 + menu .m5 .m5 add cascade .m5 entryconfigure 1 -label "test" -menu .m1 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-11.13 {ConfigureMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 - menu .m2 + menu .m2 .m2 add cascade -menu .m1 - menu .m3 + menu .m3 .m3 add cascade -menu .m1 - menu .m4 + menu .m4 .m4 add cascade -menu .m1 .m3 entryconfigure 1 -label "test" -menu .m1 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-11.14 {ConfigureMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add checkbutton list [.m1 entryconfigure 1 -variable "test"] [.m1 entrycget 1 -variable] } -cleanup { - deleteWindows + deleteWindows } -result {{} test} test menu-11.15 {ConfigureMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 list [.m1 add checkbutton -label "test"] [.m1 entrycget 1 -variable] } -cleanup { - deleteWindows + deleteWindows } -result {{} test} test menu-11.16 {ConfigureMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add radiobutton -label "test" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-11.17 {ConfigureMenuEntry} -setup { deleteWindows @@ -2844,35 +2852,35 @@ test menu-13.8 {TkGetMenuIndex} -setup { .m1 entrycget -1 -label } -returnCodes error -result {bad menu entry index "-1"} test menu-13.9 {TkGetMenuIndex} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" .m1 add command -label "test2" .m1 entrycget 999 -label } -cleanup { - deleteWindows + deleteWindows } -result {test2} test menu-13.10 {TkGetMenuIndex} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 insert 999 command -label "test" .m1 entrycget 1 -label } -cleanup { - deleteWindows + deleteWindows } -result {test} test menu-13.11 {TkGetMenuIndex} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "1test" .m1 entrycget 1test -label } -cleanup { - deleteWindows + deleteWindows } -result {1test} test menu-13.12 {TkGetMenuIndex} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" @@ -2880,176 +2888,176 @@ test menu-13.12 {TkGetMenuIndex} -setup { .m1 add command -label "test3" .m1 entrycget test2 -command } -cleanup { - deleteWindows + deleteWindows } -result {beep} test menu-14.1 {MenuCmdDeletedProc} -setup { - deleteWindows + deleteWindows } -body { menu .m1 destroy .m1 } -cleanup { - deleteWindows + deleteWindows } -returnCodes ok test menu-14.2 {MenuCmdDeletedProc} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 destroy .m1 } -cleanup { - deleteWindows + deleteWindows } -returnCodes ok test menu-15.1 {MenuNewEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-15.2 {MenuNewEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" .m1 add command -label "test3" .m1 insert 2 command -label "test2" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-15.3 {MenuNewEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" .m1 add command -label "test2" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-15.4 {MenuNewEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.1 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 insert foo command -label "test" } -returnCodes error -result {bad menu entry index "foo"} test menu-16.2 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" .m1 insert test command -label "foo" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.3 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 insert -1 command -label "test" } -returnCodes error -result {bad menu entry index "-1"} test menu-16.4 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 -tearoff 1 .m1 add command -label "test" .m1 insert 0 command -label "test2" .m1 entrycget 1 -label } -cleanup { - deleteWindows + deleteWindows } -result {test2} test menu-16.5 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.6 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add checkbutton } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.7 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.8 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add radiobutton } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.9 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add separator } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.10 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add blork } -returnCodes error -result {bad menu entry type "blork": must be cascade, checkbutton, command, radiobutton, or separator} test menu-16.11 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.12 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 .m2 clone .m3 list [.m2 add command -label "test"] [.m1 entrycget 1 -label] [.m3 entrycget 1 -label] } -cleanup { - deleteWindows + deleteWindows } -result {{} test test} test menu-16.13 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 .m2 clone .m3 list [.m3 add command -label "test"] [.m1 entrycget 1 -label] [.m2 entrycget 1 -label] } -cleanup { - deleteWindows + deleteWindows } -result {{} test test} test menu-16.14 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -blork } -returnCodes error -result {unknown option "-blork"} test menu-16.15 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "File" @@ -3057,20 +3065,20 @@ test menu-16.15 {MenuAddOrInsert} -setup { . configure -menu .container list [.container add cascade -label "File" -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-16.16 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .m2 set tearoff [tk::TearOffMenu .m2] list [.m2 add cascade -menu .m1] [$tearoff unpost] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-16.17 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .container @@ -3078,10 +3086,10 @@ test menu-16.17 {MenuAddOrInsert} -setup { set tearoff [tk::TearOffMenu .container] list [.container add cascade -label "File" -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-16.18 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .container @@ -3089,10 +3097,10 @@ test menu-16.18 {MenuAddOrInsert} -setup { . configure -menu .container list [.container add cascade -label "File" -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-16.19 {MenuAddOrInsert - Insert a cascade deep into the tree} -setup { - deleteWindows + deleteWindows } -body { menu .menubar menu .menubar.test -tearoff 0 @@ -3105,12 +3113,12 @@ test menu-16.19 {MenuAddOrInsert - Insert a cascade deep into the tree} -setup { [info commands .\#menubar.\#menubar\#test.\#menubar\#test\#cascade] \ [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {0 .#menubar.#menubar#test.#menubar#test#cascade {}} test menu-17.1 {MenuVarProc} -setup { - deleteWindows + deleteWindows } -body { catch {unset foo} menu .m1 @@ -3118,21 +3126,21 @@ test menu-17.1 {MenuVarProc} -setup { list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \ [unset foo] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} # menu-17.2 - Don't know how to generate the flags in the if test menu-17.2 {MenuVarProc} -setup { - deleteWindows + deleteWindows } -body { catch {unset foo} menu .m1 list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \ [set foo ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-17.3 {MenuVarProc} -setup { - deleteWindows + deleteWindows } -body { catch {unset foo} menu .m1 @@ -3140,30 +3148,30 @@ test menu-17.3 {MenuVarProc} -setup { list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \ [set foo "hello"] [unset foo] } -cleanup { - deleteWindows + deleteWindows } -result {{} hello {}} test menu-17.4 {MenuVarProc} -setup { - deleteWindows + deleteWindows } -body { menu .m1 set foo "goodbye" list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \ [set foo "hello"] [unset foo] } -cleanup { - deleteWindows + deleteWindows } -result {{} hello {}} test menu-17.5 {MenuVarProc} -setup { - deleteWindows + deleteWindows } -body { menu .m1 set foo "hello" list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \ [set foo "goodbye"] [unset foo] } -cleanup { - deleteWindows + deleteWindows } -result {{} goodbye {}} test menu-17.6 {MenuVarProc [5d991b822e]} -setup { - deleteWindows + deleteWindows } -body { # Want this not to crash menu .b @@ -3174,10 +3182,10 @@ test menu-17.6 {MenuVarProc [5d991b822e]} -setup { }}} unset var } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-17.7 {MenuVarProc [5d991b822e]} -setup { - deleteWindows + deleteWindows } -body { # Want this not to duplicate traces menu .b @@ -3188,30 +3196,30 @@ test menu-17.7 {MenuVarProc [5d991b822e]} -setup { }}} unset var } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-18.1 {TkActivateMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" .m1 activate 1 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-18.2 {TkActivateMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" .m1 activate 0 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-18.3 {TkActivateMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" @@ -3219,10 +3227,10 @@ test menu-18.3 {TkActivateMenuEntry} -setup { .m1 activate 1 .m1 activate 2 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-18.4 {TkActivateMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" @@ -3230,112 +3238,112 @@ test menu-18.4 {TkActivateMenuEntry} -setup { .m1 activate 1 .m1 activate 1 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-19.1 {TkPostCommand} -constraints nonUnixUserInteraction -setup { - deleteWindows -} -body { + deleteWindows +} -body { menu .m1 -postcommand "set menu_test menu-19.1" .m1 add command -label "menu-19.1 - hit Escape" list [.m1 post 40 40] [.m1 unpost] [set menu_test] } -cleanup { - deleteWindows + deleteWindows } -result {menu-19.1 {} menu-19.1} test menu-19.2 {TkPostCommand} -constraints nonUnixUserInteraction -setup { - deleteWindows -} -body { + deleteWindows +} -body { menu .m1 .m1 add command -label "menu-19.2 - hit Escape" list [.m1 post 40 40] [.m1 unpost] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-20.1 {CloneMenu} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2] } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-20.2 {CloneMenu} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 normal - deleteWindows + deleteWindows } -result {} test menu-20.3 {CloneMenu} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 tearoff } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-20.4 {CloneMenu} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 menubar } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-20.5 {CloneMenu} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 foo } -returnCodes error -result {bad menu type "foo": must be normal, tearoff, or menubar} test menu-20.6 {CloneMenu - hooking up bookeeping ptrs} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-20.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 .m1 clone .m3 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-20.8 {CloneMenu - cascade entries} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade -menu .m2 .m1 clone .foo } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-20.9 {CloneMenu - cascades entries} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade -menu .m2 menu .m2 .m1 clone .foo } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-20.10 {CloneMenu - tearoff fields} -setup { - deleteWindows + deleteWindows } -body { menu .m1 -tearoff 1 list [.m1 clone .m2 normal] [.m2 cget -tearoff] } -cleanup { - deleteWindows + deleteWindows } -result {{} 1} test menu-20.11 {CloneMenu} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .m2 @@ -3343,43 +3351,43 @@ test menu-20.11 {CloneMenu} -setup { } -returnCodes error -result {window name "m2" already exists in parent} test menu-21.1 {MenuDoYPosition} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 yposition glorp } -returnCodes error -result {bad menu entry index "glorp"} test menu-21.2 {MenuDoYPosition} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "Test" .m1 yposition 1 } -cleanup { - deleteWindows + deleteWindows } -returnCodes ok -match glob -result {*} test menu-22.1 {GetIndexFromCoords} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" .m1 configure -tearoff 0 .m1 index @5 } -cleanup { - deleteWindows + deleteWindows } -result {0} test menu-22.2 {GetIndexFromCoords} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" .m1 configure -tearoff 0 .m1 index @5,5 } -cleanup { - deleteWindows + deleteWindows } -result {0} test menu-22.3 {GetIndexFromCoords: mapped window, y only} -setup { - deleteWindows + deleteWindows } -constraints {x11} -body { menu .m1 .m1 add command -label "test" @@ -3388,10 +3396,10 @@ test menu-22.3 {GetIndexFromCoords: mapped window, y only} -setup { tkwait visibility .m1 .m1 index @5 } -cleanup { - deleteWindows + deleteWindows } -result {0} test menu-22.4 {GetIndexFromCoords: mapped window x,y} -setup { - deleteWindows + deleteWindows } -constraints {x11} -body { menu .m1 .m1 add command -label "test" @@ -3402,10 +3410,10 @@ test menu-22.4 {GetIndexFromCoords: mapped window x,y} -setup { set x [expr {[winfo width .m1] - [.m1 cget -borderwidth] - 1}] .m1 index @$x,5 } -cleanup { - deleteWindows + deleteWindows } -result {0} test menu-22.5 {GetIndexFromCoords: mapped wide window} -setup { - deleteWindows + deleteWindows } -constraints {x11} -body { menu .m1 .m1 add command -label "test" @@ -3417,20 +3425,20 @@ test menu-22.5 {GetIndexFromCoords: mapped wide window} -setup { set x [expr {[winfo width .m1] - [.m1 cget -borderwidth] - 1}] .m1 index @$x,5 } -cleanup { - deleteWindows + deleteWindows } -result {0} test menu-23.1 {RecursivelyDeleteMenu} -setup { - deleteWindows + deleteWindows } -body { menu .m1 . configure -menu .m1 . configure -menu "" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-23.2 {RecursivelyDeleteMenu} -setup { - deleteWindows + deleteWindows } -body { menu .m2 .m2 add command -label "test2" @@ -3439,28 +3447,28 @@ test menu-23.2 {RecursivelyDeleteMenu} -setup { . configure -menu .m1 . configure -menu "" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-24.1 {TkNewMenuName} -setup { - deleteWindows + deleteWindows } -body { menu .m1 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-24.2 {TkNewMenuName} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .m1\#0 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-24.3 {TkNewMenuName} -setup { - deleteWindows + deleteWindows } -body { menu .#m rename .#m hideme @@ -3470,33 +3478,33 @@ test menu-24.3 {TkNewMenuName} -setup { test menu-25.1 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.2 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.3 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" destroy .m1 menu .m1 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.4 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3504,10 +3512,10 @@ test menu-25.4 {TkSetWindowMenuBar} -setup { menu .m2 list [. configure -menu .m2] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.5 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3516,10 +3524,10 @@ test menu-25.5 {TkSetWindowMenuBar} -setup { menu .m3 list [. configure -menu .m3] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.6 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3528,10 +3536,10 @@ test menu-25.6 {TkSetWindowMenuBar} -setup { menu .m3 list [. configure -menu .m3] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.7 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3541,10 +3549,10 @@ test menu-25.7 {TkSetWindowMenuBar} -setup { .t2 configure -menu .m1 list [.t2 configure -menu .m2] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.8 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3555,10 +3563,10 @@ test menu-25.8 {TkSetWindowMenuBar} -setup { .t2 configure -menu .m1 list [. configure -menu .m2] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.9 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3570,10 +3578,10 @@ test menu-25.9 {TkSetWindowMenuBar} -setup { wm geometry .t3 +0+0 list [.t3 configure -menu .m2] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.10 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3585,10 +3593,10 @@ test menu-25.10 {TkSetWindowMenuBar} -setup { wm geometry .t3 +0+0 list [.t2 configure -menu .m2] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.11 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3600,57 +3608,57 @@ test menu-25.11 {TkSetWindowMenuBar} -setup { wm geometry .t3 +0+0 list [. configure -menu .m2] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.12 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.13 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.14 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.15 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.16 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 . configure -menu .m1 list [toplevel .t2 -menu m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {.t2 {}} test menu-26.1 {DestroyMenuHashTable} -setup { catch {interp delete testinterp} - deleteWindows + deleteWindows } -body { interp create testinterp load {} Tk testinterp @@ -3661,48 +3669,48 @@ test menu-26.1 {DestroyMenuHashTable} -setup { test menu-27.1 {GetMenuHashTable} -setup { catch {interp delete testinterp} - deleteWindows + deleteWindows } -body { interp create testinterp load {} Tk testinterp list [catch {interp eval testinterp {menu .m1}} msg] $msg [interp delete testinterp] } -cleanup { - deleteWindows + deleteWindows } -result {0 .m1 {}} test menu-28.1 {TkCreateMenuReferences - not there before} -setup { - deleteWindows + deleteWindows } -body { menu .m1 } -cleanup { - deleteWindows + deleteWindows } -result {.m1} test menu-28.2 {TkCreateMenuReferences - there already} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade -menu .m2 menu .m2 } -cleanup { - deleteWindows + deleteWindows } -result {.m2} test menu-29.1 {TkFindMenuReferences - not there} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 .m1 add cascade -menu .m2 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-30.1 {TkFindMenuReferences - there already} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3710,38 +3718,38 @@ test menu-30.1 {TkFindMenuReferences - there already} -setup { .m1 add cascade -menu .m2 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-31.1 {TkFreeMenuReferences - menuPtr} -setup { - deleteWindows + deleteWindows } -body { menu .m1 destroy .m1 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-31.2 {TkFreeMenuReferences - cascadePtr} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 .m1 add cascade -menu .m2 .m1 entryconfigure 1 -menu .m3 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-31.3 {TkFreeMenuReferences - topLevelListPtr} -setup { - deleteWindows + deleteWindows } -body { . configure -menu .m1 . configure -menu "" } -cleanup { - deleteWindows + deleteWindows } -returnCodes ok -result {} test menu-31.4 {TkFreeMenuReferences - not empty} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade -menu .m3 @@ -3749,24 +3757,24 @@ test menu-31.4 {TkFreeMenuReferences - not empty} -setup { .m2 add cascade -menu .m3 .m2 entryconfigure 1 -menu ".foo" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.1 {DeleteMenuCloneEntries} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label foo .m1 clone .m2 .m1 delete 1 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.2 {DeleteMenuCloneEntries} -setup { - deleteWindows + deleteWindows } -body { - + menu .m1 .m1 add command -label one .m1 add command -label two @@ -3775,10 +3783,10 @@ test menu-32.2 {DeleteMenuCloneEntries} -setup { .m1 clone .m2 .m1 delete 2 3 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.3 {DeleteMenuCloneEntries} -setup { - deleteWindows + deleteWindows } -body { menu .m1 -tearoff 0 .m1 add command -label one @@ -3789,10 +3797,10 @@ test menu-32.3 {DeleteMenuCloneEntries} -setup { .m2 configure -tearoff 1 .m1 delete 1 2 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.4 {DeleteMenuCloneEntries} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label one @@ -3803,10 +3811,10 @@ test menu-32.4 {DeleteMenuCloneEntries} -setup { .m2 configure -tearoff 0 .m1 delete 2 3 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.5 {DeleteMenuCloneEntries} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label one @@ -3815,29 +3823,29 @@ test menu-32.5 {DeleteMenuCloneEntries} -setup { .m1 activate one .m1 delete one } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.6 {DeleteMenuCloneEntries - reentrancy - crashes tk8.0} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label test \ -command ".m1 delete test ; .m1 add command -label test -command \".m1 delete test\"; .m1 delete test" .m1 invoke test } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.7 {DeleteMenuCloneEntries - one entry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 -tearoff 0 .m1 add command -label Hello .m1 delete Hello } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.8 {Ensure all menu clone commands are deleted} -setup { - deleteWindows + deleteWindows } -body { # SF bug #465324 menu .menubar @@ -3851,11 +3859,11 @@ test menu-32.8 {Ensure all menu clone commands are deleted} -setup { info commands .#menubar*test* } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} -setup { set res {} - deleteWindows + deleteWindows } -body { menu .menubar . configure -menu .menubar @@ -3873,12 +3881,12 @@ test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} -setup { lappend res [.#menubar.#menubar#test entrycget 1 -menu] return $res } -cleanup { - deleteWindows + deleteWindows } -result {.menubar.cascade .#menubar.#menubar#test.#menubar#cascade .menubar.cascade .#menubar.#menubar#test.#menubar#cascade} test menu-33.1 {menu vs command hiding} -setup { - deleteWindows + deleteWindows } -body { set l [interp hidden] menu .m @@ -3896,7 +3904,7 @@ test menu-33.1 {menu vs command hiding} -setup { test menu-34.1 {menus on multiple screens - crashes tk8.3.1, Bug 5454} -constraints { altDisplay } -setup { - deleteWindows + deleteWindows } -body { toplevel .one menu .one.m @@ -3916,7 +3924,7 @@ test menu-35.1 {menu -underline string overruns Bug 1599877} -setup { update tk::TraverseToMenu . "e" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-37.1 {menubar menues cannot be posted - bug 2160206} -setup { @@ -3941,14 +3949,14 @@ test menu-38.1 {Can't dismiss ttk::menubutton menu until mouse has hovered over pack .top.mb update # simulate mouse click on the menubutton, which posts its menu - event generate .top.mb <ButtonPress-1> -warp 1 + event generate .top.mb <Button-1> -warp 1 update after 50 event generate .top.mb <ButtonRelease-1> update # simulate mouse click on the menu again, i.e. without # entering/leaving the posted menu - event generate .top.mb <ButtonPress-1> + event generate .top.mb <Button-1> update after 50 event generate .top.mb <ButtonRelease-1> diff --git a/tests/menuDraw.test b/tests/menuDraw.test index 0d7a049..9382974 100644 --- a/tests/menuDraw.test +++ b/tests/menuDraw.test @@ -76,7 +76,7 @@ test menuDraw-5.3 {TkMenuConfigureDrawOptions - no disabledFg} -setup { menu .m1 -disabledforeground "" } -cleanup { deleteWindows -} -result {.m1} +} -result {.m1} test menuDraw-6.1 {TkMenuConfigureEntryDrawOptions - no tkfont specified} -setup { @@ -321,7 +321,7 @@ test menuDraw-10.4 {ComputeMenuGeometry - resize not necessary} -setup { test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} -constraints { - testImageType + testImageType } -setup { deleteWindows imageCleanup @@ -338,7 +338,7 @@ test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} imageCleanup } -result {{} {}} test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} -constraints { - testImageType + testImageType } -setup { deleteWindows imageCleanup @@ -354,7 +354,7 @@ test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} -con imageCleanup } -result {{} {}} test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} -constraints { - testImageType + testImageType } -setup { deleteWindows imageCleanup @@ -451,7 +451,7 @@ test menuDraw.12.7 {DisplayMenu - three columns} -setup { deleteWindows } -result {} test menuDraw-12.6 {Display menu - testing for extra space and menubars} -constraints { - unix + unix } -setup { deleteWindows } -body { @@ -668,7 +668,7 @@ test menuDraw-16.6 {TkPostSubMenu} -constraints { menu .m2 .m2 add command -label "Hit ESCAPE to get rid of this menu" set tearoff [tk::TearOffMenu .m1 40 40] - $tearoff postcascade 0 + $tearoff postcascade 0 } -cleanup { deleteWindows } -result {} diff --git a/tests/menubut.test b/tests/menubut.test index 4ac5d92..d245fd0 100644 --- a/tests/menubut.test +++ b/tests/menubut.test @@ -394,7 +394,7 @@ test menubutton-4.1 {ConfigureMenuButton procedure} -setup { .mb1 configure -width 1i } -cleanup { deleteWindows -} -returnCodes error -result {expected integer but got "1i"} +} -returnCodes error -result {expected integer but got "1i"} test menubutton-4.2 {ConfigureMenuButton procedure} -setup { deleteWindows } -body { @@ -451,7 +451,7 @@ test menubutton-4.6 {ConfigureMenuButton procedure} -setup { ".mb1 configure -width abc"} test menubutton-4.7 {ConfigureMenuButton procedure} -constraints { - testImageType + testImageType } -setup { deleteWindows imageCleanup @@ -464,7 +464,7 @@ test menubutton-4.7 {ConfigureMenuButton procedure} -constraints { imageCleanup } -returnCodes error -result {bad screen distance "0.5x"} test menubutton-4.8 {ConfigureMenuButton procedure} -constraints { - testImageType + testImageType } -setup { deleteWindows imageCleanup @@ -499,7 +499,7 @@ test menubutton-4.10 {ConfigureMenuButton procedure - bad direction} -setup { deleteWindows } -body { menubutton .mb -text "Test" - .mb configure -direction badValue + .mb configure -direction badValue } -cleanup { deleteWindows } -returnCodes error -result {bad direction "badValue": must be above, below, flush, left, or right} @@ -548,7 +548,7 @@ if {[tk windowingsystem] == "aqua"} { set extraWidth 0 } test menubutton-7.1 {ComputeMenuButtonGeometry procedure} -constraints { - testImageType + testImageType } -setup { deleteWindows image create test image1 @@ -561,7 +561,7 @@ test menubutton-7.1 {ComputeMenuButtonGeometry procedure} -constraints { imageCleanup } -result [list [expr {38 + $extraWidth}] 23] test menubutton-7.2 {ComputeMenuButtonGeometry procedure} -constraints { - testImageType + testImageType } -setup { deleteWindows image create test image1 @@ -574,7 +574,7 @@ test menubutton-7.2 {ComputeMenuButtonGeometry procedure} -constraints { imageCleanup } -result [list [expr {38 + $extraWidth}] 23] test menubutton-7.3 {ComputeMenuButtonGeometry procedure} -constraints { - testImageType + testImageType } -setup { deleteWindows image create test image1 @@ -587,7 +587,7 @@ test menubutton-7.3 {ComputeMenuButtonGeometry procedure} -constraints { imageCleanup } -result [list [expr {38 + $extraWidth}] 23] test menubutton-7.4 {ComputeMenuButtonGeometry procedure} -constraints { - testImageType + testImageType } -setup { deleteWindows image create test image1 @@ -601,7 +601,7 @@ test menubutton-7.4 {ComputeMenuButtonGeometry procedure} -constraints { imageCleanup } -result [list [expr {48 + $extraWidth}] 23] test menubutton-7.5 {ComputeMenuButtonGeometry procedure} -constraints { - testImageType + testImageType } -setup { deleteWindows image create test image1 diff --git a/tests/message.test b/tests/message.test index b90e89c..2ca6921 100644 --- a/tests/message.test +++ b/tests/message.test @@ -12,8 +12,8 @@ tcltest::loadTestedCommands eval tcltest::configure $argv -test message-1.1 {configuration option: "anchor"} -setup { - message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} +test message-1.1 {configuration option: "anchor"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m update } -body { @@ -32,10 +32,10 @@ test message-1.2 {configuration option: "anchor"} -setup { destroy .m } -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center} -test message-1.3 {configuration option: "aspect"} -setup { +test message-1.3 {configuration option: "aspect"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -aspect 3 .m cget -aspect @@ -52,10 +52,10 @@ test message-1.4 {configuration option: "aspect"} -setup { destroy .m } -returnCodes {error} -result {expected integer but got "bogus"} -test message-1.5 {configuration option: "background"} -setup { +test message-1.5 {configuration option: "background"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -background #ff0000 .m cget -background @@ -72,10 +72,10 @@ test message-1.6 {configuration option: "background"} -setup { destroy .m } -returnCodes {error} -result {unknown color name "non-existent"} -test message-1.7 {configuration option: "bd"} -setup { +test message-1.7 {configuration option: "bd"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -bd 4 .m cget -bd @@ -92,12 +92,12 @@ test message-1.8 {configuration option: "bd"} -setup { destroy .m } -returnCodes {error} -result {bad screen distance "badValue"} -test message-1.9 {configuration option: "bg"} -setup { +test message-1.9 {configuration option: "bg"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { - .m configure -bg #ff0000 + .m configure -bg #ff0000 .m cget -bg } -cleanup { destroy .m @@ -112,10 +112,10 @@ test message-1.10 {configuration option: "bg"} -setup { destroy .m } -returnCodes {error} -result {unknown color name "non-existent"} -test message-1.11 {configuration option: "borderwidth"} -setup { +test message-1.11 {configuration option: "borderwidth"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -borderwidth 1.3 .m cget -borderwidth @@ -132,10 +132,10 @@ test message-1.12 {configuration option: "borderwidth"} -setup { destroy .m } -returnCodes {error} -result {bad screen distance "badValue"} -test message-1.13 {configuration option: "cursor"} -setup { +test message-1.13 {configuration option: "cursor"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -cursor arrow .m cget -cursor @@ -152,10 +152,10 @@ test message-1.14 {configuration option: "cursor"} -setup { destroy .m } -returnCodes {error} -result {bad cursor spec "badValue"} -test message-1.15 {configuration option: "fg"} -setup { +test message-1.15 {configuration option: "fg"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -fg #00ff00 .m cget -fg @@ -172,10 +172,10 @@ test message-1.16 {configuration option: "fg"} -setup { destroy .m } -returnCodes {error} -result {unknown color name "badValue"} -test message-1.17 {configuration option: "font"} -setup { +test message-1.17 {configuration option: "font"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -font fixed .m cget -font @@ -192,13 +192,13 @@ test message-1.18 {configuration option: "font"} -setup { destroy .m } -returnCodes {error} -result {font "" doesn't exist} -test message-1.19 {configuration option: "-foreground"} -setup { +test message-1.19 {configuration option: "-foreground"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -foreground green - .m cget -foreground + .m cget -foreground } -cleanup { destroy .m } -result {green} @@ -212,10 +212,10 @@ test message-1.20 {configuration option: "-foreground"} -setup { destroy .m } -returnCodes {error} -result {unknown color name "badValue"} -test message-1.21 {configuration option: "highlightbackground"} -setup { +test message-1.21 {configuration option: "highlightbackground"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -highlightbackground #112233 .m cget -highlightbackground @@ -232,13 +232,13 @@ test message-1.22 {configuration option: "highlightbackground"} -setup { destroy .m } -returnCodes {error} -result {unknown color name "ugly"} -test message-1.23 {configuration option: "highlightcolor"} -setup { +test message-1.23 {configuration option: "highlightcolor"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -highlightcolor #123456 - .m cget -highlightcolor + .m cget -highlightcolor } -cleanup { destroy .m } -result {#123456} @@ -252,13 +252,13 @@ test message-1.24 {configuration option: "highlightcolor"} -setup { destroy .m } -returnCodes {error} -result {unknown color name "non-existent"} -test message-1.25 {configuration option: "highlightthickness"} -setup { +test message-1.25 {configuration option: "highlightthickness"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -highlightthickness 2 - .m cget -highlightthickness + .m cget -highlightthickness } -cleanup { destroy .m } -result {2} @@ -272,10 +272,10 @@ test message-1.26 {configuration option: "highlightthickness"} -setup { destroy .m } -returnCodes {error} -result {bad screen distance "badValue"} -test message-1.27 {configuration option: "justify"} -setup { +test message-1.27 {configuration option: "justify"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -justify right .m cget -justify @@ -292,13 +292,13 @@ test message-1.28 {configuration option: "justify"} -setup { destroy .m } -returnCodes {error} -result {bad justification "bogus": must be left, right, or center} -test message-1.29 {configuration option: "padx"} -setup { +test message-1.29 {configuration option: "padx"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -padx 12m - .m cget -padx + .m cget -padx } -cleanup { destroy .m } -result {12m} @@ -312,10 +312,10 @@ test message-1.30 {configuration option: "padx"} -setup { destroy .m } -returnCodes {error} -result {bad screen distance "420x"} -test message-1.31 {configuration option: "pady"} -setup { +test message-1.31 {configuration option: "pady"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -pady 12m .m cget -pady @@ -332,13 +332,13 @@ test message-1.32 {configuration option: "pady"} -setup { destroy .m } -returnCodes {error} -result {bad screen distance "420x"} -test message-1.33 {configuration option: "relief"} -setup { +test message-1.33 {configuration option: "relief"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -relief ridge - .m cget -relief + .m cget -relief } -cleanup { destroy .m } -result {ridge} @@ -352,10 +352,10 @@ test message-1.34 {configuration option: "relief"} -setup { destroy .m } -returnCodes {error} -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} -test message-1.35 {configuration options: "text"} -setup { +test message-1.35 {configuration options: "text"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -text "Sample text" .m cget -text @@ -363,24 +363,24 @@ test message-1.35 {configuration options: "text"} -setup { destroy .m } -result {Sample text} -test message-1.36 {configuration option: "textvariable"} -setup { +test message-1.36 {configuration option: "textvariable"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -textvariable i - .m cget -textvariable + .m cget -textvariable } -cleanup { destroy .m } -result {i} -test message-1.37 {configuration option: "width"} -setup { +test message-1.37 {configuration option: "width"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m - update + update } -body { .m configure -width 2 - .m cget -width + .m cget -width } -cleanup { destroy .m } -result {2} @@ -403,7 +403,7 @@ test message-2.2 {Tk_MessageObjCmd procedure} -body { message foo } -returnCodes {error} -result {bad window path name "foo"} test message-2.3 {Tk_MessageObjCmd procedure} -body { - catch {message foo} + catch {message foo} winfo child . } -result {} @@ -411,15 +411,15 @@ test message-2.4 {Tk_MessageObjCmd procedure} -body { message .s -gorp dump } -returnCodes {error} -result {unknown option "-gorp"} test message-2.5 {Tk_MessageObjCmd procedure} -body { - catch {message .s -gorp dump} + catch {message .s -gorp dump} winfo child . -} -result {} +} -result {} test message-3.1 {MessageWidgetObjCmd procedure} -setup { message .m } -body { - .m + .m } -cleanup { destroy .m } -returnCodes error -result {wrong # args: should be ".m option ?arg ...?"} @@ -442,7 +442,7 @@ test message-3.4 {MessageWidgetObjCmd procedure, "configure"} -setup { message .m } -body { .m configure -text foobar - lindex [.m configure -text] 4 + lindex [.m configure -text] 4 } -cleanup { destroy .m } -result {foobar} diff --git a/tests/msgbox.test b/tests/msgbox.test index 1b84463..8fd0dae 100644 --- a/tests/msgbox.test +++ b/tests/msgbox.test @@ -94,7 +94,7 @@ proc ChooseMsgByKey {parent btn} { proc PressButton {btn} { event generate $btn <Enter> - event generate $btn <ButtonPress-1> -x 5 -y 5 + event generate $btn <Button-1> -x 5 -y 5 event generate $btn <ButtonRelease-1> -x 5 -y 5 } @@ -113,7 +113,7 @@ proc SendEventToMsg {parent btn type} { event generate $w <Enter> focus $w event generate $w.$btn <Enter> - event generate $w <KeyPress> -keysym Return + event generate $w <Key> -keysym Return } } # @@ -121,295 +121,295 @@ proc SendEventToMsg {parent btn type} { # (type) x (icon). # test msgbox-2.1 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . abort tk_messageBox -title Hi -message "Please press abort" -type abortretryignore } -result {abort} test msgbox-2.2 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . abort tk_messageBox -title Hi -message "Please press abort" \ -type abortretryignore -icon warning } -result {abort} test msgbox-2.3 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . abort tk_messageBox -title Hi -message "Please press abort" \ -type abortretryignore -icon error } -result {abort} test msgbox-2.4 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . abort tk_messageBox -title Hi -message "Please press abort" \ -type abortretryignore -icon info } -result {abort} test msgbox-2.5 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . abort tk_messageBox -title Hi -message "Please press abort" \ -type abortretryignore -icon question } -result {abort} test msgbox-2.6 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . abort tk_messageBox -title Hi -message "Please press abort" \ -type abortretryignore -default abort } -result {abort} test msgbox-2.7 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . retry tk_messageBox -title Hi -message "Please press retry" \ -type abortretryignore -default retry } -result {retry} test msgbox-2.8 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . ignore tk_messageBox -title Hi -message "Please press ignore" \ -type abortretryignore -default ignore } -result {ignore} test msgbox-2.9 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" -type ok } -result {ok} test msgbox-2.10 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type ok -icon warning } -result {ok} test msgbox-2.11 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type ok -icon error } -result {ok} test msgbox-2.12 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type ok -icon info } -result {ok} test msgbox-2.13 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type ok -icon question } -result {ok} test msgbox-2.14 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type ok -default ok } -result {ok} test msgbox-2.15 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" -type okcancel } -result {ok} test msgbox-2.16 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type okcancel -icon warning } -result {ok} test msgbox-2.17 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type okcancel -icon error } -result {ok} test msgbox-2.18 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type okcancel -icon info } -result {ok} test msgbox-2.19 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type okcancel -icon question } -result {ok} test msgbox-2.20 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type okcancel -default ok } -result {ok} test msgbox-2.21 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . cancel tk_messageBox -title Hi -message "Please press cancel" \ -type okcancel -default cancel } -result {cancel} test msgbox-2.22 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . retry tk_messageBox -title Hi -message "Please press retry" -type retrycancel } -result {retry} test msgbox-2.23 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . retry tk_messageBox -title Hi -message "Please press retry" \ -type retrycancel -icon warning } -result {retry} test msgbox-2.24 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . retry tk_messageBox -title Hi -message "Please press retry" \ -type retrycancel -icon error } -result {retry} test msgbox-2.25 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . retry tk_messageBox -title Hi -message "Please press retry" \ -type retrycancel -icon info } -result {retry} test msgbox-2.26 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . retry tk_messageBox -title Hi -message "Please press retry" \ -type retrycancel -icon question } -result {retry} test msgbox-2.27 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . retry tk_messageBox -title Hi -message "Please press retry" \ -type retrycancel -default retry } -result {retry} test msgbox-2.28 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . cancel tk_messageBox -title Hi -message "Please press cancel" \ -type retrycancel -default cancel } -result {cancel} test msgbox-2.29 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" -type yesno } -result {yes} test msgbox-2.30 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesno -icon warning } -result {yes} test msgbox-2.31 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesno -icon error } -result {yes} test msgbox-2.32 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesno -icon info } -result {yes} test msgbox-2.33 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesno -icon question } -result {yes} test msgbox-2.34 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesno -default yes } -result {yes} test msgbox-2.35 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . no tk_messageBox -title Hi -message "Please press no" \ -type yesno -default no } -result {no} test msgbox-2.36 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" -type yesnocancel } -result {yes} test msgbox-2.37 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesnocancel -icon warning } -result {yes} test msgbox-2.38 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesnocancel -icon error } -result {yes} test msgbox-2.39 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesnocancel -icon info } -result {yes} test msgbox-2.40 {tk_messageBox command -icon option} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesnocancel -icon question } -result {yes} test msgbox-2.41 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesnocancel -default yes } -result {yes} test msgbox-2.42 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . no tk_messageBox -title Hi -message "Please press no" \ -type yesnocancel -default no } -result {no} test msgbox-2.43 {tk_messageBox command} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { ChooseMsg . cancel tk_messageBox -title Hi -message "Please press cancel" \ @@ -419,7 +419,7 @@ test msgbox-2.43 {tk_messageBox command} -constraints { # These tests will hang your test suite if they fail. test msgbox-3.1 {tk_messageBox handles withdrawn parent} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { wm withdraw . ChooseMsg . "ok" @@ -430,7 +430,7 @@ test msgbox-3.1 {tk_messageBox handles withdrawn parent} -constraints { } -result {ok} test msgbox-3.2 {tk_messageBox handles iconified parent} -constraints { - nonUnixUserInteraction + nonUnixUserInteraction } -body { wm iconify . ChooseMsg . "ok" diff --git a/tests/option.file1 b/tests/option.file1 index 32b4a18..c5a216e 100644 --- a/tests/option.file1 +++ b/tests/option.file1 @@ -13,6 +13,6 @@ ple *x 4: brown # More comments, this time delimited by hash-marks. # Comment-line with space. -*x6: +*x6: *x9: \ \ \\\101\n # comment line as last line of file. diff --git a/tests/option.file3 b/tests/option.file3 index 146cfd9..f0b7e11 100755 --- a/tests/option.file3 +++ b/tests/option.file3 @@ -13,6 +13,6 @@ ple *x 4: brówn # More comments, this time delimited by hash-marks. # Comment-line with space. -*x6: +*x6: *x9: \ \ \\\101\n # comment line as last line of file. diff --git a/tests/option.test b/tests/option.test index c8e29da..5e1568e 100644 --- a/tests/option.test +++ b/tests/option.test @@ -285,7 +285,7 @@ test option-12.6 {stack pushing/popping} -body { # Test the major priority levels (widgetDefault, etc.) -# Configurations for tests 13.* +# Configurations for tests 13.* option clear option add $appName.op1.a 100 100 option add $appName.op1.A interactive interactive diff --git a/tests/pack.test b/tests/pack.test index b1c22c7..4a41516 100644 --- a/tests/pack.test +++ b/tests/pack.test @@ -1,5 +1,5 @@ -# This file is a Tcl script to test out the "pack" command -# of Tk. It is organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test out the "pack" command of Tk. It is +# organized in the standard fashion for Tcl tests. # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. @@ -28,7 +28,7 @@ foreach i {a b c d} { .pack.b config -width 50 -height 30 .pack.c config -width 80 -height 80 .pack.d config -width 40 -height 30 - + test pack-1.1 {-side option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -231,7 +231,6 @@ test pack-2.21 {x padding and filling} -setup { update list [winfo geometry .pack.a] [winfo geometry .pack.b] } -result {280x40+5+0 300x160+0+40} - test pack-2.22 {x padding and filling} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -251,7 +250,6 @@ test pack-2.23 {x padding and filling} -setup { expr {$res1 eq $res2} } -result 1 - test pack-3.1 {y padding and filling} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -420,7 +418,6 @@ test pack-3.21 {y padding and filling} -setup { update list [winfo geometry .pack.a] [winfo geometry .pack.b] } -result {20x50+140+1 300x130+0+70} - test pack-3.22 {y padding and filling} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -440,7 +437,6 @@ test pack-3.23 {y padding and filling} -setup { expr {$res1 eq $res2} } -result 1 - test pack-4.1 {anchors} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -505,7 +501,6 @@ test pack-4.9 {anchors} -setup { winfo geometry .pack.a } -result {30x70+135+65} - # Repeat above tests, but with a frame that isn't at (0,0), so that # we can be sure that the frame offset is being added in correctly. @@ -591,7 +586,6 @@ test pack-5.9 {more anchors} -setup { winfo geometry .pack.b } -result {60x60+160+90} - test pack-6.1 {-expand option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -697,7 +691,6 @@ test pack-6.11 {-expand option} -setup { list [winfo geometry .pack.a] [winfo geometry .pack.b] \ [winfo geometry .pack.c] [winfo geometry .pack.d] } -result {100x200+0+0 200x100+100+0 160x100+140+100 40x100+100+100} - test pack-6.12 {-expand option} -setup { toplevel .pack2 -height 400 -width 400 wm geometry .pack2 +0+0 @@ -732,7 +725,6 @@ test pack-6.13 {-expand option} -setup { destroy .pack2 } -result {38x42+181+45 38x42+181+178 38x42+181+312} - wm geometry .pack {} test pack-7.1 {requesting size for parent} -setup { pack forget .pack.a .pack.b .pack.c .pack.d @@ -791,7 +783,6 @@ test pack-7.7 {requesting size for parent} -setup { list [winfo reqwidth .pack] [winfo reqheight .pack] } -result {100 110} - # For the tests below, create a couple of "pad" windows to shrink # the available space for the remaining windows. The tests have to # be done this way rather than shrinking the whole window, because @@ -872,7 +863,6 @@ test pack-8.9 {insufficient space} -body { } -result {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1} pack forget .pack.right .pack.bottom - test pack-9.1 {window ordering} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -945,7 +935,6 @@ test pack-9.10 {window ordering} -setup { pack slaves .pack } -result {.pack.a .pack.c .pack.d .pack.b} - test pack-10.1 {retaining/clearing configuration state} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -998,7 +987,6 @@ test pack-10.6 {prevent management loops} -body { destroy .f3 } -returnCodes error -result {can't put .f3 inside .f1, would cause management loop} - test pack-11.1 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -1133,7 +1121,6 @@ test pack-11.19 {info option} -setup { lindex $i [expr [lsearch -exact $i -side]+1] } -result right - test pack-12.1 {command options and errors} -body { pack } -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"} @@ -1375,7 +1362,6 @@ test pack-12.46 {command options and errors} -setup { pack lousy .pack } -returnCodes error -result {bad option "lousy": must be configure, forget, info, propagate, or slaves} - test pack-13.1 {window deletion} -setup { pack forget .pack.a .pack.b .pack.c .pack.d .pack.right .pack.bottom } -body { @@ -1389,7 +1375,6 @@ test pack-13.1 {window deletion} -setup { [winfo geometry .pack.b] [winfo geometry .pack.c]] } -result {{.pack.right .pack.bottom .pack.a .pack.b .pack.c} 20x40+30+0 50x30+15+40 80x80+0+70} - test pack-14.1 {respond to changes in expansion} -setup { pack forget .pack.a .pack.b .pack.c .pack.d .pack.right .pack.bottom } -body { @@ -1515,7 +1500,6 @@ test pack-15.5 {managing geometry with -in option} -setup { destroy .pack.f1 .pack.f2 } -result {50x16+25+22 1 50x16+25+22 0} - test pack-16.1 {geometry manager name} -setup { pack forget .pack.a .pack.b .pack.c .pack.d set result {} @@ -1527,7 +1511,6 @@ test pack-16.1 {geometry manager name} -setup { lappend result [winfo manager .pack.a] } -result {{} pack {}} - test pack-17.1 {PackLostSlaveProc procedure} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -1549,13 +1532,11 @@ test pack-17.2 {PackLostSlaveProc procedure} -setup { pack info .pack.a } -returnCodes error -result {window ".pack.a" isn't packed} - test pack-18.1 {unmap slaves when master unmapped} -constraints { tempNotPc } -setup { eval destroy [winfo child .pack] } -body { - # adjust the position of .pack before test to avoid a screen switch # that occurs with window managers that have desktops four times as big # as the screen (screen switch causes scale and other tests to fail). @@ -1585,7 +1566,6 @@ test pack-18.1 {unmap slaves when master unmapped} -constraints { test pack-18.2 {unmap slaves when master unmapped} -setup { eval destroy [winfo child .pack] } -body { - # adjust the position of .pack before test to avoid a screen switch # that occurs with window managers that have desktops four times as big # as the screen (screen switch causes scale and other tests to fail). @@ -1609,7 +1589,6 @@ test pack-18.2 {unmap slaves when master unmapped} -setup { lappend result [winfo ismapped .pack.b] } -result {1 0 100 30 0 1} - test pack-19.1 {test respect for internalborder} -setup { catch {eval pack forget [pack slaves .pack]} destroy .pack.l .pack.lf @@ -1647,10 +1626,98 @@ test pack-19.2 {test support for minreqsize} -setup { destroy .pack.l .pack.lf } -result {162x127+0+0 172x112+0+0} - +test pack-20.1 {<<NoManagedChild>> fires on last pack forget} -setup { + global A + unset -nocomplain A +} -body { + pack [frame .1] + update + bind . <<NoManagedChild>> {set A 1} + pack forget .1 + update + info exists A +} -cleanup { + bind . <<NoManagedChild>> {} + destroy .1 +} -result {1} +test pack-20.2 {<<NoManagedChild>> fires on last packed child destruction} -setup { + global A + unset -nocomplain A +} -body { + pack [frame .1] + update + bind . <<NoManagedChild>> {incr A} + destroy .1 + update + set A +} -cleanup { + bind . <<NoManagedChild>> {} + destroy .1 +} -result {1} +test pack-20.3 {<Configure> does not fire on last pack forget} -setup { + global A + unset -nocomplain A +} -body { + pack [frame .1] + update + bind . <Configure> {set A 1} + pack forget .1 + update + info exists A +} -cleanup { + bind . <Configure> {} + destroy .1 +} -result {0} +test pack-20.4 {<<NoManagedChild>> does not fire on forelast pack forget} -setup { + global A + unset -nocomplain A +} -body { + pack [frame .1] + pack [frame .2] + update + bind . <<NoManagedChild>> {set A 1} + pack forget .1 + update + info exists A +} -cleanup { + bind . <<NoManagedChild>> {} + destroy .1 .2 +} -result {0} +test pack-20.5 {<Configure> does not fire on last pack forget} -setup { + global A + unset -nocomplain A +} -body { + pack [frame .1] + pack [frame .2] + update + bind . <Configure> {set A 1} + pack forget .1 + update + info exists A +} -cleanup { + bind . <Configure> {} + destroy .1 .2 +} -result {1} +test pack-20.6 {<<NoManagedChild>> does not fire on last pack forget if propagation is off} -setup { + global A + unset -nocomplain A +} -body { + pack [frame .1] + pack propagate . 0 + update + bind . <<NoManagedChild>> {set A 1} + pack forget .1 + update + info exists A +} -cleanup { + bind . <<NoManagedChild>> {} + destroy .1 +} -result {0} + # cleanup cleanupTests return - - +# Local Variables: +# mode: tcl +# End: diff --git a/tests/panedwindow.test b/tests/panedwindow.test index ee184ce..ea407a0 100644 --- a/tests/panedwindow.test +++ b/tests/panedwindow.test @@ -498,7 +498,7 @@ test panedwindow-6.9 {sash coord subcommand, errors} -setup { .p add [frame .p.f] list [catch {.p sash coord -1} msg] $msg \ [catch {.p sash coord 0} msg] $msg \ - [catch {.p sash coord 1} msg] $msg + [catch {.p sash coord 1} msg] $msg } -cleanup { deleteWindows } -result [list 1 "invalid sash index" 1 "invalid sash index" 1 "invalid sash index"] @@ -511,7 +511,7 @@ test panedwindow-6.10 {sash coord subcommand, errors} -setup { list [catch {.p sash coord -1} msg] $msg \ [catch {.p sash coord 0} msg] \ [catch {.p sash coord 1} msg] $msg \ - [catch {.p sash coord 2} msg] $msg + [catch {.p sash coord 2} msg] $msg } -cleanup { deleteWindows } -result [list 1 "invalid sash index" 0 1 "invalid sash index" 1 "invalid sash index"] @@ -622,7 +622,7 @@ test panedwindow-8.5 {sash dragto subcommand, errors} -setup { } -cleanup { deleteWindows } -returnCodes error -result {expected integer but got "bar"} - + test panedwindow-9.1 {sash mark/sash dragto interaction} -setup { deleteWindows @@ -925,7 +925,7 @@ test panedwindow-11.15 {moving sash into "virtual" space on last pane increases } -cleanup { deleteWindows } -result {68 100} - + test panedwindow-12.1 {horizontal panedwindow lays out widgets properly} -setup { deleteWindows @@ -1149,7 +1149,7 @@ test panedwindow-13.2 {PanedWindowLostSlaveProc, widget yields management} -setu } -body { # Check that the paned window correctly yields geometry management of # a slave when some other geometry manager steals the slave from us. - + # This test should not cause a core dump, and it should not cause a # memory leak. panedwindow .p @@ -1518,9 +1518,9 @@ test panedwindow-17.1 {MoveSash, move right} -setup { # Get the requested width of the paned window lappend result [winfo reqwidth .p] - + .p sash place 0 30 0 - + # Get the reqwidth again, to make sure it hasn't changed lappend result [winfo reqwidth .p] @@ -1538,7 +1538,7 @@ test panedwindow-17.2 {MoveSash, move right (unmapped) clipped by reqwidth} -set } .p sash place 0 100 0 - + # Get the new sash coord; it should be clipped by the reqwidth of # the panedwindow. .p sash coord 0 @@ -1552,13 +1552,13 @@ test panedwindow-17.3 {MoveSash, move right (mapped, width < reqwidth) clipped b foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } - + # Put the panedwindow up on the display and give it a width < reqwidth place .p -x 0 -y 0 -width 32 update .p sash place 0 100 0 - + # Get the new sash coord; it should be clipped by the visible width of # the panedwindow. .p sash coord 0 @@ -1572,13 +1572,13 @@ test panedwindow-17.4 {MoveSash, move right (mapped, width > reqwidth) clipped b foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } - + # Put the panedwindow up on the display and give it a width > reqwidth place .p -x 0 -y 0 -width 102 update .p sash place 0 200 0 - + # Get the new sash coord; it should be clipped by the visible width of # the panedwindow. .p sash coord 0 @@ -1594,7 +1594,7 @@ test panedwindow-17.5 {MoveSash, move right respects minsize} -setup { } .p sash place 0 100 0 - + # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 @@ -1610,7 +1610,7 @@ test panedwindow-17.6 {MoveSash, move right respects minsize} -setup { } .p sash place 0 100 0 - + # Get the new sash coord; it should have moved as far as possible. .p sash coord 0 } -cleanup { @@ -1625,7 +1625,7 @@ test panedwindow-17.7 {MoveSash, move right pushes other sashes} -setup { } .p sash place 0 100 0 - + # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 1 @@ -1641,7 +1641,7 @@ test panedwindow-17.8 {MoveSash, move right pushes other sashes, respects minsiz } .p sash place 0 100 0 - + # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 1 @@ -1658,8 +1658,8 @@ test panedwindow-17.9 {MoveSash, move right respects minsize, exludes pad} -setu } .p sash place 0 100 0 - - # Get the new sash coord; it should have moved as far as possible, + + # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. .p sash coord 0 } -cleanup { @@ -1675,8 +1675,8 @@ test panedwindow-17.10 {MoveSash, move right, negative minsize becomes 0} -setup } .p sash place 0 50 0 - - # Get the new sash coord; it should have moved as far as possible, + + # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. list [.p sash coord 0] [.p sash coord 1] } -cleanup { @@ -1693,9 +1693,9 @@ test panedwindow-17.11 {MoveSash, move left} -setup { # Get the requested width of the paned window lappend result [winfo reqwidth .p] - + .p sash place 0 10 0 - + # Get the reqwidth again, to make sure it hasn't changed lappend result [winfo reqwidth .p] @@ -1713,7 +1713,7 @@ test panedwindow-17.12 {MoveSash, move left, can't move outside of window} -setu } .p sash place 0 -100 0 - + # Get the new sash coord; it should be clipped by the reqwidth of # the panedwindow. .p sash coord 0 @@ -1729,7 +1729,7 @@ test panedwindow-17.13 {MoveSash, move left respects minsize} -setup { } .p sash place 0 0 0 - + # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 @@ -1745,7 +1745,7 @@ test panedwindow-17.14 {MoveSash, move left respects minsize} -setup { } .p sash place 1 0 0 - + # Get the new sash coord; it should have moved as far as possible. .p sash coord 1 } -cleanup { @@ -1760,7 +1760,7 @@ test panedwindow-17.15 {MoveSash, move left pushes other sashes} -setup { } .p sash place 1 0 0 - + # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 @@ -1776,7 +1776,7 @@ test panedwindow-17.16 {MoveSash, move left pushes other sashes, respects minsiz } .p sash place 1 0 0 - + # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 @@ -1793,8 +1793,8 @@ test panedwindow-17.17 {MoveSash, move left respects minsize, exludes pad} -setu } .p sash place 1 0 0 - - # Get the new sash coord; it should have moved as far as possible, + + # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. .p sash coord 1 } -cleanup { @@ -1810,8 +1810,8 @@ test panedwindow-17.18 {MoveSash, move left, negative minsize becomes 0} -setup } .p sash place 1 10 0 - - # Get the new sash coord; it should have moved as far as possible, + + # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. list [.p sash coord 0] [.p sash coord 1] } -cleanup { @@ -1831,9 +1831,9 @@ test panedwindow-18.1 {MoveSash, move down} -setup { # Get the requested width of the paned window lappend result [winfo reqheight .p] - + .p sash place 0 0 30 - + # Get the reqwidth again, to make sure it hasn't changed lappend result [winfo reqheight .p] @@ -1852,7 +1852,7 @@ test panedwindow-18.2 {MoveSash, move down (unmapped) clipped by reqheight} -set } .p sash place 0 0 100 - + # Get the new sash coord; it should be clipped by the reqheight of # the panedwindow. .p sash coord 0 @@ -1867,13 +1867,13 @@ test panedwindow-18.3 {MoveSash, move down (mapped, height < reqheight) clipped foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } - + # Put the panedwindow up on the display and give it a height < reqheight place .p -x 0 -y 0 -height 32 update .p sash place 0 0 100 - + # Get the new sash coord; it should be clipped by the visible height of # the panedwindow. .p sash coord 0 @@ -1888,13 +1888,13 @@ test panedwindow-18.4 {MoveSash, move down (mapped, height > reqheight) clipped foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } - + # Put the panedwindow up on the display and give it a width > reqwidth place .p -x 0 -y 0 -height 102 update .p sash place 0 0 200 - + # Get the new sash coord; it should be clipped by the visible width of # the panedwindow. .p sash coord 0 @@ -1911,7 +1911,7 @@ test panedwindow-18.5 {MoveSash, move down respects minsize} -setup { } .p sash place 0 0 100 - + # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 @@ -1928,7 +1928,7 @@ test panedwindow-18.6 {MoveSash, move down respects minsize} -setup { } .p sash place 0 0 100 - + # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 @@ -1945,7 +1945,7 @@ test panedwindow-18.7 {MoveSash, move down pushes other sashes} -setup { } .p sash place 0 0 100 - + # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 1 @@ -1962,7 +1962,7 @@ test panedwindow-18.8 {MoveSash, move down pushes other sashes, respects minsize } .p sash place 0 0 100 - + # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 1 @@ -1980,8 +1980,8 @@ test panedwindow-18.9 {MoveSash, move down respects minsize, exludes pad} -setup } .p sash place 0 0 100 - - # Get the new sash coord; it should have moved as far as possible, + + # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. .p sash coord 0 } -cleanup { @@ -1998,8 +1998,8 @@ test panedwindow-18.10 {MoveSash, move right, negative minsize becomes 0} -setup } .p sash place 0 0 50 - - # Get the new sash coord; it should have moved as far as possible, + + # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. list [.p sash coord 0] [.p sash coord 1] } -cleanup { @@ -2017,9 +2017,9 @@ test panedwindow-18.11 {MoveSash, move up} -setup { # Get the requested width of the paned window lappend result [winfo reqheight .p] - + .p sash place 0 0 10 - + # Get the reqwidth again, to make sure it hasn't changed lappend result [winfo reqheight .p] @@ -2038,7 +2038,7 @@ test panedwindow-18.12 {MoveSash, move up, can't move outside of window} -setup } .p sash place 0 0 -100 - + # Get the new sash coord; it should be clipped by the reqwidth of # the panedwindow. .p sash coord 0 @@ -2055,7 +2055,7 @@ test panedwindow-18.13 {MoveSash, move up respects minsize} -setup { } .p sash place 0 0 0 - + # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 @@ -2072,7 +2072,7 @@ test panedwindow-18.14 {MoveSash, move up respects minsize} -setup { } .p sash place 1 0 0 - + # Get the new sash coord; it should have moved as far as possible. .p sash coord 1 } -cleanup { @@ -2088,7 +2088,7 @@ test panedwindow-18.15 {MoveSash, move up pushes other sashes} -setup { } .p sash place 1 0 0 - + # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 @@ -2105,7 +2105,7 @@ test panedwindow-18.16 {MoveSash, move up pushes other sashes, respects minsize} } .p sash place 1 0 0 - + # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 @@ -2123,8 +2123,8 @@ test panedwindow-18.17 {MoveSash, move up respects minsize, exludes pad} -setup } .p sash place 1 0 0 - - # Get the new sash coord; it should have moved as far as possible, + + # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. .p sash coord 1 } -cleanup { @@ -2141,8 +2141,8 @@ test panedwindow-18.18 {MoveSash, move up, negative minsize becomes 0} -setup { } .p sash place 1 0 10 - - # Get the new sash coord; it should have moved as far as possible, + + # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. list [.p sash coord 0] [.p sash coord 1] } -cleanup { @@ -4328,7 +4328,7 @@ test panedwindow-20.2 {destroyed slave causes geometry recomputation} -setup { } -cleanup { deleteWindows } -result 20 - + test panedwindow-21.1 {ArrangePanes, extra space is given to the last pane} -setup { deleteWindows diff --git a/tests/pkgconfig.test b/tests/pkgconfig.test new file mode 100644 index 0000000..e080b91 --- /dev/null +++ b/tests/pkgconfig.test @@ -0,0 +1,66 @@ +# -*- tcl -*- +# Commands covered: pkgconfig +# +# This file contains a collection of tests for one or more of the Tk +# built-in commands. Sourcing this file into Tk runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2017 Stuart Cassoff <stwo@users.sourceforge.net> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require tcltest 2.2 +namespace import ::tcltest::* +eval tcltest::configure $argv +tcltest::loadTestedCommands + +test pkgconfig-1.1 {query keys} nonwin { + lsort [::tk::pkgconfig list] +} [list \ + 64bit bindir,install bindir,runtime debug demodir,install demodir,runtime \ + docdir,install docdir,runtime fontsystem includedir,install includedir,runtime \ + libdir,install libdir,runtime mem_debug optimized profiled \ + scriptdir,install scriptdir,runtime threaded \ +] +test pkgconfig-1.2 {query keys multiple times} { + string compare [::tk::pkgconfig list] [::tk::pkgconfig list] +} 0 +test pkgconfig-1.3 {query value multiple times} { + string compare \ + [::tk::pkgconfig get 64bit] \ + [::tk::pkgconfig get 64bit] +} 0 + + +test pkgconfig-2.0 {error: missing subcommand} { + catch {::tk::pkgconfig} msg + set msg +} {wrong # args: should be "::tk::pkgconfig subcommand ?arg?"} +test pkgconfig-2.1 {error: illegal subcommand} { + catch {::tk::pkgconfig foo} msg + set msg +} {bad subcommand "foo": must be get or list} +test pkgconfig-2.2 {error: list with arguments} { + catch {::tk::pkgconfig list foo} msg + set msg +} {wrong # args: should be "::tk::pkgconfig list"} +test pkgconfig-2.3 {error: get without arguments} { + catch {::tk::pkgconfig get} msg + set msg +} {wrong # args: should be "::tk::pkgconfig get key"} +test pkgconfig-2.4 {error: query unknown key} { + catch {::tk::pkgconfig get foo} msg + set msg +} {key not known} +test pkgconfig-2.5 {error: query with to many arguments} { + catch {::tk::pkgconfig get foo bar} msg + set msg +} {wrong # args: should be "::tk::pkgconfig subcommand ?arg?"} + +# cleanup +cleanupTests +return diff --git a/tests/place.test b/tests/place.test index 62e0ed2..e04ee0a 100644 --- a/tests/place.test +++ b/tests/place.test @@ -415,7 +415,7 @@ test place-10.4 {ConfigureSlave} -setup { } -cleanup { destroy .foo } -returnCodes error -result {value for "-y" missing} - + test place-11.1 {PlaceObjCmd, slaves command} -setup { destroy .foo diff --git a/tests/safe.test b/tests/safe.test index 475d938..4f0ce15 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -28,19 +28,39 @@ namespace import -force tcltest::test # This probably means that tk wasn't installed properly. ## it indicates that something went wrong sourcing tk.tcl. -## Ensure that any changes that occured to tk.tcl will work or are properly +## Ensure that any changes that occurred to tk.tcl will work or are properly ## prevented in a safe interpreter. -- hobbs # The set of hidden commands is platform dependent: -set hidden_cmds {bell cd clipboard encoding exec exit fconfigure glob grab load menu open pwd selection socket source tcl:encoding:dirs toplevel unload wm} +set hidden_cmds {bell cd clipboard encoding exec exit fconfigure} lappend hidden_cmds {*}[apply {{} { + if {[package vsatisfies [package provide Tcl] 8.7-]} { + lappend result file + } + lappend result glob grab load menu open pwd selection socket source tcl:encoding:dirs + if {[package vsatisfies [package provide Tcl] 8.7-]} { + lappend result tcl:encoding:system + } + lappend result toplevel unload wm foreach cmd { atime attributes copy delete dirname executable exists extension isdirectory isfile link lstat mkdir mtime nativename normalize owned - readable readlink rename rootname size stat tail tempfile type + readable readlink rename rootname size stat tail tempdir tempfile type volumes writable - } {lappend result tcl:file:$cmd}; return $result + } {lappend result tcl:file:$cmd} + if {[package vsatisfies [package provide Tcl] 8.7-]} { + foreach cmd { + cmdtype nameofexecutable + } {lappend result tcl:info:$cmd} + foreach cmd { + autopurge list purge status + } {lappend result tcl:process:$cmd} + foreach cmd { + lmkimg lmkzip mkimg mkkey mkzip mount mount_data unmount + } {lappend result tcl:zipfs:$cmd} + } + return $result }}] if {[tk windowingsystem] ne "x11"} { lappend hidden_cmds tk_chooseColor tk_chooseDirectory tk_getOpenFile \ diff --git a/tests/scale.test b/tests/scale.test index 38c3e9a..955092b 100644 --- a/tests/scale.test +++ b/tests/scale.test @@ -324,7 +324,7 @@ test scale-2.1 {Tk_ScaleCmd procedure} -body { scale } -returnCodes error -result {wrong # args: should be "scale pathName ?-option value ...?"} test scale-2.2 {Tk_ScaleCmd procedure} -body { - scale foo + scale foo } -returnCodes error -result {bad window path name "foo"} test scale-2.3 {Tk_ScaleCmd procedure} -body { catch {scale foo} @@ -1364,7 +1364,7 @@ test scale-18.2 {Scale button 1 events [Bug 787065]} -setup { pack .s tkwait visibility .s list [catch { - event generate .s <1> -x 0 -y 0 + event generate .s <Button-1> -x 0 -y 0 event generate .s <ButtonRelease-1> -x 0 -y 0 update set ::error @@ -1385,7 +1385,7 @@ test scale-18.3 {Scale button 2 events [Bug 787065]} -setup { pack .s tkwait visibility .s list [catch { - event generate .s <2> -x 0 -y 0 + event generate .s <Button-2> -x 0 -y 0 event generate .s <ButtonRelease-2> -x 0 -y 0 update set ::error @@ -1411,16 +1411,16 @@ test scale-19 {Bug [3529885fff] - Click in through goes in wrong direction} \ } \ -body { foreach {x y} [.s1 coord 50] {} - event generate .s1 <1> -x $x -y $y + event generate .s1 <Button-1> -x $x -y $y event generate .s1 <ButtonRelease-1> -x $x -y $y foreach {x y} [.s2 coord 50] {} - event generate .s2 <1> -x $x -y $y + event generate .s2 <Button-1> -x $x -y $y event generate .s2 <ButtonRelease-1> -x $x -y $y foreach {x y} [.s3 coord 50] {} - event generate .s3 <1> -x $x -y $y + event generate .s3 <Button-1> -x $x -y $y event generate .s3 <ButtonRelease-1> -x $x -y $y foreach {x y} [.s4 coord 50] {} - event generate .s4 <1> -x $x -y $y + event generate .s4 <Button-1> -x $x -y $y event generate .s4 <ButtonRelease-1> -x $x -y $y update list $x1 $x2 $x3 $x4 diff --git a/tests/scrollbar.test b/tests/scrollbar.test index 8966f1f..e02e3a8 100644 --- a/tests/scrollbar.test +++ b/tests/scrollbar.test @@ -23,7 +23,7 @@ proc getTroughSize {w} { return [expr {[winfo height $w] - 2*[testmetrics cyvscroll $w]}] } else { return [expr {[winfo width $w] - 2*[testmetrics cxhscroll $w]}] - } + } } else { if {[tk windowingsystem] eq "x11"} { # Calculations here assume that the arrow area is a square. @@ -60,7 +60,7 @@ proc getTroughSize {w} { foreach {width height} [wm minsize .] { set height [expr {($height < 200) ? 200 : $height}] set width [expr {($width < 1) ? 1 : $width}] -} +} frame .f -height $height -width $width pack .f -side left @@ -380,15 +380,15 @@ test scrollbar-3.59 {ScrollbarWidgetCmd procedure, "set" option} { set result } {0.0 0.3} test scrollbar-3.60 {ScrollbarWidgetCmd procedure, "set" option} { - .s set 1.1 .4 + .s set 1.1 .4 .s get } {1.0 1.0} test scrollbar-3.61 {ScrollbarWidgetCmd procedure, "set" option} { - .s set .5 -.3 + .s set .5 -.3 .s get } {0.5 0.5} test scrollbar-3.62 {ScrollbarWidgetCmd procedure, "set" option} { - .s set .5 87 + .s set .5 87 .s get } {0.5 1.0} test scrollbar-3.63 {ScrollbarWidgetCmd procedure, "set" option} { @@ -412,23 +412,23 @@ test scrollbar-3.67 {ScrollbarWidgetCmd procedure, "set" option} { list [catch {.s set 1 2 3 jkl} msg] $msg } {1 {expected integer but got "jkl"}} test scrollbar-3.68 {ScrollbarWidgetCmd procedure, "set" option} { - .s set -10 50 20 30 + .s set -10 50 20 30 .s get } {0 50 0 0} test scrollbar-3.69 {ScrollbarWidgetCmd procedure, "set" option} { - .s set 100 -10 20 30 + .s set 100 -10 20 30 .s get } {100 0 20 30} test scrollbar-3.70 {ScrollbarWidgetCmd procedure, "set" option} { - .s set 100 50 30 20 + .s set 100 50 30 20 .s get } {100 50 30 30} test scrollbar-3.71 {ScrollbarWidgetCmd procedure, "set" option} { list [catch {.s set 1 2 3} msg] $msg -} {1 {wrong # args: should be ".s set firstFraction lastFraction" or ".s set totalUnits windowUnits firstUnit lastUnit"}} +} {1 {wrong # args: should be ".s set firstFraction lastFraction"}} test scrollbar-3.72 {ScrollbarWidgetCmd procedure, "set" option} { list [catch {.s set 1 2 3 4 5} msg] $msg -} {1 {wrong # args: should be ".s set firstFraction lastFraction" or ".s set totalUnits windowUnits firstUnit lastUnit"}} +} {1 {wrong # args: should be ".s set firstFraction lastFraction"}} test scrollbar-3.73 {ScrollbarWidgetCmd procedure} { list [catch {.s bogus} msg] $msg } {1 {bad option "bogus": must be activate, cget, configure, delta, fraction, get, identify, or set}} @@ -499,7 +499,7 @@ test scrollbar-6.12.2 {ScrollbarPosition procedure} aqua { .s identify 8 19 } {trough1} test scrollbar-6.14 {ScrollbarPosition procedure} win { - .s identify [expr {[winfo width .s] / 2}] 0 + .s identify [expr {[winfo width .s] / 2}] 0 } {arrow1} test scrollbar-6.15 {ScrollbarPosition procedure} {testmetrics win} { .s identify [expr {[winfo width .s] / 2}] [expr {[testmetrics cyvscroll .s] - 1}] @@ -610,7 +610,7 @@ test scrollbar-6.41.2 {ScrollbarPosition procedure} aqua { } {trough2} test scrollbar-6.43 {ScrollbarPosition procedure} {testmetrics win} { .t.s identify [expr {int(.4 / [.t.s delta 1 0]) + [testmetrics cxhscroll .t.s] - - 1}] [expr {[winfo height .t.s] / 2}] + - 1}] [expr {[winfo height .t.s] / 2}] } {slider} test scrollbar-6.44 {ScrollbarPosition procedure} unix { .t.s identify 100 18 @@ -645,7 +645,7 @@ test scrollbar-8.1 {TkScrollbarEventProc: recursive deletion} notAqua { .t.f.s set 0 .5 update set result [winfo exists .t.f.s] - event generate .t.f.s <ButtonPress> -button 1 -x [expr {[winfo width .t.f.s] / 2}] -y 5 + event generate .t.f.s <Button> -button 1 -x [expr {[winfo width .t.f.s] / 2}] -y 5 event generate .t <ButtonRelease> -button 1 update lappend result [winfo exists .t.f.s] [winfo exists .t.f] @@ -666,7 +666,7 @@ test scrollbar-8.2 {TkScrollbarEventProc: recursive deletion} notAqua { .t.f.s set 0 .5 update set result [winfo exists .t.f.s] - event generate .t.f.s <ButtonPress> -button 1 -x [expr {[winfo width .t.f.s] / 2}] -y 5 + event generate .t.f.s <Button> -button 1 -x [expr {[winfo width .t.f.s] / 2}] -y 5 event generate .t.f <ButtonRelease> -button 1 update lappend result [winfo exists .t.f.s] [winfo exists .t.f] @@ -714,7 +714,7 @@ test scrollbar-10.1.2 {<MouseWheel> event on scrollbar} -constraints {aqua} -set destroy .t .s } -result {5.0} -test scrollbar-10.2.1 {<MouseWheel> event on scrollbar} -constraints {notAqua} -setup { +test scrollbar-10.2.1 {<Shift-MouseWheel> event on horizontal scrollbar} -constraints {notAqua} -setup { destroy .t .s } -body { pack [text .t -xscrollcommand {.s set} -wrap none] -side top @@ -728,7 +728,7 @@ test scrollbar-10.2.1 {<MouseWheel> event on scrollbar} -constraints {notAqua} - } -cleanup { destroy .t .s } -result {1.4} -test scrollbar-10.2.2 {<MouseWheel> event on scrollbar} -constraints {aqua} -setup { +test scrollbar-10.2.2 {<Shift-MouseWheel> event on horizontal scrollbar} -constraints {aqua} -setup { destroy .t .s } -body { pack [text .t -xscrollcommand {.s set} -wrap none] -side top @@ -742,6 +742,34 @@ test scrollbar-10.2.2 {<MouseWheel> event on scrollbar} -constraints {aqua} -set } -cleanup { destroy .t .s } -result {1.4} +test scrollbar-10.2.3 {<MouseWheel> event on horizontal scrollbar} -constraints {notAqua} -setup { + destroy .t .s +} -body { + pack [text .t -xscrollcommand {.s set} -wrap none] -side top + for {set i 1} {$i < 100} {incr i} {.t insert end "Char $i "} + pack [scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top + update + focus -force .s + event generate .s <MouseWheel> -delta -120 + after 200 {set eventprocessed 1} ; vwait eventprocessed + .t index @0,0 +} -cleanup { + destroy .t .s +} -result {1.4} +test scrollbar-10.2.4 {<MouseWheel> event on horizontal scrollbar} -constraints {aqua} -setup { + destroy .t .s +} -body { + pack [text .t -xscrollcommand {.s set} -wrap none] -side top + for {set i 1} {$i < 100} {incr i} {.t insert end "Char $i "} + pack [scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top + update + focus -force .s + event generate .s <MouseWheel> -delta -4 + after 200 {set eventprocessed 1} ; vwait eventprocessed + .t index @0,0 +} -cleanup { + destroy .t .s +} -result {1.4} test scrollbar-11.1 {bug fix: [011706ec42] Scrollbar unsafe wrt widget destruction} -body { proc destroy_scrollbar {} { @@ -751,15 +779,15 @@ test scrollbar-11.1 {bug fix: [011706ec42] Scrollbar unsafe wrt widget destructi } toplevel .top scrollbar .top.s - bind .top.s <2> {destroy_scrollbar} + bind .top.s <Button-2> {destroy_scrollbar} pack .top.s focus -force .top.s update - event generate .top.s <2> + event generate .top.s <Button-2> update ; # shall not trigger error invalid command name ".top.s" } -cleanup { destroy .top.s .top -} -result {} +} -result {} test scrollbar-11.2 {bug fix: [011706ec42] Scrollbar unsafe wrt widget destruction} -body { proc destroy_scrollbar {{y 0}} { if {[winfo exists .top.s]} { @@ -770,15 +798,15 @@ test scrollbar-11.2 {bug fix: [011706ec42] Scrollbar unsafe wrt widget destructi wm minsize .top 50 400 update scrollbar .top.s - bind .top.s <2> {after idle destroy_scrollbar} + bind .top.s <Button-2> {after idle destroy_scrollbar} pack .top.s -expand true -fill y focus -force .top.s update - event generate .top.s <2> -x 2 -y [expr {[winfo height .top.s] / 2}] + event generate .top.s <Button-2> -x 2 -y [expr {[winfo height .top.s] / 2}] update ; # shall not trigger error invalid command name ".top.s" } -cleanup { destroy .top.s .top -} -result {} +} -result {} catch {destroy .s} catch {destroy .t} diff --git a/tests/select.test b/tests/select.test index f89a736..9146397 100644 --- a/tests/select.test +++ b/tests/select.test @@ -952,7 +952,7 @@ test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup { # most control paths have been exercised above test select-10.1 {ConvertSelection procedure, race with selection clear} -constraints { - x11 + x11 } -setup { setup } -body { @@ -1021,7 +1021,7 @@ test select-10.4 {ConvertSelection procedure} -constraints { lappend result $selInfo } -result {{selection owner didn't respond} {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000 STRING 0 4000 STRING 4000 4000}} test select-10.5 {ConvertSelection procedure, reentrancy issues} -constraints { - x11 + x11 } -setup { setup setupbg @@ -1036,7 +1036,7 @@ test select-10.5 {ConvertSelection procedure, reentrancy issues} -constraints { lappend result $selInfo } -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000}} test select-10.6 {ConvertSelection procedure, reentrancy issues} -constraints { - x11 + x11 } -setup { setup setupbg @@ -1131,7 +1131,7 @@ test select-12.6 {DefaultSelection procedure} -body { } -result {{Targets value} {TARGETS.f1 0 4000} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} test select-13.1 {SelectionSize procedure, handler deleted} -constraints { - x11 + x11 } -setup { setup setupbg diff --git a/tests/spinbox.test b/tests/spinbox.test index ea29f60..2d03cf1 100644 --- a/tests/spinbox.test +++ b/tests/spinbox.test @@ -16,7 +16,7 @@ proc scroll args { global scrollInfo set scrollInfo $args } -# For trace variable +# For trace variable proc override args { global x set x 12345 @@ -1017,7 +1017,7 @@ test spinbox-2.5 {Tk_SpinboxCmd procedure} -body { test spinbox-3.1 {SpinboxWidgetCmd procedure} -setup { - spinbox .e + spinbox .e pack .e update } -body { @@ -1026,7 +1026,7 @@ test spinbox-3.1 {SpinboxWidgetCmd procedure} -setup { destroy .e } -returnCodes error -result {wrong # args: should be ".e option ?arg ...?"} test spinbox-3.2 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1035,7 +1035,7 @@ test spinbox-3.2 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { destroy .e } -returnCodes error -result {wrong # args: should be ".e bbox index"} test spinbox-3.3 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1044,7 +1044,7 @@ test spinbox-3.3 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { destroy .e } -returnCodes error -result {wrong # args: should be ".e bbox index"} test spinbox-3.4 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { - spinbox .e + spinbox .e pack .e update } -body { @@ -1053,7 +1053,7 @@ test spinbox-3.4 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { destroy .e } -returnCodes error -result {bad spinbox index "bogus"} test spinbox-3.5 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1062,7 +1062,7 @@ test spinbox-3.5 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { destroy .e } -result [list 5 5 0 $cy] -# Oryginaly the result was count using measurements +# Oryginaly the result was count using measurements # and metrics. It was changed to less verbose solution - the result is the one # that passes fonts constraint (this concerns tests 3.6, 3.7, 3.8, 3.10) test spinbox-3.6 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints { @@ -1081,7 +1081,7 @@ test spinbox-3.6 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraint test spinbox-3.7 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints { fonts } -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1094,7 +1094,7 @@ test spinbox-3.7 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraint test spinbox-3.8 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints { fonts } -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1105,7 +1105,7 @@ test spinbox-3.8 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraint destroy .e } -result {31 5 7 13} test spinbox-3.9 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1117,7 +1117,7 @@ test spinbox-3.9 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { test spinbox-3.10 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints { fonts } -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1127,28 +1127,28 @@ test spinbox-3.10 {SpinboxWidgetCmd procedure, "bbox" widget command} -constrain destroy .e } -result {{5 5 7 13} {12 5 7 13} {75 5 12 13} {122 5 7 13}} test spinbox-3.11 {SpinboxWidgetCmd procedure, "cget" widget command} -setup { - spinbox .e + spinbox .e } -body { .e cget } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e cget option"} test spinbox-3.12 {SpinboxWidgetCmd procedure, "cget" widget command} -setup { - spinbox .e + spinbox .e } -body { .e cget a b } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e cget option"} test spinbox-3.13 {SpinboxWidgetCmd procedure, "cget" widget command} -setup { - spinbox .e + spinbox .e } -body { .e cget -gorp } -cleanup { destroy .e } -returnCodes error -result {unknown option "-gorp"} test spinbox-3.14 {SpinboxWidgetCmd procedure, "cget" widget command} -setup { - spinbox .e + spinbox .e } -body { .e configure -bd 4 .e cget -bd @@ -1156,23 +1156,23 @@ test spinbox-3.14 {SpinboxWidgetCmd procedure, "cget" widget command} -setup { destroy .e } -result {4} test spinbox-3.15 {SpinboxWidgetCmd procedure, "configure" widget command} -setup { - spinbox .e + spinbox .e pack .e update } -body { llength [.e configure] } -cleanup { destroy .e -} -result {49} +} -result {51} test spinbox-3.16 {SpinboxWidgetCmd procedure, "configure" widget command} -setup { - spinbox .e + spinbox .e } -body { .e configure -foo } -cleanup { destroy .e } -returnCodes error -result {unknown option "-foo"} test spinbox-3.17 {SpinboxWidgetCmd procedure, "configure" widget command} -setup { - spinbox .e + spinbox .e } -body { .e configure -bd 4 .e configure -bg #ffffff @@ -1181,28 +1181,28 @@ test spinbox-3.17 {SpinboxWidgetCmd procedure, "configure" widget command} -setu destroy .e } -result {4} test spinbox-3.18 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { - spinbox .e + spinbox .e } -body { .e delete } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"} test spinbox-3.19 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { - spinbox .e + spinbox .e } -body { .e delete a b c } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"} test spinbox-3.20 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { - spinbox .e + spinbox .e } -body { .e delete foo } -cleanup { destroy .e } -returnCodes error -result {bad spinbox index "foo"} test spinbox-3.21 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { - spinbox .e + spinbox .e } -body { .e delete 0 bar } -cleanup { @@ -1211,7 +1211,7 @@ test spinbox-3.21 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { test spinbox-3.22 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { spinbox .e pack .e - update + update } -body { .e insert end "01234567890" .e delete 2 4 @@ -1220,7 +1220,7 @@ test spinbox-3.22 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { destroy .e } -result {014567890} test spinbox-3.23 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { - spinbox .e + spinbox .e } -body { .e insert end "01234567890" .e delete 6 @@ -1231,7 +1231,7 @@ test spinbox-3.23 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { test spinbox-3.24 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { spinbox .e pack .e - update + update set x {} } -body { # UTF @@ -1252,7 +1252,7 @@ test spinbox-3.24 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { test spinbox-3.25 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { spinbox .e pack .e - update + update } -body { .e insert end "01234567890" .e delete 6 5 @@ -1263,7 +1263,7 @@ test spinbox-3.25 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { test spinbox-3.26 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { spinbox .e pack .e - update + update } -body { .e insert end "01234567890" .e configure -state disabled @@ -1276,7 +1276,7 @@ test spinbox-3.26 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { test spinbox-3.26.1 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { spinbox .e pack .e - update + update } -body { .e insert end "01234567890" .e configure -state readonly @@ -1287,28 +1287,28 @@ test spinbox-3.26.1 {SpinboxWidgetCmd procedure, "delete" widget command} -setup destroy .e } -result {01234567890} test spinbox-3.27 {SpinboxWidgetCmd procedure, "get" widget command} -setup { - spinbox .e + spinbox .e } -body { .e get foo } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e get"} test spinbox-3.28 {SpinboxWidgetCmd procedure, "icursor" widget command} -setup { - spinbox .e + spinbox .e } -body { .e icursor } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e icursor pos"} test spinbox-3.29 {SpinboxWidgetCmd procedure, "icursor" widget command} -setup { - spinbox .e + spinbox .e } -body { .e icursor foo } -cleanup { destroy .e } -returnCodes error -result {bad spinbox index "foo"} test spinbox-3.30 {SpinboxWidgetCmd procedure, "icursor" widget command} -setup { - spinbox .e + spinbox .e } -body { .e insert end "01234567890" .e icursor 4 @@ -1317,21 +1317,21 @@ test spinbox-3.30 {SpinboxWidgetCmd procedure, "icursor" widget command} -setup destroy .e } -result {4} test spinbox-3.31 {SpinboxWidgetCmd procedure, "index" widget command} -setup { - spinbox .e + spinbox .e } -body { .e in } -cleanup { destroy .e } -returnCodes error -result {ambiguous option "in": must be bbox, cget, configure, delete, get, icursor, identify, index, insert, invoke, scan, selection, set, validate, or xview} test spinbox-3.32 {SpinboxWidgetCmd procedure, "index" widget command} -setup { - spinbox .e + spinbox .e } -body { .e index } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e index string"} test spinbox-3.33 {SpinboxWidgetCmd procedure, "index" widget command} -setup { - spinbox .e + spinbox .e } -body { .e index foo } -cleanup { @@ -1340,7 +1340,7 @@ test spinbox-3.33 {SpinboxWidgetCmd procedure, "index" widget command} -setup { test spinbox-3.34 {SpinboxWidgetCmd procedure, "index" widget command} -setup { spinbox .e pack .e - update + update } -body { .e index 0 } -cleanup { @@ -1349,7 +1349,7 @@ test spinbox-3.34 {SpinboxWidgetCmd procedure, "index" widget command} -setup { test spinbox-3.35 {SpinboxWidgetCmd procedure, "index" widget command} -setup { spinbox .e pack .e - update + update } -body { # UTF .e insert 0 abc\u4e4e\u0153def @@ -1358,21 +1358,21 @@ test spinbox-3.35 {SpinboxWidgetCmd procedure, "index" widget command} -setup { destroy .e } -result {3 4 8} test spinbox-3.36 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { - spinbox .e + spinbox .e } -body { .e insert a } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e insert index text"} test spinbox-3.37 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { - spinbox .e + spinbox .e } -body { .e insert a b c } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e insert index text"} test spinbox-3.38 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { - spinbox .e + spinbox .e } -body { .e insert foo Text } -cleanup { @@ -1381,7 +1381,7 @@ test spinbox-3.38 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { test spinbox-3.39 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { spinbox .e pack .e - update + update } -body { .e insert end "01234567890" .e insert 3 xxx @@ -1392,7 +1392,7 @@ test spinbox-3.39 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { test spinbox-3.40 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { spinbox .e pack .e - update + update } -body { .e insert end "01234567890" .e configure -state disabled @@ -1405,7 +1405,7 @@ test spinbox-3.40 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { test spinbox-3.40.1 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { spinbox .e pack .e - update + update } -body { .e insert end "01234567890" .e configure -state readonly @@ -1416,14 +1416,14 @@ test spinbox-3.40.1 {SpinboxWidgetCmd procedure, "insert" widget command} -setup destroy .e } -result {01234567890} test spinbox-3.41 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { - spinbox .e + spinbox .e } -body { .e insert a b c } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e insert index text"} test spinbox-3.42 {SpinboxWidgetCmd procedure, "scan" widget command} -setup { - spinbox .e + spinbox .e pack .e update } -body { @@ -1434,7 +1434,7 @@ test spinbox-3.42 {SpinboxWidgetCmd procedure, "scan" widget command} -setup { test spinbox-3.43 {SpinboxWidgetCmd procedure, "scan" widget command} -setup { spinbox .e pack .e - update + update } -body { .e scan a b c } -cleanup { @@ -1443,7 +1443,7 @@ test spinbox-3.43 {SpinboxWidgetCmd procedure, "scan" widget command} -setup { test spinbox-3.44 {SpinboxWidgetCmd procedure, "scan" widget command} -setup { spinbox .e pack .e - update + update } -body { .e scan foobar 20 } -cleanup { @@ -1452,7 +1452,7 @@ test spinbox-3.44 {SpinboxWidgetCmd procedure, "scan" widget command} -setup { test spinbox-3.45 {SpinboxWidgetCmd procedure, "scan" widget command} -setup { spinbox .e pack .e - update + update } -body { .e scan mark 20.1 } -cleanup { @@ -1463,7 +1463,7 @@ test spinbox-3.45 {SpinboxWidgetCmd procedure, "scan" widget command} -setup { test spinbox-3.46 {SpinboxWidgetCmd procedure, "scan" widget command} -constraints { fonts } -setup { - spinbox .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1476,14 +1476,14 @@ test spinbox-3.46 {SpinboxWidgetCmd procedure, "scan" widget command} -constrain destroy .e } -result {2} test spinbox-3.47 {SpinboxWidgetCmd procedure, "select" widget command} -setup { - spinbox .e + spinbox .e } -body { .e select } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e selection option ?index?"} test spinbox-3.48 {SpinboxWidgetCmd procedure, "select" widget command} -setup { - spinbox .e + spinbox .e } -body { .e select foo } -cleanup { @@ -1491,28 +1491,28 @@ test spinbox-3.48 {SpinboxWidgetCmd procedure, "select" widget command} -setup { } -returnCodes error -result {bad selection option "foo": must be adjust, clear, element, from, present, range, or to} test spinbox-3.49 {SpinboxWidgetCmd procedure, "select clear" widget command} -setup { - spinbox .e + spinbox .e } -body { .e select clear gorp } -cleanup { destroy .e } -returnCodes error -result {wrong # args: should be ".e selection clear"} test spinbox-3.50 {SpinboxWidgetCmd procedure, "select clear" widget command} -setup { - spinbox .e + spinbox .e } -body { .e insert end "0123456789" .e select from 1 .e select to 4 update .e select clear - selection get + selection get } -cleanup { destroy .e } -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined} test spinbox-3.50.1 {SpinboxWidgetCmd procedure, "select clear" widget command} -setup { spinbox .e pack .e - update + update } -body { .e insert end "0123456789" .e select from 1 @@ -1526,7 +1526,7 @@ test spinbox-3.50.1 {SpinboxWidgetCmd procedure, "select clear" widget command} } -result {.e} test spinbox-3.51 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup { - spinbox .e + spinbox .e } -body { .e selection present foo } -cleanup { @@ -1535,7 +1535,7 @@ test spinbox-3.51 {SpinboxWidgetCmd procedure, "selection present" widget comman test spinbox-3.52 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup { spinbox .e pack .e - update + update } -body { .e insert end 0123456789 .e select from 3 @@ -1547,7 +1547,7 @@ test spinbox-3.52 {SpinboxWidgetCmd procedure, "selection present" widget comman test spinbox-3.53 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup { spinbox .e pack .e - update + update } -body { .e insert end 0123456789 .e select from 3 @@ -1560,7 +1560,7 @@ test spinbox-3.53 {SpinboxWidgetCmd procedure, "selection present" widget comman test spinbox-3.54 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup { spinbox .e pack .e - update + update } -body { .e insert end 0123456789 .e select from 3 @@ -1699,7 +1699,7 @@ test spinbox-3.64.2 {SpinboxWidgetCmd procedure, "selection" widget command} -se } -result {2 4} test spinbox-3.65 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1711,7 +1711,7 @@ test spinbox-3.65 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -result {0.053763 0.268817} test spinbox-3.66 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1720,7 +1720,7 @@ test spinbox-3.66 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -returnCodes error -result {bad spinbox index "gorp"} test spinbox-3.67 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1734,7 +1734,7 @@ test spinbox-3.67 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -result {0.107527 0.322581} test spinbox-3.68 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1743,7 +1743,7 @@ test spinbox-3.68 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -returnCodes error -result {wrong # args: should be ".e xview moveto fraction"} test spinbox-3.69 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1752,7 +1752,7 @@ test spinbox-3.69 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -returnCodes error -result {expected floating-point number but got "foo"} test spinbox-3.70 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1764,7 +1764,7 @@ test spinbox-3.70 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -result {0.505376 0.720430} test spinbox-3.71 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1773,9 +1773,9 @@ test spinbox-3.71 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { .e xview scroll 24 } -cleanup { destroy .e -} -returnCodes error -result {wrong # args: should be ".e xview scroll number units|pages"} +} -returnCodes error -result {wrong # args: should be ".e xview scroll number pages|units"} test spinbox-3.72 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1786,7 +1786,7 @@ test spinbox-3.72 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -returnCodes error -result {expected integer but got "gorp"} test spinbox-3.73 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1799,7 +1799,7 @@ test spinbox-3.73 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -result {0.193548 0.408602} test spinbox-3.74 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1813,7 +1813,7 @@ test spinbox-3.74 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -result {0.397849 0.612903} test spinbox-3.75 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1821,13 +1821,13 @@ test spinbox-3.75 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { update .e xview 30 update - .e xview scroll 2 units + .e xview scroll 2 units .e index @0 } -cleanup { destroy .e } -result {32} test spinbox-3.76 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1835,13 +1835,13 @@ test spinbox-3.76 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { update .e xview 30 update - .e xview scroll -1 units + .e xview scroll -1 units .e index @0 } -cleanup { destroy .e } -result {29} test spinbox-3.77 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1850,9 +1850,9 @@ test spinbox-3.77 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { .e xview scroll 23 foobars } -cleanup { destroy .e -} -returnCodes error -result {bad argument "foobars": must be units or pages} +} -returnCodes error -result {bad argument "foobars": must be pages or units} test spinbox-3.78 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1863,7 +1863,7 @@ test spinbox-3.78 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -returnCodes error -result {unknown option "eat": must be moveto or scroll} test spinbox-3.79 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1877,7 +1877,7 @@ test spinbox-3.79 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -result {0} test spinbox-3.80 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1889,7 +1889,7 @@ test spinbox-3.80 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { destroy .e } -result {73} test spinbox-3.81 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e insert end "This is quite a long text string, so long that it " @@ -1911,7 +1911,7 @@ test spinbox-3.81 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { } -result {0.095745 0.106383 0.117021} test spinbox-3.82 {SpinboxWidgetCmd procedure} -setup { - spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e update } -body { @@ -1982,14 +1982,14 @@ test spinbox-5.5 {ConfigureSpinbox procedure} -setup { destroy .e1 .e2 } -result {{This is so} {This is so} 1234} test spinbox-5.6 {ConfigureSpinbox procedure} -setup { - spinbox .e + spinbox .e pack .e } -body { .e insert end "0123456789" .e select from 1 .e select to 5 .e configure -exportselection 0 - selection get + selection get } -cleanup { destroy .e } -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined} @@ -2001,14 +2001,14 @@ test spinbox-5.6.1 {ConfigureSpinbox procedure} -setup { .e select from 1 .e select to 5 .e configure -exportselection 0 - catch {selection get} + catch {selection get} list [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {1 5} test spinbox-5.7 {ConfigureSpinbox procedure} -setup { - spinbox .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2 + spinbox .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { .e configure -font {Courier -12} -width 4 -xscrollcommand scroll @@ -2025,7 +2025,7 @@ test spinbox-5.7 {ConfigureSpinbox procedure} -setup { test spinbox-5.8 {ConfigureSpinbox procedure} -constraints { fonts } -setup { - spinbox .e -borderwidth 2 -highlightthickness 2 + spinbox .e -borderwidth 2 -highlightthickness 2 pack .e } -body { .e configure -width 0 -font {Helvetica -12} @@ -2074,13 +2074,28 @@ test spinbox-5.11 {ConfigureSpinbox procedure} -setup { } -cleanup { destroy .e } -result {} +test spinbox-5.12 {ConfigureSpinbox procedure, -from and -to swapping} -setup { + spinbox .e +} -body { + # this statement used to trigger error "-to value must be greater than -from value" + # because default value for -to is zero (bug [841280ffff]) + set res [catch {.e configure -from 10}] + .e configure -from 1971 -to 2016 ; # standard case + lappend res [.e cget -from] [.e cget -to] + .e configure -from 2016 -to 1971 ; # auto-swapping happens + lappend res [.e cget -from] [.e cget -to] + .e configure -to 1971 -from 2016 ; # auto-swapping, order of options does not matter + lappend res [.e cget -from] [.e cget -to] +} -cleanup { + destroy .e +} -result {0 1971.0 2016.0 1971.0 2016.0 1971.0 2016.0} # No tests for DisplaySpinbox. test spinbox-6.1 {SpinboxComputeGeometry procedure} -constraints { fonts } -setup { - spinbox .e + spinbox .e pack .e } -body { .e configure -font {Courier -12} -bd 2 -relief raised -width 20 -highlightthickness 3 @@ -2093,7 +2108,7 @@ test spinbox-6.1 {SpinboxComputeGeometry procedure} -constraints { test spinbox-6.2 {SpinboxComputeGeometry procedure} -constraints { fonts } -setup { - spinbox .e + spinbox .e pack .e } -body { .e configure -font {Courier -12} -bd 2 -relief raised -width 20 -justify center \ @@ -2107,7 +2122,7 @@ test spinbox-6.2 {SpinboxComputeGeometry procedure} -constraints { test spinbox-6.3 {SpinboxComputeGeometry procedure} -constraints { fonts } -setup { - spinbox .e + spinbox .e pack .e } -body { .e configure -font {Courier -12} -bd 2 -relief raised -width 20 -justify right \ @@ -2119,7 +2134,7 @@ test spinbox-6.3 {SpinboxComputeGeometry procedure} -constraints { destroy .e } -result {3 4} test spinbox-6.4 {SpinboxComputeGeometry procedure} -setup { - spinbox .e + spinbox .e pack .e } -body { .e configure -font {Courier -12} -bd 2 -relief raised -width 5 @@ -2134,7 +2149,7 @@ test spinbox-6.5 {SpinboxComputeGeometry procedure} -setup { spinbox .e -highlightthickness 2 pack .e } -body { - .e configure -font {Courier -12} -bd 2 -relief raised -width 5 + .e configure -font {Courier -12} -bd 2 -relief raised -width 5 .e insert end "01234567890" update .e xview 7 @@ -2148,7 +2163,7 @@ test spinbox-6.6 {SpinboxComputeGeometry procedure} -constraints { spinbox .e -highlightthickness 2 pack .e } -body { - .e configure -font {Courier -12} -bd 2 -relief raised -width 10 + .e configure -font {Courier -12} -bd 2 -relief raised -width 10 .e insert end "01234\t67890" update .e xview 3 @@ -2188,7 +2203,7 @@ test spinbox-6.9 {SpinboxComputeGeometry procedure} -constraints { spinbox .e -highlightthickness 2 pack .e } -body { - .e configure -font {Helvetica -24} -bd 3 -relief raised -width 0 + .e configure -font {Helvetica -24} -bd 3 -relief raised -width 0 update list [winfo reqwidth .e] [winfo reqheight .e] } -cleanup { @@ -2197,7 +2212,7 @@ test spinbox-6.9 {SpinboxComputeGeometry procedure} -constraints { test spinbox-7.1 {InsertChars procedure} -setup { - unset -nocomplain contents + unset -nocomplain contents spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e @@ -2214,8 +2229,8 @@ test spinbox-7.1 {InsertChars procedure} -setup { } -result {abXXXcde abXXXcde {0.000000 1.000000}} test spinbox-7.2 {InsertChars procedure} -setup { - unset -nocomplain contents - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + unset -nocomplain contents + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2286,7 +2301,7 @@ test spinbox-7.6 {InsertChars procedure} -setup { destroy .e } -result {2 6 2 5} test spinbox-7.7 {InsertChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e } -body { .e configure -xscrollcommand scroll @@ -2298,7 +2313,7 @@ test spinbox-7.7 {InsertChars procedure} -setup { destroy .e } -result {7} test spinbox-7.8 {InsertChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e } -body { .e insert 0 0123456789 @@ -2309,7 +2324,7 @@ test spinbox-7.8 {InsertChars procedure} -setup { destroy .e } -result {4} test spinbox-7.9 {InsertChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e } -body { .e insert 0 "This is a very long string" @@ -2321,7 +2336,7 @@ test spinbox-7.9 {InsertChars procedure} -setup { destroy .e } -result {7} test spinbox-7.10 {InsertChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e } -body { .e insert 0 "This is a very long string" @@ -2336,7 +2351,7 @@ test spinbox-7.10 {InsertChars procedure} -setup { test spinbox-7.11 {InsertChars procedure} -constraints { fonts } -setup { - spinbox .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e } -body { .e insert 0 "xyzzy" @@ -2348,8 +2363,8 @@ test spinbox-7.11 {InsertChars procedure} -constraints { } -result {70} test spinbox-8.1 {DeleteChars procedure} -setup { - unset -nocomplain contents - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + unset -nocomplain contents + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2364,8 +2379,8 @@ test spinbox-8.1 {DeleteChars procedure} -setup { after cancel $timeout } -result {abe abe {0.000000 1.000000}} test spinbox-8.2 {DeleteChars procedure} -setup { - unset -nocomplain contents - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + unset -nocomplain contents + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2380,8 +2395,8 @@ test spinbox-8.2 {DeleteChars procedure} -setup { after cancel $timeout } -result {cde cde {0.000000 1.000000}} test spinbox-8.3 {DeleteChars procedure} -setup { - unset -nocomplain contents - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + unset -nocomplain contents + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2396,7 +2411,7 @@ test spinbox-8.3 {DeleteChars procedure} -setup { after cancel $timeout } -result {abc abc {0.000000 1.000000}} test spinbox-8.4 {DeleteChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2412,7 +2427,7 @@ test spinbox-8.4 {DeleteChars procedure} -setup { destroy .e } -result {1 6 1 5} test spinbox-8.5 {DeleteChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2428,7 +2443,7 @@ test spinbox-8.5 {DeleteChars procedure} -setup { destroy .e } -result {1 5 1 4} test spinbox-8.6 {DeleteChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2444,7 +2459,7 @@ test spinbox-8.6 {DeleteChars procedure} -setup { destroy .e } -result {1 2 1 5} test spinbox-8.7 {DeleteChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2458,7 +2473,7 @@ test spinbox-8.7 {DeleteChars procedure} -setup { destroy .e } -returnCodes error -result {selection isn't in widget .e} test spinbox-8.8 {DeleteChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2474,7 +2489,7 @@ test spinbox-8.8 {DeleteChars procedure} -setup { destroy .e } -result {3 4 3 8} test spinbox-8.9 {DeleteChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e } -body { .e insert 0 0123456789abcde @@ -2487,7 +2502,7 @@ test spinbox-8.9 {DeleteChars procedure} -setup { destroy .e } -returnCodes error -result {selection isn't in widget .e} test spinbox-8.10 {DeleteChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2503,7 +2518,7 @@ test spinbox-8.10 {DeleteChars procedure} -setup { destroy .e } -result {3 5 5 8} test spinbox-8.11 {DeleteChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2519,7 +2534,7 @@ test spinbox-8.11 {DeleteChars procedure} -setup { destroy .e } -result {3 8 4 8} test spinbox-8.12 {DeleteChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2532,7 +2547,7 @@ test spinbox-8.12 {DeleteChars procedure} -setup { destroy .e } -result {1} test spinbox-8.13 {DeleteChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2545,7 +2560,7 @@ test spinbox-8.13 {DeleteChars procedure} -setup { destroy .e } -result {1} test spinbox-8.14 {DeleteChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2558,7 +2573,7 @@ test spinbox-8.14 {DeleteChars procedure} -setup { destroy .e } -result {4} test spinbox-8.15 {DeleteChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2571,7 +2586,7 @@ test spinbox-8.15 {DeleteChars procedure} -setup { destroy .e } -result {1} test spinbox-8.16 {DeleteChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2584,7 +2599,7 @@ test spinbox-8.16 {DeleteChars procedure} -setup { destroy .e } -result {1} test spinbox-8.17 {DeleteChars procedure} -setup { - spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { @@ -2597,17 +2612,32 @@ test spinbox-8.17 {DeleteChars procedure} -setup { destroy .e } -result {4} test spinbox-8.18 {DeleteChars procedure} -setup { - spinbox .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2 + spinbox .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e focus .e } -body { .e insert 0 "xyzzy" update .e delete 2 4 - winfo reqwidth .e -} -cleanup { - destroy .e -} -result {42} + # To check that deletion actually happened we measure the new width + # of the widget, based on the measuring width of the remaining text ("xyy") + # in the widget. For that purpose we have to mirror the code in tkEntry.c + # for computation of the reqwidth + # note: XPAD corresponds to the hardcoded #define XPAD 1 + set XPAD 1 + set buttonWidth [expr { [font measure [.e cget -font] "0"] + 2 * (1 + $XPAD) }] + if {$buttonWidth < 11} { + set buttonWidth 11 + } + set expected [expr { [font measure [.e cget -font] "xyy"] \ + + 2 * ( [.e cget -borderwidth] + \ + [.e cget -highlightthickness] + $XPAD ) \ + + $buttonWidth } ] + expr {[winfo reqwidth .e] == $expected} +} -cleanup { + destroy .e + unset XPAD buttonWidth expected +} -result {1} test spinbox-9.1 {SpinboxValueChanged procedure} -setup { unset -nocomplain x @@ -2627,7 +2657,7 @@ test spinbox-10.1 {SpinboxSetValue procedure} -constraints fonts -body { set y ab spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 -width 0 pack .e - .e configure -textvariable x + .e configure -textvariable x .e configure -textvariable y update list [.e get] [winfo reqwidth .e] @@ -2636,7 +2666,7 @@ test spinbox-10.1 {SpinboxSetValue procedure} -constraints fonts -body { } -result {ab 35} test spinbox-10.2 {SpinboxSetValue procedure, updating selection} -setup { unset -nocomplain x - spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 + spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 pack .e } -body { .e configure -textvariable x @@ -2649,7 +2679,7 @@ test spinbox-10.2 {SpinboxSetValue procedure, updating selection} -setup { } -returnCodes error -result {selection isn't in widget .e} test spinbox-10.3 {SpinboxSetValue procedure, updating selection} -setup { unset -nocomplain x - spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 + spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 pack .e } -body { .e configure -textvariable x @@ -2662,7 +2692,7 @@ test spinbox-10.3 {SpinboxSetValue procedure, updating selection} -setup { } -result {4 7} test spinbox-10.4 {SpinboxSetValue procedure, updating selection} -setup { unset -nocomplain x - spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 + spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 pack .e } -body { .e configure -textvariable x @@ -2675,7 +2705,7 @@ test spinbox-10.4 {SpinboxSetValue procedure, updating selection} -setup { } -result {4 10} test spinbox-10.5 {SpinboxSetValue procedure, updating display position} -setup { unset -nocomplain x - spinbox .e -highlightthickness 2 -bd 2 + spinbox .e -highlightthickness 2 -bd 2 pack .e } -body { .e configure -width 10 -font {Courier -12} -textvariable x @@ -2690,7 +2720,7 @@ test spinbox-10.5 {SpinboxSetValue procedure, updating display position} -setup } -result {0} test spinbox-10.6 {SpinboxSetValue procedure, updating display position} -setup { unset -nocomplain x - spinbox .e -highlightthickness 2 -bd 2 + spinbox .e -highlightthickness 2 -bd 2 pack .e } -body { .e configure -width 10 -font {Courier -12} -textvariable x @@ -2706,7 +2736,7 @@ test spinbox-10.6 {SpinboxSetValue procedure, updating display position} -setup } -result {10} test spinbox-10.7 {SpinboxSetValue procedure, updating insertion cursor} -setup { unset -nocomplain x - spinbox .e -highlightthickness 2 -bd 2 + spinbox .e -highlightthickness 2 -bd 2 pack .e update } -body { @@ -2721,7 +2751,7 @@ test spinbox-10.7 {SpinboxSetValue procedure, updating insertion cursor} -setup } -result {3} test spinbox-10.8 {SpinboxSetValue procedure, updating insertion cursor} -setup { unset -nocomplain x - spinbox .e -highlightthickness 2 -bd 2 + spinbox .e -highlightthickness 2 -bd 2 pack .e } -body { .e configure -width 10 -font {Courier -12} -textvariable x @@ -2778,7 +2808,7 @@ test spinbox-13.1 {GetSpinboxIndex procedure} -setup { destroy .e } -result {21} test spinbox-13.2 {GetSpinboxIndex procedure} -body { - spinbox .e + spinbox .e .e index abogus } -cleanup { destroy .e @@ -2864,7 +2894,7 @@ test spinbox-13.9 {GetSpinboxIndex procedure} -setup { } -result {1 6} test spinbox-13.10 {GetSpinboxIndex procedure} -constraints x11 -body { -# On unix, when selection is cleared, spinbox widget's internal +# On unix, when selection is cleared, spinbox widget's internal # selection range is reset. # Previous settings: spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken @@ -2884,7 +2914,7 @@ test spinbox-13.10 {GetSpinboxIndex procedure} -constraints x11 -body { test spinbox-13.11 {GetSpinboxIndex procedure} -constraints aquaOrWin32 -body { # On mac and pc, when selection is cleared, spinbox widget remembers -# last selected range. When selection ownership is restored to +# last selected range. When selection ownership is restored to # spinbox, the old range will be rehighlighted. # Previous settings: spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken @@ -2901,7 +2931,7 @@ test spinbox-13.11 {GetSpinboxIndex procedure} -constraints aquaOrWin32 -body { .e index sel.first } -cleanup { destroy .e -} -result {1} +} -result {1} test spinbox-13.12 {GetSpinboxIndex procedure} -constraints x11 -body { # Previous settings: @@ -2956,7 +2986,7 @@ test spinbox-13.13 {GetSpinboxIndex procedure} -constraints win -body { test spinbox-13.14 {GetSpinboxIndex procedure} -constraints win -body { # On mac and pc, when selection is cleared, spinbox widget remembers -# last selected range. When selection ownership is restored to +# last selected range. When selection ownership is restored to # spinbox, the old range will be rehighlighted. # Previous settings: spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken @@ -2969,14 +2999,14 @@ test spinbox-13.14 {GetSpinboxIndex procedure} -constraints win -body { list [.e index sel.first] [.e index sel.last] # Testing: selection clear .e - selection get + selection get } -cleanup { destroy .e } -returnCodes error -match glob -result {*} test spinbox-13.14.1 {GetSpinboxIndex procedure} -constraints win -body { # On mac and pc, when selection is cleared, spinbox widget remembers -# last selected range. When selection ownership is restored to +# last selected range. When selection ownership is restored to # spinbox, the old range will be rehighlighted. # Previous settings: spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken @@ -2988,9 +3018,9 @@ test spinbox-13.14.1 {GetSpinboxIndex procedure} -constraints win -body { .e select to 6 list [.e index sel.first] [.e index sel.last] # Testing: - selection clear .e - catch {selection get} - .e index sbogus + selection clear .e + catch {selection get} + .e index sbogus } -cleanup { destroy .e } -returnCodes error -match glob -result {*} @@ -3005,7 +3035,7 @@ test spinbox-13.15 {GetSpinboxIndex procedure} -body { test spinbox-13.16 {GetSpinboxIndex procedure} -constraints fonts -body { spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ - -font {Courier -12} + -font {Courier -12} pack .e .e insert 0 012345678901234567890 .e xview 4 @@ -3016,7 +3046,7 @@ test spinbox-13.16 {GetSpinboxIndex procedure} -constraints fonts -body { } -result {4} test spinbox-13.17 {GetSpinboxIndex procedure} -constraints fonts -body { spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ - -font {Courier -12} + -font {Courier -12} pack .e .e insert 0 012345678901234567890 .e xview 4 @@ -3027,7 +3057,7 @@ test spinbox-13.17 {GetSpinboxIndex procedure} -constraints fonts -body { } -result {4} test spinbox-13.18 {GetSpinboxIndex procedure} -constraints fonts -body { spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ - -font {Courier -12} + -font {Courier -12} pack .e .e insert 0 012345678901234567890 .e xview 4 @@ -3038,7 +3068,7 @@ test spinbox-13.18 {GetSpinboxIndex procedure} -constraints fonts -body { } -result {5} test spinbox-13.19 {GetSpinboxIndex procedure} -constraints fonts -body { spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ - -font {Courier -12} + -font {Courier -12} pack .e .e insert 0 012345678901234567890 .e xview 4 @@ -3049,7 +3079,7 @@ test spinbox-13.19 {GetSpinboxIndex procedure} -constraints fonts -body { } -result {8} test spinbox-13.20 {GetSpinboxIndex procedure} -constraints fonts -body { spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ - -font {Courier -12} + -font {Courier -12} pack .e .e insert 0 012345678901234567890 .e xview 4 @@ -3060,7 +3090,7 @@ test spinbox-13.20 {GetSpinboxIndex procedure} -constraints fonts -body { } -result {9} test spinbox-13.21 {GetSpinboxIndex procedure} -body { spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ - -font {Courier -12} + -font {Courier -12} pack .e .e insert 0 012345678901234567890 .e xview 4 @@ -3070,7 +3100,7 @@ test spinbox-13.21 {GetSpinboxIndex procedure} -body { destroy .e } -result {9} test spinbox-13.22 {GetSpinboxIndex procedure} -setup { - spinbox .e + spinbox .e pack .e update } -body { @@ -3080,7 +3110,7 @@ test spinbox-13.22 {GetSpinboxIndex procedure} -setup { } -returnCodes error -result {bad spinbox index "1xyz"} test spinbox-13.23 {GetSpinboxIndex procedure} -body { spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ - -font {Courier -12} + -font {Courier -12} pack .e .e insert 0 012345678901234567890 .e xview 4 @@ -3091,7 +3121,7 @@ test spinbox-13.23 {GetSpinboxIndex procedure} -body { } -result {0} test spinbox-13.24 {GetSpinboxIndex procedure} -body { spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ - -font {Courier -12} + -font {Courier -12} pack .e .e insert 0 012345678901234567890 .e xview 4 @@ -3102,7 +3132,7 @@ test spinbox-13.24 {GetSpinboxIndex procedure} -body { } -result {12} test spinbox-13.25 {GetSpinboxIndex procedure} -body { spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ - -font {Courier -12} + -font {Courier -12} pack .e .e insert 0 012345678901234567890 .e xview 4 @@ -3130,7 +3160,7 @@ test spinbox-14.3 {SpinboxFetchSelection procedure} -setup { } } -body { spinbox .e - .e insert end $x + .e insert end $x .e select from 0 .e select to end string compare [selection get] $x @@ -3157,7 +3187,7 @@ test spinbox-16.1 {SpinboxVisibleRange procedure} -constraints fonts -body { spinbox .e -width 10 -font {Helvetica -12} pack .e update - .e insert 0 "............................." + .e insert 0 "............................." format {%.6f %.6f} {*}[.e xview] } -cleanup { destroy .e @@ -3234,7 +3264,7 @@ test spinbox-18.1 {Spinbox widget vs hiding} -setup { set res1 [list [winfo children .] [interp hidden]] set res2 [list {} $l] expr {$res1 == $res2} -} -result {1} +} -result {1} ## ## Spinbox widget VALIDATION tests @@ -3588,7 +3618,7 @@ test spinbox-19.19 {spinbox widget validation} -setup { -background red -foreground white pack .e set ::e nextdata ;# previous settings - + .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] .e validate list [.e cget -validate] [.e get] $::vVals @@ -3613,7 +3643,7 @@ test spinbox-19.20 {spinbox widget validation} -setup { set ::e nextdata ;# previous settings .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] ;# prev .e validate ;# previous settings - + .e configure -validate all set ::e testdata list [.e cget -validate] [.e get] $::e $::vVals diff --git a/tests/teapotTransparent.png b/tests/teapotTransparent.png Binary files differnew file mode 100644 index 0000000..1e7e46d --- /dev/null +++ b/tests/teapotTransparent.png diff --git a/tests/text.test b/tests/text.test index 5b2d7e3..8019e0d 100644 --- a/tests/text.test +++ b/tests/text.test @@ -910,7 +910,7 @@ test text-2.7 {Tk_TextCmd procedure} -constraints { } -body { catch {destroy .t} text .t - .t tag cget sel -relief + .t tag cget sel -relief } -cleanup { destroy .t } -result {flat} @@ -919,7 +919,7 @@ test text-2.8 {Tk_TextCmd procedure} -constraints { } -body { catch {destroy .t} text .t - .t tag cget sel -relief + .t tag cget sel -relief } -cleanup { destroy .t } -result {flat} @@ -928,7 +928,7 @@ test text-2.9 {Tk_TextCmd procedure} -constraints { } -body { catch {destroy .t} text .t - .t tag cget sel -relief + .t tag cget sel -relief } -cleanup { destroy .t } -result {raised} @@ -1485,7 +1485,19 @@ Line 7" rename .t {} rename test.t .t destroy .t -} -result {{edit undo} {delete 2.1 2.4} {mark set insert 2.1} {see insert} {insert 2.1 ef} {mark set insert 2.3} {see insert}} +} -result [list {edit undo} {delete 2.1 2.4} {mark set insert 2.1} {see insert} \ + {mark set tk::undoMarkL2 2.1} {mark set tk::undoMarkR2 2.4} \ + {mark gravity tk::undoMarkL2 left} {mark gravity tk::undoMarkR2 right} \ + {insert 2.1 ef} {mark set insert 2.3} {see insert} \ + {mark set tk::undoMarkL1 2.1} {mark set tk::undoMarkR1 2.3} \ + {mark gravity tk::undoMarkL1 left} {mark gravity tk::undoMarkR1 right} \ + {mark names} \ + {index tk::undoMarkL1} {index tk::undoMarkR1} \ + {mark unset tk::undoMarkL1 tk::undoMarkR1} \ + {index tk::undoMarkL2} {index tk::undoMarkR2} \ + {mark unset tk::undoMarkL2 tk::undoMarkR2} \ + {compare 2.1 > 2.3} {compare 2.6 > 2.3} ] + test text-8.23 {TextWidgetCmd procedure, "replace" option with undo} -setup { text .t } -body { @@ -2035,7 +2047,7 @@ Line 7" .t tag configure elide -elide 1 .t tag add elide 5.2 5.4 .t window create 5.4 - .t delete 5.4 + .t delete 5.4 .t tag add elide 5.5 5.6 .t get -displaychars 5.2 5.8 } -cleanup { @@ -2917,7 +2929,7 @@ test text-11.9 {counting with tag priority eliding} -setup { lappend res [.t index "1.0 +1 indices"] lappend res [.t index "1.0 +1 display indices"] lappend res [.t index "1.0 +1 display chars"] - lappend res [.t index end] + lappend res [.t index end] lappend res [.t index "end -1 indices"] lappend res [.t index "end -1 display indices"] lappend res [.t index "end -1 display chars"] @@ -3089,7 +3101,7 @@ test text-11a.41 {"sync" "pendingsync" and <<WidgetViewSync>>} -setup { for {set i 1} {$i < 300} {incr i} { append content [string repeat "$i " 50] \n } - # Sync the widget and process all <<WidgetViewSync>> events before binding. + # Sync the widget and process all <<WidgetViewSync>> events before binding. .top.yt sync update bind .top.yt <<WidgetViewSync>> {lappend res Sync:%d} @@ -3120,7 +3132,7 @@ test text-11a.51 {<<WidgetViewSync>> calls TkSendVirtualEvent(), pack [text .top.t] update for {set i 1} {$i < 10000} {incr i} { - .top.t insert end "Hello world!\n" + .top.t insert end "Hello world!\n" } bind .top.t <<WidgetViewSync>> {destroy .top.t} .top.t tag add mytag 1.5 8000.8 ; # shall not crash @@ -3323,11 +3335,11 @@ test text-14.5 {ConfigureText procedure} -setup { .t configure -tabs {30 foo} } -cleanup { destroy .t -} -returnCodes {error} -result {bad tab alignment "foo": must be left, right, center, or numeric} +} -returnCodes {error} -result {bad tab alignment "foo": must be left, right, center, or numeric} test text-14.6 {ConfigureText procedure} -setup { text .t } -body { - catch {.t configure -tabs {30 foo}} + catch {.t configure -tabs {30 foo}} .t configure -tabs {10 20 30} return $errorInfo } -cleanup { @@ -3346,7 +3358,7 @@ test text-14.7 {ConfigureText procedure} -setup { destroy .t } -result {} test text-14.8 {ConfigureText procedure} -setup { - text .t + text .t } -body { .t configure -wrap bogus } -cleanup { @@ -3372,7 +3384,7 @@ test text-14.10 {ConfigureText procedure} -setup { destroy .t } -result {} test text-14.11 {ConfigureText procedure} -setup { - text .t + text .t } -body { .t configure -selectborderwidth foo } -cleanup { @@ -3462,7 +3474,7 @@ test text-14.18 {ConfigureText procedure} -constraints fonts -setup { toplevel .top text .top.t -font {Courier -12} -borderwidth 2 -highlightthickness 2 } -body { - .top.t configure -width 20 -height 10 + .top.t configure -width 20 -height 10 pack .top.t update set geom [wm geometry .top] @@ -3558,7 +3570,7 @@ test text-17.1 {TextCmdDeletedProc procedure} -body { test text-17.2 {TextCmdDeletedProc procedure, disabling -setgrid} -constraints { fonts } -body { - toplevel .top + toplevel .top text .top.t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} \ -setgrid 1 -width 20 -height 10 pack .top.t @@ -4950,7 +4962,7 @@ test text-22.118 {TextSearchCmd, multiline matching end of window} -body { test text-22.119 {TextSearchCmd, multiline regexp matching} -body { pack [text .t] .t insert 1.0 { Tcl_Obj *objPtr)); -static Tcl_Obj* FSNormalizeAbsolutePath +static Tcl_Obj* FSNormalizeAbsolutePath _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr));} set markExpr "^(\[A-Za-z0-9~_\]+\[ \t\n\r\]*\\(|(\[^ \t\(#\n\r/@:\*\]\[^=\(\r\n\]*\[ \t\]+\\*?)?" append markExpr "(\[A-Za-z0-9~_\]+(<\[^>\]*>)?(::)?(\[A-Za-z0-9~_\]+::)*\[-A-Za-z0-9~_+ <>\|\\*/\]+|\[A-Za-z0-9~_\]+)" @@ -4967,7 +4979,7 @@ test text-22.120 {TextSearchCmd, multiline regexp matching} -body { pack [text .t] .t insert 1.0 {static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); -static Tcl_Obj* FSNormalizeAbsolutePath +static Tcl_Obj* FSNormalizeAbsolutePath _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr));} set markExpr "^(\[A-Za-z0-9~_\]+\[ \t\n\r\]*\\(|(\[^ \t\(#\n\r/@:\*\]\[^=\(\r\n\]*\[ \t\]+\\*?)?" append markExpr "(\[A-Za-z0-9~_\]+(<\[^>\]*>)?(::)?(\[A-Za-z0-9~_\]+::)*\[-A-Za-z0-9~_+ <>\|\\*/\]+|\[A-Za-z0-9~_\]+)" @@ -4981,7 +4993,7 @@ test text-22.121 {TextSearchCmd, multiline regexp matching} -body { .t insert 1.0 { static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); -static Tcl_Obj* FSNormalizeAbsolutePath +static Tcl_Obj* FSNormalizeAbsolutePath _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr));} set markExpr "^(\[A-Za-z0-9~_\]+\[ \t\n\r\]*\\(|(\[^ \t\(#\n\r/@:\*\]\[^=\(\r\n\]*\[ \t\]+\\*?)?" append markExpr "(\[A-Za-z0-9~_\]+(<\[^>\]*>)?(::)?(\[A-Za-z0-9~_\]+::)*\[-A-Za-z0-9~_+ <>\|\\*/\]+|\[A-Za-z0-9~_\]+)" @@ -6177,7 +6189,7 @@ test text-23.7 {TkTextGetTabs procedure} -setup { test text-24.1 {TextDumpCmd procedure, bad args} -body { pack [text .t] .t insert 1.0 "One Line" - .t mark set insert 1.0 + .t mark set insert 1.0 .t dump } -cleanup { destroy .t @@ -6185,7 +6197,7 @@ test text-24.1 {TextDumpCmd procedure, bad args} -body { test text-24.2 {TextDumpCmd procedure, bad args} -body { pack [text .t] .t insert 1.0 "One Line" - .t mark set insert 1.0 + .t mark set insert 1.0 .t dump -all } -cleanup { destroy .t @@ -6193,7 +6205,7 @@ test text-24.2 {TextDumpCmd procedure, bad args} -body { test text-24.3 {TextDumpCmd procedure, bad args} -body { pack [text .t] .t insert 1.0 "One Line" - .t mark set insert 1.0 + .t mark set insert 1.0 .t dump -command } -cleanup { destroy .t @@ -6201,7 +6213,7 @@ test text-24.3 {TextDumpCmd procedure, bad args} -body { test text-24.4 {TextDumpCmd procedure, bad args} -body { pack [text .t] .t insert 1.0 "One Line" - .t mark set insert 1.0 + .t mark set insert 1.0 .t dump -bogus } -cleanup { destroy .t @@ -6209,7 +6221,7 @@ test text-24.4 {TextDumpCmd procedure, bad args} -body { test text-24.5 {TextDumpCmd procedure, bad args} -body { pack [text .t] .t insert 1.0 "One Line" - .t mark set insert 1.0 + .t mark set insert 1.0 .t dump bogus } -cleanup { destroy .t @@ -6246,7 +6258,7 @@ test text-24.9 {TextDumpCmd procedure, same indices} -body { test text-24.10 {TextDumpCmd procedure, negative range} -body { pack [text .t] .t insert 1.0 "One Line" - .t mark set insert 1.0 + .t mark set insert 1.0 .t dump 1.5 1.0 } -cleanup { destroy .t @@ -6564,6 +6576,7 @@ test text-27.11 {TextEditCmd procedure, set modified flag repeat} -setup { # Make sure the Text is mapped before we start update set ::retval {} + update } -body { bind .t <<Modified>> "lappend ::retval modified" # Shouldn't require [update idle] to trigger event [Bug 1809538] @@ -6809,14 +6822,14 @@ test text-27.18 {patch 1469210 - inserting after undo} -setup { } -cleanup { destroy .t } -result 1 -test text-27.19 {patch 1669632 (i) - undo after <Control-1>} -setup { +test text-27.19 {patch 1669632 (i) - undo after <Control-Button-1>} -setup { destroy .t } -body { text .t -undo 1 .t insert end foo\nbar .t edit reset .t insert 2.2 WORLD - event generate .t <Control-1> -x 1 -y 1 + event generate .t <Control-Button-1> -x 1 -y 1 .t insert insert HELLO .t edit undo .t get 2.2 2.7 @@ -6849,7 +6862,7 @@ test text-27.21 {patch 1669632 (vii) - <<Undo>> shall not remove separators} -se .t insert end "This is an example text" .t edit reset .t insert 1.5 "WORLD " - event generate .t <Control-1> -x 1 -y 1 + event generate .t <Control-Button-1> -x 1 -y 1 .t insert insert HELLO event generate .t <<Undo>> .t insert insert E @@ -6966,6 +6979,66 @@ test text-27.25 {<<UndoStack>> virtual event} -setup { } -cleanup { destroy .t } -result {0 0 1 2 3 4 4 5 6 6 7 8 8 9} +test text-27.26 {edit undo and edit redo return ranges} -setup { + destroy .t + set res {} +} -body { + text .t -undo true -autoseparators false + .t insert end "Hello " + .t edit separator + .t insert end "World!\n" + .t insert 1.6 "GREAT " + .t insert end "Another edit here!!" + lappend res [.t edit undo] + lappend res [.t edit redo] + .t edit separator + .t delete 1.6 + .t delete 1.9 1.10 + .t insert 1.9 L + lappend res [.t edit undo] + lappend res [.t edit redo] + .t replace 1.6 1.10 Tcl/Tk + .t replace 2.8 2.12 "one bites the dust" + lappend res [.t edit undo] + lappend res [.t edit redo] +} -cleanup { + destroy .t +} -result [list {1.6 2.0} \ + {1.6 2.19} \ + {1.6 1.7 1.10 1.12} \ + {1.6 1.7 1.9 1.11} \ + {1.6 1.16 2.8 2.19} \ + {1.6 1.16 2.8 2.30} ] +test text-27.27 {edit undo and edit redo return ranges} -setup { + destroy .t + set res {} +} -body { + text .t -undo true -autoseparators false + for {set i 3} {$i >= 1} {incr i -1} { + .t insert 1.0 "Line $i\n" + } + lappend res [.t edit undo] + lappend res [.t edit redo] +} -cleanup { + destroy .t +} -result [list {1.0 2.0} \ + {1.0 4.0} ] +test text-27.28 {edit undo and edit redo do not leave \ + spurious temporary marks behind them} -setup { + destroy .t + set res {} +} -body { + pack [text .t -undo true -autoseparators false] + .t insert end "Hello World.\n" + .t edit separator + .t insert end "Again hello.\n" + .t edit undo + lappend res [lsearch [.t mark names] tk::undoMark*] + .t edit redo + lappend res [lsearch [.t mark names] tk::undoMark*] +} -cleanup { + destroy .t +} -result [list -1 -1] test text-28.1 {bug fix - 624372, ControlUtfProc long lines} -body { @@ -7236,7 +7309,7 @@ test text-31.14 {peer widgets} -setup { for {set i 1} {$i < 20} {incr i} { .t insert end "Line $i\n" } - .t tag add sel 1.0 3.0 5.0 7.0 9.0 11.0 13.0 15.0 17.0 19.0 + .t tag add sel 1.0 3.0 5.0 7.0 9.0 11.0 13.0 15.0 17.0 19.0 lappend res [.t tag prevrange sel 1.0] .t configure -start 6 -end 12 lappend res [.t tag ranges sel] @@ -7257,7 +7330,7 @@ test text-31.15 {peer widgets} -setup { for {set i 1} {$i < 20} {incr i} { .t insert end "Line $i\n" } - .t tag add sel 1.0 3.0 9.0 11.0 13.0 15.0 17.0 19.0 + .t tag add sel 1.0 3.0 9.0 11.0 13.0 15.0 17.0 19.0 .t configure -start 6 -end 12 lappend res [.t tag ranges sel] lappend res "next" [.t tag nextrange sel 4.0] \ @@ -7277,7 +7350,7 @@ test text-31.16 {peer widgets} -setup { for {set i 1} {$i < 20} {incr i} { .t insert end "Line $i\n" } - .t tag add sel 1.0 7.0 9.0 11.0 13.0 15.0 17.0 19.0 + .t tag add sel 1.0 7.0 9.0 11.0 13.0 15.0 17.0 19.0 .t configure -start 6 -end 12 lappend res [.t tag ranges sel] lappend res "next" [.t tag nextrange sel 4.0] \ @@ -7322,7 +7395,7 @@ test text-31.18 {peer widgets} -setup { return $res } -cleanup { destroy .t -} -result {1.0 11.0} +} -result {1.0 11.0} test text-31.19 {peer widgets} -body { pack [text .t] for {set i 1} {$i < 20} {incr i} { @@ -7367,7 +7440,7 @@ test text-32.1 {line heights on creation} -setup { update set after [$w count -ypixels 1.0 2.0] destroy .g - expr {$before eq $after} + expr {$before eq $after} } -cleanup { destroy .t } -result {1} @@ -7466,6 +7539,100 @@ test text-32.4 {peer widget -start, -end and deletion (bug 1630262)} -setup { destroy .pt .t } -result {5 11 8 10 5 8 6 8 22 27 38 44 55 60 57 57} +test text-32.2 {peer widget -start, -end and deletion (bug 1630262)} -setup { + destroy .t .pt + set res {} +} -body { + text .t + .t peer create .pt + for {set i 1} {$i < 100} {incr i} { + .t insert end "Line $i\n" + } + .t configure -startline 5 + # none of the following delete shall crash + # (all did before fixing bug 1630262) + # 1. delete on the same line: line1 == line2 in DeleteIndexRange, + # and resetView is true neither for .t not for .pt + .pt delete 2.0 2.2 + # 2. delete just one line: line1 < line2 in DeleteIndexRange, + # and resetView is true only for .t, not for .pt + .pt delete 2.0 3.0 + # 3. delete several lines: line1 < line2 in DeleteIndexRange, + # and resetView is true only for .t, not for .pt + .pt delete 2.0 5.0 + # 4. delete to the end line: line1 < line2 in DeleteIndexRange, + # and resetView is true only for .t, not for .pt + .pt delete 2.0 end + # this test succeeds provided there is no crash + set res 1 +} -cleanup { + destroy .pt +} -result {1} + +test text-32.3 {peer widget -start, -end and deletion (bug 1630262)} -setup { + destroy .t .pt + set res {} +} -body { + text .t + .t peer create .pt + for {set i 1} {$i < 100} {incr i} { + .t insert end "Line $i\n" + } + .t configure -startline 5 + .pt configure -startline 3 + # the following delete shall not crash + # (it did before fixing bug 1630262) + .pt delete 2.0 3.0 + # moreover -startline shall be correct + # (was wrong before fixing bug 1630262) + lappend res [.t cget -start] [.pt cget -start] +} -cleanup { + destroy .pt +} -result {4 3} + +test text-32.4 {peer widget -start, -end and deletion (bug 1630262)} -setup { + destroy .t .pt + set res {} +} -body { + text .t + .t peer create .pt + for {set i 1} {$i < 100} {incr i} { + .t insert end "Line $i\n" + } + .t configure -startline 5 -endline 15 + .pt configure -startline 8 -endline 12 + # .pt now shows a range entirely inside the range of .pt + # from .t, delete lines located after [.pt cget -end] + .t delete 9.0 10.0 + # from .t, delete lines straddling [.pt cget -end] + .t delete 6.0 9.0 + lappend res [.t cget -start] [.t cget -end] [.pt cget -start] [.pt cget -end] + .t configure -startline 5 -endline 12 + .pt configure -startline 8 -endline 12 + # .pt now shows again a range entirely inside the range of .pt + # from .t, delete lines located before [.pt cget -start] + .t delete 2.0 3.0 + # from .t, delete lines straddling [.pt cget -start] + .t delete 2.0 5.0 + lappend res [.t cget -start] [.t cget -end] [.pt cget -start] [.pt cget -end] + .t configure -startline 22 -endline 31 + .pt configure -startline 42 -endline 51 + # .t now shows a range entirely before the range of .pt + # from .t, delete some lines, then do it from .pt + .t delete 2.0 3.0 + .t delete 2.0 5.0 + .pt delete 2.0 5.0 + lappend res [.t cget -start] [.t cget -end] [.pt cget -start] [.pt cget -end] + .t configure -startline 55 -endline 75 + .pt configure -startline 60 -endline 70 + # .pt now shows a range entirely inside the range of .t + # from .t, delete a range straddling the entire range of .pt + .t delete 3.0 18.0 + lappend res [.t cget -start] [.t cget -end] [.pt cget -start] [.pt cget -end] +} -cleanup { + destroy .pt .t +} -result {5 11 8 10 5 8 6 8 22 27 38 44 55 60 57 57} + test text-33.1 {TextWidgetCmd procedure, "peer" option} -setup { text .t @@ -7650,8 +7817,8 @@ test text-36.1 "bug #1777362: event handling with hyphenated windows" -setup { pack [set w [text .t-1]] } -body { tkwait visibility $w - event generate $w <1> - event generate $w <1> + event generate $w <Button-1> + event generate $w <Button-1> update set ::my_error } -cleanup { @@ -7668,8 +7835,8 @@ test text-36.2 "bug #1777362: event handling with hyphenated windows" -setup { pack [set w [text .t+1]] } -body { tkwait visibility $w - event generate $w <1> - event generate $w <1> + event generate $w <Button-1> + event generate $w <Button-1> update set ::my_error } -cleanup { @@ -7686,8 +7853,8 @@ test text-36.3 "bug #1777362: event handling with hyphenated windows" -setup { pack [set w [text .t*1]] } -body { tkwait visibility $w - event generate $w <1> - event generate $w <1> + event generate $w <Button-1> + event generate $w <Button-1> update set ::my_error } -cleanup { diff --git a/tests/textDisp.test b/tests/textDisp.test index b4891e4..f2d7047 100644 --- a/tests/textDisp.test +++ b/tests/textDisp.test @@ -53,7 +53,15 @@ catch {destroy .f .t} frame .f -width 100 -height 20 pack .f -side left -set fixedFont {Courier -12} +# On macOS the font "Courier New" has different metrics than "Courier", +# and this causes tests 20.1 - 20.5 to fail. So we use "Courier" as the +# fixed font for testing on Aqua. + +if {[tk windowingsystem] eq "aqua"} { + set fixedFont {Courier -12} +} else { + set fixedFont {"Courier New" -12} +} # 15 on XP, 13 on Solaris 8 set fixedHeight [font metrics $fixedFont -linespace] # 7 on all platforms @@ -602,7 +610,7 @@ if {$tcl_platform(platform) == "windows"} { test textDisp-4.6 {UpdateDisplayInfo, tiny window} { # This test was failing on Windows because the title bar on . # was a certain minimum size and it was interfering with the size - # requested. The "overrideredirect" gets rid of the titlebar so + # requested. The "overrideredirect" gets rid of the titlebar so # the toplevel can shrink to the appropriate size. On Unix, setting # the overrideredirect on "." confuses the window manager and # causes subsequent tests to fail. @@ -634,7 +642,7 @@ set hlth [.t cget -highlightthickness] test textDisp-4.7 {UpdateDisplayInfo, filling in extra vertical space} { # This test was failing on Windows because the title bar on . # was a certain minimum size and it was interfering with the size - # requested. The "overrideredirect" gets rid of the titlebar so + # requested. The "overrideredirect" gets rid of the titlebar so # the toplevel can shrink to the appropriate size. On Unix, setting # the overrideredirect on "." confuses the window manager and # causes subsequent tests to fail. @@ -1876,10 +1884,10 @@ test textDisp-14.9 {TkTextXviewCmd procedure} { } [list [expr {9.0/14}] 1.0] test textDisp-14.10 {TkTextXviewCmd procedure} { list [catch {.t xview scroll a} msg] $msg -} {1 {wrong # args: should be ".t xview scroll number units|pages|pixels"}} +} {1 {wrong # args: should be ".t xview scroll number pages|pixels|units"}} test textDisp-14.11 {TkTextXviewCmd procedure} { list [catch {.t xview scroll a b c} msg] $msg -} {1 {wrong # args: should be ".t xview scroll number units|pages|pixels"}} +} {1 {wrong # args: should be ".t xview scroll number pages|pixels|units"}} test textDisp-14.12 {TkTextXviewCmd procedure} { list [catch {.t xview scroll gorp units} msg] $msg } {1 {expected integer but got "gorp"}} @@ -1902,7 +1910,7 @@ test textDisp-14.14 {TkTextXviewCmd procedure} { .t insert end "a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9\n" .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" .t xview moveto 0 - .t xview scroll 21 u + .t xview scroll 21 u set x [.t index @0,22] .t xview scroll -1 u lappend x [.t index @0,22] @@ -1913,7 +1921,7 @@ test textDisp-14.14 {TkTextXviewCmd procedure} { } {2.21 2.20 2.99 2.84} test textDisp-14.15 {TkTextXviewCmd procedure} { list [catch {.t xview scroll 14 globs} msg] $msg -} {1 {bad argument "globs": must be units, pages, or pixels}} +} {1 {bad argument "globs": must be pages, pixels, or units}} test textDisp-14.16 {TkTextXviewCmd procedure} { list [catch {.t xview flounder} msg] $msg } {1 {bad option "flounder": must be moveto or scroll}} @@ -2096,13 +2104,13 @@ test textDisp-16.18 {TkTextYviewCmd procedure, "moveto" roundoff} {textfonts} { } [list [expr {1.0/3}] [expr {5.0/6}]] test textDisp-16.19 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll a} msg] $msg -} {1 {wrong # args: should be ".t yview scroll number units|pages|pixels"}} +} {1 {wrong # args: should be ".t yview scroll number pages|pixels|units"}} test textDisp-16.20 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll a b c} msg] $msg -} {1 {wrong # args: should be ".t yview scroll number units|pages|pixels"}} +} {1 {wrong # args: should be ".t yview scroll number pages|pixels|units"}} test textDisp-16.21 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll badInt bogus} msg] $msg -} {1 {bad argument "bogus": must be units, pages, or pixels}} +} {1 {bad argument "bogus": must be pages, pixels, or units}} test textDisp-16.21.2 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll badInt units} msg] $msg } {1 {expected integer but got "badInt"}} @@ -2114,7 +2122,7 @@ test textDisp-16.22 {TkTextYviewCmd procedure, "scroll" option, back pages} { } {42.0} test textDisp-16.22.1 {TkTextYviewCmd procedure, "scroll" option, back pages} { list [catch {.t yview scroll -3 p} res] $res -} {1 {ambiguous argument "p": must be units, pages, or pixels}} +} {1 {ambiguous argument "p": must be pages, pixels, or units}} test textDisp-16.23 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t yview 50.0 updateText @@ -2185,7 +2193,7 @@ test textDisp-16.31 {TkTextYviewCmd procedure, "scroll units" option} { } {151.40} test textDisp-16.32 {TkTextYviewCmd procedure} { list [catch {.t yview scroll 12 bogoids} msg] $msg -} {1 {bad argument "bogoids": must be units, pages, or pixels}} +} {1 {bad argument "bogoids": must be pages, pixels, or units}} test textDisp-16.33 {TkTextYviewCmd procedure} { list [catch {.t yview bad_arg 1 2} msg] $msg } {1 {bad option "bad_arg": must be moveto or scroll}} @@ -2359,7 +2367,7 @@ test textDisp-17.8 {TkTextScanCmd procedure} {textfonts} { .t xview moveto 0 .t scan mark 0 60 .t scan dragto 30 100 - .t scan dragto 25 95 + .t scan dragto 25 95 .t index @0,0 } {4.7} test textDisp-17.9 {TkTextScanCmd procedure} {textfonts} { @@ -2921,7 +2929,7 @@ test textDisp-20.1 {FindDLine} { list [.t dlineinfo 46.0] [.t dlineinfo 47.0] [.t dlineinfo 49.0] \ [.t dlineinfo 58.0] } [list {} {} [list 3 [expr {$fixedDiff + 16}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] {}] -test textDisp-20.2 {FindDLine} { +test textDisp-20.2 {FindDLine} { .t yview 100.0 .t yview -pickplace 53.0 list [.t dlineinfo 50.0] [.t dlineinfo 50.14] [.t dlineinfo 50.21] @@ -2970,7 +2978,7 @@ test textDisp-21.4 {count -displaylines regression} { Use the Up (cursor) key to scroll up one line at a time. At the second press, the cursor either gets locked or jumps several lines. Connect with Tkcon. The command -.u count -displaylines \ +.u count -displaylines \ 3.10 2.173 should give answer -1; it gives me 5. @@ -3874,7 +3882,7 @@ test textDisp-29.2.5 {miscellaneous: can show last character} { set iWidth [lindex [.t2.t bbox end-2c] 2] .t2.t xview scroll 2 units set iWidth2 [lindex [.t2.t bbox end-2c] 2] - + if {($iWidth == $iWidth2) && $iWidth >= 2} { set result "correct" } else { diff --git a/tests/textImage.test b/tests/textImage.test index 4bb190c..2666ec5 100644 --- a/tests/textImage.test +++ b/tests/textImage.test @@ -74,7 +74,7 @@ test textImage-1.6 {configure argument checking} -setup { } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t - .t image configure + .t image configure } -cleanup { destroy .t } -returnCodes error -result {wrong # args: should be ".t image configure index ?-option value ...?"} @@ -84,7 +84,7 @@ test textImage-1.7 {configure argument checking} -setup { } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t - .t image configure blurf + .t image configure blurf } -cleanup { destroy .t } -returnCodes error -result {bad text index "blurf"} @@ -94,7 +94,7 @@ test textImage-1.8 {configure argument checking} -setup { } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t - .t image configure 1.1 + .t image configure 1.1 } -cleanup { destroy .t } -returnCodes error -result {no embedded image at index "1.1"} @@ -114,7 +114,7 @@ test textImage-1.10 {create argument checking} -setup { } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t - .t image create blurf + .t image create blurf } -cleanup { destroy .t } -returnCodes error -result {bad text index "blurf"} @@ -221,7 +221,7 @@ test textImage-1.17 {basic cget options} -setup { .t image create end -image small foreach i {align padx pady image name} { lappend result $i:[.t image cget small -$i] - } + } return $result } -cleanup { destroy .t @@ -243,7 +243,7 @@ test textImage-1.18 {basic configure options} -setup { .t image create end -image small foreach {option value} {align top padx 5 pady 7 image large name none} { .t image configure small -$option $value - } + } update .t image configure small } -cleanup { @@ -309,7 +309,7 @@ test textImage-3.1 {image change propagation} -setup { vary configure -width $i -height $i update lappend result $i:[.t bbox vary] - } + } return $result } -cleanup { destroy .t diff --git a/tests/textIndex.test b/tests/textIndex.test index 612ade1..310db6a 100644 --- a/tests/textIndex.test +++ b/tests/textIndex.test @@ -17,7 +17,7 @@ pack .t -expand 1 -fill both update .t debug on wm geometry . {} - + # The statements below reset the main window; it's needed if the window # manager is mwm to make mwm forget about a previous minimum size setting. @@ -74,7 +74,7 @@ test textIndex-1.9 {TkTextMakeByteIndex: shortcut for 0} {testtext} { testtext .t byteindex 3 80 } {3.5 5} test textIndex-1.10 {TkTextMakeByteIndex: verify index is in range} {testtext} { - # for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) + # for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) # one segment testtext .t byteindex 3 5 @@ -84,7 +84,7 @@ test textIndex-1.11 {TkTextMakeByteIndex: verify index is in range} {testtext} { # index += segPtr->size # Multiple segments, make sure add segment size to index. - .t mark set foo 3.2 + .t mark set foo 3.2 set x [testtext .t byteindex 3 7] .t mark unset foo set x @@ -117,7 +117,7 @@ test textIndex-1.16 {TkTextMakeByteIndex: UTF-8 characters} {testtext} { } {5.18 20} test textIndex-1.17 {TkTextMakeByteIndex: prevent splitting UTF-8 character} \ {testtext} { - # ((byteIndex > index) && (segPtr->typePtr == &tkTextCharType)) + # ((byteIndex > index) && (segPtr->typePtr == &tkTextCharType)) # Wrong answer would be \xb9 (the 2nd byte of UTF rep of 0x4e4f). set x [testtext .t byteindex 5 2] @@ -125,7 +125,7 @@ test textIndex-1.17 {TkTextMakeByteIndex: prevent splitting UTF-8 character} \ } {{5.2 4} y} test textIndex-1.18 {TkTextMakeByteIndex: prevent splitting UTF-8 character} \ {testtext} { - # ((byteIndex > index) && (segPtr->typePtr == &tkTextCharType)) + # ((byteIndex > index) && (segPtr->typePtr == &tkTextCharType)) testtext .t byteindex 5 1 .t get insert } "\u4e4f" @@ -168,7 +168,7 @@ test textIndex-2.9 {TkTextMakeCharIndex: verify index is in range} { # for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) # Multiple segments, make sure add segment size to index. - .t mark set foo 3.2 + .t mark set foo 3.2 set x [.t index 3.7] .t mark unset foo set x @@ -439,7 +439,7 @@ test textIndex-12.5 {TkTextIndexForwChars: find index} { test textIndex-12.6 {TkTextIndexForwChars: find index} { # for ( ; segPtr != NULL; segPtr = segPtr->nextPtr) # border condition: segPtr == NULL -> beginning of next line - + .t index {2.3 + 11 chars} } 3.0 test textIndex-12.7 {TkTextIndexForwChars: find index} { @@ -458,7 +458,7 @@ test textIndex-12.9 {TkTextIndexForwChars: find index} { .t image create 2.4 -image textimage set x [.t get {2.3 + 3 chars}] .t delete 2.4 - set x + set x } "f" test textIndex-12.10 {TkTextIndexForwChars: find index} { # dstPtr->byteIndex += segPtr->size - byteOffset @@ -588,11 +588,11 @@ test textIndex-14.11 {TkTextIndexBackChars: move to previous segment} { set x } 2.9 test textIndex-14.12 {TkTextIndexBackChars: move to previous line} { - # (lineIndex == 0) + # (lineIndex == 0) .t index {1.5 - 10 chars} } 1.0 test textIndex-14.13 {TkTextIndexBackChars: move to previous line} { - # not (lineIndex == 0) + # not (lineIndex == 0) .t index {2.5 - 10 chars} } 1.2 test textIndex-14.14 {TkTextIndexBackChars: move to previous line} { diff --git a/tests/textMark.test b/tests/textMark.test index bbf226e..043ff82 100644 --- a/tests/textMark.test +++ b/tests/textMark.test @@ -27,7 +27,7 @@ Line 4 bOy GIrl .#@? x_yz !@#$% Line 7" - + # The statements below reset the main window; it's needed if the window # manager is mwm to make mwm forget about a previous minimum size setting. diff --git a/tests/textTag.test b/tests/textTag.test index d85037a..04a4b30 100644 --- a/tests/textTag.test +++ b/tests/textTag.test @@ -11,19 +11,30 @@ namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +set textWidgetFont {Courier 12} +set bigFont {Courier 24} + +# what is needed is a font that is both fixed-width and featuring a +# specific size because in some tests (that will be constrained by +# haveFontSizes), a tag applying the $bigFont will be set to some +# characters, which action has the effect of changing what character +# is under the mouse pointer, which is the purpose of the tests +testConstraint haveFontSizes [expr { + [font metrics $textWidgetFont -fixed] && + [font actual $textWidgetFont -size] == 12 && + [font metrics $bigFont -fixed] && + [font actual $bigFont -size] == 24 } +] + destroy .t text .t -width 20 -height 10 -testConstraint haveCourier12 [expr {[catch { - .t configure -font {Courier 12} -}] == 0}] pack .t -expand 1 -fill both update .t debug on wm geometry . {} -set bigFont {Helvetica 24} - + # The statements below reset the main window; it's needed if the window # manager is mwm, to make mwm forget about a previous minimum size setting. @@ -40,130 +51,96 @@ bOy GIrl .#@? x_yz !@#$% Line 7" -test textTag-1.1 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.1 {tag configuration options} -body { .t tag configure x -background #012345 .t tag cget x -background } -cleanup { .t tag configure x -background [lindex [.t tag configure x -background] 3] } -result {#012345} -test textTag-1.2 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.2 {configuration options} -body { .t tag configure x -background non-existent } -cleanup { .t tag configure x -background [lindex [.t tag configure x -background] 3] } -returnCodes error -result {unknown color name "non-existent"} -test textTag-1.3 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.3 {tag configuration options} -body { .t tag configure x -bgstipple gray50 .t tag cget x -bgstipple } -cleanup { .t tag configure x -bgstipple [lindex [.t tag configure x -bgstipple] 3] } -result {gray50} -test textTag-1.4 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.4 {configuration options} -body { .t tag configure x -bgstipple badStipple } -cleanup { .t tag configure x -bgstipple [lindex [.t tag configure x -bgstipple] 3] } -returnCodes error -result {bitmap "badStipple" not defined} -test textTag-1.5 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.5 {tag configuration options} -body { .t tag configure x -borderwidth 2 .t tag cget x -borderwidth } -cleanup { .t tag configure x -borderwidth [lindex [.t tag configure x -borderwidth] 3] } -result {2} -test textTag-1.6 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.6 {configuration options} -body { .t tag configure x -borderwidth 46q } -cleanup { .t tag configure x -borderwidth [lindex [.t tag configure x -borderwidth] 3] } -returnCodes error -result {bad screen distance "46q"} -test textTag-1.7 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.7 {tag configuration options} -body { .t tag configure x -fgstipple gray25 .t tag cget x -fgstipple } -cleanup { .t tag configure x -fgstipple [lindex [.t tag configure x -fgstipple] 3] } -result {gray25} -test textTag-1.8 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.8 {configuration options} -body { .t tag configure x -fgstipple bogus } -cleanup { .t tag configure x -fgstipple [lindex [.t tag configure x -fgstipple] 3] } -returnCodes error -result {bitmap "bogus" not defined} -test textTag-1.9 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.9 {tag configuration options} -body { .t tag configure x -font fixed .t tag cget x -font } -cleanup { .t tag configure x -font [lindex [.t tag configure x -font] 3] } -result {fixed} -test textTag-1.10 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.10 {tag configuration options} -body { .t tag configure x -foreground #001122 .t tag cget x -foreground } -cleanup { .t tag configure x -foreground [lindex [.t tag configure x -foreground] 3] } -result {#001122} -test textTag-1.11 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.11 {configuration options} -body { .t tag configure x -foreground {silly color} } -cleanup { .t tag configure x -foreground [lindex [.t tag configure x -foreground] 3] } -returnCodes error -result {unknown color name "silly color"} -test textTag-1.12 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.12 {tag configuration options} -body { .t tag configure x -justify left .t tag cget x -justify } -cleanup { .t tag configure x -justify [lindex [.t tag configure x -justify] 3] } -result {left} -test textTag-1.13 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.13 {configuration options} -body { .t tag configure x -justify middle } -cleanup { .t tag configure x -justify [lindex [.t tag configure x -justify] 3] } -returnCodes error -result {bad justification "middle": must be left, right, or center} -test textTag-1.14 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.14 {tag configuration options} -body { .t tag configure x -lmargin1 10 .t tag cget x -lmargin1 } -cleanup { .t tag configure x -lmargin1 [lindex [.t tag configure x -lmargin1] 3] } -result {10} -test textTag-1.15 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.15 {configuration options} -body { .t tag configure x -lmargin1 bad } -cleanup { .t tag configure x -lmargin1 [lindex [.t tag configure x -lmargin1] 3] } -returnCodes error -result {bad screen distance "bad"} -test textTag-1.16 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.16 {tag configuration options} -body { .t tag configure x -lmargin2 10 .t tag cget x -lmargin2 } -cleanup { .t tag configure x -lmargin2 [lindex [.t tag configure x -lmargin2] 3] } -result {10} -test textTag-1.17 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.17 {configuration options} -body { .t tag configure x -lmargin2 bad } -cleanup { .t tag configure x -lmargin2 [lindex [.t tag configure x -lmargin2] 3] @@ -179,32 +156,24 @@ test textTag-1.17b {configuration options} -body { } -cleanup { .t tag configure x -lmargincolor [lindex [.t tag configure x -lmargincolor] 3] } -returnCodes error -result {unknown color name "non-existent"} -test textTag-1.18 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.18 {tag configuration options} -body { .t tag configure x -offset 2 .t tag cget x -offset } -cleanup { .t tag configure x -offset [lindex [.t tag configure x -offset] 3] } -result {2} -test textTag-1.19 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.19 {configuration options} -body { .t tag configure x -offset 100xyz } -cleanup { .t tag configure x -offset [lindex [.t tag configure x -offset] 3] } -returnCodes error -result {bad screen distance "100xyz"} -test textTag-1.20 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.20 {tag configuration options} -body { .t tag configure x -overstrike on .t tag cget x -overstrike } -cleanup { .t tag configure x -overstrike [lindex [.t tag configure x -overstrike] 3] } -result {on} -test textTag-1.21 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.21 {configuration options} -body { .t tag configure x -overstrike stupid } -cleanup { .t tag configure x -overstrike [lindex [.t tag configure x -overstrike] 3] @@ -220,32 +189,24 @@ test textTag-1.21b {configuration options} -body { } -cleanup { .t tag configure x -overstrikefg [lindex [.t tag configure x -overstrikefg] 3] } -returnCodes error -result {unknown color name "stupid"} -test textTag-1.22 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.22 {tag configuration options} -body { .t tag configure x -relief raised .t tag cget x -relief } -cleanup { .t tag configure x -relief [lindex [.t tag configure x -relief] 3] } -result {raised} -test textTag-1.23 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.23 {configuration options} -body { .t tag configure x -relief stupid } -cleanup { .t tag configure x -relief [lindex [.t tag configure x -relief] 3] } -returnCodes error -result {bad relief "stupid": must be flat, groove, raised, ridge, solid, or sunken} -test textTag-1.24 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.24 {tag configuration options} -body { .t tag configure x -rmargin 10 .t tag cget x -rmargin } -cleanup { .t tag configure x -rmargin [lindex [.t tag configure x -rmargin] 3] } -result {10} -test textTag-1.25 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.25 {configuration options} -body { .t tag configure x -rmargin bad } -cleanup { .t tag configure x -rmargin [lindex [.t tag configure x -rmargin] 3] @@ -283,77 +244,57 @@ test textTag-1.25f {configuration options} -body { } -cleanup { .t tag configure x -selectforeground [lindex [.t tag configure x -selectforeground] 3] } -returnCodes error -result {unknown color name "non-existent"} -test textTag-1.26 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.26 {tag configuration options} -body { .t tag configure x -spacing1 10 .t tag cget x -spacing1 } -cleanup { .t tag configure x -spacing1 [lindex [.t tag configure x -spacing1] 3] } -result {10} -test textTag-1.27 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.27 {configuration options} -body { .t tag configure x -spacing1 bad } -cleanup { .t tag configure x -spacing1 [lindex [.t tag configure x -spacing1] 3] } -returnCodes error -result {bad screen distance "bad"} -test textTag-1.28 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.28 {tag configuration options} -body { .t tag configure x -spacing2 10 .t tag cget x -spacing2 } -cleanup { .t tag configure x -spacing2 [lindex [.t tag configure x -spacing2] 3] } -result {10} -test textTag-1.29 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.29 {configuration options} -body { .t tag configure x -spacing2 bad } -cleanup { .t tag configure x -spacing2 [lindex [.t tag configure x -spacing2] 3] } -returnCodes error -result {bad screen distance "bad"} -test textTag-1.30 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.30 {tag configuration options} -body { .t tag configure x -spacing3 10 .t tag cget x -spacing3 } -cleanup { .t tag configure x -spacing3 [lindex [.t tag configure x -spacing3] 3] } -result {10} -test textTag-1.31 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.31 {configuration options} -body { .t tag configure x -spacing3 bad } -cleanup { .t tag configure x -spacing3 [lindex [.t tag configure x -spacing3] 3] } -returnCodes error -result {bad screen distance "bad"} -test textTag-1.32 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.32 {tag configuration options} -body { .t tag configure x -tabs {10 20 30} .t tag cget x -tabs } -cleanup { .t tag configure x -tabs [lindex [.t tag configure x -tabs] 3] } -result {10 20 30} -test textTag-1.33 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.33 {configuration options} -body { .t tag configure x -tabs {10 fork} } -cleanup { .t tag configure x -tabs [lindex [.t tag configure x -tabs] 3] } -returnCodes error -result {bad tab alignment "fork": must be left, right, center, or numeric} -test textTag-1.34 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.34 {tag configuration options} -body { .t tag configure x -underline no .t tag cget x -underline } -cleanup { .t tag configure x -underline [lindex [.t tag configure x -underline] 3] } -result {no} -test textTag-1.35 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.35 {configuration options} -body { .t tag configure x -underline stupid } -cleanup { .t tag configure x -underline [lindex [.t tag configure x -underline] 3] @@ -371,43 +312,29 @@ test textTag-1.37 {configuration options} -body { } -returnCodes error -result {unknown color name "stupid"} -test textTag-2.1 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -body { +test textTag-2.1 {TkTextTagCmd - "add" option} -body { .t tag } -returnCodes error -result {wrong # args: should be ".t tag option ?arg ...?"} -test textTag-2.2 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -body { +test textTag-2.2 {TkTextTagCmd - "add" option} -body { .t tag gorp } -returnCodes error -result {bad tag option "gorp": must be add, bind, cget, configure, delete, lower, names, nextrange, prevrange, raise, ranges, or remove} -test textTag-2.3 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -body { +test textTag-2.3 {TkTextTagCmd - "add" option} -body { .t tag add foo } -returnCodes error -result {wrong # args: should be ".t tag add tagName index1 ?index2 index1 index2 ...?"} -test textTag-2.4 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -body { +test textTag-2.4 {TkTextTagCmd - "add" option} -body { .t tag add x gorp } -returnCodes error -result {bad text index "gorp"} -test textTag-2.5 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -body { +test textTag-2.5 {TkTextTagCmd - "add" option} -body { .t tag add x 1.2 gorp } -returnCodes error -result {bad text index "gorp"} -test textTag-2.6 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -setup { +test textTag-2.6 {TkTextTagCmd - "add" option} -setup { .t tag delete sel } -body { .t tag add sel 3.2 3.4 .t tag add sel 3.2 3.0 .t tag ranges sel } -result {3.2 3.4} -test textTag-2.7 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -setup { +test textTag-2.7 {TkTextTagCmd - "add" option} -setup { .t tag delete x } -body { .t tag add x 1.0 1.end @@ -415,9 +342,7 @@ test textTag-2.7 {TkTextTagCmd - "add" option} -constraints { } -cleanup { .t tag delete x } -result {1.0 1.6} -test textTag-2.8 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -setup { +test textTag-2.8 {TkTextTagCmd - "add" option} -setup { .t tag remove x 1.0 end } -body { .t tag add x 1.2 @@ -425,9 +350,7 @@ test textTag-2.8 {TkTextTagCmd - "add" option} -constraints { } -cleanup { .t tag delete x } -result {1.2 1.3} -test textTag-2.9 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -setup { +test textTag-2.9 {TkTextTagCmd - "add" option} -setup { destroy .t.e } -body { entry .t.e @@ -439,9 +362,7 @@ test textTag-2.9 {TkTextTagCmd - "add" option} -constraints { } -cleanup { destroy .t.e } -result 34 -test textTag-2.10 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -setup { +test textTag-2.10 {TkTextTagCmd - "add" option} -setup { destroy .t.e } -body { entry .t.e @@ -454,23 +375,19 @@ test textTag-2.10 {TkTextTagCmd - "add" option} -constraints { } -cleanup { destroy .t.e } -result {Text} -test textTag-2.11 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -body { +test textTag-2.11 {TkTextTagCmd - "add" option} -body { .t tag remove sel 1.0 end .t tag add sel 1.1 1.5 2.4 3.1 4.2 4.4 .t tag ranges sel } -result {1.1 1.5 2.4 3.1 4.2 4.4} -test textTag-2.12 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -body { +test textTag-2.12 {TkTextTagCmd - "add" option} -body { .t tag remove sel 1.0 end .t tag add sel 1.1 1.5 2.4 .t tag ranges sel } -cleanup { .t tag remove sel 1.0 end } -result {1.1 1.5 2.4 2.5} -test textTag-2.14 {tag add before -startline - Bug 1615425} haveCourier12 { +test textTag-2.14 {tag add before -startline - Bug 1615425} -body { text .tt for {set i 1} {$i <10} {incr i} { .tt insert end "Line $i\n" @@ -482,54 +399,40 @@ test textTag-2.14 {tag add before -startline - Bug 1615425} haveCourier12 { .tt tag add mytag 1.0 1.end destroy .ptt .tt set res 1 -} {1} +} -result {1} -test textTag-3.1 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.1 {TkTextTagCmd - "bind" option} -body { .t tag bind } -returnCodes error -result {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"} -test textTag-3.2 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.2 {TkTextTagCmd - "bind" option} -body { .t tag bind 1 2 3 4 } -returnCodes error -result {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"} -test textTag-3.3 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.3 {TkTextTagCmd - "bind" option} -body { .t tag bind x <Enter> script1 .t tag bind x <Enter> } -cleanup { .t tag delete x } -result {script1} -test textTag-3.4 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.4 {TkTextTagCmd - "bind" option} -body { .t tag bind x <Gorp> script2 } -returnCodes error -result {bad event type or keysym "Gorp"} -test textTag-3.5 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.5 {TkTextTagCmd - "bind" option} -body { .t tag delete x .t tag bind x <Enter> script1 .t tag bind x <FocusIn> script2 } -cleanup { .t tag delete x } -returnCodes error -result {requested illegal events; only key, button, motion, enter, leave, and virtual events may be used} -test textTag-3.6 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.6 {TkTextTagCmd - "bind" option} -body { .t tag delete x .t tag bind x <Enter> script1 - catch {.t tag bind x <FocusIn> script2} + catch {.t tag bind x <FocusIn> script2} .t tag bind x } -cleanup { .t tag delete x } -result {<Enter>} -test textTag-3.7 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.7 {TkTextTagCmd - "bind" option} -body { .t tag delete x .t tag bind x <Enter> script1 .t tag bind x <Leave> script2 @@ -538,9 +441,7 @@ test textTag-3.7 {TkTextTagCmd - "bind" option} -constraints { } -cleanup { .t tag delete x } -result {{<Enter> <Leave> a} script1 xyzzy} -test textTag-3.8 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.8 {TkTextTagCmd - "bind" option} -body { .t tag delete x .t tag bind x <Enter> script1 .t tag bind x <Enter> +script2 @@ -549,17 +450,13 @@ test textTag-3.8 {TkTextTagCmd - "bind" option} -constraints { .t tag delete x } -result {script1 script2} -test textTag-3.9 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.9 {TkTextTagCmd - "bind" option} -body { .t tag delete x .t tag bind x <Enter> } -cleanup { .t tag delete x } -returnCodes ok -result {} -test textTag-3.10 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.10 {TkTextTagCmd - "bind" option} -body { .t tag delete x .t tag bind x < } -cleanup { @@ -567,30 +464,20 @@ test textTag-3.10 {TkTextTagCmd - "bind" option} -constraints { } -returnCodes error -result {no event type or button # or keysym} -test textTag-4.1 {TkTextTagCmd - "cget" option} -constraints { - haveCourier12 -} -body { +test textTag-4.1 {TkTextTagCmd - "cget" option} -body { .t tag cget a } -returnCodes error -result {wrong # args: should be ".t tag cget tagName option"} -test textTag-4.2 {TkTextTagCmd - "cget" option} -constraints { - haveCourier12 -} -body { +test textTag-4.2 {TkTextTagCmd - "cget" option} -body { .t tag cget a b c } -returnCodes error -result {wrong # args: should be ".t tag cget tagName option"} -test textTag-4.3 {TkTextTagCmd - "cget" option} -constraints { - haveCourier12 -} -body { +test textTag-4.3 {TkTextTagCmd - "cget" option} -body { .t tag delete foo .t tag cget foo bar } -returnCodes error -result {tag "foo" isn't defined in text widget} -test textTag-4.4 {TkTextTagCmd - "cget" option} -constraints { - haveCourier12 -} -body { +test textTag-4.4 {TkTextTagCmd - "cget" option} -body { .t tag cget sel bogus } -returnCodes error -result {unknown option "bogus"} -test textTag-4.5 {TkTextTagCmd - "cget" option} -constraints { - haveCourier12 -} -body { +test textTag-4.5 {TkTextTagCmd - "cget" option} -body { .t tag delete x .t tag configure x -background red .t tag cget x -background @@ -599,26 +486,18 @@ test textTag-4.5 {TkTextTagCmd - "cget" option} -constraints { } -result {red} -test textTag-5.1 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.1 {TkTextTagCmd - "configure" option} -body { .t tag configure } -returnCodes error -result {wrong # args: should be ".t tag configure tagName ?-option? ?value? ?-option value ...?"} -test textTag-5.2 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.2 {TkTextTagCmd - "configure" option} -body { .t tag configure x -foo } -returnCodes error -result {unknown option "-foo"} -test textTag-5.3 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.3 {TkTextTagCmd - "configure" option} -body { .t tag configure x -background red -underline } -cleanup { .t tag delete x } -returnCodes error -result {value for "-underline" missing} -test textTag-5.4 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.4 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -underline yes .t tag configure x -underline @@ -632,9 +511,7 @@ test textTag-5.4a {TkTextTagCmd - "configure" option} -body { } -cleanup { .t tag delete x } -result {-underlinefg {} {} {} lightgreen} -test textTag-5.5 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.5 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -overstrike on .t tag cget x -overstrike @@ -648,58 +525,44 @@ test textTag-5.5a {TkTextTagCmd - "configure" option} -body { } -cleanup { .t tag delete x } -result {-overstrikefg {} {} {} lightgreen} -test textTag-5.6 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.6 {TkTextTagCmd - "configure" option} -body { .t tag configure x -overstrike foo } -cleanup { .t tag delete x } -returnCodes error -result {expected boolean value but got "foo"} -test textTag-5.7 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.7 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -underline stupid } -cleanup { .t tag delete x } -returnCodes error -result {expected boolean value but got "stupid"} -test textTag-5.8 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.8 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -justify left .t tag configure x -justify } -cleanup { .t tag delete x } -result {-justify {} {} {} left} -test textTag-5.9 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.9 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -justify bogus } -cleanup { .t tag delete x } -returnCodes error -result {bad justification "bogus": must be left, right, or center} -test textTag-5.10 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.10 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -justify fill } -cleanup { .t tag delete x } -returnCodes error -result {bad justification "fill": must be left, right, or center} -test textTag-5.11 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.11 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -offset 2 .t tag configure x -offset } -cleanup { .t tag delete x } -result {-offset {} {} {} 2} -test textTag-5.12 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.12 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -offset 1.0q } -cleanup { @@ -718,17 +581,13 @@ test textTag-5.13 {TkTextTagCmd - "configure" option} -body { {-rmargin {} {} {} 5} \ {-lmargincolor {} {} {} darkblue} {-rmargincolor {} {} {} lightgreen} \ ] -test textTag-5.14 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.14 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -lmargin1 2.0x } -cleanup { .t tag delete x } -returnCodes error -result {bad screen distance "2.0x"} -test textTag-5.15 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.15 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -lmargin2 gorp } -cleanup { @@ -740,9 +599,7 @@ test textTag-5.15a {TkTextTagCmd - "configure" option} -body { } -cleanup { .t tag delete x } -returnCodes error -result {unknown color name "rainbow"} -test textTag-5.16 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.16 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -rmargin 140.1.1 } -cleanup { @@ -755,9 +612,7 @@ test textTag-5.16a {TkTextTagCmd - "configure" option} -body { .t tag delete x } -returnCodes error -result {unknown color name "rainbow"} .t tag delete x -test textTag-5.17 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.17 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -spacing1 2 -spacing2 4 -spacing3 6 list [.t tag configure x -spacing1] [.t tag configure x -spacing2] \ @@ -765,33 +620,25 @@ test textTag-5.17 {TkTextTagCmd - "configure" option} -constraints { } -cleanup { .t tag delete x } -result {{-spacing1 {} {} {} 2} {-spacing2 {} {} {} 4} {-spacing3 {} {} {} 6}} -test textTag-5.18 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.18 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -spacing1 2.0x } -cleanup { .t tag delete x } -returnCodes error -result {bad screen distance "2.0x"} -test textTag-5.19 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.19 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -spacing1 lousy } -cleanup { .t tag delete x } -returnCodes error -result {bad screen distance "lousy"} -test textTag-5.20 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.20 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -spacing1 4.2.3 } -cleanup { .t tag delete x } -returnCodes error -result {bad screen distance "4.2.3"} -test textTag-5.21 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.21 {TkTextTagCmd - "configure" option} -body { .t configure -selectborderwidth 2 -selectforeground blue \ -selectbackground black .t tag configure sel -borderwidth 4 -foreground green -background yellow @@ -801,9 +648,7 @@ test textTag-5.21 {TkTextTagCmd - "configure" option} -constraints { } return $x } -result {4 green yellow} -test textTag-5.22 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.22 {TkTextTagCmd - "configure" option} -body { .t configure -selectborderwidth 20 .t tag configure sel -borderwidth {} .t cget -selectborderwidth @@ -855,19 +700,13 @@ test textTag-5.24 {TkTextTagCmd - "configure" option} -body { return $x } -result {yellow blue red white} -test textTag-6.1 {TkTextTagCmd - "delete" option} -constraints { - haveCourier12 -} -body { +test textTag-6.1 {TkTextTagCmd - "delete" option} -body { .t tag delete } -returnCodes error -result {wrong # args: should be ".t tag delete tagName ?tagName ...?"} -test textTag-6.2 {TkTextTagCmd - "delete" option} -constraints { - haveCourier12 -} -body { +test textTag-6.2 {TkTextTagCmd - "delete" option} -body { .t tag delete zork } -returnCodes ok -result {} -test textTag-6.3 {TkTextTagCmd - "delete" option} -constraints { - haveCourier12 -} -setup { +test textTag-6.3 {TkTextTagCmd - "delete" option} -setup { .t tag delete {*}[.t tag names] } -body { .t tag config x -background black @@ -878,9 +717,7 @@ test textTag-6.3 {TkTextTagCmd - "delete" option} -constraints { } -cleanup { .t tag delete x } -result {sel x} -test textTag-6.4 {TkTextTagCmd - "delete" option} -constraints { - haveCourier12 -} -setup { +test textTag-6.4 {TkTextTagCmd - "delete" option} -setup { .t tag delete {*}[.t tag names] } -body { .t tag config x -background black @@ -889,9 +726,7 @@ test textTag-6.4 {TkTextTagCmd - "delete" option} -constraints { eval .t tag delete [.t tag names] .t tag names } -result {sel} -test textTag-6.5 {TkTextTagCmd - "delete" option} -constraints { - haveCourier12 -} -body { +test textTag-6.5 {TkTextTagCmd - "delete" option} -body { .t tag bind x <Enter> foo .t tag delete x .t tag configure x -background black @@ -901,24 +736,16 @@ test textTag-6.5 {TkTextTagCmd - "delete" option} -constraints { } -result {} -test textTag-7.1 {TkTextTagCmd - "lower" option} -constraints { - haveCourier12 -} -body { +test textTag-7.1 {TkTextTagCmd - "lower" option} -body { .t tag lower } -returnCodes error -result {wrong # args: should be ".t tag lower tagName ?belowThis?"} -test textTag-7.2 {TkTextTagCmd - "lower" option} -constraints { - haveCourier12 -} -body { +test textTag-7.2 {TkTextTagCmd - "lower" option} -body { .t tag lower foo } -returnCodes error -result {tag "foo" isn't defined in text widget} -test textTag-7.3 {TkTextTagCmd - "lower" option} -constraints { - haveCourier12 -} -body { +test textTag-7.3 {TkTextTagCmd - "lower" option} -body { .t tag lower sel bar } -returnCodes error -result {tag "bar" isn't defined in text widget} -test textTag-7.4 {TkTextTagCmd - "lower" option} -constraints { - haveCourier12 -} -setup { +test textTag-7.4 {TkTextTagCmd - "lower" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -930,9 +757,7 @@ test textTag-7.4 {TkTextTagCmd - "lower" option} -constraints { } -cleanup { .t tag delete {*}[.t tag names] } -result {c sel a b d} -test textTag-7.5 {TkTextTagCmd - "lower" option} -constraints { - haveCourier12 -} -setup { +test textTag-7.5 {TkTextTagCmd - "lower" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -944,9 +769,7 @@ test textTag-7.5 {TkTextTagCmd - "lower" option} -constraints { } -cleanup { .t tag delete {*}[.t tag names] } -result {sel a d b c} -test textTag-7.6 {TkTextTagCmd - "lower" option} -constraints { - haveCourier12 -} -setup { +test textTag-7.6 {TkTextTagCmd - "lower" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -960,16 +783,12 @@ test textTag-7.6 {TkTextTagCmd - "lower" option} -constraints { } -result {sel b a c d} -test textTag-8.1 {TkTextTagCmd - "names" option} -constraints { - haveCourier12 -} -body { +test textTag-8.1 {TkTextTagCmd - "names" option} -body { .t tag names a b } -cleanup { .t tag delete {*}[.t tag names] } -returnCodes error -result {wrong # args: should be ".t tag names ?index?"} -test textTag-8.2 {TkTextTagCmd - "names" option} -constraints { - haveCourier12 -} -setup { +test textTag-8.2 {TkTextTagCmd - "names" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -980,9 +799,7 @@ test textTag-8.2 {TkTextTagCmd - "names" option} -constraints { } -cleanup { .t tag delete {*}[.t tag names] } -result {sel a b c d} -test textTag-8.3 {TkTextTagCmd - "names" option} -constraints { - haveCourier12 -} -setup { +test textTag-8.3 {TkTextTagCmd - "names" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -997,24 +814,16 @@ test textTag-8.3 {TkTextTagCmd - "names" option} -constraints { } -result {c {a b}} -test textTag-9.1 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -body { +test textTag-9.1 {TkTextTagCmd - "nextrange" option} -body { .t tag nextrange x } -returnCodes error -result {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"} -test textTag-9.2 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -body { +test textTag-9.2 {TkTextTagCmd - "nextrange" option} -body { .t tag nextrange x 1 2 3 } -returnCodes error -result {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"} -test textTag-9.3 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -body { +test textTag-9.3 {TkTextTagCmd - "nextrange" option} -body { .t tag nextrange foo 1.0 } -returnCodes ok -result {} -test textTag-9.4 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.4 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1022,9 +831,7 @@ test textTag-9.4 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -returnCodes error -result {bad text index "foo"} -test textTag-9.5 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.5 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1034,9 +841,7 @@ test textTag-9.5 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -returnCodes error -result {bad text index "bar"} -test textTag-9.6 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.6 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1046,9 +851,7 @@ test textTag-9.6 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.3 2.5} -test textTag-9.7 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.7 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1058,9 +861,7 @@ test textTag-9.7 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.3 2.5} -test textTag-9.8 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.8 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1070,9 +871,7 @@ test textTag-9.8 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.3 2.5} -test textTag-9.9 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.9 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1082,9 +881,7 @@ test textTag-9.9 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.9 3.1} -test textTag-9.10 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.10 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1094,9 +891,7 @@ test textTag-9.10 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {} -test textTag-9.11 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.11 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1106,9 +901,7 @@ test textTag-9.11 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.9 3.1} -test textTag-9.12 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.12 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1118,9 +911,7 @@ test textTag-9.12 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.9 3.1} -test textTag-9.13 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.13 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1130,9 +921,7 @@ test textTag-9.13 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {7.2 7.3} -test textTag-9.14 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.14 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1144,28 +933,20 @@ test textTag-9.14 {TkTextTagCmd - "nextrange" option} -constraints { } -result {} -test textTag-10.1 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -body { +test textTag-10.1 {TkTextTagCmd - "prevrange" option} -body { .t tag prevrange x } -returnCodes error -result {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"} -test textTag-10.2 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -body { +test textTag-10.2 {TkTextTagCmd - "prevrange" option} -body { .t tag prevrange x 1 2 3 } -returnCodes error -result {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"} -test textTag-10.3 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.3 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag prevrange foo end } -cleanup { .t tag delete x } -returnCodes ok -result {} -test textTag-10.4 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.4 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1175,9 +956,7 @@ test textTag-10.4 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -returnCodes error -result {bad text index "foo"} -test textTag-10.5 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.5 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1187,9 +966,7 @@ test textTag-10.5 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -returnCodes error -result {bad text index "bar"} -test textTag-10.6 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.6 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1199,9 +976,7 @@ test textTag-10.6 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {7.2 7.3} -test textTag-10.7 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.7 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1211,9 +986,7 @@ test textTag-10.7 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.3 2.5} -test textTag-10.8 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.8 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1223,9 +996,7 @@ test textTag-10.8 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.3 2.5} -test textTag-10.9 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.9 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1235,9 +1006,7 @@ test textTag-10.9 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.3 2.5} -test textTag-10.10 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.10 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1247,9 +1016,7 @@ test textTag-10.10 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {} -test textTag-10.11 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.11 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1259,9 +1026,7 @@ test textTag-10.11 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {} -test textTag-10.12 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.12 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1271,9 +1036,7 @@ test textTag-10.12 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.3 2.5} -test textTag-10.13 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.13 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1283,9 +1046,7 @@ test textTag-10.13 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.9 3.1} -test textTag-10.14 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.14 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1297,24 +1058,16 @@ test textTag-10.14 {TkTextTagCmd - "prevrange" option} -constraints { } -result {} -test textTag-11.1 {TkTextTagCmd - "raise" option} -constraints { - haveCourier12 -} -body { +test textTag-11.1 {TkTextTagCmd - "raise" option} -body { .t tag raise } -returnCodes error -result {wrong # args: should be ".t tag raise tagName ?aboveThis?"} -test textTag-11.2 {TkTextTagCmd - "raise" option} -constraints { - haveCourier12 -} -body { +test textTag-11.2 {TkTextTagCmd - "raise" option} -body { .t tag raise foo } -returnCodes error -result {tag "foo" isn't defined in text widget} -test textTag-11.3 {TkTextTagCmd - "raise" option} -constraints { - haveCourier12 -} -body { +test textTag-11.3 {TkTextTagCmd - "raise" option} -body { .t tag raise sel bar } -returnCodes error -result {tag "bar" isn't defined in text widget} -test textTag-11.4 {TkTextTagCmd - "raise" option} -constraints { - haveCourier12 -} -setup { +test textTag-11.4 {TkTextTagCmd - "raise" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -1326,9 +1079,7 @@ test textTag-11.4 {TkTextTagCmd - "raise" option} -constraints { } -cleanup { .t tag delete {*}[.t tag names] } -result {sel a b d c} -test textTag-11.5 {TkTextTagCmd - "raise" option} -constraints { - haveCourier12 -} -setup { +test textTag-11.5 {TkTextTagCmd - "raise" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -1340,9 +1091,7 @@ test textTag-11.5 {TkTextTagCmd - "raise" option} -constraints { } -cleanup { .t tag delete {*}[.t tag names] } -result {sel a b d c} -test textTag-11.6 {TkTextTagCmd - "raise" option} -constraints { - haveCourier12 -} -setup { +test textTag-11.6 {TkTextTagCmd - "raise" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -1356,20 +1105,14 @@ test textTag-11.6 {TkTextTagCmd - "raise" option} -constraints { } -result {sel b c a d} -test textTag-12.1 {TkTextTagCmd - "ranges" option} -constraints { - haveCourier12 -} -body { +test textTag-12.1 {TkTextTagCmd - "ranges" option} -body { .t tag ranges } -returnCodes error -result {wrong # args: should be ".t tag ranges tagName"} -test textTag-12.2 {TkTextTagCmd - "ranges" option} -constraints { - haveCourier12 -} -body { +test textTag-12.2 {TkTextTagCmd - "ranges" option} -body { .t tag delete x .t tag ranges x } -result {} -test textTag-12.3 {TkTextTagCmd - "ranges" option} -constraints { - haveCourier12 -} -setup { +test textTag-12.3 {TkTextTagCmd - "ranges" option} -setup { .t tag delete x } -body { .t tag add x 2.2 @@ -1379,9 +1122,7 @@ test textTag-12.3 {TkTextTagCmd - "ranges" option} -constraints { } -cleanup { .t tag delete x } -result {2.2 2.3 2.7 4.6 5.2 5.5} -test textTag-12.4 {TkTextTagCmd - "ranges" option} -constraints { - haveCourier12 -} -setup { +test textTag-12.4 {TkTextTagCmd - "ranges" option} -setup { .t tag delete x } -body { .t tag add x 1.0 3.0 @@ -1392,14 +1133,10 @@ test textTag-12.4 {TkTextTagCmd - "ranges" option} -constraints { } -result {1.0 3.0 4.0 8.0} -test textTag-13.1 {TkTextTagCmd - "remove" option} -constraints { - haveCourier12 -} -body { +test textTag-13.1 {TkTextTagCmd - "remove" option} -body { .t tag remove } -returnCodes error -result {wrong # args: should be ".t tag remove tagName index1 ?index2 index1 index2 ...?"} -test textTag-13.2 {TkTextTagCmd - "remove" option} -constraints { - haveCourier12 -} -setup { +test textTag-13.2 {TkTextTagCmd - "remove" option} -setup { .t tag delete x } -body { .t tag add x 2.2 2.11 @@ -1408,9 +1145,7 @@ test textTag-13.2 {TkTextTagCmd - "remove" option} -constraints { } -cleanup { .t tag delete x } -result {2.2 2.3 2.7 2.11} -test textTag-13.3 {TkTextTagCmd - "remove" option} -constraints { - haveCourier12 -} -setup { +test textTag-13.3 {TkTextTagCmd - "remove" option} -setup { destroy .t.e } -body { entry .t.e @@ -1426,7 +1161,7 @@ test textTag-13.3 {TkTextTagCmd - "remove" option} -constraints { } -result {Text} -test textTag-14.1 {SortTags} -constraints haveCourier12 -setup { +test textTag-14.1 {SortTags} -setup { .t tag delete a b c d } -body { foreach i {a b c d} { @@ -1437,7 +1172,7 @@ test textTag-14.1 {SortTags} -constraints haveCourier12 -setup { .t tag delete a b c d } -result {a b c d} .t tag delete a b c d -test textTag-14.2 {SortTags} -constraints haveCourier12 -setup { +test textTag-14.2 {SortTags} -setup { .t tag delete a b c d } -body { foreach i {a b c d} { @@ -1450,7 +1185,7 @@ test textTag-14.2 {SortTags} -constraints haveCourier12 -setup { } -cleanup { .t tag delete a b c d } -result {a b c d} -test textTag-14.3 {SortTags} -constraints haveCourier12 -setup { +test textTag-14.3 {SortTags} -setup { .t tag delete {*}[.t tag names] } -body { for {set i 0} {$i < 30} {incr i} { @@ -1460,7 +1195,7 @@ test textTag-14.3 {SortTags} -constraints haveCourier12 -setup { } -cleanup { .t tag delete {*}[.t tag names] } -result {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29} -test textTag-14.4 {SortTags} -constraints haveCourier12 -setup { +test textTag-14.4 {SortTags} -setup { .t tag delete {*}[.t tag names] } -body { for {set i 0} {$i < 30} {incr i} { @@ -1475,7 +1210,8 @@ test textTag-14.4 {SortTags} -constraints haveCourier12 -setup { } -result {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29} - +set curFont [.t cget -font] +set curWrap [.t cget -wrap] set c [.t bbox 2.1] set x1 [expr {[lindex $c 0] + [lindex $c 2]/2}] set y1 [expr {[lindex $c 1] + [lindex $c 3]/2}] @@ -1485,8 +1221,17 @@ set y2 [expr {[lindex $c 1] + [lindex $c 3]/2}] set c [.t bbox 4.3] set x3 [expr {[lindex $c 0] + [lindex $c 2]/2}] set y3 [expr {[lindex $c 1] + [lindex $c 3]/2}] +.t configure -font $textWidgetFont -wrap none +update +set c [.t bbox 2.1] +set x4 [expr [lindex $c 0] + [lindex $c 2]/2] +set y4 [expr [lindex $c 1] + [lindex $c 3]/2] +set c [.t bbox 3.2] +set x5 [expr [lindex $c 0] + [lindex $c 2]/2] +set y5 [expr [lindex $c 1] + [lindex $c 3]/2] +.t configure -font $curFont -wrap $curWrap -test textTag-15.1 {TkTextBindProc} -constraints haveCourier12 -setup { +test textTag-15.1 {TkTextBindProc} -setup { .t tag delete x y wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 @@ -1512,17 +1257,17 @@ test textTag-15.1 {TkTextBindProc} -constraints haveCourier12 -setup { bind .t <ButtonRelease> {} } -result {x-up up up y-up up} -test textTag-15.2 {TkTextBindProc} -constraints haveCourier12 -setup { +test textTag-15.2 {TkTextBindProc} -setup { .t tag delete x y wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 } -body { .t tag bind x <Enter> {lappend x x-enter} - .t tag bind x <ButtonPress> {lappend x x-down} + .t tag bind x <Button> {lappend x x-down} .t tag bind x <ButtonRelease> {lappend x x-up} .t tag bind x <Leave> {lappend x x-leave} .t tag bind y <Enter> {lappend x y-enter} - .t tag bind y <ButtonPress> {lappend x y-down} + .t tag bind y <Button> {lappend x y-down} .t tag bind y <ButtonRelease> {lappend x y-up} .t tag bind y <Leave> {lappend x y-leave} event gen .t <Motion> -x 0 -y 0 @@ -1541,18 +1286,18 @@ test textTag-15.2 {TkTextBindProc} -constraints haveCourier12 -setup { .t tag delete x y } -result {x-enter | x-down | | x-up x-leave y-enter} -test textTag-15.3 {TkTextBindProc} -constraints haveCourier12 -setup { +test textTag-15.3 {TkTextBindProc} -setup { .t tag delete x y wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 } -body { .t tag bind x <Enter> {lappend x x-enter} - .t tag bind x <Any-ButtonPress-1> {lappend x x-down} - .t tag bind x <Any-ButtonRelease-1> {lappend x x-up} + .t tag bind x <Button-1> {lappend x x-down} + .t tag bind x <ButtonRelease-1> {lappend x x-up} .t tag bind x <Leave> {lappend x x-leave} .t tag bind y <Enter> {lappend x y-enter} - .t tag bind y <Any-ButtonPress-1> {lappend x y-down} - .t tag bind y <Any-ButtonRelease-1> {lappend x y-up} + .t tag bind y <Button-1> {lappend x y-down} + .t tag bind y <ButtonRelease-1> {lappend x y-up} .t tag bind y <Leave> {lappend x y-leave} event gen .t <Motion> -x 0 -y 0 set x {} @@ -1575,9 +1320,7 @@ test textTag-15.3 {TkTextBindProc} -constraints haveCourier12 -setup { } -result {x-enter | x-down | | | x-up | x-leave y-enter} -test textTag-16.1 {TkTextPickCurrent procedure} -constraints { - haveCourier12 -} -setup { +test textTag-16.1 {TkTextPickCurrent procedure} -setup { .t tag delete {*}[.t tag names] wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 @@ -1599,26 +1342,26 @@ test textTag-16.1 {TkTextPickCurrent procedure} -constraints { } -result {2.1 3.2 3.2 3.2 3.2 3.2 4.3} test textTag-16.2 {TkTextPickCurrent procedure} -constraints { - haveCourier12 + haveFontSizes } -setup { .t tag delete {*}[.t tag names] wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 + .t configure -font $textWidgetFont -wrap none } -body { .t tag configure big -font $bigFont - event gen .t <ButtonRelease-1> -state 0x100 -x $x1 -y $y1 - event gen .t <Motion> -x $x2 -y $y2 + event gen .t <ButtonRelease-1> -state 0x100 -x $x4 -y $y4 + event gen .t <Motion> -x $x5 -y $y5 set x [.t index current] .t tag add big 3.0 update lappend x [.t index current] } -cleanup { .t tag delete big + .t configure -font $curFont -wrap $curWrap } -result {3.2 3.1} -test textTag-16.3 {TkTextPickCurrent procedure} -constraints { - haveCourier12 -} -setup { +test textTag-16.3 {TkTextPickCurrent procedure} -setup { foreach i {a b c d} { .t tag remove $i 1.0 end } @@ -1646,9 +1389,7 @@ test textTag-16.3 {TkTextPickCurrent procedure} -constraints { .t tag delete {*}[.t tag names] } -result {enter-a enter-b | leave-b enter-c | leave-a leave-c} -test textTag-16.4 {TkTextPickCurrent procedure} -constraints { - haveCourier12 -} -setup { +test textTag-16.4 {TkTextPickCurrent procedure} -setup { foreach i {a b c d} { .t tag remove $i 1.0 end } @@ -1676,65 +1417,71 @@ test textTag-16.4 {TkTextPickCurrent procedure} -constraints { } -result {enter-a enter-b enter-c | leave-c leave-b} test textTag-16.5 {TkTextPickCurrent procedure} -constraints { - haveCourier12 + haveFontSizes } -setup { foreach i {big a b c d} { .t tag remove $i 1.0 end } wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 + .t configure -font $textWidgetFont -wrap none } -body { .t tag configure big -font $bigFont - event gen .t <Motion> -x $x1 -y $y1 + event gen .t <Motion> -x $x4 -y $y4 .t tag bind a <Enter> {.t tag add big 3.0 3.2} .t tag add a 3.2 - event gen .t <Motion> -x $x2 -y $y2 + event gen .t <Motion> -x $x5 -y $y5 .t index current } -cleanup { .t tag delete a big + .t configure -font $curFont -wrap $curWrap } -result {3.2} test textTag-16.6 {TkTextPickCurrent procedure} -constraints { - haveCourier12 + haveFontSizes } -setup { foreach i {big a b c d} { .t tag remove $i 1.0 end } wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 + .t configure -font $textWidgetFont -wrap none } -body { .t tag configure big -font $bigFont - event gen .t <Motion> -x $x1 -y $y1 + event gen .t <Motion> -x $x4 -y $y4 .t tag bind a <Enter> {.t tag add big 3.0 3.2} .t tag add a 3.2 - event gen .t <Motion> -x $x2 -y $y2 + event gen .t <Motion> -x $x5 -y $y5 update .t index current } -cleanup { .t tag delete a big + .t configure -font $curFont -wrap $curWrap } -result {3.1} test textTag-16.7 {TkTextPickCurrent procedure} -constraints { - haveCourier12 + haveFontSizes } -setup { foreach i {big a b c d} { .t tag remove $i 1.0 end } wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 + .t configure -font $textWidgetFont -wrap none } -body { .t tag configure big -font $bigFont .t tag bind a <Enter> {.t tag add big 3.0 3.2} .t tag add a 3.2 - event gen .t <Motion> -x $x1 -y $y1 + event gen .t <Motion> -x $x4 -y $y4 .t tag bind a <Leave> {.t tag add big 3.0 3.2} .t tag add a 2.1 - event gen .t <Motion> -x $x2 -y $y2 + event gen .t <Motion> -x $x5 -y $y5 update .t index current } -cleanup { .t tag delete a big + .t configure -font $curFont -wrap $curWrap } -result {3.1} @@ -1758,7 +1505,7 @@ test textTag-18.1 {TkTextPickCurrent tag bindings} -setup { -highlightthickness 10 -pady 2 pack .t update ; # map the window, otherwise -warp can't be done - + .t insert end " Tag here " TAG " no tag here" .t tag configure TAG -borderwidth 4 -relief raised .t tag bind TAG <Enter> {lappend res "%x %y tag-Enter"} diff --git a/tests/textWind.test b/tests/textWind.test index 938357b..7e2d315 100644 --- a/tests/textWind.test +++ b/tests/textWind.test @@ -42,7 +42,7 @@ wm deiconify . # This update is needed on MacOS to make sure that the window is mapped # when the tests begin. -update +update set bw [.t cget -borderwidth] set px [.t cget -padx] diff --git a/tests/tk.test b/tests/tk.test index 748a6cf..c5c475e 100644 --- a/tests/tk.test +++ b/tests/tk.test @@ -10,6 +10,8 @@ eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test +testConstraint testprintf [llength [info command testprintf]] + test tk-1.1 {tk command: general} -body { tk } -returnCodes error -result {wrong # args: should be "tk subcommand ?arg ...?"} @@ -177,6 +179,10 @@ test tk-7.2 {tk inactive reset in a safe interpreter} -body { ::safe::interpDelete foo } -returnCodes 1 -result {resetting the user inactivity timer is not allowed in a safe interpreter} +test tk-8.1 {Test for ticket [1cc44617e2], see if TCL_LL_MODIFIER works as expected on all platforms} -constraints testprintf -body { + testprintf -21474836480 +} -result {-21474836480 18446744052234715136} + # tests of [tk busy] in busy.test # cleanup diff --git a/tests/ttk/checkbutton.test b/tests/ttk/checkbutton.test index 15d365f..5e929de 100644 --- a/tests/ttk/checkbutton.test +++ b/tests/ttk/checkbutton.test @@ -56,7 +56,7 @@ test checkbutton-1.7 "Button destroyed by click" -body { pack .top.mb focus -force .top.mb update - event generate .top.mb <1> + event generate .top.mb <Button-1> event generate .top.mb <ButtonRelease-1> update ; # shall not trigger error invalid command name ".top.b" } -result {} diff --git a/tests/ttk/combobox.test b/tests/ttk/combobox.test index 45fe0fc..c14db9b 100644 --- a/tests/ttk/combobox.test +++ b/tests/ttk/combobox.test @@ -38,18 +38,18 @@ test combobox-2.3 "current -- change value" -body { .cb current } -result 1 -test combobox-2.4 "current -- value not in list" -body { +test combobox-2.4 "current -- value not in list" -body { .cb set "z" .cb current } -result -1 -test combobox-2.5 "current -- set to end index" -body { +test combobox-2.5 "current -- set to end index" -body { .cb configure -values [list a b c d e thelastone] .cb current end .cb get } -result thelastone -test combobox-2.6 "current -- set to unknown index" -body { +test combobox-2.6 "current -- set to unknown index" -body { .cb configure -values [list a b c d e] .cb current notanindex } -returnCodes error -result {Incorrect index notanindex} @@ -58,7 +58,7 @@ test combobox-2.end "Cleanup" -body { destroy .cb } test combobox-3 "Read postoffset value dynamically from current style" -body { ttk::combobox .cb -values [list a b c] -style "DerivedStyle.TCombobox" - pack .cb -expand true -fill both + pack .cb -expand true -fill both ttk::style configure DerivedStyle.TCombobox -postoffset [list 25 0 0 0] ttk::combobox::Post .cb expr {[winfo rootx .cb.popdown] - [winfo rootx .cb]} diff --git a/tests/ttk/entry.test b/tests/ttk/entry.test index 2e5f43c..26edca9 100644 --- a/tests/ttk/entry.test +++ b/tests/ttk/entry.test @@ -324,7 +324,25 @@ test entry-9.1 "Index range invariants" -setup { destroy .e } -test entry-10.1 {Bug [2830360fff] - Don't loose invalid at focus events} -setup { +test entry-10.1 {configuration option: "-placeholder"} -setup { + pack [ttk::entry .e] +} -body { + .e configure -placeholder {Some text} + .e cget -placeholder +} -cleanup { + destroy .e +} -result {Some text} + +test entry-10.2 {configuration option: "-placeholderforeground"} -setup { + pack [ttk::entry .e] +} -body { + .e configure -placeholder {Some text} -placeholderforeground red + .e cget -placeholderforeground +} -cleanup { + destroy .e +} -result {red} + +test entry-11.1 {Bug [2830360fff] - Don't loose invalid at focus events} -setup { pack [ttk::entry .e] update } -body { diff --git a/tests/ttk/image.test b/tests/ttk/image.test index a55f7f8..5e48d5c 100644 --- a/tests/ttk/image.test +++ b/tests/ttk/image.test @@ -23,7 +23,7 @@ test image-2.0 "Deletion of displayed image (label)" -setup { } -cleanup { destroy .ttk_image20 } -result {} - + test image-2.1 "Deletion of displayed image (checkbutton)" -setup { image create photo test.image -width 10 -height 10 } -body { diff --git a/tests/ttk/labelframe.test b/tests/ttk/labelframe.test index 28b4d2e..649c35f 100644 --- a/tests/ttk/labelframe.test +++ b/tests/ttk/labelframe.test @@ -70,7 +70,7 @@ test labelframe-3.6 "Destroy child slave" -body { # @@@ but seems to succeed if it's some other widget class. # @@@ I suspect a race condition; unable to track it down ATM. # -# @@@ FOLLOWUP: This *may* have been caused by a bug in ManagerIdleProc +# @@@ FOLLOWUP: This *may* have been caused by a bug in ManagerIdleProc # @@@ (see manager.c r1.11). There's still probably a race condition in here. # test labelframe-4.1 "Add nonchild slave" -body { diff --git a/tests/ttk/panedwindow.test b/tests/ttk/panedwindow.test index 7fe5c87..c1fc6ac 100644 --- a/tests/ttk/panedwindow.test +++ b/tests/ttk/panedwindow.test @@ -110,8 +110,8 @@ test panedwindow-2.end "Cleanup" -body { destroy .pw } # test panedwindow-3.0 "configure pane" -body { ttk::panedwindow .pw - .pw add [listbox .pw.lb1] - .pw add [listbox .pw.lb2] + .pw add [listbox .pw.lb1] + .pw add [listbox .pw.lb2] .pw pane 1 -weight 2 .pw pane 1 -weight } -result 2 @@ -253,7 +253,7 @@ test paned-propagation-setup "Setup." -body { frame .pw.f2 -width 100 -height 50 list [winfo reqwidth .pw.f1] [winfo reqheight .pw.f1] -} -result [list 100 50] +} -result [list 100 50] test paned-propagation-1 "Initial request size" -body { .pw add .pw.f1 diff --git a/tests/ttk/progressbar.test b/tests/ttk/progressbar.test index b9add86..7c888c6 100644 --- a/tests/ttk/progressbar.test +++ b/tests/ttk/progressbar.test @@ -82,4 +82,43 @@ test progressbar-end "Cleanup" -body { destroy .pb } +# check existence and default value of each non-core option of the widget +test progressbar-3.1 "progressbar non-core options" -setup { + set res {} + ttk::progressbar .defaultpb +} -body { + foreach option {-anchor -foreground -justify -style -text -wraplength \ + -length -maximum -mode -orient -phase -value -variable} { + lappend res [.defaultpb cget $option] + } + set res +} -cleanup { + unset res + destroy .defaultpb +} -result {w black left {} {} 0 100 100 determinate horizontal 0 0.0 {}} + +test progressbar-3.2 "TIP #442 options are taken into account" -setup { + set res {} + pack [ttk::progressbar .p -value 0 -maximum 50 -orient horizontal -mode determinate -length 500] + set thefont [font actual {Arial 10}] +} -body { + .p configure -anchor c -foreground blue -justify right \ + -text "TIP #442\noptions are now tested" -wraplength 100 + update + .p step 10 + .p configure -anchor e -font $thefont -foreground green -justify center \ + -text "Changing the value of each option\nfrom TIP #442" -wraplength 250 + update + .p step 20 + .p configure -orient vertical -text "Cannot be seen" + update + foreach option {-anchor -foreground -justify -text -wraplength} { + lappend res [list $option [.p cget $option]] + } + set res +} -cleanup { + unset res thefont + destroy .p +} -result {{-anchor e} {-foreground green} {-justify center} {-text {Cannot be seen}} {-wraplength 250}} + tcltest::cleanupTests diff --git a/tests/ttk/scrollbar.test b/tests/ttk/scrollbar.test index 903328e..443687a 100644 --- a/tests/ttk/scrollbar.test +++ b/tests/ttk/scrollbar.test @@ -18,8 +18,8 @@ test scrollbar-swapout-1 "Don't use core scrollbars on OSX..." \ } -body { ttk::scrollbar .sb -command "yadda" list [winfo class .sb] [.sb cget -command] -} -result [list TScrollbar yadda] -cleanup { - destroy .sb +} -result [list TScrollbar yadda] -cleanup { + destroy .sb } test scrollbar-swapout-2 "... regardless of whether -style ..." \ @@ -28,7 +28,7 @@ test scrollbar-swapout-2 "... regardless of whether -style ..." \ } -body { ttk::style layout Vertical.Custom.TScrollbar \ [ttk::style layout Vertical.TScrollbar] ; # See #1833339 - ttk::scrollbar .sb -command "yadda" -style Custom.TScrollbar + ttk::scrollbar .sb -command "yadda" -style Custom.TScrollbar list [winfo class .sb] [.sb cget -command] [.sb cget -style] } -result [list TScrollbar yadda Custom.TScrollbar] -cleanup { destroy .sb @@ -37,7 +37,7 @@ test scrollbar-swapout-2 "... regardless of whether -style ..." \ test scrollbar-swapout-3 "... or -class is specified." -constraints { coreScrollbar } -body { - ttk::scrollbar .sb -command "yadda" -class Custom.TScrollbar + ttk::scrollbar .sb -command "yadda" -class Custom.TScrollbar list [winfo class .sb] [.sb cget -command] } -result [list Custom.TScrollbar yadda] -cleanup { destroy .sb @@ -70,6 +70,92 @@ test scrollbar-1.3 "Change orientation" -body { expr {$h < $w} } -result 1 +test scrollbar-10.1.1 {<MouseWheel> event on scrollbar} -constraints {notAqua} -setup { + destroy .t .s +} -body { + pack [text .t -yscrollcommand {.s set}] -side left + for {set i 1} {$i < 100} {incr i} {.t insert end "Line $i\n"} + pack [ttk::scrollbar .s -command {.t yview}] -fill y -expand 1 -side left + update + focus -force .s + event generate .s <MouseWheel> -delta -120 + after 200 {set eventprocessed 1} ; vwait eventprocessed + .t index @0,0 +} -cleanup { + destroy .t .s +} -result {5.0} +test scrollbar-10.1.2 {<MouseWheel> event on scrollbar} -constraints {aqua} -setup { + destroy .t .s +} -body { + pack [text .t -yscrollcommand {.s set}] -side left + for {set i 1} {$i < 100} {incr i} {.t insert end "Line $i\n"} + pack [ttk::scrollbar .s -command {.t yview}] -fill y -expand 1 -side left + update + focus -force .s + event generate .s <MouseWheel> -delta -4 + after 200 {set eventprocessed 1} ; vwait eventprocessed + .t index @0,0 +} -cleanup { + destroy .t .s +} -result {5.0} + +test scrollbar-10.2.1 {<Shift-MouseWheel> event on horizontal scrollbar} -constraints {notAqua} -setup { + destroy .t .s +} -body { + pack [text .t -xscrollcommand {.s set} -wrap none] -side top + for {set i 1} {$i < 100} {incr i} {.t insert end "Char $i "} + pack [ttk::scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top + update + focus -force .s + event generate .s <Shift-MouseWheel> -delta -120 + after 200 {set eventprocessed 1} ; vwait eventprocessed + .t index @0,0 +} -cleanup { + destroy .t .s +} -result {1.4} +test scrollbar-10.2.2 {<Shift-MouseWheel> event on horizontal scrollbar} -constraints {aqua} -setup { + destroy .t .s +} -body { + pack [text .t -xscrollcommand {.s set} -wrap none] -side top + for {set i 1} {$i < 100} {incr i} {.t insert end "Char $i "} + pack [ttk::scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top + update + focus -force .s + event generate .s <Shift-MouseWheel> -delta -4 + after 200 {set eventprocessed 1} ; vwait eventprocessed + .t index @0,0 +} -cleanup { + destroy .t .s +} -result {1.4} +test scrollbar-10.2.3 {<MouseWheel> event on horizontal scrollbar} -constraints {notAqua} -setup { + destroy .t .s +} -body { + pack [text .t -xscrollcommand {.s set} -wrap none] -side top + for {set i 1} {$i < 100} {incr i} {.t insert end "Char $i "} + pack [ttk::scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top + update + focus -force .s + event generate .s <MouseWheel> -delta -120 + after 200 {set eventprocessed 1} ; vwait eventprocessed + .t index @0,0 +} -cleanup { + destroy .t .s +} -result {1.4} +test scrollbar-10.2.4 {<MouseWheel> event on horizontal scrollbar} -constraints {aqua} -setup { + destroy .t .s +} -body { + pack [text .t -xscrollcommand {.s set} -wrap none] -side top + for {set i 1} {$i < 100} {incr i} {.t insert end "Char $i "} + pack [ttk::scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top + update + focus -force .s + event generate .s <MouseWheel> -delta -4 + after 200 {set eventprocessed 1} ; vwait eventprocessed + .t index @0,0 +} -cleanup { + destroy .t .s +} -result {1.4} + # # Scale tests: # diff --git a/tests/ttk/spinbox.test b/tests/ttk/spinbox.test index 08f2bda..38bae14 100644 --- a/tests/ttk/spinbox.test +++ b/tests/ttk/spinbox.test @@ -253,7 +253,7 @@ test spinbox-nostomp-3 "don't stomp on -variable (configure; -from/to)" -body { test spinbox-nostomp-4 "don't stomp on -variable (configure; -values)" -body { set SBV Apr - ttk::spinbox .sb + ttk::spinbox .sb .sb configure -textvariable SBV -values {Jan Feb Mar Apr May Jun Jul Aug} list $SBV [.sb get] } -cleanup { @@ -278,7 +278,7 @@ test spinbox-dieoctaldie-1 "Cope with leading zeros" -body { event generate .sb <<Decrement>>; lappend result $secs set result -} -result [list 07 08 09 10 11 10 09 08 07] -cleanup { +} -result [list 07 08 09 10 11 10 09 08 07] -cleanup { destroy .sb unset secs } diff --git a/tests/ttk/treetags.test b/tests/ttk/treetags.test index 7f26e2f..09c34e0 100644 --- a/tests/ttk/treetags.test +++ b/tests/ttk/treetags.test @@ -105,7 +105,7 @@ test treetags-1.8 "tag names" -body { } -result [list tag1 tag2 tag3] test treetags-1.9 "tag names - tag added to item" -body { - $tv item item1 -tags tag4 + $tv item item1 -tags tag4 lsort [$tv tag names] } -result [list tag1 tag2 tag3 tag4] @@ -123,28 +123,28 @@ test treetags-1.end "cleanup" -body { } -result [list [list item1] [list item2] [list]] test treetags-2.0 "tag bind" -body { - $tv tag bind tag1 <KeyPress> {set ::KEY %A} - $tv tag bind tag1 <KeyPress> + $tv tag bind tag1 <Key> {set ::KEY %A} + $tv tag bind tag1 <Key> } -cleanup { treeConstraints $tv } -result {set ::KEY %A} test treetags-2.1 "Events delivered to tags" -body { - focus -force $tv ; update ;# needed so [event generate] delivers KeyPress + focus -force $tv ; update ;# needed so [event generate] delivers Key $tv focus item1 - event generate $tv <KeyPress-a> + event generate $tv <a> set ::KEY } -cleanup { treeConstraints $tv } -result a test treetags-2.2 "Events delivered to correct tags" -body { - $tv tag bind tag2 <KeyPress> [list set ::KEY2 %A] + $tv tag bind tag2 <Key> [list set ::KEY2 %A] $tv focus item1 - event generate $tv <KeyPress-b> + event generate $tv <b> $tv focus item2 - event generate $tv <KeyPress-c> + event generate $tv <c> list $::KEY $::KEY2 } -cleanup { @@ -201,12 +201,12 @@ test treetags-3.4 "stomp tags in tag binding procedure" -body { set result [list] $tv tag bind rm1 <<Remove>> { lappend ::result rm1 [%W focus] <<Remove>> } $tv tag bind rm2 <<Remove>> { - lappend ::result rm2 [%W focus] <<Remove>> + lappend ::result rm2 [%W focus] <<Remove>> %W item [%W focus] -tags {tag1} } $tv tag bind rm3 <<Remove>> { lappend ::result rm3 [%W focus] <<Remove>> } - $tv item item1 -tags {rm1 rm2 rm3} + $tv item item1 -tags {rm1 rm2 rm3} $tv focus item1 event generate $tv <<Remove>> set result diff --git a/tests/ttk/treeview.test b/tests/ttk/treeview.test index 0ad0443..43dd249 100644 --- a/tests/ttk/treeview.test +++ b/tests/ttk/treeview.test @@ -699,9 +699,9 @@ test treeview-10.1 "Root node properly initialized (#1541739)" -setup { test treeview-3006842 "Null bindings" -setup { ttk::treeview .tv -show tree } -body { - .tv tag bind empty <ButtonPress-1> {} + .tv tag bind empty <Button-1> {} .tv insert {} end -text "Click me" -tags empty - event generate .tv <ButtonPress-1> -x 10 -y 10 + event generate .tv <Button-1> -x 10 -y 10 .tv tag bind empty } -result {} -cleanup { destroy .tv @@ -729,14 +729,14 @@ test treeview-3085489-2 "tag remove, no -tags" -setup { test treeview-368fa4561e "indicators cannot be clicked on leafs" -setup { pack [ttk::treeview .tv] - .tv insert {} end -id foo -text "<-- (1) Click the blank space to my left" + .tv insert {} end -id foo -text "<-- (1) Click the blank space to my left" update } -body { foreach {x y w h} [.tv bbox foo #0] {} set res [.tv item foo -open] # using $h even for x computation is intentional here in order to simulate # a mouse click on the (invisible since we're on a leaf) indicator - event generate .tv <ButtonPress-1> \ + event generate .tv <Button-1> \ -x [expr {$x + $h / 2}] \ -y [expr {$y + $h / 2}] lappend res [.tv item foo -open] @@ -748,7 +748,7 @@ test treeview-368fa4561e "indicators cannot be clicked on leafs" -setup { test treeview-ce470f20fd-1 "dragging further than the right edge of the treeview is allowed" -setup { pack [ttk::treeview .tv] - .tv heading #0 -text "Drag my right edge -->" + .tv heading #0 -text "Drag my right edge -->" update } -body { set res [.tv column #0 -width] @@ -818,7 +818,7 @@ test treeview-ce470f20fd-4 "changing -stretch resizes columns" -setup { update idletasks ; # redisplay treeview } -body { # only some columns are displayed (and in a different order than declared - # in -columns), a non-displayed column becomes stretchable --> nothing + # in -columns), a non-displayed column becomes stretchable --> nothing # happens set origTreeWidth [winfo width .tv] set res [list [.tv column bar -width] [.tv column colA -width]] diff --git a/tests/ttk/ttk.test b/tests/ttk/ttk.test index aba3eba..53da18a 100644 --- a/tests/ttk/ttk.test +++ b/tests/ttk/ttk.test @@ -134,8 +134,8 @@ test ttk-selfdestruct-ok-1 "Intentional self-destruction" -body { # # Basic tests. # -test ttk-1.1 "Create button" -body { - pack [ttk::button .t] -expand true -fill both +test ttk-1.1 "Create multiline button showing justified text" -body { + pack [ttk::button .t -text "Hello\nWorld!!" -justify center] -expand true -fill both update } @@ -207,9 +207,9 @@ test ttk-2.8 "bug 3223850: button state disabled during click" -setup { set ttk28 {} pack [ttk::button .b -command {set ::ttk28 failed}] update -} -body { - bind .b <ButtonPress-1> {after 0 {.b configure -state disabled}} - after 1 {event generate .b <ButtonPress-1>} +} -body { + bind .b <Button-1> {after 0 {.b configure -state disabled}} + after 1 {event generate .b <Button-1>} after 20 {event generate .b <ButtonRelease-1>} set aid [after 100 {set ::ttk28 [.b instate {disabled !pressed}]}] vwait ::ttk28 diff --git a/tests/ttk/validate.test b/tests/ttk/validate.test index 417deac..5755943 100644 --- a/tests/ttk/validate.test +++ b/tests/ttk/validate.test @@ -161,7 +161,7 @@ test validate-1.18 {entry widget validation} -constraints coreEntry -body { list [.e cget -validate] $::vVals } -result {none {.e -1 -1 nextdata newdata {} all forced}} # DIFFERENCE: ttk::entry doesn't validate when setting linked -variable -# DIFFERENCE: ttk::entry doesn't disable validation +# DIFFERENCE: ttk::entry doesn't disable validation proc doval {W d i P s S v V} { set ::vVals [list $W $d $i $P $s $S $v $V] diff --git a/tests/unixButton.test b/tests/unixButton.test index 325f497..f0dcde5 100644 --- a/tests/unixButton.test +++ b/tests/unixButton.test @@ -16,7 +16,7 @@ imageInit # Create entries in the option database to be sure that geometry options # like border width have predictable values. - + option add *Label.borderWidth 2 option add *Label.highlightThickness 0 option add *Label.font {Helvetica -12 bold} @@ -70,7 +70,7 @@ test unixbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints { [expr {72 + $bigIndicator}] 52 \ [expr {72 + $bigIndicator}] 52] test unixbutton-1.2 {TkpComputeButtonGeometry procedure} -constraints { - unix + unix } -setup { deleteWindows } -body { @@ -91,7 +91,7 @@ test unixbutton-1.2 {TkpComputeButtonGeometry procedure} -constraints { [expr {27 + $smallIndicator}] 37 \ [expr {27 + $smallIndicator}] 37] test unixbutton-1.3 {TkpComputeButtonGeometry procedure} -constraints { - unix + unix } -setup { deleteWindows } -body { @@ -192,7 +192,7 @@ test unixbutton-1.8 {TkpComputeButtonGeometry procedure} -constraints { deleteWindows } -result {62 30 56 24 58 22 62 22} test unixbutton-1.9 {TkpComputeButtonGeometry procedure} -constraints { - unix + unix } -setup { deleteWindows } -body { @@ -200,9 +200,9 @@ test unixbutton-1.9 {TkpComputeButtonGeometry procedure} -constraints { list [winfo reqwidth .b2] [winfo reqheight .b2] } -cleanup { deleteWindows -} -result [list [expr {17 + $defaultBorder}] [expr {27 + $defaultBorder}]] +} -result [list [expr {17 + $defaultBorder}] [expr {27 + $defaultBorder}]] test unixbutton-1.10 {TkpComputeButtonGeometry procedure} -constraints { - unix + unix } -setup { deleteWindows } -body { @@ -212,7 +212,7 @@ test unixbutton-1.10 {TkpComputeButtonGeometry procedure} -constraints { deleteWindows } -result [list [expr {17 + $defaultBorder}] [expr {27 + $defaultBorder}]] test unixbutton-1.11 {TkpComputeButtonGeometry procedure} -constraints { - unix + unix } -setup { deleteWindows } -body { @@ -224,7 +224,7 @@ test unixbutton-1.11 {TkpComputeButtonGeometry procedure} -constraints { test unixbutton-2.1 {disabled coloring check, bug 669595} -constraints { - unix + unix } -setup { deleteWindows catch {unset value} diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test index 2ebf9c2..c0a5bac 100644 --- a/tests/unixEmbed.test +++ b/tests/unixEmbed.test @@ -970,20 +970,20 @@ test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} -constrain toplevel .t1 -use $w1 } focus -force . - bind . <KeyPress> {lappend x {key %A %E}} + bind . <Key> {lappend x {key %A %E}} set x {} set y [dobg { update - bind .t1 <KeyPress> {lappend y {key %A}} + bind .t1 <Key> {lappend y {key %A}} set y {} - event generate .t1 <KeyPress> -keysym a + event generate .t1 <Keys> -keysym a set y }] update list $x $y } -cleanup { deleteWindows - bind . <KeyPress> {} + bind . <Key> {} } -result {{{key a 1}} {}} # TkpRedirectKeyEvent is not implemented in win or aqua. If someone # implements it they should change the constraints for this test. @@ -1004,13 +1004,13 @@ test unixEmbed-7.1a {TkpRedirectKeyEvent procedure, forward keystroke} -constrai toplevel .t1 -use [w1] } focus -force . - bind . <KeyPress> {lappend x {key %A %E}} + bind . <Key> {lappend x {key %A %E}} set x {} set y [slave eval { update - bind .t1 <KeyPress> {lappend y {key %A}} + bind .t1 <Key> {lappend y {key %A}} set y {} - event generate .t1 <KeyPress> -keysym a + event generate .t1 <Key> -keysym a set y }] update @@ -1018,7 +1018,7 @@ test unixEmbed-7.1a {TkpRedirectKeyEvent procedure, forward keystroke} -constrai } -cleanup { interp delete slave deleteWindows - bind . <KeyPress> {} + bind . <Key> {} } -result {{{key a 1}} {}} test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} -constraints { unix notAqua @@ -1035,20 +1035,20 @@ test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width update focus -force .f1 update - bind . <KeyPress> {lappend x {key %A}} + bind . <Key> {lappend x {key %A}} set x {} set y [dobg { update - bind .t1 <KeyPress> {lappend y {key %A}} + bind .t1 <Key> {lappend y {key %A}} set y {} - event generate .t1 <KeyPress> -keysym b + event generate .t1 <Key> -keysym b set y }] update list $x $y } -cleanup { deleteWindows - bind . <KeyPress> {} + bind . <Key> {} } -result {{} {{key b}}} test unixEmbed-7.2a {TkpRedirectKeyEvent procedure, don't forward keystroke width} -constraints { unix @@ -1068,13 +1068,13 @@ test unixEmbed-7.2a {TkpRedirectKeyEvent procedure, don't forward keystroke widt update focus -force .f1 update - bind . <KeyPress> {lappend x {key %A}} + bind . <Key> {lappend x {key %A}} set x {} set y [slave eval { update - bind .t1 <KeyPress> {lappend y {key %A}} + bind .t1 <Key> {lappend y {key %A}} set y {} - event generate .t1 <KeyPress> -keysym b + event generate .t1 <Key> -keysym b set y }] update @@ -1082,7 +1082,7 @@ test unixEmbed-7.2a {TkpRedirectKeyEvent procedure, don't forward keystroke widt } -cleanup { interp delete slave deleteWindows - bind . <KeyPress> {} + bind . <Key> {} } -result {{} {{key b}}} test unixEmbed-8.1 {TkpClaimFocus procedure} -constraints { diff --git a/tests/unixMenu.test b/tests/unixMenu.test index 3d655e4..63e4849 100644 --- a/tests/unixMenu.test +++ b/tests/unixMenu.test @@ -35,7 +35,7 @@ test unixMenu-3.1 {TkpDestroymenuEntry - nothing to do} -constraints unix -body test unixMenu-4.1 {TkpConfigureMenuEntry - non-cascade entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -44,7 +44,7 @@ test unixMenu-4.1 {TkpConfigureMenuEntry - non-cascade entry} -constraints { list [.m1 entryconfigure test -label foo] [destroy .m1] } -returnCodes ok -result {{} {}} test unixMenu-4.2 {TkpConfigureMenuEntry - cascade entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -79,7 +79,7 @@ test unixMenu-7.1 {TkpSetMainMenubar - nothing to do} -constraints unix -body {} test unixMenu-8.1 {GetMenuIndicatorGeometry - indicator off} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -89,7 +89,7 @@ test unixMenu-8.1 {GetMenuIndicatorGeometry - indicator off} -constraints { destroy .m1 } -returnCodes ok test unixMenu-8.2 {GetMenuIndicatorGeometry - not checkbutton or radio} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -112,9 +112,9 @@ test unixMenu-8.3 {GetMenuIndicatorGeometry - checkbutton image} -constraints { destroy .m1 } -cleanup { image delete image1 -} -returnCodes ok +} -returnCodes ok test unixMenu-8.4 {GetMenuIndicatorGeometry - checkbutton bitmap} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -125,7 +125,7 @@ test unixMenu-8.4 {GetMenuIndicatorGeometry - checkbutton bitmap} -constraints { destroy .m1 } -returnCodes ok test unixMenu-8.5 {GetMenuIndicatorGeometry - checkbutton} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -150,7 +150,7 @@ test unixMenu-8.6 {GetMenuIndicatorGeometry - radiobutton image} -constraints { image delete image1 } -returnCodes ok test unixMenu-8.7 {GetMenuIndicatorGeometry - radiobutton bitmap} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -159,9 +159,9 @@ test unixMenu-8.7 {GetMenuIndicatorGeometry - radiobutton bitmap} -constraints { .m1 invoke foo tk::TearOffMenu .m1 40 40 destroy .m1 -} -returnCodes ok +} -returnCodes ok test unixMenu-8.8 {GetMenuIndicatorGeometry - radiobutton} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -172,7 +172,7 @@ test unixMenu-8.8 {GetMenuIndicatorGeometry - radiobutton} -constraints { destroy .m1 } -returnCodes ok test unixMenu-8.9 {GetMenuIndicatorGeometry - hideMargin} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -181,11 +181,11 @@ test unixMenu-8.9 {GetMenuIndicatorGeometry - hideMargin} -constraints { .m1 invoke foo tk::TearOffMenu .m1 40 40 destroy .m1 -} -returnCodes ok +} -returnCodes ok test unixMenu-9.1 {GetMenuAccelGeometry - cascade entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -195,7 +195,7 @@ test unixMenu-9.1 {GetMenuAccelGeometry - cascade entry} -constraints { destroy .m1 } -returnCodes ok test unixMenu-9.2 {GetMenuAccelGeometry - non-null label} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -215,7 +215,7 @@ test unixMenu-9.3 {GetMenuAccelGeometry - null label} -constraints unix -setup { test unixMenu-10.1 {DrawMenuEntryBackground - active menubar} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -235,7 +235,7 @@ test unixMenu-10.2 {DrawMenuEntryBackground - active} -constraints unix -setup { list [update] [destroy .m1] } -returnCodes ok -result {{} {}} test unixMenu-10.3 {DrawMenuEntryBackground - non-active} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -247,7 +247,7 @@ test unixMenu-10.3 {DrawMenuEntryBackground - non-active} -constraints { test unixMenu-11.1 {DrawMenuEntryAccelerator - menubar} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -258,7 +258,7 @@ test unixMenu-11.1 {DrawMenuEntryAccelerator - menubar} -constraints { } -result {{} {} {}} # drawArrow parameter is never false under Unix test unixMenu-11.2 {DrawMenuEntryAccelerator - cascade entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -268,7 +268,7 @@ test unixMenu-11.2 {DrawMenuEntryAccelerator - cascade entry} -constraints { list [update] [destroy .m1] } -result {{} {}} test unixMenu-11.3 {DrawMenuEntryAccelerator - normal entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -278,7 +278,7 @@ test unixMenu-11.3 {DrawMenuEntryAccelerator - normal entry} -constraints { list [update] [destroy .m1] } -result {{} {}} test unixMenu-11.4 {DrawMenuEntryAccelerator - null entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -290,7 +290,7 @@ test unixMenu-11.4 {DrawMenuEntryAccelerator - null entry} -constraints { test unixMenu-12.1 {DrawMenuEntryIndicator - non-check or radio} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -300,7 +300,7 @@ test unixMenu-12.1 {DrawMenuEntryIndicator - non-check or radio} -constraints { list [update] [destroy .m1] } -result {{} {}} test unixMenu-12.2 {DrawMenuEntryIndicator - checkbutton - indicator off} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -310,7 +310,7 @@ test unixMenu-12.2 {DrawMenuEntryIndicator - checkbutton - indicator off} -const list [update] [destroy .m1] } -result {{} {}} test unixMenu-12.3 {DrawMenuEntryIndicator - checkbutton - not selected} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -320,7 +320,7 @@ test unixMenu-12.3 {DrawMenuEntryIndicator - checkbutton - not selected} -constr list [update] [destroy .m1] } -result {{} {}} test unixMenu-12.4 {DrawMenuEntryIndicator - checkbutton - selected} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -331,7 +331,7 @@ test unixMenu-12.4 {DrawMenuEntryIndicator - checkbutton - selected} -constraint list [update] [destroy .m1] } -result {{} {}} test unixMenu-12.5 {DrawMenuEntryIndicator - radiobutton - indicator off} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -341,7 +341,7 @@ test unixMenu-12.5 {DrawMenuEntryIndicator - radiobutton - indicator off} -const list [update] [destroy .m1] } -result {{} {}} test unixMenu-12.6 {DrawMenuEntryIndicator - radiobutton - not selected} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -351,7 +351,7 @@ test unixMenu-12.6 {DrawMenuEntryIndicator - radiobutton - not selected} -constr list [update] [destroy .m1] } -result {{} {}} test unixMenu-12.7 {DrawMenuEntryIndicator - radiobutton - selected} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -446,7 +446,7 @@ test unixMenu-18.1 {GetTearoffEntryGeometry} -constraints { # Don't know how to reproduce the case where the tkwin has been deleted. test unixMenu-19.1 {TkpComputeMenubarGeometry - zero entries} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -456,7 +456,7 @@ test unixMenu-19.1 {TkpComputeMenubarGeometry - zero entries} -constraints { } -result {{} {} {}} # Don't know how to generate one width windows test unixMenu-19.2 {TkpComputeMenubarGeometry - one entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -466,7 +466,7 @@ test unixMenu-19.2 {TkpComputeMenubarGeometry - one entry} -constraints { list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.3 {TkpComputeMenubarGeometry - entry with different font} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -476,7 +476,7 @@ test unixMenu-19.3 {TkpComputeMenubarGeometry - entry with different font} -cons list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.4 {TkpComputeMenubarGeometry - separator} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -486,7 +486,7 @@ test unixMenu-19.4 {TkpComputeMenubarGeometry - separator} -constraints { list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.5 {TkpComputeMenubarGeometry - First entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -496,7 +496,7 @@ test unixMenu-19.5 {TkpComputeMenubarGeometry - First entry} -constraints { list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.6 {TkpComputeMenubarGeometry - First entry too wide} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -507,7 +507,7 @@ test unixMenu-19.6 {TkpComputeMenubarGeometry - First entry too wide} -constrain list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.7 {TkpComputeMenubarGeometry - two entries fit} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -519,7 +519,7 @@ test unixMenu-19.7 {TkpComputeMenubarGeometry - two entries fit} -constraints { list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.8 {TkpComputeMenubarGeometry - two entries; 2nd don't fit} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -531,7 +531,7 @@ test unixMenu-19.8 {TkpComputeMenubarGeometry - two entries; 2nd don't fit} -con list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.9 {TkpComputeMenubarGeometry - two entries; 1st dont fit} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -543,7 +543,7 @@ test unixMenu-19.9 {TkpComputeMenubarGeometry - two entries; 1st dont fit} -cons list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.10 {TkpComputeMenubarGeometry - two entries; neither fit} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -645,7 +645,7 @@ test unixMenu-19.18 {TkpComputeMenubarGeometry - ABC} -constraints unix -setup { list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -661,7 +661,7 @@ test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} -c list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -677,7 +677,7 @@ test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} -constrain list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -693,7 +693,7 @@ test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} -c list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -707,7 +707,7 @@ test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} -constraints { list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -721,7 +721,7 @@ test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} -constr list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.24 {TkpComputeMenubarGeometry - help item only one} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -766,7 +766,7 @@ test unixMenu-22.1 {SetHelpMenu - no menubars} -constraints unix -setup { } -result {.m1.test {}} # Don't know how to automate missing tkwins test unixMenu-22.2 {SetHelpMenu - menubar but no help menu} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -776,7 +776,7 @@ test unixMenu-22.2 {SetHelpMenu - menubar but no help menu} -constraints { list [menu .m1.file] [. configure -menu ""] [destroy .m1] } -result {.m1.file {} {}} test unixMenu-22.3 {SetHelpMenu - menubar with help menu} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -786,7 +786,7 @@ test unixMenu-22.3 {SetHelpMenu - menubar with help menu} -constraints { list [menu .m1.help] [. configure -menu ""] [destroy .m1] } -result {.m1.help {} {}} test unixMenu-22.4 {SetHelpMenu - multiple menubars with same help menu} -constraints { - unix + unix } -setup { destroy .m1 .t2 } -body { @@ -801,7 +801,7 @@ test unixMenu-22.4 {SetHelpMenu - multiple menubars with same help menu} -constr test unixMenu-23.1 {TkpDrawMenuEntry - gc for active and not strict motif} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -812,7 +812,7 @@ test unixMenu-23.1 {TkpDrawMenuEntry - gc for active and not strict motif} -cons list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -823,7 +823,7 @@ test unixMenu-23.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.3 {TkpDrawMenuEntry - gc for active and strict motif} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -835,7 +835,7 @@ test unixMenu-23.3 {TkpDrawMenuEntry - gc for active and strict motif} -constrai list [update] [destroy .m1] [set tk_strictMotif 0] } -result {{} {} 0} test unixMenu-23.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -845,7 +845,7 @@ test unixMenu-23.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custo list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -855,7 +855,7 @@ test unixMenu-23.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} -constra list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -865,7 +865,7 @@ test unixMenu-23.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} -constra list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.7 {TkpDrawMenuEntry - gc for normal - custom entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -883,7 +883,7 @@ test unixMenu-23.8 {TkpDrawMenuEntry - gc for normal} -constraints unix -setup { list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.9 {TkpDrawMenuEntry - gc for indicator - custom entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -894,7 +894,7 @@ test unixMenu-23.9 {TkpDrawMenuEntry - gc for indicator - custom entry} -constra list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.10 {TkpDrawMenuEntry - gc for indicator} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -905,7 +905,7 @@ test unixMenu-23.10 {TkpDrawMenuEntry - gc for indicator} -constraints { list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.11 {TkpDrawMenuEntry - border - custom entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -925,7 +925,7 @@ test unixMenu-23.12 {TkpDrawMenuEntry - border} -constraints unix -setup { list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.13 {TkpDrawMenuEntry - active border - strict motif} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -937,7 +937,7 @@ test unixMenu-23.13 {TkpDrawMenuEntry - active border - strict motif} -constrain list [update] [destroy .m1] [set tk_strictMotif 0] } -result {{} {} 0} test unixMenu-23.14 {TkpDrawMenuEntry - active border - custom entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -957,7 +957,7 @@ test unixMenu-23.15 {TkpDrawMenuEntry - active border} -constraints unix -setup list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.16 {TkpDrawMenuEntry - font - custom entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -991,7 +991,7 @@ test unixMenu-23.19 {TkpDrawMenuEntry - standard} -constraints unix -setup { list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1058,7 +1058,7 @@ test unixMenu-24.4 {GetMenuLabelGeometry - text} -constraints unix -setup { test unixMenu-25.1 {TkpComputeStandardMenuGeometry - no entries} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1066,7 +1066,7 @@ test unixMenu-25.1 {TkpComputeStandardMenuGeometry - no entries} -constraints { list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.2 {TkpComputeStandardMenuGeometry - one entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1075,7 +1075,7 @@ test unixMenu-25.2 {TkpComputeStandardMenuGeometry - one entry} -constraints { list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.3 {TkpComputeStandardMenuGeometry - more than one entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1085,7 +1085,7 @@ test unixMenu-25.3 {TkpComputeStandardMenuGeometry - more than one entry} -const list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.4 {TkpComputeStandardMenuGeometry - separator} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1106,7 +1106,7 @@ test unixMenu-25.5 {TkpComputeStandardMenuGeometry - tearoff entry} -constraints list [update] [tk::MenuUnpost .mb.m] [destroy .mb] } -result {{} {} {}} test unixMenu-25.6 {TkpComputeStandardMenuGeometry - standard label geometry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1115,7 +1115,7 @@ test unixMenu-25.6 {TkpComputeStandardMenuGeometry - standard label geometry} -c list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.7 {TkpComputeStandardMenuGeometry - different font for entry} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1124,7 +1124,7 @@ test unixMenu-25.7 {TkpComputeStandardMenuGeometry - different font for entry} - list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.8 {TkpComputeStandardMenuGeometry - second entry larger} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1134,7 +1134,7 @@ test unixMenu-25.8 {TkpComputeStandardMenuGeometry - second entry larger} -const list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.9 {TkpComputeStandardMenuGeometry - first entry larger} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1144,7 +1144,7 @@ test unixMenu-25.9 {TkpComputeStandardMenuGeometry - first entry larger} -constr list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.10 {TkpComputeStandardMenuGeometry - accelerator} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1153,7 +1153,7 @@ test unixMenu-25.10 {TkpComputeStandardMenuGeometry - accelerator} -constraints list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.11 {TkpComputeStandardMenuGeometry - second accel larger} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1163,7 +1163,7 @@ test unixMenu-25.11 {TkpComputeStandardMenuGeometry - second accel larger} -cons list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.12 {TkpComputeStandardMenuGeometry - second accel smaller} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1173,7 +1173,7 @@ test unixMenu-25.12 {TkpComputeStandardMenuGeometry - second accel smaller} -con list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.13 {TkpComputeStandardMenuGeometry - indicator} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1211,7 +1211,7 @@ test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } list [update idletasks] [destroy .m1] [image delete image1] } -result {{} {} {}} test unixMenu-25.16 {TkpComputeStandardMenuGeometry - zero sized menus} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1219,7 +1219,7 @@ test unixMenu-25.16 {TkpComputeStandardMenuGeometry - zero sized menus} -constra list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.17 {TkpComputeStandardMenuGeometry - first column bigger} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1230,7 +1230,7 @@ test unixMenu-25.17 {TkpComputeStandardMenuGeometry - first column bigger} -cons list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.18 {TkpComputeStandardMenuGeometry - second column bigger} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1241,7 +1241,7 @@ test unixMenu-25.18 {TkpComputeStandardMenuGeometry - second column bigger} -con list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} -constraints { - unix + unix } -setup { destroy .m1 } -body { @@ -1252,10 +1252,10 @@ test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} -constraint .m1 add command -label four .m1 add command -label five -columnbreak 1 .m1 add command -label six - list [update idletasks] [destroy .m1] + list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} -constraints { - unix + unix } -setup { destroy .m1 } -body { diff --git a/tests/util.test b/tests/util.test index c1ec6a5..d457b50 100644 --- a/tests/util.test +++ b/tests/util.test @@ -28,10 +28,10 @@ test util-1.3 {Tk_GetScrollInfo procedure} -body { } -result {0.5 0.75} test util-1.4 {Tk_GetScrollInfo procedure} -body { .l yview scroll a -} -returnCodes error -result {wrong # args: should be ".l yview scroll number units|pages"} +} -returnCodes error -result {wrong # args: should be ".l yview scroll number pages|units"} test util-1.5 {Tk_GetScrollInfo procedure} -body { .l yview scroll a b c -} -returnCodes error -result {wrong # args: should be ".l yview scroll number units|pages"} +} -returnCodes error -result {wrong # args: should be ".l yview scroll number pages|units"} test util-1.6 {Tk_GetScrollInfo procedure} -body { .l yview scroll xyz units } -returnCodes error -result {expected integer but got "xyz"} @@ -57,7 +57,7 @@ test util-1.10 {Tk_GetScrollInfo procedure} -body { } -result {13} test util-1.11 {Tk_GetScrollInfo procedure} -body { .l yview scroll 3 zips -} -returnCodes error -result {bad argument "zips": must be units or pages} +} -returnCodes error -result {bad argument "zips": must be pages or units} test util-1.12 {Tk_GetScrollInfo procedure} -body { .l yview dropdead 3 times } -returnCodes error -result {unknown option "dropdead": must be moveto or scroll} diff --git a/tests/visual_bb.test b/tests/visual_bb.test index 2b06d05..eda67e4 100644 --- a/tests/visual_bb.test +++ b/tests/visual_bb.test @@ -52,7 +52,7 @@ test 1.1 {running visual tests} -constraints userInteraction -body { frame .menu -relief raised -borderwidth 1 message .msg -font {Times 18} -relief raised -width 4i \ -borderwidth 1 -text "This application provides a collection of visual tests for the Tk toolkit. Each menu entry invokes a test, which displays information on the screen. You can then verify visually that the information is being displayed in the correct way. The tests under the \"Postscript\" menu exercise the Postscript-generation capabilities of canvas widgets." - + pack .menu -side top -fill x pack .msg -side bottom -expand yes -fill both @@ -64,7 +64,7 @@ test 1.1 {running visual tests} -constraints userInteraction -body { menubutton .menu.file -text "File" -menu .menu.file.m menu .menu.file.m .menu.file.m add command -label "Quit" -command end - + menubutton .menu.group1 -text "Group 1" -menu .menu.group1.m menu .menu.group1.m .menu.group1.m add command -label "Canvas arcs" -command {runTest arc.tcl} @@ -76,7 +76,7 @@ test 1.1 {running visual tests} -constraints userInteraction -body { -command {runTest butGeom.tcl} .menu.group1.m add command -label "Label/button colors" \ -command {runTest butGeom2.tcl} - + menubutton .menu.ps -text "Canvas Postscript" -menu .menu.ps.m menu .menu.ps.m .menu.ps.m add command -label "Rectangles and other graphics" \ @@ -89,12 +89,12 @@ test 1.1 {running visual tests} -constraints userInteraction -body { -command {runTest canvPsImg.tcl} .menu.ps.m add command -label "Arcs" \ -command {runTest canvPsArc.tcl} - + pack .menu.file .menu.group1 .menu.ps -side left -padx 1m - + # Set up for keyboard-based menu traversal - - bind . <Any-FocusIn> { + + bind . <FocusIn> { if {("%d" == "NotifyVirtual") && ("%m" == "NotifyNormal")} { focus .menu } @@ -104,7 +104,7 @@ test 1.1 {running visual tests} -constraints userInteraction -body { # Set up a class binding to allow objects to be deleted from a canvas # by clicking with mouse button 1: - bind Canvas <1> {%W delete [%W find closest %x %y]} + bind Canvas <Button-1> {%W delete [%W find closest %x %y]} concat "" } -result {} diff --git a/tests/winDialog.test b/tests/winDialog.test index 852a38a..e70ae3f 100755 --- a/tests/winDialog.test +++ b/tests/winDialog.test @@ -255,7 +255,7 @@ test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} -constraints { set y [then { Click cancel }] - # Note this also tests fix for + # Note this also tests fix for # https://core.tcl-lang.org/tk/tktview/4a0451f5291b3c9168cc560747dae9264e1d2ef6 # $x is expected to be empty append x $y @@ -441,7 +441,7 @@ test winDialog-5.9 {GetFileName: file types} -constraints { nt testwinevent } -body { # case FILE_TYPES: - + start {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo} # XXX - currently disabled for vista style dialogs because the file # types control has no control ID and we don't have a mechanism to @@ -504,7 +504,7 @@ test winDialog-5.12.1 {tk_getSaveFile: initial directory: ~} -constraints { test winDialog-5.12.2 {tk_getSaveFile: initial directory: ~user} -constraints { nt testwinevent } -body { - + # Note: this test will fail on Tcl versions 8.6.4 and earlier due # to a bug in file normalize for names of the form ~xxx that # returns the wrong dir on Windows. In particular (in Win8 at @@ -731,7 +731,7 @@ test winDialog-5.17 {GetFileName: title} -constraints { nt testwinevent } -body { # case FILE_TITLE: - + start {tk_getOpenFile -title Narf} then { Click cancel @@ -794,7 +794,7 @@ test winDialog-5.21 {GetFileName: call GetOpenFileName} -constraints { nt testwinevent english } -body { # winCode = GetOpenFileName(&ofn); - + start {tk_getOpenFile -title Open} then { set x [GetText ok] @@ -927,7 +927,7 @@ test winDialog-9.8 {Tk_ChooseDirectoryObjCmd: initial directory: Tcl_TranslateFi } -body { # if (Tcl_TranslateFileName(interp, string, # &utfDirString) == NULL) - + tk_chooseDirectory -initialdir ~12x/455 } -returnCodes error -result {user "12x" doesn't exist} diff --git a/tests/winFont.test b/tests/winFont.test index 377ef41..23c09c9 100644 --- a/tests/winFont.test +++ b/tests/winFont.test @@ -4,7 +4,7 @@ # Many of these tests are visually oriented and cannot be checked # programmatically (such as "does an underlined font appear to be # underlined?"); these tests attempt to exercise the code in question, -# but there are no results that can be checked. +# but there are no results that can be checked. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. @@ -71,7 +71,7 @@ test winfont-2.7 {TkpGetFontFromAttributes procedure: Times fonts} -constraints lappend x [font actual {-family "Times"} -family] lappend x [font actual {-family "New York"} -family] lappend x [font actual {-family "Times New Roman"} -family] -} -result {{Times New Roman} {Times New Roman} {Times New Roman}} +} -result {Times Times {Times New Roman}} test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} -constraints { win } -setup { @@ -80,7 +80,7 @@ test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} -constraint lappend x [font actual {-family "Courier"} -family] lappend x [font actual {-family "Monaco"} -family] lappend x [font actual {-family "Courier New"} -family] -} -result {{Courier New} {Courier New} {Courier New}} +} -match regexp -result {Courier (Courier|Monaco) {Courier New}} test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} -constraints { win } -setup { @@ -89,7 +89,7 @@ test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} -constrai lappend x [font actual {-family "Helvetica"} -family] lappend x [font actual {-family "Geneva"} -family] lappend x [font actual {-family "Arial"} -family] -} -result {Arial Arial Arial} +} -match regexp -result {Helvetica (Helvetica|Geneva) Arial} test winfont-2.10 {TkpGetFontFromAttributes procedure: fallback} -constraints { win } -body { @@ -141,7 +141,7 @@ test winfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} -constraint update set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - + .t.l config -wrap 0 -text "000000" list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \ [expr {[winfo reqheight .t.l] eq $ay}] @@ -160,7 +160,7 @@ test winfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} -cons update set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - + .t.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" list [expr {[winfo reqwidth .t.l] eq 256*$ax}] \ [expr {[winfo reqheight .t.l] eq $ay}] @@ -179,7 +179,7 @@ test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} -constraints { update set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - + .t.l config -wrap [expr {$ax*10}] -text "00000000" list [expr {[winfo reqwidth .t.l] eq 8*$ax}] \ [expr {[winfo reqheight .t.l] eq $ay}] @@ -198,7 +198,7 @@ test winfont-5.4 {Tk_MeasureChars procedure: not all chars fit} -constraints { update set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - + .t.l config -wrap [expr {$ax*6}] -text "00000000" list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \ [expr {[winfo reqheight .t.l] eq 2*$ay}] @@ -234,7 +234,7 @@ test winfont-5.6 {Tk_MeasureChars procedure: at least one char on line} -constra update set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - + .t.l config -text "000000" -wrap 1 list [expr {[winfo reqwidth .t.l] eq $ax}] \ [expr {[winfo reqheight .t.l] eq 6*$ay}] @@ -253,7 +253,7 @@ test winfont-5.7 {Tk_MeasureChars procedure: whole words} -constraints { update set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - + .t.l config -wrap [expr {$ax*8}] -text "000000 0000" list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \ [expr {[winfo reqheight .t.l] eq 2*$ay}] @@ -272,7 +272,7 @@ test winfont-5.8 {Tk_MeasureChars procedure: already saw space in line} -constra update set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - + .t.l config -wrap [expr {$ax*12}] -text "000000 0000000" list [expr {[winfo reqwidth .t.l] eq 7*$ax}] \ [expr {[winfo reqheight .t.l] eq 2*$ay}] @@ -291,7 +291,7 @@ test winfont-5.9 {Tk_MeasureChars procedure: internal spaces significant} -const update set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - + .t.l config -wrap [expr {$ax*12}] -text "000 00 00000" list [expr {[winfo reqwidth .t.l] eq 7*$ax}] \ [expr {[winfo reqheight .t.l] eq 2*$ay}] @@ -310,7 +310,7 @@ test winfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} -cons update set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - + .t.l config -wrap [expr {$ax*12}] -text "0000000000000000" list [expr {[winfo reqwidth .t.l] eq 12*$ax}] \ [expr {[winfo reqheight .t.l] eq 2*$ay}] @@ -327,7 +327,7 @@ test winfont-5.11 {Tk_MeasureChars procedure: check for kerning} -constraints { -text "0" -font systemfixed pack .t.l update - + set font [.t.l cget -font] .t.l config -font {{MS Sans Serif} 8} -text "W" set width [winfo reqwidth .t.l] diff --git a/tests/winMenu.test b/tests/winMenu.test index ce2069f..b77e9a9 100644 --- a/tests/winMenu.test +++ b/tests/winMenu.test @@ -481,7 +481,7 @@ test winMenu-11.3 {TkWinHandleMenuEvent - WM_COMMAND} -constraints { "error 1" (menu invoke)}} {} {}} - + # Can't test WM_MENUCHAR test winMenu-11.4 {TkWinHandleMenuEvent - WM_MEASUREITEM} -constraints { @@ -788,7 +788,7 @@ test winMenu-22.1 {DrawMenuUnderline} -constraints win -setup { .m1 add command -label foo -underline 0 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} -result {{} {}} +} -result {{} {}} test winMenu-23.1 {Don't know how to test MenuKeyBindProc} -constraints { @@ -1343,7 +1343,7 @@ test winMenu-32.19 {TkpComputeStandardMenuGeometry - three columns} -constraints .m1 add command -label four .m1 add command -label five -columnbreak 1 .m1 add command -label six - list [update idletasks] [destroy .m1] + list [update idletasks] [destroy .m1] } -result {{} {}} diff --git a/tests/winWm.test b/tests/winWm.test index ad4988d..0064c5a 100644 --- a/tests/winWm.test +++ b/tests/winWm.test @@ -245,7 +245,7 @@ test winWm-5.2 {UpdateGeometryInfo: menu resizing} -constraints win -setup { update set y [winfo rooty .t] lappend result [winfo height .t] - menu .t.m + menu .t.m -tearoff 1 .t configure -menu .t.m .t.m add command -label foo .t.m add command -label "thisisreallylong" @@ -448,7 +448,7 @@ test winWm-9.0 "Bug #2799589 - delayed activation of destroyed window" -constrai if {![winfo ismapped $w]} { update } event generate $w <Enter> focus -force $w - event generate $w <ButtonPress-1> -x 5 -y 5 + event generate $w <Button-1> -x 5 -y 5 event generate $w <ButtonRelease-1> -x 5 -y 5 } proc winwm90proc3 {} { @@ -474,7 +474,7 @@ test winWm-9.0 "Bug #2799589 - delayed activation of destroyed window" -constrai global winwm90done set winwm90done wait toplevel .t -} -body { +} -body { pack [button .t.b -text "Show" -command {winwm90proc1 .tx}] bind .t.b <Map> {bind %W <Map> {}; after idle {winwm90click %W}} after 5000 {set winwm90done timeout} @@ -485,14 +485,14 @@ test winWm-9.0 "Bug #2799589 - delayed activation of destroyed window" -constrai rename winwm90$cmd {} } destroy .tx .t .sd -} -result {ok} +} -result {ok} test winWm-9.1 "delayed activation of grabbed destroyed window" -constraints win -setup { proc winwm91click {w} { if {![winfo ismapped $w]} { update } event generate $w <Enter> focus -force $w - event generate $w <ButtonPress-1> -x 5 -y 5 + event generate $w <Button-1> -x 5 -y 5 event generate $w <ButtonRelease-1> -x 5 -y 5 } proc winwm91proc3 {} { @@ -519,7 +519,7 @@ test winWm-9.1 "delayed activation of grabbed destroyed window" -constraints win global winwm91done set winwm91done wait toplevel .t -} -body { +} -body { pack [button .t.b -text "Show" -command {winwm91proc1 .tx}] bind .t.b <Map> {bind %W <Map> {}; after idle {winwm91click %W}} after 5000 {set winwm91done timeout} diff --git a/tests/wm.test b/tests/wm.test index 4d0d73b..2978c1b 100644 --- a/tests/wm.test +++ b/tests/wm.test @@ -1525,7 +1525,7 @@ test wm-stackorder-5.1 {a menu is not a toplevel} -body { test wm-stackorder-5.2 {A normal toplevel can't be raised above an \ overrideredirect toplevel on unix} -constraints x11 -body { toplevel .t - tkwait visibility .t + tkwait visibility .t wm overrideredirect .t 1 raise . update @@ -1537,7 +1537,7 @@ test wm-stackorder-5.2 {A normal toplevel can't be raised above an \ test wm-stackorder-5.2.1 {A normal toplevel can be raised above an \ overrideredirect toplevel on macOS or win} -constraints aquaOrWin32 -body { toplevel .t - tkwait visibility .t + tkwait visibility .t wm overrideredirect .t 1 raise . update @@ -1549,7 +1549,7 @@ test wm-stackorder-5.2.1 {A normal toplevel can be raised above an \ test wm-stackorder-5.3 {An overrideredirect window\ can be explicitly lowered} -body { toplevel .t - tkwait visibility .t + tkwait visibility .t wm overrideredirect .t 1 lower .t update |
