diff options
Diffstat (limited to 'tests')
64 files changed, 4311 insertions, 1804 deletions
diff --git a/tests/arc.tcl b/tests/arc.tcl index d0a93ea..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,17 +89,17 @@ 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 } bind .t.c <Shift-B1-Motion> { - .t.c move circle [expr %x-$curx] [expr %y-$cury] + .t.c move circle [expr {%x-$curx}] [expr {%y-$cury}] set curx %x set cury %y } @@ -127,7 +127,7 @@ bind .t.c a { } incr i $delta c -start $i - c -extent [expr 360-2*$i] + c -extent [expr {360-2*$i}] after 20 update } diff --git a/tests/bind.test b/tests/bind.test index 50289b5..adc628a 100644 --- a/tests/bind.test +++ b/tests/bind.test @@ -22,7 +22,7 @@ foreach event [bind Test] { bind Test $event {} } foreach event [bind all] { - bind all $event {} + bind all $event {} } proc unsetBindings {} { @@ -34,19 +34,6 @@ proc unsetBindings {} { bind .t <Enter> {} } -# This function fills the pattern matcher's ring buffer with events of -# the specified type. This can be used when testing with generated -# events to make sure that there are no stray events in the ring -# buffer which might cause the pattern matcher to find unintended -# matches. The size of the ring buffer is EVENT_BUFFER_SIZE, which is -# currently set to 30 (or 45 on macOS). If this changes, the code -# below will need to change. -proc clearRingBuffer {{event}} { - for {set i 0} {$i < 45} {incr i} { - event generate . $event - } -} - # move the mouse pointer away of the testing area # otherwise some spurious events may pollute the tests toplevel .top @@ -310,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 @@ -325,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} @@ -355,11 +342,11 @@ test bind-9.2 {Tk_DeleteBinding procedure} -setup { } -body { frame .t.f -class Test -width 150 -height 100 foreach i {a b c d} { - bind .t.f $i "binding for $i" + bind .t.f $i "binding for $i" } foreach i {b d a c} { - bind .t.f $i {} - lappend result [lsort [bind .t.f]] + bind .t.f $i {} + lappend result [lsort [bind .t.f]] } return $result } -cleanup { @@ -369,12 +356,12 @@ 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>} { - bind .t.f $i "binding for $i" + 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>} { - bind .t.f $i {} - lappend result [lsort [bind .t.f]] + foreach i {<Control-Button-1> <Double-Alt-Button-1> <Button-1> <Meta-Button-1>} { + bind .t.f $i {} + lappend result [lsort [bind .t.f]] } return $result } -cleanup { @@ -398,7 +385,7 @@ test bind-10.2 {Tk_GetBinding procedure} -body { test bind-11.1 {Tk_GetAllBindings procedure} -body { frame .t.f foreach i "! a \\\{ ~ <Delete> <space> <<Paste>> <Tab> <Linefeed> <less> <Meta-a> <Acircumflex>" { - bind .t.f $i Test + bind .t.f $i Test } lsort [bind .t.f] } -cleanup { @@ -406,8 +393,8 @@ 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>" { - bind .t.f $i Test + 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] } -cleanup { @@ -415,8 +402,8 @@ 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" { - bind .t.f $i Test + foreach i "<Double-Triple-Button-1> abcd a<Leave>b" { + bind .t.f $i Test } lsort [bind .t.f] } -cleanup { @@ -430,8 +417,8 @@ 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>" { - bind .t.f $i x + foreach i "a b c <Meta-Button-1> <Alt-a> <Control-a>" { + bind .t.f $i x } destroy .t.f } -result {} @@ -443,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 @@ -468,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 { @@ -488,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 @@ -504,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 @@ -547,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 : {} @@ -564,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 : {} @@ -579,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 @@ -629,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 { @@ -948,13 +935,13 @@ test bind-13.33 {Tk_BindEvent procedure: many C bindings cause realloc} -setup { set x {} } -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" + foreach p [bindtags .t.f] { + 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 { @@ -979,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 @@ -992,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 @@ -1107,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> @@ -1139,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> @@ -1156,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> @@ -1175,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 @@ -1190,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 @@ -1203,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 @@ -1216,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 @@ -1233,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 @@ -1248,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 @@ -1260,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> @@ -1277,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> @@ -1294,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> @@ -1311,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> @@ -1328,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> @@ -1345,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> @@ -1362,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> @@ -1379,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> @@ -1395,9 +1382,8 @@ test bind-15.22 {MatchPatterns procedure, time wrap-around} -setup { pack .t.f focus -force .t.f update - clearRingBuffer <Key> } -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 @@ -1411,9 +1397,8 @@ test bind-15.23 {MatchPatterns procedure, time wrap-around} -setup { pack .t.f focus -force .t.f update - clearRingBuffer <Key> } -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 @@ -1428,7 +1413,6 @@ test bind-15.24 {MatchPatterns procedure, virtual event} -setup { focus -force .t.f update set x {} - clearRingBuffer <Key> } -body { event add <<Paste>> <Button-1> bind .t.f <<Paste>> {lappend x paste} @@ -1445,7 +1429,6 @@ test bind-15.25 {MatchPatterns procedure, reject a virtual event} -setup { focus -force .t.f update set x {} - clearRingBuffer <Key> } -body { event add <<Paste>> <Shift-Button-1> bind .t.f <<Paste>> {lappend x paste} @@ -1462,7 +1445,6 @@ test bind-15.26 {MatchPatterns procedure, reject a virtual event} -setup { focus -force .t.f update set x {} - clearRingBuffer <Key> } -body { event add <<V1>> <Button> event add <<V2>> <Button-1> @@ -1489,9 +1471,8 @@ test bind-15.27 {MatchPatterns procedure, conflict resolution} -setup { pack .t.f focus -force .t.f update - clearRingBuffer <Button> } -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> @@ -1504,9 +1485,8 @@ test bind-15.28 {MatchPatterns procedure, conflict resolution} -setup { pack .t.f focus -force .t.f update - clearRingBuffer <Button> } -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> @@ -1519,9 +1499,8 @@ test bind-15.29 {MatchPatterns procedure, conflict resolution} -setup { pack .t.f focus -force .t.f update - clearRingBuffer <Button> } -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 @@ -1537,10 +1516,9 @@ test bind-15.30 {MatchPatterns procedure, conflict resolution} -setup { pack .t.f focus -force .t.f update - clearRingBuffer <Key> } -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> @@ -1554,11 +1532,10 @@ test bind-15.31 {MatchPatterns procedure, conflict resolution} -setup { focus -force .t.f update set x {} - clearRingBuffer <Button> } -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 @@ -1568,12 +1545,11 @@ test bind-15.32 {MatchPatterns procedure, conflict resolution} -setup { pack .t.f focus -force .t.f update - clearRingBuffer <Button> } -body { 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 @@ -1584,11 +1560,10 @@ test bind-15.33 {MatchPatterns procedure, conflict resolution} -setup { focus -force .t.f update set x {} - clearRingBuffer <Key> } -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> @@ -1596,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)} @@ -1934,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> @@ -2058,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 @@ -2110,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 @@ -2130,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 @@ -2143,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 @@ -2216,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 @@ -2232,13 +2207,12 @@ test bind-16.46 {ExpandPercents procedure} -setup { focus -force .t.e foreach p [event info] {event delete $p} update - clearRingBuffer <Button> } -body { bind all <Key> {set z "%M"} 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 @@ -2272,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>> @@ -2289,11 +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>> <3> t + event delete <<Paste>> + event delete <<Paste>> <Button-3> t } -result {<Button-3> t} test bind-17.10 {event command: delete all} -body { event add <<Paste>> a b @@ -2341,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 @@ -2590,6 +2565,7 @@ test bind-19.15 {DeleteVirtualEvent procedure: owned by many, first} -setup { pack [frame .t.f -class Test -width 150 -height 100] pack [frame .t.g -class Test -width 150 -height 100] pack [frame .t.h -class Test -width 150 -height 100] + after 250 ;# we need a bit time to ensure that .t.h is mapped (<TODO>: fix this race condition) focus -force .t.f update set x {} @@ -2626,6 +2602,7 @@ test bind-19.16 {DeleteVirtualEvent procedure: owned by many, middle} -setup { pack [frame .t.f -class Test -width 150 -height 100] pack [frame .t.g -class Test -width 150 -height 100] pack [frame .t.h -class Test -width 150 -height 100] + after 250 ;# we need a bit time to ensure that .t.h is mapped (<TODO>: fix this race condition) focus -force .t.f update set x {} @@ -2662,6 +2639,7 @@ test bind-19.17 {DeleteVirtualEvent procedure: owned by many, last} -setup { pack [frame .t.f -class Test -width 150 -height 100] pack [frame .t.g -class Test -width 150 -height 100] pack [frame .t.h -class Test -width 150 -height 100] + after 250 ;# we need a bit time to ensure that .t.h is mapped (<TODO>: fix this race condition) focus -force .t.f update set x {} @@ -2706,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>> @@ -2737,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>> @@ -2774,7 +2752,7 @@ test bind-22.5 {HandleEventGenerate} -body { } -returnCodes error -result {bad event type or keysym "xyz"} test bind-22.6 {HandleEventGenerate} -body { event generate . <Double-Button-1> -} -returnCodes error -result {Double or Triple modifier not allowed} +} -returnCodes error -result {Double, Triple, or Quadruple modifier not allowed} test bind-22.7 {HandleEventGenerate} -body { event generate . xyz } -returnCodes error -result {only one event specification allowed} @@ -2806,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 @@ -3928,7 +3906,7 @@ test bind-22.92 {HandleEventGenerate: options <Key> -sendevent 43} -setup { return $x } -cleanup { destroy .t.f -} -result {43} +} -result {1} test bind-22.93 {HandleEventGenerate: options <Key> -serial xyz} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4942,7 +4920,7 @@ test bind-24.3 {FindSequence procedure: virtual allowed} -setup { destroy .t.f } -result {} test bind-24.4 {FindSequence procedure: virtual not allowed} -body { - event add <<Paste>> <<Alive>> + event add <<Paste>> <<Alive>> } -returnCodes error -result {virtual event not allowed in definition of another virtual event} test bind-24.5 {FindSequence procedure, multiple bindings} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4950,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> @@ -5121,9 +5099,13 @@ test bind-25.3 {ParseEventDescription procedure} -setup { } -cleanup { destroy .t.f } -result a -test bind-25.4 {ParseEventDescription} -body { - bind .t <<Shift-Paste>> {puts hi} - bind .t +test bind-25.4 {ParseEventDescription} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <<Shift-Paste>> {puts hi} + bind .t.f +} -cleanup { + destroy .t.f } -result {<<Shift-Paste>>} # Assorted error cases in event sequence parsing @@ -5170,310 +5152,346 @@ test bind-25.17 {ParseEventDescription} -body { # Modifier canonicalization tests test bind-25.18 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { bind .t.f {<Control- a>} foo - bind .t.f + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Control-Key-a> test bind-25.19 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Shift-a> foo - bind .t.f + bind .t.f <Shift-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Shift-Key-a> test bind-25.20 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Lock-a> foo - bind .t.f + bind .t.f <Lock-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Lock-Key-a> test bind-25.21 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Meta---a> foo - bind .t.f + bind .t.f <Meta---a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Meta-Key-a> test bind-25.22 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <M-a> foo - bind .t.f + bind .t.f <M-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Meta-Key-a> test bind-25.23 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Alt-a> foo - bind .t.f + bind .t.f <Alt-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Alt-Key-a> test bind-25.24 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <B1-a> foo - bind .t.f + bind .t.f <B1-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <B1-Key-a> test bind-25.25 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <B2-a> foo - bind .t.f + bind .t.f <B2-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <B2-Key-a> test bind-25.26 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <B3-a> foo - bind .t.f + bind .t.f <B3-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <B3-Key-a> test bind-25.27 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <B4-a> foo - bind .t.f + bind .t.f <B4-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <B4-Key-a> test bind-25.28 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <B5-a> foo - bind .t.f + bind .t.f <B5-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <B5-Key-a> test bind-25.29 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Button1-a> foo - bind .t.f + bind .t.f <Button1-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <B1-Key-a> test bind-25.30 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Button2-a> foo - bind .t.f + bind .t.f <Button2-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <B2-Key-a> test bind-25.31 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Button3-a> foo - bind .t.f + bind .t.f <Button3-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <B3-Key-a> test bind-25.32 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Button4-a> foo - bind .t.f + bind .t.f <Button4-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <B4-Key-a> test bind-25.33 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Button5-a> foo - bind .t.f + bind .t.f <Button5-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <B5-Key-a> test bind-25.34 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <M1-a> foo - bind .t.f + bind .t.f <M1-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Mod1-Key-a> test bind-25.35 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <M2-a> foo - bind .t.f + bind .t.f <M2-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Mod2-Key-a> test bind-25.36 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <M3-a> foo - bind .t.f + bind .t.f <M3-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Mod3-Key-a> test bind-25.37 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <M4-a> foo - bind .t.f + bind .t.f <M4-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Mod4-Key-a> test bind-25.38 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <M5-a> foo - bind .t.f + bind .t.f <M5-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Mod5-Key-a> test bind-25.39 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Mod1-a> foo - bind .t.f + bind .t.f <Mod1-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Mod1-Key-a> test bind-25.40 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Mod2-a> foo - bind .t.f + bind .t.f <Mod2-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Mod2-Key-a> test bind-25.41 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Mod3-a> foo - bind .t.f + bind .t.f <Mod3-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Mod3-Key-a> test bind-25.42 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Mod4-a> foo - bind .t.f + bind .t.f <Mod4-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Mod4-Key-a> test bind-25.43 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Mod5-a> foo - bind .t.f + bind .t.f <Mod5-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Mod5-Key-a> test bind-25.44 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Double-a> foo - bind .t.f + bind .t.f <Double-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Double-Key-a> test bind-25.45 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Triple-a> foo - bind .t.f + bind .t.f <Triple-a> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Triple-Key-a> test bind-25.46 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f {<Double 1>} foo - bind .t.f + bind .t.f {<Double 1>} foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Double-Button-1> test bind-25.47 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Triple-1> foo - bind .t.f + bind .t.f <Triple-1> foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Triple-Button-1> test bind-25.48 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f {<M1-M2 M3-M4 B1-Control-a>} foo - bind .t.f + bind .t.f {<M1-M2 M3-M4 B1-Control-a>} foo + bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <Control-B1-Mod1-Mod2-Mod3-Mod4-Key-a> test bind-25.49 {modifier names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <Extended-Return> foo - bind .t.f + bind .t.f <Extended-Return> foo + bind .t.f } -cleanup { - destroy .t.f + 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 { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { bind .t.f <FocusIn> {nothing} bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <FocusIn> test bind-26.2 {event names} -setup { - frame .t.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { bind .t.f <FocusOut> {nothing} bind .t.f } -cleanup { - destroy .t.f + destroy .t.f } -result <FocusOut> test bind-26.3 {event names} -setup { frame .t.f -class Test -width 150 -height 100 @@ -5495,12 +5513,12 @@ test bind-26.4 {event names: Motion} -setup { focus -force .t.f update } -body { - bind .t.f <Motion> "set x {event Motion}" - set x xyzzy - event generate .t.f <Motion> - list $x [bind .t.f] + bind .t.f <Motion> "set x {event Motion}" + set x xyzzy + event generate .t.f <Motion> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Motion} <Motion>} test bind-26.5 {event names: Button} -setup { @@ -5509,12 +5527,12 @@ test bind-26.5 {event names: Button} -setup { focus -force .t.f update } -body { - bind .t.f <Button> "set x {event Button}" - set x xyzzy - event generate .t.f <Button> - list $x [bind .t.f] + bind .t.f <Button> "set x {event Button}" + set x xyzzy + event generate .t.f <Button> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Button} <Button>} test bind-26.6 {event names: ButtonPress} -setup { @@ -5523,12 +5541,12 @@ test bind-26.6 {event names: ButtonPress} -setup { focus -force .t.f update } -body { - bind .t.f <ButtonPress> "set x {event ButtonPress}" - set x xyzzy - event generate .t.f <ButtonPress> - list $x [bind .t.f] + bind .t.f <ButtonPress> "set x {event ButtonPress}" + set x xyzzy + event generate .t.f <ButtonPress> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event ButtonPress} <Button>} test bind-26.7 {event names: ButtonRelease} -setup { @@ -5537,12 +5555,12 @@ test bind-26.7 {event names: ButtonRelease} -setup { focus -force .t.f update } -body { - bind .t.f <ButtonRelease> "set x {event ButtonRelease}" - set x xyzzy - event generate .t.f <ButtonRelease> - list $x [bind .t.f] + bind .t.f <ButtonRelease> "set x {event ButtonRelease}" + set x xyzzy + event generate .t.f <ButtonRelease> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event ButtonRelease} <ButtonRelease>} test bind-26.8 {event names: Colormap} -setup { @@ -5551,12 +5569,12 @@ test bind-26.8 {event names: Colormap} -setup { focus -force .t.f update } -body { - bind .t.f <Colormap> "set x {event Colormap}" - set x xyzzy - event generate .t.f <Colormap> - list $x [bind .t.f] + bind .t.f <Colormap> "set x {event Colormap}" + set x xyzzy + event generate .t.f <Colormap> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Colormap} <Colormap>} test bind-26.9 {event names: Enter} -setup { @@ -5565,12 +5583,12 @@ test bind-26.9 {event names: Enter} -setup { focus -force .t.f update } -body { - bind .t.f <Enter> "set x {event Enter}" - set x xyzzy - event generate .t.f <Enter> - list $x [bind .t.f] + bind .t.f <Enter> "set x {event Enter}" + set x xyzzy + event generate .t.f <Enter> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Enter} <Enter>} test bind-26.10 {event names: Leave} -setup { @@ -5579,12 +5597,12 @@ test bind-26.10 {event names: Leave} -setup { focus -force .t.f update } -body { - bind .t.f <Leave> "set x {event Leave}" - set x xyzzy - event generate .t.f <Leave> - list $x [bind .t.f] + bind .t.f <Leave> "set x {event Leave}" + set x xyzzy + event generate .t.f <Leave> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Leave} <Leave>} test bind-26.11 {event names: Expose} -setup { @@ -5593,12 +5611,12 @@ test bind-26.11 {event names: Expose} -setup { focus -force .t.f update } -body { - bind .t.f <Expose> "set x {event Expose}" - set x xyzzy - event generate .t.f <Expose> - list $x [bind .t.f] + bind .t.f <Expose> "set x {event Expose}" + set x xyzzy + event generate .t.f <Expose> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Expose} <Expose>} test bind-26.12 {event names: Key} -setup { @@ -5607,12 +5625,12 @@ test bind-26.12 {event names: Key} -setup { focus -force .t.f update } -body { - bind .t.f <Key> "set x {event Key}" - set x xyzzy - event generate .t.f <Key> - list $x [bind .t.f] + bind .t.f <Key> "set x {event Key}" + set x xyzzy + event generate .t.f <Key> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Key} <Key>} test bind-26.13 {event names: KeyPress} -setup { @@ -5621,12 +5639,12 @@ test bind-26.13 {event names: KeyPress} -setup { focus -force .t.f update } -body { - bind .t.f <KeyPress> "set x {event KeyPress}" - set x xyzzy - event generate .t.f <KeyPress> - list $x [bind .t.f] + bind .t.f <KeyPress> "set x {event KeyPress}" + set x xyzzy + event generate .t.f <KeyPress> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event KeyPress} <Key>} test bind-26.14 {event names: KeyRelease} -setup { @@ -5635,12 +5653,12 @@ test bind-26.14 {event names: KeyRelease} -setup { focus -force .t.f update } -body { - bind .t.f <KeyRelease> "set x {event KeyRelease}" - set x xyzzy - event generate .t.f <KeyRelease> - list $x [bind .t.f] + bind .t.f <KeyRelease> "set x {event KeyRelease}" + set x xyzzy + event generate .t.f <KeyRelease> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event KeyRelease} <KeyRelease>} test bind-26.15 {event names: Property} -setup { @@ -5649,12 +5667,12 @@ test bind-26.15 {event names: Property} -setup { focus -force .t.f update } -body { - bind .t.f <Property> "set x {event Property}" - set x xyzzy - event generate .t.f <Property> - list $x [bind .t.f] + bind .t.f <Property> "set x {event Property}" + set x xyzzy + event generate .t.f <Property> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Property} <Property>} test bind-26.16 {event names: Visibility} -setup { @@ -5663,12 +5681,12 @@ test bind-26.16 {event names: Visibility} -setup { focus -force .t.f update } -body { - bind .t.f <Visibility> "set x {event Visibility}" - set x xyzzy - event generate .t.f <Visibility> - list $x [bind .t.f] + bind .t.f <Visibility> "set x {event Visibility}" + set x xyzzy + event generate .t.f <Visibility> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Visibility} <Visibility>} test bind-26.17 {event names: Activate} -setup { @@ -5677,12 +5695,12 @@ test bind-26.17 {event names: Activate} -setup { focus -force .t.f update } -body { - bind .t.f <Activate> "set x {event Activate}" - set x xyzzy - event generate .t.f <Activate> - list $x [bind .t.f] + bind .t.f <Activate> "set x {event Activate}" + set x xyzzy + event generate .t.f <Activate> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Activate} <Activate>} test bind-26.18 {event names: Deactivate} -setup { @@ -5691,12 +5709,12 @@ test bind-26.18 {event names: Deactivate} -setup { focus -force .t.f update } -body { - bind .t.f <Deactivate> "set x {event Deactivate}" - set x xyzzy - event generate .t.f <Deactivate> - list $x [bind .t.f] + bind .t.f <Deactivate> "set x {event Deactivate}" + set x xyzzy + event generate .t.f <Deactivate> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Deactivate} <Deactivate>} @@ -5707,12 +5725,12 @@ test bind-26.19 {event names: Circulate} -setup { focus -force .t.f update } -body { - bind .t.f <Circulate> "set x {event Circulate}" - set x xyzzy - event generate .t.f <Circulate> - list $x [bind .t.f] + bind .t.f <Circulate> "set x {event Circulate}" + set x xyzzy + event generate .t.f <Circulate> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Circulate} <Circulate>} test bind-26.20 {event names: Configure} -setup { @@ -5721,12 +5739,12 @@ test bind-26.20 {event names: Configure} -setup { focus -force .t.f update } -body { - bind .t.f <Configure> "set x {event Configure}" - set x xyzzy - event generate .t.f <Configure> - list $x [bind .t.f] + bind .t.f <Configure> "set x {event Configure}" + set x xyzzy + event generate .t.f <Configure> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Configure} <Configure>} test bind-26.21 {event names: Gravity} -setup { @@ -5735,12 +5753,12 @@ test bind-26.21 {event names: Gravity} -setup { focus -force .t.f update } -body { - bind .t.f <Gravity> "set x {event Gravity}" - set x xyzzy - event generate .t.f <Gravity> - list $x [bind .t.f] + bind .t.f <Gravity> "set x {event Gravity}" + set x xyzzy + event generate .t.f <Gravity> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Gravity} <Gravity>} test bind-26.22 {event names: Map} -setup { @@ -5749,12 +5767,12 @@ test bind-26.22 {event names: Map} -setup { focus -force .t.f update } -body { - bind .t.f <Map> "set x {event Map}" - set x xyzzy - event generate .t.f <Map> - list $x [bind .t.f] + bind .t.f <Map> "set x {event Map}" + set x xyzzy + event generate .t.f <Map> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Map} <Map>} test bind-26.23 {event names: Reparent} -setup { @@ -5763,12 +5781,12 @@ test bind-26.23 {event names: Reparent} -setup { focus -force .t.f update } -body { - bind .t.f <Reparent> "set x {event Reparent}" - set x xyzzy - event generate .t.f <Reparent> - list $x [bind .t.f] + bind .t.f <Reparent> "set x {event Reparent}" + set x xyzzy + event generate .t.f <Reparent> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Reparent} <Reparent>} test bind-26.24 {event names: Unmap} -setup { @@ -5777,12 +5795,12 @@ test bind-26.24 {event names: Unmap} -setup { focus -force .t.f update } -body { - bind .t.f <Unmap> "set x {event Unmap}" - set x xyzzy - event generate .t.f <Unmap> - list $x [bind .t.f] + bind .t.f <Unmap> "set x {event Unmap}" + set x xyzzy + event generate .t.f <Unmap> + list $x [bind .t.f] } -cleanup { - destroy .t.f + destroy .t.f } -result {{event Unmap} <Unmap>} @@ -5791,7 +5809,7 @@ test bind-27.1 {button names} -body { } -returnCodes error -result {specified button "1" for non-button event} test bind-27.2 {button names} -body { bind .t <Button-10> foo -} -returnCodes error -result {bad event type or keysym "10"} +} -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 @@ -5926,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 @@ -5942,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 @@ -5956,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 @@ -5970,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 @@ -5984,17 +6002,45 @@ 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 } -result {X x {keysym X}} +test bind-28.9 {keysym names, Eth -> ETH} -body { + frame .t.f -class Test -width 150 -height 100 + bind .t.f <Eth> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result {<Key-ETH>} +test bind-28.10 {keysym names, Ooblique -> Oslash} -body { + frame .t.f -class Test -width 150 -height 100 + bind .t.f <Ooblique> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result {<Key-Oslash>} +test bind-28.11 {keysym names, gcedilla} -body { + frame .t.f -class Test -width 150 -height 100 + bind .t.f <gcedilla> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result {<Key-gcedilla>} +test bind-28.12 {keysym names, Greek_IOTAdiaeresis -> Greek_IOTAdieresis} -body { + frame .t.f -class Test -width 150 -height 100 + bind .t.f <Greek_IOTAdiaeresis> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result {<Key-Greek_IOTAdieresis>} -test bind-29.1 {Tk_BackgroundError procedure} -setup { +test bind-29.1 {Tcl_BackgroundError procedure} -setup { proc bgerror msg { global x errorInfo set x [list $msg $errorInfo] @@ -6018,7 +6064,7 @@ test bind-29.1 {Tk_BackgroundError procedure} -setup { "error "This is a test"" (command bound to event)}} -test bind-29.2 {Tk_BackgroundError procedure} -setup { +test bind-29.2 {Tcl_BackgroundError procedure} -setup { proc do {} { event generate .t.f <Button> event generate .t.f <ButtonRelease> @@ -6182,7 +6228,7 @@ test bind-31.7 {virtual event user_data field - unshared, asynch} -setup { destroy .t.f } -result {{} {} {TestUserData >b<}} -test bind-32 {-warp, window was destroyed before the idle callback DoWarp} -setup { +test bind-32.1 {-warp, window was destroyed before the idle callback DoWarp} -setup { frame .t.f pack .t.f focus -force .t.f @@ -6194,12 +6240,691 @@ test bind-32 {-warp, window was destroyed before the idle callback DoWarp} -setu update ; # shall simply not crash } -cleanup { } -result {} +test bind-32.2 {detection of double click should not fail} -setup { + pack [frame .t.f] + focus -force .t.f + bind .t.f <Double-Button-1> { set x "Double" } + update + set x {} +} -body { + 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. + # But new implementation should work properly. + for {set i 0} {$i < 1000} {incr i} { + event generate .t.f <Expose> + } + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> + set x +} -cleanup { + destroy .t.f +} -result {Double} +test bind-32.3 {should trigger best match of modifier states} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + 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 +} -result {Shift-Control} +test bind-32.4 {should not trigger Double-1} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Double-Button-1> { set x "Double" } + event generate .t.f <Button-1> -time current + after 1000 + event generate .t.f <Button-1> -time current + set x +} -cleanup { + destroy .t.f +} -result {} +test bind-32.5 {should trigger Quadruple-1} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + 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 + event generate .t.f <Button-1> -time 400 + event generate .t.f <Button-1> -time 800 + event generate .t.f <Button-1> -time 1200 + set x +} -cleanup { + destroy .t.f +} -result {Quadruple} +test bind-32.6 {problem with sendevent} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + # Old implementation was losing sendevent value + bind .t.f <FocusIn> { set x "sendevent=%E" } + event generate .t.f <FocusIn> -sendevent 1 + set x +} -cleanup { + destroy .t.f +} -result {sendevent=1} +test bind-32.7 {test sequences} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + 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 { + destroy .t.f +} -result {Double 11} +test bind-32.8 {test sequences} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + bind .t.f <a><Button-1><Double-Button-1><Button-1><a> { lappend x "Double" } + event generate .t.f <a> + 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 { + destroy .t.f +} -result {Double} +test bind-32.9 {trigger events for modifier keys} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Key> { set x "Key" } + event generate .t.f <Key> -keysym Caps_Lock + set x +} -cleanup { + destroy .t.f +} -result {Key} +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 <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 <A> { set x "A" } + bind .t.f <Double-A> { set x "AA" } + event generate .t.f <A> + destroy .t.f + set x +} -result {A} +test bind-32.11 {match detailed virtual} -setup { + pack [frame .t.f -class Test] + focus -force .t.f + update + set x {} +} -body { + event add <<TestControlButton1>> <Control-Button-1> + 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-Button-1> + set x +} -cleanup { + destroy .t.f + event delete <<TestControlButton1>> + bind Test <Button-1> {#} +} -result {Control-Button-1} +test bind-32.12 {don't detect repetition when window has changed} -setup { + pack [frame .t.f] + pack [frame .t.g] + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Button-1> { set x "1" } + bind .t.f <Double-Button-1> { set x "11" } + event generate .t.f <Button-1> + event generate .t.g <Button-1> + event generate .t.f <Button-1> + set x +} -cleanup { + destroy .t.f + destroy .t.g +} -result {1} +test bind-32.13 {don't detect repetition when window has changed} -setup { + pack [frame .t.f] + pack [frame .t.g] + update + set x {} +} -body { + 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 + destroy .t.g +} -result {A} +test bind-32.14 {don't detect repetition when window has changed} -setup { + pack [frame .t.f] + pack [frame .t.g] + update + set x {} +} -body { + 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 + destroy .t.g +} -result {1} +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 <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 <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} +test bind-33.1 {prefer longest match} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + 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 <Button-1> + event generate .t.f <Button-1> + set x +} -cleanup { + destroy .t.f +} -result {a11} +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-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 +} -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-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 <Button-1> + event generate .t.f <Button-1> + event generate .t.f <a> + set x +} -cleanup { + destroy .t.f +} -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 <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 +} -result {11} +test bind-33.5 {prefer most specific event} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + 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 +} -result {11} +test bind-33.6 {prefer most specific event} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + 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 <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 { + destroy .t.f +} -result {1111} +test bind-33.7 {prefer most specific event} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + 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 { + destroy .t.f +} -result {1} +test bind-33.8 {prefer most specific event} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + 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 { + destroy .t.f +} -result {1} +test bind-33.9 {prefer last in case of homogeneous equal patterns} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + 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 +} -result {last} +test bind-33.10 {prefer last in case of homogeneous equal patterns} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + 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 +} -result {last} +test bind-33.11 {should prefer most specific} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + 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 +} -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-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 +} -result {last} +test bind-33.13 {prefer last in case of homogeneous equal patterns} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + 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 + # Old implementation failed, and returned "first", but this was wrong, + # because both bindings are homogeneous equal, so the most recently defined + # must be preferred. +} -result {last} +test bind-33.14 {prefer last in case of homogeneous equal patterns} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + 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 +} -result {last} +test bind-33.15 {prefer last in case of homogeneous equal patterns} -setup { + pack [frame .t.f] + focus -force .t.f + update + set x {} +} -body { + 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 + # Old implementation failed, and returned "first", but this was wrong, + # because both bindings are homogeneous equal, so the most recently defined + # must be preferred. +} -result {last} + +test bind-34.1 {-warp works relatively to a window} -setup { + toplevel .top + wm geometry .top +100+100 + update +} -body { + # In order to avoid platform-dependent coordinate results due to + # decorations and borders, this test warps the pointer twice + # relatively to a window that moved in the meantime, and checks + # how much the pointer moved + wm geometry .top +200+200 + update + event generate .top <Motion> -x 20 -y 20 -warp 1 + update idletasks ; # DoWarp is an idle callback + after 50 ; # Win specific - wait for SendInput to be executed + set pointerPos1 [winfo pointerxy .t] + wm geometry .top +600+600 + update + event generate .top <Motion> -x 20 -y 20 -warp 1 + update idletasks ; # DoWarp is an idle callback + after 50 ; # Win specific - wait for SendInput to be executed + set pointerPos2 [winfo pointerxy .t] + # from the first warped position to the second one, the mouse + # pointer should have moved the same amount as the window moved + set res 1 + foreach pos1 $pointerPos1 pos2 $pointerPos2 { + if {$pos1 != [expr {$pos2 - 400}]} { + set res [list $pointerPos1 $pointerPos2] + } + } + set res +} -cleanup { + destroy .top +} -result {1} +test bind-34.2 {-warp works relatively to the screen} -setup { +} -body { + # Contrary to bind-34.1, we're directly checking screen coordinates + event generate {} <Motion> -x 20 -y 20 -warp 1 + update idletasks ; # DoWarp is an idle callback + after 50 ; # Win specific - wait for SendInput to be executed + set res [winfo pointerxy .] + event generate {} <Motion> -x 200 -y 200 -warp 1 + update idletasks ; # DoWarp is an idle callback + after 50 ; # Win specific - wait for SendInput to be executed + lappend res {*}[winfo pointerxy .] +} -cleanup { +} -result {20 20 200 200} +test bind-34.3 {-warp works with null or negative coordinates} -setup { + # On some OS/WM, at least Linux with KDE, the "Screen edges" feature + # provides hot spots that can be associated with some action. + # When activated, the WM will not allow warping to happen on top of + # a hot spot (which would trigger the corresponding action as an + # unwanted effect) but will warp the pointer to the hot spot limit only. + if {[tk windowingsystem] eq "x11"} { + set halo 1 + } else { + set halo 0 + } + set res {} +} -body { + event generate {} <Motion> -x 0 -y 0 -warp 1 + update idletasks ; # DoWarp is an idle callback + after 50 ; # Win specific - wait for SendInput to be executed + foreach dim [winfo pointerxy .] { + if {$dim <= $halo} { + lappend res ok + } else { + lappend res $dim + } + } + event generate {} <Motion> -x 100 -y 100 -warp 1 + update idletasks ; after 50 + event generate {} <Motion> -x -1 -y -1 -warp 1 + update idletasks ; after 50 + foreach dim [winfo pointerxy .] { + if {$dim <= $halo} { + lappend res ok + } else { + lappend res $dim + } + } + set res +} -cleanup { +} -result {ok ok ok ok} + +set keyInfo {} +set numericKeysym {} +proc testKey {window event type mods} { + global keyInfo numericKeysym + set keyInfo {} + set numericKeysym {} + bind $window <KeyPress> { + set keyInfo [format "%K,0x%%X,0x%%X,%A" %N %k] + set numericKeysym %N + } + focus -force $window + update + event generate $window $event + if {$keyInfo == {}} { + vwait keyInfo + } + set save $keyInfo + set keyInfo {} + set injectcmd [list injectkeyevent $type $numericKeysym] + foreach {option} $mods { + lappend injectcmd $option + } + eval $injectcmd + if {$keyInfo == {}} { + vwait keyInfo + } + if {$save != $keyInfo} { + return "[format "0x%x" $numericKeysym] ($mods): $save != $keyInfo" + } + return pass +} +proc testKeyWithMods {window keysym type} { + set result [testKey $window "<$keysym>" $type {}] + if {$result != {pass}} { + return $result + } + set result [testKey $window "<Shift-$keysym>" $type {-shift}] + if {$result != {pass}} { + return $result + } + set result [testKey $window "<Option-$keysym>" $type {-option}] + if {$result != {pass}} { + return $result + } + set result [testKey $window "<Shift-Option-$keysym>" $type {-shift -option}] + if {$result != {pass}} { + return $result + } + return pass +} +test bind-35.0 {Generated and real key events agree} -constraints {aqua} -body { + foreach k {o O F2 Home Right Greek_sigma Greek_ALPHA} { + set result [testKeyWithMods . $k press] + if {$result != "pass"} { + return $result + } + } + return pass +} -cleanup { +} -result pass + +test bind-35.1 {Key events agree for entry widgets} -constraints {aqua} -setup { + toplevel .new + entry .new.e + pack .new.e +} -body { + foreach k {o O F2 Home Right Greek_sigma Greek_ALPHA Menu} { + set result [testKeyWithMods .new.e $k press] + if {$result != "pass"} { + return $result + } + } + return pass +} -cleanup { + destroy .new.e + destroy .new +} -result pass + +test bind-35.2 {Can bind to function keys} -constraints {aqua} -body { + global keyInfo numericKeysym + bind . <KeyPress> {} + bind . <KeyPress> { + lappend keyInfo %K + set numericKeysym %N + } + set keyInfo {} + set numericKeysym {} + focus -force . + event generate . <F2> + injectkeyevent press $numericKeysym -function + vwait keyInfo + return $keyInfo +} -cleanup { +} -result {F2 F2} + +test bind-35.3 {Events agree for modifier keys} -constraints {aqua} -setup { +} -body { + global keyInfo numericalKeysym + set result {} + bind . <KeyPress> { + set keyInfo [format "%K,0x%%X,0x%%X,%A" %N %k] + set numericalKeysym [format "0x%x" %N] + } + foreach event { + {<Control_L> -control} + {<Control_R> -control} + {<Alt_L> -option} + {<Alt_R> -option} + {<Meta_L> -command} + {<Meta_R> -command} + {<Shift_L> -shift} + {<Shift_R> -shift} + } { + set keyInfo {} + event generate . [lindex $event 0] + if {$keyInfo == {}} { + vwait keyInfo + } + set save $keyInfo + injectkeyevent flagschanged $numericKeysym [lindex $event 1] + if {$keyInfo == {}} { + vwait keyInfo + } + if {$save != $keyInfo} { + return "$save != $keyInfo" + } + } + return pass +} -cleanup { +} -result pass # cleanup cleanupTests return +# vi:set ts=4 sw=4 et: # Local Variables: # mode: tcl # End: diff --git a/tests/bugs.tcl b/tests/bugs.tcl deleted file mode 100644 index 55e5f84..0000000 --- a/tests/bugs.tcl +++ /dev/null @@ -1,41 +0,0 @@ -# This file is a Tcl script to test out various known bugs that will -# cause Tk to crash. This file ends with .tcl instead of .test to make -# sure it isn't run when you type "source all". We currently are not -# shipping this file with the rest of the source release. -# -# Copyright (c) 1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {[info procs test] != "test"} { - source defs -} - -test crash-1.0 {imgPhoto} { - image create photo p1 - image create photo p2 - catch {image create photo p2 -file bogus} - p1 copy p2 - label .l -image p1 - destroy .l - set foo "" -} {} - -test crash-1.1 {color} { - . configure -bg rgb:345 - set foo "" -} {} - - - - - - - - - - - - - diff --git a/tests/button.test b/tests/button.test index 47d4296..f3292b31 100644 --- a/tests/button.test +++ b/tests/button.test @@ -3444,12 +3444,12 @@ test button-5.24 {ConfigureButton - computing geometry} -constraints { set expectedwidth [expr {$textwidth + 2*[.b cget -borderwidth] \ + 2*[.b cget -highlightthickness] + 2*[.b cget -padx]}] incr expectedwidth 2 ; # added (hardcoded) in tkUnixButton.c - set result [expr $expectedwidth == [winfo reqwidth .b]] + set result [expr {$expectedwidth == [winfo reqwidth .b]}] set linespace [lindex [font metrics [.b cget -font] -displayof .b] 5] set expectedheight [expr {$linespace + 2*[.b cget -borderwidth] \ + 2*[.b cget -highlightthickness] + 2*[.b cget -pady]}] incr expectedheight 2 ; # added (hardcoded) in tkUnixButton.c - lappend result [expr $expectedheight == [winfo reqheight .b]] + lappend result [expr {$expectedheight == [winfo reqheight .b]}] # 2. button with a bitmap image # there is no access to characteristics the predefined bitmaps, # so define one as an image (copied from questhead.xbm) @@ -3468,11 +3468,11 @@ test button-5.24 {ConfigureButton - computing geometry} -constraints { set expectedwidth [expr {[image width $myquesthead] + 2*[.b cget -borderwidth] \ + 2*[.b cget -highlightthickness]}] incr expectedwidth 2 ; # added (hardcoded) in tkUnixButton.c - lappend result [expr $expectedwidth == [winfo reqwidth .b]] + lappend result [expr {$expectedwidth == [winfo reqwidth .b]}] set expectedheight [expr {[image height $myquesthead] + 2*[.b cget -borderwidth] \ + 2*[.b cget -highlightthickness]}] incr expectedheight 2 ; # added (hardcoded) in tkUnixButton.c - lappend result [expr $expectedheight == [winfo reqheight .b]] + lappend result [expr {$expectedheight == [winfo reqheight .b]}] } -cleanup { destroy .b } -result {1 1 1 1} @@ -3958,6 +3958,45 @@ test button-14.1 {bug fix: [011706ec42] tk::ButtonInvoke unsafe wrt widget destr destroy .top.b .top } -result {} +test button-15.1 {Bug [5d991b822e]} { + # Want this not to segfault + set var INIT + button .b -textvariable var + trace add variable var unset {apply {args { + .b configure -textvariable {} + }}} + pack .b + bind .b <Configure> {unset var} + update + destroy .b +} {} +test button-15.2 {Bug [5d991b822e]} { + # Want this not to leak traces + set var INIT + button .b -textvariable var + trace add variable var unset {apply {args { + .b configure -textvariable new + }}} + pack .b + bind .b <Configure> {unset -nocomplain var} + update + destroy .b + unset new +} {} +test button-15.3 {Bug [5d991b822e]} { + # Want this not to leak traces + set var INIT + checkbutton .b -variable var + trace add variable var unset {apply {args { + .b configure -variable {} + }}} + pack .b + bind .b <Configure> {unset var} + update + destroy .b +} {} + + imageFinish cleanupTests return diff --git a/tests/canvImg.test b/tests/canvImg.test index 84992f2..d6ed9a8 100644 --- a/tests/canvImg.test +++ b/tests/canvImg.test @@ -156,23 +156,30 @@ test canvImg-4.1 {ConfiugreImage procedure} -constraints testImageType -setup { .c delete all image delete foo } -result {{{foo free}} {}} -test canvImg-4.2 {ConfiugreImage procedure} -constraints testImageType -setup { +test canvImg-4.2 {ConfigureImage procedure} -constraints testImageType -setup { .c delete all } -body { - image create test foo -variable x + image create test foo -variable x image create test foo2 -variable y foo2 changed 0 0 0 0 80 60 .c create image 50 100 -image foo -tags i1 -anchor nw update set x {} set y {} + set timer [after 300 {lappend y "timed out"}] .c itemconfigure i1 -image foo2 + update idletasks update + # On MacOS we need to wait for the test image display procedure to run. + while {"timed out" ni $y && [lindex $y end 1] ne "display"} { + vwait y + } + after cancel timer list $x $y [.c bbox i1] } -cleanup { - .c delete all - image delete foo - image delete foo2 + .c delete all + image delete foo + image delete foo2 } -result {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60}} {50 100 130 160}} test canvImg-4.3 {ConfiugreImage procedure} -constraints testImageType -setup { .c delete all @@ -720,36 +727,48 @@ test canvImg-9.1 {DisplayImage procedure} -constraints testImageType -setup { image delete foo } -result {75 150 105 165} +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}} +} test canvImg-10.1 {TranslateImage procedure} -constraints testImageType -setup { .c delete all update } -body { - image create test foo -variable x + image create test foo -variable x .c create image 50 100 -image foo -tags image -anchor nw update set x {} + set timer [after 500 {lappend x "timed out"}] foo changed 2 4 6 8 30 15 + vwait x + after cancel $timer update return $x } -cleanup { - .c delete all - image delete foo -} -result {{foo display 2 4 6 8}} + .c delete all + image delete foo +} -result $result_10_1 test canvImg-11.1 {TranslateImage procedure} -constraints testImageType -setup { .c delete all update } -body { - image create test foo -variable x + image create test foo -variable x .c create image 50 100 -image foo -tags image -anchor nw update set x {} + set timer [after 500 {lappend x "timed out"}] foo changed 2 4 6 8 40 50 + vwait x + after cancel $timer update return $x } -cleanup { - .c delete all - image delete foo + .c delete all + image delete foo } -result {{foo display 0 0 40 50}} test canvImg-11.2 {ImageChangedProc procedure} -constraints { testImageType @@ -766,6 +785,12 @@ test canvImg-11.2 {ImageChangedProc procedure} -constraints { .c delete all image delete foo } -result {30 75 70 125} +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}} +} test canvImg-11.3 {ImageChangedProc procedure} -constraints { testImageType } -setup { @@ -773,21 +798,22 @@ test canvImg-11.3 {ImageChangedProc procedure} -constraints { update } -body { image create test foo -variable x - image create test foo2 -variable y + image create test foo2 -variable z foo changed 0 0 0 0 40 50 foo2 changed 0 0 0 0 80 60 - .c create image 50 100 -image foo -tags image -anchor nw .c create image 70 110 -image foo2 -anchor nw - update - set y {} + update idletasks + set z {} + set timer [after 500 {lappend z "timed out"}] image create test foo -variable x - update - return $y + vwait x + after cancel $timer + return $z } -cleanup { - .c delete all - image delete foo foo2 -} -result {{foo2 display 0 0 20 40}} + .c delete all + image delete foo foo2 +} -result $result_11_3 # cleanup imageFinish diff --git a/tests/canvPs.test b/tests/canvPs.test index c7ba958..eb09af9 100644 --- a/tests/canvPs.test +++ b/tests/canvPs.test @@ -19,17 +19,17 @@ pack .c update test canvPs-1.1 {test writing to a file} -constraints { - unixOrPc + unixOrWin } -setup { set foo [makeFile {} foo.ps] } -body { - .c postscript -file $foo - file exists $foo + set res [.c postscript -file $foo] + lappend res [file exists $foo] } -cleanup { removeFile foo.ps } -result 1 test canvPs-1.2 {test writing to a file, idempotency} -constraints { - unixOrPc + unixOrWin } -setup { set foo [makeFile {} foo.ps] set bar [makeFile {} bar.ps] @@ -48,21 +48,21 @@ test canvPs-1.2 {test writing to a file, idempotency} -constraints { test canvPs-2.1 {test writing to a channel} -constraints { - unixOrPc + unixOrWin } -setup { set foo [makeFile {} foo.ps] file delete $foo } -body { set chan [open $foo w] fconfigure $chan -translation lf - .c postscript -channel $chan + set res [.c postscript -channel $chan] close $chan - file exists $foo + lappend res [file exists $foo] } -cleanup { removeFile foo.ps } -result 1 test canvPs-2.2 {test writing to channel, idempotency} -constraints { - unixOrPc + unixOrWin } -setup { set foo [makeFile {} foo.ps] set bar [makeFile {} bar.ps] diff --git a/tests/canvText.test b/tests/canvText.test index c04cb63..20cbff4 100644 --- a/tests/canvText.test +++ b/tests/canvText.test @@ -269,7 +269,7 @@ test canvText-6.1 {ComputeTextBbox procedure} -constraints fonts -setup { .c create text 0 0 -tag test .c itemconfig test -font $font -text 0 expr {[.c itemconfig test -anchor n; .c bbox test] \ - eq "[expr -$ax/2-1] 0 [expr $ax/2+1] $ay"} + eq "[expr {-$ax/2-1}] 0 [expr {$ax/2+1}] $ay"} } -cleanup { .c delete test } -result 1 @@ -282,7 +282,7 @@ test canvText-6.2 {ComputeTextBbox procedure} -constraints fonts -setup { .c create text 0 0 -tag test .c itemconfig test -font $font -text 0 expr {[.c itemconfig test -anchor nw; .c bbox test] \ - eq "-1 0 [expr $ax+1] $ay"} + eq "-1 0 [expr {$ax+1}] $ay"} } -cleanup { .c delete test } -result 1 @@ -803,6 +803,25 @@ test canvText-14.6 {select clear errors} -setup { } -cleanup { .c delete test } -returnCodes error -result "wrong \# args: should be \".c select clear\"" +test canvText-14.7 {GetTextIndex procedure: pixel index with non-default scrollregion} -setup { + canvas .cc + .cc create text 50 80 -tag test -text Hello -anchor nw -font "Arial 30" + foreach {xmin ymin xmax ymax} [.cc bbox test] {} +} -body { + # default -scrollregion + set res [.cc index test @$xmin,$ymin] + lappend res [.cc index test @$xmax,$ymax] + # -scrollregion with positive upper left corner + .cc configure -scrollregion {50 50 700 900} + lappend res [.cc index test @$xmin,$ymin] + lappend res [.cc index test @$xmax,$ymax] + # -scrollregion with negative upper left corner + .cc configure -scrollregion {-100 -100 700 900} + lappend res [.cc index test @$xmin,$ymin] + lappend res [.cc index test @$xmax,$ymax] +} -cleanup { + destroy .cc +} -result {0 5 0 5 0 5} test canvText-15.1 {SetTextCursor procedure} -setup { .c create text 0 0 -tag test @@ -945,6 +964,20 @@ test canvText-20.1 {angled text bounding box} -setup { rename transpose {} } -result {ok ok ok} +test canvText-20.2 {crash on angled text selection (X11, without xft) - bug 2712f43f6e} -setup { + destroy .c + canvas .c -background bisque -selectforeground green2 + grid .c + set id [.c create text 50 150 -anchor w -text "Angled text" \ + -angle 30 -font {Helvetica 32} -fill darkblue] +} -body { + .c select clear + .c select from $id 0 + .c select to $id 8 ; update ; # used to crash on X11 (--disable-xft build only) +} -cleanup { + destroy .c +} -result {} + # cleanup cleanupTests return diff --git a/tests/canvas.test b/tests/canvas.test index e8dc332..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 @@ -356,9 +366,9 @@ test canvas-9.1 {canvas id creation and deletion} -setup { for {set i 0} {$i < $size} {incr i} { set x [expr {-10 + 3*$i}] for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { - .c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \ + .c create rect ${x}c ${y}c [expr {$x+2}]c [expr {$y+2}]c \ -outline black -fill blue -tags rect - .c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \ + .c create text [expr {$x+1}]c [expr {$y+1}]c -text "$i,$j" \ -anchor center -tags text } } @@ -574,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 @@ -952,6 +962,48 @@ test canvas-19.11 {rchars method - errors} -setup { destroy .c } -returnCodes error -result {bad index "foo"} +test canvas-20.1 {addtag/dtag - no shuffling of tag sequence} -setup { + canvas .c + .c create text 100 100 -text Hello +} -body { + for {set i 1} {$i < 5} {incr i} { + .c addtag tag$i all + } + # [.c addtags] only adds tags that are not already present + .c addtag tag1 all ; # no effect + set res [list [.c gettags 1]] + .c dtag 1 tag2 + lappend res [.c gettags 1] +} -cleanup { + destroy .c +} -result {{tag1 tag2 tag3 tag4} {tag1 tag3 tag4}} +test canvas-20.2 {tag deletion - multiple tags with same name, no shuffling} -setup { + canvas .c + .c create text 100 100 -text Hello +} -body { + # [.c itemconfigure -tags] lets the user add duplicate tags + # this is not a problem although inconsistent with [.c addtags] + .c itemconfigure 1 -tags {tagA tagB tagA tagA tagC tagA} + set res [list [.c gettags 1]] + .c dtag 1 tagA + lappend res [.c gettags 1] +} -cleanup { + destroy .c +} -result {{tagA tagB tagA tagA tagC tagA} {tagB tagC}} +test canvas-20.3 {tag deletion - all tags match} -setup { + canvas .c + .c create text 100 100 -text Hello +} -body { + # [.c itemconfigure -tags] lets the user add duplicate tags + # this is not a problem although inconsistent with [.c addtags] + .c itemconfigure 1 -tags {tagA tagA tagA tagA tagA tagA} + set res [list [.c gettags 1]] + .c dtag 1 tagA + lappend res [.c gettags 1] +} -cleanup { + 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 @@ -1040,6 +1092,207 @@ test canvas-20.3 {canvas image with subsample and zoom} -setup { 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/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/cmap.tcl b/tests/cmap.tcl index cca4c24..ea19131 100644 --- a/tests/cmap.tcl +++ b/tests/cmap.tcl @@ -19,7 +19,7 @@ proc colors {w redInc greenInc blueInc} { for {set x 0} {$x < 8} {incr x} { frame $w.f$x,$y -width 40 -height 40 -bd 2 -relief raised \ -bg [format #%02x%02x%02x $red $green $blue] - place $w.f$x,$y -x [expr 40*$x] -y [expr 40*$y] + place $w.f$x,$y -x [expr {40*$x}] -y [expr {40*$y}] incr red $redInc incr green $greenInc incr blue $blueInc diff --git a/tests/constraints.tcl b/tests/constraints.tcl index a87499d..c77fb00 100644 --- a/tests/constraints.tcl +++ b/tests/constraints.tcl @@ -190,7 +190,7 @@ testConstraint nonUnixUserInteraction [expr { [testConstraint userInteraction] || ([testConstraint unix] && [testConstraint notAqua]) }] -testConstraint haveDISPLAY [info exists env(DISPLAY)] +testConstraint haveDISPLAY [expr {[info exists env(DISPLAY)] && [testConstraint x11]}] testConstraint altDisplay [info exists env(TK_ALT_DISPLAY)] testConstraint noExceed [expr { ![testConstraint unix] || [catch {font actual "\{xyz"}] 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 7065343..b92c894 100644 --- a/tests/entry.test +++ b/tests/entry.test @@ -1435,7 +1435,7 @@ 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 pack .e @@ -1512,7 +1512,7 @@ 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 pack .e @@ -1688,11 +1688,13 @@ test entry-5.7 {ConfigureEntry procedure} -setup { } -body { .e configure -font {Courier -12} -width 4 -xscrollcommand scroll .e insert end "01234567890" - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo .e configure -width 5 format {%.6f %.6f} {*}$scrollInfo } -cleanup { destroy .e + after cancel $timeout } -result {0.000000 0.363636} @@ -1933,10 +1935,12 @@ test entry-7.1 {InsertChars procedure} -setup { .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e insert 2 XXX - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] } -cleanup { destroy .e + after cancel $timeout } -result {abXXXcde abXXXcde {0.000000 1.000000}} test entry-7.2 {InsertChars procedure} -setup { @@ -1948,10 +1952,12 @@ test entry-7.2 {InsertChars procedure} -setup { .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e insert 500 XXX - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] } -cleanup { destroy .e + after cancel $timeout } -result {abcdeXXX abcdeXXX {0.000000 1.000000}} test entry-7.3 {InsertChars procedure} -setup { entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 @@ -2080,10 +2086,12 @@ test entry-8.1 {DeleteChars procedure} -setup { .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e delete 2 4 - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] } -cleanup { destroy .e + after cancel $timeout } -result {abe abe {0.000000 1.000000}} test entry-8.2 {DeleteChars procedure} -setup { unset -nocomplain contents @@ -2094,10 +2102,12 @@ test entry-8.2 {DeleteChars procedure} -setup { .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e delete -2 2 - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] } -cleanup { destroy .e + after cancel $timeout } -result {cde cde {0.000000 1.000000}} test entry-8.3 {DeleteChars procedure} -setup { unset -nocomplain contents @@ -2108,10 +2118,12 @@ test entry-8.3 {DeleteChars procedure} -setup { .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e delete 3 1000 - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] } -cleanup { destroy .e + 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 @@ -2954,30 +2966,36 @@ test entry-17.1 {EntryUpdateScrollbar procedure} -body { pack .e .e delete 0 end .e insert 0 123 - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo format {%.6f %.6f} {*}$scrollInfo } -cleanup { destroy .e + after cancel $timeout } -result {0.000000 1.000000} test entry-17.2 {EntryUpdateScrollbar procedure} -body { entry .e -width 10 -xscrollcommand scroll -font {Courier -12} pack .e .e insert 0 0123456789abcdef .e xview 3 - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo format {%.6f %.6f} {*}$scrollInfo } -cleanup { destroy .e + after cancel $timeout } -result {0.187500 0.812500} test entry-17.3 {EntryUpdateScrollbar procedure} -body { entry .e -width 10 -xscrollcommand scroll -font {Courier -12} pack .e .e insert 0 abcdefghijklmnopqrs .e xview 6 - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo format {%.6f %.6f} {*}$scrollInfo } -cleanup { destroy .e + after cancel $timeout } -result {0.315789 0.842105} test entry-17.4 {EntryUpdateScrollbar procedure} -setup { proc bgerror msg { @@ -2987,7 +3005,7 @@ test entry-17.4 {EntryUpdateScrollbar procedure} -setup { } -body { entry .e -width 5 -xscrollcommand thisisnotacommand pack .e - update + vwait x list $x $errorInfo } -cleanup { destroy .e @@ -3529,6 +3547,34 @@ test entry-24.1 {textvariable lives in a non-existing namespace} -setup { destroy .e } -result {can't trace "thisnsdoesntexist::myvar": parent namespace doesn't exist} +test entry-25.1 {Bug [5d991b822e]} { + # Want this not to segfault, or write to variable with empty name + set var INIT + entry .b -textvariable var + trace add variable var unset {apply {args { + .b configure -textvariable {} + }}} + pack .b + bind .b <Configure> {unset var} + update + destroy .b + info exists {} +} 0 +test entry-25.2 {Bug [5d991b822e]} { + # Want this not to leak traces + set var INIT + entry .b -textvariable var + trace add variable var unset {apply {args { + .b configure -textvariable new + }}} + pack .b + bind .b <Configure> {unset -nocomplain var} + update + destroy .b + unset new +} {} + + # Gathered comments about lacks # XXX Still need to write tests for EntryBlinkProc, EntryFocusProc, # and EntryTextVarProc. diff --git a/tests/event.test b/tests/event.test index f874065..2e53196 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,6 +245,8 @@ 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 + wm geometry .t +200+100 _keypress_string $e MELLO _keypress $e BackSpace _keypress $e BackSpace @@ -267,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> } @@ -321,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> } @@ -353,7 +355,7 @@ 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] @@ -379,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 @@ -420,7 +422,7 @@ 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] @@ -446,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 @@ -485,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 @@ -556,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] @@ -628,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] @@ -678,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 @@ -717,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 @@ -732,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 @@ -783,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 @@ -798,18 +800,18 @@ test event-7.2(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 @@ -832,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> @@ -858,6 +860,7 @@ test event-8 {event generate with keysyms corresponding to } -result {OK} # cleanup +update unset -nocomplain keypress_lookup rename _init_keypress_lookup {} rename _keypress_lookup {} diff --git a/tests/filebox.test b/tests/filebox.test index e373d73..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 } } diff --git a/tests/focus.test b/tests/focus.test index 73bb9fd..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 @@ -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 @@ -730,6 +730,26 @@ test focus-6.2 {miscellaneous - embedded application in different process} -cons bind all <FocusOut> {} } -result {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} +test focus-7.1 {TkSetFocusWin procedure, unmapped windows} -setup { + # TkSetFocusWin handles the case of not yet mapped windows + # by not setting the focus on them right at the time it is + # requested, but by scheduling an event handler that will + # set the focus later once it gets mapped. The purpose of + # this test is to check that event scheduling and deletion + # work as expected (bug [08e2f8e6f0]). + toplevel .top + spinbox .top.s1 + spinbox .top.s2 + spinbox .top.s3 + grid .top.s1 .top.s2 .top.s3 +} -body { + focus -force .top.s2 + focus -force .top.s3 + update + focus +} -cleanup { + destroy .top +} -result {.top.s3} deleteWindows diff --git a/tests/font.test b/tests/font.test index 09c2dc6..9f279dd 100644 --- a/tests/font.test +++ b/tests/font.test @@ -11,6 +11,9 @@ namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +# Some tests require support for 4-byte UTF-8 sequences +testConstraint fullutf [expr {[format %c 0x010000] != "\uFFFD"}] +testConstraint utfcompat [expr {([string length "\U10000"] == 2) && [package vsatisfies [package provide Tcl] 8]}] set defaultfontlist [font names] @@ -151,12 +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 { - font actual {-family times} -family -- \ud800\udc00 +test font-4.14 {font command: actual} -constraints {utfcompat win} -body { + font actual {-family times} -family -- \uD800\uDC00 } -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} test font-5.1 {font command: configure} -body { @@ -2250,7 +2256,7 @@ test font-38.10 {ParseFontNameObj procedure: arguments} -body { font actual {times xyz xyz} } -returnCodes error -result {expected integer but got "xyz"} test font-38.11 {ParseFontNameObj procedure: stylelist loop} -constraints { - unixOrPc + unixOrWin } -body { lrange [font actual {times 12 bold italic overstrike underline}] 4 end } -result {-weight bold -slant italic -underline 1 -overstrike 1} diff --git a/tests/frame.test b/tests/frame.test index e1eb5e4..bdeb2e9 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,21 +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 -} -body { - option add *NewFrame.background #123456 - frame .f -class NewFrame - lindex [.f configure -background] 4 -} -cleanup { deleteWindows - option clear -} -result {#123456} -test frame-3.6 {TkCreateFrame procedure} -setup { - deleteWindows } -body { option add *NewFrame.background #123456 frame .f -class NewFrame @@ -634,7 +621,7 @@ test frame-3.6 {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 @@ -645,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 @@ -658,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 @@ -668,6 +655,12 @@ 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. + update idletasks deleteWindows } -result {0 0 140 300} test frame-3.10 {TkCreateFrame procedure, -use option} -constraints { @@ -677,9 +670,19 @@ test frame-3.10 {TkCreateFrame procedure, -use option} -constraints { } -body { toplevel .t -container 1 -width 300 -height 120 wm geometry .t +0+0 + if {[tk windowingsystem] eq "aqua"} { + update idletasks + } else { + update + } option add *x.use [winfo id .t] toplevel .x -width 140 -height 300 -bg green - tkwait visibility .x + if {[tk windowingsystem] eq "aqua"} { + update idletasks + } else { + tkwait visibility .x + update + } list [expr {[winfo rootx .x] - [winfo rootx .t]}] \ [expr {[winfo rooty .x] - [winfo rooty .t]}] \ [winfo width .t] [winfo height .t] @@ -687,42 +690,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 @@ -732,12 +733,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 @@ -747,12 +748,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 @@ -763,21 +764,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 @@ -785,24 +786,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} @@ -812,14 +813,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 @@ -828,27 +828,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 @@ -873,22 +871,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 @@ -916,10 +912,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"} @@ -933,12 +928,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] @@ -946,7 +941,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] @@ -954,7 +949,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 {} @@ -968,7 +963,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] @@ -976,7 +971,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 @@ -990,7 +985,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 {} @@ -999,7 +994,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 @@ -1014,7 +1009,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 @@ -1025,12 +1019,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 @@ -1041,7 +1034,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 @@ -1050,7 +1043,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 @@ -1066,22 +1059,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 @@ -1092,9 +1080,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 @@ -1105,9 +1093,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 @@ -1119,19 +1106,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 @@ -1146,27 +1130,37 @@ 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 + update idletasks } -body { # Check reaction on font change font create myfont -family courier -size 10 labelframe .f -font myfont -text Mupp place .f -x 0 -y 0 -width 40 -height 40 pack [frame .f.f] -fill both -expand 1 - update + if {[tk windowingsystem] eq "aqua"} { + update idletasks + } else { + update + } set h1 [font metrics myfont -linespace] set y1 [winfo y .f.f] font configure myfont -size 20 - update + if {[tk windowingsystem] eq "aqua"} { + update idletasks + } else { + update + } set h2 [font metrics myfont -linespace] set y2 [winfo y .f.f] expr {($h2 - $h1) - ($y2 - $y1)} @@ -1175,9 +1169,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 @@ -1189,32 +1182,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 { @@ -1229,21 +1222,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 { @@ -1251,9 +1243,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 @@ -1262,16 +1254,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 @@ -1280,7 +1272,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 @@ -1289,16 +1281,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} @@ -1311,9 +1303,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 @@ -1322,25 +1314,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 @@ -1349,7 +1341,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 @@ -1357,9 +1349,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 @@ -1367,7 +1359,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 @@ -1376,7 +1368,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 @@ -1384,9 +1376,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 @@ -1406,13 +1398,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} @@ -1427,7 +1418,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 @@ -1446,7 +1437,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 @@ -1465,7 +1456,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 @@ -1479,7 +1470,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 @@ -1502,12 +1493,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 @@ -1516,14 +1507,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/grab.test b/tests/grab.test index 33399cb..653d756 100644 --- a/tests/grab.test +++ b/tests/grab.test @@ -12,10 +12,14 @@ eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test -# There's currently no way to test the actual grab effect, per se, -# in an automated test. Therefore, this test suite only covers the -# interface to the grab command (ie, error messages, etc.) +# The macOS test module includes the pressbutton command to simulate a +# mouse button press event by injecting events into the NSApplication +# event queue. On other platforms there is currently no way to test +# the actual grab effect, per se, in an automated test. Therefore, +# this test suite only covers the interface to the grab command (ie, +# error messages, etc.) on platforms other than macOS. +testConstraint pressbutton [llength [info commands pressbutton]] test grab-1.1 {Tk_GrabObjCmd} -body { grab @@ -182,6 +186,32 @@ test grab-5.2 {Tk_GrabObjCmd, grab set} -body { grab release . } -result {. global} +test grab-6.1 {local grab on child window} -constraints { + pressbutton +} -body { + wm geometry . 100x200+200+100 + set result {} + frame .f -background red -padx 10 -pady 10 -height 100 -width 80 + bind . <Button-1> {lappend result "outside"} + bind .f <Button-1> {lappend result "inside"} + pack .f + update idletasks + pressbutton 250 150 + update + lappend result ":" + pressbutton 250 250 + update + lappend result ":" + grab set .f + pressbutton 250 150 + update + lappend result ":" + pressbutton 250 250 + update + return $result +} -cleanup { + grab release .f +} -result {inside outside : outside : inside outside :} cleanupTests return diff --git a/tests/grid.test b/tests/grid.test index 63bfe2a..53f8be5 100644 --- a/tests/grid.test +++ b/tests/grid.test @@ -80,6 +80,7 @@ test grid-1.9 {basic argument checking} -body { grid_reset 1.9 } -returnCodes ok -result {} + test grid-2.1 {bbox} -body { grid bbox . } -result {0 0 0 0} @@ -192,6 +193,30 @@ test grid-3.9 {configure: basic argument checking} -body { } -cleanup { grid_reset 3.9 } -returnCodes error -result {invalid window shortcut, "y" should be '-', 'x', or '^'} +test grid-3.10 {ConfigureSlave procedure, bad -in option} -body { + frame .f + grid .f -in .f +} -cleanup { + grid_reset 3.10 +} -returnCodes error -result {window can't be managed in itself} +test grid-3.11 {prevent management loops} -body { + frame .f1 + frame .f2 + grid .f1 -in .f2 + grid .f2 -in .f1 +} -cleanup { + grid_reset 3.11 +} -returnCodes error -result {can't put .f2 inside .f1, would cause management loop} +test grid-3.12 {prevent management loops} -body { + frame .f1 + frame .f2 + frame .f3 + grid .f1 -in .f2 + grid .f2 -in .f3 + grid .f3 -in .f1 +} -cleanup { + grid_reset 3.12 +} -returnCodes error -result {can't put .f3 inside .f1, would cause management loop} test grid-4.1 {forget: basic argument checking} -body { grid forget foo diff --git a/tests/image.test b/tests/image.test index 8121ffd..da65a66 100644 --- a/tests/image.test +++ b/tests/image.test @@ -47,7 +47,7 @@ test image-1.6 {Tk_ImageCmd procedure, "create" option} -constraints { scan [image create test] image%d first image create test myimage scan [image create test -variable x] image%d second - expr $second-$first + expr {$second-$first} } -cleanup { imageCleanup } -result {1} @@ -62,8 +62,18 @@ test image-1.7 {Tk_ImageCmd procedure, "create" option} -constraints { .c create image 100 150 -image myimage update set x {} + set timer [after 500 {lappend x "timed out"}] image create test myimage -variable x + update idletasks update + # On MacOS we need to wait for the test image display procedure to run. + while {"timed out" ni $x && [lindex $x end 1] ne "display"} { + vwait x + } + after cancel timer + if {[lindex $x end] eq "timed out"} { + return [lreplace $x end end] + } return $x } -cleanup { imageCleanup @@ -80,8 +90,10 @@ test image-1.8 {Tk_ImageCmd procedure, "create" option} -constraints { image delete myimage update set x {} + set timer [after 500 {lappend x "timed out"}] image create test myimage -variable x - update + vwait x + after cancel $timer return $x } -cleanup { .c delete all @@ -345,7 +357,12 @@ test image-8.1 {Tk_ImageCmd procedure, "inuse" option} -constraints { catch {destroy .b} } -result [list 0 1] - +if {[tk windowingsystem] == "aqua" && $tcl_platform(osVersion) > 18} { + # Aqua >= 10.14 will redraw the entire image in drawRect. + set result_9_1 {{foo display 0 0 30 15}} +} else { + set result_9_1 {{foo display 5 6 7 8}} +} test image-9.1 {Tk_ImageChanged procedure} -constraints testImageType -setup { .c delete all imageCleanup @@ -355,13 +372,26 @@ test image-9.1 {Tk_ImageChanged procedure} -constraints testImageType -setup { .c create image 50 50 -image foo update set x {} + set timer [after 500 {lappend x "timed out"}] foo changed 5 6 7 8 30 15 + update idletasks update + # On MacOS we need to wait for the test image display procedure to run. + while {"timed out" ni $x && [lindex $x end 1] ne "display"} { + vwait x + } + after cancel $timer return $x } -cleanup { .c delete all imageCleanup -} -result {{foo display 5 6 7 8}} +} -result $result_9_1 +if {[tk windowingsystem] == "aqua" && $tcl_platform(osVersion) > 18} { + # Aqua >= 10.14 will redraw the entire image. + set result_9_2 {{foo display 0 0 30 15} {foo display 0 0 30 15}} +} else { + set result_9_2 {{foo display 5 6 25 9} {foo display 0 0 12 14}} +} test image-9.2 {Tk_ImageChanged procedure} -constraints testImageType -setup { .c delete all imageCleanup @@ -373,13 +403,15 @@ test image-9.2 {Tk_ImageChanged procedure} -constraints testImageType -setup { update set x {} foo changed 5 6 7 8 30 15 - update + set timer [after 500 {lappend x "timed out"}] + image create test myimage -variable x + vwait x + after cancel $timer return $x } -cleanup { .c delete all imageCleanup -} -result {{foo display 5 6 25 9} {foo display 0 0 12 14}} - +} -result $result_9_2 test image-10.1 {Tk_GetImage procedure} -setup { imageCleanup @@ -413,8 +445,10 @@ test image-11.1 {Tk_FreeImage procedure} -constraints testImageType -setup { update set x {} .c delete i1 + set timer [after 500 {lappend x "timed out"}] pack .c - update + vwait x + after cancel $timer list [imageNames] $x } -cleanup { .c delete all diff --git a/tests/imgListFormat.test b/tests/imgListFormat.test index b2c401c..331b572 100644 --- a/tests/imgListFormat.test +++ b/tests/imgListFormat.test @@ -139,7 +139,7 @@ test imgListFormat-3.4 {StringMatchDef: base64 data is not parsed as valid \ } -format default } -cleanup { imageCleanup -} -returnCodes error -result {couldn't recognize image data} +} -returnCodes error -result {invalid color name "iVBORw0KGgoAAAANSUhEUgAAAAIAAAACCA"} test imgListFormat-3.5 {StringMatchDef: valid data} -setup { image create photo photo1 } -body { diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test index 8ab555f..df4cfcb 100644 --- a/tests/imgPhoto.test +++ b/tests/imgPhoto.test @@ -542,14 +542,14 @@ test imgPhoto-4.27 {ImgPhotoCmd procedure: put option} -setup { photo1 put {{white} {white white}} } -returnCodes error -cleanup { image delete photo1 -} -result {couldn't recognize image data} +} -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 {couldn't recognize image data} +} -returnCodes error -result {invalid color name "blahgle"} test imgPhoto-4.29 {ImgPhotoCmd procedure: put option} -setup { image create photo photo1 } -body { @@ -1149,7 +1149,7 @@ test imgPhoto-4.95 {ImgPhotoCmd put: default fmt, invalid data} -setup { #" } -cleanup { imageCleanup -} -returnCodes error -result {couldn't recognize image data} +} -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 @@ -1932,14 +1932,14 @@ test imgPhoto-19.6 {MatchStringFormat: invalid data for default} -setup { photo1 put bogus } -cleanup { imageCleanup -} -returnCodes error -result {couldn't recognize image data} +} -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 {couldn't recognize image data} +} -returnCodes error -result {invalid color name "bogus"} test imgPhoto-19.8 {MatchStirngFormat: invalid data for gif} -setup { image create photo photo1 } -body { 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 92029de..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 { @@ -2209,6 +2209,7 @@ test listbox-11.5 {ChangeListboxView procedure} -setup { } -body { listbox .l -height 5 -yscrollcommand "record y" pack .l + update .l insert 0 a b c d e f g h i j .l yview 3 update @@ -2662,10 +2663,11 @@ test listbox-21.9 {ListboxListVarProc, test hscrollbar after listvar mod} -setup destroy .l } -body { catch {unset x} - set log {} listbox .l -font $fixed -width 10 -xscrollcommand "record x" -listvar x + set log {} pack .l - update + set timeout [after 500 {set log timeout}] + vwait log lappend x "0000000000" update lappend x "00000000000000000000" @@ -2673,15 +2675,17 @@ test listbox-21.9 {ListboxListVarProc, test hscrollbar after listvar mod} -setup set log } -cleanup { destroy .l + after cancel $timeout } -result [list {x 0 1} {x 0 1} {x 0 0.5}] test listbox-21.10 {ListboxListVarProc, test hscrollbar after listvar mod} -setup { destroy .l } -body { catch {unset x} - set log {} listbox .l -font $fixed -width 10 -xscrollcommand "record x" -listvar x + set log {} pack .l - update + set timeout [after 500 {set log timeout}] + vwait log lappend x "0000000000" update lappend x "00000000000000000000" @@ -2691,6 +2695,7 @@ test listbox-21.10 {ListboxListVarProc, test hscrollbar after listvar mod} -setu set log } -cleanup { destroy .l + after cancel timeout } -result [list {x 0 1} {x 0 1} {x 0 0.5} {x 0 1}] test listbox-21.11 {ListboxListVarProc, bad list} -setup { destroy .l @@ -2755,15 +2760,19 @@ test listbox-21.15 {ListboxListVarProc, update vertical scrollbar} -setup { destroy .l } -body { catch {unset x} + listbox .l -font $fixed -height 3 -yscrollcommand "record y" -listvar x + update set log {} - listbox .l -listvar x -yscrollcommand "record y" -font fixed -height 3 pack .l + set timeout [after 500 {set log timeout}] + vwait log update lappend x a b c d e f - update + vwait log set log } -cleanup { destroy .l + after cancel $timeout } -result [list {y 0 1} {y 0 0.5}] test listbox-21.16 {ListboxListVarProc, update vertical scrollbar} -setup { destroy .l @@ -2771,7 +2780,6 @@ test listbox-21.16 {ListboxListVarProc, update vertical scrollbar} -setup { catch {unset x} listbox .l -listvar x -height 3 pack .l - update set x [list 0 1 2 3 4 5] .l yview scroll 3 units update @@ -2792,17 +2800,19 @@ test listbox-21.16 {ListboxListVarProc, update vertical scrollbar} -setup { test listbox-22.1 {UpdateHScrollbar} -setup { destroy .l } -body { - set log {} listbox .l -font $fixed -width 10 -xscrollcommand "record x" + set log {} pack .l - update + set timeout [after 500 {set log timeout}] + vwait log .l insert end "0000000000" update .l insert end "00000000000000000000" - update + vwait log set log } -cleanup { destroy .l + after cancel $timeout } -result [list {x 0 1} {x 0 1} {x 0 0.5}] @@ -3146,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 @@ -3169,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 @@ -3177,6 +3187,33 @@ test listbox-31.2 {<<ListboxSelect>> event on lost selection} -setup { destroy .l } -result {{.l 0} {{} {}}} +test listbox-32.1 {Bug [5d991b822e]} { + # Want this not to segfault, or write to variable with empty name + set var INIT + listbox .b -listvariable var + trace add variable var unset {apply {args { + .b configure -listvariable {} + }}} + pack .b + bind .b <Configure> {unset var} + update + destroy .b + info exists {} +} 0 +test listbox-32.2 {Bug [5d991b822e]} { + # Want this not to leak traces + set var INIT + listbox .b -listvariable var + trace add variable var unset {apply {args { + .b configure -listvariable new + }}} + pack .b + bind .b <Configure> {unset -nocomplain var} + update + destroy .b + unset new +} {} + resetGridInfo deleteWindows option clear diff --git a/tests/menu.test b/tests/menu.test index 87d8a9e..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 @@ -1821,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 @@ -1839,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 @@ -1877,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 @@ -2034,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 @@ -2130,7 +2130,7 @@ test menu-6.4 {TkDestroyMenu - reentrancy - clones} -setup { .m1 clone .m1.m3 destroy .m1 } -cleanup { - deleteWindows + deleteWindows } -returnCodes ok test menu-6.5 {TkDestroyMenu} -setup { destroy .m1 .m2 @@ -2271,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 @@ -2282,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 @@ -2293,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 @@ -2304,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 @@ -2375,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" @@ -2392,7 +2392,7 @@ test menu-9.1 {ConfigureMenu} -setup { menu .m1 list [.m1 configure -postcommand "beep"] [.m1 cget -postcommand] } -cleanup { - deleteWindows + deleteWindows } -result {{} beep} test menu-9.2 {ConfigureMenu} -setup { destroy .m1 @@ -2401,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 @@ -2409,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 @@ -2418,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 @@ -2428,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 @@ -2439,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 @@ -2465,7 +2465,7 @@ test menu-9.9 {ConfigureMenu} -setup { menu .m1 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} @@ -2478,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 @@ -2488,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} @@ -2500,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 @@ -2509,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 @@ -2518,83 +2518,83 @@ 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 .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 @@ -2607,10 +2607,10 @@ test menu-11.12 {ConfigureMenuEntry} -setup { .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 @@ -2621,32 +2621,32 @@ test menu-11.13 {ConfigureMenuEntry} -setup { .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 @@ -2852,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" @@ -2888,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" @@ -3065,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 @@ -3086,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 @@ -3097,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 @@ -3113,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 @@ -3126,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 @@ -3148,50 +3148,78 @@ 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 +} -body { + # Want this not to crash + menu .b + set var INIT + .b add checkbutton -variable var + trace add variable var unset {apply {args { + .b entryconfigure 1 -variable {} + }}} + unset var +} -cleanup { + deleteWindows +} -result {} +test menu-17.7 {MenuVarProc [5d991b822e]} -setup { + deleteWindows +} -body { + # Want this not to duplicate traces + menu .b + set var INIT + .b add checkbutton -variable var + trace add variable var unset {apply {args { + .b entryconfigure 1 -variable new + }}} + unset var +} -cleanup { + 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" @@ -3199,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" @@ -3210,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 + 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 + 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 @@ -3323,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" @@ -3368,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" @@ -3382,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" @@ -3397,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" @@ -3419,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 @@ -3450,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 @@ -3484,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 @@ -3496,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 @@ -3508,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 @@ -3521,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 @@ -3535,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 @@ -3550,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 @@ -3565,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 @@ -3580,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 @@ -3641,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 @@ -3690,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 @@ -3729,22 +3757,22 @@ 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 @@ -3755,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 @@ -3769,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 @@ -3783,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 @@ -3795,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 @@ -3831,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 @@ -3853,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 @@ -3876,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 @@ -3896,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 { @@ -3921,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 ec9dae5..9382974 100644 --- a/tests/menuDraw.test +++ b/tests/menuDraw.test @@ -20,7 +20,7 @@ test menuDraw-1.1 {TkMenuInitializeDrawingFields} -setup { } -result {.m1} -test menuDraw-2.1 {TkIntializeMenuEntryDrawingFields} -setup { +test menuDraw-2.1 {TkInitializeMenuEntryDrawingFields} -setup { deleteWindows } -body { menu .m1 diff --git a/tests/menubut.test b/tests/menubut.test index a9d0656..d245fd0 100644 --- a/tests/menubut.test +++ b/tests/menubut.test @@ -751,6 +751,35 @@ test menubutton-8.1 {menubutton vs hidden commands} -body { expr {$res1 eq $res2} } -result 1 +test menubutton-9.1 {Bug [5d991b822e]} { + # Want this not to segfault, or write to variable with empty name + unset -nocomplain {} + set var INIT + menubutton .b -textvariable var + trace add variable var unset {apply {args { + .b configure -textvariable {} + }}} + pack .b + bind .b <Configure> {unset var} + update + destroy .b + info exists {} +} 0 +test menubutton-9.2 {Bug [5d991b822e]} { + # Want this not to leak traces + set var INIT + menubutton .b -textvariable var + trace add variable var unset {apply {args { + .b configure -textvariable new + }}} + pack .b + bind .b <Configure> {unset -nocomplain var} + update + destroy .b + unset new +} {} + + deleteWindows diff --git a/tests/message.test b/tests/message.test index e25bbee..2ca6921 100644 --- a/tests/message.test +++ b/tests/message.test @@ -470,5 +470,33 @@ test message-3.7 {MessageWidgetObjCmd procedure, "configure"} -setup { destroy .m } -result {4} +test message-4.1 {Bug [5d991b822e]} { + # Want this not to segfault, or write to variable with empty name + unset -nocomplain {} + set var INIT + message .b -textvariable var + trace add variable var unset {apply {args { + .b configure -textvariable {} + }}} + pack .b + bind .b <Configure> {unset var} + update + destroy .b + info exists {} +} 0 +test message-4.2 {Bug [5d991b822e]} { + # Want this not to leak traces + set var INIT + message .b -textvariable var + trace add variable var unset {apply {args { + .b configure -textvariable new + }}} + pack .b + bind .b <Configure> {unset -nocomplain var} + update + destroy .b + unset new +} {} + cleanupTests return diff --git a/tests/msgbox.test b/tests/msgbox.test index 4a6de57..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 } } # diff --git a/tests/pack.test b/tests/pack.test index 9d5964c..4a41516 100644 --- a/tests/pack.test +++ b/tests/pack.test @@ -965,6 +965,27 @@ test pack-10.4 {bad -in window does not change master} -setup { winfo manager .pack.a pack .pack.a -in .pack.a } -returnCodes error -result {can't pack .pack.a inside itself} +test pack-10.5 {prevent management loops} -body { + frame .f1 + frame .f2 + pack .f1 -in .f2 + pack .f2 -in .f1 +} -cleanup { + destroy .f1 + destroy .f2 +} -returnCodes error -result {can't put .f2 inside .f1, would cause management loop} +test pack-10.6 {prevent management loops} -body { + frame .f1 + frame .f2 + frame .f3 + pack .f1 -in .f2 + pack .f2 -in .f3 + pack .f3 -in .f1 +} -cleanup { + destroy .f1 + destroy .f2 + 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 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 6a00192..e04ee0a 100644 --- a/tests/place.test +++ b/tests/place.test @@ -118,7 +118,26 @@ test place-4.4 {ConfigureSlave procedure, bad -in option} -setup { } -body { place .t.f2 -in . } -returnCodes error -result {can't place .t.f2 relative to .} - +test place-4.5 {ConfigureSlave procedure, bad -in option} -setup { +} -body { + frame .t.f1 + place .t.f1 -in .t.f1 +} -returnCodes error -result {can't place .t.f1 relative to itself} +test place-4.6 {prevent management loops} -setup { + place forget .t.f1 +} -body { + place .t.f1 -in .t.f2 + place .t.f2 -in .t.f1 +} -returnCodes error -result {can't put .t.f2 inside .t.f1, would cause management loop} +test place-4.7 {prevent management loops} -setup { + place forget .t.f1 + place forget .t.f2 +} -body { + frame .t.f3 + place .t.f1 -in .t.f2 + place .t.f2 -in .t.f3 + place .t.f3 -in .t.f1 +} -returnCodes error -result {can't put .t.f3 inside .t.f1, would cause management loop} test place-5.1 {ConfigureSlave procedure, -relwidth option} -body { place .t.f2 -relwidth abcd diff --git a/tests/safe.test b/tests/safe.test index d4e5f2e..4f0ce15 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -46,7 +46,7 @@ lappend hidden_cmds {*}[apply {{} { 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} if {[package vsatisfies [package provide Tcl] 8.7-]} { diff --git a/tests/scale.test b/tests/scale.test index e9dbc65..955092b 100644 --- a/tests/scale.test +++ b/tests/scale.test @@ -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 @@ -1478,10 +1478,12 @@ test scale-20.4 {Bug [2262543fff] - Scale widget unexpectedly fires command call scale .s -from 1 -to 50 -command {set commandedVar} .s set 10 pack .s - update ; # -command callback shall fire + set timeout [after 500 {set $commandedVar "timeout"}] + vwait commandedVar ; # -command callback shall fire set res [list [.s get] $commandedVar] } -cleanup { destroy .s + after cancel $timeout } -result {10 10} test scale-20.5 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 5} -setup { catch {destroy .s} @@ -1506,10 +1508,12 @@ test scale-20.6 {Bug [2262543fff] - Scale widget unexpectedly fires command call pack .s .s configure -command {set commandedVar} .s set 10 - update ; # -command callback shall fire + set timeout [after 500 {set $commandedVar "timeout"}] + vwait commandedVar ; # -command callback shall fire set res [list [.s get] $commandedVar] } -cleanup { destroy .s + after cancel $timeout } -result {10 10} test scale-20.7 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 7} -setup { catch {destroy .s} @@ -1519,10 +1523,12 @@ test scale-20.7 {Bug [2262543fff] - Scale widget unexpectedly fires command call scale .s -from 1 -to 50 -command {set commandedVar} pack .s .s set 10 - update ; # -command callback shall fire + set timeout [after 500 {set $commandedVar "timeout"}] + vwait commandedVar ; # -command callback shall fire set res [list [.s get] $commandedVar] } -cleanup { destroy .s + after cancel $timeout } -result {10 10} test scale-20.8 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 8} -setup { catch {destroy .s} @@ -1533,10 +1539,12 @@ test scale-20.8 {Bug [2262543fff] - Scale widget unexpectedly fires command call scale .s -from 1 -to 50 -variable scaleVar -command {set commandedVar} pack .s .s set 10 - update ; # -command callback shall fire + set timeout [after 500 {set $commandedVar "timeout"}] + vwait commandedVar ; # -command callback shall fire set res [list [.s get] $commandedVar] } -cleanup { destroy .s + after cancel $timeout } -result {10 10} test scale-21.1 {Bug [55b95f578a] - Associating variable with bignum value with scale crashes it} -setup { @@ -1559,6 +1567,32 @@ test scale-21.2 {Bug [55b95f578a] again - Bignum value for -from/-to with scale destroy .s } -result {} +test scale-22.1 {Bug [5d991b822e]} { + # Want this not to crash + set var INIT + scale .b -variable var + trace add variable var unset {apply {args { + .b configure -variable {} + }}} + pack .b + bind .b <Configure> {unset var} + update + destroy .b +} {} +test scale-22.2 {Bug [5d991b822e]} { + # Want this not to leak traces + set var INIT + scale .b -variable var + trace add variable var unset {apply {args { + .b configure -variable new + }}} + pack .b + bind .b <Configure> {unset -nocomplain var} + update + destroy .b + unset new +} {} + option clear # cleanup diff --git a/tests/scrollbar.test b/tests/scrollbar.test index cde99a0..e02e3a8 100644 --- a/tests/scrollbar.test +++ b/tests/scrollbar.test @@ -20,34 +20,34 @@ proc getTroughSize {w} { if {[testConstraint testmetrics]} { # Only Windows has [testmetrics] if [string match v* [$w cget -orient]] { - return [expr [winfo height $w] - 2*[testmetrics cyvscroll $w]] + return [expr {[winfo height $w] - 2*[testmetrics cyvscroll $w]}] } else { - return [expr [winfo width $w] - 2*[testmetrics cxhscroll $w]] + 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. if [string match v* [$w cget -orient]] { - return [expr [winfo height $w] \ + return [expr {[winfo height $w] \ - ([winfo width $w] \ - [$w cget -highlightthickness] \ - - [$w cget -bd] + 1)*2] + - [$w cget -bd] + 1)*2}] } else { - return [expr [winfo width $w] \ + return [expr {[winfo width $w] \ - ([winfo height $w] \ - [$w cget -highlightthickness] \ - - [$w cget -bd] + 1)*2] + - [$w cget -bd] + 1)*2}] } } else { # macOS aqua if [string match v* [$w cget -orient]] { - return [expr [winfo height $w] \ + return [expr {[winfo height $w] \ - ([$w cget -highlightthickness] \ - +[$w cget -bd])*2] + +[$w cget -bd])*2}] } else { - return [expr [winfo width $w] \ + return [expr {[winfo width $w] \ - ([$w cget -highlightthickness] \ - +[$w cget -bd])*2] + +[$w cget -bd])*2}] } } } @@ -58,8 +58,8 @@ proc getTroughSize {w} { # as you fix bugs and add features. foreach {width height} [wm minsize .] { - set height [expr ($height < 200) ? 200 : $height] - set width [expr ($width < 1) ? 1 : $width] + set height [expr {($height < 200) ? 200 : $height}] + set width [expr {($width < 1) ? 1 : $width}] } frame .f -height $height -width $width @@ -233,10 +233,10 @@ test scrollbar-3.25 {ScrollbarWidgetCmd procedure, "delta" option} { } {0} test scrollbar-3.26 {ScrollbarWidgetCmd procedure, "delta" option} { format {%.6g} [.s delta 0 20] -} [format %.6g [expr 20.0/([getTroughSize .s]-1)]] +} [format %.6g [expr {20.0/([getTroughSize .s]-1)}]] test scrollbar-3.27 {ScrollbarWidgetCmd procedure, "delta" option} { format {%.6g} [.s delta 0 -20] -} [format %.6g [expr -20.0/([getTroughSize .s]-1)]] +} [format %.6g [expr {-20.0/([getTroughSize .s]-1)}]] test scrollbar-3.28 {ScrollbarWidgetCmd procedure, "delta" option} { toplevel .t -width 250 -height 100 wm geom .t +0+0 @@ -244,7 +244,7 @@ test scrollbar-3.28 {ScrollbarWidgetCmd procedure, "delta" option} { place .t.s -width 201 update set result [list [format {%.6g} [.t.s delta 0 20]] \ - [format {%.6g} [.t.s delta [expr [getTroughSize .t.s] - 1] 0]]] + [format {%.6g} [.t.s delta [expr {[getTroughSize .t.s] - 1}] 0]]] destroy .t set result } {0 1} @@ -268,22 +268,22 @@ test scrollbar-3.34 {ScrollbarWidgetCmd procedure, "fraction" option} { } {1} test scrollbar-3.35 {ScrollbarWidgetCmd procedure, "fraction" option} { format {%.6g} [.s fraction 4 21] -} [format %.6g [expr (21.0 - ([winfo height .s] - [getTroughSize .s])/2.0) \ - /([getTroughSize .s] - 1)]] +} [format %.6g [expr {(21.0 - ([winfo height .s] - [getTroughSize .s])/2.0) \ + /([getTroughSize .s] - 1)}]] test scrollbar-3.36 {ScrollbarWidgetCmd procedure, "fraction" option} x11 { format {%.6g} [.s fraction 4 179] } {1} test scrollbar-3.37 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics} { - format {%.6g} [.s fraction 4 [expr 200 - [testmetrics cyvscroll .s]]] + format {%.6g} [.s fraction 4 [expr {200 - [testmetrics cyvscroll .s]}]] } {1} test scrollbar-3.38 {ScrollbarWidgetCmd procedure, "fraction" option} x11 { format {%.6g} [.s fraction 4 178] } {0.993711} test scrollbar-3.39 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics win} { - expr \ - [format {%.6g} [.s fraction 4 [expr 200 - [testmetrics cyvscroll .s] - 2]]] \ - == [format %g [expr (200.0 - [testmetrics cyvscroll .s]*2 - 2) \ - / ($height - 1 - [testmetrics cyvscroll .s]*2)]] + expr { + [format {%.6g} [.s fraction 4 [expr {200 - [testmetrics cyvscroll .s] - 2}]]] + == [format %g [expr {(200.0 - [testmetrics cyvscroll .s]*2 - 2) + / ($height - 1 - [testmetrics cyvscroll .s]*2)}]]} } 1 toplevel .t -width 250 -height 100 @@ -297,13 +297,13 @@ test scrollbar-3.41 {ScrollbarWidgetCmd procedure, "fraction" option} { } {0.5} if {[testConstraint testmetrics]} { # Only Windows has [testmetrics] - place configure .t.s -width [expr 2*[testmetrics cxhscroll .t.s]+1] + place configure .t.s -width [expr {2*[testmetrics cxhscroll .t.s]+1}] } else { if {[tk windowingsystem] eq "x11"} { - place configure .t.s -width [expr [winfo height .t.s] - 2*([.t.s cget -highlightthickness] + [.t.s cget -bd] + 1)] + place configure .t.s -width [expr {[winfo height .t.s] - 2*([.t.s cget -highlightthickness] + [.t.s cget -bd] + 1)}] } else { # macOS aqua - place configure .t.s -width [expr 2*([.t.s cget -highlightthickness] + [.t.s cget -bd])] + place configure .t.s -width [expr {2*([.t.s cget -highlightthickness] + [.t.s cget -bd])}] } } update @@ -473,16 +473,16 @@ test scrollbar-6.6 {ScrollbarPosition procedure} unix { .s identify 19 100 } {} test scrollbar-6.7 {ScrollbarPosition procedure} { - .s identify [expr [winfo width .s] / 2] -1 + .s identify [expr {[winfo width .s] / 2}] -1 } {} test scrollbar-6.8 {ScrollbarPosition procedure} { - .s identify [expr [winfo width .s] / 2] [expr [winfo height .s]] + .s identify [expr {[winfo width .s] / 2}] [winfo height .s] } {} test scrollbar-6.9 {ScrollbarPosition procedure} { - .s identify -1 [expr [winfo height .s] / 2] + .s identify -1 [expr {[winfo height .s] / 2}] } {} test scrollbar-6.10 {ScrollbarPosition procedure} { - .s identify [winfo width .s] [expr [winfo height .s] / 2] + .s identify [winfo width .s] [expr {[winfo height .s] / 2}] } {} test scrollbar-6.11.1 {ScrollbarPosition procedure} x11 { .s identify 8 4 @@ -499,10 +499,10 @@ 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] + .s identify [expr {[winfo width .s] / 2}] [expr {[testmetrics cyvscroll .s] - 1}] } {arrow1} test scrollbar-6.16 {ScrollbarPosition procedure} unix { .s identify 8 20 @@ -513,11 +513,11 @@ test scrollbar-6.17 {ScrollbarPosition procedure} {unix nonPortable} { .s identify 8 51 } {trough1} test scrollbar-6.18 {ScrollbarPosition procedure} {testmetrics win} { - .s identify [expr [winfo width .s] / 2] [testmetrics cyvscroll .s] + .s identify [expr {[winfo width .s] / 2}] [testmetrics cyvscroll .s] } {trough1} test scrollbar-6.19 {ScrollbarPosition procedure} {testmetrics win} { - .s identify [expr [winfo width .s] / 2] [expr int(.2 / [.s delta 0 1]) \ - + [testmetrics cyvscroll .s] - 1] + .s identify [expr {[winfo width .s] / 2}] [expr {int(.2 / [.s delta 0 1]) + + [testmetrics cyvscroll .s] - 1}] } {trough1} test scrollbar-6.20 {ScrollbarPosition procedure} unix { .s identify 8 52 @@ -528,12 +528,12 @@ test scrollbar-6.21 {ScrollbarPosition procedure} {unix nonPortable} { .s identify 8 83 } {slider} test scrollbar-6.22 {ScrollbarPosition procedure} {testmetrics win} { - .s identify [expr [winfo width .s] / 2] \ - [expr int(.2 / [.s delta 0 1] + 0.5) + [testmetrics cyvscroll .s]] + .s identify [expr {[winfo width .s] / 2}] \ + [expr {int(.2 / [.s delta 0 1] + 0.5) + [testmetrics cyvscroll .s]}] } {slider} test scrollbar-6.23 {ScrollbarPosition procedure} {testmetrics win} { - .s identify [expr [winfo width .s] / 2] [expr int(.4 / [.s delta 0 1]) \ - + [testmetrics cyvscroll .s] - 1] + .s identify [expr {[winfo width .s] / 2}] [expr {int(.4 / [.s delta 0 1]) + + [testmetrics cyvscroll .s] - 1}] } {slider} test scrollbar-6.24 {ScrollbarPosition procedure} unix { .s identify 8 84 @@ -542,12 +542,12 @@ test scrollbar-6.25 {ScrollbarPosition procedure} unix { .s identify 8 179 } {trough2} test scrollbar-6.27 {ScrollbarPosition procedure} {testmetrics win} { - .s identify [expr [winfo width .s] / 2] [expr int(.4 / [.s delta 0 1]) \ - + [testmetrics cyvscroll .s]] + .s identify [expr {[winfo width .s] / 2}] [expr {int(.4 / [.s delta 0 1]) + + [testmetrics cyvscroll .s]}] } {trough2} test scrollbar-6.28 {ScrollbarPosition procedure} {testmetrics win} { - .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] \ - - [testmetrics cyvscroll .s] - 1] + .s identify [expr {[winfo width .s] / 2}] [expr {[winfo height .s] + - [testmetrics cyvscroll .s] - 1}] } {trough2} test scrollbar-6.29.1 {ScrollbarPosition procedure} x11 { .s identify 8 180 @@ -564,11 +564,11 @@ test scrollbar-6.30.2 {ScrollbarPosition procedure} aqua { .s identify 8 195 } {trough2} test scrollbar-6.32 {ScrollbarPosition procedure} {testmetrics win} { - .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] \ - - [testmetrics cyvscroll .s]] + .s identify [expr {[winfo width .s] / 2}] [expr {[winfo height .s] + - [testmetrics cyvscroll .s]}] } {arrow2} test scrollbar-6.33 {ScrollbarPosition procedure} win { - .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] - 1] + .s identify [expr {[winfo width .s] / 2}] [expr {[winfo height .s] - 1}] } {arrow2} test scrollbar-6.34 {ScrollbarPosition procedure} unix { .s identify 4 100 @@ -580,7 +580,7 @@ test scrollbar-6.37 {ScrollbarPosition procedure} win { .s identify 0 100 } {trough2} test scrollbar-6.38 {ScrollbarPosition procedure} win { - .s identify [expr [winfo width .s] - 1] 100 + .s identify [expr {[winfo width .s] - 1}] 100 } {trough2} catch {destroy .t} @@ -599,7 +599,7 @@ test scrollbar-6.39.2 {ScrollbarPosition procedure} aqua { .t.s identify 4 8 } {trough1} test scrollbar-6.40 {ScrollbarPosition procedure} win { - .t.s identify 0 [expr [winfo height .t.s] / 2] + .t.s identify 0 [expr {[winfo height .t.s] / 2}] } {arrow1} test scrollbar-6.41.1 {ScrollbarPosition procedure} x11 { .t.s identify 82 8 @@ -609,14 +609,14 @@ test scrollbar-6.41.2 {ScrollbarPosition procedure} aqua { .t.s identify 82 8 } {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] + .t.s identify [expr {int(.4 / [.t.s delta 1 0]) + [testmetrics cxhscroll .t.s] + - 1}] [expr {[winfo height .t.s] / 2}] } {slider} test scrollbar-6.44 {ScrollbarPosition procedure} unix { .t.s identify 100 18 } {trough2} test scrollbar-6.46 {ScrollbarPosition procedure} win { - .t.s identify 100 [expr [winfo height .t.s] - 1] + .t.s identify 100 [expr {[winfo height .t.s] - 1}] } {trough2} test scrollbar-7.1 {EventuallyRedraw} { @@ -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,11 +779,11 @@ 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 @@ -770,11 +798,11 @@ 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 diff --git a/tests/select.test b/tests/select.test index 568749f..9146397 100644 --- a/tests/select.test +++ b/tests/select.test @@ -36,7 +36,7 @@ proc handler {type offset count} { if {$numBytes <= 0} { return "" } - string range $selValue $offset [expr $numBytes+$offset] + string range $selValue $offset [expr {$numBytes+$offset}] } proc errIncrHandler {type offset count} { @@ -55,7 +55,7 @@ proc errIncrHandler {type offset count} { if {$numBytes <= 0} { return "" } - string range $selValue $offset [expr $numBytes+$offset] + string range $selValue $offset [expr {$numBytes+$offset}] } proc errHandler args { @@ -70,7 +70,7 @@ proc badHandler {path type offset count} { if {$numBytes <= 0} { return "" } - string range $selValue $offset [expr $numBytes+$offset] + string range $selValue $offset [expr {$numBytes+$offset}] } proc reallyBadHandler {path type offset count} { global selValue selInfo pass @@ -86,7 +86,7 @@ proc reallyBadHandler {path type offset count} { if {$numBytes <= 0} { return "" } - string range $selValue $offset [expr $numBytes+$offset] + string range $selValue $offset [expr {$numBytes+$offset}] } # Eliminate any existing selection on the screen. This is needed in case @@ -1147,7 +1147,7 @@ test select-13.1 {SelectionSize procedure, handler deleted} -constraints { if {$numBytes <= 0} { return "" } - string range $selValue $offset [expr $numBytes+$offset] + string range $selValue $offset [expr {$numBytes+$offset}] } set selValue $longValue set selInfo "" diff --git a/tests/spinbox.test b/tests/spinbox.test index 28ebe68..2d03cf1 100644 --- a/tests/spinbox.test +++ b/tests/spinbox.test @@ -1773,7 +1773,7 @@ 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 pack .e @@ -1850,7 +1850,7 @@ 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 pack .e @@ -2013,11 +2013,13 @@ test spinbox-5.7 {ConfigureSpinbox procedure} -setup { } -body { .e configure -font {Courier -12} -width 4 -xscrollcommand scroll .e insert end "01234567890" - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo .e configure -width 5 format {%.6f %.6f} {*}$scrollInfo } -cleanup { destroy .e + after cancel $timeout } -result {0.000000 0.363636} test spinbox-5.8 {ConfigureSpinbox procedure} -constraints { @@ -2218,10 +2220,12 @@ test spinbox-7.1 {InsertChars procedure} -setup { .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e insert 2 XXX - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] } -cleanup { destroy .e + after cancel $timeout } -result {abXXXcde abXXXcde {0.000000 1.000000}} test spinbox-7.2 {InsertChars procedure} -setup { @@ -2233,10 +2237,12 @@ test spinbox-7.2 {InsertChars procedure} -setup { .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e insert 500 XXX - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] } -cleanup { destroy .e + after cancel $timeout } -result {abcdeXXX abcdeXXX {0.000000 1.000000}} test spinbox-7.3 {InsertChars procedure} -setup { spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 @@ -2365,10 +2371,12 @@ test spinbox-8.1 {DeleteChars procedure} -setup { .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e delete 2 4 - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] } -cleanup { destroy .e + after cancel $timeout } -result {abe abe {0.000000 1.000000}} test spinbox-8.2 {DeleteChars procedure} -setup { unset -nocomplain contents @@ -2379,10 +2387,12 @@ test spinbox-8.2 {DeleteChars procedure} -setup { .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e delete -2 2 - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] } -cleanup { destroy .e + after cancel $timeout } -result {cde cde {0.000000 1.000000}} test spinbox-8.3 {DeleteChars procedure} -setup { unset -nocomplain contents @@ -2393,10 +2403,12 @@ test spinbox-8.3 {DeleteChars procedure} -setup { .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e delete 3 1000 - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] } -cleanup { destroy .e + 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 @@ -3193,30 +3205,36 @@ test spinbox-17.1 {SpinboxUpdateScrollbar procedure} -body { pack .e .e delete 0 end .e insert 0 123 - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo format {%.6f %.6f} {*}$scrollInfo } -cleanup { destroy .e + after cancel $timeout } -result {0.000000 1.000000} test spinbox-17.2 {SpinboxUpdateScrollbar procedure} -body { spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12} pack .e .e insert 0 0123456789abcdef .e xview 3 - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo format {%.6f %.6f} {*}$scrollInfo } -cleanup { destroy .e + after cancel $timeout } -result {0.187500 0.812500} test spinbox-17.3 {SpinboxUpdateScrollbar procedure} -body { spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12} pack .e .e insert 0 abcdefghijklmnopqrs .e xview 6 - update + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo format {%.6f %.6f} {*}$scrollInfo } -cleanup { destroy .e + after cancel $timeout } -result {0.315789 0.842105} test spinbox-17.4 {SpinboxUpdateScrollbar procedure} -setup { proc bgerror msg { @@ -3226,7 +3244,7 @@ test spinbox-17.4 {SpinboxUpdateScrollbar procedure} -setup { } -body { spinbox .e -width 5 -xscrollcommand thisisnotacommand pack .e - update + vwait x list $x $errorInfo } -cleanup { destroy .e diff --git a/tests/text.test b/tests/text.test index 3314fc9..7770084 100644 --- a/tests/text.test +++ b/tests/text.test @@ -2698,7 +2698,7 @@ test text-9.2.45 {TextWidgetCmd procedure, "count" option} -setup { set res {} } -body { for {set i 1} {$i < 5} {incr i} { - .t insert end "Line $i+++Line $i---Line $i///Line $i - This is Line [format %c [expr 64+$i]]\n" + .t insert end "Line $i+++Line $i---Line $i///Line $i - This is Line [format %c [expr {64+$i}]]\n" } .t tag configure hidden -elide true .t tag add hidden 2.15 3.10 @@ -2720,7 +2720,7 @@ test text-9.2.46 {TextWidgetCmd procedure, "count" option} -setup { for {set i 1} {$i < 5} {incr i} { # 0 1 2 3 4 # 012345 678901234 567890123 456789012 34567890123456789 - .mytop.t insert end "Line $i+++Line $i---Line $i///Line $i - This is Line [format %c [expr 64+$i]]\n" + .mytop.t insert end "Line $i+++Line $i---Line $i///Line $i - This is Line [format %c [expr {64+$i}]]\n" } .mytop.t tag configure hidden -elide true .mytop.t tag add hidden 2.30 3.10 @@ -6145,9 +6145,9 @@ test text-23.4 {TkTextGetTabs procedure} -setup { .t insert end "1\t2\t3\t4\t55.5" .t configure -tabs {100 right 200 left 300 center 400 numeric} update idletasks - list [expr [lindex [.t bbox 1.2] 0] + [lindex [.t bbox 1.2] 2]] \ + list [expr {[lindex [.t bbox 1.2] 0] + [lindex [.t bbox 1.2] 2]}] \ [lindex [.t bbox 1.4] 0] \ - [expr [lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]/2] \ + [expr {[lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]/2}] \ [lindex [.t bbox 1.10] 0] } -cleanup { destroy .t @@ -6159,9 +6159,9 @@ test text-23.5 {TkTextGetTabs procedure} -setup { .t insert end "1\t2\t3\t4\t55.5" .t configure -tabs {105 r 205 l 305 c 405 n} update idletasks - list [expr [lindex [.t bbox 1.2] 0] + [lindex [.t bbox 1.2] 2]] \ + list [expr {[lindex [.t bbox 1.2] 0] + [lindex [.t bbox 1.2] 2]}] \ [lindex [.t bbox 1.4] 0] \ - [expr [lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]/2] \ + [expr {[lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]/2}] \ [lindex [.t bbox 1.10] 0] } -cleanup { destroy .t @@ -6705,7 +6705,8 @@ test text-27.15d {<<Selection>> virtual event on <Delete> with cursor inside sel update set ::retval no_<<Selection>>_event_fired .t mark set insert 1.15 - focus .t + update idletasks + focus -force .t event generate .t <Delete> update set ::retval @@ -6822,14 +6823,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 @@ -6862,7 +6863,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 @@ -7817,8 +7818,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 { @@ -7835,8 +7836,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 { @@ -7853,8 +7854,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/textBTree.test b/tests/textBTree.test index ebd6c50..fd97afa 100644 --- a/tests/textBTree.test +++ b/tests/textBTree.test @@ -422,8 +422,8 @@ test btree-6.5 {very large deletes, with tags} -setup { setup .t insert 1.1 $bigText2 for {set i 0} {$i < 100} {incr i} { - set j [expr $i+2] - set k [expr 1+2*$i] + set j [expr {$i+2}] + set k [expr {1+2*$i}] .t tag add x $j.1 $j.3 .t tag add y $k.1 $k.6 } @@ -439,13 +439,13 @@ test btree-6.6 {very large deletes, with tags} -setup { setup .t insert 1.1 $bigText2 for {set i 0} {$i < 100} {incr i} { - set j [expr $i+2] - set k [expr 1+2*$i] + set j [expr {$i+2}] + set k [expr {1+2*$i}] .t tag add x $j.1 $j.3 .t tag add y $k.1 $k.6 } for {set i 199} {$i >= 2} {incr i -1} { - .t delete $i.0 [expr $i+1].0 + .t delete $i.0 [expr {$i+1}].0 } list [.t tag ranges x] [.t tag ranges y] } -result {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}} diff --git a/tests/textDisp.test b/tests/textDisp.test index b74fc4a..f2d7047 100644 --- a/tests/textDisp.test +++ b/tests/textDisp.test @@ -11,6 +11,18 @@ eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test +# Platform specific procedure for updating the text widget. + +if {[tk windowingsystem] == "aqua"} { + proc updateText {} { + update idletasks + } +} else { + proc updateText {} { + update + } +} + # The procedure below is used as the scrolling command for the text; # it just saves the scrolling information in a variable "scrollInfo". @@ -41,7 +53,15 @@ catch {destroy .f .t} frame .f -width 100 -height 20 pack .f -side left -set fixedFont {"Courier New" -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 @@ -77,7 +97,7 @@ wm withdraw . wm minsize . 1 1 wm positionfrom . user wm deiconify . -update +updateText # Some window managers (like olwm under SunOS 4.1.3) misbehave in a way # that tends to march windows off the top and left of the screen. If @@ -158,7 +178,7 @@ test textDisp-0.3 {double tag elide transition} { .txt tag configure SYSTEM -elide 0 .txt tag configure TRAFFIC -elide 1 .txt insert end "\n" {TRAFFIC SYSTEM} - update + updateText destroy .txt } {} @@ -171,7 +191,7 @@ test textDisp-0.4 {double tag elide transition} { .txt tag configure TRAFFIC -elide 1 .txt insert end "\n" {SYSTEM TRAFFIC} # Crash was here. - update + updateText destroy .txt } {} @@ -185,7 +205,7 @@ test textDisp-0.5 {double tag elide transition} { .txt insert end "\n" {SYSTEM TRAFFIC} .txt insert end "\n" WELCOME # Crash was here. - update + updateText destroy .txt } {} @@ -216,7 +236,7 @@ test textDisp-1.2 {GetStyle procedure, wrapmode} {textfonts} { .t tag configure x -wrap word .t tag configure y -wrap none .t tag raise y - update + updateText set result [list [.t bbox 2.20]] .t tag add x 2.0 2.1 lappend result [.t bbox 2.20] @@ -230,7 +250,7 @@ test textDisp-2.1 {LayoutDLine, basics} { .t delete 1.0 end .t insert 1.0 "This is some sample text for testing." list [.t bbox 1.19] [.t bbox 1.20] -} [list [list [expr 5 + $fixedWidth * 19] 5 $fixedWidth $fixedHeight] [list 5 [expr 5 + $fixedHeight] $fixedWidth $fixedHeight]] +} [list [list [expr {5 + $fixedWidth * 19}] 5 $fixedWidth $fixedHeight] [list 5 [expr {5 + $fixedHeight}] $fixedWidth $fixedHeight]] test textDisp-2.2 {LayoutDLine, basics} {textfonts} { .t configure -wrap char .t delete 1.0 end @@ -274,8 +294,8 @@ foreach m [.t mark names] { } scan [wm geom .] %dx%d width height test textDisp-2.8 {LayoutDLine, extra chunk at end of dline} {textfonts} { - wm geom . [expr $width+1]x$height - update + wm geom . [expr {$width+1}]x$height + updateText .t configure -wrap char .t delete 1.0 end .t insert 1.0 "This isxx some sample text for testing." @@ -283,7 +303,7 @@ test textDisp-2.8 {LayoutDLine, extra chunk at end of dline} {textfonts} { list [.t bbox 1.19] [.t bbox 1.20] } [list [list 138 5 8 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]] wm geom . {} -update +updateText test textDisp-2.9 {LayoutDLine, marks and tags} {textfonts} { .t configure -wrap word .t delete 1.0 end @@ -414,22 +434,22 @@ test textDisp-2.22 {LayoutDLine, spacing options} {textfonts} { .t insert end "to wrap around a couple of times" .t insert end "\nLine 3\nLine 4" set i [.t dlineinfo 1.0] - set b1 [expr [lindex $i 1] + [lindex $i 4]] + set b1 [expr {[lindex $i 1] + [lindex $i 4]}] set i [.t dlineinfo 2.0] - set b2 [expr [lindex $i 1] + [lindex $i 4]] + set b2 [expr {[lindex $i 1] + [lindex $i 4]}] set i [.t dlineinfo 2.end] - set b3 [expr [lindex $i 1] + [lindex $i 4]] + set b3 [expr {[lindex $i 1] + [lindex $i 4]}] set i [.t dlineinfo 3.0] - set b4 [expr [lindex $i 1] + [lindex $i 4]] + set b4 [expr {[lindex $i 1] + [lindex $i 4]}] .t configure -spacing1 2 -spacing2 1 -spacing3 3 set i [.t dlineinfo 1.0] - set b1 [expr [lindex $i 1] + [lindex $i 4] - $b1] + set b1 [expr {[lindex $i 1] + [lindex $i 4] - $b1}] set i [.t dlineinfo 2.0] - set b2 [expr [lindex $i 1] + [lindex $i 4] - $b2] + set b2 [expr {[lindex $i 1] + [lindex $i 4] - $b2}] set i [.t dlineinfo 2.end] - set b3 [expr [lindex $i 1] + [lindex $i 4] - $b3] + set b3 [expr {[lindex $i 1] + [lindex $i 4] - $b3}] set i [.t dlineinfo 3.0] - set b4 [expr [lindex $i 1] + [lindex $i 4] - $b4] + set b4 [expr {[lindex $i 1] + [lindex $i 4] - $b4}] list $b1 $b2 $b3 $b4 } [list 2 7 10 15] .t configure -spacing1 0 -spacing2 0 -spacing3 0 @@ -441,13 +461,13 @@ test textDisp-2.23 {LayoutDLine, spacing options} {textfonts} { .t insert end "to wrap around a couple of times" .t insert end "\nLine 3\nLine 4" set i [.t dlineinfo 1.0] - set b1 [expr [lindex $i 1] + [lindex $i 4]] + set b1 [expr {[lindex $i 1] + [lindex $i 4]}] set i [.t dlineinfo 2.0] - set b2 [expr [lindex $i 1] + [lindex $i 4]] + set b2 [expr {[lindex $i 1] + [lindex $i 4]}] set i [.t dlineinfo 2.end] - set b3 [expr [lindex $i 1] + [lindex $i 4]] + set b3 [expr {[lindex $i 1] + [lindex $i 4]}] set i [.t dlineinfo 3.0] - set b4 [expr [lindex $i 1] + [lindex $i 4]] + set b4 [expr {[lindex $i 1] + [lindex $i 4]}] .t configure -spacing1 4 -spacing2 4 -spacing3 4 .t tag configure x -spacing1 1 -spacing2 2 -spacing3 3 .t tag add x 1.0 end @@ -455,13 +475,13 @@ test textDisp-2.23 {LayoutDLine, spacing options} {textfonts} { .t tag add y 2.19 end .t tag raise y set i [.t dlineinfo 1.0] - set b1 [expr [lindex $i 1] + [lindex $i 4] - $b1] + set b1 [expr {[lindex $i 1] + [lindex $i 4] - $b1}] set i [.t dlineinfo 2.0] - set b2 [expr [lindex $i 1] + [lindex $i 4] - $b2] + set b2 [expr {[lindex $i 1] + [lindex $i 4] - $b2}] set i [.t dlineinfo 2.end] - set b3 [expr [lindex $i 1] + [lindex $i 4] - $b3] + set b3 [expr {[lindex $i 1] + [lindex $i 4] - $b3}] set i [.t dlineinfo 3.0] - set b4 [expr [lindex $i 1] + [lindex $i 4] - $b4] + set b4 [expr {[lindex $i 1] + [lindex $i 4] - $b4}] list $b1 $b2 $b3 $b4 } [list 1 5 13 16] .t configure -spacing1 0 -spacing2 0 -spacing3 0 @@ -535,33 +555,33 @@ test textDisp-3.1 {different character sizes} {textfonts} { test textDisp-4.1 {UpdateDisplayInfo, basic} {textfonts} { .t delete 1.0 end .t insert end "Line 1\nLine 2\nLine 3\n" - update + updateText .t delete 2.0 2.end - update + updateText set res $tk_textRelayout .t insert 2.0 "New Line 2" - update + updateText lappend res [.t bbox 1.0] [.t bbox 2.0] [.t bbox 3.0] $tk_textRelayout } [list 2.0 [list 5 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] 2.0] test textDisp-4.2 {UpdateDisplayInfo, re-use tail of text line} {textfonts} { .t delete 1.0 end .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" - update + updateText .t mark set x 2.21 .t delete 2.2 - update + updateText set res $tk_textRelayout .t insert 2.0 X - update + updateText lappend res [.t bbox 2.0] [.t bbox x] [.t bbox 3.0] $tk_textRelayout } [list 2.0 2.20 [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 12 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] {2.0 2.20}] test textDisp-4.3 {UpdateDisplayInfo, tail of text line shifts} {textfonts} { .t delete 1.0 end .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" - update + updateText .t mark set x 2.21 .t delete 2.2 - update + updateText list [.t bbox 2.0] [.t bbox x] [.t bbox 3.0] $tk_textRelayout } [list [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] {2.0 2.20}] .t mark unset x @@ -569,7 +589,7 @@ test textDisp-4.4 {UpdateDisplayInfo, wrap-mode "none"} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" - update + updateText list [.t bbox 2.0] [.t bbox 2.25] [.t bbox 3.0] $tk_textRelayout } [list [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] {} [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] {1.0 2.0 3.0}] test textDisp-4.5 {UpdateDisplayInfo, tiny window} {textfonts} { @@ -577,11 +597,11 @@ test textDisp-4.5 {UpdateDisplayInfo, tiny window} {textfonts} { wm overrideredirect . 1 } wm geom . 103x$height - update + updateText .t configure -wrap none .t delete 1.0 end .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" - update + updateText list [.t bbox 2.0] [.t bbox 2.1] [.t bbox 3.0] $tk_textRelayout } [list [list 5 [expr {$fixedDiff + 18}] 1 $fixedHeight] {} [list 5 [expr {2*$fixedDiff + 31}] 1 $fixedHeight] {1.0 2.0 3.0}] if {$tcl_platform(platform) == "windows"} { @@ -601,20 +621,20 @@ test textDisp-4.6 {UpdateDisplayInfo, tiny window} { frame .f2 -width 20 -height 100 pack .f2 -before .f wm geom . 103x103 - update + updateText .t configure -wrap none -borderwidth 2 .t delete 1.0 end .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" - update + updateText set x [list [.t bbox 1.0] [.t bbox 2.0] $tk_textRelayout] wm overrideredirect . 0 - update + updateText set x } [list [list 5 5 1 1] {} 1.0] catch {destroy .f2} .t configure -borderwidth 0 -wrap char wm geom . {} -update +updateText set bw [.t cget -borderwidth] set px [.t cget -padx] set py [.t cget -pady] @@ -633,28 +653,28 @@ test textDisp-4.7 {UpdateDisplayInfo, filling in extra vertical space} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17" .t yview 1.0 - update + updateText .t yview 16.0 - update + updateText set x [list [.t index @0,0] $tk_textRelayout $tk_textRedraw] wm overrideredirect . 0 - update + updateText set x } {8.0 {16.0 17.0 15.0 14.0 13.0 12.0 11.0 10.0 9.0 8.0} {8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0 16.0 17.0}} test textDisp-4.8 {UpdateDisplayInfo, filling in extra vertical space} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17" .t yview 16.0 - update + updateText .t delete 5.0 14.0 - update + updateText set x [list [.t index @0,0] $tk_textRelayout $tk_textRedraw] } {1.0 {5.0 4.0 3.0 2.0 1.0} {1.0 2.0 3.0 4.0 5.0 eof}} test textDisp-4.9 {UpdateDisplayInfo, filling in extra vertical space} {textfonts} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17" .t yview 16.0 - update + updateText .t delete 15.0 end list [.t bbox 7.0] [.t bbox 12.0] } [list [list [expr {$hlth + $px + $bw}] [expr {$hlth + $py + $bw + 2 * $fixedHeight}] $fixedWidth $fixedHeight] [list [expr {$hlth + $px + $bw}] [expr {$hlth + $py + $bw + 7 * $fixedHeight}] $fixedWidth $fixedHeight]] @@ -662,18 +682,18 @@ test textDisp-4.10 {UpdateDisplayInfo, filling in extra vertical space} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\nLine 6 is such a long line that it wraps around.\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17" .t yview end - update + updateText .t delete 13.0 end - update + updateText list [.t index @0,0] $tk_textRelayout $tk_textRedraw } {5.0 {12.0 7.0 6.40 6.20 6.0 5.0} {5.0 6.0 6.20 6.40 7.0 12.0}} test textDisp-4.11 {UpdateDisplayInfo, filling in extra vertical space} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\nLine 6 is such a long line that it wraps around, not once but really quite a few times.\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17" .t yview end - update + updateText .t delete 14.0 end - update + updateText list [.t index @0,0] $tk_textRelayout $tk_textRedraw } {6.40 {13.0 7.0 6.80 6.60 6.40} {6.40 6.60 6.80 7.0 13.0}} test textDisp-4.12 {UpdateDisplayInfo, filling in extra vertical space} { @@ -682,11 +702,11 @@ test textDisp-4.12 {UpdateDisplayInfo, filling in extra vertical space} { button .b -text "Test" -bd 2 -highlightthickness 2 .t window create 3.end -window .b .t yview moveto 1 - update + updateText .t yview moveto 0 - update + updateText .t yview moveto 1 - update + updateText winfo ismapped .b } {0} .t configure -wrap word @@ -699,33 +719,33 @@ test textDisp-4.12 {UpdateDisplayInfo, filling in extra vertical space} { test textDisp-4.13 {UpdateDisplayInfo, special handling for top/bottom lines} { .t tag add x 1.0 end .t yview 1.0 - update + updateText .t yview scroll 3 units - update + updateText list $tk_textRelayout $tk_textRedraw } {{11.0 12.0 13.0} {4.0 10.0 11.0 12.0 13.0}} test textDisp-4.14 {UpdateDisplayInfo, special handling for top/bottom lines} { .t tag remove x 1.0 end .t yview 1.0 - update + updateText .t yview scroll 3 units - update + updateText list $tk_textRelayout $tk_textRedraw } {{11.0 12.0 13.0} {11.0 12.0 13.0}} test textDisp-4.15 {UpdateDisplayInfo, special handling for top/bottom lines} { .t tag add x 1.0 end .t yview 4.0 - update + updateText .t yview scroll -2 units - update + updateText list $tk_textRelayout $tk_textRedraw } {{2.0 3.0} {2.0 3.0 4.0 11.0}} test textDisp-4.16 {UpdateDisplayInfo, special handling for top/bottom lines} { .t tag remove x 1.0 end .t yview 4.0 - update + updateText .t yview scroll -2 units - update + updateText list $tk_textRelayout $tk_textRedraw } {{2.0 3.0} {2.0 3.0}} test textDisp-4.17 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { @@ -733,9 +753,9 @@ test textDisp-4.17 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" .t insert end "\nLine 3\nLine 4" - update + updateText .t xview scroll 3 units - update + updateText list $tk_textRelayout $tk_textRedraw [.t bbox 2.0] [.t bbox 2.5] \ [.t bbox 2.23] } [list {} {1.0 2.0 3.0 4.0} {} [list 17 [expr {$fixedDiff + 16}] 7 $fixedHeight] {}] @@ -744,9 +764,9 @@ test textDisp-4.18 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" .t insert end "\nLine 3\nLine 4" - update + updateText .t xview scroll 100 units - update + updateText list $tk_textRelayout $tk_textRedraw [.t bbox 2.25] } [list {} {1.0 2.0 3.0 4.0} [list 10 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-4.19 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { @@ -754,10 +774,10 @@ test textDisp-4.19 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" .t insert end "\nLine 3\nLine 4" - update + updateText .t xview moveto 0 .t xview scroll -10 units - update + updateText list $tk_textRelayout $tk_textRedraw [.t bbox 2.5] } [list {} {1.0 2.0 3.0 4.0} [list 38 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-4.20 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { @@ -767,9 +787,9 @@ test textDisp-4.20 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { .t insert end "\nLine 3\nLine 4" .t xview moveto 0.0 .t xview scroll 100 units - update + updateText .t delete 2.30 2.44 - update + updateText list $tk_textRelayout $tk_textRedraw [.t bbox 2.25] } [list 2.0 {1.0 2.0 3.0 4.0} [list 108 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-4.21 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { @@ -778,9 +798,9 @@ test textDisp-4.21 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" .t insert end "\nLine 3\nLine 4" .t xview moveto .9 - update + updateText .t xview moveto .6 - update + updateText list $tk_textRelayout $tk_textRedraw } {{} {}} test textDisp-4.22 {UpdateDisplayInfo, no horizontal scrolling except for -wrap none} {textfonts} { @@ -789,7 +809,7 @@ test textDisp-4.22 {UpdateDisplayInfo, no horizontal scrolling except for -wrap .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" .t insert end "\nLine 3\nLine 4" .t xview scroll 25 units - update + updateText .t configure -wrap word list [.t bbox 2.0] [.t bbox 2.16] } [list [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 10 [expr {2*$fixedDiff + 29}] 7 $fixedHeight]] @@ -799,7 +819,7 @@ test textDisp-4.23 {UpdateDisplayInfo, no horizontal scrolling except for -wrap .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" .t insert end "\nLine 3\nLine 4" .t xview scroll 25 units - update + updateText .t configure -wrap char list [.t bbox 2.0] [.t bbox 2.16] } [list [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 115 [expr {$fixedDiff + 16}] 7 $fixedHeight]] @@ -817,7 +837,7 @@ test textDisp-5.1 {DisplayDLine, handling of spacing} {textfonts} { .t window create 1.7 -window .t.f2 -align center .t window create 2.1 -window .t.f3 -align bottom .t window create 2.10 -window .t.f4 -align baseline - update + updateText list [winfo geometry .t.f1] [winfo geometry .t.f2] \ [winfo geometry .t.f3] [winfo geometry .t.f4] } [list 10x4+24+11 10x4+55+[expr {$fixedDiff/2 + 15}] 10x4+10+[expr {2*$fixedDiff + 43}] 10x4+76+[expr {2*$fixedDiff + 40}]] @@ -832,7 +852,7 @@ test textDisp-5.2 {DisplayDLine, line resizes during display} { frame .t.f -width 20 -height 20 -bd 2 -relief raised bind .t.f <Configure> {.t.f configure -width 30 -height 30} .t window create insert -window .t.f - update + updateText list [winfo width .t.f] [winfo height .t.f] } [list 30 30] @@ -843,9 +863,9 @@ test textDisp-6.1 {scrolling in DisplayText, scroll up} { foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } - update + updateText .t delete 2.0 3.0 - update + updateText list $tk_textRelayout $tk_textRedraw } {{2.0 10.0} {2.0 10.0}} test textDisp-6.2 {scrolling in DisplayText, scroll down} { @@ -854,9 +874,9 @@ test textDisp-6.2 {scrolling in DisplayText, scroll down} { foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } - update + updateText .t insert 2.0 "New Line 2\n" - update + updateText list $tk_textRelayout $tk_textRedraw } {{2.0 3.0} {2.0 3.0}} test textDisp-6.3 {scrolling in DisplayText, multiple scrolls} { @@ -866,10 +886,10 @@ test textDisp-6.3 {scrolling in DisplayText, multiple scrolls} { foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } - update + updateText .t insert 2.end "is so long that it wraps" .t insert 4.end "is so long that it wraps" - update + updateText list $tk_textRelayout $tk_textRedraw } {{2.0 2.20 4.0 4.20} {2.0 2.20 4.0 4.20}} test textDisp-6.4 {scrolling in DisplayText, scrolls interfere} { @@ -879,10 +899,10 @@ test textDisp-6.4 {scrolling in DisplayText, scrolls interfere} { foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } - update + updateText .t insert 2.end "is so long that it wraps around, not once but three times" .t insert 4.end "is so long that it wraps" - update + updateText list $tk_textRelayout $tk_textRedraw } {{2.0 2.20 2.40 2.60 4.0 4.20} {2.0 2.20 2.40 2.60 4.0 4.20 6.0}} test textDisp-6.5 {scrolling in DisplayText, scroll source obscured} {nonPortable} { @@ -894,9 +914,9 @@ test textDisp-6.5 {scrolling in DisplayText, scroll source obscured} {nonPortabl foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } - update + updateText .t delete 1.6 1.end - update + updateText destroy .f2 list $tk_textRelayout $tk_textRedraw } {{1.0 9.0 10.0} {1.0 4.0 5.0 9.0 10.0}} @@ -911,41 +931,44 @@ test textDisp-6.6 {scrolling in DisplayText, Expose events after scroll} {unix n foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } - update + updateText .t delete 1.6 1.end destroy .f2 - update + updateText list $tk_textRelayout $tk_textRedraw } {{1.0 9.0 10.0} {borders 1.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0}} .t configure -bd 0 test textDisp-6.7 {DisplayText, vertical scrollbar updates} { .t configure -wrap char .t delete 1.0 end - update ; .t count -update -ypixels 1.0 end ; update + updateText + .t count -update -ypixels 1.0 end + updateText set scrollInfo } {0.0 1.0} test textDisp-6.8 {DisplayText, vertical scrollbar updates} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1" - update + updateText set scrollInfo "unchanged" foreach i {2 3 4 5 6 7 8 9 10 11 12 13} { .t insert end "\nLine $i" } - update ; .t count -update -ypixels 1.0 end ; update + updateText + .t count -update -ypixels 1.0 end ; update set scrollInfo } [list 0.0 [expr {10.0/13}]] .t configure -yscrollcommand {} -xscrollcommand scroll test textDisp-6.9 {DisplayText, horizontal scrollbar updates} { .t configure -wrap none .t delete 1.0 end - update + updateText set scrollInfo unchanged .t insert end xxxxxxxxx\n .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx - update + updateText set scrollInfo } [list 0.0 [expr {4.0/11}]] test textDisp-6.10 {DisplayText, redisplay embedded windows after scroll.} {aqua} { @@ -964,9 +987,9 @@ test textDisp-6.10 {DisplayText, redisplay embedded windows after scroll.} {aqua .t insert end "\nLine 8\n" .t window create end -create { button %W.button_three -text "Button 3"} - update + updateText .t delete 2.0 3.0 - update + updateText list $tk_textEmbWinDisplay } {{4.0 6.0}} @@ -984,61 +1007,61 @@ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { test textDisp-7.1 {TkTextRedrawRegion} {nonPortable} { frame .f2 -bg #ff0000 place .f2 -in .t -relx 0.2 -relwidth 0.6 -rely 0.22 -relheight 0.55 - update + updateText destroy .f2 - update + updateText list $tk_textRelayout $tk_textRedraw } {{} {1.40 2.0 3.0 4.0 5.0 6.0}} test textDisp-7.2 {TkTextRedrawRegion} {nonPortable} { frame .f2 -bg #ff0000 place .f2 -in .t -relx 0 -relwidth 0.5 -rely 0 -relheight 0.5 - update + updateText destroy .f2 - update + updateText list $tk_textRelayout $tk_textRedraw } {{} {borders 1.0 1.20 1.40 2.0 3.0}} test textDisp-7.3 {TkTextRedrawRegion} {nonPortable} { frame .f2 -bg #ff0000 place .f2 -in .t -relx 0.5 -relwidth 0.5 -rely 0.5 -relheight 0.5 - update + updateText destroy .f2 - update + updateText list $tk_textRelayout $tk_textRedraw } {{} {borders 4.0 5.0 6.0 7.0 8.0}} test textDisp-7.4 {TkTextRedrawRegion} {nonPortable} { frame .f2 -bg #ff0000 place .f2 -in .t -relx 0.4 -relwidth 0.2 -rely 0 -relheight 0.2 \ -bordermode ignore - update + updateText destroy .f2 - update + updateText list $tk_textRelayout $tk_textRedraw } {{} {borders 1.0 1.20}} test textDisp-7.5 {TkTextRedrawRegion} {nonPortable} { frame .f2 -bg #ff0000 place .f2 -in .t -relx 0.4 -relwidth 0.2 -rely 1.0 -relheight 0.2 \ -anchor s -bordermode ignore - update + updateText destroy .f2 - update + updateText list $tk_textRelayout $tk_textRedraw } {{} {borders 7.0 8.0}} test textDisp-7.6 {TkTextRedrawRegion} {nonPortable} { frame .f2 -bg #ff0000 place .f2 -in .t -relx 0 -relwidth 0.2 -rely 0.55 -relheight 0.2 \ -anchor w -bordermode ignore - update + updateText destroy .f2 - update + updateText list $tk_textRelayout $tk_textRedraw } {{} {borders 3.0 4.0 5.0}} test textDisp-7.7 {TkTextRedrawRegion} {nonPortable} { frame .f2 -bg #ff0000 place .f2 -in .t -relx 1.0 -relwidth 0.2 -rely 0.55 -relheight 0.2 \ -anchor e -bordermode ignore - update + updateText destroy .f2 - update + updateText list $tk_textRelayout $tk_textRedraw } {{} {borders 3.0 4.0 5.0}} test textDisp-7.8 {TkTextRedrawRegion} {nonPortable} { @@ -1047,9 +1070,9 @@ test textDisp-7.8 {TkTextRedrawRegion} {nonPortable} { frame .f2 -bg #ff0000 place .f2 -in .t -relx 0.0 -relwidth 0.4 -rely 0.35 -relheight 0.4 \ -anchor nw -bordermode ignore - update + updateText destroy .f2 - update + updateText list $tk_textRelayout $tk_textRedraw } {{} {borders 4.0 5.0 6.0 7.0 eof}} .t configure -bd 0 @@ -1061,9 +1084,9 @@ test textDisp-8.1 {TkTextChanged: redisplay whole lines} {textfonts} { foreach i {3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } - update + updateText .t delete 2.36 2.38 - update + updateText list $tk_textRelayout $tk_textRedraw [.t bbox 2.32] } [list {2.0 2.18 2.38} {2.0 2.18 2.38} [list 101 [expr {2*$fixedDiff + 29}] 7 $fixedHeight]] .t configure -wrap char @@ -1073,9 +1096,9 @@ test textDisp-8.2 {TkTextChanged, redisplay whole lines} { foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } - update + updateText .t insert 1.2 xx - update + updateText list $tk_textRelayout $tk_textRedraw } {{1.0 1.20 1.40} {1.0 1.20 1.40}} test textDisp-8.3 {TkTextChanged} { @@ -1084,9 +1107,9 @@ test textDisp-8.3 {TkTextChanged} { foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } - update + updateText .t insert 2.0 xx - update + updateText list $tk_textRelayout $tk_textRedraw } {2.0 2.0} test textDisp-8.4 {TkTextChanged} { @@ -1095,9 +1118,9 @@ test textDisp-8.4 {TkTextChanged} { foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } - update + updateText .t delete 1.5 - update + updateText list $tk_textRelayout $tk_textRedraw } {{1.0 1.20 1.40} {1.0 1.20 1.40}} test textDisp-8.5 {TkTextChanged} { @@ -1106,9 +1129,9 @@ test textDisp-8.5 {TkTextChanged} { foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } - update + updateText .t delete 1.40 1.44 - update + updateText list $tk_textRelayout $tk_textRedraw } {{1.0 1.20 1.40} {1.0 1.20 1.40}} test textDisp-8.6 {TkTextChanged} { @@ -1117,9 +1140,9 @@ test textDisp-8.6 {TkTextChanged} { foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } - update + updateText .t delete 1.41 1.44 - update + updateText list $tk_textRelayout $tk_textRedraw } {{1.0 1.20 1.40} {1.0 1.20 1.40}} test textDisp-8.7 {TkTextChanged} { @@ -1128,9 +1151,9 @@ test textDisp-8.7 {TkTextChanged} { foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } - update + updateText .t delete 1.2 1.end - update + updateText list $tk_textRelayout $tk_textRedraw } {{1.0 9.0 10.0} {1.0 9.0 10.0}} test textDisp-8.8 {TkTextChanged} { @@ -1139,9 +1162,9 @@ test textDisp-8.8 {TkTextChanged} { foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } - update + updateText .t delete 2.2 - update + updateText list $tk_textRelayout $tk_textRedraw } {2.0 2.0} test textDisp-8.9 {TkTextChanged} { @@ -1150,9 +1173,9 @@ test textDisp-8.9 {TkTextChanged} { foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } - update + updateText .t delete 2.0 3.0 - update + updateText list $tk_textRelayout $tk_textRedraw } {{2.0 8.0} {2.0 8.0}} test textDisp-8.10 {TkTextChanged} { @@ -1160,21 +1183,23 @@ test textDisp-8.10 {TkTextChanged} { .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" .t tag add big 2.19 - update + updateText .t delete 2.19 - update + updateText set tk_textRedraw } {2.0 2.20 eof} test textDisp-8.11 {TkTextChanged, scrollbar notification when changes are off-screen} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n" .t configure -yscrollcommand scroll - update + updateText set scrollInfo "" .t insert end "a\nb\nc\n" # We need to wait for our asychronous callbacks to update the # scrollbar - update ; .t count -update -ypixels 1.0 end ; update + updateText + .t count -update -ypixels 1.0 end + updateText .t configure -yscrollcommand "" set scrollInfo } {0.0 0.625} @@ -1187,27 +1212,27 @@ test textDisp-8.12 {TkTextChanged, moving the insert cursor redraws only past an .t tag add hidden 5.0 8.0 .t tag configure hidden -elide true .t mark set insert 9.0 - update + updateText .t mark set insert 8.0 ; # up one line - update + updateText set res [list $tk_textRedraw] .t mark set insert 12.2 ; # in the visible text - update + updateText lappend res $tk_textRedraw .t mark set insert 6.5 ; # in the hidden text - update + updateText lappend res $tk_textRedraw .t mark set insert 3.5 ; # in the visible text again - update + updateText lappend res $tk_textRedraw .t mark set insert 3.8 ; # within the same line - update + updateText lappend res $tk_textRedraw } {{8.0 9.0} {8.0 12.0} {8.0 12.0} {3.0 8.0} {3.0 4.0}} test textDisp-8.13 {TkTextChanged, used to crash, see [06c1433906]} { .t delete 1.0 end .t insert 1.0 \nLine2\nLine3\n - update + updateText .t insert 3.0 "" .t delete 1.0 2.0 update idletasks @@ -1217,62 +1242,62 @@ test textDisp-9.1 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4" - update + updateText .t tag add big 2.2 2.4 - update + updateText list $tk_textRelayout $tk_textRedraw } {{2.0 2.18} {2.0 2.18}} test textDisp-9.2 {TkTextRedrawTag} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4" - update + updateText .t tag add big 1.2 2.4 - update + updateText list $tk_textRelayout $tk_textRedraw } {{1.0 2.0 2.17} {1.0 2.0 2.17}} test textDisp-9.3 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4" - update + updateText .t tag add big 2.2 2.4 - update + updateText .t tag remove big 1.0 end - update + updateText list $tk_textRelayout $tk_textRedraw } {{2.0 2.20} {2.0 2.20 eof}} test textDisp-9.4 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4" - update + updateText .t tag add big 2.2 2.20 - update + updateText .t tag remove big 1.0 end - update + updateText list $tk_textRelayout $tk_textRedraw } {{2.0 2.20} {2.0 2.20 eof}} test textDisp-9.5 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4" - update + updateText .t tag add big 2.2 2.end - update + updateText .t tag remove big 1.0 end - update + updateText list $tk_textRelayout $tk_textRedraw } {{2.0 2.20} {2.0 2.20 eof}} test textDisp-9.6 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap" - update + updateText .t tag add big 2.2 3.5 - update + updateText .t tag remove big 1.0 end - update + updateText list $tk_textRelayout $tk_textRedraw } {{2.0 2.20 3.0 3.20} {2.0 2.20 3.0 3.20 eof}} test textDisp-9.7 {TkTextRedrawTag} { @@ -1280,9 +1305,9 @@ test textDisp-9.7 {TkTextRedrawTag} { .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" .t tag add big 2.19 - update + updateText .t tag remove big 2.19 - update + updateText set tk_textRedraw } {2.0 2.20 eof} test textDisp-9.8 {TkTextRedrawTag} {textfonts} { @@ -1290,9 +1315,9 @@ test textDisp-9.8 {TkTextRedrawTag} {textfonts} { .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" .t tag add big 1.0 2.0 - update + updateText .t tag add big 2.0 2.5 - update + updateText set tk_textRedraw } {2.0 2.17} test textDisp-9.9 {TkTextRedrawTag} {textfonts} { @@ -1300,9 +1325,9 @@ test textDisp-9.9 {TkTextRedrawTag} {textfonts} { .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" .t tag add big 1.0 2.0 - update + updateText .t tag add big 1.5 2.5 - update + updateText set tk_textRedraw } {2.0 2.17} test textDisp-9.10 {TkTextRedrawTag} { @@ -1310,10 +1335,10 @@ test textDisp-9.10 {TkTextRedrawTag} { .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" .t tag add big 1.0 2.0 - update + updateText set tk_textRedraw {none} .t tag add big 1.3 1.5 - update + updateText set tk_textRedraw } {none} test textDisp-9.11 {TkTextRedrawTag} { @@ -1321,9 +1346,9 @@ test textDisp-9.11 {TkTextRedrawTag} { .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" .t tag add big 1.0 2.0 - update + updateText .t tag add big 1.0 2.0 - update + updateText set tk_textRedraw } {} test textDisp-9.12 {TkTextRedrawTag} { @@ -1334,24 +1359,24 @@ test textDisp-9.12 {TkTextRedrawTag} { } .t tag configure hidden -elide true .t tag add hidden 2.6 3.6 - update + updateText .t tag add hidden 3.11 4.6 - update + updateText list $tk_textRelayout $tk_textRedraw } {2.0 {2.0 eof}} test textDisp-9.13 {TkTextRedrawTag} { .t configure -wrap none .t delete 1.0 end for {set i 1} {$i < 10} {incr i} { - .t insert end "Line $i - This is Line [format %c [expr 64+$i]]\n" + .t insert end "Line $i - This is Line [format %c [expr {64+$i}]]\n" } .t tag add hidden 2.8 2.17 .t tag add hidden 6.8 7.17 .t tag configure hidden -background red .t tag configure hidden -elide true - update + updateText .t tag configure hidden -elide false - update + updateText list $tk_textRelayout $tk_textRedraw } {{2.0 6.0 7.0} {2.0 6.0 7.0}} test textDisp-9.14 {TkTextRedrawTag} { @@ -1361,7 +1386,7 @@ test textDisp-9.14 {TkTextRedrawTag} { } .tnocrash tag configure mytag1 -relief raised .tnocrash tag configure mytag2 -relief solid - update + updateText proc doit {} { .tnocrash tag add mytag1 4.0 5.0 .tnocrash tag add mytag2 4.0 5.0 @@ -1383,9 +1408,9 @@ test textDisp-10.1 {TkTextRelayoutWindow} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" - update + updateText .t configure -bg black - update + updateText list $tk_textRelayout $tk_textRedraw } {{1.0 2.0 2.20 3.0 3.20 4.0} {borders 1.0 2.0 2.20 3.0 3.20 4.0 eof}} .t configure -bg [lindex [.t configure -bg] 3] @@ -1399,7 +1424,7 @@ test textDisp-10.2 {TkTextRelayoutWindow} { .top.t see insert tkwait visibility .top.t place .top.t -width 150 -height 100 - update + updateText .top.t index @0,0 } {1.0} catch {destroy .top} @@ -1409,96 +1434,96 @@ catch {destroy .top} for {set i 2} {$i <= 200} {incr i} { .t insert end "\nLine $i" } -update +updateText test textDisp-11.1 {TkTextSetYView} { .t yview 30.0 - update + updateText .t index @0,0 } {30.0} test textDisp-11.2 {TkTextSetYView} { .t yview 30.0 - update + updateText .t yview 32.0 - update + updateText list [.t index @0,0] $tk_textRedraw } {32.0 {40.0 41.0}} test textDisp-11.3 {TkTextSetYView} { .t yview 30.0 - update + updateText .t yview 28.0 - update + updateText list [.t index @0,0] $tk_textRedraw } {28.0 {28.0 29.0}} test textDisp-11.4 {TkTextSetYView} { .t yview 30.0 - update + updateText .t yview 31.4 - update + updateText list [.t index @0,0] $tk_textRedraw } {31.0 40.0} test textDisp-11.5 {TkTextSetYView} { .t yview 30.0 - update + updateText set tk_textRedraw {} .t yview -pickplace 31.0 - update + updateText list [.t index @0,0] $tk_textRedraw } {30.0 {}} test textDisp-11.6 {TkTextSetYView} { .t yview 30.0 - update + updateText set tk_textRedraw {} .t yview -pickplace 28.0 - update + updateText list [.t index @0,0] $tk_textRedraw } {28.0 {28.0 29.0}} test textDisp-11.7 {TkTextSetYView} { .t yview 30.0 - update ; update + updateText set tk_textRedraw {} .t yview -pickplace 26.0 - update + updateText list [.t index @0,0] $tk_textRedraw } {21.0 {21.0 22.0 23.0 24.0 25.0 26.0 27.0 28.0 29.0}} test textDisp-11.8 {TkTextSetYView} { .t yview 30.0 - update + updateText set tk_textRedraw {} .t yview -pickplace 41.0 - update + updateText list [.t index @0,0] $tk_textRedraw } {32.0 {40.0 41.0}} test textDisp-11.9 {TkTextSetYView} { .t yview 30.0 - update + updateText set tk_textRedraw {} .t yview -pickplace 43.0 - update + updateText list [.t index @0,0] $tk_textRedraw } {38.0 {40.0 41.0 42.0 43.0 44.0 45.0 46.0 47.0 48.0}} test textDisp-11.10 {TkTextSetYView} { .t yview 30.0 - update + updateText set tk_textRedraw {} .t yview 10000.0 - update + updateText list [.t index @0,0] $tk_textRedraw } {191.0 {191.0 192.0 193.0 194.0 195.0 196.0 197.0 198.0 199.0 200.0}} test textDisp-11.11 {TkTextSetYView} { .t yview 195.0 - update + updateText set tk_textRedraw {} .t yview 197.0 - update + updateText list [.t index @0,0] $tk_textRedraw } {191.0 {191.0 192.0 193.0 194.0 195.0 196.0}} test textDisp-11.12 {TkTextSetYView, wrapped line is off-screen} { .t insert 10.0 "Long line with enough text to wrap\n" .t yview 1.0 - update + updateText set tk_textRedraw {} .t see 10.30 - update + updateText list [.t index @0,0] $tk_textRedraw } {2.0 10.20} .t delete 10.0 11.0 @@ -1512,15 +1537,15 @@ test textDisp-11.13 {TkTestSetYView, partially visible last line} { for {set i 2} {$i <= 100} {incr i} { .top.t insert end "\nLine $i" } - update + updateText scan [wm geometry .top] "%dx%d" w2 h2 - wm geometry .top ${w2}x[expr $h2-2] - update + wm geometry .top ${w2}x[expr {$h2-2}] + updateText .top.t yview 1.0 - update + updateText set tk_textRedraw {} .top.t see 5.0 - update + updateText # Note, with smooth scrolling, the results of this test # have changed, and the old '2.0 {5.0 6.0}' is quite wrong. list [.top.t index @0,0] $tk_textRedraw @@ -1534,29 +1559,29 @@ pack .top.t for {set i 2} {$i <= 20} {incr i} { .top.t insert end "\nLine $i" } -update +updateText test textDisp-11.14 {TkTextSetYView, only a few lines visible} { .top.t yview 5.0 - update + updateText .top.t see 10.0 .top.t index @0,0 } {8.0} test textDisp-11.15 {TkTextSetYView, only a few lines visible} { .top.t yview 5.0 - update + updateText .top.t see 11.0 .top.t index @0,0 # The index 9.0 should be just visible by a couple of pixels } {9.0} test textDisp-11.16 {TkTextSetYView, only a few lines visible} { .top.t yview 8.0 - update + updateText .top.t see 5.0 .top.t index @0,0 } {5.0} test textDisp-11.17 {TkTextSetYView, only a few lines visible} { .top.t yview 8.0 - update + updateText .top.t see 4.0 .top.t index @0,0 # The index 2.0 should be just visible by a couple of pixels @@ -1571,7 +1596,7 @@ test textDisp-11.18 {TkTextSetYView, see in elided lines} { .top.t tag add hidden 4.10 "4.10 lineend" .top.t tag add hidden 5.15 10.3 .top.t tag configure hidden -elide true - update + updateText .top.t see "8.0 lineend" # The index "8.0 lineend" is on screen despite elided -> no scroll .top.t index @0,0 @@ -1591,19 +1616,19 @@ test textDisp-11.19 {TkTextSetYView, see in elided lines} { # Indices 21.0, 17.0 and 15.0 are all on the same display line # therefore index @0,0 shall be the same for all of them .top.t see end - update + updateText .top.t see 21.0 - update + updateText set ind1 [.top.t index @0,0] .top.t see end - update + updateText .top.t see 17.0 - update + updateText set ind2 [.top.t index @0,0] .top.t see end - update + updateText .top.t see 15.0 - update + updateText set ind3 [.top.t index @0,0] list [expr {$ind1 == $ind2}] [expr {$ind1 == $ind3}] } {1 1} @@ -1626,7 +1651,7 @@ test textDisp-11.21 {TkTextSetYView, window height smaller than the line height} } set lineheight [font metrics [.top.t cget -font] -linespace] wm geometry .top 200x[expr {$lineheight / 2}] - update + updateText .top.t see 1.0 .top.t index @0,[expr {$lineheight - 2}] } {1.0} @@ -1636,38 +1661,38 @@ test textDisp-11.21 {TkTextSetYView, window height smaller than the line height} .t insert 50.0 "This is a long line, one that will wrap around twice.\n" test textDisp-12.1 {MeasureUp} { .t yview 100.0 - update + updateText .t yview -pickplace 52.0 - update + updateText .t index @0,0 } {49.0} test textDisp-12.2 {MeasureUp} { .t yview 100.0 - update + updateText .t yview -pickplace 53.0 - update + updateText .t index @0,0 } {50.0} test textDisp-12.3 {MeasureUp} { .t yview 100.0 - update + updateText .t yview -pickplace 50.10 - update + updateText .t index @0,0 } {45.0} .t configure -wrap none test textDisp-12.4 {MeasureUp} { .t yview 100.0 - update + updateText .t yview -pickplace 53.0 - update + updateText .t index @0,0 } {48.0} test textDisp-12.5 {MeasureUp} { .t yview 100.0 - update + updateText .t yview -pickplace 50.10 - update + updateText .t index @0,0 } {45.0} @@ -1690,7 +1715,7 @@ test textDisp-13.3 {TkTextSeeCmd procedure} { test textDisp-13.4 {TkTextSeeCmd procedure} { .t xview moveto 0 .t yview moveto 0 - update + updateText .t see 4.2 .t index @0,0 } {1.0} @@ -1698,7 +1723,7 @@ test textDisp-13.5 {TkTextSeeCmd procedure} { .t configure -wrap char .t xview moveto 0 .t yview moveto 0 - update + updateText .t see 12.1 .t index @0,0 } {3.0} @@ -1706,7 +1731,7 @@ test textDisp-13.6 {TkTextSeeCmd procedure} { .t configure -wrap char .t xview moveto 0 .t yview moveto 0 - update + updateText .t see 30.50 set x [.t index @0,0] .t configure -wrap none @@ -1717,7 +1742,7 @@ test textDisp-13.7 {TkTextSeeCmd procedure} {textfonts} { .t yview moveto 0 .t tag add sel 30.20 .t tag add sel 30.40 - update + updateText .t see 30.50 .t yview 25.0 .t see 30.50 @@ -1734,7 +1759,7 @@ test textDisp-13.8 {TkTextSeeCmd procedure} {textfonts} { .t yview moveto 0 .t tag add sel 30.20 .t tag add sel 30.50 - update + updateText .t see 30.50 set x [list [.t bbox 30.50]] .t see 30.60 @@ -1745,12 +1770,12 @@ test textDisp-13.8 {TkTextSeeCmd procedure} {textfonts} { lappend x [.t bbox 30.90] } [list [list 73 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight] [list 136 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight] [list 136 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight] [list 73 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight]] test textDisp-13.9 {TkTextSeeCmd procedure} {textfonts} { - wm geom . [expr $width-2]x$height + wm geom . [expr {$width-2}]x$height .t xview moveto 0 .t yview moveto 0 .t tag add sel 30.20 .t tag add sel 30.50 - update + updateText .t see 30.50 set x [list [.t bbox 30.50]] .t see 30.60 @@ -1782,13 +1807,13 @@ test textDisp-13.11 {TkTextSeeCmd procedure} {} { } wm geometry .top2 300x200+0+0 - update + updateText .top2.t2 see "1.0 lineend" - update + updateText set ref [.top2.t2 index @0,0] .top2.t2 insert "1.0 lineend" ç .top2.t2 see "1.0 lineend" - update + updateText set new [.top2.t2 index @0,0] set res [.top2.t2 compare $ref == $new] destroy .top2 @@ -1799,7 +1824,7 @@ wm geom . {} .t configure -wrap none test textDisp-14.1 {TkTextXviewCmd procedure} { .t delete 1.0 end - update + updateText .t insert end xxxxxxxxx\n .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n" .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" @@ -1809,7 +1834,7 @@ test textDisp-14.1 {TkTextXviewCmd procedure} { .t configure -wrap char test textDisp-14.2 {TkTextXviewCmd procedure} { .t delete 1.0 end - update + updateText .t insert end xxxxxxxxx\n .t insert end "xxxxx\n" .t insert end "xxxx" @@ -1818,7 +1843,7 @@ test textDisp-14.2 {TkTextXviewCmd procedure} { .t configure -wrap none test textDisp-14.3 {TkTextXviewCmd procedure} { .t delete 1.0 end - update + updateText .t insert end xxxxxxxxx\n .t insert end "xxxxx\n" .t insert end "xxxx" @@ -1859,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"}} @@ -1896,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}} @@ -1911,43 +1936,43 @@ for {set i 1} {$i < 99} {incr i} { .t insert 50.0 "This is a long line, one that will wrap around twice.\n" test textDisp-15.1 {ScrollByLines procedure, scrolling backwards} { .t yview 45.0 - update + updateText .t yview scroll -3 units .t index @0,0 } {42.0} test textDisp-15.2 {ScrollByLines procedure, scrolling backwards} { .t yview 51.0 - update + updateText .t yview scroll -2 units .t index @0,0 } {50.20} test textDisp-15.3 {ScrollByLines procedure, scrolling backwards} { .t yview 51.0 - update + updateText .t yview scroll -4 units .t index @0,0 } {49.0} test textDisp-15.4 {ScrollByLines procedure, scrolling backwards} { .t yview 50.20 - update + updateText .t yview scroll -2 units .t index @0,0 } {49.0} test textDisp-15.5 {ScrollByLines procedure, scrolling backwards} { .t yview 50.40 - update + updateText .t yview scroll -2 units .t index @0,0 } {50.0} test textDisp-15.6 {ScrollByLines procedure, scrolling backwards} { .t yview 3.2 - update + updateText .t yview scroll -5 units .t index @0,0 } {1.0} test textDisp-15.7 {ScrollByLines procedure, scrolling forwards} { .t yview 48.0 - update + updateText .t yview scroll 4 units .t index @0,0 } {50.40} @@ -1973,7 +1998,7 @@ test textDisp-15.8 {Scrolling near end of window} { for {set i 1} {$i < $textheight} {incr i} { .tf.f.t insert end "\nLine $i" } - update ; after 1000 ; update + updateText set refind [.tf.f.t index @0,[winfo height .tf.f.t]] # Should scroll and should not crash! .tf.f.t yview scroll 1 unit @@ -1993,7 +2018,8 @@ for {set i 2} {$i <= 200} {incr i} { .t tag add big 100.0 105.0 .t insert 151.end { has a lot of extra text, so that it wraps around on the screen several times over.} .t insert 153.end { also has enoug extra text to wrap.} -update ; .t count -update -ypixels 1.0 end +updateText +.t count -update -ypixels 1.0 end test textDisp-16.1 {TkTextYviewCmd procedure} { .t yview 21.0 set x [.t yview] @@ -2014,7 +2040,7 @@ test textDisp-16.5 {TkTextYviewCmd procedure} { } {1 {bad option "-bogus": must be moveto or scroll}} test textDisp-16.6 {TkTextYviewCmd procedure, integer position} { .t yview 100.0 - update + updateText .t yview 98 .t index @0,0 } {99.0} @@ -2069,7 +2095,7 @@ test textDisp-16.18 {TkTextYviewCmd procedure, "moveto" roundoff} {textfonts} { text .top1.t -height 3 -width 4 -wrap none -setgrid 1 -padx 6 \ -spacing3 6 pack .top1.t - update + updateText .top1.t insert end "1\n2\n3\n4\n5\n6" .top1.t yview moveto 0.3333 set result [.top1.t yview] @@ -2078,65 +2104,65 @@ 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"}} test textDisp-16.22 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t yview 50.0 - update + updateText .t yview scroll -1 pages .t index @0,0 } {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 - update + updateText .t yview scroll -3 pa .t index @0,0 } {26.0} test textDisp-16.24 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t yview 5.0 - update + updateText .t yview scroll -3 pa .t index @0,0 } {1.0} test textDisp-16.25 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t configure -height 1 - update + updateText .t yview 50.0 - update + updateText .t yview scroll -1 pages set x [.t index @0,0] .t configure -height 10 - update + updateText set x } {49.0} test textDisp-16.26 {TkTextYviewCmd procedure, "scroll" option, forward pages} { .t yview 50.0 - update + updateText .t yview scroll 1 pages .t index @0,0 } {58.0} test textDisp-16.27 {TkTextYviewCmd procedure, "scroll" option, forward pages} { .t yview 50.0 - update + updateText .t yview scroll 2 pages .t index @0,0 } {66.0} test textDisp-16.28 {TkTextYviewCmd procedure, "scroll" option, forward pages} {textfonts} { .t yview 98.0 - update + updateText .t yview scroll 1 page - set res [expr int([.t index @0,0])] + set res [expr {int([.t index @0,0])}] if {$fixedDiff > 1} { incr res -1 } @@ -2144,30 +2170,30 @@ test textDisp-16.28 {TkTextYviewCmd procedure, "scroll" option, forward pages} { } {102} test textDisp-16.29 {TkTextYviewCmd procedure, "scroll" option, forward pages} { .t configure -height 1 - update + updateText .t yview 50.0 - update + updateText .t yview scroll 1 pages set x [.t index @0,0] .t configure -height 10 - update + updateText set x } {51.0} test textDisp-16.30 {TkTextYviewCmd procedure, "scroll units" option} { .t yview 45.0 - update + updateText .t yview scroll -3 units .t index @0,0 } {42.0} test textDisp-16.31 {TkTextYviewCmd procedure, "scroll units" option} { .t yview 149.0 - update + updateText .t yview scroll 4 units .t index @0,0 } {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}} @@ -2266,7 +2292,7 @@ test textDisp-16.42 {TkTextYviewCmd procedure with indices in elided lines} { .t tag configure hidden -elide true .t yview 35.0 .t yview scroll [expr {- 15 * $fixedHeight}] pixels - update + updateText .t index @0,0 } {5.0} test textDisp-16.43 {TkTextYviewCmd procedure with indices in elided lines} { @@ -2280,7 +2306,7 @@ test textDisp-16.43 {TkTextYviewCmd procedure with indices in elided lines} { .t tag configure hidden -elide true .t yview 35.0 .t yview scroll -15 units - update + updateText .t index @0,0 } {5.0} test textDisp-16.44 {TkTextYviewCmd procedure, scroll down, with elided lines} { @@ -2291,9 +2317,9 @@ test textDisp-16.44 {TkTextYviewCmd procedure, scroll down, with elided lines} { .t insert end "$x 1111\n$x 2222\n$x 3333\n$x 4444\n$x 5555\n$x 6666" hidden } .t tag configure hidden -elide true ; # 5 hidden lines - update - .t see [expr {5 + [winfo height .t] / $fixedHeight} + 1].0 - update + updateText + .t see [expr {5 + [winfo height .t] / $fixedHeight + 1}].0 + updateText .t index @0,0 } {2.0} @@ -2369,7 +2395,7 @@ test textDisp-18.1 {GetXView procedure} { .t insert end xxxxxxxxx\n .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx - update + updateText set scrollInfo } [list 0.0 [expr {4.0/11}]] test textDisp-18.2 {GetXView procedure} { @@ -2378,13 +2404,13 @@ test textDisp-18.2 {GetXView procedure} { .t insert end xxxxxxxxx\n .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx - update + updateText set scrollInfo } {0.0 1.0} test textDisp-18.3 {GetXView procedure} { .t configure -wrap none .t delete 1.0 end - update + updateText set scrollInfo } {0.0 1.0} test textDisp-18.4 {GetXView procedure} { @@ -2393,7 +2419,7 @@ test textDisp-18.4 {GetXView procedure} { .t insert end xxxxxxxxx\n .t insert end xxxxxx\n .t insert end xxxxxxxxxxxxxxxxx - update + updateText set scrollInfo } {0.0 1.0} test textDisp-18.5 {GetXView procedure} { @@ -2403,7 +2429,7 @@ test textDisp-18.5 {GetXView procedure} { .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx .t xview scroll 31 units - update + updateText set scrollInfo } [list [expr {31.0/55}] [expr {51.0/55}]] test textDisp-18.6 {GetXView procedure} { @@ -2414,27 +2440,27 @@ test textDisp-18.6 {GetXView procedure} { .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" .t xview moveto 0 .t xview scroll 31 units - update + updateText set x {} lappend x $scrollInfo .t configure -wrap char - update + updateText lappend x $scrollInfo .t configure -wrap word - update + updateText lappend x $scrollInfo .t configure -wrap none - update + updateText lappend x $scrollInfo } [list [list [expr {31.0/56}] [expr {51.0/56}]] {0.0 1.0} {0.0 1.0} [list 0.0 [expr {5.0/14}]]] test textDisp-18.7 {GetXView procedure} { .t configure -wrap none .t delete 1.0 end - update + updateText set scrollInfo unchanged .t insert end xxxxxx\n .t insert end xxx - update + updateText set scrollInfo } {unchanged} test textDisp-18.8 {GetXView procedure} { @@ -2448,10 +2474,10 @@ test textDisp-18.8 {GetXView procedure} { .t configure -wrap none .t delete 1.0 end .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n - update + updateText .t delete 1.0 end .t configure -xscrollcommand scrollError - update + updateText set x } {{scrolling error} {scrolling error while executing @@ -2468,37 +2494,37 @@ catch {rename bogus {}} test textDisp-19.1 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end - update + updateText set scrollInfo } {0.0 1.0} test textDisp-19.2 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end - update + updateText set scrollInfo "unchanged" .t insert 1.0 "Line1\nLine2" - update + updateText set scrollInfo } {unchanged} test textDisp-19.3 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end - update; after 10 ; update + updateText set scrollInfo "unchanged" .t insert 1.0 "Line 1\nLine 2 is so long that it wraps around\nLine 3" - update + updateText set scrollInfo } {unchanged} test textDisp-19.4 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1" - update + updateText set scrollInfo "unchanged" foreach i {2 3 4 5 6 7 8 9 10 11 12 13} { .t insert end "\nLine $i" } - update + updateText set scrollInfo } [list 0.0 [expr {70.0/91}]] test textDisp-19.5 {GetYView procedure} { @@ -2509,7 +2535,7 @@ test textDisp-19.5 {GetYView procedure} { .t insert end "\nLine $i" } .t insert 2.end " is really quite long; in fact it's so long that it wraps three times" - update ; after 100 + updateText set x $scrollInfo } {0.0 0.625} test textDisp-19.6 {GetYView procedure} { @@ -2521,7 +2547,7 @@ test textDisp-19.6 {GetYView procedure} { } .t insert 2.end " is really quite long; in fact it's so long that it wraps three times" .t yview 4.0 - update + updateText set x $scrollInfo } {0.375 1.0} test textDisp-19.7 {GetYView procedure} { @@ -2533,7 +2559,7 @@ test textDisp-19.7 {GetYView procedure} { } .t insert 2.end " is really quite long; in fact it's so long that it wraps three times" .t yview 2.26 - update; after 1; update + updateText set x $scrollInfo } {0.125 0.75} test textDisp-19.8 {GetYView procedure} { @@ -2545,7 +2571,7 @@ test textDisp-19.8 {GetYView procedure} { } .t insert 10.end " is really quite long; in fact it's so long that it wraps three times" .t yview 2.0 - update + updateText .t count -update -ypixels 1.0 end set x $scrollInfo } {0.0625 0.6875} @@ -2557,7 +2583,7 @@ test textDisp-19.9 {GetYView procedure} { .t insert end "\nLine $i" } .t yview 3.0 - update + updateText set scrollInfo } [list [expr {4.0/30}] 0.8] test textDisp-19.10 {GetYView procedure} { @@ -2568,7 +2594,7 @@ test textDisp-19.10 {GetYView procedure} { .t insert end "\nLine $i" } .t yview 11.0 - update + updateText set scrollInfo } [list [expr {1.0/3}] 1.0] test textDisp-19.10.1 {Widget manipulation causes height miscount} { @@ -2579,7 +2605,7 @@ test textDisp-19.10.1 {Widget manipulation causes height miscount} { .t insert end "\nLine $i" } .t yview 11.0 - update + updateText .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Line 1" @@ -2589,7 +2615,7 @@ test textDisp-19.10.1 {Widget manipulation causes height miscount} { .t insert end "\nThis last line wraps around four " .t insert end "times with a little bit left on the last line." .t yview insert - update + updateText .t count -update -ypixels 1.0 end set scrollInfo } {0.5 1.0} @@ -2603,7 +2629,7 @@ test textDisp-19.11 {GetYView procedure} { .t insert end "\nThis last line wraps around four " .t insert end "times with a little bit left on the last line." .t yview insert - update + updateText .t count -update -ypixels 1.0 end set scrollInfo } {0.5 1.0} @@ -2741,10 +2767,10 @@ test textDisp-19.12 {GetYView procedure, partially visible last line} { pack .top.t -expand yes -fill both .top.t insert end "Line 1\nLine 2\nLine 3\nLine 4\nLine 5" # Need to wait for asychronous calculations to complete. - update ; after 10 + updateText scan [wm geom .top] %dx%d twidth theight - wm geom .top ${twidth}x[expr $theight - 3] - update + wm geom .top ${twidth}x[expr {$theight - 3}] + updateText .top.t yview } [list 0.0 [expr {(5.0 * $fixedHeight - 3.0)/ (5.0 * $fixedHeight)}]] test textDisp-19.13 {GetYView procedure, partially visible last line} {textfonts} { @@ -2755,10 +2781,10 @@ test textDisp-19.13 {GetYView procedure, partially visible last line} {textfonts pack .top.t -expand yes -fill both .top.t insert end "Line 1\nLine 2\nLine 3\nLine 4 has enough text to wrap around at least once" # Need to wait for asychronous calculations to complete. - update ; after 10 + updateText scan [wm geom .top] %dx%d twidth theight - wm geom .top ${twidth}x[expr $theight - 3] - update + wm geom .top ${twidth}x[expr {$theight - 3}] + updateText .top.t yview } [list 0.0 [expr {(5.0 * $fixedHeight - 3.0)/ (5.0 * $fixedHeight)}]] catch {destroy .top} @@ -2772,13 +2798,14 @@ test textDisp-19.14 {GetYView procedure} { .t insert end "\nThis last line wraps around four " .t insert end "times with a little bit left on the last line." # Need to update so everything is calculated. - update ; .t count -update -ypixels 1.0 end - update ; after 10 ; update + updateText + .t count -update -ypixels 1.0 end + updateText set scrollInfo "unchanged" .t mark set insert 3.0 .t tag configure x -background red .t tag add x 1.0 5.0 - update + updateText .t tag delete x set scrollInfo } {unchanged} @@ -2791,14 +2818,14 @@ test textDisp-19.15 {GetYView procedure} { } .t insert end "\nThis last line wraps around four " .t insert end "times with a bit little left on the last line." - update + updateText .t configure -yscrollcommand scrollError proc bgerror args { global x errorInfo errorCode set x [list $args $errorInfo $errorCode] } .t delete 1.0 end - update + updateText rename bgerror {} .t configure -yscrollcommand scroll set x @@ -2820,7 +2847,9 @@ test textDisp-19.16 {count -ypixels} { .t insert end "\nThis last line wraps around four " .t insert end "times with a little bit left on the last line." # Need to update so everything is calculated. - update ; .t count -update -ypixels 1.0 end ; update + updateText + .t count -update -ypixels 1.0 end + updateText set res {} lappend res \ [.t count -ypixels 1.0 end] \ @@ -2871,7 +2900,7 @@ test textDisp-19.18 {count -ypixels with indices in elided lines} { update lappend res [.t count -ypixels 5.0 25.0] .t yview scroll [expr {- 15 * $fixedHeight}] pixels - update + updateText lappend res [.t count -ypixels 5.0 25.0] } [list [expr {5 * $fixedHeight}] [expr {5 * $fixedHeight}]] test textDisp-19.19 {count -ypixels with indices in elided lines} { @@ -2884,7 +2913,7 @@ test textDisp-19.19 {count -ypixels with indices in elided lines} { .t tag add hidden 5.27 11.0 .t tag configure hidden -elide true .t yview 5.0 - update + updateText set res [list [.t count -ypixels 5.0 11.0] [.t count -ypixels 5.0 11.20]] } [list [expr {1 * $fixedHeight}] [expr {2 * $fixedHeight}]] .t delete 1.0 end @@ -2976,7 +3005,7 @@ for {set i 2} {$i <= 200} {incr i} { .t configure -wrap word .t delete 50.0 51.0 .t insert 50.0 "This is a long line, one that will wrap around twice.\n" -update +updateText .t tag add x 50.1 test textDisp-22.1 {TkTextCharBbox} {textfonts} { .t config -wrap word @@ -2992,39 +3021,39 @@ test textDisp-22.2 {TkTextCharBbox} {textfonts} { test textDisp-22.3 {TkTextCharBbox, cut-off lines} {textfonts} { .t config -wrap char .t yview 10.0 - wm geom . ${width}x[expr $height-1] - update + wm geom . ${width}x[expr {$height-1}] + updateText list [.t bbox 19.1] [.t bbox 20.1] } [list [list 10 [expr {3+9*$fixedHeight}] 7 $fixedHeight] [list 10 [expr {3+10*$fixedHeight}] 7 3]] test textDisp-22.4 {TkTextCharBbox, cut-off lines} {textfonts} { .t config -wrap char .t yview 10.0 - wm geom . ${width}x[expr $height+1] - update + wm geom . ${width}x[expr {$height+1}] + updateText list [.t bbox 19.1] [.t bbox 20.1] } [list [list 10 [expr {3+9*$fixedHeight}] 7 $fixedHeight] [list 10 [expr {3+10*$fixedHeight}] 7 5]] test textDisp-22.5 {TkTextCharBbox, cut-off char} {textfonts} { .t config -wrap none .t yview 10.0 - wm geom . [expr $width-95]x$height - update + wm geom . [expr {$width-95}]x$height + updateText .t bbox 15.6 } [list 45 [expr {3+5*$fixedHeight}] 7 $fixedHeight] test textDisp-22.6 {TkTextCharBbox, line visible but not char} {textfonts} { .t config -wrap char .t yview 10.0 .t tag add big 20.2 20.5 - wm geom . ${width}x[expr $height+3] - update + wm geom . ${width}x[expr {$height+3}] + updateText list [.t bbox 19.1] [.t bbox 20.1] [.t bbox 20.2] } [list [list 10 [expr {3+9*$fixedHeight}] 7 $fixedHeight] {} [list 17 [expr {3+10*$fixedHeight}] 14 7]] wm geom . {} -update +updateText test textDisp-22.7 {TkTextCharBbox, different character sizes} {textfonts} { .t config -wrap char .t yview 10.0 .t tag add big 12.2 12.5 - update + updateText list [.t bbox 12.1] [.t bbox 12.2] } [list [list 10 [expr {3 + 2*$fixedHeight + $ascentDiff}] 7 $fixedHeight] [list 17 [expr {3+ 2*$fixedHeight}] 14 27]] .t tag remove big 1.0 end @@ -3051,7 +3080,7 @@ test textDisp-22.9 {TkTextCharBbox, handling of spacing} {textfonts} { .t window create 1.7 -window .t.f2 -align center .t window create 2.1 -window .t.f3 -align bottom .t window create 2.10 -window .t.f4 -align baseline - update + updateText list [.t bbox .t.f1] [.t bbox .t.f2] [.t bbox .t.f3] [.t bbox .t.f4] \ [.t bbox 1.1] [.t bbox 2.9] } [list [list 24 11 10 4] [list 55 [expr {$fixedDiff/2 + 15}] 10 4] [list 10 [expr {2*$fixedDiff + 43}] 10 4] [list 76 [expr {2*$fixedDiff + 40}] 10 4] [list 10 11 7 $fixedHeight] [list 69 [expr {$fixedDiff + 34}] 7 $fixedHeight]] @@ -3060,12 +3089,12 @@ test textDisp-22.10 {TkTextCharBbox, handling of elided lines} {textfonts} { .t configure -wrap char .t delete 1.0 end for {set i 1} {$i < 10} {incr i} { - .t insert end "Line $i - Line [format %c [expr 64+$i]]\n" + .t insert end "Line $i - Line [format %c [expr {64+$i}]]\n" } .t tag add hidden 2.8 2.13 .t tag add hidden 6.8 7.13 .t tag configure hidden -elide true - update + updateText list \ [expr {[lindex [.t bbox 2.9] 0] - [lindex [.t bbox 2.8] 0]}] \ [expr {[lindex [.t bbox 2.10] 0] - [lindex [.t bbox 2.8] 0]}] \ @@ -3083,11 +3112,11 @@ test textDisp-22.11 {TkTextCharBbox, handling of wrapped elided lines} {textfont .t configure -wrap char .t delete 1.0 end for {set i 1} {$i < 10} {incr i} { - .t insert end "Line $i - Line _$i - Lines .$i - Line [format %c [expr 64+$i]]\n" + .t insert end "Line $i - Line _$i - Lines .$i - Line [format %c [expr {64+$i}]]\n" } .t tag add hidden 1.30 2.5 .t tag configure hidden -elide true - update + updateText list \ [expr {[lindex [.t bbox 1.30] 0] - [lindex [.t bbox 2.4] 0]}] \ [expr {[lindex [.t bbox 1.30] 0] - [lindex [.t bbox 2.5] 0]}] @@ -3101,7 +3130,7 @@ for {set i 2} {$i <= 200} {incr i} { .t configure -wrap word .t delete 50.0 51.0 .t insert 50.0 "This is a long line, one that will wrap around twice.\n" -update +updateText test textDisp-23.1 {TkTextDLineInfo} {textfonts} { .t config -wrap word .t yview 48.0 @@ -3110,33 +3139,33 @@ test textDisp-23.1 {TkTextDLineInfo} {textfonts} { } [list {} [list 3 3 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {4*$fixedDiff + 55}] 91 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] {}] test textDisp-23.2 {TkTextDLineInfo} {textfonts} { .t config -bd 4 -wrap word - update + updateText .t yview 48.0 .t dlineinfo 50.40 } [list 7 [expr {4*$fixedDiff + 59}] 91 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] .t config -bd 0 test textDisp-23.3 {TkTextDLineInfo} {textfonts} { .t config -wrap none - update + updateText .t yview 48.0 list [.t dlineinfo 50.40] [.t dlineinfo 57.3] } [list [list 3 [expr {2*$fixedDiff + 29}] 371 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {9*$fixedDiff + 120}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]] test textDisp-23.4 {TkTextDLineInfo, cut-off lines} {textfonts} { .t config -wrap char .t yview 10.0 - wm geom . ${width}x[expr $height-1] - update + wm geom . ${width}x[expr {$height-1}] + updateText list [.t dlineinfo 19.0] [.t dlineinfo 20.0] } [list [list 3 [expr {9*$fixedDiff + 120}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {10*$fixedDiff + 133}] 49 3 [expr {$fixedDiff + 10}]]] test textDisp-23.5 {TkTextDLineInfo, cut-off lines} {textfonts} { .t config -wrap char .t yview 10.0 - wm geom . ${width}x[expr $height+1] - update + wm geom . ${width}x[expr {$height+1}] + updateText list [.t dlineinfo 19.0] [.t dlineinfo 20.0] } [list [list 3 [expr {9*$fixedDiff + 120}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {10*$fixedDiff + 133}] 49 5 [expr {$fixedDiff + 10}]]] wm geom . {} -update +updateText test textDisp-23.6 {TkTextDLineInfo, horizontal scrolling} {textfonts} { .t config -wrap none .t delete 1.0 end @@ -3144,7 +3173,7 @@ test textDisp-23.6 {TkTextDLineInfo, horizontal scrolling} {textfonts} { .t insert end "Second line is a very long one that doesn't all fit.\n" .t insert end "Third" .t xview scroll 6 units - update + updateText list [.t dlineinfo 1.0] [.t dlineinfo 2.0] [.t dlineinfo 3.0] } [list [list -39 3 70 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list -39 [expr {$fixedDiff + 16}] 364 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list -39 [expr {2*$fixedDiff + 29}] 35 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]] .t xview moveto 0 @@ -3172,16 +3201,16 @@ test textDisp-24.2 {TkTextCharLayoutProc} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" - wm geom . [expr $width+1]x$height - update + wm geom . [expr {$width+1}]x$height + updateText list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 12 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-24.3 {TkTextCharLayoutProc} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" - wm geom . [expr $width-1]x$height - update + wm geom . [expr {$width-1}]x$height + updateText list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 10 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-24.4 {TkTextCharLayoutProc, newline not visible} {textfonts} { @@ -3189,7 +3218,7 @@ test textDisp-24.4 {TkTextCharLayoutProc, newline not visible} {textfonts} { .t delete 1.0 end .t insert 1.0 01234567890123456789\n012345678901234567890 wm geom . {} - update + updateText list [.t bbox 1.19] [.t bbox 1.20] [.t bbox 2.20] } [list [list 136 3 7 $fixedHeight] [list 143 3 0 $fixedHeight] [list 3 [expr {2*$fixedDiff + 29}] 7 $fixedHeight]] test textDisp-24.5 {TkTextCharLayoutProc, char doesn't fit, newline not visible} {unix textfonts} { @@ -3197,7 +3226,7 @@ test textDisp-24.5 {TkTextCharLayoutProc, char doesn't fit, newline not visible} .t delete 1.0 end .t insert 1.0 0\n1\n wm geom . 110x$height - update + updateText list [.t bbox 1.0] [.t bbox 1.1] [.t bbox 2.0] } [list [list 3 3 4 $fixedHeight] [list 7 3 0 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 4 $fixedHeight]] test textDisp-24.6 {TkTextCharLayoutProc, line ends with space} {textfonts} { @@ -3205,47 +3234,47 @@ test textDisp-24.6 {TkTextCharLayoutProc, line ends with space} {textfonts} { .t delete 1.0 end .t insert 1.0 "a b c d e f g h i j k l m n o p" wm geom . {} - update + updateText list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-24.7 {TkTextCharLayoutProc, line ends with space} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "a b c d e f g h i j k l m n o p" - wm geom . [expr $width+1]x$height - update + wm geom . [expr {$width+1}]x$height + updateText list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 12 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-24.8 {TkTextCharLayoutProc, line ends with space} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "a b c d e f g h i j k l m n o p" - wm geom . [expr $width-1]x$height - update + wm geom . [expr {$width-1}]x$height + updateText list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 10 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-24.9 {TkTextCharLayoutProc, line ends with space} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "a b c d e f g h i j k l m n o p" - wm geom . [expr $width-6]x$height - update + wm geom . [expr {$width-6}]x$height + updateText list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 5 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-24.10 {TkTextCharLayoutProc, line ends with space} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "a b c d e f g h i j k l m n o p" - wm geom . [expr $width-7]x$height - update + wm geom . [expr {$width-7}]x$height + updateText list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 4 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-24.11 {TkTextCharLayoutProc, line ends with space that doesn't quite fit} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "01234567890123456789 \nabcdefg" - wm geom . [expr $width-2]x$height - update + wm geom . [expr {$width-2}]x$height + updateText set result {} lappend result [.t bbox 1.21] [.t bbox 2.0] .t mark set insert 1.21 @@ -3264,23 +3293,23 @@ test textDisp-24.13 {TkTextCharLayoutProc, -wrap none} {textfonts} { .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" wm geom . {} - update + updateText list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 7 $fixedHeight] {}] test textDisp-24.14 {TkTextCharLayoutProc, -wrap none} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" - wm geom . [expr $width+1]x$height - update + wm geom . [expr {$width+1}]x$height + updateText list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 7 $fixedHeight] [list 143 3 5 $fixedHeight]] test textDisp-24.15 {TkTextCharLayoutProc, -wrap none} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" - wm geom . [expr $width-1]x$height - update + wm geom . [expr {$width-1}]x$height + updateText list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 7 $fixedHeight] [list 143 3 3 $fixedHeight]] test textDisp-24.16 {TkTextCharLayoutProc, no chars fit} {textfonts} { @@ -3291,7 +3320,7 @@ test textDisp-24.16 {TkTextCharLayoutProc, no chars fit} {textfonts} { .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" wm geom . 103x$height - update + updateText list [.t bbox 1.0] [.t bbox 1.1] [.t bbox 1.2] } [list [list 3 3 1 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 1 $fixedHeight] [list 3 [expr {2*$fixedDiff + 29}] 1 $fixedHeight]] if {$tcl_platform(platform) == "windows"} { @@ -3302,7 +3331,7 @@ test textDisp-24.17 {TkTextCharLayoutProc, -wrap word} {textfonts} { .t delete 1.0 end .t insert 1.0 "This is a line that wraps around" wm geom . {} - update + updateText list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-24.18 {TkTextCharLayoutProc, -wrap word} {textfonts} { @@ -3310,7 +3339,7 @@ test textDisp-24.18 {TkTextCharLayoutProc, -wrap word} {textfonts} { .t delete 1.0 end .t insert 1.0 "xxThis is a line that wraps around" wm geom . {} - update + updateText list [.t bbox 1.15] [.t bbox 1.16] [.t bbox 1.17] } [list [list 108 3 7 $fixedHeight] [list 115 3 28 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-24.19 {TkTextCharLayoutProc, -wrap word} {textfonts} { @@ -3318,7 +3347,7 @@ test textDisp-24.19 {TkTextCharLayoutProc, -wrap word} {textfonts} { .t delete 1.0 end .t insert 1.0 "xxThis is a line that wraps around" wm geom . {} - update + updateText list [.t bbox 1.14] [.t bbox 1.15] [.t bbox 1.16] } [list [list 101 3 7 $fixedHeight] [list 108 3 7 $fixedHeight] [list 115 3 28 $fixedHeight]] test textDisp-24.20 {TkTextCharLayoutProc, vertical offset} {textfonts} { @@ -3336,7 +3365,7 @@ test textDisp-24.20 {TkTextCharLayoutProc, vertical offset} {textfonts} { set result } [list [list 10 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 42 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 10 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 42 [expr {$fixedDiff + 19}] [expr {$fixedDiff + 16}]] [list 10 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 42 [expr {$fixedDiff + 15}] [expr {$fixedDiff + 10}]]] .t configure -width 30 -update +updateText test textDisp-24.21 {TkTextCharLayoutProc, word breaks} {textfonts} { .t configure -wrap word .t delete 1.0 end @@ -3366,7 +3395,7 @@ test textDisp-24.23 {TkTextCharLayoutProc, word breaks} {textfonts} { } [list 3 [expr {2*$fixedDiff + 29}] 30 20] catch {destroy .t.f} .t configure -width 20 -update +updateText test textDisp-24.24 {TkTextCharLayoutProc, justification and tabs} {textfonts} { .t delete 1.0 end .t tag configure x -justify center @@ -3379,7 +3408,7 @@ test textDisp-24.25 {TkTextCharLayoutProc, justification and tabs} -constraints pack .tt } -body { .tt insert end \t9\n\t99\n\t999 - update + updateText list [.tt bbox 1.1] [.tt bbox 2.2] [.tt bbox 3.3] } -cleanup { destroy .tt @@ -3387,7 +3416,7 @@ test textDisp-24.25 {TkTextCharLayoutProc, justification and tabs} -constraints .t configure -width 40 -bd 0 -relief flat -highlightthickness 0 -padx 0 \ -tabs 100 -update +updateText test textDisp-25.1 {CharBboxProc procedure, check tab width} {textfonts} { .t delete 1.0 end .t insert 1.0 abc\td\tfgh @@ -3396,7 +3425,7 @@ test textDisp-25.1 {CharBboxProc procedure, check tab width} {textfonts} { .t configure -width 40 -bd 0 -relief flat -highlightthickness 0 -padx 0 \ -tabs {} -update +updateText test textDisp-26.1 {AdjustForTab procedure, no tabs} {textfonts} { .t delete 1.0 end .t insert 1.0 a\tbcdefghij\tc\td @@ -3428,9 +3457,9 @@ test textDisp-26.3 {AdjustForTab procedure, not enough tabs specified} { .t tag configure x -tabs {40 70 right} .t tag add x 1.0 end list [lindex [.t bbox 1.2] 0] \ - [expr [lindex [.t bbox 1.4] 0] + [lindex [.t bbox 1.4] 2]] \ - [expr [lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]] \ - [expr [lindex [.t bbox 1.8] 0] + [lindex [.t bbox 1.8] 2]] + [expr {[lindex [.t bbox 1.4] 0] + [lindex [.t bbox 1.4] 2]}] \ + [expr {[lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]}] \ + [expr {[lindex [.t bbox 1.8] 0] + [lindex [.t bbox 1.8] 2]}] } [list 40 70 100 130] test textDisp-26.4 {AdjustForTab procedure, different alignments} { .t delete 1.0 end @@ -3519,7 +3548,7 @@ test textDisp-26.12 {AdjustForTab procedure, adjusting chunks} { .t tag add y 1.9 button .b -text "=" .t window create 1.3 -window .b - update + updateText lindex [.t bbox 1.5] 0 } {120} test textDisp-26.13 {AdjustForTab procedure, not enough space} {textfonts} { @@ -3566,7 +3595,7 @@ test textDisp-26.14.2 {AdjustForTab procedure, not enough space} {textfonts} { .t configure -width 20 -bd 2 -highlightthickness 2 -relief sunken -tabs {} \ -wrap char -update +updateText test textDisp-27.1 {SizeOfTab procedure, old-style tabs} {textfonts} { .t delete 1.0 end .t insert 1.0 a\tbcdefghij\tc\td @@ -3635,7 +3664,7 @@ test textDisp-27.7 {SizeOfTab procedure, center alignment, wrap -none (potential # Tk_GetPixelsFromObj uses the standard 'int(0.5 + float)' rounding, # so must we. set tab [expr {4 + int(0.5 + $tab + $cm)}] - update + updateText set res [.t bbox 2.23] lset res 0 [expr {[lindex $res 0] - $tab}] set res @@ -3656,7 +3685,7 @@ test textDisp-27.7.1 {SizeOfTab procedure, center alignment, wrap -none (potenti # Tk_GetPixelsFromObj uses the standard 'int(0.5 + float)' rounding, # so must we. set tab [expr {4 + int(0.5 + $tab + $cm)}] - update + updateText set res [.t bbox 2.23] .t configure -tabstyle tabular lset res 0 [expr {[lindex $res 0] - $tab}] @@ -3671,17 +3700,17 @@ test textDisp-27.7.2 {SizeOfTab procedure, fractional tab interpolation problem} } .t configure -tabs $interpolatetab -wrap none -width 150 .t insert 1.0 [string repeat "a\t" 20] - update + updateText set res [.t bbox 1.20] # Now, Tk's interpolated tabs should be the same as # non-interpolated. .t configure -tabs $precisetab - update + updateText expr {[lindex $res 0] - [lindex [.t bbox 1.20] 0]} } {0} .t configure -wrap char -tabs {} -width 20 -update +updateText test textDisp-27.8 {SizeOfTab procedure, right alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\t\txyzzyabc @@ -3725,11 +3754,11 @@ test textDisp-28.1 {"yview" option with bizarre scroll command} { .t2.t insert end "1\n2\n3\n4\n5\n6\n7\n8\n" pack .t2.t wm geometry .t2 +0+0 - update + updateText .t2.t configure -yscrollcommand bizarre_scroll .t2.t yview 100.0 set result [.t2.t index @0,0] - update + updateText lappend result [.t2.t index @0,0] } {6.0 1.0} @@ -3745,7 +3774,7 @@ test textDisp-29.1 {miscellaneous: lines wrap but are still too long} {textfonts .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f - update + updateText list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] } [list [list 0.0 [expr {20.0*$fixedWidth/300}]] 300x50+[expr {$twbw + $twht + 1}]+[expr {$twbw + $twht + $fixedHeight + 1}] [list [expr {$twbw + $twht + $fixedWidth + 1}] [expr {$twbw + $twht + $fixedHeight + 50 + 1}] $fixedWidth $fixedHeight]] test textDisp-29.2 {miscellaneous: lines wrap but are still too long} {textfonts} { @@ -3760,9 +3789,9 @@ test textDisp-29.2 {miscellaneous: lines wrap but are still too long} {textfonts .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f - update + updateText .t2.t xview scroll 1 unit - update + updateText list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] } [list [list [expr {1.0*$fixedWidth/300}] [expr {21.0*$fixedWidth/300}]] 300x50+[expr {$twbw + $twht + 1 - $fixedWidth}]+[expr {$twbw + $twht + $fixedHeight + 1}] [list [expr {$twbw + $twht + $fixedWidth + 1 - $fixedWidth}] [expr {$twbw + $twht + $fixedHeight + 50 + 1}] $fixedWidth $fixedHeight]] test textDisp-29.2.1 {miscellaneous: lines wrap but are still too long} {textfonts} { @@ -3776,9 +3805,9 @@ test textDisp-29.2.1 {miscellaneous: lines wrap but are still too long} {textfon pack .t2.s -side bottom -fill x .t2.t insert end 1\n .t2.t insert end [string repeat "abc" 30] - update + updateText .t2.t xview scroll 5 unit - update + updateText .t2.t xview } [list [expr {5.0/90}] [expr {25.0/90}]] test textDisp-29.2.2 {miscellaneous: lines wrap but are still too long} {textfonts} { @@ -3793,9 +3822,9 @@ test textDisp-29.2.2 {miscellaneous: lines wrap but are still too long} {textfon .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f - update + updateText .t2.t xview scroll 2 unit - update + updateText list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] } [list [list [expr {2.0*$fixedWidth/300}] [expr {22.0*$fixedWidth/300}]] 300x50+[expr {$twbw + $twht + 1 - 2*$fixedWidth}]+[expr {$twbw + $twht + $fixedHeight + 1}] {}] test textDisp-29.2.3 {miscellaneous: lines wrap but are still too long} {textfonts} { @@ -3810,9 +3839,9 @@ test textDisp-29.2.3 {miscellaneous: lines wrap but are still too long} {textfon .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f - update + updateText .t2.t xview scroll 7 pixels - update + updateText list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] } [list [list [expr {7.0/300}] [expr {(20.0*$fixedWidth + 7)/300}]] 300x50+[expr {$twbw + $twht + 1 - 7}]+[expr {$twbw + $twht + $fixedHeight + 1}] [list [expr {$twbw + $twht + $fixedWidth + 1 - 7}] [expr {$twbw + $twht + $fixedHeight + 50 + 1}] $fixedWidth $fixedHeight]] test textDisp-29.2.4 {miscellaneous: lines wrap but are still too long} {textfonts} { @@ -3827,9 +3856,9 @@ test textDisp-29.2.4 {miscellaneous: lines wrap but are still too long} {textfon .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f - update + updateText .t2.t xview scroll 17 pixels - update + updateText list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] } [list [list [expr {17.0/300}] [expr {(20.0*$fixedWidth + 17)/300}]] 300x50+[expr {$twbw + $twht + 1 - 17}]+[expr {$twbw + $twht + $fixedHeight + 1}] {}] test textDisp-29.2.5 {miscellaneous: can show last character} { @@ -3846,7 +3875,7 @@ test textDisp-29.2.5 {miscellaneous: can show last character} { grid columnconfigure .t2 0 -weight 1 grid rowconfigure .t2 0 -weight 1 grid rowconfigure .t2 1 -weight 0 - update ; update + updateText set xv [.t2.t xview] set xd [expr {[lindex $xv 1] - [lindex $xv 0]}] .t2.t xview moveto [expr {1.0-$xd}] @@ -3872,9 +3901,9 @@ test textDisp-29.3 {miscellaneous: lines wrap but are still too long} {textfonts .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f - update + updateText .t2.t xview scroll 200 units - update + updateText list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] } [list [list [expr {16.0/30}] 1.0] 300x50+-155+[expr {$fixedDiff + 18}] {}] test textDisp-30.1 {elidden text joining multiple logical lines} { @@ -3894,7 +3923,7 @@ test textDisp-30.2 {elidden text joining multiple logical lines} { catch {destroy .t2} .t configure -height 1 -update +updateText test textDisp-31.1 {line embedded window height update} { set res {} @@ -3912,7 +3941,7 @@ test textDisp-31.1 {line embedded window height update} { test textDisp-31.2 {line update index shifting} { set res {} .t.f configure -height 100 - update + updateText lappend res [.t count -update -ypixels 1.0 end] .t.f configure -height 10 .t insert 1.0 "abc\n" @@ -3934,7 +3963,7 @@ test textDisp-31.3 {line update index shifting} { # have been performed. set res {} .t.f configure -height 100 - update + updateText lappend res [.t count -update -ypixels 1.0 end] .t.f configure -height 10 .t insert 1.0 "abc\n" @@ -3955,7 +3984,7 @@ test textDisp-31.4 {line embedded image height update} { image create photo textest -height 100 -width 10 .t delete 3.0 .t image create 3.0 -image textest - update + updateText lappend res [.t count -update -ypixels 1.0 end] textest configure -height 10 lappend res [.t count -ypixels 1.0 end] @@ -3966,7 +3995,7 @@ test textDisp-31.4 {line embedded image height update} { test textDisp-31.5 {line update index shifting} { set res {} textest configure -height 100 - update ; after 1000 ; update + updateText lappend res [.t count -update -ypixels 1.0 end] textest configure -height 10 .t insert 1.0 "abc\n" @@ -3988,7 +4017,6 @@ test textDisp-31.6 {line update index shifting} { # have been performed. set res {} textest configure -height 100 - update ; after 1000 ; update lappend res [.t count -update -ypixels 1.0 end] textest configure -height 10 .t insert 1.0 "abc\n" @@ -4031,19 +4059,19 @@ test textDisp-32.0 {everything elided} { .tt insert 0.0 HELLO .tt tag configure HIDE -elide 1 .tt tag add HIDE 0.0 end - update ; update ; update ; update + updateText destroy .tt } {} test textDisp-32.1 {everything elided} { # Must not crash pack [text .tt] - update + updateText .tt insert 0.0 HELLO - update + updateText .tt tag configure HIDE -elide 1 - update + updateText .tt tag add HIDE 0.0 end - update ; update ; update ; update + updateText destroy .tt } {} test textDisp-32.2 {elide and tags} { @@ -4054,10 +4082,11 @@ test textDisp-32.2 {elide and tags} { {testtag1 testtag3} \ {[this bit here uses tags 2 and 3]} \ {testtag2 testtag3} - update + updateText # indent left margin of tag 1 by 20 pixels # text should be indented - .tt tag configure testtag1 -lmargin1 20 ; update + .tt tag configure testtag1 -lmargin1 20 + updateText #1 set res {} lappend res [list [.tt index "1.0 + 0 displaychars"] \ @@ -4065,7 +4094,8 @@ test textDisp-32.2 {elide and tags} { [lindex [.tt bbox "1.0 + 0 displaychars"] 0]] # hide tag 1, remaining text should not be indented, since # the indented tag and character is hidden. - .tt tag configure testtag1 -elide 1 ; update + .tt tag configure testtag1 -elide 1 + updateText #2 lappend res [list [.tt index "1.0 + 0 displaychars"] \ [lindex [.tt bbox 1.0] 0] \ @@ -4075,7 +4105,8 @@ test textDisp-32.2 {elide and tags} { .tt tag configure testtag1 -elide 0 # indent left margin of tag 2 by 20 pixels # text should not be indented, since tag1 has lmargin1 of 0. - .tt tag configure testtag2 -lmargin1 20 ; update + .tt tag configure testtag2 -lmargin1 20 + updateText #3 lappend res [list [.tt index "1.0 + 0 displaychars"] \ [lindex [.tt bbox 1.0] 0] \ @@ -4083,7 +4114,8 @@ test textDisp-32.2 {elide and tags} { # hide tag 1, remaining text should now be indented, but # the bbox of 1.0 should have zero width and zero indent, # since it is elided at that position. - .tt tag configure testtag1 -elide 1 ; update + .tt tag configure testtag1 -elide 1 + updateText #4 lappend res [list [.tt index "1.0 + 0 displaychars"] \ [lindex [.tt bbox 1.0] 0] \ @@ -4095,7 +4127,8 @@ test textDisp-32.2 {elide and tags} { # text should be indented, since this tag takes # precedence over testtag1, and is applied to the # start of the text. - .tt tag configure testtag3 -lmargin1 20 ; update + .tt tag configure testtag3 -lmargin1 20 + updateText #5 lappend res [list [.tt index "1.0 + 0 displaychars"] \ [lindex [.tt bbox 1.0] 0] \ @@ -4103,7 +4136,8 @@ test textDisp-32.2 {elide and tags} { # hide tag 1, remaining text should still be indented, # since it still has testtag3 on it. Again the # bbox of 1.0 should have 0. - .tt tag configure testtag1 -elide 1 ; update + .tt tag configure testtag1 -elide 1 + updateText #6 lappend res [list [.tt index "1.0 + 0 displaychars"] \ [lindex [.tt bbox 1.0] 0] \ @@ -4141,7 +4175,7 @@ test textDisp-32.3 "NULL undisplayProc problems: #1791052" -setup { .tt insert end ":)" emoticon .tt image create end -image $img pack .tt - update; update; update + updateText } -cleanup { image delete $img destroy .tt @@ -4150,7 +4184,7 @@ test textDisp-32.3 "NULL undisplayProc problems: #1791052" -setup { test textDisp-33.0 {one line longer than fits in the widget} { pack [text .tt -wrap char] .tt insert 1.0 [string repeat "more wrap + " 300] - update ; update ; update + updateText .tt see 1.0 lindex [.tt yview] 0 } {0.0} @@ -4158,7 +4192,7 @@ test textDisp-33.1 {one line longer than fits in the widget} { destroy .tt pack [text .tt -wrap char] .tt insert 1.0 [string repeat "more wrap + " 300] - update ; update ; update + updateText .tt yview "1.0 +1 displaylines" if {[lindex [.tt yview] 0] > 0.1} { set result "window should be scrolled to the top" @@ -4182,7 +4216,9 @@ test textDisp-33.3 {one line longer than fits in the widget} { .tt debug 1 set tk_textHeightCalc "" .tt insert 1.0 [string repeat "more wrap + " 300] - update ; .tt count -update -ypixels 1.0 end ; update + updateText + .tt count -update -ypixels 1.0 end + updateText # Each line should have been recalculated just once .tt debug 0 expr {[llength $tk_textHeightCalc] == [.tt count -displaylines 1.0 end]} @@ -4193,7 +4229,7 @@ test textDisp-33.4 {one line longer than fits in the widget} { .tt debug 1 set tk_textHeightCalc "" .tt insert 1.0 [string repeat "more wrap + " 300] - update ; update ; update + updateText set idx [.tt index "1.0 + 1 displaylines"] .tt yview $idx if {[lindex [.tt yview] 0] > 0.1} { @@ -4215,7 +4251,7 @@ test textDisp-33.5 {bold or italic fonts} win { .tt tag configure bi -font bi .tt tag configure no -font no .tt insert end abcd no efgh bi ijkl\n no - update + updateText set bb {} for {set i 0} {$i < 12} {incr i 4} { lappend bb [lindex [.tt bbox 1.$i] 0] @@ -4242,7 +4278,7 @@ test textDisp-34.1 {Line heights recalculation problem: bug 2677890} -setup { .t1 debug 1 set ge [winfo geometry .] scan $ge "%dx%d+%d+%d" width height left top - update + updateText .t1 sync set negative 0 bind .t1 <<WidgetViewSync>> { if {%d < 0} {set negative 1} } @@ -4252,7 +4288,7 @@ test textDisp-34.1 {Line heights recalculation problem: bug 2677890} -setup { # Thus we use this way to check for regression regarding bug 2677890, # i.e. to check that the fix for this bug really is still in. wm geometry . "[expr {$width * 2}]x$height+$left+$top" - update + updateText .t1 sync set negative } -cleanup { diff --git a/tests/textIndex.test b/tests/textIndex.test index 3f26af5..310db6a 100644 --- a/tests/textIndex.test +++ b/tests/textIndex.test @@ -803,6 +803,14 @@ test textIndex-19.12 {Display lines} { .t index "2.40 -1displaylines" } {2.20} +test textIndex-19.12.1 {Display lines} { + .t index "2.50 - 100 displaylines" +} {1.0} + +test textIndex-19.12.2 {Display lines} { + .t compare [.t index "2.50 + 100 displaylines"] == "end - 1 c" +} {1} + test textIndex-19.13 {Display lines} { destroy {*}[pack slaves .] text .txt -height 1 -wrap word -yscroll ".sbar set" -width 400 diff --git a/tests/textTag.test b/tests/textTag.test index 8b247b9..04a4b30 100644 --- a/tests/textTag.test +++ b/tests/textTag.test @@ -1213,14 +1213,14 @@ test textTag-14.4 {SortTags} -setup { 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] +set x1 [expr {[lindex $c 0] + [lindex $c 2]/2}] +set y1 [expr {[lindex $c 1] + [lindex $c 3]/2}] set c [.t bbox 3.2] -set x2 [expr [lindex $c 0] + [lindex $c 2]/2] -set y2 [expr [lindex $c 1] + [lindex $c 3]/2] +set x2 [expr {[lindex $c 0] + [lindex $c 2]/2}] +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] +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] @@ -1233,7 +1233,8 @@ set y5 [expr [lindex $c 1] + [lindex $c 3]/2] test textTag-15.1 {TkTextBindProc} -setup { .t tag delete x y - event generate {} <Motion> -warp 1 -x -1 -y -1; update + wm geometry . +200+200 ; update + event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 } -body { bind .t <ButtonRelease> {lappend x up} .t tag bind x <ButtonRelease> {lappend x x-up} @@ -1258,14 +1259,15 @@ test textTag-15.1 {TkTextBindProc} -setup { test textTag-15.2 {TkTextBindProc} -setup { .t tag delete x y - event generate {} <Motion> -warp 1 -x -1 -y -1; update + 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 @@ -1286,15 +1288,16 @@ test textTag-15.2 {TkTextBindProc} -setup { test textTag-15.3 {TkTextBindProc} -setup { .t tag delete x y - event generate {} <Motion> -warp 1 -x -1 -y -1; update + 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 {} @@ -1319,7 +1322,8 @@ test textTag-15.3 {TkTextBindProc} -setup { test textTag-16.1 {TkTextPickCurrent procedure} -setup { .t tag delete {*}[.t tag names] - event generate {} <Motion> -warp 1 -x -1 -y -1; update + wm geometry . +200+200 ; update + event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 } -body { event gen .t <ButtonRelease-1> -state 0x100 -x $x1 -y $y1 set x [.t index current] @@ -1341,7 +1345,8 @@ test textTag-16.2 {TkTextPickCurrent procedure} -constraints { haveFontSizes } -setup { .t tag delete {*}[.t tag names] - event generate {} <Motion> -warp 1 -x -1 -y -1; update + 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 @@ -1360,7 +1365,8 @@ test textTag-16.3 {TkTextPickCurrent procedure} -setup { foreach i {a b c d} { .t tag remove $i 1.0 end } - event generate {} <Motion> -warp 1 -x -1 -y -1; update + wm geometry . +200+200 ; update + event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 } -body { foreach i {a b c d} { .t tag bind $i <Enter> "lappend x enter-$i" @@ -1387,7 +1393,8 @@ test textTag-16.4 {TkTextPickCurrent procedure} -setup { foreach i {a b c d} { .t tag remove $i 1.0 end } - event generate {} <Motion> -warp 1 -x -1 -y -1; update + wm geometry . +200+200 ; update + event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 } -body { foreach i {a b c d} { .t tag bind $i <Enter> "lappend x enter-$i" @@ -1415,7 +1422,8 @@ test textTag-16.5 {TkTextPickCurrent procedure} -constraints { foreach i {big a b c d} { .t tag remove $i 1.0 end } - event generate {} <Motion> -warp 1 -x -1 -y -1; update + 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 @@ -1435,7 +1443,8 @@ test textTag-16.6 {TkTextPickCurrent procedure} -constraints { foreach i {big a b c d} { .t tag remove $i 1.0 end } - event generate {} <Motion> -warp 1 -x -1 -y -1; update + 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 @@ -1456,7 +1465,8 @@ test textTag-16.7 {TkTextPickCurrent procedure} -constraints { foreach i {big a b c d} { .t tag remove $i 1.0 end } - event generate {} <Motion> -warp 1 -x -1 -y -1; update + 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 @@ -1488,7 +1498,8 @@ test textTag-17.1 {insert procedure inserts tags} -setup { test textTag-18.1 {TkTextPickCurrent tag bindings} -setup { destroy .t - event generate {} <Motion> -warp 1 -x -1 -y -1; update + wm geometry . +200+200 ; update + event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 } -body { text .t -width 30 -height 4 -relief sunken -borderwidth 10 \ -highlightthickness 10 -pady 2 diff --git a/tests/textWind.test b/tests/textWind.test index e189663..7e2d315 100644 --- a/tests/textWind.test +++ b/tests/textWind.test @@ -39,6 +39,11 @@ wm minsize . 1 1 wm positionfrom . user wm deiconify . +# This update is needed on MacOS to make sure that the window is mapped +# when the tests begin. + +update + set bw [.t cget -borderwidth] set px [.t cget -padx] set py [.t cget -pady] @@ -955,7 +960,7 @@ test textWind-11.1 {EmbWinDisplayProc procedure, geometry transforms} -setup { place .t -x 30 -y 50 frame .f -width 30 -height 20 -bg $color .t window create 1.12 -window .f - update + update ; after 100 ; update winfo geom .f } -cleanup { destroy .f @@ -975,7 +980,7 @@ test textWind-11.2 {EmbWinDisplayProc procedure, geometry transforms} -setup { place .t -x 30 -y 50 frame .t.f -width 30 -height 20 -bg $color .t window create 1.12 -window .t.f - update + update ; after 100 ; update winfo geom .t.f } -cleanup { destroy .t.f 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 3868953..c14db9b 100644 --- a/tests/ttk/combobox.test +++ b/tests/ttk/combobox.test @@ -43,6 +43,17 @@ test combobox-2.4 "current -- value not in list" -body { .cb current } -result -1 +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 { + .cb configure -values [list a b c d e] + .cb current notanindex +} -returnCodes error -result {Incorrect index notanindex} + test combobox-2.end "Cleanup" -body { destroy .cb } test combobox-3 "Read postoffset value dynamically from current style" -body { diff --git a/tests/ttk/entry.test b/tests/ttk/entry.test index d303446..26edca9 100644 --- a/tests/ttk/entry.test +++ b/tests/ttk/entry.test @@ -74,12 +74,29 @@ test entry-2.1 "Create entry before scrollbar" -body { -expand false -fill x } -cleanup {destroy .te .tsb} +test entry-2.1.1 "Create entry before scrollbar - scrollbar catches up" -body { + pack [ttk::entry .te -xscrollcommand [list .tsb set]] \ + -expand true -fill both + .te insert end [string repeat "abc" 50] + catch {update} ; # error triggers because the -xscrollcommand callback + # errors out: invalid command name ".tsb" + pack [ttk::scrollbar .tsb -orient horizontal -command [list .te xview]] \ + -expand false -fill x + update ; # no error + lappend res [expr [lindex [.tsb get] 1] < 1] ; # scrollbar did update +} -result {1} -cleanup {destroy .te .tsb} + test entry-2.2 "Initial scroll position" -body { ttk::entry .e -font fixed -width 5 -xscrollcommand scroll .e insert end "0123456789" - pack .e; update + pack .e; + set timeout [after 500 {set $scrollInfo "timeout"}] + vwait scrollInfo set scrollInfo -} -result {0.0 0.5} -cleanup { destroy .e } +} -cleanup { + destroy .e + after cancel $timeout +} -result {0.0 0.5} # NOTE: result can vary depending on font. # Bounding box / scrolling tests. @@ -103,10 +120,37 @@ test entry-3.1 "bbox widget command" -body { test entry-3.2 "xview" -body { .e delete 0 end; .e insert end [string repeat "0" 40] - update idletasks set result [.e xview] } -result {0.0 0.5} +test entry-3.3 "xview" -body { + .e delete 0 end; + .e insert end abcdefghijklmnopqrstuvwxyz + .e xview end + set result [.e index @0] +} -result {7} + +test entry-3.4 "xview" -body { + .e delete 0 end; + .e insert end abcdefghijklmnopqrstuvwxyz + .e xview moveto 1.0 + set result [.e index @0] +} -result {7} + +test entry-3.5 "xview" -body { + .e delete 0 end; + .e insert end abcdefghijklmnopqrstuvwxyz + .e xview scroll 5 units + set result [.e index @0] +} -result {5} + +test entry-3.6 "xview" -body { + .e delete 0 end; + .e insert end [string repeat abcdefghijklmnopqrstuvwxyz 5] + .e xview scroll 2 pages + set result [.e index @0] +} -result {40} + test entry-3.last "Series 3 cleanup" -body { destroy .e } @@ -298,4 +342,16 @@ test entry-10.2 {configuration option: "-placeholderforeground"} -setup { destroy .e } -result {red} +test entry-11.1 {Bug [2830360fff] - Don't loose invalid at focus events} -setup { + pack [ttk::entry .e] + update +} -body { + .e state invalid + set res [.e state] + event generate .e <FocusOut> + lappend res [.e state] +} -result {invalid invalid} -cleanup { + destroy .e +} + tcltest::cleanupTests diff --git a/tests/ttk/notebook.test b/tests/ttk/notebook.test index 3a2a6ff..ac63088 100644 --- a/tests/ttk/notebook.test +++ b/tests/ttk/notebook.test @@ -69,7 +69,7 @@ test notebook-2.5 "tab - get all options" -body { .nb tab .nb.foo } -result [list \ -padding 0 -sticky nsew \ - -state normal -text "Changed Foo" -image "" -compound none -underline -1] + -state normal -text "Changed Foo" -image "" -compound {} -underline -1] test notebook-4.1 "Test .nb index end" -body { .nb index end diff --git a/tests/ttk/scrollbar.test b/tests/ttk/scrollbar.test index c7cab13..443687a 100644 --- a/tests/ttk/scrollbar.test +++ b/tests/ttk/scrollbar.test @@ -4,16 +4,26 @@ loadTestedCommands testConstraint coreScrollbar [expr {[tk windowingsystem] eq "aqua"}] -test scrollbar-swapout-1 "Use core scrollbars on OSX..." -constraints { - coreScrollbar +# Before 2019 the code in library/ttk/scrollbar.tcl would replace the +# constructor of ttk::scrollbar with the constructor of tk::scrollbar +# unless the -class or -style options were specified.. +# Now there is an implementation of ttk::scrollbar for macOS. The +# tests are left in place, though, except that scrollbar-swapout-1 +# test was changed to expect the class to be TScrollbar instead of +# Scrollbar. + +test scrollbar-swapout-1 "Don't use core scrollbars on OSX..." \ + -constraints { + coreScrollbar } -body { ttk::scrollbar .sb -command "yadda" list [winfo class .sb] [.sb cget -command] -} -result [list Scrollbar yadda] -cleanup { +} -result [list TScrollbar yadda] -cleanup { destroy .sb } -test scrollbar-swapout-2 "... unless -style is specified ..." -constraints { +test scrollbar-swapout-2 "... regardless of whether -style ..." \ +-constraints { coreScrollbar } -body { ttk::style layout Vertical.Custom.TScrollbar \ @@ -24,7 +34,7 @@ test scrollbar-swapout-2 "... unless -style is specified ..." -constraints { destroy .sb } -test scrollbar-swapout-3 "... or -class." -constraints { +test scrollbar-swapout-3 "... or -class is specified." -constraints { coreScrollbar } -body { ttk::scrollbar .sb -command "yadda" -class Custom.TScrollbar @@ -44,16 +54,108 @@ test scrollbar-1.1 "Set method" -body { test scrollbar-1.2 "Set orientation" -body { .tsb configure -orient vertical - set w [winfo reqwidth .tsb] ; set h [winfo reqheight .tsb] + pack .tsb -side right -anchor e -expand 1 -fill y + wm geometry . 200x200 + update + set w [winfo width .tsb] ; set h [winfo height .tsb] expr {$h > $w} } -result 1 test scrollbar-1.3 "Change orientation" -body { .tsb configure -orient horizontal - set w [winfo reqwidth .tsb] ; set h [winfo reqheight .tsb] + pack .tsb -side bottom -anchor s -expand 1 -fill x + wm geometry . 200x200 + update + set w [winfo width .tsb] ; set h [winfo height .tsb] 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/treetags.test b/tests/ttk/treetags.test index f91673f..fd3a0c5 100644 --- a/tests/ttk/treetags.test +++ b/tests/ttk/treetags.test @@ -11,12 +11,11 @@ proc assert {expr {message ""}} { error "PANIC: $message ($expr failed)" } } -proc in {e l} { expr {[lsearch -exact $l $e] >= 0} } proc itemConstraints {tv item} { # $tag in [$tv item $item -tags] <==> [$tv tag has $tag $item] foreach tag [$tv item $item -tags] { - assert {[in $item [$tv tag has $tag]]} + assert {$item in [$tv tag has $tag]} } foreach child [$tv children $item] { itemConstraints $tv $child @@ -28,7 +27,7 @@ proc treeConstraints {tv} { # foreach tag [$tv tag names] { foreach item [$tv tag has $tag] { - assert {[in $tag [$tv item $item -tags]]} + assert {$tag in [$tv item $item -tags]} } } @@ -114,6 +113,12 @@ test treetags-1.10 "tag names - tag configured" -body { lsort [$tv tag names] } -result [list tag1 tag2 tag3 tag4 tag5] +test treetags-1.11 "tag delete" -body { + $tv tag delete tag5 + $tv tag delete tag4 + lsort [$tv tag names] +} -result [list tag1 tag2 tag3] + test treetags-1.end "cleanup" -body { $tv item item1 -tags tag1 $tv item item2 -tags tag2 @@ -123,28 +128,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 { diff --git a/tests/ttk/treeview.test b/tests/ttk/treeview.test index aa7e64a..43dd249 100644 --- a/tests/ttk/treeview.test +++ b/tests/ttk/treeview.test @@ -459,6 +459,31 @@ test treeview-8.5 "Selection - bad operation" -body { .tv selection badop foo } -returnCodes 1 -match glob -result {bad selection operation "badop": must be *} +test treeview-8.6 "Selection - <<TreeviewSelect>> on selection add" -body { + .tv selection set {} + bind .tv <<TreeviewSelect>> {set res 1} + set res 0 + .tv selection add newnode.n1 + update + set res +} -result {1} + +test treeview-8.7 "<<TreeviewSelect>> on selected item deletion" -body { + .tv selection set {} + .tv insert "" end -id selectedDoomed -text DeadItem + .tv insert "" end -id doomed -text AlsoDead + .tv selection add selectedDoomed + update + bind .tv <<TreeviewSelect>> {lappend res 1} + set res 0 + .tv delete doomed + update + set res [expr {$res == 0}] + .tv delete selectedDoomed + update + set res +} -result {1 1} + ### NEED: more tests for see/yview/scrolling proc scrollcallback {args} { @@ -471,6 +496,72 @@ test treeview-9.0 "scroll callback - empty tree" -body { set ::scrolldata } -result [list 0.0 1.0] +test treeview-9.1 "scrolling" -setup { + pack [ttk::treeview .tree -show tree] -fill y + for {set i 1} {$i < 100} {incr i} { + .tree insert {} end -text $i + } +} -body { + .tree yview scroll 5 units + .tree identify item 2 2 +} -cleanup { + destroy .tree +} -result {I006} + +test treeview-9.2 {scrolling on see command - bug [14188104c3]} -setup { + toplevel .top + ttk::treeview .top.tree -show {} -height 10 -columns {label} \ + -yscrollcommand [list .top.vs set] + ttk::scrollbar .top.vs -command {.top.tree yview} + grid .top.tree -row 0 -column 0 -sticky ns + grid .top.vs -row 0 -column 1 -sticky ns + update + proc setrows {n} { + .top.tree delete [.top.tree children {}] + for {set i 1} {$i <= $n} {incr i} { + .top.tree insert {} end -id row$i \ + -values [list [format "Row %2.2d" $i]] + } + .top.tree see row1 + update idletasks + } +} -body { + setrows 10 + set res [.top.vs get] + setrows 20 + lappend res [expr [lindex [.top.vs get] 1] < 1] +} -cleanup { + destroy .top +} -result {0.0 1.0 1} + +test treeview-9.3 {scrolling on see command, requested item is closed} -setup { + toplevel .top + ttk::treeview .top.tree -show tree -height 10 -columns {label} \ + -yscrollcommand [list .top.vs set] + ttk::scrollbar .top.vs -command {.top.tree yview} + grid .top.tree -row 0 -column 0 -sticky ns + grid .top.vs -row 0 -column 1 -sticky ns + + .top.tree insert {} end -id a -text a + .top.tree insert a end -id b -text b + .top.tree insert b end -id c -text c + .top.tree insert c end -id d -text d + .top.tree insert d end -id e -text e + for {set i 6} {$i <= 15} {incr i} { + .top.tree insert {} end -id row$i \ + -values [list [format "Row %2.2d" $i]] + } + update +} -body { + set before [lindex [.top.vs get] 1] + .top.tree see e + update idletasks + set after [lindex [.top.vs get] 1] + expr $after < $before +} -cleanup { + destroy .top +} -result {1} + ### identify tests: # proc identify* {tv comps args} { @@ -608,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 @@ -636,4 +727,111 @@ test treeview-3085489-2 "tag remove, no -tags" -setup { destroy .tv } -result [list] +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" + 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 <Button-1> \ + -x [expr {$x + $h / 2}] \ + -y [expr {$y + $h / 2}] + lappend res [.tv item foo -open] + .tv insert foo end -text "sub" + lappend res [.tv item foo -open] +} -cleanup { + destroy .tv +} -result {0 0 0} + +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 -->" + update +} -body { + set res [.tv column #0 -width] + .tv drag #0 400 + lappend res [expr {[.tv column #0 -width] > $res}] +} -cleanup { + destroy .tv +} -result {200 1} + +proc nostretch {tv} { + foreach col [$tv cget -columns] { + $tv column $col -stretch 0 + } + $tv column #0 -stretch 0 + update idletasks ; # redisplay $tv +} + +test treeview-ce470f20fd-2 "changing -stretch resizes columns" -setup { + pack [ttk::treeview .tv -columns {bar colA colB colC foo}] + foreach col [.tv cget -columns] { + .tv heading $col -text $col + } + nostretch .tv + .tv column colA -width 50 ; .tv column colB -width 50 ; # slack created + update idletasks ; # redisplay treeview +} -body { + # when no column is stretchable and one of them becomes stretchable + # the stretchable column takes the slack and the widget is redisplayed + # automatically at idle time + set res [.tv column colA -width] + .tv column colA -stretch 1 + update idletasks ; # no slack anymore, widget redisplayed + lappend res [expr {[.tv column colA -width] > $res}] +} -cleanup { + destroy .tv +} -result {50 1} + +test treeview-ce470f20fd-3 "changing -stretch resizes columns" -setup { + pack [ttk::treeview .tv -columns {bar colA colB colC foo}] + foreach col [.tv cget -columns] { + .tv heading $col -text $col + } + .tv configure -displaycolumns {colB colA colC} + nostretch .tv + .tv column colA -width 50 ; .tv column colB -width 50 ; # slack created + update idletasks ; # redisplay treeview +} -body { + # only some columns are displayed (and in a different order than declared + # in -columns), a displayed column becomes stretchable --> the stretchable + # column expands + set res [.tv column colA -width] + .tv column colA -stretch 1 + update idletasks ; # no slack anymore, widget redisplayed + lappend res [expr {[.tv column colA -width] > $res}] +} -cleanup { + destroy .tv +} -result {50 1} + +test treeview-ce470f20fd-4 "changing -stretch resizes columns" -setup { + pack [ttk::treeview .tv -columns {bar colA colB colC foo}] + foreach col [.tv cget -columns] { + .tv heading $col -text $col + } + .tv configure -displaycolumns {colB colA colC} + nostretch .tv + .tv column colA -width 50 ; .tv column bar -width 60 ; # slack created + 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 + # happens + set origTreeWidth [winfo width .tv] + set res [list [.tv column bar -width] [.tv column colA -width]] + .tv column bar -stretch 1 + update idletasks ; # no change, widget redisplayed + lappend res [.tv column bar -width] [.tv column colA -width] + # this column becomes visible --> widget resizes + .tv configure -displaycolumns {bar colC colA colB} + update idletasks ; # no slack anymore because the widget resizes (shrinks) + lappend res [.tv column bar -width] [.tv column colA -width] \ + [expr {[winfo width .tv] < $origTreeWidth}] +} -cleanup { + destroy .tv +} -result {60 50 60 50 60 50 1} + tcltest::cleanupTests diff --git a/tests/ttk/ttk.test b/tests/ttk/ttk.test index 6760b80..53da18a 100644 --- a/tests/ttk/ttk.test +++ b/tests/ttk/ttk.test @@ -206,9 +206,10 @@ test ttk-2.8 "bug 3223850: button state disabled during click" -setup { destroy .b 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>} + 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 @@ -269,7 +270,7 @@ test ttk-3.4 "SF#2009213" -body { test ttk-4.0 "Setup" -body { catch { destroy .t } pack [ttk::label .t -text "Button 1"] - testConstraint fontOption [expr ![catch { set prevFont [.t cget -font] }]] + testConstraint fontOption [expr {![catch { set prevFont [.t cget -font] }]}] ok } @@ -506,6 +507,19 @@ test ttk-12.2 "-cursor option" -body { .b cget -cursor } -result arrow +test ttk-12.2.1 "-cursor option, widget doesn't overwrite it" -setup { + ttk::treeview .tr + pack .tr + update +} -body { + .tr configure -cursor X_cursor + event generate .tr <Motion> + update + .tr cget -cursor +} -cleanup { + destroy .tr +} -result {X_cursor} + test ttk-12.3 "-borderwidth frame option" -body { destroy .t toplevel .t diff --git a/tests/unixButton.test b/tests/unixButton.test index 9d54707..f0dcde5 100644 --- a/tests/unixButton.test +++ b/tests/unixButton.test @@ -200,7 +200,7 @@ 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 } -setup { diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test index 99f7265..c0a5bac 100644 --- a/tests/unixEmbed.test +++ b/tests/unixEmbed.test @@ -85,6 +85,8 @@ proc colorsFree {w {red 31} {green 245} {blue 192}} { && ([lindex $vals 2]/256 == $blue) } +testConstraint pressbutton [llength [info commands pressbutton]] + test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} -constraints { unix } -setup { @@ -341,7 +343,7 @@ test unixEmbed-2.4 {EmbeddedEventProc procedure} -constraints { test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} -constraints { - unix testembed notPortable + unix testembed nonPortable } -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 @@ -968,23 +970,25 @@ 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. test unixEmbed-7.1a {TkpRedirectKeyEvent procedure, forward keystroke} -constraints { - unix + unix notAqua } -setup { deleteWindows catch {interp delete slave} @@ -1000,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 @@ -1014,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 @@ -1031,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 @@ -1064,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 @@ -1078,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 { @@ -1234,6 +1238,7 @@ test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} -con deleteWindows } -body { frame .f1 -container 1 -width 200 -height 50 + update pack .f1 update toplevel .t1 -use [winfo id .f1] -width 150 -height 80 @@ -1260,6 +1265,56 @@ test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} -con deleteWindows } -result {70x300+0+0} +test unixEmbed-11.1 {focus -force works for embedded toplevels} -constraints { + unix +} -setup { + deleteWindows +} -body { + toplevel .t + pack [frame .t.f -container 1 -width 200 -height 200] -fill both + update idletasks + toplevel .embed -use [winfo id .t.f] -bg green + update idletasks + focus -force .t + focus -force .embed + focus +} -cleanup { + deleteWindows +} -result .embed +test unixEmbed-11.2 {mouse coordinates in embedded toplevels} -constraints { + unix pressbutton +} -setup { + deleteWindows +} -body { + toplevel .main + set result {} + pack [button .main.b -text "Main Button" \ + -command {lappend result ".main.b"}] -padx 30 -pady 30 + pack [frame .main.f -container 1 -width 200 -height 200] -fill both + update idletasks + toplevel .embed -use [winfo id .main.f] -bg green + pack [button .embed.b -text "Emb Button" \ + -command {lappend result ".embed.b"}] -padx 30 -pady 30 + wm geometry .main 200x400+100+100 + update idletasks + focus -force .main + set x [expr {[winfo x .main ] + [winfo x .main.b] + 40}] + set y [expr {[winfo y .main ] + [winfo y .main.b] + 38}] + lappend result [winfo containing $x $y] + after 200 + pressbutton $x $y + update + set y [expr {$y + 80}] + lappend result [winfo containing $x $y] + after 200 + pressbutton $x $y + update + set result +} -cleanup { + deleteWindows +} -result {.main.b .main.b .embed.b .embed.b} + + # cleanup deleteWindows cleanupbg 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.test b/tests/visual.test index 2f5c34a..13d6fd2 100644 --- a/tests/visual.test +++ b/tests/visual.test @@ -29,9 +29,9 @@ 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 {} \ + 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 } } @@ -50,8 +50,8 @@ proc eatColors {w} { 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) + expr {([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) + && ([lindex $vals 2]/256 == $blue)} } # If more than one visual type is available for the screen, pick one diff --git a/tests/visual_bb.test b/tests/visual_bb.test index 030a369..eda67e4 100644 --- a/tests/visual_bb.test +++ b/tests/visual_bb.test @@ -94,7 +94,7 @@ test 1.1 {running visual tests} -constraints userInteraction -body { # 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 c53b6d7..e70ae3f 100755 --- a/tests/winDialog.test +++ b/tests/winDialog.test @@ -256,7 +256,7 @@ test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} -constraints { Click cancel }] # Note this also tests fix for - # http://core.tcl.tk/tk/tktview/4a0451f5291b3c9168cc560747dae9264e1d2ef6 + # https://core.tcl-lang.org/tk/tktview/4a0451f5291b3c9168cc560747dae9264e1d2ef6 # $x is expected to be empty append x $y } -result {0} @@ -376,8 +376,8 @@ test winDialog-5.7.5 {GetFileName: extension {} } -constraints { test winDialog-5.7.6 {GetFileName: All/extension } -constraints { nt testwinevent } -body { - # In 8.6.4 this combination resulted in bar.ext.ext which is bad - start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {ext} -title Save]} + # In 8.6.4 this combination resulted in bar.aaa.aaa which is bad + start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {aaa} -title Save]} set msg {} then { if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { @@ -389,37 +389,37 @@ test winDialog-5.7.6 {GetFileName: All/extension } -constraints { set x "[file tail $x]$msg" } -cleanup { unset msg -} -result bar.ext +} -result bar.aaa test winDialog-5.7.7 {tk_getOpenFile: -defaultextension} -constraints { nt testwinevent } -body { unset -nocomplain x - tcltest::makeFile "" "5 7 7.ext" [initialdir] + tcltest::makeFile "" "5 7 7.aaa" [initialdir] start {set x [tk_getOpenFile \ - -defaultextension ext \ + -defaultextension aaa \ -initialdir [file nativename [initialdir]] \ -initialfile "5 7 7" -title Foo]} then { Click ok } return $x -} -result [file join [initialdir] "5 7 7.ext"] +} -result [file join [initialdir] "5 7 7.aaa"] test winDialog-5.7.8 {tk_getOpenFile: -defaultextension} -constraints { nt testwinevent } -body { unset -nocomplain x - tcltest::makeFile "" "5 7 8.ext" [initialdir] + tcltest::makeFile "" "5 7 8.aaa" [initialdir] start {set x [tk_getOpenFile \ - -defaultextension ext \ + -defaultextension aaa \ -initialdir [file nativename [initialdir]] \ - -initialfile "5 7 8.ext" -title Foo]} + -initialfile "5 7 8.aaa" -title Foo]} then { Click ok } return $x -} -result [file join [initialdir] "5 7 8.ext"] +} -result [file join [initialdir] "5 7 8.aaa"] test winDialog-5.8 {GetFileName: extension doesn't begin with .} -constraints { nt testwinevent diff --git a/tests/winFont.test b/tests/winFont.test index 662eb10..23c09c9 100644 --- a/tests/winFont.test +++ b/tests/winFont.test @@ -180,7 +180,7 @@ test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} -constraints { set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - .t.l config -wrap [expr $ax*10] -text "00000000" + .t.l config -wrap [expr {$ax*10}] -text "00000000" list [expr {[winfo reqwidth .t.l] eq 8*$ax}] \ [expr {[winfo reqheight .t.l] eq $ay}] } -cleanup { @@ -199,7 +199,7 @@ test winfont-5.4 {Tk_MeasureChars procedure: not all chars fit} -constraints { set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - .t.l config -wrap [expr $ax*6] -text "00000000" + .t.l config -wrap [expr {$ax*6}] -text "00000000" list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \ [expr {[winfo reqheight .t.l] eq 2*$ay}] } -cleanup { @@ -218,7 +218,7 @@ test winfont-5.5 {Tk_MeasureChars procedure: include last partial char} -constra .t.c dchars $t 0 end .t.c insert $t 0 "0000" - .t.c index $t @[expr int($cx*2.5)],1 + .t.c index $t @[expr {int($cx*2.5)}],1 } -cleanup { destroy .t.c } -result {2} @@ -254,7 +254,7 @@ test winfont-5.7 {Tk_MeasureChars procedure: whole words} -constraints { set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - .t.l config -wrap [expr $ax*8] -text "000000 0000" + .t.l config -wrap [expr {$ax*8}] -text "000000 0000" list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \ [expr {[winfo reqheight .t.l] eq 2*$ay}] } -cleanup { @@ -273,7 +273,7 @@ test winfont-5.8 {Tk_MeasureChars procedure: already saw space in line} -constra set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - .t.l config -wrap [expr $ax*12] -text "000000 0000000" + .t.l config -wrap [expr {$ax*12}] -text "000000 0000000" list [expr {[winfo reqwidth .t.l] eq 7*$ax}] \ [expr {[winfo reqheight .t.l] eq 2*$ay}] } -cleanup { @@ -292,7 +292,7 @@ test winfont-5.9 {Tk_MeasureChars procedure: internal spaces significant} -const set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - .t.l config -wrap [expr $ax*12] -text "000 00 00000" + .t.l config -wrap [expr {$ax*12}] -text "000 00 00000" list [expr {[winfo reqwidth .t.l] eq 7*$ax}] \ [expr {[winfo reqheight .t.l] eq 2*$ay}] } -cleanup { @@ -311,7 +311,7 @@ test winfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} -cons set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - .t.l config -wrap [expr $ax*12] -text "0000000000000000" + .t.l config -wrap [expr {$ax*12}] -text "0000000000000000" list [expr {[winfo reqwidth .t.l] eq 12*$ax}] \ [expr {[winfo reqheight .t.l] eq 2*$ay}] } -cleanup { @@ -334,7 +334,7 @@ test winfont-5.11 {Tk_MeasureChars procedure: check for kerning} -constraints { .t.l config -text "XaYoYaKaWx" set x [lindex [getsize] 0] .t.l config -font $font - expr $x < ($width*10) + expr {$x < ($width*10)} } -cleanup { destroy .t.l } -result {1} diff --git a/tests/winSend.test b/tests/winSend.test index 0f3baf8..31c800e 100644 --- a/tests/winSend.test +++ b/tests/winSend.test @@ -118,8 +118,8 @@ test winSend-2.3 {Tk_SendObjCmd - sending to ourselves in a different interprete } {0 b {}} test winSend-2.4 {Tk_SendObjCmd - sending to ourselves in a different interp with errors} winSend { newApp testApp - list [catch {send testApp {expr 2 / 0}} msg] $msg $errorCode $errorInfo [interp delete testApp] -} "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr 2 / 0\"\n invoked from within\n\"send testApp {expr 2 / 0}\"} {}" + list [catch {send testApp {expr {2 / 0}}} msg] $msg $errorCode $errorInfo [interp delete testApp] +} "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr {2 / 0}\"\n invoked from within\n\"send testApp {expr {2 / 0}}\"} {}" test winSend-2.5 {Tk_SendObjCmd - sending to another app async} winSend { set newInterps [winfo interps] foreach interp $newInterps { @@ -145,8 +145,8 @@ test winSend-2.7 {Tk_SendObjCmd - sending to another app - error} winSend { break } } - list [catch {send $interp {expr 2 / 0}} msg] $msg $errorCode $errorInfo -} "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr 2 / 0\"\n invoked from within\n\"send \$interp {expr 2 / 0}\"}" + list [catch {send $interp {expr {2 / 0}}} msg] $msg $errorCode $errorInfo +} "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr {2 / 0}\"\n invoked from within\n\"send \$interp {expr {2 / 0}}\"}" test winSend-3.1 {TkGetInterpNames} winSend { set origLength [llength $currentInterps] @@ -170,7 +170,7 @@ test winSend-5.1 {ExecuteRemoteObject - no error} winSend { break } } - list [send $interp {send [tk appname] {expr 2 / 1}}] + list [send $interp {send [tk appname] {expr {2 / 1}}}] } {2} test winSend-5.2 {ExecuteRemoteObject - error} winSend { set newInterps [winfo interps] @@ -179,7 +179,7 @@ test winSend-5.2 {ExecuteRemoteObject - error} winSend { break } } - list [catch {send $interp {send [tk appname] {expr 2 / 0}}} msg] $msg + list [catch {send $interp {send [tk appname] {expr {2 / 0}}}} msg] $msg } {1 {divide by zero}} test winSend-6.1 {SendDDEServer - XTYP_CONNECT} winSend { @@ -246,7 +246,7 @@ test winSend-6.6 {SendDDEServer - XTYP_REQUEST return results} winSend { break } } - set command "send [tk appname] {expr $foo + 1}" + set command "send [tk appname] {expr {$foo + 1}}" list [catch "send \{$interp\} \{$command\}" msg] $msg } {0 4} test winSend-6.7 {SendDDEServer - XTYP_EXECUTE} winSend { @@ -256,7 +256,7 @@ test winSend-6.7 {SendDDEServer - XTYP_EXECUTE} winSend { break } } - set command "send [tk appname] {expr 4 / 2}" + set command "send [tk appname] {expr {4 / 2}}" list [catch "send \{$interp\} \{$command\}" msg] $msg } {0 2} test winSend-6.8 {SendDDEServer - XTYP_WILDCONNECT} winSend { @@ -386,7 +386,7 @@ test winSend-10.17 {Tk_DDEObjCmd - valid variable} winSend { } {0 winSend-10.17} test winSend-10.18 {Tk_DDEObjCmd - services} winSend { set currentService [list Tk [tk appname]] - list [catch {dde services Tk {}} msg] [expr [lsearch $msg $currentService] >= 0] + list [catch {dde services Tk {}} msg] [expr {[lsearch $msg $currentService] >= 0}] } {0 1} # Get rid of the other app and all of its interps diff --git a/tests/winWm.test b/tests/winWm.test index d251eb8..0064c5a 100644 --- a/tests/winWm.test +++ b/tests/winWm.test @@ -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 {} { @@ -492,7 +492,7 @@ test winWm-9.1 "delayed activation of grabbed destroyed window" -constraints win 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 {} { diff --git a/tests/winfo.test b/tests/winfo.test index 14c2838..49a92a6 100644 --- a/tests/winfo.test +++ b/tests/winfo.test @@ -27,9 +27,9 @@ proc eatColors {w {options ""}} { 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 {} \ + 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 } } @@ -156,7 +156,7 @@ test winfo-4.6 {"winfo containing" command} -constraints { wm geom .t +0+0 update - winfo containing [expr [winfo rootx .t.f]-1] [expr [winfo rooty .t.f]-1] + winfo containing [expr {[winfo rootx .t.f]-1}] [expr {[winfo rooty .t.f]-1}] } -cleanup { destroy .t } -result .t @@ -169,8 +169,8 @@ test winfo-4.7 {"winfo containing" command} -setup { wm geom .t +0+0 update - set x [winfo containing -display .t.f [expr [winfo rootx .t]+600] \ - [expr [winfo rooty .t.f]+450]] + set x [winfo containing -display .t.f [expr {[winfo rootx .t]+600}] \ + [expr {[winfo rooty .t.f]+450}]] expr {($x == ".") || ($x == "")} } -cleanup { destroy .t @@ -364,7 +364,7 @@ test winfo-11.5 {"winfo visualid" command} -body { } -result {3} test winfo-11.6 {"winfo visualid" command} -body { set x [lindex [lindex [winfo visualsa . includeids] 0] 2] - expr $x + 2 - $x + expr {$x + 2 - $x} } -result {2} @@ -394,6 +394,13 @@ test winfo-13.1 {root coordinates of embedded toplevel} -setup { deleteWindows } -result {rootx 1 rooty 1} +# Windows does not destroy the container when an embedded window is +# destroyed. Unix and macOS do destroy it. See ticket [67384bce7d]. +if {[tk windowingsystem] == "win32"} { + set result_13_2 {embedded 0 container 1} +} else { + set result_13_2 {embedded 0 container 0} +} test winfo-13.2 {destroying embedded toplevel} -setup { deleteWindows } -body { @@ -409,7 +416,7 @@ test winfo-13.2 {destroying embedded toplevel} -setup { list embedded [winfo exists .emb.b] container [winfo exists .con] } -cleanup { deleteWindows -} -result {embedded 0 container 1} +} -result $result_13_2 test winfo-13.3 {destroying container window} -setup { deleteWindows diff --git a/tests/wm.test b/tests/wm.test index df8d325..2978c1b 100644 --- a/tests/wm.test +++ b/tests/wm.test @@ -873,6 +873,12 @@ test wm-iconphoto-1.4 {usage} -returnCodes error -body { # we currently have no return info wm iconphoto . -default } -result {wrong # args: should be "wm iconphoto window ?-default? image1 ?image2 ...?"} +test wm-iconphoto-1.5.1 {usage} -constraints aquaOrWin32 -returnCodes error -body { + wm iconphoto . -default [image create photo -file {}] +} -match {glob} -result {failed to create an iconphoto with image *} +test wm-iconphoto-1.5.2 {usage} -constraints x11 -body { + wm iconphoto . -default [image create photo -file {}] +} -result {} # All other iconphoto tests are platform specific @@ -1553,8 +1559,8 @@ test wm-stackorder-5.3 {An overrideredirect window\ destroy .t } -result 1 -test wm-stackorder-6.1 {An embedded toplevel does not\ - appear in the stacking order on unix or win} -constraints notAqua -body { +test wm-stackorder-6.1 {An embedded toplevel does not appear in the \ + stacking order} -body { toplevel .real -container 1 toplevel .embd -bg blue -use [winfo id .real] update @@ -1562,16 +1568,6 @@ test wm-stackorder-6.1 {An embedded toplevel does not\ } -cleanup { deleteWindows } -result {. .real} -test wm-stackorder-6.1.1 {An embedded toplevel does\ - appear in the stacking order on macOS} -constraints aqua -body { - toplevel .real -container 1 - toplevel .embd -bg blue -use [winfo id .real] - update - wm stackorder . -} -cleanup { - deleteWindows -} -result {. .embd} - stdWindow |