diff options
Diffstat (limited to 'tests')
120 files changed, 6222 insertions, 2862 deletions
diff --git a/tests/all.tcl b/tests/all.tcl index 46721a2..99e6d0c 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -4,12 +4,12 @@ # tests. Execute it by invoking "source all.tcl" when running tktest # in this directory. # -# Copyright © 1998-1999 by Scriptics Corporation. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tk ;# This is the Tk test suite; fail early if no Tk! +package require tk ;# This is the Tk test suite; fail early if no Tk! package require tcltest 2.2 tcltest::configure {*}$argv tcltest::configure -testdir [file normalize [file dirname [info script]]] diff --git a/tests/arc.tcl b/tests/arc.tcl index 0126c7d..2887047 100644 --- a/tests/arc.tcl +++ b/tests/arc.tcl @@ -52,7 +52,7 @@ set outline black .t.c addtag arc withtag all .t.c addtag circle withtag [.t.c create oval 320 200 340 220 -fill MistyRose3] -.t.c bind arc <Any-Enter> { +.t.c bind arc <Enter> { set prevFill [lindex [.t.c itemconf current -fill] 4] set prevOutline [lindex [.t.c itemconf current -outline] 4] if {($prevFill != "") || ($prevOutline == "")} { @@ -62,9 +62,9 @@ set outline black .t.c itemconf current -outline $outline2 } } -.t.c bind arc <Any-Leave> {.t.c itemconf current -fill $prevFill -outline $prevOutline} +.t.c bind arc <Leave> {.t.c itemconf current -fill $prevFill -outline $prevOutline} -bind .t.c <1> {markarea %x %y} +bind .t.c <Button-1> {markarea %x %y} bind .t.c <B1-Motion> {strokearea %x %y} proc markarea {x y} { @@ -89,11 +89,11 @@ bind .t.c <Control-f> { puts stdout "Overlapping: [.t.c find overl $areaX1 $areaY1 $areaX2 $areaY2]" } -bind .t.c <3> {puts stdout "%x %y"} +bind .t.c <Button-3> {puts stdout "%x %y"} # The code below allows the circle to be move by shift-dragging. -bind .t.c <Shift-1> { +bind .t.c <Shift-Button-1> { set curx %x set cury %y } diff --git a/tests/bell.test b/tests/bell.test index bbafeac..4cf7596 100644 --- a/tests/bell.test +++ b/tests/bell.test @@ -1,8 +1,8 @@ # This file is a Tcl script to test out Tk's "bell" command. # It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1998-2000 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1998-2000 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/bgerror.test b/tests/bgerror.test index fd9594a..bd38310 100644 --- a/tests/bgerror.test +++ b/tests/bgerror.test @@ -1,8 +1,8 @@ # This file is a Tcl script to test the bgerror command. # It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/bind.test b/tests/bind.test index 47b80ed..c27412d 100644 --- a/tests/bind.test +++ b/tests/bind.test @@ -2,9 +2,9 @@ # commands plus the procedures in tkBind.c. It is organized in the # standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -13,6 +13,11 @@ eval tcltest::configure $argv tcltest::loadTestedCommands tk useinputmethods 0 +testConstraint nodeprecated [expr {"nodeprecated" ni [tk::pkgconfig list]}] +testConstraint needsTcl87 [package vsatisfies [package provide Tcl] 8.7-] +testConstraint failsOnWindows [expr {![info exists ::env(CI)] || [tk windowingsystem] ne "win32"}] + + toplevel .t -width 100 -height 50 wm geom .t +0+0 update idletasks @@ -36,22 +41,12 @@ proc unsetBindings {} { # move the mouse pointer away of the testing area # otherwise some spurious events may pollute the tests -# also, this will procure a known grab state at startup -# for tests mixing grabs and pointer warps -proc pointerAway {} { - toplevel .top - wm geometry .top 50x50-50-50 - update - # On KDE/Plasma _with_the_Aurorae_theme_ (at least), setting up the toplevel - # will not be finished right after the above 'update'. The WM still - # needs some time before the window is fully ready. For me 50 ms is enough, - # but let's wait more (it depends on computer performance). - after 100 ; update - event generate .top <Button-1> -warp 1 - update - destroy .top -} -pointerAway +toplevel .top +wm geometry .top 50x50-50-50 +update +event generate .top <Button-1> -warp 1 +update +destroy .top test bind-1.1 {bind command} -body { bind @@ -307,9 +302,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 @@ -322,17 +317,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} @@ -366,10 +361,10 @@ test bind-9.3 {Tk_DeleteBinding procedure} -setup { set result {} } -body { frame .t.f -class Test -width 150 -height 100 - foreach i {<1> <Meta-1> <Control-1> <Double-Alt-1>} { + foreach i {<Button-1> <Meta-Button-1> <Control-Button-1> <Double-Alt-Button-1>} { bind .t.f $i "binding for $i" } - foreach i {<Control-1> <Double-Alt-1> <1> <Meta-1>} { + foreach i {<Control-Button-1> <Double-Alt-Button-1> <Button-1> <Meta-Button-1>} { bind .t.f $i {} lappend result [lsort [bind .t.f]] } @@ -394,16 +389,16 @@ 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>" { + foreach i "! a \\\{ ~ <Delete> <space> <<Paste>> <Tab> <Linefeed> <Key-<> <Meta-a> <Â>" { bind .t.f $i Test } lsort [bind .t.f] } -cleanup { destroy .t.f -} -result {! <<Paste>> <Key-Acircumflex> <Key-Delete> <Key-Linefeed> <Key-Tab> <Key-less> <Key-space> <Meta-Key-a> a \{ ~} +} -result "! <<Paste>> <Key-<> <Key-Delete> <Key-Linefeed> <Key-Tab> <Key-space> <Key-Â> <Meta-Key-a> a \\\{ ~" test bind-11.2 {Tk_GetAllBindings procedure} -body { frame .t.f - foreach i "<Double-1> <Triple-1> <Meta-Control-a> <Double-Alt-Enter> <1>" { + foreach i "<Double-Button-1> <Triple-Button-1> <Meta-Control-a> <Double-Alt-Enter> <Button-1>" { bind .t.f $i Test } lsort [bind .t.f] @@ -412,7 +407,7 @@ test bind-11.2 {Tk_GetAllBindings procedure} -body { } -result {<Button-1> <Control-Meta-Key-a> <Double-Alt-Enter> <Double-Button-1> <Triple-Button-1>} test bind-11.3 {Tk_GetAllBindings procedure} -body { frame .t.f - foreach i "<Double-Triple-1> abcd a<Leave>b" { + foreach i "<Double-Triple-Button-1> abcd a<Leave>b" { bind .t.f $i Test } lsort [bind .t.f] @@ -427,7 +422,7 @@ test bind-12.1 {Tk_DeleteAllBindings procedure} -body { } -result {} test bind-12.2 {Tk_DeleteAllBindings procedure} -body { frame .t.f -class Test -width 150 -height 100 - foreach i "a b c <Meta-1> <Alt-a> <Control-a>" { + foreach i "a b c <Meta-Button-1> <Alt-a> <Control-a>" { bind .t.f $i x } destroy .t.f @@ -440,23 +435,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 <:> + event generate .t.f <+> + event generate .t.f <_> 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 : .t.f :} {.t.f : Test :} {.t.f : all Key} {.t.f + Test Key} {.t.f + all Key} {.t.f _ Test Key} {.t.f _ all _}} test bind-13.2 {Tk_BindEvent procedure} -setup { frame .t.f -class Test -width 150 -height 100 @@ -465,17 +460,17 @@ 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 <:> return $x } -cleanup { destroy .t.f - bind all <KeyPress> {} - bind Test <KeyPress> {} -} -result {{.t.f colon .t.f pressed colon} {.t.f colon Test press any}} + bind all <Key> {} + bind Test <Key> {} +} -result {{.t.f : .t.f pressed colon} {.t.f : Test press any}} test bind-13.3 {Tk_BindEvent procedure} -setup { proc bgerror args {} @@ -485,23 +480,23 @@ 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 <:> 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 +} -result {{{.t.f : .t.f pressed colon} {.t.f : Test press any}} {Test while executing "error Test" (command bound to event)}} test bind-13.4 {Tk_BindEvent procedure} -setup { proc foo {} { set x 44 - event generate .t.f <Key-colon> + event generate .t.f <:> } frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -516,7 +511,7 @@ test bind-13.4 {Tk_BindEvent procedure} -setup { } -cleanup { destroy .t.f bind Test : {} -} -result {{.t.f colon .t.f} {.t.f colon Test}} +} -result {{.t.f : .t.f} {.t.f : Test}} test bind-13.5 {Tk_BindEvent procedure} -body { bind all <Destroy> {lappend x "%W destroyed"} @@ -544,7 +539,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 <:> return $x } -cleanup { bind Test : {} @@ -561,7 +556,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 <:> return $x } -cleanup { bind Test : {} @@ -576,14 +571,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 @@ -626,9 +621,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 { @@ -643,12 +638,12 @@ test bind-13.13 {Tk_BindEvent procedure: valid key detail} -setup { } -body { bind .t.f <Key> "lappend x Key%K" bind .t.f <KeyRelease> "lappend x Release%K" - event generate .t.f <Key> -keysym colon - event generate .t.f <KeyRelease> -keysym colon + event generate .t.f <Key> -keysym : + event generate .t.f <KeyRelease> -keysym : return $x } -cleanup { destroy .t.f -} -result {Keycolon Releasecolon} +} -result {Key: Release:} test bind-13.14 {Tk_BindEvent procedure: invalid key detail} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -946,12 +941,12 @@ test bind-13.33 {Tk_BindEvent procedure: many C bindings cause realloc} -setup { } -body { bindtags .t.f {a b c d e f g h i j k l m n o p} foreach p [bindtags .t.f] { - bind $p <1> "lappend x $p" + bind $p <Button-1> "lappend x $p" } - event generate .t.f <1> + event generate .t.f <Button-1> return $x } -cleanup { - foreach p [bindtags .t.f] {bind $p <1> {}} + foreach p [bindtags .t.f] {bind $p <Button-1> {}} destroy .t.f } -result {a b c d e f g h i j k l m n o p} test bind-13.34 {Tk_BindEvent procedure: multiple tags} -setup { @@ -976,12 +971,12 @@ 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 -} -result {1} +} -result 1 test bind-13.38 {Tk_BindEvent procedure: binding gets to run} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -989,13 +984,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 @@ -1064,7 +1059,7 @@ test bind-15.1 {MatchPatterns procedure, ignoring type mismatches} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-15.2 {MatchPatterns procedure, ignoring type mismatches} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1082,7 +1077,7 @@ test bind-15.2 {MatchPatterns procedure, ignoring type mismatches} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-15.3 {MatchPatterns procedure, ignoring type mismatches} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1097,14 +1092,14 @@ test bind-15.3 {MatchPatterns procedure, ignoring type mismatches} -setup { return $x } -cleanup { destroy .t.f -} -result {0} +} -result 0 test bind-15.4 {MatchPatterns procedure, ignoring type mismatches} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f 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> @@ -1113,7 +1108,7 @@ test bind-15.4 {MatchPatterns procedure, ignoring type mismatches} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-15.5 {MatchPatterns procedure, ignoring type mismatches} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1129,41 +1124,41 @@ test bind-15.5 {MatchPatterns procedure, ignoring type mismatches} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-15.6 {MatchPatterns procedure, ignoring type mismatches} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f 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> return $x } -cleanup { destroy .t.f -} -result {0} +} -result 0 test bind-15.7 {MatchPatterns procedure, ignoring type mismatches} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f 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> return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-15.8 {MatchPatterns procedure, ignoring type mismatches} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1172,13 +1167,13 @@ 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 -} -result {0} +} -result 0 test bind-15.9 {MatchPatterns procedure, modifier checks} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1187,11 +1182,11 @@ 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 -} -result {1} +} -result 1 test bind-15.10 {MatchPatterns procedure, modifier checks} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1200,11 +1195,11 @@ 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 -} -result {1} +} -result 1 test bind-15.11 {MatchPatterns procedure, modifier checks} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1213,11 +1208,11 @@ 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 -} -result {0} +} -result 0 test bind-15.12 {MatchPatterns procedure, ignore modifier presses and releases} -constraints { nonPortable } -setup { @@ -1230,13 +1225,13 @@ 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 -} -result {1} +} -result 1 test bind-15.13 {MatchPatterns procedure, checking detail} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1245,19 +1240,19 @@ 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 -} -result {0} +} -result 0 test bind-15.14 {MatchPatterns procedure, checking "nearby"} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f 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> @@ -1267,14 +1262,14 @@ test bind-15.14 {MatchPatterns procedure, checking "nearby"} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-15.15 {MatchPatterns procedure, checking "nearby"} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f 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> @@ -1284,14 +1279,14 @@ test bind-15.15 {MatchPatterns procedure, checking "nearby"} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-15.16 {MatchPatterns procedure, checking "nearby"} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f 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> @@ -1301,14 +1296,14 @@ test bind-15.16 {MatchPatterns procedure, checking "nearby"} -setup { return $x } -cleanup { destroy .t.f -} -result {0} +} -result 0 test bind-15.17 {MatchPatterns procedure, checking "nearby"} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f 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> @@ -1318,14 +1313,14 @@ test bind-15.17 {MatchPatterns procedure, checking "nearby"} -setup { return $x } -cleanup { destroy .t.f -} -result {0} +} -result 0 test bind-15.18 {MatchPatterns procedure, checking "nearby"} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f 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> @@ -1335,14 +1330,14 @@ test bind-15.18 {MatchPatterns procedure, checking "nearby"} -setup { return $x } -cleanup { destroy .t.f -} -result {0} +} -result 0 test bind-15.19 {MatchPatterns procedure, checking "nearby"} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f 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> @@ -1352,14 +1347,14 @@ test bind-15.19 {MatchPatterns procedure, checking "nearby"} -setup { return $x } -cleanup { destroy .t.f -} -result {0} +} -result 0 test bind-15.20 {MatchPatterns procedure, checking "nearby"} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f 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> @@ -1369,14 +1364,14 @@ test bind-15.20 {MatchPatterns procedure, checking "nearby"} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-15.21 {MatchPatterns procedure, checking "nearby"} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f 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> @@ -1386,14 +1381,14 @@ test bind-15.21 {MatchPatterns procedure, checking "nearby"} -setup { return $x } -cleanup { destroy .t.f -} -result {0} +} -result 0 test bind-15.22 {MatchPatterns procedure, time wrap-around} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update } -body { - bind .t.f <Double-1> {set x 1} + bind .t.f <Double-Button-1> {set x 1} set x 0 event generate .t.f <Button-1> -time -100 event generate .t.f <Button-1> -time 200 @@ -1401,14 +1396,14 @@ test bind-15.22 {MatchPatterns procedure, time wrap-around} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-15.23 {MatchPatterns procedure, time wrap-around} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update } -body { - bind .t.f <Double-1> {set x 1} + bind .t.f <Double-Button-1> {set x 1} set x 0 event generate .t.f <Button-1> -time -100 event generate .t.f <Button-1> -time 500 @@ -1416,7 +1411,7 @@ test bind-15.23 {MatchPatterns procedure, time wrap-around} -setup { return $x } -cleanup { destroy .t.f -} -result {0} +} -result 0 test bind-15.24 {MatchPatterns procedure, virtual event} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1482,35 +1477,35 @@ test bind-15.27 {MatchPatterns procedure, conflict resolution} -setup { focus -force .t.f update } -body { - bind .t.f <KeyPress> {set x 0} + bind .t.f <Key> {set x 0} bind .t.f 1 {set x 1} set x none event generate .t.f <Key-1> return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-15.28 {MatchPatterns procedure, conflict resolution} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update } -body { - bind .t.f <KeyPress> {set x 0} + bind .t.f <Key> {set x 0} bind .t.f 1 {set x 1} set x none event generate .t.f <Key-2> return $x } -cleanup { destroy .t.f -} -result {0} +} -result 0 test bind-15.29 {MatchPatterns procedure, conflict resolution} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update } -body { - bind .t.f <KeyPress> {lappend x 0} + bind .t.f <Key> {lappend x 0} bind .t.f 1 {lappend x 1} bind .t.f 21 {lappend x 2} set x none @@ -1527,15 +1522,15 @@ test bind-15.30 {MatchPatterns procedure, conflict resolution} -setup { focus -force .t.f update } -body { - bind .t.f <ButtonPress> {set x 0} - bind .t.f <1> {set x 1} + bind .t.f <Button> {set x 0} + bind .t.f <Button-1> {set x 1} set x none event generate .t.f <Button-1> event generate .t.f <ButtonRelease-1> return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-15.31 {MatchPatterns procedure, conflict resolution} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1545,11 +1540,11 @@ test bind-15.31 {MatchPatterns procedure, conflict resolution} -setup { } -body { bind .t.f <M1-Key> {set x 0} bind .t.f <M2-Key> {set x 1} - event generate .t.f <Key-a> -state 0x18 + event generate .t.f <a> -state 0x18 return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-15.32 {MatchPatterns procedure, conflict resolution} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1559,11 +1554,11 @@ test bind-15.32 {MatchPatterns procedure, conflict resolution} -setup { bind .t.f <M2-Key> {set x 0} bind .t.f <M1-Key> {set x 1} set x none - event generate .t.f <Key-a> -state 0x18 + event generate .t.f <a> -state 0x18 return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-15.33 {MatchPatterns procedure, conflict resolution} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1571,9 +1566,9 @@ test bind-15.33 {MatchPatterns procedure, conflict resolution} -setup { update set x {} } -body { - bind .t.f <1> {lappend x single} - bind Test <1> {lappend x single(Test)} - bind Test <Double-1> {lappend x double(Test)} + bind .t.f <Button-1> {lappend x single} + bind Test <Button-1> {lappend x single(Test)} + bind Test <Double-Button-1> {lappend x double(Test)} event generate .t.f <Button-1> event generate .t.f <Button-1> event generate .t.f <Button-1> @@ -1581,8 +1576,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)} @@ -1611,7 +1606,7 @@ test bind-16.2 {ExpandPercents procedure} -setup { set x } -cleanup { destroy .t.f -} -result {1234} +} -result 1234 test bind-16.3 {ExpandPercents procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1638,7 +1633,7 @@ test bind-16.4 {ExpandPercents procedure} -setup { set x } -cleanup { destroy .t.f -} -result {3} +} -result 3 test bind-16.5 {ExpandPercents procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1651,7 +1646,7 @@ test bind-16.5 {ExpandPercents procedure} -setup { set x } -cleanup { destroy .t.f -} -result {47} +} -result 47 test bind-16.6 {ExpandPercents procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1755,7 +1750,7 @@ test bind-16.13 {ExpandPercents procedure} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-16.14 {ExpandPercents procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1794,7 +1789,7 @@ test bind-16.16 {ExpandPercents procedure} -setup { set x } -cleanup { destroy .t.f -} -result {146} +} -result 146 test bind-16.17 {ExpandPercents procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1860,7 +1855,7 @@ test bind-16.21 {ExpandPercents procedure} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-16.22 {ExpandPercents procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1873,7 +1868,7 @@ test bind-16.22 {ExpandPercents procedure} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-16.23 {ExpandPercents procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1886,7 +1881,7 @@ test bind-16.23 {ExpandPercents procedure} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-16.24 {ExpandPercents procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1919,14 +1914,14 @@ 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> set x } -cleanup { destroy .t.f -} -result {1402} +} -result 1402 test bind-16.27 {ExpandPercents procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1939,7 +1934,7 @@ test bind-16.27 {ExpandPercents procedure} -setup { set x } -cleanup { destroy .t.f -} -result {1023} +} -result 1023 test bind-16.28 {ExpandPercents procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -1992,7 +1987,7 @@ test bind-16.31 {ExpandPercents procedure} -setup { set x } -cleanup { destroy .t.f -} -result {4294} +} -result 4294 test bind-16.32 {ExpandPercents procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -2043,22 +2038,22 @@ 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 -} -result {a A { } {\r} {{}} {{}} { } {\$} \\\{ {{}} {{}} \u00e9} +} -result {a A { } {\r} {{}} {{}} { } {\$} \\\{ {{}} {{}} é} test bind-16.36 {ExpandPercents procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -2071,7 +2066,7 @@ test bind-16.36 {ExpandPercents procedure} -setup { set x } -cleanup { destroy .t.f -} -result {24} +} -result 24 test bind-16.37 {ExpandPercents procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -2084,7 +2079,7 @@ test bind-16.37 {ExpandPercents procedure} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-16.38 {ExpandPercents procedure} -constraints { nonPortable } -setup { @@ -2095,14 +2090,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 @@ -2115,11 +2110,11 @@ 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 -} -result {32} +} -result 32 test bind-16.40 {ExpandPercents procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -2128,7 +2123,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 @@ -2145,7 +2140,7 @@ test bind-16.41 {ExpandPercents procedure} -setup { set x } -cleanup { destroy .t.f -} -result {2} +} -result 2 test bind-16.42 {ExpandPercents procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -2201,7 +2196,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 @@ -2222,7 +2217,7 @@ test bind-16.46 {ExpandPercents procedure} -setup { bind Entry <Key> {set y "%M"} bind .t.e <Key> {set x "%M"} set x none; set y none; set z none - event gen .t.e <Key-a> + event gen .t.e <a> list $x $y $z } -cleanup { destroy .t.e @@ -2230,6 +2225,19 @@ test bind-16.46 {ExpandPercents procedure} -setup { bind all <Key> $savedBind(All) unset savedBind } -result {0 1 2} +test bind-16.47 {ExpandPercents procedure} -constraints {aquaOrWin32 needsTcl87 failsOnWindows} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Key> {set x "%K"} + set x none + event generate .t.f <Key> -keysym € + set x +} -cleanup { + destroy .t.f +} -result € test bind-17.1 {event command} -body { event @@ -2246,7 +2254,7 @@ test bind-17.4 {event command: add 1} -body { event info <<Paste>> } -cleanup { event delete <<Paste>> <Control-v> -} -result {<Control-Key-v>} +} -result <Control-Key-v> test bind-17.5 {event command: add 2} -body { event delete <<Paste>> event add <<Paste>> <Control-v> <Button-2> @@ -2256,13 +2264,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>> @@ -2273,12 +2281,12 @@ test bind-17.8 {event command: delete} -body { } -returnCodes error -result {wrong # args: should be "event delete virtual ?sequence ...?"} test bind-17.9 {event command: delete many} -body { event delete <<Paste>> - event add <<Paste>> <3> <1> <2> t - event delete <<Paste>> <1> <2> + event add <<Paste>> <Button-3> <Button-1> <Button-2> t + event delete <<Paste>> <Button-1> <Button-2> lsort [event info <<Paste>>] } -cleanup { event delete <<Paste>> - event delete <<Paste>> <3> t + event delete <<Paste>> <Button-3> t } -result {<Button-3> t} test bind-17.10 {event command: delete all} -body { event add <<Paste>> a b @@ -2326,12 +2334,12 @@ 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 -} -result {1} +} -result 1 test bind-17.17 {event command: generate} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -2359,7 +2367,7 @@ test bind-18.3 {CreateVirtualEvent procedure: new physical} -body { event info <<xyz>> } -cleanup { event delete <<xyz>> -} -result {<Control-Key-v>} +} -result <Control-Key-v> test bind-18.4 {CreateVirtualEvent procedure: duplicate physical} -body { event delete <<xyz>> event add <<xyz>> <Control-v> @@ -2367,7 +2375,7 @@ test bind-18.4 {CreateVirtualEvent procedure: duplicate physical} -body { event info <<xyz>> } -cleanup { event delete <<xyz>> -} -result {<Control-Key-v>} +} -result <Control-Key-v> test bind-18.5 {CreateVirtualEvent procedure: existing physical} -body { foreach p [event info] {event delete $p} event add <<xyz>> <Control-v> @@ -2416,7 +2424,7 @@ test bind-19.4 {DeleteVirtualEvent procedure: delete 1, not owned} -setup { event add <<xyz>> <Control-v> event delete <<xyz>> <Button-1> event info <<xyz>> -} -result {<Control-Key-v>} +} -result <Control-Key-v> test bind-19.5 {DeleteVirtualEvent procedure: delete 1, badly formed} -body { event add <<xyz>> <Control-v> event delete <<xyz>> <xyz> @@ -2473,7 +2481,7 @@ test bind-19.11 {DeleteVirtualEvent procedure: owned by 1, only} -setup { set x } -cleanup { destroy .t.f -} -result {101} +} -result 101 test bind-19.12 {DeleteVirtualEvent procedure: owned by 1, first in chain} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -2694,11 +2702,11 @@ 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>> -} -result {<Control-Key-v>} +} -result <Control-Key-v> test bind-20.4 {GetVirtualEvent procedure: owns many} -setup { event delete <<xyz>> } -body { @@ -2719,13 +2727,13 @@ test bind-21.2 {GetAllVirtualEvents procedure: 1 event} -body { event info } -cleanup { event delete <<xyz>> -} -result {<<xyz>>} +} -result <<xyz>> test bind-21.3 {GetAllVirtualEvents procedure: many events} -body { foreach p [event info] {event delete $p} 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>> @@ -2794,7 +2802,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 @@ -2811,7 +2819,7 @@ test bind-22.11 {HandleEventGenerate} -setup { set x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.12 {HandleEventGenerate} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -2824,7 +2832,7 @@ test bind-22.12 {HandleEventGenerate} -setup { set x } -cleanup { destroy .t.f -} -result {4} +} -result 4 test bind-22.13 {HandleEventGenerate} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -2838,7 +2846,7 @@ test bind-22.13 {HandleEventGenerate} -setup { set x } -cleanup { destroy .t.f -} -result {100} +} -result 100 test bind-22.14 {HandleEventGenerate} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -2994,7 +3002,7 @@ test bind-22.25 {HandleEventGenerate: options <Configure> -borderwidth 2i} -setu expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.26 {HandleEventGenerate: options <Key> -borderwidth 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3088,7 +3096,7 @@ test bind-22.32 {HandleEventGenerate: options <Expose> -count 20} -setup { return $x } -cleanup { destroy .t.f -} -result {20} +} -result 20 test bind-22.33 {HandleEventGenerate: options <Key> -count 20} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3196,7 +3204,7 @@ test bind-22.39 {HandleEventGenerate: options <Enter> -focus 1} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.40 {HandleEventGenerate: options <Key> -focus 1} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3236,7 +3244,7 @@ test bind-22.42 {HandleEventGenerate: options <Expose> -height 2i} -setup { expr {$x eq [winfo pixels .t.f 2i]} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.43 {HandleEventGenerate: options <Configure> -height 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3250,7 +3258,7 @@ test bind-22.43 {HandleEventGenerate: options <Configure> -height 2i} -setup { expr {$x eq [winfo pixels .t.f 2i]} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.44 {HandleEventGenerate: options <Key> -height 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3290,7 +3298,7 @@ test bind-22.46 {HandleEventGenerate: options <Key> -keycode 20} -setup { return $x } -cleanup { destroy .t.f -} -result {20} +} -result 20 test bind-22.47 {HandleEventGenerate: options <Button> -keycode 20} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3423,7 +3431,7 @@ test bind-22.56 {HandleEventGenerate: options <Map> -override 1} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.57 {HandleEventGenerate: options <Reparent> -override 1} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3437,7 +3445,7 @@ test bind-22.57 {HandleEventGenerate: options <Reparent> -override 1} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.58 {HandleEventGenerate: options <Configure> -override 1} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3451,7 +3459,7 @@ test bind-22.58 {HandleEventGenerate: options <Configure> -override 1} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.59 {HandleEventGenerate: options <Key> -override 1} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3531,7 +3539,7 @@ test bind-22.64 {HandleEventGenerate: options <Key> -root .t} -setup { expr {[winfo id .t] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.65 {HandleEventGenerate: options <Key> -root xyz} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3558,7 +3566,7 @@ test bind-22.66 {HandleEventGenerate: options <Key> -root [winfo id .t]} -setup expr {[winfo id .t] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.67 {HandleEventGenerate: options <Button> -root .t} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3572,7 +3580,7 @@ test bind-22.67 {HandleEventGenerate: options <Button> -root .t} -setup { expr {[winfo id .t] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.68 {HandleEventGenerate: options <ButtonRelease> -root .t} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3586,7 +3594,7 @@ test bind-22.68 {HandleEventGenerate: options <ButtonRelease> -root .t} -setup { expr {[winfo id .t] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.69 {HandleEventGenerate: options <Motion> -root .t} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3600,7 +3608,7 @@ test bind-22.69 {HandleEventGenerate: options <Motion> -root .t} -setup { expr {[winfo id .t] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.70 {HandleEventGenerate: options <<Paste>> -root .t} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3614,7 +3622,7 @@ test bind-22.70 {HandleEventGenerate: options <<Paste>> -root .t} -setup { expr {[winfo id .t] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.71 {HandleEventGenerate: options <Enter> -root .t} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3628,7 +3636,7 @@ test bind-22.71 {HandleEventGenerate: options <Enter> -root .t} -setup { expr {[winfo id .t] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.72 {HandleEventGenerate: options <Configure> -root .t} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3668,7 +3676,7 @@ test bind-22.74 {HandleEventGenerate: options <Key> -rootx 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.75 {HandleEventGenerate: options <Button> -rootx 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3682,7 +3690,7 @@ test bind-22.75 {HandleEventGenerate: options <Button> -rootx 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.76 {HandleEventGenerate: options <ButtonRelease> -rootx 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3696,7 +3704,7 @@ test bind-22.76 {HandleEventGenerate: options <ButtonRelease> -rootx 2i} -setup expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.77 {HandleEventGenerate: options <Motion> -rootx 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3710,7 +3718,7 @@ test bind-22.77 {HandleEventGenerate: options <Motion> -rootx 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.78 {HandleEventGenerate: options <<Paste>> -rootx 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3724,7 +3732,7 @@ test bind-22.78 {HandleEventGenerate: options <<Paste>> -rootx 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.79 {HandleEventGenerate: options <Enter> -rootx 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3738,7 +3746,7 @@ test bind-22.79 {HandleEventGenerate: options <Enter> -rootx 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.80 {HandleEventGenerate: options <Configure> -rootx 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3778,7 +3786,7 @@ test bind-22.82 {HandleEventGenerate: options <Key> -rooty 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.83 {HandleEventGenerate: options <Button> -rooty 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3792,7 +3800,7 @@ test bind-22.83 {HandleEventGenerate: options <Button> -rooty 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.84 {HandleEventGenerate: options <ButtonRelease> -rooty 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3806,7 +3814,7 @@ test bind-22.84 {HandleEventGenerate: options <ButtonRelease> -rooty 2i} -setup expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.85 {HandleEventGenerate: options <Motion> -rooty 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3820,7 +3828,7 @@ test bind-22.85 {HandleEventGenerate: options <Motion> -rooty 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.86 {HandleEventGenerate: options <<Paste>> -rooty 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3834,7 +3842,7 @@ test bind-22.86 {HandleEventGenerate: options <<Paste>> -rooty 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.87 {HandleEventGenerate: options <Enter> -rooty 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3848,7 +3856,7 @@ test bind-22.87 {HandleEventGenerate: options <Enter> -rooty 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.88 {HandleEventGenerate: options <Configure> -rooty 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3888,7 +3896,7 @@ test bind-22.90 {HandleEventGenerate: options <Key> -sendevent 1} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.91 {HandleEventGenerate: options <Key> -sendevent yes} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3902,7 +3910,7 @@ test bind-22.91 {HandleEventGenerate: options <Key> -sendevent yes} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.92 {HandleEventGenerate: options <Key> -sendevent 43} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3916,7 +3924,7 @@ test bind-22.92 {HandleEventGenerate: options <Key> -sendevent 43} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.93 {HandleEventGenerate: options <Key> -serial xyz} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3943,7 +3951,7 @@ test bind-22.94 {HandleEventGenerate: options <Key> -serial 100} -setup { return $x } -cleanup { destroy .t.f -} -result {100} +} -result 100 test bind-22.95 {HandleEventGenerate: options <Key> -state xyz} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3970,7 +3978,7 @@ test bind-22.96 {HandleEventGenerate: options <Key> -state 1} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.97 {HandleEventGenerate: options <Button> -state 1025} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3984,7 +3992,7 @@ test bind-22.97 {HandleEventGenerate: options <Button> -state 1025} -setup { return $x } -cleanup { destroy .t.f -} -result {1025} +} -result 1025 test bind-22.98 {HandleEventGenerate: options <ButtonRelease> -state 1025} -setup { frame .t.f -class Test -width 150 -height 100 @@ -3998,7 +4006,7 @@ test bind-22.98 {HandleEventGenerate: options <ButtonRelease> -state 1025} -setu return $x } -cleanup { destroy .t.f -} -result {1025} +} -result 1025 test bind-22.99 {HandleEventGenerate: options <Motion> -state 1} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4012,7 +4020,7 @@ test bind-22.99 {HandleEventGenerate: options <Motion> -state 1} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.100 {HandleEventGenerate: options <<Paste>> -state 1} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4026,7 +4034,7 @@ test bind-22.100 {HandleEventGenerate: options <<Paste>> -state 1} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.101 {HandleEventGenerate: options <Enter> -state 1} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4040,7 +4048,7 @@ test bind-22.101 {HandleEventGenerate: options <Enter> -state 1} -setup { return $x } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.102 {HandleEventGenerate: options <Visibility> -state xyz} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4107,7 +4115,7 @@ test bind-22.106 {HandleEventGenerate: options <Key> -subwindow .t} -setup { expr {[winfo id .t] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.107 {HandleEventGenerate: options <Key> -subwindow xyz} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4134,7 +4142,7 @@ test bind-22.108 {HandleEventGenerate: options <Key> -subwindow [winfo id .t]} - expr {[winfo id .t] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.109 {HandleEventGenerate: options <Button> -subwindow .t} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4148,7 +4156,7 @@ test bind-22.109 {HandleEventGenerate: options <Button> -subwindow .t} -setup { expr {[winfo id .t] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.110 {HandleEventGenerate: options <ButtonRelease> -subwindow .t} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4162,7 +4170,7 @@ test bind-22.110 {HandleEventGenerate: options <ButtonRelease> -subwindow .t} -s expr {[winfo id .t] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.111 {HandleEventGenerate: options <Motion> -subwindow .t} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4176,7 +4184,7 @@ test bind-22.111 {HandleEventGenerate: options <Motion> -subwindow .t} -setup { expr {[winfo id .t] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.112 {HandleEventGenerate: options <<Paste>> -subwindow .t} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4190,7 +4198,7 @@ test bind-22.112 {HandleEventGenerate: options <<Paste>> -subwindow .t} -setup { expr {[winfo id .t] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.113 {HandleEventGenerate: options <Enter> -subwindow .t} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4204,7 +4212,7 @@ test bind-22.113 {HandleEventGenerate: options <Enter> -subwindow .t} -setup { expr {[winfo id .t] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.114 {HandleEventGenerate: options <Configure> -subwindow .t} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4244,7 +4252,7 @@ test bind-22.116 {HandleEventGenerate: options <Key> -time 100} -setup { return $x } -cleanup { destroy .t.f -} -result {100} +} -result 100 test bind-22.117 {HandleEventGenerate: options <Button> -time 100} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4258,7 +4266,7 @@ test bind-22.117 {HandleEventGenerate: options <Button> -time 100} -setup { return $x } -cleanup { destroy .t.f -} -result {100} +} -result 100 test bind-22.118 {HandleEventGenerate: options <ButtonRelease> -time 100} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4272,7 +4280,7 @@ test bind-22.118 {HandleEventGenerate: options <ButtonRelease> -time 100} -setup return $x } -cleanup { destroy .t.f -} -result {100} +} -result 100 test bind-22.119 {HandleEventGenerate: options <Motion> -time 100} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4286,7 +4294,7 @@ test bind-22.119 {HandleEventGenerate: options <Motion> -time 100} -setup { return $x } -cleanup { destroy .t.f -} -result {100} +} -result 100 test bind-22.120 {HandleEventGenerate: options <<Paste>> -time 100} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4300,7 +4308,7 @@ test bind-22.120 {HandleEventGenerate: options <<Paste>> -time 100} -setup { return $x } -cleanup { destroy .t.f -} -result {100} +} -result 100 test bind-22.121 {HandleEventGenerate: options <Enter> -time 100} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4314,7 +4322,7 @@ test bind-22.121 {HandleEventGenerate: options <Enter> -time 100} -setup { return $x } -cleanup { destroy .t.f -} -result {100} +} -result 100 test bind-22.122 {HandleEventGenerate: options <Property> -time 100} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4328,7 +4336,7 @@ test bind-22.122 {HandleEventGenerate: options <Property> -time 100} -setup { return $x } -cleanup { destroy .t.f -} -result {100} +} -result 100 test bind-22.123 {HandleEventGenerate: options <Configure> -time 100} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4368,7 +4376,7 @@ test bind-22.125 {HandleEventGenerate: options <Expose> -width 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.126 {HandleEventGenerate: options <Configure> -width 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4382,7 +4390,7 @@ test bind-22.126 {HandleEventGenerate: options <Configure> -width 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.127 {HandleEventGenerate: options <Key> -width 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4573,7 +4581,7 @@ test bind-22.140 {HandleEventGenerate: options <Key> -x 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.141 {HandleEventGenerate: options <Button> -x 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4587,7 +4595,7 @@ test bind-22.141 {HandleEventGenerate: options <Button> -x 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.142 {HandleEventGenerate: options <ButtonRelease> -x 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4601,7 +4609,7 @@ test bind-22.142 {HandleEventGenerate: options <ButtonRelease> -x 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.143 {HandleEventGenerate: options <Motion> -x 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4615,7 +4623,7 @@ test bind-22.143 {HandleEventGenerate: options <Motion> -x 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.144 {HandleEventGenerate: options <<Paste>> -x 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4629,7 +4637,7 @@ test bind-22.144 {HandleEventGenerate: options <<Paste>> -x 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.145 {HandleEventGenerate: options <Enter> -x 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4643,7 +4651,7 @@ test bind-22.145 {HandleEventGenerate: options <Enter> -x 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.146 {HandleEventGenerate: options <Expose> -x 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4657,7 +4665,7 @@ test bind-22.146 {HandleEventGenerate: options <Expose> -x 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.147 {HandleEventGenerate: options <Configure> -x 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4671,7 +4679,7 @@ test bind-22.147 {HandleEventGenerate: options <Configure> -x 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.148 {HandleEventGenerate: options <Gravity> -x 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4685,7 +4693,7 @@ test bind-22.148 {HandleEventGenerate: options <Gravity> -x 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.149 {HandleEventGenerate: options <Reparent> -x 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4699,7 +4707,7 @@ test bind-22.149 {HandleEventGenerate: options <Reparent> -x 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.150 {HandleEventGenerate: options <Map> -x 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4739,7 +4747,7 @@ test bind-22.152 {HandleEventGenerate: options <Key> -y 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.153 {HandleEventGenerate: options <Button> -y 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4753,7 +4761,7 @@ test bind-22.153 {HandleEventGenerate: options <Button> -y 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.154 {HandleEventGenerate: options <ButtonRelease> -y 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4767,7 +4775,7 @@ test bind-22.154 {HandleEventGenerate: options <ButtonRelease> -y 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.155 {HandleEventGenerate: options <Motion> -y 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4781,7 +4789,7 @@ test bind-22.155 {HandleEventGenerate: options <Motion> -y 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.156 {HandleEventGenerate: options <<Paste>> -y 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4795,7 +4803,7 @@ test bind-22.156 {HandleEventGenerate: options <<Paste>> -y 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.157 {HandleEventGenerate: options <Enter> -y 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4809,7 +4817,7 @@ test bind-22.157 {HandleEventGenerate: options <Enter> -y 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.158 {HandleEventGenerate: options <Expose> -y 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4823,7 +4831,7 @@ test bind-22.158 {HandleEventGenerate: options <Expose> -y 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.159 {HandleEventGenerate: options <Configure> -y 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4837,7 +4845,7 @@ test bind-22.159 {HandleEventGenerate: options <Configure> -y 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.160 {HandleEventGenerate: options <Gravity> -y 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4851,7 +4859,7 @@ test bind-22.160 {HandleEventGenerate: options <Gravity> -y 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.161 {HandleEventGenerate: options <Reparent> -y 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4865,7 +4873,7 @@ test bind-22.161 {HandleEventGenerate: options <Reparent> -y 2i} -setup { expr {[winfo pixels .t.f 2i] eq $x} } -cleanup { destroy .t.f -} -result {1} +} -result 1 test bind-22.162 {HandleEventGenerate: options <Map> -y 2i} -setup { frame .t.f -class Test -width 150 -height 100 @@ -4938,10 +4946,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> @@ -5096,7 +5104,7 @@ test bind-25.2 {ParseEventDescription procedure: misinterpreted modifier} -setup button .b } -body { bind .b <Control-M> a - bind .b <M-M> b + bind .b <Meta-M> b lsort [bind .b] } -cleanup { destroy .b @@ -5116,7 +5124,7 @@ test bind-25.4 {ParseEventDescription} -setup { bind .t.f } -cleanup { destroy .t.f -} -result {<<Shift-Paste>>} +} -result <<Shift-Paste>> # Assorted error cases in event sequence parsing test bind-25.5 {ParseEventDescription procedure error cases} -body { @@ -5200,7 +5208,7 @@ test bind-25.21 {modifier names} -setup { test bind-25.22 {modifier names} -setup { frame .t.f -class Test -width 150 -height 100 } -body { - bind .t.f <M-a> foo + bind .t.f <Meta-a> foo bind .t.f } -cleanup { destroy .t.f @@ -5449,6 +5457,42 @@ test bind-25.49 {modifier names} -setup { destroy .t.f } -result <Extended-Key-Return> +test bind-25.50 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Button6-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B6-Key-a> + +test bind-25.51 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Button7-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B7-Key-a> + +test bind-25.52 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Button8-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B8-Key-a> + +test bind-25.53 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Button9-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B9-Key-a> + test bind-26.1 {event names} -setup { @@ -5509,20 +5553,6 @@ test bind-26.5 {event names: Button} -setup { destroy .t.f } -result {{event Button} <Button>} -test bind-26.6 {event names: ButtonPress} -setup { - frame .t.f -class Test -width 150 -height 100 - pack .t.f - 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] -} -cleanup { - destroy .t.f -} -result {{event ButtonPress} <Button>} - test bind-26.7 {event names: ButtonRelease} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -5607,20 +5637,6 @@ test bind-26.12 {event names: Key} -setup { destroy .t.f } -result {{event Key} <Key>} -test bind-26.13 {event names: KeyPress} -setup { - frame .t.f -class Test -width 150 -height 100 - pack .t.f - 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] -} -cleanup { - destroy .t.f -} -result {{event KeyPress} <Key>} - test bind-26.14 {event names: KeyRelease} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -5782,8 +5798,8 @@ test bind-27.1 {button names} -body { bind .t <Expose-1> foo } -returnCodes error -result {specified button "1" for non-button event} test bind-27.2 {button names} -body { - bind .t <Button-6> foo -} -returnCodes error -result {bad button number "6"} + bind .t <Button-10> foo +} -returnCodes error -result {bad button number "10"} test bind-27.3 {button names} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -5854,6 +5870,62 @@ test bind-27.7 {button names} -setup { } -cleanup { destroy .t.f } -result {<Button-5> {button 5}} +test bind-27.8 {button names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button-6> {lappend x "button 6"} + set x [bind .t.f] + event generate .t.f <Button-6> + event generate .t.f <ButtonRelease-6> + set x +} -cleanup { + destroy .t.f +} -result {<Button-6> {button 6}} +test bind-27.9 {button names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button-7> {lappend x "button 7"} + set x [bind .t.f] + event generate .t.f <Button-7> + event generate .t.f <ButtonRelease-7> + set x +} -cleanup { + destroy .t.f +} -result {<Button-7> {button 7}} +test bind-27.10 {button names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button-8> {lappend x "button 8"} + set x [bind .t.f] + event generate .t.f <Button-8> + event generate .t.f <ButtonRelease-8> + set x +} -cleanup { + destroy .t.f +} -result {<Button-8> {button 8}} +test bind-27.11 {button names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button-9> {lappend x "button 9"} + set x [bind .t.f] + event generate .t.f <Button-9> + event generate .t.f <ButtonRelease-9> + set x +} -cleanup { + destroy .t.f +} -result {<Button-9> {button 9}} test bind-28.1 {keysym names} -body { bind .t <Expose-a> foo @@ -5862,7 +5934,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 @@ -5878,10 +5950,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 <:> "lappend x \"keysym received\"" + bind .t.f <_> "lappend x {bad binding match}" set x [lsort [bind .t.f]] - event generate .t.f <Key-colon> ;# -state 0 + event generate .t.f <:> ;# -state 0 set x } -cleanup { destroy .t.f @@ -5892,10 +5964,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 @@ -5906,10 +5978,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 @@ -5920,42 +5992,63 @@ 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 { +test bind-28.9 {keysym names, Ð} -body { frame .t.f -class Test -width 150 -height 100 - bind .t.f <Eth> foo + bind .t.f <Ð> foo bind .t.f } -cleanup { destroy .t.f -} -result {<Key-ETH>} -test bind-28.10 {keysym names, Ooblique -> Oslash} -body { +} -result <Key-Ð> +test bind-28.10 {keysym names, Ø} -constraints nodeprecated -body { frame .t.f -class Test -width 150 -height 100 - bind .t.f <Ooblique> foo + bind .t.f <Ø> foo bind .t.f } -cleanup { destroy .t.f -} -result {<Key-Oslash>} +} -result <Key-Ø> 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>} +} -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>} +} -result <Key-Greek_IOTAdieresis> +test bind-28.13 {keysym names, Unicode} -body { + frame .t.f -class Test -width 150 -height 100 + bind .t.f <€> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result "<Key-€>" +test bind-28.14 {keysym names, Emoji} -body { + frame .t.f -class Test -width 150 -height 100 + bind .t.f <\U1F44D> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result "<Key-\U1F44D>" +test bind-28.15 {keysym names, Emoji} -constraints needsTcl87 -body { + frame .t.f -class Test -width 150 -height 100 + bind .t.f <👍> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result "<Key-👍>" test bind-29.1 {Tcl_BackgroundError procedure} -setup { @@ -6036,7 +6129,7 @@ test bind-30.2 {MouseWheel events} -setup { set x } -cleanup { destroy .t.f -} -result {120} +} -result 120 test bind-30.3 {MouseWheel events} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f @@ -6147,12 +6240,15 @@ test bind-31.7 {virtual event user_data field - unshared, asynch} -setup { } -result {{} {} {TestUserData >b<}} test bind-32.1 {-warp, window was destroyed before the idle callback DoWarp} -setup { + # note: this test is now essentially useless + # since DoWarp no longer exist, not even as an idle callback frame .t.f pack .t.f focus -force .t.f update } -body { event generate .t.f <Button-1> -warp 1 + after 50 ; # Win specific - wait for SendInput to be executed event generate .t.f <ButtonRelease-1> destroy .t.f update ; # shall simply not crash @@ -6165,7 +6261,7 @@ test bind-32.2 {detection of double click should not fail} -setup { update set x {} } -body { - event generate .t.f <ButtonPress-1> + event generate .t.f <Button-1> event generate .t.f <ButtonRelease-1> # Simulate a lot of intervening exposure events. The old implementation # that used an event ring overflowed, and the double click was not detected. @@ -6173,7 +6269,7 @@ test bind-32.2 {detection of double click should not fail} -setup { for {set i 0} {$i < 1000} {incr i} { event generate .t.f <Expose> } - event generate .t.f <ButtonPress-1> + event generate .t.f <Button-1> event generate .t.f <ButtonRelease-1> set x } -cleanup { @@ -6185,10 +6281,10 @@ test bind-32.3 {should trigger best match of modifier states} -setup { update set x {} } -body { - bind .t.f <Alt-Control-Key-A> { lappend x "Alt-Control" } - bind .t.f <Shift-Control-Key-A> { lappend x "Shift-Control" } - bind .t.f <Shift-Key-A> { lappend x "Shift" } - event generate .t.f <Alt-Control-Key-A> + bind .t.f <Alt-Control-A> { lappend x "Alt-Control" } + bind .t.f <Shift-Control-A> { lappend x "Shift-Control" } + bind .t.f <Shift-A> { lappend x "Shift" } + event generate .t.f <Alt-Control-A> set x } -cleanup { destroy .t.f @@ -6199,10 +6295,10 @@ test bind-32.4 {should not trigger Double-1} -setup { update set x {} } -body { - bind .t.f <Double-1> { set x "Double" } - event generate .t.f <1> -time current + bind .t.f <Double-Button-1> { set x "Double" } + event generate .t.f <Button-1> -time current after 1000 - event generate .t.f <1> -time current + event generate .t.f <Button-1> -time current set x } -cleanup { destroy .t.f @@ -6213,10 +6309,10 @@ test bind-32.5 {should trigger Quadruple-1} -setup { update set x {} } -body { - bind .t.f <Quadruple-1> { set x "Quadruple" } - bind .t.f <Triple-1> { set x "Triple" } - bind .t.f <Double-1> { set x "Double" } - bind .t.f <1> { set x "Single" } + bind .t.f <Quadruple-Button-1> { set x "Quadruple" } + bind .t.f <Triple-Button-1> { set x "Triple" } + bind .t.f <Double-Button-1> { set x "Double" } + bind .t.f <Button-1> { set x "Single" } # Old implementation triggered "Double", but new implementation # triggers "Quadruple", the latter behavior conforms to other toolkits. event generate .t.f <Button-1> -time 0 @@ -6246,10 +6342,10 @@ test bind-32.7 {test sequences} -setup { update set x {} } -body { - bind .t.f <Double-1> { lappend x "Double" } - bind .t.f <1><1><a> { lappend x "11" } - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Double-Button-1> { lappend x "Double" } + bind .t.f <Button-1><Button-1><a> { lappend x "11" } + event generate .t.f <Button-1> + event generate .t.f <Button-1> event generate .t.f <a> set x } -cleanup { @@ -6261,12 +6357,12 @@ test bind-32.8 {test sequences} -setup { update set x {} } -body { - bind .t.f <a><1><Double-1><1><a> { lappend x "Double" } + bind .t.f <a><Button-1><Double-Button-1><Button-1><a> { lappend x "Double" } event generate .t.f <a> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> event generate .t.f <a> set x } -cleanup { @@ -6278,8 +6374,8 @@ test bind-32.9 {trigger events for modifier keys} -setup { update set x {} } -body { - bind .t.f <Any-Key> { set x "Key" } - event generate .t.f <KeyPress> -keysym Caps_Lock + bind .t.f <Key> { set x "Key" } + event generate .t.f <Key> -keysym Caps_Lock set x } -cleanup { destroy .t.f @@ -6288,14 +6384,14 @@ test bind-32.10 {reset key state when destroying window} -setup { set x {} } -body { pack [frame .t.f]; update; focus -force .t.f - bind .t.f <Key-A> { set x "A" } - event generate .t.f <KeyPress-A> - event generate .t.f <KeyPress-A> + bind .t.f <A> { set x "A" } + event generate .t.f <A> + event generate .t.f <A> destroy .t.f; update pack [frame .t.f]; update; focus -force .t.f - bind .t.f <Key-A> { set x "A" } - bind .t.f <Double-Key-A> { set x "AA" } - event generate .t.f <KeyPress-A> + bind .t.f <A> { set x "A" } + bind .t.f <Double-A> { set x "AA" } + event generate .t.f <A> destroy .t.f set x } -result {A} @@ -6309,7 +6405,7 @@ test bind-32.11 {match detailed virtual} -setup { bind Test <<TestControlButton1>> { set x "Control-Button-1" } bind Test <Button-1> { set x "Button-1" } bind .t.f <Button-1> { set x "Button-1" } - event generate .t.f <Control-ButtonPress-1> + event generate .t.f <Control-Button-1> set x } -cleanup { destroy .t.f @@ -6325,25 +6421,25 @@ test bind-32.12 {don't detect repetition when window has changed} -setup { } -body { bind .t.f <Button-1> { set x "1" } bind .t.f <Double-Button-1> { set x "11" } - event generate .t.f <ButtonPress-1> - event generate .t.g <ButtonPress-1> - event generate .t.f <ButtonPress-1> + event generate .t.f <Button-1> + event generate .t.g <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f destroy .t.g -} -result {1} +} -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 <Key-A> { set x "A" } - bind .t.f <Double-Key-A> { set x "AA" } - focus -force .t.f; event generate .t.f <KeyPress-A> - focus -force .t.g; event generate .t.g <KeyPress-A> - focus -force .t.f; event generate .t.f <KeyPress-A> + bind .t.f <A> { set x "A" } + bind .t.f <Double-A> { set x "AA" } + focus -force .t.f; event generate .t.f <A> + focus -force .t.g; event generate .t.g <A> + focus -force .t.f; event generate .t.f <A> set x } -cleanup { destroy .t.f @@ -6355,31 +6451,31 @@ test bind-32.14 {don't detect repetition when window has changed} -setup { update set x {} } -body { - bind .t.f <ButtonPress-1> { set x "1" } - bind .t.f <Double-ButtonPress-1> { set x "11" } - focus -force .t.f; event generate .t.f <ButtonPress-1> - focus -force .t.g; event generate .t.g <ButtonPress-1> - focus -force .t.f; event generate .t.f <ButtonPress-1> + bind .t.f <Button-1> { set x "1" } + bind .t.f <Double-Button-1> { set x "11" } + focus -force .t.f; event generate .t.f <Button-1> + focus -force .t.g; event generate .t.g <Button-1> + focus -force .t.f; event generate .t.f <Button-1> set x } -cleanup { destroy .t.f destroy .t.g -} -result {1} +} -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 <ButtonPress-1> { set x "1" } - event generate .t.f <ButtonPress-1> - event generate .t.f <ButtonPress-1> + bind .t.f <Button-1> { set x "1" } + event generate .t.f <Button-1> + event generate .t.f <Button-1> destroy .t.f; update pack [frame .t.f]; update; focus -force .t.f - bind .t.f <ButtonPress-1> { set x "1" } - bind .t.f <Double-ButtonPress-1> { set x "11" } - event generate .t.f <ButtonPress-1> + bind .t.f <Button-1> { set x "1" } + bind .t.f <Double-Button-1> { set x "11" } + event generate .t.f <Button-1> destroy .t.f set x -} -result {1} +} -result 1 test bind-33.1 {prefer longest match} -setup { pack [frame .t.f] @@ -6387,141 +6483,133 @@ test bind-33.1 {prefer longest match} -setup { update set x {} } -body { - bind .t.f <a><1><1> { lappend x "a11" } - bind .t.f <Double-1> { lappend x "Double" } + bind .t.f <a><Button-1><Button-1> { lappend x "a11" } + bind .t.f <Double-Button-1> { lappend x "Double" } event generate .t.f <a> - event generate .t.f <1> - event generate .t.f <1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f } -result {a11} -test bind-33.2 {should prefer most specific event} -setup { +test bind-33.2 {prefer most specific event} -setup { pack [frame .t.f] focus -force .t.f update set x {} } -body { - bind .t.f <Double-1> { lappend x "Double" } - bind .t.f <1><1> { lappend x "11" } - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Double-Button-1> { lappend x "Double" } + bind .t.f <Button-1><Button-1> { lappend x "11" } + event generate .t.f <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f - # This test case shows that old implementation has an issue, because - # it is expected that <Double-1> is matching, this binding - # is more specific. But new implementation will be conform to old, - # and so "11" is the expected result. -} -result {11} -test bind-33.3 {should prefer most specific event} -setup { +} -result {Double} +test bind-33.3 {prefer most specific event} -setup { pack [frame .t.f] focus -force .t.f update set x {} } -body { - bind .t.f <a><Double-1><a> { lappend x "Double" } - bind .t.f <a><1><1><a> { lappend x "11" } + bind .t.f <a><Double-Button-1><a> { lappend x "Double" } + bind .t.f <a><Button-1><Button-1><a> { lappend x "11" } event generate .t.f <a> - event generate .t.f <1> - event generate .t.f <1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> event generate .t.f <a> set x } -cleanup { destroy .t.f - # Also this test case shows that old implementation has an issue, it is - # expected that <a><Double-1><a> is matching, because <Double-1> is more - # specific than <1><1>. But new implementation will be conform to old, - # and so "11" is the expected result. -} -result {11} +} -result {Double} test bind-33.4 {prefer most specific event} -setup { pack [frame .t.f] focus -force .t.f update set x {} } -body { - bind .t.f <1><1> { lappend x "11" } - bind .t.f <Double-1> { lappend x "Double" } - event generate .t.f <1> -time 0 - event generate .t.f <1> -time 1000 + bind .t.f <Button-1><Button-1> { lappend x "11" } + bind .t.f <Double-Button-1> { lappend x "Double" } + event generate .t.f <Button-1> -time 0 + event generate .t.f <Button-1> -time 1000 set x } -cleanup { destroy .t.f -} -result {11} +} -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 <1><1> { lappend x "11" } - bind .t.f <Double-ButtonPress> { lappend x "Double" } - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Button-1><Button-1> { lappend x "11" } + bind .t.f <Double-Button> { lappend x "Double" } + event generate .t.f <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f -} -result {11} +} -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><1><1><1><1><a> { lappend x "1111" } - bind .t.f <a><ButtonPress><Double-ButtonPress><ButtonPress><a> { lappend x "Any-Double-Any" } + bind .t.f <a><Button-1><Button-1><Button-1><Button-1><a> { lappend x "1111" } + bind .t.f <a><Button><Double-Button><Button><a> { lappend x "Any-Double-Any" } event generate .t.f <a> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> event generate .t.f <a> set x } -cleanup { destroy .t.f -} -result {1111} +} -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 <ButtonPress-1><a> { lappend x "1" } - bind .t.f <ButtonPress><a> { lappend x "Any" } - event generate .t.f <1> + bind .t.f <Button-1><a> { lappend x "1" } + bind .t.f <Button><a> { lappend x "Any" } + event generate .t.f <Button-1> event generate .t.f <a> set x } -cleanup { destroy .t.f -} -result {1} +} -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-ButtonPress-1><a> { lappend x "1" } - bind .t.f <ButtonPress><ButtonPress><a> { lappend x "Any" } - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Double-Button-1><a> { lappend x "1" } + bind .t.f <Button><Button><a> { lappend x "Any" } + event generate .t.f <Button-1> + event generate .t.f <Button-1> event generate .t.f <a> set x } -cleanup { destroy .t.f -} -result {1} +} -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 <1><2><2><Double-1> { lappend x "first" } - bind .t.f <1><Double-2><1><1> { lappend x "last" } - event generate .t.f <1> - event generate .t.f <2> - event generate .t.f <2> - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Button-1><Button-2><Button-2><Double-Button-1> { lappend x "first" } + bind .t.f <Button-1><Double-Button-2><Button-1><Button-1> { lappend x "last" } + event generate .t.f <Button-1> + event generate .t.f <Button-2> + event generate .t.f <Button-2> + event generate .t.f <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f @@ -6532,13 +6620,13 @@ test bind-33.10 {prefer last in case of homogeneous equal patterns} -setup { update set x {} } -body { - bind .t.f <1><Double-2><1><1> { lappend x "first" } - bind .t.f <1><2><2><Double-1> { lappend x "last" } - event generate .t.f <1> - event generate .t.f <2> - event generate .t.f <2> - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Button-1><Double-Button-2><Button-1><Button-1> { lappend x "first" } + bind .t.f <Button-1><Button-2><Button-2><Double-Button-1> { lappend x "last" } + event generate .t.f <Button-1> + event generate .t.f <Button-2> + event generate .t.f <Button-2> + event generate .t.f <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f @@ -6549,35 +6637,31 @@ test bind-33.11 {should prefer most specific} -setup { update set x {} } -body { - bind .t.f <2><Double-1><Double-2><Double-1><2><2> { lappend x "first" } - bind .t.f <2><1><1><2><2><Double-1><Double-2> { lappend x "last" } - event generate .t.f <2> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <2> - event generate .t.f <2> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <2> - event generate .t.f <2> + bind .t.f <Button-2><Double-Button-1><Double-Button-2><Double-Button-1><Button-2><Button-2> { lappend x "first" } + bind .t.f <Button-2><Button-1><Button-1><Button-2><Button-2><Double-Button-1><Double-Button-2> { lappend x "last" } + event generate .t.f <Button-2> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-2> + event generate .t.f <Button-2> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-2> + event generate .t.f <Button-2> set x } -cleanup { destroy .t.f - # This test case shows that old implementation has an issue, because - # it is expected that first one is matching, this binding - # is more specific. But new implementation will be conform to old, - # and so "last" is the expected result. -} -result {last} +} -result {first} test bind-33.12 {prefer last in case of homogeneous equal patterns} -setup { pack [frame .t.f] focus -force .t.f update set x {} } -body { - bind .t.f <Control-1><1> { lappend x "first" } - bind .t.f <1><Control-1> { lappend x "last" } - event generate .t.f <Control-1> - event generate .t.f <Control-1> + bind .t.f <Control-Button-1><Button-1> { lappend x "first" } + bind .t.f <Button-1><Control-Button-1> { lappend x "last" } + event generate .t.f <Control-Button-1> + event generate .t.f <Control-Button-1> set x } -cleanup { destroy .t.f @@ -6588,10 +6672,10 @@ test bind-33.13 {prefer last in case of homogeneous equal patterns} -setup { update set x {} } -body { - bind .t.f <1><Control-1> { lappend x "first" } - bind .t.f <Control-1><1> { lappend x "last" } - event generate .t.f <Control-1> - event generate .t.f <Control-1> + bind .t.f <Button-1><Control-1> { lappend x "first" } + bind .t.f <Control-1><Button-1> { lappend x "last" } + event generate .t.f <Control-Button-1> + event generate .t.f <Control-Button-1> set x } -cleanup { destroy .t.f @@ -6605,12 +6689,12 @@ test bind-33.14 {prefer last in case of homogeneous equal patterns} -setup { update set x {} } -body { - bind .t.f <1><ButtonPress><1><ButtonPress> { lappend x "first" } - bind .t.f <ButtonPress><1><ButtonPress><1> { lappend x "last" } - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Button-1><Button><Button-1><Button> { lappend x "first" } + bind .t.f <Button><Button-1><Button><Button-1> { lappend x "last" } + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f @@ -6621,12 +6705,12 @@ test bind-33.15 {prefer last in case of homogeneous equal patterns} -setup { update set x {} } -body { - bind .t.f <ButtonPress><1><ButtonPress><1> { lappend x "first" } - bind .t.f <1><ButtonPress><1><ButtonPress> { lappend x "last" } - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> - event generate .t.f <1> + bind .t.f <Button><Button-1><Button><Button-1> { lappend x "first" } + bind .t.f <Button-1><Button><Button-1><Button> { lappend x "last" } + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> set x } -cleanup { destroy .t.f @@ -6692,7 +6776,7 @@ test bind-33.19 {simulate use of the keyboard to trigger a pattern sequence with set x {} } -body { bind .t.f <Escape><Control-c> { lappend x "Esc_Control-c" } - bind .t.f <Escape><KeyPress><KeyPress><Control-c> { lappend x "Esc_Key(2)_Control-c" } + bind .t.f <Escape><Key><Key><Control-c> { lappend x "Esc_Key(2)_Control-c" } event generate .t.f <Escape> event generate .t.f <Alt_L> event generate .t.f <Control_L> @@ -6745,14 +6829,12 @@ test bind-34.1 {-warp works relatively to a window} -setup { wm geometry .top +200+200 after 10 ; 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 + after 50 ; # Win specific - wait for SendInput to be executed set pointerPos1 [winfo pointerxy .top] wm geometry .top +600+600 after 10 ; 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 + after 50 ; # Win specific - wait for SendInput to be executed set pointerPos2 [winfo pointerxy .top] # from the first warped position to the second one, the mouse # pointer should have moved the same amount as the window moved @@ -6765,17 +6847,15 @@ test bind-34.1 {-warp works relatively to a window} -setup { set res } -cleanup { destroy .top -} -result {1} +} -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 + 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 + after 50 ; # Win specific - wait for SendInput to be executed lappend res {*}[winfo pointerxy .] } -cleanup { } -result {20 20 200 200} @@ -6793,8 +6873,7 @@ test bind-34.3 {-warp works with null or negative coordinates} -setup { 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 + after 50 ; # Win specific - wait for SendInput to be executed foreach dim [winfo pointerxy .] { if {$dim <= $halo} { lappend res ok @@ -6803,9 +6882,9 @@ test bind-34.3 {-warp works with null or negative coordinates} -setup { } } event generate {} <Motion> -x 100 -y 100 -warp 1 - update idletasks ; after 50 + after 50 ; # Win specific - wait for SendInput to be executed event generate {} <Motion> -x -1 -y -1 -warp 1 - update idletasks ; after 50 + after 50 ; # Win specific - wait for SendInput to be executed foreach dim [winfo pointerxy .] { if {$dim <= $halo} { lappend res ok @@ -6823,7 +6902,7 @@ proc testKey {window event type mods} { global keyInfo numericKeysym set keyInfo {} set numericKeysym {} - bind $window <KeyPress> { + bind $window <Key> { set keyInfo [format "%K,0x%%X,0x%%X,%A" %N %k] set numericKeysym %N } @@ -6897,8 +6976,8 @@ test bind-35.1 {Key events agree for entry widgets} -constraints {aqua} -setup { test bind-35.2 {Can bind to function keys} -constraints {aqua} -body { global keyInfo numericKeysym - bind . <KeyPress> {} - bind . <KeyPress> { + bind . <Key> {} + bind . <Key> { lappend keyInfo %K set numericKeysym %N } @@ -6916,7 +6995,7 @@ test bind-35.3 {Events agree for modifier keys} -constraints {aqua} -setup { } -body { global keyInfo numericalKeysym set result {} - bind . <KeyPress> { + bind . <Key> { set keyInfo [format "%K,0x%%X,0x%%X,%A" %N %k] set numericalKeysym [format "0x%x" %N] } @@ -6949,7 +7028,8 @@ test bind-35.3 {Events agree for modifier keys} -constraints {aqua} -setup { } -result pass test bind-36.1 {pointer warp with grab on toplevel, bug [e3888d5820]} -setup { - pointerAway + event generate {} <Motion> -warp 1 -x 50 -y 50 + after 50 ; # Win specific - wait for SendInput to be executed toplevel .top grab release .top wm geometry .top 200x200+300+300 @@ -6963,19 +7043,15 @@ test bind-36.1 {pointer warp with grab on toplevel, bug [e3888d5820]} -setup { # but let's wait more (it depends on computer performance). after 100 ; update } -body { - grab .top ; # this will queue events - after 50 - update + grab .top event generate .top.l <Motion> -warp 1 -x 10 -y 10 - update idletasks ; after 50 + after 50 ; # Win specific - wait for SendInput to be executed foreach {x1 y1} [winfo pointerxy .top.l] {} event generate {} <Motion> -warp 1 -x 50 -y 50 - update idletasks ; after 50 - grab release .top ; # this will queue events - after 50 - update + after 50 ; # Win specific - wait for SendInput to be executed + grab release .top event generate .top.l <Motion> -warp 1 -x 10 -y 10 - update idletasks ; after 50 + after 50 ; # Win specific - wait for SendInput to be executed foreach {x2 y2} [winfo pointerxy .top.l] {} # success if the coords are the same with or without the grab, and if they # are at (10,10) inside the label widget as requested by the warping @@ -6984,7 +7060,7 @@ test bind-36.1 {pointer warp with grab on toplevel, bug [e3888d5820]} -setup { } -cleanup { destroy .top unset x1 y1 x2 y2 -} -result {1} +} -result 1 # cleanup cleanupTests diff --git a/tests/bitmap.test b/tests/bitmap.test index 6996f88..02c0f40 100644 --- a/tests/bitmap.test +++ b/tests/bitmap.test @@ -2,8 +2,8 @@ # tkBitmap.c. It is organized in the standard white-box fashion for # Tcl tests. # -# Copyright (c) 1998 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/border.test b/tests/border.test index e13d52a..96ebdcf 100644 --- a/tests/border.test +++ b/tests/border.test @@ -1,8 +1,8 @@ # This file is a Tcl script to test out the procedures in the file # tkBorder.c. It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1998 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -127,6 +127,7 @@ test border-2.2 {Tk_Free3DBorder - unlinking from list} -constraints { destroy .b .t2 .t3 .t } -result {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}} + test border-3.1 {FreeBorderObjProc} -constraints { testborder } -setup { diff --git a/tests/busy.test b/tests/busy.test index 98d83a8..e4f5165 100644 --- a/tests/busy.test +++ b/tests/busy.test @@ -4,7 +4,7 @@ # commands. Sourcing this file runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1998-2000 by Jos Decoster. All rights reserved. +# Copyright © 1998-2000 Jos Decoster. All rights reserved. package require tcltest 2.2 tcltest::configure {*}$argv @@ -17,59 +17,65 @@ namespace import -force tcltest::test test busy-1.1 {Tk_BusyObjCmd} -returnCodes error -body { tk busy -} -result {wrong # args: should be "tk busy options ?arg arg ...?"} +} -result {wrong # args: should be "tk busy options ?arg ...?"} test busy-2.1 {tk busy hold} -returnCodes error -body { tk busy hold -} -result {wrong # args: should be "tk busy hold window ?option value ...?"} +} -result {wrong # args: should be "tk busy hold window ?-option value ...?"} test busy-2.2 {tk busy hold root window} -body { - tk busy hold . + set res [tk busy hold .] update + set res } -cleanup { tk busy forget . -} -result {} +} -result {._Busy} test busy-2.3 {tk busy hold root window with shortcut} -body { - tk busy . + set res [tk busy .] update + set res } -cleanup { tk busy forget . -} -result {} +} -result {._Busy} test busy-2.4 {tk busy hold nested window} -setup { pack [frame .f] } -body { - tk busy hold .f + set res [tk busy hold .f] update + set res } -cleanup { tk busy forget .f destroy .f -} -result {} +} -result {.f_Busy} test busy-2.5 {tk busy hold nested window with shortcut} -setup { pack [frame .f] } -body { - tk busy .f + set res [tk busy .f] update + set res } -cleanup { tk busy forget .f destroy .f -} -result {} +} -result {.f_Busy} test busy-2.6 {tk busy hold toplevel window} -setup { toplevel .f } -body { - tk busy hold .f + set res [tk busy hold .f] update + set res } -cleanup { tk busy forget .f destroy .f -} -result {} +} -result {.f._Busy} test busy-2.7 {tk busy hold toplevel window with shortcut} -setup { toplevel .f } -body { - tk busy .f + set res [tk busy .f] update + set res } -cleanup { tk busy forget .f destroy .f -} -result {} +} -result {.f._Busy} test busy-2.8 {tk busy hold non existing window} -body { tk busy hold .f update @@ -79,17 +85,19 @@ test busy-2.9 {tk busy hold (shortcut) non existing window} -body { update } -returnCodes {error} -result {bad window path name ".f"} test busy-2.10 {tk busy hold root window with cursor} -body { - tk busy hold . -cursor arrow + set res [tk busy hold . -cursor arrow] update + set res } -cleanup { tk busy forget . -} -result {} +} -result {._Busy} test busy-2.11 {tk busy hold (shortcut) root window, cursor} -body { - tk busy . -cursor arrow + set res [tk busy . -cursor arrow] update + set res } -cleanup { tk busy forget . -} -result {} +} -result {._Busy} test busy-2.12 {tk busy hold root window, invalid cursor} -body { tk busy hold . -cursor nonExistingCursor update @@ -174,7 +182,7 @@ test busy-3.7 {tk busy cget unix} -setup { test busy-4.1 {tk busy configure no window} -returnCodes error -body { tk busy configure -} -result {wrong # args: should be "tk busy configure window ?option? ?value ...?"} +} -result {wrong # args: should be "tk busy configure window ?-option value ...?"} test busy-4.2 {tk busy configure invalid window} -body { tk busy configure .f @@ -342,14 +350,14 @@ test busy-6.1 {tk busy status} -returnCodes error -body { } -result {wrong # args: should be "tk busy status window"} test busy-6.2 {tk busy status non existing window} -body { tk busy status .f -} -result {0} +} -result 0 test busy-6.3 {tk busy status non busy window} -setup { pack [frame .f] } -body { tk busy status .f } -cleanup { destroy .f -} -result {0} +} -result 0 test busy-6.4 {tk busy status busy window} -setup { pack [frame .f] tk busy hold .f @@ -359,7 +367,7 @@ test busy-6.4 {tk busy status busy window} -setup { } -cleanup { tk busy forget .f destroy .f -} -result {1} +} -result 1 test busy-6.5 {tk busy status forgotten busy window} -setup { pack [frame .f] tk busy hold .f @@ -369,7 +377,7 @@ test busy-6.5 {tk busy status forgotten busy window} -setup { tk busy status .f } -cleanup { destroy .f -} -result {0} +} -result 0 test busy-7.1 {tk busy current no busy} -body { tk busy current @@ -473,5 +481,29 @@ test busy-7.9 {tk busy current 2 busy with non matching filter after forget} -se destroy .f1 .f2 } -result {} +test busy-8.1 {tk busy busywindow with a busy toplevel} -body { + toplevel .top + tk busy .top + tk busy busywindow .top +} -cleanup { + tk busy forget .top + destroy .top +} -result {.top._Busy} +test busy-8.2 {tk busy busywindow with a busy widget} -body { + pack [frame .f] + tk busy .f + tk busy busywindow .f +} -cleanup { + tk busy forget .f + destroy .f +} -result {.f_Busy} +test busy-8.3 {tk busy busywindow with a nonexisting widget} -body { + tk busy . + tk busy busywindow .nonExistingWidget +} -cleanup { + tk busy forget . +} -result {} + + ::tcltest::cleanupTests return diff --git a/tests/button.test b/tests/button.test index f3292b31..25df606 100644 --- a/tests/button.test +++ b/tests/button.test @@ -2,9 +2,9 @@ # radiobuttons in Tk (i.e., all the widgets defined in tkButton.c). It is # organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -334,7 +334,7 @@ test button-1.33 {configuration option: "bd" for label} -setup { .l cget -bd } -cleanup { destroy .l -} -result {4} +} -result 4 test button-1.34 {configuration option: "bd" for label} -setup { label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .l @@ -353,7 +353,7 @@ test button-1.35 {configuration option: "bd" for button} -setup { .b cget -bd } -cleanup { destroy .b -} -result {4} +} -result 4 test button-1.36 {configuration option: "bd" for button} -setup { button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .b @@ -372,7 +372,7 @@ test button-1.37 {configuration option: "bd" for checkbutton} -setup { .c cget -bd } -cleanup { destroy .c -} -result {4} +} -result 4 test button-1.38 {configuration option: "bd" for checkbutton} -setup { checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .c @@ -391,7 +391,7 @@ test button-1.39 {configuration option: "bd" for radiobutton} -setup { .r cget -bd } -cleanup { destroy .r -} -result {4} +} -result 4 test button-1.40 {configuration option: "bd" for radiobutton} -setup { radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .r @@ -1165,7 +1165,7 @@ test button-1.119 {configuration option: "height" for label} -setup { .l cget -height } -cleanup { destroy .l -} -result {18} +} -result 18 test button-1.120 {configuration option: "height" for label} -setup { label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .l @@ -1184,7 +1184,7 @@ test button-1.121 {configuration option: "height" for button} -setup { .b cget -height } -cleanup { destroy .b -} -result {18} +} -result 18 test button-1.122 {configuration option: "height" for button} -setup { button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .b @@ -1203,7 +1203,7 @@ test button-1.123 {configuration option: "height" for checkbutton} -setup { .c cget -height } -cleanup { destroy .c -} -result {18} +} -result 18 test button-1.124 {configuration option: "height" for checkbutton} -setup { checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .c @@ -1222,7 +1222,7 @@ test button-1.125 {configuration option: "height" for radiobutton} -setup { .r cget -height } -cleanup { destroy .r -} -result {18} +} -result 18 test button-1.126 {configuration option: "height" for radiobutton} -setup { radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .r @@ -1566,7 +1566,7 @@ test button-1.159 {configuration option: "indicatoron" for checkbutton} -setup { .c cget -indicatoron } -cleanup { destroy .c -} -result {1} +} -result 1 test button-1.160 {configuration option: "indicatoron" for checkbutton} -setup { checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .c @@ -1585,7 +1585,7 @@ test button-1.161 {configuration option: "indicatoron" for radiobutton} -setup { .r cget -indicatoron } -cleanup { destroy .r -} -result {1} +} -result 1 test button-1.162 {configuration option: "indicatoron" for radiobutton} -setup { radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .r @@ -1955,7 +1955,7 @@ test button-1.199 {configuration option: "repeatdelay" for button} -setup { .b cget -repeatdelay } -cleanup { destroy .b -} -result {100} +} -result 100 test button-1.200 {configuration option: "repeatdelay" for button} -setup { button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .b @@ -1975,7 +1975,7 @@ test button-1.201 {configuration option: "repeatinterval" for button} -setup { .b cget -repeatinterval } -cleanup { destroy .b -} -result {100} +} -result 100 test button-1.202 {configuration option: "repeatinterval" for button} -setup { button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .b @@ -2405,7 +2405,7 @@ test button-1.243 {configuration option: "underline" for label} -setup { .l cget -underline } -cleanup { destroy .l -} -result {5} +} -result 5 test button-1.244 {configuration option: "underline" for label} -setup { label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .l @@ -2424,7 +2424,7 @@ test button-1.245 {configuration option: "underline" for button} -setup { .b cget -underline } -cleanup { destroy .b -} -result {5} +} -result 5 test button-1.246 {configuration option: "underline" for button} -setup { button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .b @@ -2443,7 +2443,7 @@ test button-1.247 {configuration option: "underline" for checkbutton} -setup { .c cget -underline } -cleanup { destroy .c -} -result {5} +} -result 5 test button-1.248 {configuration option: "underline" for checkbutton} -setup { checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .c @@ -2462,7 +2462,7 @@ test button-1.249 {configuration option: "underline" for radiobutton} -setup { .r cget -underline } -cleanup { destroy .r -} -result {5} +} -result 5 test button-1.250 {configuration option: "underline" for radiobutton} -setup { radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .r @@ -2514,7 +2514,7 @@ test button-1.254 {configuration option: "width" for label} -setup { .l cget -width } -cleanup { destroy .l -} -result {402} +} -result 402 test button-1.255 {configuration option: "width" for label} -setup { label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .l @@ -2533,7 +2533,7 @@ test button-1.256 {configuration option: "width" for button} -setup { .b cget -width } -cleanup { destroy .b -} -result {402} +} -result 402 test button-1.257 {configuration option: "width" for button} -setup { button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .b @@ -2552,7 +2552,7 @@ test button-1.258 {configuration option: "width" for checkbutton} -setup { .c cget -width } -cleanup { destroy .c -} -result {402} +} -result 402 test button-1.259 {configuration option: "width" for checkbutton} -setup { checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .c @@ -2571,7 +2571,7 @@ test button-1.260 {configuration option: "width" for radiobutton} -setup { .r cget -width } -cleanup { destroy .r -} -result {402} +} -result 402 test button-1.261 {configuration option: "width" for radiobutton} -setup { radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .r @@ -2591,7 +2591,7 @@ test button-1.262 {configuration option: "wraplength" for label} -setup { .l cget -wraplength } -cleanup { destroy .l -} -result {100} +} -result 100 test button-1.263 {configuration option: "wraplength" for label} -setup { label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .l @@ -2610,7 +2610,7 @@ test button-1.264 {configuration option: "wraplength" for button} -setup { .b cget -wraplength } -cleanup { destroy .b -} -result {100} +} -result 100 test button-1.265 {configuration option: "wraplength" for button} -setup { button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .b @@ -2629,7 +2629,7 @@ test button-1.266 {configuration option: "wraplength" for checkbutton} -setup { .c cget -wraplength } -cleanup { destroy .c -} -result {100} +} -result 100 test button-1.267 {configuration option: "wraplength" for checkbutton} -setup { checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .c @@ -2648,7 +2648,7 @@ test button-1.268 {configuration option: "wraplength" for radiobutton} -setup { .r cget -wraplength } -cleanup { destroy .r -} -result {100} +} -result 100 test button-1.269 {configuration option: "wraplength" for radiobutton} -setup { radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .r @@ -2834,13 +2834,13 @@ test button-3.13 {ButtonWidgetCmd procedure, "configure" option} -body { lindex [.b configure -highlightthickness] 4 } -cleanup { destroy .b -} -result {3} +} -result 3 test button-3.14 {ButtonWidgetCmd procedure, "configure" option} -body { checkbutton .c llength [.c configure] } -cleanup { destroy .c -} -result {41} +} -result 41 test button-3.15 {ButtonWidgetCmd procedure, "configure" option} -body { button .b .b configure -gorp @@ -2889,7 +2889,7 @@ test button-3.21 {ButtonWidgetCmd procedure, "deselect" option} -body { return $checkvar } -cleanup { destroy .c -} -result {0} +} -result 0 test button-3.22 {ButtonWidgetCmd procedure, "deselect" option} -body { radiobutton .r -variable radiovar -value red set radiovar green @@ -3249,7 +3249,7 @@ test button-5.4 {ConfigureButton - variable trace} -body { ;# ex 6.2a return $y } -cleanup { destroy .c -} -result {1} +} -result 1 test button-5.5 {ConfigureButton - image handling} -constraints { testImageType @@ -3282,7 +3282,7 @@ test button-5.7 {ConfigureButton - setting selected state from variable} -body { return $y } -cleanup { destroy .c -} -result {0} +} -result 0 test button-5.8 {ConfigureButton - setting selected state from variable} -setup { unset -nocomplain x } -body { @@ -3487,7 +3487,7 @@ test button-5.25 {ConfigureButton - computing geometry} -setup { expr {$old == $new} } -cleanup { destroy .b -} -result {0} +} -result 0 test button-6.1 {ButtonEventProc procedure} -body { button .b -text "Test Button" -command { @@ -3554,7 +3554,7 @@ test button-8.3 {TkInvokeButton procedure} -setup { } -cleanup { destroy .c trace vdelete x w bogusTrace -} -result {1} +} -result 1 test button-8.4 {TkInvokeButton procedure} -setup { set x 1 } -body { @@ -3575,7 +3575,7 @@ test button-8.5 {TkInvokeButton procedure} -setup { } -cleanup { destroy .c trace vdelete x w bogusTrace -} -result {0} +} -result 0 test button-8.6 {TkInvokeButton procedure} -setup { set x 0 @@ -3665,7 +3665,7 @@ test button-9.2 {ButtonVarProc procedure} -body { return $x } -cleanup { destroy .c -} -result {1} +} -result 1 test button-9.3 {ButtonVarProc procedure} -setup { set x 1 } -body { @@ -3675,7 +3675,7 @@ test button-9.3 {ButtonVarProc procedure} -setup { return $x } -cleanup { destroy .c -} -result {1} +} -result 1 test button-9.4 {ButtonVarProc procedure} -setup { set x 0 } -body { @@ -3685,7 +3685,7 @@ test button-9.4 {ButtonVarProc procedure} -setup { return $x } -cleanup { destroy .c -} -result {0} +} -result 0 test button-9.5 {ButtonVarProc procedure} -setup { set x 1 } -body { @@ -3695,7 +3695,7 @@ test button-9.5 {ButtonVarProc procedure} -setup { return $x } -cleanup { destroy .c -} -result {0} +} -result 0 test button-9.6 {ButtonVarProc procedure} -setup { set x 0 } -body { @@ -3705,7 +3705,7 @@ test button-9.6 {ButtonVarProc procedure} -setup { return $x } -cleanup { destroy .c -} -result {1} +} -result 1 test button-9.7 {ButtonVarProc procedure} -setup { set x 1 } -body { @@ -3715,7 +3715,7 @@ test button-9.7 {ButtonVarProc procedure} -setup { return $x } -cleanup { destroy .c -} -result {1} +} -result 1 test button-9.8 {ButtonVarProc procedure, can't read variable} -setup { # This test does nothing but produce a core dump if there's a prbblem. unset -nocomplain a @@ -3751,7 +3751,7 @@ test button-10.2 {ButtonTextVarProc procedure} -setup { expr {$old == $new} } -cleanup { destroy .b -} -result {0} +} -result 0 test button-11.1 {ButtonImageProc procedure} -constraints { testImageType @@ -3780,7 +3780,7 @@ test button-12.1 {button widget vs hidden commands} -body { expr {$res1 == $res2} } -cleanup { destroy .b -} -result {1} +} -result 1 test button-13.1 {size behavior: label} -setup { label .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} diff --git a/tests/canvImg.test b/tests/canvImg.test index 27c00d6..db72219 100644 --- a/tests/canvImg.test +++ b/tests/canvImg.test @@ -2,9 +2,9 @@ # which implement canvas "image" items. It is organized in the standard # fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/canvMoveto.test b/tests/canvMoveto.test index a6cf849..187a56d 100644 --- a/tests/canvMoveto.test +++ b/tests/canvMoveto.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test out the canvas "moveto" command. It is # derived from canvRect.test. # -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2004 Neil McKay. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2004 Neil McKay. # All rights reserved. package require tcltest 2.2 diff --git a/tests/canvPs.test b/tests/canvPs.test index eb09af9..ffebd21 100644 --- a/tests/canvPs.test +++ b/tests/canvPs.test @@ -2,8 +2,8 @@ # for canvases to files and channels. It exercises the procedure # TkCanvPostscriptCmd in generic/tkCanvPs.c # -# Copyright (c) 1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -158,7 +158,7 @@ test canvPs-3.1 {test ps generation with an embedded window} -constraints { destroy .c imageCleanup removeFile bar.ps -} -result {1} +} -result 1 test canvPs-3.2 {test ps generation with an embedded window not mapped} -setup { set bar [makeFile {} bar.ps] file delete $bar @@ -172,7 +172,7 @@ test canvPs-3.2 {test ps generation with an embedded window not mapped} -setup { } -cleanup { destroy .c removeFile bar.ps -} -result {1} +} -result 1 test canvPs-4.1 {test ps generation with single-point uncolored poly, bug 734498} -body { diff --git a/tests/canvRect.test b/tests/canvRect.test index ec59e8b..33e5d18 100644 --- a/tests/canvRect.test +++ b/tests/canvRect.test @@ -2,8 +2,8 @@ # which implement canvas "rectangle" and "oval" items. It is organized # in the standard fashion for Tcl tests. # -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/canvText.test b/tests/canvText.test index 4898eb8..f6b5e4b 100644 --- a/tests/canvText.test +++ b/tests/canvText.test @@ -2,8 +2,8 @@ # which implement canvas "text" items. It is organized in the standard # fashion for Tcl tests. # -# Copyright (c) 1996-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -253,7 +253,7 @@ test canvText-4.6 {ConfigureText procedure: adjust cursor} -setup { .c index test insert } -cleanup { .c delete test -} -result {4} +} -result 4 test canvText-5.1 {ConfigureText procedure: adjust cursor} -body { @@ -576,7 +576,7 @@ test canvText-8.8 {TextInsert procedure: inserting before cursor} -setup { .c icursor test 3 .c insert test 2 "xyz" .c index test insert -} -result {6} +} -result 6 test canvText-8.9 {TextInsert procedure: inserting after cursor} -setup { .c create text 20 20 -tag test focus .c @@ -586,7 +586,7 @@ test canvText-8.9 {TextInsert procedure: inserting after cursor} -setup { .c icursor test 3 .c insert test 4 "xyz" .c index test insert -} -result {3} +} -result 3 # Item used in 9.* tests .c create text 20 20 -tag test @@ -676,19 +676,19 @@ test canvText-9.13 {TextInsert procedure: move cursor} -body { .c icursor test 6 .c dchars test 2 4 .c index test insert -} -result {3} +} -result 3 test canvText-9.14 {TextInsert procedure: keep cursor >= first} -body { .c itemconfig test -text "abcdefghijk" .c icursor test 6 .c dchars test 2 10 .c index test insert -} -result {2} +} -result 2 test canvText-9.15 {TextInsert procedure: cursor doesn't move} -body { .c itemconfig test -text "abcdefghijk" .c icursor test 5 .c dchars test 7 9 .c index test insert -} -result {5} +} -result 5 .c delete test @@ -698,7 +698,7 @@ test canvText-10.1 {TextToPoint procedure} -body { .c index test @0,0 } -cleanup { .c delete test -} -result {0} +} -result 0 test canvText-11.1 {TextToArea procedure} -setup { @@ -837,7 +837,7 @@ test canvText-15.1 {SetTextCursor procedure} -setup { .c index test insert } -cleanup { .c delete test -} -result {3} +} -result 3 test canvText-16.1 {GetSelText procedure} -setup { .c create text 0 0 -tag test diff --git a/tests/canvWind.test b/tests/canvWind.test index 436ee2c..cef0cb8 100644 --- a/tests/canvWind.test +++ b/tests/canvWind.test @@ -2,8 +2,8 @@ # which implement canvas "window" items. It is organized in the standard # fashion for Tcl tests. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/canvas.test b/tests/canvas.test index d91d872..ea71193 100644 --- a/tests/canvas.test +++ b/tests/canvas.test @@ -2,9 +2,9 @@ # implements generic code for canvases. It is organized in the standard # fashion for Tcl tests. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 Ajuba Solutions. -# Copyright (c) 2008 Donal K. Fellows +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-2000 Ajuba Solutions. +# Copyright © 2008 Donal K. Fellows # All rights reserved. package require tcltest 2.2 @@ -37,14 +37,14 @@ test canvas-1.4 {configuration options: bad value for "bg"} -body { test canvas-1.5 {configuration options: good value for "bd"} -body { .c configure -bd 4 .c cget -bd -} -result {4} +} -result 4 test canvas-1.6 {configuration options: bad value for "bd"} -body { .c configure -bd badValue } -returnCodes error -result {bad screen distance "badValue"} test canvas-1.7 {configuration options: good value for "borderwidth"} -body { .c configure -borderwidth 1.3 .c cget -borderwidth -} -result {1} +} -result 1 test canvas-1.8 {configuration options: bad value for "borderwidth"} -body { .c configure -borderwidth badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -58,7 +58,7 @@ test canvas-1.10 {configuration options: bad value for "closeenough"} -body { test canvas-1.11 {configuration options: good value for "confine"} -body { .c configure -confine true .c cget -confine -} -result {1} +} -result 1 test canvas-1.12 {configuration options: bad value for "confine"} -body { .c configure -confine silly } -returnCodes error -result {expected boolean value but got "silly"} @@ -72,7 +72,7 @@ test canvas-1.14 {configuration options: bad value for "cursor"} -body { test canvas-1.15 {configuration options: good value for "height"} -body { .c configure -height 2.1 .c cget -height -} -result {2} +} -result 2 test canvas-1.16 {configuration options: bad value for "height"} -body { .c configure -height x42 } -returnCodes error -result {bad screen distance "x42"} @@ -93,7 +93,7 @@ test canvas-1.20 {configuration options: bad value for "highlightcolor"} -body { test canvas-1.21 {configuration options: good value for "highlightthickness"} -body { .c configure -highlightthickness 18 .c cget -highlightthickness -} -result {18} +} -result 18 test canvas-1.22 {configuration options: bad value for "highlightthickness"} -body { .c configure -highlightthickness badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -107,28 +107,28 @@ test canvas-1.24 {configuration options: bad value for "insertbackground"} -body test canvas-1.25 {configuration options: good value for "insertborderwidth"} -body { .c configure -insertborderwidth 1.3 .c cget -insertborderwidth -} -result {1} +} -result 1 test canvas-1.26 {configuration options: bad value for "insertborderwidth"} -body { .c configure -insertborderwidth 2.6x } -returnCodes error -result {bad screen distance "2.6x"} test canvas-1.27 {configuration options: good value for "insertofftime"} -body { .c configure -insertofftime 100 .c cget -insertofftime -} -result {100} +} -result 100 test canvas-1.28 {configuration options: bad value for "insertofftime"} -body { .c configure -insertofftime 3.2 } -returnCodes error -result {expected integer but got "3.2"} test canvas-1.29 {configuration options: good value for "insertontime"} -body { .c configure -insertontime 100 .c cget -insertontime -} -result {100} +} -result 100 test canvas-1.30 {configuration options: bad value for "insertontime"} -body { .c configure -insertontime 3.2 } -returnCodes error -result {expected integer but got "3.2"} test canvas-1.31 {configuration options: good value for "insertwidth"} -body { .c configure -insertwidth 1.3 .c cget -insertwidth -} -result {1} +} -result 1 test canvas-1.32 {configuration options: bad value for "insertwidth"} -body { .c configure -insertwidth 6x } -returnCodes error -result {bad screen distance "6x"} @@ -149,7 +149,7 @@ test canvas-1.36 {configuration options: bad value for "selectbackground"} -body test canvas-1.37 {configuration options: good value for "selectborderwidth"} -body { .c configure -selectborderwidth 1.3 .c cget -selectborderwidth -} -result {1} +} -result 1 test canvas-1.38 {configuration options: bad value for "selectborderwidth"} -body { .c configure -selectborderwidth badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -167,7 +167,7 @@ test canvas-1.41 {configuration options: good value for "takefocus"} -body { test canvas-1.42 {configuration options: good value for "width"} -body { .c configure -width 402 .c cget -width -} -result {402} +} -result 402 test canvas-1.43 {configuration options: bad value for "width"} -body { .c configure -width xyz } -returnCodes error -result {bad screen distance "xyz"} @@ -227,6 +227,16 @@ test canvas-2.4 {CanvasWidgetCmd, xview option} -constraints nonPortable -body { update lappend x [.c xview] } -result {{0.6 0.9} {0.66 0.96}} +test canvas-2.5 {CanvasWidgetCmd, raise/lower option, no error on non-existing tags} -setup { + .c create line 0 0 10 10 -tags aline +} -body { + .c raise aline noline + .c raise bline aline + .c lower aline noline + .c lower bline aline +} -cleanup { + .c delete aline +} -result {} catch {destroy .c} # Canvas used in 3.* test cases @@ -340,8 +350,26 @@ test canvas-8.1 {canvas arc bbox} -setup { set coordBox [.c bbox arc2] .c create arc 300 10 500 210 -start 10 -extent 50 -style pieslice -tags arc3 set pieBox [.c bbox arc3] - list $arcBox $coordBox $pieBox -} -result {{48 21 100 94} {248 21 300 94} {398 21 500 112}} + .c create arc 100 200 300 200 -height [expr {(1-0.5*sqrt(3))*200}] -style arc -tags arc4 + set arcSegBox [.c bbox arc4] + list $arcBox $coordBox $pieBox $arcSegBox +} -result {{48 21 100 94} {248 21 300 94} {398 21 500 112} {98 171 302 202}} +test canvas-8.2 {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} test canvas-9.1 {canvas id creation and deletion} -setup { catch {destroy .c} @@ -572,7 +600,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 @@ -729,7 +757,7 @@ test canvas-15.19 "basic coords check: centimeters are larger than pixels" -setu } -body { set id [.c create rect 0 0 1cm 1cm] expr {[lindex [.c coords $id] 2]>1} -} -result {1} +} -result 1 test canvas-15.20 {bug [237971ce]} -setup { destroy .c canvas .c @@ -1008,6 +1036,277 @@ test canvas-20.3 {tag deletion - all tags match} -setup { destroy .c } -result {{tagA tagA tagA tagA tagA tagA} {}} +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}} + +# Procedure used in test cases 23.1 23.2 23.3 +proc matchPixels {pixels expected} { + set matched 1 + foreach pline $pixels eline $expected { + foreach ppixel $pline epixel $eline { + if {$ppixel != $epixel} { + set matched 0 + break + } + } + } + return $matched +} + +test canvas-23.1 {canvas image} -setup { + canvas .c + image create photo testimage +} -body { + .c configure -background #c0c0c0 -scrollregion {0 0 9 9} + .c create rectangle 0 0 0 9 -fill #000080 -outline #000080 + .c image testimage + matchPixels [testimage data] { \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0}} +} -cleanup { + destroy .c + image delete testimage +} -result 1 + +test canvas-23.2 {canvas image with subsample} -setup { + canvas .c + image create photo testimage +} -body { + .c configure -background #c0c0c0 -scrollregion {0 0 9 9} + .c create rectangle 0 0 1 9 -fill #008000 -outline #008000 + .c image testimage 2 + matchPixels [testimage data] { \ + {#008000 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#008000 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#008000 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#008000 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#008000 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0}} +} -cleanup { + destroy .c + image delete testimage +} -result 1 + +test canvas-23.3 {canvas image with subsample and zoom} -setup { + canvas .c + image create photo testimage +} -body { + .c configure -background #c0c0c0 -scrollregion {0 0 9 9} + .c create rectangle 0 0 9 0 -fill #800000 -outline #800000 + .c image testimage 1 2 + matchPixels [testimage data] { \ + {#800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000} \ + {#800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \ + {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0}} +} -cleanup { + destroy .c + image delete testimage +} -result 1 + # cleanup imageCleanup cleanupTests diff --git a/tests/choosedir.test b/tests/choosedir.test index f67a721..7e66756 100644 --- a/tests/choosedir.test +++ b/tests/choosedir.test @@ -1,8 +1,8 @@ # This file is a Tcl script to test out Tk's "tk_chooseDir" and # It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -26,7 +26,7 @@ proc ToEnterDirsByKey {parent dirs} { proc PressButton {btn} { event generate $btn <Enter> - event generate $btn <1> -x 5 -y 5 + event generate $btn <Button-1> -x 5 -y 5 event generate $btn <ButtonRelease-1> -x 5 -y 5 } @@ -68,7 +68,7 @@ proc SendButtonPress {parent btn type} { event generate $w <Enter> focus $w event generate $button <Enter> - event generate $w <KeyPress> -keysym Return + event generate $w <Key> -keysym Return } } diff --git a/tests/clipboard.test b/tests/clipboard.test index 7c1a506..aa8f148 100644 --- a/tests/clipboard.test +++ b/tests/clipboard.test @@ -2,8 +2,8 @@ # especially the "clipboard" command. It is organized in the standard # fashion for Tcl tests. # -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. # diff --git a/tests/clrpick.test b/tests/clrpick.test index 747a1c4..84b883e 100644 --- a/tests/clrpick.test +++ b/tests/clrpick.test @@ -1,8 +1,8 @@ # This file is a Tcl script to test out Tk's "tk_chooseColor" command. # It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -99,7 +99,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 } @@ -139,7 +139,7 @@ proc SendButtonPress {parent btn type} { event generate $w <Enter> focus $w event generate $button <Enter> - event generate $w <KeyPress> -keysym Return + event generate $w <Key> -keysym Return } } diff --git a/tests/cmds.test b/tests/cmds.test index caf5afe..3ccd587 100644 --- a/tests/cmds.test +++ b/tests/cmds.test @@ -1,8 +1,8 @@ # This file is a Tcl script to test the procedures in the file # tkCmds.c. It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/color.test b/tests/color.test index 1e99a7d..798e6b9 100644 --- a/tests/color.test +++ b/tests/color.test @@ -1,8 +1,8 @@ # This file is a Tcl script to test out the procedures in the file # tkColor.c. It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1995-1998 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/config.test b/tests/config.test index 9fd048a..ff06a22 100644 --- a/tests/config.test +++ b/tests/config.test @@ -2,8 +2,8 @@ # which comprise the new new option configuration system. It is # organized in the standard "white-box" fashion for Tcl tests. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -235,7 +235,7 @@ test config-4.2 {DoObjConfig - boolean} -constraints testobjconfig -setup { .foo cget -boolean } -cleanup { killTables -} -returnCodes ok -result {0} +} -returnCodes ok -result 0 test config-4.3 {DoObjConfig - boolean} -constraints testobjconfig -setup { catch {rename .foo {}} } -body { @@ -259,7 +259,7 @@ test config-4.5 {DoObjConfig - boolean} -constraints testobjconfig -setup { .foo cget -boolean } -cleanup { killTables -} -returnCodes ok -result {1} +} -returnCodes ok -result 1 test config-4.6 {DoObjConfig - boolean} -constraints testobjconfig -setup { catch {rename .foo {}} } -body { @@ -287,7 +287,7 @@ test config-4.8 {DoObjConfig - boolean internal value} -constraints { .foo cget -boolean } -cleanup { killTables -} -result {0} +} -result 0 test config-4.9 {DoObjConfig - integer} -constraints testobjconfig -setup { catch {rename .foo {}} @@ -303,7 +303,7 @@ test config-4.10 {DoObjConfig - integer} -constraints testobjconfig -setup { .foo cget -integer } -cleanup { killTables -} -returnCodes ok -result {3} +} -returnCodes ok -result 3 test config-4.11 {DoObjConfig - integer} -constraints testobjconfig -setup { catch {rename .foo {}} } -body { @@ -333,7 +333,7 @@ test config-4.13 {DoObjConfig - integer internal value} -constraints { .foo cget -integer } -cleanup { killTables -} -result {421} +} -result 421 test config-4.14 {DoObjConfig - double} -constraints testobjconfig -setup { catch {rename .foo {}} @@ -472,7 +472,7 @@ test config-4.30 {DoObjConfig - new string table} -constraints { .foo configure -stringtable three } -cleanup { killTables -} -returnCodes ok -result {16} +} -returnCodes ok -result 16 test config-4.31 {DoObjConfig - new string table} -constraints { testobjconfig } -body { @@ -564,7 +564,7 @@ test config-4.42 {DoObjConfig - getting rid of old color} -constraints { .foo configure -color #444444 } -cleanup { killTables -} -returnCodes ok -result {32} +} -returnCodes ok -result 32 test config-4.43 {DoObjConfig - getting rid of old color} -constraints { testobjconfig } -body { @@ -607,7 +607,7 @@ test config-4.47 {DoObjConfig - new font} -constraints testobjconfig -setup { .foo configure -font {Helvetica 72} } -cleanup { killTables -} -returnCodes ok -result {64} +} -returnCodes ok -result 64 test config-4.48 {DoObjConfig - new font} -constraints testobjconfig -setup { catch {rename .foo {}} } -body { @@ -668,7 +668,7 @@ test config-4.55 {DoObjConfig - new bitmap} -constraints testobjconfig -body { .foo configure -bitmap gray50 } -cleanup { killTables -} -returnCodes ok -result {128} +} -returnCodes ok -result 128 test config-4.56 {DoObjConfig - new bitmap} -constraints testobjconfig -body { testobjconfig alltypes .foo -bitmap gray75 .foo configure -bitmap gray50 @@ -751,7 +751,7 @@ test config-4.67 {DoObjConfig - getting rid of old border} -constraints { .foo configure -border #444444 } -cleanup { killTables -} -returnCodes ok -result {256} +} -returnCodes ok -result 256 test config-4.68 {DoObjConfig - getting rid of old border} -constraints { testobjconfig } -body { @@ -793,7 +793,7 @@ test config-4.73 {DoObjConfig - new relief} -constraints testobjconfig -body { .foo configure -relief flat } -cleanup { killTables -} -returnCodes ok -result {512} +} -returnCodes ok -result 512 test config-4.74 {DoObjConfig - new relief} -constraints testobjconfig -body { testobjconfig alltypes .foo -relief raised .foo configure -relief flat @@ -838,7 +838,7 @@ test config-4.80 {DoObjConfig - new cursor} -constraints testobjconfig -body { .foo configure -cursor arrow } -cleanup { killTables -} -returnCodes ok -result {1024} +} -returnCodes ok -result 1024 test config-4.81 {DoObjConfig - new cursor} -constraints testobjconfig -body { testobjconfig alltypes .foo -cursor xterm .foo configure -cursor arrow @@ -878,7 +878,7 @@ test config-4.86 {DoObjConfig - new justify} -constraints testobjconfig -body { .foo configure -justify right } -cleanup { killTables -} -returnCodes ok -result {2048} +} -returnCodes ok -result 2048 test config-4.87 {DoObjConfig - new justify} -constraints testobjconfig -body { testobjconfig alltypes .foo -justify left .foo configure -justify right @@ -918,7 +918,7 @@ test config-4.92 {DoObjConfig - new anchor} -constraints testobjconfig -body { .foo configure -anchor n } -cleanup { killTables -} -returnCodes ok -result {4096} +} -returnCodes ok -result 4096 test config-4.93 {DoObjConfig - new anchor} -constraints testobjconfig -body { testobjconfig alltypes .foo -anchor e .foo configure -anchor n @@ -946,7 +946,7 @@ test config-4.96 {DoObjConfig - pixel} -constraints testobjconfig -body { .foo cget -pixel } -cleanup { killTables -} -returnCodes ok -result {42} +} -returnCodes ok -result 42 test config-4.97 {DoObjConfig - invalid pixel} -constraints testobjconfig -body { testobjconfig alltypes .foo -pixel foo } -cleanup { @@ -957,7 +957,7 @@ test config-4.98 {DoObjConfig - new pixel} -constraints testobjconfig -body { .foo configure -pixel 3c } -cleanup { killTables -} -returnCodes ok -result {8192} +} -returnCodes ok -result 8192 test config-4.99 {DoObjConfig - new pixel} -constraints testobjconfig -body { testobjconfig alltypes .foo -pixel 42m .foo configure -pixel 3c @@ -976,7 +976,7 @@ test config-4.100 {DoObjConfig - pixel internal value} -constraints { expr {$screenW eq $result} } -cleanup { killTables -} -result {1} +} -result 1 test config-4.101 {DoObjConfig - window} -constraints testobjconfig -body { toplevel .bar @@ -1017,7 +1017,7 @@ test config-4.106 {DoObjConfig - new window} -constraints testobjconfig -body { .foo configure -window .blamph } -cleanup { killTables -} -returnCodes ok -result {0} +} -returnCodes ok -result 0 test config-4.107 {DoObjConfig - new window} -constraints testobjconfig -body { toplevel .bar toplevel .blamph @@ -1258,7 +1258,7 @@ test config-7.11 {Tk_SetOptions - synonym name in error message} -constraints { ".a configure -synonym bogus"} test config-7.12 {Tk_SetOptions - returning mask} -constraints testobjconfig -body { format %x [.a configure -color red -int 7 -relief raised -double 3.14159] -} -result {226} +} -result 226 test config-7.13 {Tk_SetOptions - error in DoObjConfig with custom option} -constraints { testobjconfig } -body { @@ -1304,7 +1304,7 @@ test config-8.3 {Tk_RestoreSavedOptions - freeing object memory} -constraints { .a csave -color green -color black -color blue -color #ffff00 -color #ff00ff } -cleanup { killTables -} -result {32} +} -result 32 test config-8.4 {Tk_RestoreSavedOptions - boolean internal form} -constraints { testobjconfig } -body { @@ -1321,7 +1321,7 @@ test config-8.5 {Tk_RestoreSavedOptions - boolean internal form} -constraints { .a cget -boolean } -cleanup { killTables -} -result {1} +} -result 1 test config-8.6 {Tk_RestoreSavedOptions - integer internal form} -constraints { testobjconfig } -body { @@ -1338,7 +1338,7 @@ test config-8.7 {Tk_RestoreSavedOptions - integer internal form} -constraints { .a cget -integer } -cleanup { killTables -} -result {148962237} +} -result 148962237 test config-8.8 {Tk_RestoreSavedOptions - double internal form} -constraints { testobjconfig } -body { @@ -1620,11 +1620,11 @@ if {[testConstraint testobjconfig]} { test config-12.1 {GetObjectForOption - boolean} -constraints testobjconfig -body { .a configure -boolean 0 .a cget -boolean -} -result {0} +} -result 0 test config-12.2 {GetObjectForOption - integer} -constraints testobjconfig -body { .a configure -integer 1247 .a cget -integer -} -result {1247} +} -result 1247 test config-12.3 {GetObjectForOption - double} -constraints testobjconfig -body { .a configure -double -88.82 .a cget -double @@ -1680,7 +1680,7 @@ test config-12.13 {GetObjectForOption - anchor} -constraints testobjconfig -body test config-12.14 {GetObjectForOption - pixels} -constraints testobjconfig -body { .a configure -pixel 193.2 .a cget -pixel -} -result {193} +} -result 193 test config-12.15 {GetObjectForOption - window} -constraints testobjconfig -body { .a configure -window .a .a cget -window diff --git a/tests/constraints.tcl b/tests/constraints.tcl index ee073cf..a89605a 100644 --- a/tests/constraints.tcl +++ b/tests/constraints.tcl @@ -5,7 +5,7 @@ if {[namespace exists tk::test]} { return } -package require Tk +package require tk tk appname tktest wm title . tktest # If the main window isn't already mapped (e.g. because the tests are diff --git a/tests/cursor.test b/tests/cursor.test index 8d7ebb0..f84232c 100644 --- a/tests/cursor.test +++ b/tests/cursor.test @@ -2,8 +2,8 @@ # tkCursor.c. It is organized in the standard white-box fashion for # Tcl tests. # -# Copyright (c) 1998 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/dialog.test b/tests/dialog.test index 78b6620..692d928 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 { @@ -36,12 +36,12 @@ test dialog-2.1 {tk_dialog operation} -setup { return $res } -cleanup { destroy .d -} -result {0} +} -result 0 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"]] @@ -51,7 +51,7 @@ test dialog-2.2 {tk_dialog operation} -setup { return $res } -cleanup { destroy .d -} -result {1} +} -result 1 test dialog-2.3 {tk_dialog operation} -body { set x [after 5000 [list set tk::Priv(button) "no response"]] after 100 destroy .d @@ -60,7 +60,7 @@ test dialog-2.3 {tk_dialog operation} -body { return $res } -cleanup { destroy .b -} -result {-1} +} -result -1 cleanupTests return diff --git a/tests/earth.gif b/tests/earth.gif Binary files differindex 2c229eb..d667244 100644 --- a/tests/earth.gif +++ b/tests/earth.gif diff --git a/tests/embed.test b/tests/embed.test index 1fe73ef..92b8be9 100644 --- a/tests/embed.test +++ b/tests/embed.test @@ -1,7 +1,7 @@ # This file is a Tcl script to test out embedded Windows. # -# Copyright (c) 1996-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/entry.test b/tests/entry.test index ef70a9e..aef509c 100644 --- a/tests/entry.test +++ b/tests/entry.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test entry widgets in Tk. It is # organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -632,6 +632,23 @@ test entry-1.58 {configuration option: "xscrollcommand" for entry} -setup { destroy .e } -result {Some command} +test entry-1.59 {configuration option: "-placeholder"} -setup { + pack [entry .e] +} -body { + .e configure -placeholder {Some text} + .e cget -placeholder +} -cleanup { + destroy .e +} -result {Some text} + +test entry-1.60 {configuration option: "-placeholderforeground"} -setup { + pack [entry .e] +} -body { + .e configure -placeholder {Some text} -placeholderforeground red + .e cget -placeholderforeground +} -cleanup { + destroy .e +} -result {red} test entry-2.1 {Tk_EntryCmd procedure} -body { @@ -736,7 +753,7 @@ test entry-3.7 {EntryWidgetCmd procedure, "bbox" widget command} -constraints { update } -body { # Tcl_UtfAtIndex(): utf at end - .e insert 0 "ab\u4e4e" + .e insert 0 "ab乎" .e bbox end } -cleanup { destroy .e @@ -749,7 +766,7 @@ test entry-3.8 {EntryWidgetCmd procedure, "bbox" widget command} -constraints { update } -body { # Tcl_UtfAtIndex(): utf before index - .e insert 0 "ab\u4e4ec" + .e insert 0 "ab乎c" .e bbox 3 } -cleanup { destroy .e @@ -771,7 +788,7 @@ test entry-3.10 {EntryWidgetCmd procedure, "bbox" widget command} -constraints { pack .e update } -body { - .e insert 0 "abcdefghij\u4e4eklmnop" + .e insert 0 "abcdefghij乎klmnop" list [.e bbox 0] [.e bbox 1] [.e bbox 10] [.e bbox end] } -cleanup { destroy .e @@ -813,7 +830,7 @@ test entry-3.15 {EntryWidgetCmd procedure, "configure" widget command} -setup { llength [.e configure] } -cleanup { destroy .e -} -result 36 +} -result 38 test entry-3.16 {EntryWidgetCmd procedure, "configure" widget command} -setup { entry .e } -body { @@ -885,20 +902,20 @@ test entry-3.24 {EntryWidgetCmd procedure, "delete" widget command} -setup { set x {} } -body { # UTF - .e insert end "01234\u4e4e67890" + .e insert end "01234乎67890" .e delete 6 lappend x [.e get] .e delete 0 end - .e insert end "012345\u4e4e7890" + .e insert end "012345乎7890" .e delete 6 lappend x [.e get] .e delete 0 end - .e insert end "0123456\u4e4e890" + .e insert end "0123456乎890" .e delete 6 lappend x [.e get] } -cleanup { destroy .e -} -result [list "01234\u4e4e7890" "0123457890" "012345\u4e4e890"] +} -result [list "01234乎7890" "0123457890" "012345乎890"] test entry-3.25 {EntryWidgetCmd procedure, "delete" widget command} -setup { entry .e pack .e @@ -1002,7 +1019,7 @@ test entry-3.35 {EntryWidgetCmd procedure, "index" widget command} -setup { update } -body { # UTF - .e insert 0 abc\u4e4e\u0153def + .e insert 0 abc乎œdef list [.e index 3] [.e index 4] [.e index end] } -cleanup { destroy .e @@ -1423,7 +1440,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 @@ -1434,7 +1451,7 @@ test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} -setup { .e xview scroll gorp units } -cleanup { destroy .e -} -returnCodes error -result {expected integer but got "gorp"} +} -returnCodes error -result {expected floating-point number but got "gorp"} test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} -setup { entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e @@ -1500,7 +1517,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 @@ -1544,7 +1561,7 @@ test entry-3.86 {EntryWidgetCmd procedure, "xview" widget command} -setup { } -body { .e insert end "This is quite a long text string, so long that it " .e insert end "runs off the end of the window quite a bit." - .e insert 10 \u4e4e + .e insert 10 乎 update # UTF # If Tcl_NumUtfChars wasn't used, wrong answer would be: @@ -2323,10 +2340,20 @@ test entry-8.18 {DeleteChars procedure} -constraints failsOnUbuntuNoXft -setup { .e insert 0 "xyzzy" update .e delete 2 4 - winfo reqwidth .e -} -cleanup { - destroy .e -} -result 31 + # To check that deletion actually happened we measure the new width + # of the widget, based on the measuring width of the remaining text ("xyy") + # in the widget. For that purpose we have to mirror the code in tkEntry.c + # for computation of the reqwidth + # note: XPAD corresponds to the hardcoded #define XPAD 1 + set XPAD 1 + set expected [expr { [font measure [.e cget -font] "xyy"] \ + + 2 * ( [.e cget -borderwidth] + \ + [.e cget -highlightthickness] + $XPAD ) } ] + expr {[winfo reqwidth .e] == $expected} +} -cleanup { + destroy .e + unset XPAD expected +} -result 1 test entry-9.1 {EntryValueChanged procedure} -setup { unset -nocomplain x @@ -3479,7 +3506,7 @@ test entry-20.7 {widget deletion with textvariable active} -body { # SF bugs 607390 and 617446 set FOO init entry .e -textvariable FOO -validate all \ - -vcmd {%W configure -bg white; format 1} + -validatecommand {%W configure -bg white; format 1} bind .e <Destroy> { set FOO hello } destroy .e winfo exists .e diff --git a/tests/event.test b/tests/event.test index ea190de..03405dd 100644 --- a/tests/event.test +++ b/tests/event.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test the code in tkEvent.c. It is # organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -20,57 +20,10 @@ namespace import -force tcltest::test proc _init_keypress_lookup {} { global keypress_lookup - scan A %c start - scan Z %c finish - - for {set i $start} {$i <= $finish} {incr i} { - set l [format %c $i] - set keypress_lookup($l) $l - } - - scan a %c start - scan z %c finish - - for {set i $start} {$i <= $finish} {incr i} { - set l [format %c $i] - set keypress_lookup($l) $l - } - - scan 0 %c start - scan 9 %c finish - - for {set i $start} {$i <= $finish} {incr i} { - set l [format %c $i] - set keypress_lookup($l) $l - } - - # Most punctuation - array set keypress_lookup { - ! exclam - % percent - & ampersand - ( parenleft - ) parenright - * asterisk - + plus - , comma - - minus - . period - / slash - : colon - < less - = equal - > greater - ? question - @ at - ^ asciicircum - _ underscore - | bar - ~ asciitilde - ' apostrophe - } # Characters with meaning to Tcl... array set keypress_lookup [list \ + - minus \ + > greater \ \" quotedbl \ \# numbersign \ \$ dollar \ @@ -81,6 +34,7 @@ proc _init_keypress_lookup {} { \{ braceleft \ \} braceright \ " " space \ + \xA0 nobreakspace \ "\n" Return \ "\t" Tab] } @@ -88,8 +42,8 @@ proc _init_keypress_lookup {} { # Lookup an event in the keypress table. # For example: # Q -> Q -# . -> period -# / -> slash +# ; -> semicolon +# > -> greater # Delete -> Delete # Escape -> Escape @@ -111,7 +65,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 +78,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 +148,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 } @@ -269,7 +223,7 @@ test event-2.3(keypress) {type into entry widget, triple click, hit Delete key, event generate $e <Enter> for {set i 0} {$i < 3} {incr i} { _pause 100 - event generate $e <ButtonPress-1> + event generate $e <Button-1> _pause 100 event generate $e <ButtonRelease-1> } @@ -323,7 +277,7 @@ test event-2.6(keypress) {type into text widget, triple click, event generate $e <Enter> for {set i 0} {$i < 3} {incr i} { _pause 100 - event generate $e <ButtonPress-1> + event generate $e <Button-1> _pause 100 event generate $e <ButtonRelease-1> } @@ -355,7 +309,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] @@ -381,7 +335,7 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests # Now click and click and drag to the left, over "Tcl/Tk selection" - event generate $e <ButtonPress-1> -x $current_x -y $current_y + event generate $e <Button-1> -x $current_x -y $current_y while {[$e compare $current >= [list $anchor - 4 char]]} { foreach {current_x current_y} [_text_ind_to_x_y $e $current] break @@ -422,7 +376,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] @@ -448,7 +402,7 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests # Now click and click and drag to the left, over "Tcl/Tk selection" - event generate $e <ButtonPress-1> -x $current_x -y $current_y + event generate $e <Button-1> -x $current_x -y $current_y while {$current >= ($anchor - 4)} { foreach {current_x current_y} [_text_ind_to_x_y $e $current] break @@ -487,11 +441,11 @@ test event-4.1(double-click-drag) {click down, click up, click down again, # Click down, release, then click down again event generate $e <Enter> - event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y + event generate $e <Button-1> -x $anchor_x -y $anchor_y _pause 50 event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y _pause 50 - event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y + event generate $e <Button-1> -x $anchor_x -y $anchor_y _pause 50 # Save the highlighted text @@ -558,11 +512,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] @@ -630,17 +584,17 @@ test event-5.1(triple-click-drag) {Triple click and drag across lines in a event generate $e <Enter> - event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y + event generate $e <Button-1> -x $anchor_x -y $anchor_y _pause 50 event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y _pause 50 - event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y + event generate $e <Button-1> -x $anchor_x -y $anchor_y _pause 50 event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y _pause 50 - event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y + event generate $e <Button-1> -x $anchor_x -y $anchor_y _pause 50 set result [list] @@ -680,7 +634,7 @@ test event-6.1(button-state) {button press in a window that is then } -body { set t [toplevel .t] - event generate $t <ButtonPress-1> + event generate $t <Button-1> destroy $t set t [toplevel .t] set motion nomotion @@ -719,11 +673,11 @@ test event-7.1(double-click) {A double click on a lone character # Double click near left hand egde of the letter A event generate $e <Enter> - event generate $e <ButtonPress-1> -x $left_x -y $left_y + event generate $e <Button-1> -x $left_x -y $left_y _pause 50 event generate $e <ButtonRelease-1> -x $left_x -y $left_y _pause 50 - event generate $e <ButtonPress-1> -x $left_x -y $left_y + event generate $e <Button-1> -x $left_x -y $left_y _pause 50 event generate $e <ButtonRelease-1> -x $left_x -y $left_y _pause 50 @@ -734,18 +688,18 @@ test event-7.1(double-click) {A double click on a lone character # Clear selection by clicking at 0,0 - event generate $e <ButtonPress-1> -x 0 -y 0 + event generate $e <Button-1> -x 0 -y 0 _pause 50 event generate $e <ButtonRelease-1> -x 0 -y 0 _pause 50 # Double click near right hand edge of the letter A - event generate $e <ButtonPress-1> -x $right_x -y $right_y + event generate $e <Button-1> -x $right_x -y $right_y _pause 50 event generate $e <ButtonRelease-1> -x $right_x -y $right_y _pause 50 - event generate $e <ButtonPress-1> -x $right_x -y $right_y + event generate $e <Button-1> -x $right_x -y $right_y _pause 50 event generate $e <ButtonRelease-1> -x $right_x -y $right_y _pause 50 @@ -785,11 +739,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 @@ -800,18 +754,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 @@ -834,7 +788,7 @@ test event-8 {event generate with keysyms corresponding to set e [entry $t.e] pack $e tkwait visibility $e - bind $e <KeyPress> {lappend res keycode: %k keysym: %K} + bind $e <Key> {lappend res keycode: %k keysym: %K} focus -force $e update event generate $e <diaeresis> diff --git a/tests/filebox.test b/tests/filebox.test index fdb5614..d7d051e 100644 --- a/tests/filebox.test +++ b/tests/filebox.test @@ -2,8 +2,8 @@ # "tk_getSaveFile" commands. It is organized in the standard fashion # for Tcl tests. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -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 5a13d91..1a318c3 100644 --- a/tests/focus.test +++ b/tests/focus.test @@ -2,8 +2,8 @@ # other procedures in the file tkFocus.c. It is organized in the # standard fashion for Tcl tests. # -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -67,7 +67,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 @@ -319,7 +319,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 { @@ -620,7 +620,7 @@ test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} -constr destroy .t bind all <FocusIn> {} bind all <FocusOut> {} -bind all <KeyPress> {} +bind all <Key> {} fixfocus diff --git a/tests/focusTcl.test b/tests/focusTcl.test index 0e457a6..6cfc230 100644 --- a/tests/focusTcl.test +++ b/tests/focusTcl.test @@ -3,8 +3,8 @@ # tk_focusPrev, among other things. This file is organized in the # standard fashion for Tcl tests. # -# Copyright (c) 1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/font.test b/tests/font.test index 6995a7b..d490c64 100644 --- a/tests/font.test +++ b/tests/font.test @@ -2,8 +2,8 @@ # plus the procedures in tkFont.c. It is organized in the # standard white-box fashion for Tcl tests. # -# Copyright (c) 1996-1998 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996-1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -13,7 +13,7 @@ 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]}] testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] testConstraint failsOnUbuntuNoXft [expr {[testConstraint failsOnUbuntu] || (![catch {tk::pkgconfig get fontsystem} fs] && ($fs eq "xft"))}] @@ -116,21 +116,21 @@ test font-4.1 {font command: actual: arguments} -body { test font-4.2 {font command: actual: arguments} -body { # (objc < 3) font actual -} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"} +} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?-option? ?--? ?char?"} test font-4.3 {font command: actual: arguments} -body { # (objc - skip > 4) when skip == 0 font actual xyz abc def -} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"} +} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?-option? ?--? ?char?"} test font-4.4 {font command: actual: displayof specified, so skip to next} -body { catch {font actual xyz -displayof . -size} -} -result {0} +} -result 0 test font-4.5 {font command: actual: displayof specified, so skip to next} -body { lindex [font actual xyz -displayof .] 0 } -result {-family} test font-4.6 {font command: actual: arguments} -body { # (objc - skip > 4) when skip == 2 font actual xyz -displayof . abc def -} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"} +} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?-option? ?--? ?char?"} test font-4.7 {font command: actual: arguments} -constraints noExceed -body { # (tkfont == NULL) font actual "\{xyz" @@ -146,25 +146,25 @@ test font-4.9 {font command: actual} -constraints {unix noExceed failsOnUbuntu} test font-4.10 {font command: actual} -constraints win -body { # (objc > 3) so objPtr = objv[3 + skip] font actual {-family times} -family -} -result {Times New Roman} +} -result {times} test font-4.11 {font command: bad option} -body { font actual xyz -style } -returnCodes error -result {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike} test font-4.12 {font command: actual} -body { - font actual {-family times} -- \ud800 + font actual {-family times} -- \uD800 } -match glob -result {*} test font-4.13 {font command: actual} -body { - font actual {-family times} -- \udc00 + font actual {-family times} -- \uDC00 } -match glob -result {*} -test font-4.14 {font command: actual} -constraints win -body { +test font-4.14 {font command: actual} -constraints {utfcompat win} -body { font actual {-family times} -family -- \uD800\uDC00 -} -result {Times New Roman} +} -result {times} test font-4.15 {font command: actual} -body { - font actual {-family times} -- \udc00\ud800 + font actual {-family times} -- \uDC00\uD800 } -returnCodes 1 -match glob -result {expected a single character but got "*"} test font-4.16 {font command: actual} -constraints {fullutf win} -body { font actual {-family times} -family -- \U10000 -} -result {Times New Roman} +} -result {times} test font-5.1 {font command: configure} -body { @@ -432,11 +432,11 @@ test font-10.2 {font command: metrics: arguments} -body { test font-10.3 {font command: metrics: arguments} -body { # (objc < 3) font metrics -} -returnCodes error -result {wrong # args: should be "font metrics font ?-displayof window? ?option?"} +} -returnCodes error -result {wrong # args: should be "font metrics font ?-displayof window? ?-option?"} test font-10.4 {font command: metrics: arguments} -body { # (objc - skip) > 4) when skip == 0 font metrics xyz abc def -} -returnCodes error -result {wrong # args: should be "font metrics font ?-displayof window? ?option?"} +} -returnCodes error -result {wrong # args: should be "font metrics font ?-displayof window? ?-option?"} test font-10.5 {font command: metrics: arguments} -body { # (objc - skip) > 4) when skip == 2 font metrics xyz -displayof . abc @@ -538,7 +538,7 @@ test font-12.2 {UpdateDependantFonts procedure: pings the widgets} -setup { } -cleanup { destroy .t.f font delete xyz -} -result {1} +} -result 1 test font-13.1 {CreateNamedFont: new named font} -setup { @@ -1683,14 +1683,14 @@ destroy .t.f pack [label .t.f] update test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} -body { - .t.f config -text "foo" -under -1 + .t.f config -text "foo" -underline -1 } -result {} test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} -body { .t.f config -text "000 00000" -wrap [expr $ax*7] -under 10 } -result {} test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} -body { .t.f config -text "000 00000" -wrap [expr $ax*7] -under 5 - .t.f config -wrap -1 -under -1 + .t.f config -wrap -1 -underline -1 } -result {} destroy .t.f @@ -1705,7 +1705,7 @@ update test font-28.1 {Tk_PointToChar procedure: above all lines} -body { csetup "000" .t.c index text @-1,0 -} -result {0} +} -result 0 test font-28.2 {Tk_PointToChar procedure: no chars} -body { # After fixing the following bug: # @@ -1717,46 +1717,46 @@ test font-28.2 {Tk_PointToChar procedure: no chars} -body { csetup "" .t.c index text @100,100 -} -result {0} +} -result 0 test font-28.3 {Tk_PointToChar procedure: loop test} -body { csetup "000\n000\n000\n000" .t.c index text @10000,0 -} -result {3} +} -result 3 test font-28.4 {Tk_PointToChar procedure: intersect line} -body { csetup "000\n000\n000" .t.c index text @0,$ay -} -result {4} +} -result 4 test font-28.5 {Tk_PointToChar procedure: to the left of all chunks} -body { csetup "000\n000\n000" .t.c index text @-100,$ay -} -result {4} +} -result 4 test font-28.6 {Tk_PointToChar procedure: past any possible chunk} -body { csetup "000\n000\n000" .t.c index text @100000,$ay -} -result {7} +} -result 7 test font-28.7 {Tk_PointToChar procedure: which chunk on this line} -body { csetup "000\n000\t000\t000\n000" .t.c index text @[expr $ax*2],$ay -} -result {6} +} -result 6 test font-28.8 {Tk_PointToChar procedure: which chunk on this line} -body { csetup "000\n000\t000\t000\n000" .t.c index text @[expr $ax*10],$ay -} -result {10} +} -result 10 test font-28.9 {Tk_PointToChar procedure: in special chunk} -body { csetup "000\n000\t000\t000\n000" .t.c index text @[expr $ax*6],$ay -} -result {7} +} -result 7 test font-28.10 {Tk_PointToChar procedure: past all chars in chunk} -body { csetup "000 0000000" .t.c itemconfig text -width [expr $ax*5] set x [.t.c index text @[expr $ax*5],0] .t.c itemconfig text -width 0 return $x -} -result {3} +} -result 3 test font-28.11 {Tk_PointToChar procedure: below all chunks} -body { csetup "000 0000000" .t.c index text @0,1000000 -} -result {11} +} -result 11 destroy .t.c @@ -1803,7 +1803,7 @@ test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} -body { return $x } -cleanup { bind all <Enter> {} -} -result {0} +} -result 0 test font-30.2 {Tk_DistanceToTextLayout procedure: loop multiple} -body { csetup "000\n000\n000" .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} @@ -1813,7 +1813,7 @@ test font-30.2 {Tk_DistanceToTextLayout procedure: loop multiple} -body { return $x } -cleanup { bind all <Enter> {} -} -result {5} +} -result 5 test font-30.3 {Tk_DistanceToTextLayout procedure: loop to end} -body { csetup "000\n0\n000" .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} @@ -1833,7 +1833,7 @@ test font-30.4 {Tk_DistanceToTextLayout procedure: hit a special char (tab)} -bo return $x } -cleanup { bind all <Enter> {} -} -result {3} +} -result 3 test font-30.5 {Tk_DistanceToTextLayout procedure: ignore newline} -body { csetup "000\n0\n000" .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} @@ -1886,7 +1886,7 @@ test font-30.9 {Tk_DistanceToTextLayout procedure: inside line} -body { return $x } -cleanup { bind all <Enter> {} -} -result {0} +} -result 0 test font-30.10 {Tk_DistanceToTextLayout procedure: above line} -body { csetup "0\n000" .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} @@ -1916,7 +1916,7 @@ test font-30.12 {Tk_DistanceToTextLayout procedure: in line} -body { return $x } -cleanup { bind all <Enter> {} -} -result {3} +} -result 3 .t.c itemconfig text -justify left test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} -body { csetup "000" @@ -1927,7 +1927,7 @@ test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} -body { return $x } -cleanup { bind all <Enter> {} -} -result {1} +} -result 1 destroy .t.c @@ -1973,7 +1973,7 @@ test font-31.7 {TkIntersectAngledTextLayout procedure: bug [514ff64dd0]} -body { # The text has been rotated 90 degrees around it's upper left corner, # so it's enough to check with a small rectangle with small negative y coords. .t.c find overlapping 5 -7 7 -5 -} -result {1} +} -result 1 destroy .t.c @@ -2184,7 +2184,7 @@ test font-37.3 {GetAttributeInfo procedure: size} -setup { font config xyz -size } -cleanup { font delete xyz -} -result {20} +} -result 20 test font-37.4 {GetAttributeInfo procedure: weight} -setup { catch {font delete xyz} set x {} @@ -2211,7 +2211,7 @@ test font-37.6 {GetAttributeInfo procedure: underline} -setup { font config xyz -underline } -cleanup { font delete xyz -} -result {1} +} -result 1 test font-37.7 {GetAttributeInfo procedure: overstrike} -setup { catch {font delete xyz} set x {} @@ -2220,7 +2220,7 @@ test font-37.7 {GetAttributeInfo procedure: overstrike} -setup { font config xyz -overstrike } -cleanup { font delete xyz -} -result {0} +} -result 0 # In tests below, one field is set to "xyz" so that font name doesn't @@ -2347,7 +2347,7 @@ test font-44.1 {TkFontGetPixels: size < 0} -constraints failsOnUbuntu -setup { font actual {times -12} -size } -cleanup { tk scaling $oldscale -} -result {24} +} -result 24 test font-44.2 {TkFontGetPoints: size >= 0} -constraints {noExceed failsOnUbuntuNoXft} -setup { set oldscale [tk scaling] } -body { @@ -2355,7 +2355,7 @@ test font-44.2 {TkFontGetPoints: size >= 0} -constraints {noExceed failsOnUbuntu font actual {times 12} -size } -cleanup { tk scaling $oldscale -} -result {12} +} -result 12 test font-45.1 {TkFontGetAliasList: no match} -body { @@ -2363,7 +2363,7 @@ test font-45.1 {TkFontGetAliasList: no match} -body { } -result [font actual {-size 10} -family] test font-45.2 {TkFontGetAliasList: match} -constraints win -body { font actual {times 10} -family -} -result {Times New Roman} +} -result {times} test font-45.3 {TkFontGetAliasList: match} -constraints {noExceed failsOnUbuntu} -body { if {[font actual {{times new roman} 10} -family] eq "Times New Roman"} { # avoid test failure on systems that have a real "times new roman" font @@ -2372,7 +2372,7 @@ test font-45.3 {TkFontGetAliasList: match} -constraints {noExceed failsOnUbuntu} set res [expr {[font actual {{times new roman} 10} -family] eq \ [font actual {times 10} -family]} ] } -} -result {1} +} -result 1 test font-46.1 {font actual, with character, no option, no --} -body { diff --git a/tests/fontchooser.test b/tests/fontchooser.test index 471ed64..8fb9059 100644 --- a/tests/fontchooser.test +++ b/tests/fontchooser.test @@ -1,6 +1,6 @@ # Test the "tk::fontchooser" command # -# Copyright (c) 2008 Pat Thoyts +# Copyright © 2008 Pat Thoyts package require tcltest 2.2 eval tcltest::configure $argv @@ -82,7 +82,7 @@ test fontchooser-1.7 {tk fontchooser: usage} -returnCodes error -body { test fontchooser-1.8 {tk fontchooser: usage} -returnCodes ok -body { tk fontchooser configure -visible -} -result {0} +} -result 0 test fontchooser-1.9 {tk fontchooser: usage} -returnCodes error -body { tk fontchooser configure -visible 1 @@ -112,7 +112,7 @@ test fontchooser-2.0 {fontchooser -title} -constraints scriptImpl -body { test fontchooser-2.1 {fontchooser -title (cyrillic)} -constraints scriptImpl -body { start { tk::fontchooser::Configure \ - -title "\u041f\u0440\u0438\u0432\u0435\u0442" + -title "Привет" tk::fontchooser::Show } then { @@ -120,7 +120,7 @@ test fontchooser-2.1 {fontchooser -title (cyrillic)} -constraints scriptImpl -bo Click cancel } set x -} -result "\u041f\u0440\u0438\u0432\u0435\u0442" +} -result "Привет" test fontchooser-3.0 {fontchooser -parent} -constraints scriptImpl -body { start { @@ -158,7 +158,7 @@ test fontchooser-4.1 {fontchooser -font} -constraints scriptImpl -body { Click ok } expr {$::testfont ne {}} -} -result {1} +} -result 1 test fontchooser-4.2 {fontchooser -font} -constraints scriptImpl -body { start { @@ -169,7 +169,7 @@ test fontchooser-4.2 {fontchooser -font} -constraints scriptImpl -body { Click ok } expr {$::testfont ne {}} -} -result {1} +} -result 1 test fontchooser-4.3 {fontchooser -font} -constraints scriptImpl -body { start { @@ -180,7 +180,7 @@ test fontchooser-4.3 {fontchooser -font} -constraints scriptImpl -body { Click ok } expr {$::testfont ne {}} -} -result {1} +} -result 1 test fontchooser-4.4 {fontchooser -font} -constraints {scriptImpl failsOnUbuntuNoXft} -body { start { diff --git a/tests/frame.test b/tests/frame.test index 63bb187..d2f9d69 100644 --- a/tests/frame.test +++ b/tests/frame.test @@ -1,20 +1,22 @@ -# 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. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. 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"} @@ -174,7 +195,7 @@ test frame-1.15 {frame configuration options} -body { lindex [.f configure -bd] 4 } -cleanup { .f configure -bd [lindex [.f configure -bd] 3] -} -result {4} +} -result 4 test frame-1.16 {frame configuration options} -body { .f configure -bd badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -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"} @@ -192,7 +213,7 @@ test frame-1.19 {frame configuration options} -body { lindex [.f configure -borderwidth] 4 } -cleanup { .f configure -borderwidth [lindex [.f configure -borderwidth] 3] -} -result {1} +} -result 1 test frame-1.20 {frame configuration options} -body { .f configure -borderwidth badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -210,7 +231,7 @@ test frame-1.23 {frame configuration options} -body { lindex [.f configure -height] 4 } -cleanup { .f configure -height [lindex [.f configure -height] 3] -} -result {100} +} -result 100 test frame-1.24 {frame configuration options} -body { .f configure -height not_a_number } -returnCodes error -result {bad screen distance "not_a_number"} @@ -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"} @@ -237,7 +258,7 @@ test frame-1.29 {frame configuration options} -body { lindex [.f configure -highlightthickness] 4 } -cleanup { .f configure -highlightthickness [lindex [.f configure -highlightthickness] 3] -} -result {6} +} -result 6 test frame-1.30 {frame configuration options} -body { .f configure -highlightthickness badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -246,7 +267,7 @@ test frame-1.31 {frame configuration options} -body { lindex [.f configure -padx] 4 } -cleanup { .f configure -padx [lindex [.f configure -padx] 3] -} -result {3} +} -result 3 test frame-1.32 {frame configuration options} -body { .f configure -padx badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -255,7 +276,7 @@ test frame-1.33 {frame configuration options} -body { lindex [.f configure -pady] 4 } -cleanup { .f configure -pady [lindex [.f configure -pady] 3] -} -result {4} +} -result 4 test frame-1.34 {frame configuration options} -body { .f configure -pady badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -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 @@ -279,15 +300,14 @@ test frame-1.38 {frame configuration options} -body { lindex [.f configure -width] 4 } -cleanup { .f configure -width [lindex [.f configure -width] 3] -} -result {32} +} -result 32 test frame-1.39 {frame configuration options} -body { .f configure -width badValue } -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,28 +493,28 @@ 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"} test frame-2.22 {toplevel configuration options} -body { .t configure -bd 4 lindex [.t configure -bd] 4 -} -result {4} +} -result 4 test frame-2.23 {toplevel configuration options} -body { .t configure -bd badValue } -returnCodes error -result {bad screen distance "badValue"} 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"} test frame-2.26 {toplevel configuration options} -body { .t configure -borderwidth 1.3 lindex [.t configure -borderwidth] 4 -} -result {1} +} -result 1 test frame-2.27 {toplevel configuration options} -body { .t configure -borderwidth badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -529,35 +528,35 @@ test frame-2.29 {toplevel configuration options} -body { test frame-2.30 {toplevel configuration options} -body { .t configure -height 100 lindex [.t configure -height] 4 -} -result {100} +} -result 100 test frame-2.31 {toplevel configuration options} -body { .t configure -height not_a_number } -returnCodes error -result {bad screen distance "not_a_number"} 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"} test frame-2.34 {toplevel configuration options} -body { .t configure -highlightthickness 3 lindex [.t configure -highlightthickness] 4 -} -result {3} +} -result 3 test frame-2.35 {toplevel configuration options} -body { .t configure -highlightthickness badValue } -returnCodes error -result {bad screen distance "badValue"} test frame-2.36 {toplevel configuration options} -body { .t configure -padx 3 lindex [.t configure -padx] 4 -} -result {3} +} -result 3 test frame-2.37 {toplevel configuration options} -body { .t configure -padx badValue } -returnCodes error -result {bad screen distance "badValue"} test frame-2.38 {toplevel configuration options} -body { .t configure -pady 4 lindex [.t configure -pady] 4 -} -result {4} +} -result 4 test frame-2.39 {toplevel configuration options} -body { .t configure -pady badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -565,24 +564,23 @@ 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 -} -result {32} +} -result 32 test frame-2.43 {toplevel configuration options} -body { .t configure -width badValue } -returnCodes error -result {bad screen distance "badValue"} destroy .t - -test frame-3.1 {TkCreateFrame procedure} -body { +test frame-3.1 {TkCreateFrame procedure} -returnCodes error -body { frame -} -returnCodes error -result {wrong # args: should be "frame pathName ?-option value ...?"} +} -result {wrong # args: should be "frame pathName ?-option value ...?"} test frame-3.2 {TkCreateFrame procedure} -setup { - deleteWindows + deleteWindows frame .f } -body { .f configure -class @@ -590,7 +588,7 @@ test frame-3.2 {TkCreateFrame procedure} -setup { deleteWindows } -result {-class class Class Frame Frame} test frame-3.3 {TkCreateFrame procedure} -setup { - deleteWindows + deleteWindows toplevel .t wm geometry .t +0+0 } -body { @@ -599,7 +597,7 @@ test frame-3.3 {TkCreateFrame procedure} -setup { deleteWindows } -result {-class class Class Toplevel Toplevel} test frame-3.4 {TkCreateFrame procedure} -setup { - deleteWindows + deleteWindows } -body { toplevel .t -width 350 -class NewClass -bg black -visual default -height 90 wm geometry .t +0+0 @@ -610,11 +608,10 @@ test frame-3.4 {TkCreateFrame procedure} -setup { } -cleanup { deleteWindows } -result {350 black 90} - # Be sure that the -class, -colormap, and -visual options are processed # before configuring the widget. test frame-3.5 {TkCreateFrame procedure} -setup { - deleteWindows + deleteWindows } -body { option add *NewFrame.background #123456 frame .f -class NewFrame @@ -624,7 +621,7 @@ test frame-3.5 {TkCreateFrame procedure} -setup { option clear } -result {#123456} test frame-3.7 {TkCreateFrame procedure} -setup { - deleteWindows + deleteWindows } -body { option add *NewFrame.background #332211 option add *f.class NewFrame @@ -635,7 +632,7 @@ test frame-3.7 {TkCreateFrame procedure} -setup { option clear } -result {NewFrame #332211} test frame-3.8 {TkCreateFrame procedure} -setup { - deleteWindows + deleteWindows } -body { option add *Silly.background #122334 option add *f.Class Silly @@ -648,7 +645,7 @@ test frame-3.8 {TkCreateFrame procedure} -setup { test frame-3.9 {TkCreateFrame procedure, -use option} -constraints { unix } -setup { - deleteWindows + deleteWindows } -body { toplevel .t -container 1 -width 300 -height 120 wm geometry .t +0+0 @@ -658,11 +655,11 @@ test frame-3.9 {TkCreateFrame procedure, -use option} -constraints { [expr {[winfo rooty .x] - [winfo rooty .t]}] \ [winfo width .t] [winfo height .t] } -cleanup { -# This call to update idletasks was added to prevent a crash that was -# observed on OSX 10.12 (Sierra) only. Any change, such as using the -# Development version to make debugging symbols available, adding a print -# statement, or calling update idletasks here, would make the test pass -# with no segfault. + # This call to update idletasks was added to prevent a crash that was + # observed on OSX 10.12 (Sierra) only. Any change, such as using the + # Development version to make debugging symbols available, adding a print + # statement, or calling update idletasks here, would make the test pass + # with no segfault. update idletasks deleteWindows } -result {0 0 140 300} @@ -693,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 -} -result {0} + 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 -} -result {1} + 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 @@ -738,12 +733,12 @@ test frame-3.13 {TkCreateFrame procedure} -constraints { option clear colorsFree .t } -cleanup { - deleteWindows -} -result {1} + 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 @@ -753,12 +748,12 @@ test frame-3.14 {TkCreateFrame procedure} -constraints { option clear colorsFree .t } -cleanup { - deleteWindows -} -result {1} + 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 @@ -769,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 -} -result {0} + 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 @@ -791,24 +786,24 @@ test frame-3.17 {TkCreateFrame procedure} -constraints { update colorsFree .t } -cleanup { - deleteWindows -} -result {1} + 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 -} -result {1} + 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} @@ -818,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 @@ -834,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 -} -result {1} + 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 @@ -879,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 @@ -922,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"} @@ -939,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] @@ -952,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] @@ -960,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 {} @@ -974,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] @@ -982,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 @@ -996,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 {} @@ -1005,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 @@ -1020,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 @@ -1031,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 @@ -1047,16 +1034,16 @@ 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 destroy .t update winfo exists .t -} -result {0} +} -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 @@ -1070,24 +1057,19 @@ test frame-9.3 {MapFrame procedure, window deleted while mapping} -setup { winfo exists .t } -cleanup { deleteWindows -} -result {0} - +} -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 @@ -1098,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 @@ -1111,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 @@ -1125,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 @@ -1152,16 +1130,17 @@ test frame-12.2 {FrameWorldChanged procedure} -setup { w* {incr expx $fw ; incr expw -$fw} e* {incr expw -$fw} } - lappend result [expr {\ - [winfo x .f.f] == $expx && [winfo y .f.f] == $expy &&\ - [winfo width .f.f] == $expw && [winfo height .f.f] == $exph}] + lappend result [expr { + [winfo x .f.f] == $expx && [winfo y .f.f] == $expy && + [winfo width .f.f] == $expw && [winfo height .f.f] == $exph + }] } return $result } -cleanup { deleteWindows } -result {1 1 1 1 1 1 1 1 1 1 1 1} test frame-12.3 {FrameWorldChanged procedure} -setup { - deleteWindows + deleteWindows update idletasks } -body { # Check reaction on font change @@ -1188,11 +1167,10 @@ test frame-12.3 {FrameWorldChanged procedure} -setup { } -cleanup { deleteWindows font delete myfont -} -result {0} - +} -result 0 test frame-13.1 {labelframe configuration options} -setup { - deleteWindows + deleteWindows } -body { labelframe .f -class NewFrame .f configure -class @@ -1204,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 { @@ -1244,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 { @@ -1266,36 +1243,36 @@ 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 lindex [.f configure -bd] 4 } -cleanup { .f configure -bd [lindex [.f configure -bd] 3] -} -result {4} +} -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 lindex [.f configure -borderwidth] 4 } -cleanup { .f configure -borderwidth [lindex [.f configure -borderwidth] 3] -} -result {1} +} -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 @@ -1304,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} @@ -1326,45 +1303,45 @@ 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 lindex [.f configure -height] 4 } -cleanup { .f configure -height [lindex [.f configure -height] 3] -} -result {100} +} -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 lindex [.f configure -highlightthickness] 4 } -cleanup { .f configure -highlightthickness [lindex [.f configure -highlightthickness] 3] -} -result {6} +} -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 @@ -1372,26 +1349,26 @@ 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 } -cleanup { .f configure -padx [lindex [.f configure -padx] 3] -} -result {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 lindex [.f configure -pady] 4 } -cleanup { .f configure -pady [lindex [.f configure -pady] 3] -} -result {4} +} -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 @@ -1399,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 @@ -1419,15 +1396,14 @@ test frame-13.43 {labelframe configuration options} -body { lindex [.f configure -width] 4 } -cleanup { .f configure -width [lindex [.f configure -width] 3] -} -result {32} +} -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} @@ -1442,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 @@ -1461,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 @@ -1480,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 @@ -1494,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 @@ -1517,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 @@ -1531,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/geometry.test b/tests/geometry.test index c10a119..6576331 100644 --- a/tests/geometry.test +++ b/tests/geometry.test @@ -2,9 +2,9 @@ # tkGeometry.c (generic support for geometry managers). It is # organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. proc getsize w { @@ -282,7 +282,7 @@ test geometry-4.10 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { winfo ismapped .t.quit } -cleanup { destroy .t -} -result {1} +} -result 1 # cleanup diff --git a/tests/get.test b/tests/get.test index ea08c8c..51b6b94 100644 --- a/tests/get.test +++ b/tests/get.test @@ -2,8 +2,8 @@ # tkGet.c. It is organized in the standard fashion for Tcl # white-box tests. # -# Copyright (c) 1998 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/grab.test b/tests/grab.test index 653d756..ea8e992 100644 --- a/tests/grab.test +++ b/tests/grab.test @@ -4,7 +4,7 @@ # built-in commands. Sourcing this file runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright © 1998-2000 Ajuba Solutions. # All rights reserved. package require tcltest 2.2 @@ -107,7 +107,7 @@ test grab-2.1 {Tk_GrabObjCmd, grab status gives correct status} -body { grab status . } -cleanup { grab release . -} -result {none} +} -result none test grab-2.2 {Tk_GrabObjCmd, grab status gives correct status} -body { set curr [grab current .] if { [string length $curr] > 0 } { diff --git a/tests/grid.test b/tests/grid.test index dd02729..627b4e7 100644 --- a/tests/grid.test +++ b/tests/grid.test @@ -1,8 +1,8 @@ # This file is a Tcl script to test out the *NEW* "grid" command of Tk. It is # (almost) organized in the standard fashion for Tcl tests. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -45,7 +45,7 @@ test grid-1.1 {basic argument checking} -body { } -returnCodes error -result {wrong # args: should be "grid option arg ?arg ...?"} test grid-1.2 {basic argument checking} -body { grid foo bar -} -returnCodes error -result {bad option "foo": must be anchor, bbox, columnconfigure, configure, content, forget, info, location, propagate, remove, rowconfigure, size, or slaves} +} -returnCodes error -result {bad option "foo": must be anchor, bbox, columnconfigure, configure, content, forget, info, location, propagate, remove, rowconfigure, or size} test grid-1.3 {basic argument checking} -body { button .b grid .b -row 0 -column @@ -63,10 +63,10 @@ test grid-1.5 {basic argument checking} -body { } -returnCodes error -result {can't manage ".": it's a top-level window} test grid-1.6 {basic argument checking} -body { grid x -} -returnCodes error -result {can't determine master window} +} -returnCodes error -result {can't determine container window} test grid-1.7 {basic argument checking} -body { grid configure x -} -returnCodes error -result {can't determine master window} +} -returnCodes error -result {can't determine container window} test grid-1.8 {basic argument checking} -body { button .b grid x .b @@ -93,7 +93,7 @@ test grid-2.2 {bbox} -body { } -result {0 0 0 0} test grid-2.3 {bbox: argument checking} -body { grid bbox . 0 0 5 -} -returnCodes error -result {wrong # args: should be "grid bbox master ?column row ?column row??"} +} -returnCodes error -result {wrong # args: should be "grid bbox window ?column row ?column row??"} test grid-2.4 {bbox} -body { grid bbox .bad 0 0 } -returnCodes error -result {bad window path name ".bad"} @@ -179,7 +179,7 @@ test grid-3.7 {configure: basic argument checking} -body { grid .f .f.b } -cleanup { grid_reset 3.7 -} -returnCodes error -result {can't put .f.b inside .} +} -returnCodes error -result {can't put ".f.b" inside "."} test grid-3.8 {configure: basic argument checking} -body { button .b grid configure x .b @@ -206,7 +206,7 @@ test grid-3.11 {prevent management loops} -body { grid .f2 -in .f1 } -cleanup { grid_reset 3.11 -} -returnCodes error -result {can't put .f2 inside .f1, would cause management loop} +} -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 @@ -216,7 +216,7 @@ test grid-3.12 {prevent management loops} -body { grid .f3 -in .f1 } -cleanup { grid_reset 3.12 -} -returnCodes error -result {can't put .f3 inside .f1, would cause management loop} +} -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 @@ -293,7 +293,7 @@ test grid-5.4 {info} -body { test grid-6.1 {location: basic argument checking} -body { grid location . -} -returnCodes error -result {wrong # args: should be "grid location master x y"} +} -returnCodes error -result {wrong # args: should be "grid location window x y"} test grid-6.2 {location: basic argument checking} -body { grid location .bad 0 0 } -returnCodes error -result {bad window path name ".bad"} @@ -389,12 +389,12 @@ test grid-7.2 {propagate} -body { grid propagate . } -cleanup { grid_reset 7.2 -} -result {1} +} -result 1 test grid-7.3 {propagate} -body { grid propagate . 0;grid propagate . } -cleanup { grid_reset 7.3 -} -result {0} +} -result 0 test grid-7.4 {propagate} -body { grid propagate .x } -cleanup { @@ -576,12 +576,12 @@ test grid-10.1 {column/row configure} -body { grid columnconfigure . } -cleanup { grid_reset 10.1 -} -returnCodes error -result {wrong # args: should be "grid columnconfigure master index ?-option value ...?"} +} -returnCodes error -result {wrong # args: should be "grid columnconfigure window index ?-option value ...?"} test grid-10.2 {column/row configure} -body { grid columnconfigure . 0 -weight 0 -pad } -cleanup { grid_reset 10.2 -} -returnCodes error -result {wrong # args: should be "grid columnconfigure master index ?-option value ...?"} +} -returnCodes error -result {wrong # args: should be "grid columnconfigure window index ?-option value ...?"} test grid-10.3 {column/row configure} -body { grid columnconfigure .f 0 -weight } -cleanup { @@ -596,7 +596,7 @@ test grid-10.5 {column/row configure} -body { grid columnconfigure . 265 -weight } -cleanup { grid_reset 10.5 -} -result {0} +} -result 0 test grid-10.6 {column/row configure} -body { grid columnconfigure . 0 } -cleanup { @@ -622,7 +622,7 @@ test grid-10.10 {column/row configure} -body { grid columnconfigure . 0 -minsize } -cleanup { grid_reset 10.10 -} -result {10} +} -result 10 test grid-10.11 {column/row configure} -body { grid columnconfigure . 0 -weight bad } -cleanup { @@ -638,7 +638,7 @@ test grid-10.13 {column/row configure} -body { grid columnconfigure . 0 -weight } -cleanup { grid_reset 10.13 -} -result {3} +} -result 3 test grid-10.14 {column/row configure} -body { grid columnconfigure . 0 -pad foo } -cleanup { @@ -654,7 +654,7 @@ test grid-10.16 {column/row configure} -body { grid columnconfigure . 0 -pad } -cleanup { grid_reset 10.16 -} -result {3} +} -result 3 test grid-10.17 {column/row configure} -body { frame .f set a "" @@ -856,13 +856,13 @@ test grid-11.1 {default widget placement} -body { grid ^ } -cleanup { grid_reset 11.1 -} -returnCodes error -result {can't use '^', cant find master} +} -returnCodes error -result {can't use '^', can't find container window} test grid-11.2 {default widget placement} -body { button .b grid .b ^ } -cleanup { grid_reset 11.2 -} -returnCodes error -result {can't find slave to extend with "^"} +} -returnCodes error -result {can't find content to extend with "^"} test grid-11.3 {default widget placement} -body { button .b grid .b - - .c @@ -917,7 +917,7 @@ test grid-11.9 {default widget placement} -body { grid .f x ^ } -cleanup { grid_reset 11.9 -} -returnCodes error -result {can't find slave to extend with "^"} +} -returnCodes error -result {can't find content to extend with "^"} test grid-11.10 {default widget placement} -body { foreach i {1 2 3} { frame .f$i -width 100 -height 50 -highlightthickness 0 -bg red @@ -1162,7 +1162,7 @@ test grid-13.4 {-in} -body { grid .f -in .top } -cleanup { grid_reset 13.3 -} -returnCodes error -result {can't put .f inside .top} +} -returnCodes error -result {can't put ".f" inside ".top"} destroy .top test grid-13.5 {-ipadx} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red @@ -1825,7 +1825,6 @@ test grid-17.1 {forget and pending idle handlers} -body { set result ok } -result ok - test grid-18.1 {test respect for internalborder} -body { toplevel .pack wm geometry .pack 200x200 @@ -2040,8 +2039,123 @@ test grid-23 {grid configure -in leaked from previous container window - bug pack forget .f update winfo ismapped .t ; # must return 1 -} {1} +} 1 grid_reset 23 + +test grid-24.1 {<<NoManagedChild>> fires on last grid forget} -setup { + global A + unset -nocomplain A +} -body { + grid [frame .1] + update + bind . <<NoManagedChild>> {set A 1} + grid forget .1 + update + info exists A +} -cleanup { + bind . <<NoManagedChild>> {} + grid_reset 24.1 +} -result 1 +test grid-24.2 {<<NoManagedChild>> fires on last grid remove} -setup { + global A + unset -nocomplain A +} -body { + grid [frame .1] + update + bind . <<NoManagedChild>> {set A 1} + grid remove .1 + update + info exists A +} -cleanup { + bind . <<NoManagedChild>> {} + grid_reset 24.2 +} -result 1 +test grid-24.3 {<<NoManagedChild>> fires on last gridded child destruction} -setup { + global A + unset -nocomplain A +} -body { + grid [frame .1] + update + bind . <<NoManagedChild>> {incr A} + destroy .1 + update + set A +} -cleanup { + bind . <<NoManagedChild>> {} + grid_reset 24.3 +} -result 1 +test grid-24.4 {<Configure> does not fire on last grid forget} -setup { + global A + unset -nocomplain A +} -body { + grid [frame .1] + update + bind . <Configure> {set A 1} + grid forget .1 + update + info exists A +} -cleanup { + bind . <Configure> {} + grid_reset 24.4 +} -result 0 +test grid-24.5 {<Configure> fires on forelast grid forget} -setup { + global A + unset -nocomplain A +} -body { + grid [frame .1] + grid [frame .2] + update + bind . <Configure> {set A 1} + grid forget .1 + update + info exists A +} -cleanup { + bind . <Configure> {} + grid_reset 24.5 +} -result 1 +test grid-24.6 {<<NoManagedChild>> does not fire on forelast grid forget} -setup { + global A + unset -nocomplain A +} -body { + grid [frame .1] + grid [frame .2] + update + bind . <<NoManagedChild>> {set A 1} + grid forget .1 + update + info exists A +} -cleanup { + bind . <<NoManagedChild>> {} + grid_reset 24.6 +} -result 0 +test grid-24.7 {<<NoManagedChild>> does not fire on grid anchor} -setup { + global A + unset -nocomplain A +} -body { + bind . <<NoManagedChild>> {set A 1} + grid anchor . w + update + info exists A +} -cleanup { + grid anchor . nw + bind . <<NoManagedChild>> {} + grid_reset 24.7 +} -result 0 +test grid-24.8 {<<NoManagedChild>> does not fire on last grid forget if propagation is off} -setup { + global A + unset -nocomplain A +} -body { + grid [frame .1] + grid propagate . 0 + update + bind . <<NoManagedChild>> {set A 1} + grid forget .1 + update + info exists A +} -cleanup { + bind . <<NoManagedChild>> {} + grid_reset 24.8 +} -result 0 # cleanup cleanupTests diff --git a/tests/image.test b/tests/image.test index 1f0aad2..c7b6511 100644 --- a/tests/image.test +++ b/tests/image.test @@ -2,9 +2,9 @@ # other procedures in the file tkImage.c. It is organized in the # standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -50,7 +50,7 @@ test image-1.6 {Tk_ImageCmd procedure, "create" option} -constraints { expr {$second-$first} } -cleanup { imageCleanup -} -result {1} +} -result 1 test image-1.7 {Tk_ImageCmd procedure, "create" option} -constraints { testImageType @@ -308,7 +308,9 @@ test image-5.7 {Tk_ImageCmd procedure, "type" option} -constraints { } -returnCodes error -result {image "myimage" doesn't exist} -test image-6.1 {Tk_ImageCmd procedure, "types" option} -body { +test image-6.1 {Tk_ImageCmd procedure, "types" option} -constraints { + testImageType +} -body { image types x } -returnCodes error -result {wrong # args: should be "image types"} test image-6.2 {Tk_ImageCmd procedure, "types" option} -body { diff --git a/tests/imgBmap.test b/tests/imgBmap.test index 56484a6..1beafac 100644 --- a/tests/imgBmap.test +++ b/tests/imgBmap.test @@ -2,9 +2,9 @@ # the procedures in the file tkImgBmap.c). It is organized in the # standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -366,7 +366,7 @@ test imageBmap-7.5 {ImgBmapCmd procedure, "cget" option} -body { } -returnCodes error -result {unknown option "-stupid"} test imageBmap-7.6 {ImgBmapCmd procedure} -body { llength [i1 configure] -} -result {6} +} -result 6 test imageBmap-7.7 {ImgBmapCmd procedure} -body { i1 co -foreground #001122 i1 configure -foreground diff --git a/tests/imgListFormat.test b/tests/imgListFormat.test new file mode 100644 index 0000000..4877645 --- /dev/null +++ b/tests/imgListFormat.test @@ -0,0 +1,661 @@ +# This file is a Tcl script to test out the default image data format +# ("list format") implementend in the file tkImgListFormat.c. +# It is organized in the standard fashion for Tcl tests. +# +# Copyright © 2017 Simon Bachmann +# All rights reserved. +# +# Author: Simon Bachmann (simonbachmann@bluewin.ch) + +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv +tcltest::loadTestedCommands + +imageInit + +# find the teapot.ppm file for use in these tests +set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm] +testConstraint hasTeapotPhoto [file exists $teapotPhotoFile] +# let's see if we have the semi-transparent one as well +set transpTeapotPhotoFile [file join [file dirname [info script]] teapotTransparent.png] +testConstraint hasTranspTeapotPhoto [file exists $transpTeapotPhotoFile] + +# --------------------------------------------------------------------- + + +test imgListFormat-1.1 {ParseFormatOptions: default values} -setup { + image create photo photo1 +} -body { + photo1 put {{red green} {blue black}} + lindex [photo1 data] 1 1 +} -cleanup { + imageCleanup +} -result {#000000} +test imgListFormat-1.2 {ParseFormatOptions: format name as first arg} -setup { + image create photo photo1 +} -body { + photo1 put #1256ef -format {default} -to 0 0 10 10 +} -cleanup { + imageCleanup +} -result {} +test imgListFormat-1.3 {ParseFormatOptions: unknown option} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -bogus} +} -cleanup { + imageCleanup +} -returnCodes error -result {bad format option "-bogus": must be -colorformat} +test imgListFormat-1.4 {ParseFormatOptions: option not allowed} -setup { + image create photo photo1 +} -body { + photo1 put yellow -format {default -colorformat rgb} +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {bad format option "-colorformat": no options allowed} +test imgListFormat-1.5 {ParseFormatOptions: no -colorformat value} -setup { + image create photo photo1 -data black +} -body { + photo1 data -format {default -colorformat} +} -returnCodes error -result {the "-colorformat" option requires a value} +test imgListFormat-1.6 {ParseFormatOptions: bad -colorformat val #1} -setup { + image create photo photo1 +} -body { + photo1 put yellow + photo1 data -format {default -colorformat bogus} +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {bad color format "bogus": must be rgb, rgba, or list} +test imgListFormat-1.7 {ParseFormatOptions: bad -colorformat val #2} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -colorformat tkcolor} +} -returnCodes error -result \ + {bad color format "tkcolor": must be rgb, rgba, or list} +test imgListFormat-1.8 {ParseFormatOptions: bad -colorformat #3} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -colorformat emptystring} +} -returnCodes error -result \ + {bad color format "emptystring": must be rgb, rgba, or list} +test imgListFormat-1.9 {ParseFormatOptions: bad -colorformat #4} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -colorformat rgb-short} +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {bad color format "rgb-short": must be rgb, rgba, or list} +test imgListFormat-1.10 {ParseFormatOptions: bad -colorformat #5} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -colorformat rgba-short} +} -returnCodes error -result \ + {bad color format "rgba-short": must be rgb, rgba, or list} +test imgListFormat-1.11 {valid colorformats} -setup { + image create photo photo1 +} -body { + photo1 put white#78 + set result {} + lappend result [photo1 data -format {default -colorformat rgb}] + lappend result [photo1 data -format {default -colorformat rgba}] + lappend result [photo1 data -format {default -colorformat list}] + set result +} -cleanup { + imageCleanup + unset result +} -result {{{#ffffff}} {{#ffffff78}} {{{255 255 255 120}}}} + +# GetBadOptMsg: only use case already tested with imgListFormat-1.4 + +test imgListFormat-3.1 {StringMatchDef: data is not a list} -body { + testphotostringmatch {not a " proper list} + # " (this comment is here only for editor highlighting) +} -returnCodes error -result {unmatched open quote in list} +# empty data case tested with imgPhoto-4.95 (imgPhoto.test) +test imgListFormat-3.2 {StringMatchDef: \ + list element not a proper list} -body { + testphotostringmatch {{red white} {not "} {blue green}} + # " +} -returnCodes error -result {unmatched open quote in list} +test imgListFormat-3.3 {StringMatchDef: \ + sublists with differen lengths} -body { + testphotostringmatch {{#001122 #334455 #667788} + {#99AABB #CCDDEE} + {#FF0011 #223344 #556677}} +} -returnCodes error -result \ + {invalid row # 1: all rows must have the same number of elements} +test imgListFormat-3.4 {StringMatchDef: base64 data is not parsed as valid \ +} -setup { + image create photo photo1 +} -body { + photo1 put { + iVBORw0KGgoAAAANSUhEUgAAAAIAAAACCA + YAAAEFsT2yAAAABGdBTUEAAYagMeiWXwAA + ABdJREFUCJkFwQEBAAAAgiD6P9pACRoqDk + fUBvt1wUFKAAAAAElFTkSuQmCC + } -format default +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "iVBORw0KGgoAAAANSUhEUgAAAAIAAAACCA"} +test imgListFormat-3.5 {StringMatchDef: valid data} -setup { + image create photo photo1 +} -body { + photo1 put {{blue green} + {yellow magenta} + {#000000 #FFFFFFFF}} + list [image width photo1] [image height photo1] \ + [photo1 get 0 2 -withalpha] +} -cleanup { + imageCleanup +} -result {2 3 {0 0 0 255}} + +# ImgStringRead: most of the error cases cannot be tested with current code, +# as the errors are detected by StringMatchDef +test imgListFormat-4.1 {StringReadDef: use with -format opt} -setup { + image create photo photo1 +} -body { + photo1 put white -format "default" + photo1 get 0 0 +} -cleanup { + imageCleanup +} -result {255 255 255} +test imgListFormat-4.2 {StringReadDef: suboptions to format} -setup { + image create photo photo1 +} -body { + photo1 put white -format {default -bogus} +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {bad format option "-bogus": no options allowed} +test imgListFormat-4.3 {StringReadDef: erroneous non-option argument} -setup { + image create photo photo1 +} -body { + photo1 put orange -format {default bogus} +} -returnCodes error -result {bad format option "bogus": no options allowed} +test imgListFormat-4.4 {StringReadDef: normal use case} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 -file $teapotPhotoFile + image create photo photo2 +} -body { + set imgData [photo1 data] + photo2 put $imgData + string equal [photo1 data] [photo2 data] +} -cleanup { + imageCleanup + unset imgData +} -result 1 +test imgListFormat-4.5 {StringReadDef: correct compositing rule} -constraints { + hasTranspTeapotPhoto +} -setup { + image create photo photo1 -file $transpTeapotPhotoFile + image create photo photo2 +} -body { + photo2 put #FF0000 -to 0 0 50 50 + photo2 put [photo1 data -format {default -colorformat rgba}] -to 10 10 40 40 + list [photo2 get 0 0 -withalpha] [photo2 get 20 25 -withalpha] \ + [photo2 get 49 49 -withalpha] +} -cleanup { + imageCleanup +} -result {{255 0 0 255} {0 78 185 225} {255 0 0 255}} + +test imgListFormat-5.1 {StringWriteDef: format options not a list} -setup { + image create photo photo1 +} -body { + photo1 data -format {default " bogus} + # " +} -cleanup { + imageCleanup +} -returnCodes error -result {unmatched open quote in list} +test imgListFormat-5.2 {StringWriteDef: invalid format option} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -bogus} +} -cleanup { + imageCleanup +} -returnCodes error -result {bad format option "-bogus": must be -colorformat} +test imgListFormat-5.3 {StringWriteDef: non-option arg in format} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -colorformat list bogus} +} -cleanup { + imageCleanup +} -returnCodes error -result {bad format option "bogus": must be -colorformat} +test imgListFormat-5.4 {StringWriteDef: empty image} -setup { + image create photo photo1 +} -body { + photo1 data -format {default -colorformat rgba} +} -cleanup { + imageCleanup +} -result {} +test imgListFormat-5.5 {StirngWriteDef: size of data} -setup { + image create photo photo1 +} -body { + photo1 put blue -to 0 0 35 64 + set imgData [photo1 data] + list [llength [lindex $imgData 0]] [llength $imgData] +} -cleanup { + unset imgData + imageCleanup +} -result {35 64} +test imgListFormat-5.6 {StringWriteDef: test some pixels #1} -constraints { + hasTeapotPhoto +} -setup { + set result {} + image create photo photo1 -file $teapotPhotoFile +} -body { + set imgData [photo1 data] + # note: with [lindex], the coords are inverted (y x) + lappend result [lindex $imgData 0 0] + lappend result [lindex $imgData 3 2] + lappend result [lindex $imgData 107 53] + lappend result [lindex $imgData 203 157] + lappend result [lindex $imgData 255 255] + set result +} -cleanup { + unset result + unset imgData + imageCleanup +} -result {{#135cc0} #135cc0 #a06d52 #e1c8ba #135cc0} +test imgListFormat-5.7 {StringWriteDef: test some pixels #2} -constraints { + hasTeapotPhoto +} -setup { + set result {} + image create photo photo1 -file $teapotPhotoFile +} -body { + set imgData [photo1 data -format {default -colorformat rgba}] + # note: with [lindex], the coords are inverted (y x) + lappend result [lindex $imgData 0 0] + lappend result [lindex $imgData 3 2] + lappend result [lindex $imgData 107 53] + lappend result [lindex $imgData 203 157] + lappend result [lindex $imgData 255 255] + set result +} -cleanup { + unset result + unset imgData + imageCleanup +} -result {{#135cc0ff} #135cc0ff #a06d52ff #e1c8baff #135cc0ff} +test imgListFormat-5.8 {StringWriteDef: test some pixels #3} -constraints { + hasTranspTeapotPhoto +} -setup { + image create photo photo1 -file $transpTeapotPhotoFile +} -body { + set imgData [photo1 data -format {default -colorformat rgb}] + set result {} + lappend result [lindex $imgData 3 2] + lappend result [lindex $imgData 107 53] + lappend result [lindex $imgData 203 157] + set result +} -cleanup { + unset result + unset imgData + imageCleanup +} -result {{#004eb9} #a14100 #ffca9f} +test imgListFormat-5.9 {StringWriteDef: test some pixels #4} -constraints { + hasTranspTeapotPhoto +} -setup { + image create photo photo1 -file $transpTeapotPhotoFile +} -body { + set imgData [photo1 data -format {default -colorformat rgba}] + set result [lindex $imgData 3 2] + lappend result [lindex $imgData 107 53] + lappend result [lindex $imgData 203 157] + set result +} -cleanup { + unset result + unset imgData + imageCleanup +} -result {{#004eb9e1} #a14100aa #ffca9faf} +test imgListFormat-5.10 {StringWriteDef: test some pixels #5} -constraints { + hasTranspTeapotPhoto +} -setup { + image create photo photo1 -file $transpTeapotPhotoFile +} -body { + set imgData [photo1 data -format {default -colorformat list}] + set result {} + lappend result [lindex $imgData 3 2] + lappend result [lindex $imgData 107 53] + lappend result [lindex $imgData 203 157] + set result +} -cleanup { + unset imgData + unset result + imageCleanup +} -result {{0 78 185 225} {161 65 0 170} {255 202 159 175}} + +test imgListFormat-6.1 {ParseColor: empty string} -setup { + image create photo photo1 + set result {} +} -body { + photo1 put {{"" ""} {"" ""}} + lappend result [image width photo1] + lappend result [image height photo1] + lappend result [photo1 get 1 1 -withalpha] + set result +} -cleanup { + unset result + imageCleanup +} -result {2 2 {0 0 0 0}} +test imgListFormat-6.2 {ParseColor: empty string, mixed} -setup { + image create photo photo1 +} -body { + photo1 put {{black white} {{} white}} + list [photo1 get 0 0 -withalpha] [photo1 get 0 1 -withalpha] +} -cleanup { + imageCleanup +} -result {{0 0 0 255} {0 0 0 0}} +test imgListFormat-6.3 {ParseColor: color name too long} -setup { + image create photo photo1 + set longstr {} + for {set i 1} {$i <= 100} {incr i} { + append longstr "z" + } +} -body { + photo1 put [list [list blue] [list $longstr]] +} -cleanup { + imageCleanup + unset longstr +} -returnCodes error -result {invalid color} +test imgListFormat-6.4 {ParseColor: #XXX color, different forms} -setup { + image create photo photo1 +} -body { + photo1 put {{#A123 #334455} {#012 #fffefd#00}} + photo1 data -format {default -colorformat rgba} +} -cleanup { + imageCleanup +} -result {{#aa112233 #334455ff} {#001122ff #fffefd00}} +test imgListFormat-6.5 {ParseColor: list format} -setup { + image create photo photo1 +} -body { + photo1 put [list [list [list 255 255 255]]] + photo1 get 0 0 -withalpha +} -cleanup { + imageCleanup +} -result {255 255 255 255} +test imgListFormat-6.6 {ParseColor: string format} -setup { + image create photo photo1 +} -body { + photo1 put [list [list [list white]]] + photo1 get 0 0 -withalpha +} -cleanup { + imageCleanup +} -result {255 255 255 255} +test imgListFormat-6.7 {ParseColor: invalid color} -setup { + image create photo photo1 +} -body { + photo1 put {{blue red} {green bogus}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "bogus"} +test imgListFormat-6.8 {ParseColor: overall test} -setup { + image create photo photo1 + set result {} +} -body { + photo1 put { + {snow@0.5 snow#80 snow#8 #fffffafafafa@0.5 #fffffabbfacc#8} + {#fffffafffaff#80 #ffffaafaa@.5 #ffffaafaa#8 #ffffaafaa#80 #fee#8} + {#fee#80 #fee@0.5 #fffafa@0.5 #fffafa#8 #fffafa#80} + {{0xff 250 0xfa 128} {255 250 250} #fee8 #fffafa80 snow}} + for {set y 0} {$y < 4} {incr y} { + for {set x 0} {$x < 5} {incr x} { + lappend result [photo1 get $x $y -withalpha] + } + } + set result +} -cleanup { + imageCleanup + unset result +} -result \ +{{255 250 250 128} {255 250 250 128} {255 250 250 136} {255 250 250 128}\ +{255 250 250 136} {255 250 250 128} {255 250 250 128} {255 250 250 136}\ +{255 250 250 128} {255 238 238 136} {255 238 238 128} {255 238 238 128}\ +{255 250 250 128} {255 250 250 136} {255 250 250 128} {255 250 250 128}\ +{255 250 250 255} {255 238 238 136} {255 250 250 128} {255 250 250 255}} + +# Note: these tests were written for an earlier implementation of +# ParseColorAsList. For this reason, their order and layout do not follow the +# current code very well. Test coverage is pretty good, nevertheless. +test imgListFormat-7.1 {ParseColorAsList: invalid list} -setup { + image create photo photo1 +} -body { + photo1 put {{{123 45 67 89} {123 45 " 67}}} + #" +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "123 45 " 67"} +#" +test imgListFormat-7.2 {ParseColorAsList: too few elements in list} -setup { + image create photo photo1 +} -body { + photo1 put {{{0 255 0 255} {0 255}}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "0 255"} +test imgListFormat-7.3 {ParseColorAsList: too many elements in list} -setup { + image create photo photo1 +} -body { + photo1 put {{{0 100 200 255} {0 100 200 255 0}}} +} -returnCodes error -result {invalid color name "0 100 200 255 0"} +test imgListFormat-7.4 {ParseColorAsList: not an integer value} -setup { + image create photo photo1 +} -body { + photo1 put {{{9 0xf3 87 65} {43 21 10 1.0}}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "43 21 10 1.0"} +test imgListFormat-7.5 {ParseColorAsList: negative value in list} -setup { + image create photo photo1 +} -body { + photo1 put {{{121 121 121} {121 121 -1}}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "121 121 -1"} +test imgListFormat-7.6 {ParseColorAsList: value in list too large} -setup { + image create photo photo1 +} -body { + photo1 put {{{0 1 2 3} {254 255 256}}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "254 255 256"} +test imgListFormat-7.7 {ParseColorAsList: suffix not allowed} -setup { + image create photo photo1 +} -body { + photo1 put {{{100 100 100} {100 100 100#FE}}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "100 100 100#FE"} +test imgListFormat-7.8 {ParseColorAsList: valid list form} -setup { + image create photo photo1 +} -body { + photo1 put {{{0x0 0x10 0xfe 0xff} {0 100 254}} + {{30 30 30 0} {1 1 254 1}}} + list [photo1 get 0 0 -withalpha] [photo1 get 1 0 -withalpha] \ + [photo1 get 0 1 -withalpha] [photo1 get 1 1 -withalpha] +} -cleanup { + imageCleanup +} -result {{0 16 254 255} {0 100 254 255} {30 30 30 0} {1 1 254 1}} +test imgListFormat-7.9 {ParseColorAsList: additional spaces in list} -setup { + image create photo photo1 +} -body { + photo1 put { { { 1 2 3} {1 2 3} } { {1 2 3 } { 1 2 3 4 } } } + photo1 data -format {default -colorformat rgba} +} -cleanup { + imageCleanup +} -result {{#010203ff #010203ff} {#010203ff #01020304}} +test imgListFormat-7.10 {ParseColorAsList: list format, string rep} -setup { + image create photo photo1 +} -body { + photo1 put {{"111 222 33 44"}} + photo1 get 0 0 -withalpha +} -cleanup { + imageCleanup +} -result {111 222 33 44} + +test imgListFormat-8.1 {ParseColorAsHex: RGB format} -setup { + image create photo photo1 +} -body { + photo1 put {{#010 #001100}} + photo1 data +} -cleanup { + imageCleanup +} -result {{#001100 #001100}} +test imgListFormat-8.2 {ParseColorAsHex: invalid hex digit} -setup { + image create photo photo1 +} -body { + photo1 put {#ABCD #ABCZ} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "#ABCZ"} +test imgListFormat-8.3 {ParseColorAsHex: RGB with suffix, 8 chars} -setup { + image create photo photo1 +} -body { + photo1 put {{#FFfFFf #AbCdef#0}} + photo1 data +} -cleanup { + imageCleanup +} -result {{#ffffff #abcdef}} +test imgListFormat-8.4 {ParseColor: valid #RGBA color} -setup { + image create photo photo1 +} -body { + photo1 put {{#9bd5020d #7acF}} + list [photo1 get 0 0 -withalpha] [photo1 get 1 0 -withalpha] +} -cleanup { + imageCleanup +} -result {{155 213 2 13} {119 170 204 255}} + +test imgListFormat-9.1 {ParseColorAsStandard: + Tk color, valid suffixes} -setup { + image create photo photo1 + set result {} +} -body { + photo1 put {{blue@0.711 #114433#C} {#8D4#1A magenta}} + lappend result [photo1 get 0 0 -withalpha] + lappend result [photo1 get 1 0 -withalpha] + lappend result [photo1 get 0 1 -withalpha] + lappend result [photo1 get 1 1 -withalpha] + set result +} -cleanup { + unset result + imageCleanup +} -result {{0 0 255 181} {17 68 51 204} {136 221 68 26} {255 0 255 255}} +test imgListFormat-9.2 {ParseColorAsStandard: + Tk color with and w/o suffixes} -setup { + image create photo photo1 + set result {} +} -body { + photo1 put {{#52D8a0 #2B5} {#E47@0.01 maroon#4}} + lappend result [photo1 get 0 0 -withalpha] + lappend result [photo1 get 1 0 -withalpha] + lappend result [photo1 get 0 1 -withalpha] + lappend result [photo1 get 1 1 -withalpha] + set result +} -cleanup { + unset result + imageCleanup +} -result {{82 216 160 255} {34 187 85 255} {238 68 119 3} {128 0 0 68}} +test imgListFormat-9.3 {ParseColorAsStandard: wrong digit count} -setup { + image create photo photo1 +} -body { + photo1 put {{#000 #00}} +} -returnCodes error -result {invalid color name "#00"} +test imgListFormat-9.4 {ParseColorAsStandard: @A suffix, not a float} -setup { + image create photo photo1 +} -body { + photo1 put {{blue@0.5 blue@bogus}} +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {invalid alpha suffix "@bogus": expected floating-point value} +test imgListFormat-9.5 {ParseColorAsStandard: @A, value too low} -setup { + image create photo photo1 +} -body { + photo1 put {green@.1 green@-0.1} +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {invalid alpha suffix "@-0.1": value must be in the range from 0 to 1} +test imgListFormat-9.6 {ParseColorAsStandard: @A, value too high} -setup { + image create photo photo1 +} -body { + photo1 put {#000000@0 #000000@1.0001} +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {invalid alpha suffix "@1.0001": value must be in the range from 0 to 1} +test imgListFormat-9.7 {ParseColorAsStandard: @A suffix, edge values} -setup { + imageCleanup + image create photo photo1 +} -body { + photo1 put {{yellow@1e-22 yellow@0.12352941 yellow@0.12352942 \ + yellow@0.9999999}} + list [photo1 get 0 0 -withalpha] [photo1 get 1 0 -withalpha] \ + [photo1 get 2 0 -withalpha] [photo1 get 3 0 -withalpha] +} -cleanup { + imageCleanup +} -result {{255 255 0 0} {255 255 0 31} {255 255 0 32} {255 255 0 255}} +test imgListFormat-9.8 {ParseColorAsStandard: # suffix, no hex digits} -setup { + image create photo photo1 +} -body { + photo1 put {{black#f} {black#}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid alpha suffix "#"} +test imgListFormat-9.9 {ParseColorAsStandard: + '#' suffix, too many digits} -setup { + image create photo photo1 +} -body { + photo1 put {{#ABC#12 #ABC#123}} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid alpha suffix "#123"} +test imgListFormat-9.10 {ParseColorAsStandard: + invalid digit in #X suffix} -setup { + image create photo photo1 +} -body { + photo1 put {#000#a #000#g} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid alpha suffix "#g": expected hex digit} +test imgListFormat-9.11 {ParseColorAsStandard: + invalid digit in #XX suffix} -setup { + image create photo photo1 +} -body { + photo1 put {green#2 green#2W} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid alpha suffix "#2W": expected hex digit} +test imgListFormat-9.12 {ParseColorAsStandard: + invalid color: not a hex digit} -setup { + image create photo photo1 +} -body { + photo1 put {#ABCDEF@.99 #ABCDEG@.99} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "#ABCDEG@.99"} +test imgListFormat-9.13 {ParseColorAsStandard: suffix not allowed #1} -setup { + image create photo photo1 +} -body { + photo1 put {#ABC@.5 #ABCD@0.5} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "#ABCD@0.5"} +test imgListFormat-9.14 {ParseColorAsStandard: suffix not allowed #2} -setup { + image create photo photo1 +} -body { + photo1 put {#1111 #1111#1} +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "#1111#1"} + + +# --------------------------------------------------------------------- + +imageFinish + +# cleanup +cleanupTests +return diff --git a/tests/imgPNG.test b/tests/imgPNG.test index 4900e9c..522dca7 100644 --- a/tests/imgPNG.test +++ b/tests/imgPNG.test @@ -2,10 +2,10 @@ # and write PNG-format image files for photo widgets. The files is organized # in the standard fashion for Tcl tests. # -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 1998 Willem van Schaik (images only) -# Copyright (c) 2008 Donal K. Fellows +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 1998 Willem van Schaik (images only) +# Copyright © 2008 Donal K. Fellows # All rights reserved. package require tcltest 2.2 @@ -1056,7 +1056,10 @@ duFtaSrZF3pfCpiGjN2imToJJ39m6BjG1XZRwrkAI8YUKSZWlEZQDAIrNArHnyvpXtmM/B7wJeAbwO fBcxKuQMrzfLdBoz29fX9led5v6u1XnBJW7vnr/YlrXEoNo22LRYOYlxZ1S6rkOfDcLvPAY/hGmWC7 H68uFI+x0oSPg2MAN/L5/M/vtqSED/T5cMu9J4Wf7HMGsB/4TEv/DFwe3Y/NPN57VXh+5BWApwFLlh r661tV1eju/ne8YJrkWtES0tmRe2VOviv2j2aBp5nHihiRaz/A4oCnsAsje/+AAAAAElFTkSuQmCC" - } + dpi100aspect2 +"iVBORw0KGgoAAAANSUhEUgAAAAIAAAACCAIAAAD91JpzAAAACXBIWXMAAA9hAAAewgEw8YEEAAAA +FklEQVR4nGP4+vXrP11lJgYGhj9xSQAzOwXsETZ69QAAAABJRU5ErkJggg==" + } # $encoded(basn0g08), $encoded(basn2c08), $encoded(basn3p08), $encoded(basn6a08) test imgPNG-1.1 {reading basic images; grayscale} -setup { @@ -1113,9 +1116,53 @@ test imgPNG-3.1 {reading image with unknown ancillary chunk - bug [1c659ef0f1]} catch {set i [image create photo -file $fileName]} } -cleanup { image delete $i -} -result {0} - +} -result 0 + +test imgPNG-4.1 {data image with metadata} -body { + image create photo i1 -data $encoded(dpi100aspect2) + i1 cget -metadata +} -cleanup { + image delete i1 +} -result {DPI 99.9998 aspect 2.0} + +test imgPNG-4.2 {file image with metadata} -setup { + set path [file join [configure -tmpdir] test.png] + set h [open $path "WRONLY BINARY CREAT"] + puts -nonewline $h [binary decode base64 $encoded(dpi100aspect2)] + close $h +} -body { + image create photo i1 -file $path + i1 cget -metadata +} -cleanup { + image delete i1 + file delete $path +} -result {DPI 99.9998 aspect 2.0} + +test imgPNG-4.3 {data output with metadata} -setup { + image create photo i1 -data $encoded(dpi100aspect2) +} -body { + set imgData [i1 data -format png] + image delete i1 + image create photo i1 -data $imgData + i1 cget -metadata +} -cleanup { + image delete i1 +} -result {DPI 99.9998 aspect 2.0} + +test imgPNG-4.4 {file output with metadata} -setup { + image create photo i1 -data $encoded(dpi100aspect2) + set path [file join [configure -tmpdir] test.png] +} -body { + i1 write $path -format png + image delete i1 + image create photo i1 -file $path + i1 cget -metadata +} -cleanup { + image delete i1 +} -result {DPI 99.9998 aspect 2.0} + } + namespace delete png imageFinish cleanupTests diff --git a/tests/imgPPM.test b/tests/imgPPM.test index e3a738a..dfabd62 100644 --- a/tests/imgPPM.test +++ b/tests/imgPPM.test @@ -2,8 +2,8 @@ # which reads and write PPM-format image files for photo widgets. # The files is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test index a890fd7..544b2e6 100644 --- a/tests/imgPhoto.test +++ b/tests/imgPhoto.test @@ -2,22 +2,92 @@ # procedures in the file tkImgPhoto.c. It is organized in the standard fashion # for Tcl tests. # -# Copyright (c) 1994 The Australian National University -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2002-2008 Donal K. Fellows +# Copyright © 1994 The Australian National University +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2002-2008 Donal K. Fellows # All rights reserved. # # Author: Paul Mackerras (paulus@cs.anu.edu.au) +# +# This file is somewhat caothic: the order of the tests does not +# really follow the order of the corresponding functions in +# tkImgPhoto.c. Probably, because early versions had only a few tests +# and over time test cases were added in bits and pieces. +# To be noted, also, that this file is not complete: large portions of +# code in tkImgPhoto.c have no test coverage. +# +# To help keeping the overview, the table below lists where to find +# tests for each of the functions in tkImgPhoto.c. The function are +# listed in the order as they appear in the source file. +# + +# +# Function name Tests for function +#-------------------------------------------------------------------------- +# PhotoFormatThreadExitProc no tests +# Tk_Create*PhotoImageFormat no tests +# ImgPhotoCreate imgPhoto-2.* +# ImgPhotoCmd imgPhoto-4.*, imgPhoto-17.* +# GetExtension: no tests +# ParseSubcommandOptions: imgPhoto-1.* +# ImgPhotoConfigureModel: imgPhoto-3.*, imgPhoto-15.* +# toggleComplexAlphaIfNeeded: no tests +# ImgPhotoDelete: imgPhoto-8.* +# ImgPhotoCmdDeleteProc: imgPhoto-9.* +# ImgPhotoSetSize: no tests +# MatchFileFormat: imgPhoto-18.* +# MatchSringFormat: imgPhoto-19.* +# Tk_FindPhoto: imgPhoto-11.* +# Tk_PhotoPutBlock: imgPhoto-10.*, imgPhoto-16.* +# Tk_PhotoPutZoomedBlock: imgPhoto-12.* +# Tk_DitherPhoto: no tets +# Tk_PhotoBlank: no tests +# Tk_PhotoExpand: no tests +# Tk_PhotoGetSize: no tests +# Tk_PhotoSetSize: no tests +# TkGetPhotoValidRegion: no tests +# ImgGetPhoto: no tests +# Tk_PhotoGetImage no tests +# ImgPostscriptPhoto no tests +# Tk_PhotoPutBlock_NoComposite no tests, probably none needed +# Tk_PhotoPutZoomedBlock_NoComposite no tests, probably none needed +# Tk_PhotoExpand_Panic no tests, probably none needed +# Tk_PhotoPutBlock_Panic no tests, probably none needed +# Tk_PhotoPutZoomedBlock_Panic no tests, probably none needed +# Tk_PhotoSetSize_Panic no tests, probably none needed +# Tk_PhotoGetMetadata: imgPhoto-21.* +# Tk_PhotoSetMetadata: imgPhoto-22.* +#-------------------------------------------------------------------------- +# + +# +# Some tests are not specific to a function in tkImgPhoto.c. They are: +# + +# +# Test name(s) Description +#-------------------------------------------------------------------------- +# imgPhoto-5.* Do not really belong to this file. ImgPhotoGet and +# ImgPhotoFree are defined in tkImgPhInstance.c. +# imgPhoto-6.* Do not really belong to this file. ImgPhotoDisplay +# is defined in tkImgPhInstance.c. +# imgPhoto-7.* Do not really belong to this file. ImgPhotoFree is +# defined in tkImgPhInstance.c. +# imgPhoto-13.* Tests for separation in different interpreters +# imgPhoto-14.* Test GIF format. Would belong to imgGIF.test +# - which does not exist. +# + package require tcltest 2.2 namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands - -# Used for 4.65 - 4.73 tests -# Now for some heftier testing, checking that setting and resetting of pixels' -# transparency status doesn't "leak" with any one-off errors. + +# +# Used for imgPhoto-4.65 - imgPhoto-4.73 +# proc foreachPixel {img xVar yVar script} { upvar 1 $xVar x $yVar y set width [image width $img] @@ -58,6 +128,11 @@ set README [makeFile { # find the teapot.ppm file for use in these tests set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm] testConstraint hasTeapotPhoto [file exists $teapotPhotoFile] +# let's see if we have the semi-transparent one as well +set transpTeapotPhotoFile [file join [file dirname [info script]] teapotTransparent.png] +testConstraint hasTranspTeapotPhoto [file exists $transpTeapotPhotoFile] +testConstraint needsTcl867 [package vsatisfies [package provide Tcl] 8.6.7-] + test imgPhoto-1.1 {options for photo images} -body { image create photo photo1 -width 79 -height 83 @@ -107,7 +182,26 @@ test imgPhoto-1.10 {options for photo images - error case} -body { test imgPhoto-1.11 {options for photo images - error case} -body { image create photo photo1 -format } -returnCodes error -result {value for "-format" missing} - +test imgPhoto-1.12 {option -alpha, normal use} -setup { + image create photo photo1 +} -body { + photo1 put "white" -to 0 0 + photo1 transparency get 0 0 -alpha +} -cleanup { + imageCleanup +} -result 255 +test imgPhoto-1.13 {option -withalpha, normal use} -setup { + image create photo photo1 +} -body { + photo1 put {{blue green}} + photo1 get 1 0 -withalpha +} -cleanup { + imageCleanup +} -result {0 128 0 255} +test imgPhoto-1.14 {options for photo images - error case} -body { + image create photo photo1 -metadata +} -returnCodes error -result {value for "-metadata" missing} + test imgPhoto-2.1 {ImgPhotoCreate procedure} -setup { imageCleanup } -body { @@ -130,7 +224,7 @@ test imgPhoto-2.2 {ImgPhotoCreate procedure} -setup { # photo1 copy photo2 # set msg # } {couldn't open "bogus.img": no such file or directory} - + test imgPhoto-3.1 {ImgPhotoConfigureModel procedure} -constraints { hasTeapotPhoto } -body { @@ -166,7 +260,41 @@ test imgPhoto-3.3 {ImgPhotoConfigureModel procedure} -constraints { destroy .c image delete photo1 } -result {256 256 {10 10 266 266} {300 10 556 266}} - +test imgPhoto-3.4 {ImgPhotoConfigureModel: -data <ppm>} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 -file $teapotPhotoFile + image create photo photo2 +} -body { + photo2 configure -data [photo1 data -format ppm -from 100 100 120 120] + list [image width photo2] [image height photo2] +} -cleanup { + imageCleanup +} -result {20 20} +# This testcase fails with Tcl < 8.6.7, due to [25842c] +test imgPhoto-3.5 {ImgPhotoConfigureModel: -data <png>} -constraints { + hasTeapotPhoto needsTcl867 +} -setup { + image create photo photo1 -file $teapotPhotoFile + image create photo photo2 +} -body { + photo2 configure -data [photo1 data -format png -from 120 120 140 140] + list [image width photo2] [image height photo2] +} -cleanup { + imageCleanup +} -result {20 20} +test imgPhoto-3.6 {ImgPhotoConfigureModel: -data <default>} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 -file $teapotPhotoFile + image create photo photo2 +} -body { + photo2 configure -data [photo1 data -from 80 90 100 110] + list [image width photo2] [image height photo2] +} -cleanup { + imageCleanup +} -result {20 20} + test imgPhoto-4.1 {ImgPhotoCmd procedure} -setup { image create photo photo1 } -body { @@ -209,7 +337,7 @@ test imgPhoto-4.6 {ImgPhotoCmd procedure: configure option} -setup { llength [photo1 configure] } -cleanup { image delete photo1 -} -result 7 +} -result 8 test imgPhoto-4.7 {ImgPhotoCmd procedure: configure option} -setup { image create photo photo1 } -body { @@ -365,16 +493,19 @@ test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} -constraints { } -cleanup { image delete photo1 photo2 } -result {256 256 49 51 49 51 49 51 10 51 10 10} +# tests for <imageName> data: imgPhoto-4. test imgPhoto-4.22 {ImgPhotoCmd procedure: get option} -constraints { - hasTeapotPhoto + hasTranspTeapotPhoto } -setup { image create photo photo1 } -body { - photo1 read $teapotPhotoFile - list [photo1 get 100 100] [photo1 get 150 100] [photo1 get 100 150] + photo1 read $transpTeapotPhotoFile + list [photo1 get 100 100 -withalpha] \ + [photo1 get 150 100 -withalpha] \ + [photo1 get 100 150] [photo1 get 150 150] } -cleanup { image delete photo1 -} -result {{169 117 90} {172 115 84} {35 35 35}} +} -result {{175 71 0 162} {179 73 0 168} {14 8 0} {0 0 0}} test imgPhoto-4.23 {ImgPhotoCmd procedure: get option} -setup { image create photo photo1 } -body { @@ -392,10 +523,12 @@ test imgPhoto-4.24 {ImgPhotoCmd procedure: get option} -setup { test imgPhoto-4.25 {ImgPhotoCmd procedure: get option} -setup { image create photo photo1 } -body { - photo1 get + photo1 get 0 } -cleanup { image delete photo1 -} -returnCodes error -result {wrong # args: should be "photo1 get x y"} +} -returnCodes error -result \ + {wrong # args: should be "photo1 get x y ?-withalpha?"} +# more test for image get: 4.101-4.102 test imgPhoto-4.26 {ImgPhotoCmd procedure: put option} -setup { image create photo photo1 } -body { @@ -409,22 +542,28 @@ test imgPhoto-4.27 {ImgPhotoCmd procedure: put option} -setup { photo1 put {{white} {white white}} } -returnCodes error -cleanup { image delete photo1 -} -result {all elements of color list must have the same number of elements} +} -result {invalid row # 1: all rows must have the same number of elements} test imgPhoto-4.28 {ImgPhotoCmd procedure: put option} -setup { image create photo photo1 } -body { photo1 put {{blahgle}} } -cleanup { image delete photo1 -} -returnCodes error -result {can't parse color "blahgle"} +} -returnCodes error -result {invalid color name "blahgle"} test imgPhoto-4.29 {ImgPhotoCmd procedure: put option} -setup { image create photo photo1 } -body { - photo1 put -to 10 10 20 20 {{white}} + # SB: odd thing - this test passed with tk 8.6.6, even if the data + # is in the wrong position: + #photo1 put -to 10 10 20 20 {{white}} + + # this is how it's supposed to be: + photo1 put {{white}} -to 10 10 20 20 photo1 get 19 19 } -cleanup { image delete photo1 } -result {255 255 255} +# more tests for image put: 4.90-4.100 test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} -setup { image create photo photo1 } -body { @@ -440,7 +579,7 @@ test imgPhoto-4.31 {ImgPhotoCmd procedure: read option} -constraints { photo1 read $teapotPhotoFile -zoom 2 } -returnCodes error -cleanup { image delete photo1 -} -result {unrecognized option "-zoom": must be -format, -from, -shrink, or -to} +} -result {unrecognized option "-zoom": must be -format, -from, -metadata, -shrink, or -to} test imgPhoto-4.32 {ImgPhotoCmd procedure: read option} -setup { image create photo photo1 } -body { @@ -506,6 +645,7 @@ test imgPhoto-4.39 {ImgPhotoCmd procedure: write option} -setup { } -cleanup { image delete photo1 } -returnCodes error -result {image file format "bogus" is unknown} +# more tests on "imageName write": imgPhoto-17.* test imgPhoto-4.40 {ImgPhotoCmd procedure: transparency option} -setup { image create photo photo1 } -body { @@ -519,21 +659,21 @@ test imgPhoto-4.41 {ImgPhotoCmd procedure: transparency get option} -setup { photo1 transparency get } -returnCodes error -cleanup { image delete photo1 -} -result {wrong # args: should be "photo1 transparency get x y"} +} -result {wrong # args: should be "photo1 transparency get x y ?-option?"} test imgPhoto-4.42 {ImgPhotoCmd procedure: transparency get option} -setup { image create photo photo1 } -body { photo1 transparency get 0 } -returnCodes error -cleanup { image delete photo1 -} -result {wrong # args: should be "photo1 transparency get x y"} +} -result {wrong # args: should be "photo1 transparency get x y ?-option?"} test imgPhoto-4.43 {ImgPhotoCmd procedure: transparency get option} -setup { image create photo photo1 } -body { - photo1 transparency get 0 0 0 + photo1 transparency get 0 0 0 -alpha } -returnCodes error -cleanup { image delete photo1 -} -result {wrong # args: should be "photo1 transparency get x y"} +} -result {wrong # args: should be "photo1 transparency get x y ?-option?"} test imgPhoto-4.44 {ImgPhotoCmd procedure: transparency get option} -setup { image create photo photo1 } -body { @@ -593,34 +733,39 @@ test imgPhoto-4.51 {ImgPhotoCmd procedure: transparency get option} -setup { } -cleanup { image delete photo1 } -result 1 +# more tests for transparency get: 4.65, 4.66, 4.76-4.81 test imgPhoto-4.52 {ImgPhotoCmd procedure: transparency set option} -setup { image create photo photo1 } -body { photo1 transparency set } -returnCodes error -cleanup { image delete photo1 -} -result {wrong # args: should be "photo1 transparency set x y boolean"} +} -result \ + {wrong # args: should be "photo1 transparency set x y newVal ?-option?"} test imgPhoto-4.53 {ImgPhotoCmd procedure: transparency set option} -setup { image create photo photo1 } -body { photo1 transparency set 0 } -returnCodes error -cleanup { image delete photo1 -} -result {wrong # args: should be "photo1 transparency set x y boolean"} +} -result \ + {wrong # args: should be "photo1 transparency set x y newVal ?-option?"} test imgPhoto-4.54 {ImgPhotoCmd procedure: transparency set option} -setup { image create photo photo1 } -body { photo1 transparency set 0 0 } -returnCodes error -cleanup { image delete photo1 -} -result {wrong # args: should be "photo1 transparency set x y boolean"} +} -result \ + {wrong # args: should be "photo1 transparency set x y newVal ?-option?"} test imgPhoto-4.55 {ImgPhotoCmd procedure: transparency set option} -setup { image create photo photo1 } -body { - photo1 transparency set 0 0 0 0 + photo1 transparency set 0 0 0 0 -alpha } -returnCodes error -cleanup { image delete photo1 -} -result {wrong # args: should be "photo1 transparency set x y boolean"} +} -result \ + {wrong # args: should be "photo1 transparency set x y newVal ?-option?"} test imgPhoto-4.56 {ImgPhotoCmd procedure: transparency set option} -setup { image create photo photo1 } -body { @@ -637,6 +782,7 @@ test imgPhoto-4.57 {ImgPhotoCmd procedure: transparency set option} -setup { } -returnCodes error -result {expected integer but got "bogus"} test imgPhoto-4.58 {ImgPhotoCmd procedure: transparency set option} -setup { image create photo photo1 + photo1 put blue } -body { photo1 transparency set 0 0 bogus } -cleanup { @@ -688,6 +834,7 @@ test imgPhoto-4.64 {ImgPhotoCmd procedure: transparency set option} -setup { } -cleanup { image delete photo1 } -result 1 +# more tests for transparency set: 4.67, 4.68, 4.82-4.89 # Now for some heftier testing, checking that setting and resetting of pixels' # transparency status doesn't "leak" with any one-off errors. test imgPhoto-4.65 {ImgPhotoCmd procedure: transparency get option} -setup { @@ -812,7 +959,7 @@ test imgPhoto-4.75 {<photo> read command: filename starting with '-'} -constrain image delete photo1 file delete ./-teapotPhotoFile } -result {} -test imgPhoto-4.76 {ImgPhotoCmd procedure: copy to same image} -constraints { +test imgPhoto-4.75.1 {ImgPhotoCmd procedure: copy to same image} -constraints { hasTeapotPhoto } -setup { imageCleanup @@ -824,7 +971,411 @@ test imgPhoto-4.76 {ImgPhotoCmd procedure: copy to same image} -constraints { } -cleanup { imageCleanup } -result {} - +test imgPhoto-4.76 {ImgPhotoCmd, transparency get: too many options} -setup { + image create photo photo1 +} -body { + photo1 put white -to 0 0 1 1 + photo1 transparency get 0 0 -alpha -bogus +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {wrong # args: should be "photo1 transparency get x y ?-option?"} +test imgPhoto-4.77 {ImgPhotoCmd, transparency get: invalid option} -setup { + image create photo photo1 +} -body { + photo1 put white -to 0 0 1 1 + photo1 transparency get 0 0 -bogus +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {unrecognized option "-bogus": must be -alpha} +test imgPhoto-4.78 {ImgPhotoCmd, transparency get: normal use} -setup { + image create photo photo1 +} -body { + photo1 put white -to 0 0 1 1 + set result [photo1 transparency get 0 0] + lappend result [photo1 transparency get 0 0 -alpha] +} -cleanup { + imageCleanup +} -result {0 255} +test imgPhoto-4.79 {ImgPhotoCmd, transparency get: no option} -constraints { + hasTranspTeapotPhoto +} -setup { + image create photo photo1 -file $transpTeapotPhotoFile + set result {} +} -body { + set pixelCoords {{156 239} {76 207} {153 213} {139 43} {75 112}} + foreach coord $pixelCoords { + lappend result [photo1 transparency get {*}$coord] + } + set result +} -cleanup { + imageCleanup +} -result {0 1 0 0 0} +# test imgPhoto-4.80: deleted (was transparency get: -boolean) +test imgPhoto-4.81 {ImgPhotoCmd, transparency get: -alpha} -constraints { + hasTranspTeapotPhoto +} -setup { + image create photo photo1 -file $transpTeapotPhotoFile + set result {} +} -body { + set pixelCoords {{156 239} {76 207} {153 213} {139 43} {75 112}} + foreach coord $pixelCoords { + lappend result [photo1 transparency get {*}$coord -alpha] + } + set result +} -cleanup { + imageCleanup +} -result {255 0 1 254 206} +test imgPhoto-4.82 {ImgPhotoCmd, transparency set: too many opts} -setup { + image create photo photo1 +} -body { + photo1 transparency set 0 0 -alpha -bogus 1 +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {wrong # args: should be "photo1 transparency set x y newVal ?-option?"} +test imgPhoto-4.83 {ImgPhotoCmd, transparency set: invalid opt} -setup { + image create photo photo1 -data black +} -body { + photo1 transparency set 0 0 0 -bogus +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {unrecognized option "-bogus": must be -alpha} +test imgPhoto-4.84 {ImgPhotoCmd, transparency set: invalid newVal} -setup { + image create photo photo1 -data white +} -body { + photo1 transparency set 0 0 bogus -alpha +} -cleanup { + imageCleanup +} -returnCodes error -result {expected integer but got "bogus"} +test imgPhoto-4.85 {ImgPhotoCmd, transparency set: invalid newVal} -setup { + image create photo photo1 -data red +} -body { + photo1 transparency set 0 0 -1 -alpha +} -returnCodes error -result \ + {invalid alpha value "-1": must be integer between 0 and 255} +test imgPhoto-4.86 {ImgPhotoCmd, transparency set: invalid newVal} -setup { + image create photo photo1 -data green +} -body { + photo1 transparency set 0 0 256 -alpha +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {invalid alpha value "256": must be integer between 0 and 255} +test imgPhoto-4.87 {ImgPhotoCmd, transparency set: no opt} -setup { + image create photo photo1 +} -body { + photo1 put white -to 0 0 2 1 + photo1 transparency set 0 0 0 + photo1 transparency set 1 0 1 + list [photo1 transparency get 0 0 -alpha] \ + [photo1 transparency get 1 0 -alpha] +} -cleanup { + imageCleanup +} -result {255 0} +# deleted: test imgPhoto-4.88 {ImgPhotoCmd, transparency set: -boolean} +test imgPhoto-4.89 {ImgPhotoCmd, transparency set: -alpha} -setup { + image create photo photo1 +} -body { + photo1 put white -to 0 0 2 2 + photo1 transparency set 0 0 0 -alpha + photo1 transparency set 1 0 1 -alpha + photo1 transparency set 0 1 254 -alpha + photo1 transparency set 1 1 255 -alpha + list [photo1 transparency get 0 0] [photo1 transparency get 1 0] \ + [photo1 transparency get 0 1] [photo1 transparency get 1 1] +} -cleanup { + imageCleanup +} -result {1 0 0 0} +test imgPhoto-4.90 {ImgPhotoCmd put: existing but not allowed opt} -setup { + image create photo photo1 +} -body { + photo1 put yellow -from 0 0 1 1 +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {unrecognized option "-from": must be -format, -metadata, or -to} +test imgPhoto-4.91 {ImgPhotoCmd put: invalid option} -setup { + image create photo photo1 +} -body { + photo1 put {{0 1 2 3}} -bogus x +} -returnCodes error -result \ + {unrecognized option "-bogus": must be -format, -metadata, or -to} +test imgPhoto-4.92 {ImgPhotocmd put: missing data} -setup { + image create photo photo1 +} -body { + photo1 put -to 0 0 +} -returnCodes error -result \ + {wrong # args: should be "photo1 put data ?-option value ...?"} +test imgPhoto-4.93 {ImgPhotoCmd put: data in ppm format} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 -file $teapotPhotoFile + image create photo photo2 +} -body { + set imgdata [photo1 data -format ppm] + photo2 put $imgdata -format ppm + set result {} + if {[image width photo1] != [image width photo2] \ + || [image height photo1] != [image height photo2]} { + lappend result [list [image width photo2] [image height photo2]] + } else { + lappend result 1 + } + foreach point {{206 125} {67 12} {13 46} {19 184}} { + if {[photo1 get {*}$point] ne [photo2 get {*}$point]} { + lappend result [photo2 get {*}$point] + } else { + lappend result 1 + } + } + set result +} -cleanup { + imageCleanup +} -result {1 1 1 1 1} +test imgPhoto-4.94 {ImgPhotoCmd put: unknown format} -setup { + image create photo photo1 +} -body { + photo1 put {no real data} -format bogus +} -cleanup { + imageCleanup +} -returnCodes error -result {image format "bogus" is not supported} +test imgPhoto-4.95 {ImgPhotoCmd put: default fmt, invalid data} -setup { + image create photo photo1 +} -body { + photo1 put {{red green blue} {red " blue}} + #" +} -cleanup { + imageCleanup +} -returnCodes error -result {unmatched open quote in list} +test imgPhoto-4.96 {ImgPhotoCmd put: "default" handler is selected} -setup { + image create photo photo1 + image create photo photo2 + set imgData {{{1 2 3 4} {5 6 7 8} {9 10 11 12}} + {{13 14 15 15} {17 18 19 20} {21 22 23 24}}} +} -body { + photo1 put $imgData + photo2 put $imgData -format default + set result {} + lappend result [list [image width photo1] [image height photo1]] + lappend result [list [image width photo2] [image height photo2]] + lappend result [string equal \ + [photo1 data -format "default -colorformat rgba"] \ + [photo2 data -format "default -colorformat rgba"]] + set result +} -cleanup { + imageCleanup + unset result + unset imgData +} -result {{3 2} {3 2} 1} +test imgPhoto-4.97 {ImgPhotoCmd put: image size} -setup { + image create photo photo1 +} -body { + photo1 put {{red green blue} {blue red green}} + list [image width photo1] [image height photo1] +} -cleanup { + imageCleanup +} -result {3 2} +test imgPhoto-4.98 {ImgPhotoCmd put: -to with 2 coords} -setup { + image create photo photo1 +} -body { + photo1 put {{"alice blue" "blanched almond"} + {"deep sky blue" "ghost white"} + {#AABBCC #AABBCCDD}} -to 5 6 + list [image width photo1] [image height photo1] +} -cleanup { + imageCleanup +} -result {7 9} +test imgPhoto-4.99 {ImgPhotoCmd put: -to with 4 coords} -setup { + image create photo photo1 +} -body { + photo1 put {{#123 #456 #678} {#9AB #CDE #F01}} -to 1 2 20 21 + set result {} + lappend result [photo1 get 19 20 -withalpha] + lappend result [string equal \ + [photo1 data -from 1 2 4 4] [photo1 data -from 4 2 7 4]] + lappend result [string equal \ + [photo1 data -from 10 12 13 14] [photo1 data -from 16 16 19 18]] + set result +} -cleanup { + imageCleanup +} -result {{17 34 51 255} 1 1} +test imgPhoto-4.100 {ImgPhotoCmd put: no changes on empty data} -setup { + image create photo photo1 +} -body { + photo1 put {{brown blue} {cyan coral}} + set imgData [photo1 data] + photo1 put {} + string equal $imgData [photo1 data] +} -cleanup { + imageCleanup +} -result 1 +test imgPhoto-4.101 {ImgPhotoCmd get: too many args} -setup { + image create photo photo1 +} -body { + photo1 get 0 0 -withalpha bogus +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {wrong # args: should be "photo1 get x y ?-withalpha?"} +test imgPhoto-4.102 {ImgPhotoCmd get: invalid option} -setup { + image create photo photo1 +} -body { + photo1 get 0 0 -bogus +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {unrecognized option "-bogus": must be -withalpha} +test imgPhoto-4.103 {ImgPhotoCmd data: accepted opts} -setup { + image create photo photo1 -data black +} -body { + photo1 data -format default -from 0 0 -grayscale -background blue +} -cleanup { + imageCleanup +} -result {{#000000}} +test imgPhoto-4.104 {ImgPhotoCmd data: existing but not accepted opt} -setup { + image create photo photo1 +} -body { + photo1 data -to +} -cleanup { + imageCleanup +} -returnCodes error -result \ +{unrecognized option "-to": must be -background, -format, -from, -grayscale, or -metadata} +test imgPhoto-4.105 {ImgPhotoCmd data: invalid option} -setup { + image create photo photo1 +} -body { + photo1 data -bogus +} -cleanup { + imageCleanup +} -returnCodes error -result \ +{unrecognized option "-bogus": must be -background, -format, -from, -grayscale, or -metadata} +test imgPhoto-4.106 {ImgPhotoCmd data: extra arg before options} -setup { + image create photo photo1 +} -body { + photo1 data bogus -grayscale +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {wrong # args: should be "photo1 data ?-option value ...?"} +test imgPhoto-4.107 {ImgPhotoCmd data: extra arg after options} -setup { + image create photo photo1 +} -body { + photo1 data -format default bogus +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {wrong # args: should be "photo1 data ?-option value ...?"} +test imgPhoto-4.108 {ImgPhotoCmd data: invalid -from coords #1} -setup { + image create photo photo1 -data blue +} -body { + photo1 data -from 2 0 +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {coordinates for -from option extend outside image} +test imgPhoto-4.109 {ImgPhotoCmd data: invalid -from coords #2} -setup { + image create photo photo1 -data blue +} -body { + photo1 data -from 0 2 +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {coordinates for -from option extend outside image} +test imgPhoto-4.110 {ImgPhotoCmd data: invalid -from coords #3} -setup { + image create photo photo1 -data blue +} -body { + photo1 data -from 0 0 2 1 +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {coordinates for -from option extend outside image} +test imgPhoto-4.111 {ImgPhotoCmd data: invalid -from coords #4} -setup { + image create photo photo1 -data blue +} -body { + photo1 data -from 0 0 1 2 +} -cleanup { + imageCleanup +} -returnCodes error -result \ + {coordinates for -from option extend outside image} +test imgPhoto-4.112 {ImgPhotoCmd data: -from with 2 coords} -setup { + image create photo photo1 -data { + {black black black black black} + {white white white white white} + {green green green green green}} +} -body { + set imgData [photo1 data -from 2 1] + list [llength [lindex $imgData 0]] [llength $imgData] +} -cleanup { + imageCleanup + unset imgData +} -result {3 2} +test imgPhoto-4.113 {ImgPhotoCmd data: default is rgb format} -setup { + image create photo photo1 -data red +} -body { + photo1 data +} -cleanup { + imageCleanup +} -result {{#ff0000}} +test imgPhoto-4.114 {ImgPhotoCmd data: unknown format} -setup { + image create photo photo1 +} -body { + photo1 data -format bogus +} -cleanup { + imageCleanup +} -returnCodes error -result {image string format "bogus" is unknown} +test imgPhoto-4.115 {ImgPhotoCmd data: rgb colorformat} -setup { + image create photo photo1 -data {{red#a green#b} {blue#c white}} +} -body { + photo1 data -format {default -colorformat rgb} +} -result {{#ff0000 #008000} {#0000ff #ffffff}} +test imgPhoto-4.116 {ImgPhotoCmd data: rgba colorformat} -setup { + image create photo photo1 -data {{red green} {blue white}} +} -body { + photo1 data -format {default -colorformat rgba} +} -result {{#ff0000ff #008000ff} {#0000ffff #ffffffff}} +test imgPhoto-4.117 {ImgPhotoCmd data: list colorformat} -setup { + image create photo photo1 -data {{red#a green} {blue#c white#d}} +} -body { + photo1 data -format {default -colorformat list} +} -result {{{255 0 0 170} {0 128 0 255}} {{0 0 255 204} {255 255 255 221}}} +# This testcase fails with Tcl < 8.6.7, due to [25842c] +test imgPhoto-4.118 {ImgPhotoCmd data: using data for new image + results in same image as orignial } -constraints { + hasTeapotPhoto hasTranspTeapotPhoto needsTcl867 +} -setup { + image create photo teapot -file $teapotPhotoFile + teapot copy teapot -from 50 60 70 80 -shrink + image create photo teapotTransp -file $transpTeapotPhotoFile + teapotTransp copy teapotTransp -from 100 110 120 130 -shrink + image create photo photo1 +} -body { + set result {} + # We don't test gif here, as there seems to be a problem with + # <imgName> data and gif format ("too many colors", probably a bug) + foreach fmt {ppm png {default -colorformat rgba} \ + {default -colorformat list}} { + set imgData [teapotTransp data -format $fmt] + photo1 blank + photo1 put $imgData + if { ! [string equal [photo1 data] [teapotTransp data]]} { + lappend result $fmt + } + } + set imgData [teapot data -format default] + photo1 blank + photo1 put $imgData + if { ! [string equal [photo1 data] [teapot data]]} { + lappend result default + } + set result +} -cleanup { + unset imgData + unset result + imageCleanup +} -result {} + test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} -constraints { hasTeapotPhoto } -setup { @@ -847,7 +1398,7 @@ test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} -constraints { } -cleanup { destroy .c } -result {} - + test imgPhoto-6.1 {ImgPhotoDisplay procedure, blank display} -setup { destroy .c pack [canvas .c] @@ -861,7 +1412,7 @@ test imgPhoto-6.1 {ImgPhotoDisplay procedure, blank display} -setup { destroy .c image delete photo1 } -result {} - + test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} -constraints { hasTeapotPhoto } -setup { @@ -922,7 +1473,7 @@ test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} -constraints { destroy .f image delete photo1 } -result {} - + test imgPhoto-8.1 {ImgPhotoDelete procedure} -constraints hasTeapotPhoto -body { image create photo photo2 -file $teapotPhotoFile image delete photo2 @@ -946,7 +1497,7 @@ test imgPhoto-8.3 {ImgPhotoDelete procedure, name cleanup} -body { } -returnCodes error -cleanup { imageCleanup } -result {image "photo2" doesn't exist or is not a photo image} - + test imgPhoto-9.1 {ImgPhotoCmdDeletedProc procedure} -constraints { hasTeapotPhoto } -body { @@ -954,7 +1505,7 @@ test imgPhoto-9.1 {ImgPhotoCmdDeletedProc procedure} -constraints { rename photo2 {} list [expr {"photo2" in [imageNames]}] [catch {photo2 foo} msg] $msg } -result {0 1 {invalid command name "photo2"}} - + test imgPhoto-10.1 {Tk_ImgPhotoPutBlock procedure} -setup { imageCleanup } -body { @@ -976,7 +1527,7 @@ test imgPhoto-10.2 {Tk_ImgPhotoPutBlock, same source and dest img} -constraints string equal [photo1 data] [photo2 data] } -cleanup { imageCleanup -} -result {1} +} -result 1 test imgPhoto-10.3 {Tk_ImgPhotoPutBlock, same source and dest img} -constraints { hasTeapotPhoto } -setup { @@ -990,7 +1541,7 @@ test imgPhoto-10.3 {Tk_ImgPhotoPutBlock, same source and dest img} -constraints string equal [photo1 data] [photo2 data] } -cleanup { imageCleanup -} -result {1} +} -result 1 test imgPhoto-10.4 {Tk_ImgPhotoPutBlock, empty image} -setup { imageCleanup } -body { @@ -1001,7 +1552,6 @@ test imgPhoto-10.4 {Tk_ImgPhotoPutBlock, empty image} -setup { imageCleanup } -result {0 0} - test imgPhoto-11.1 {Tk_FindPhoto} -setup { imageCleanup } -body { @@ -1011,7 +1561,7 @@ test imgPhoto-11.1 {Tk_FindPhoto} -setup { } -cleanup { imageCleanup } -returnCodes error -result {image "i1" doesn't exist or is not a photo image} - + test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} -constraints hasTeapotPhoto -body { image create photo p3 -file $teapotPhotoFile set result [list [p3 get 50 50] [p3 get 100 100]] @@ -1033,7 +1583,7 @@ test imgPhoto-12.2 {Tk_ImgPhotoPutZoomedBlock, same source and dest img} -constr string equal [photo1 data] [photo2 data] } -cleanup { imageCleanup -} -result {1} +} -result 1 test imgPhoto-12.3 {Tk_ImgPhotoPutZoomedBlock, same source and dest img} -setup { imageCleanup } -body { @@ -1045,7 +1595,7 @@ test imgPhoto-12.3 {Tk_ImgPhotoPutZoomedBlock, same source and dest img} -setup string equal [photo1 data] [photo2 data] } -cleanup { imageCleanup -} -result {1} +} -result 1 test imgPhoto-12.4 {Tk_ImgPhotoPutZoomedBlock, empty image} -setup { imageCleanup } -body { @@ -1100,7 +1650,7 @@ test imgPhoto-13.1 {check separation of images in different interpreters} -setup interp delete x1 interp delete x2 } -result T1_data - + test imgPhoto-14.1 {GIF writes work correctly} -setup { set data { R0lGODlhYwA5APcAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgAysnGy8hKzM @@ -1244,7 +1794,7 @@ test imgPhoto-15.1 {photo images can fail to allocate memory gracefully} -constr # free memory available... image create photo -width 32000 -height 32000 } -returnCodes error -result {not enough free memory for image buffer} - + test imgPhoto-16.1 {copying to self doesn't access freed memory} -setup { set i [image create photo] } -body { @@ -1255,7 +1805,7 @@ test imgPhoto-16.1 {copying to self doesn't access freed memory} -setup { } -cleanup { image delete $i } -result {} - + # Check that we can guess our supported output formats [Bug 2983824] test imgPhoto-17.1 {photo write: format guessing from filename} -setup { set i [image create photo -width 3 -height 3] @@ -1294,11 +1844,114 @@ test imgPhoto-17.3 {photo write: format guessing from filename} -setup { image delete $i catch {removeFile $f} } -result "P6\n" +test imgPhoto-17.4 {photo write: default format not supported} -setup { + image create photo photo1 -data {{blue blue} {red red} {green green}} + set f [makeFile {} test.txt] +} -body { + photo1 write $f -format default +} -cleanup { + imageCleanup + catch {removeFile $f} + unset f +} -returnCodes error -result \ + {image file format "default" has no file writing capability} +test imgPhoto-17.5 {photo write: file with extension .default} -setup { + image create photo photo1 -data {{black}} + set f [makeFile {} test.default] +} -body { + photo1 write $f +} -cleanup { + imageCleanup + catch {removeFile $f} + unset f +} -returnCodes error -result \ + {image file format "default" has no file writing capability} + +test imgPhoto-18.1 {MatchFileFormat: "default" format not supported} -setup { + image create photo photo1 + set f [makeFile {} test.txt] +} -body { + photo1 read $f -format default +} -cleanup { + imageCleanup + catch {removeFile $f} + unset f +} -returnCodes error -result {-file option isn't supported for default images} + +test imgPhoto-19.1 {MatchStringFormat: with "-format default"} -setup { + image create photo photo1 +} -body { + photo1 put {{red blue red} {yellow green yellow}} -format default + list [image width photo1] [image height photo1] +} -cleanup { + imageCleanup +} -result {3 2} +test imgPhoto-19.2 {MatchStringFormat: without -format option, + default fmt} -body { + image create photo photo1 + photo1 put {{red} {green}} + list [image width photo1] [image height photo1] +} -cleanup { + imageCleanup +} -result {1 2} +test imgPhoto-19.3 {MatchStringFormat: "-format ppm"} -setup { + image create photo photo1 + image create photo photo2 + photo2 put {cyan cyan} + set imgData [photo2 data -format ppm] +} -body { + photo1 put $imgData -format ppm + list [image width photo1] [image height photo1] +} -cleanup { + unset imgData + imageCleanup +} -result {1 2} +test imgPhoto-19.4 {MatchStringFormat: ppm fmt, without opt} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 -file $teapotPhotoFile + image create photo photo2 +} -body { + set imgData [photo1 data -format ppm] + photo2 put $imgData + list [image width photo2] [image height photo2] +} -cleanup { + imageCleanup + unset imgData +} -result {256 256} +test imgPhoto-19.5 {MatchStirngFormat: unknown -format} -setup { + image create photo photo1 +} -body { + photo1 put {} -format bogus +} -cleanup { + imageCleanup +} -returnCodes error -result {image format "bogus" is not supported} +test imgPhoto-19.6 {MatchStringFormat: invalid data for default} -setup { + image create photo photo1 +} -body { + photo1 put bogus +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "bogus"} +test imgPhoto-19.7 {MatchStringFormat: invalid data for default} -setup { + image create photo photo1 +} -body { + photo1 put bogus -format dEFault +} -cleanup { + imageCleanup +} -returnCodes error -result {invalid color name "bogus"} +test imgPhoto-19.8 {MatchStirngFormat: invalid data for gif} -setup { + image create photo photo1 +} -body { + photo1 put bogus -format giF +} -cleanup { + imageCleanup +} -returnCodes error -result {couldn't recognize image data} # Reject corrupted or truncated image [Bug b601ce3ab1]. -# WARNING - tests 18.1-18.9 will cause a segfault on 8.5.19 and lower, +# WARNING - tests 20.1-20.9 will cause a segfault on 8.5.19 and lower, # and on 8.6.6 and lower. -test imgPhoto-18.1 {Reject corrupted GIF (binary string)} -setup { +test imgPhoto-20.1 {Reject corrupted GIF (binary string)} -setup { set data [binary decode base64 { R0lGODlhAAQABP8zM/8z/zP/MzP/////M////yH5CiwheLrcLTBCd6Tv2qW16tdK4jhV 5qpraXIvM1JlNyAgOw== @@ -1308,7 +1961,7 @@ test imgPhoto-18.1 {Reject corrupted GIF (binary string)} -setup { } -cleanup { catch {image delete gif1} } -returnCodes error -result {error reading color map|not enough free memory for image buffer} -match regexp -test imgPhoto-18.2 {Reject corrupted GIF (base 64 string)} -setup { +test imgPhoto-20.2 {Reject corrupted GIF (base 64 string)} -setup { set data { R0lGODlhAAQABP8zM/8z/zP/MzP/////M////yH5CiwheLrcLTBCd6Tv2qW16tdK4jhV 5qpraXIvM1JlNyAgOw== @@ -1318,14 +1971,14 @@ test imgPhoto-18.2 {Reject corrupted GIF (base 64 string)} -setup { } -cleanup { catch {image delete gif1} } -returnCodes error -result {error reading color map|not enough free memory for image buffer} -match regexp -test imgPhoto-18.3 {Reject corrupted GIF (file)} -setup { +test imgPhoto-20.3 {Reject corrupted GIF (file)} -setup { set fileName [file join [file dirname [info script]] corruptMangled.gif] } -body { image create photo gif1 -file $fileName } -cleanup { catch {image delete gif1} } -returnCodes error -result {error reading color map|not enough free memory for image buffer} -match regexp -test imgPhoto-18.4 {Reject truncated GIF (binary string)} -setup { +test imgPhoto-20.4 {Reject truncated GIF (binary string)} -setup { set data [binary decode base64 { R0lGODlhEAAQAMIHAAAAADMz//8zM/8z/zP/MzP///8= }] @@ -1334,7 +1987,7 @@ test imgPhoto-18.4 {Reject truncated GIF (binary string)} -setup { } -cleanup { catch {image delete gif1} } -returnCodes error -result {error reading color map} -test imgPhoto-18.5 {Reject truncated GIF (base 64 string)} -setup { +test imgPhoto-20.5 {Reject truncated GIF (base 64 string)} -setup { set data { R0lGODlhEAAQAMIHAAAAADMz//8zM/8z/zP/MzP///8= } @@ -1343,14 +1996,14 @@ test imgPhoto-18.5 {Reject truncated GIF (base 64 string)} -setup { } -cleanup { catch {image delete gif1} } -returnCodes error -result {error reading color map} -test imgPhoto-18.6 {Reject truncated GIF (file)} -setup { +test imgPhoto-20.6 {Reject truncated GIF (file)} -setup { set fileName [file join [file dirname [info script]] corruptTruncated.gif] } -body { image create photo gif1 -file $fileName } -cleanup { catch {image delete gif1} } -returnCodes error -result {error reading color map} -test imgPhoto-18.7 {Reject corrupted GIF (> 4Gb) (binary string)} -constraints { +test imgPhoto-20.7 {Reject corrupted GIF (> 4Gb) (binary string)} -constraints { nonPortable } -setup { # About the non portability constraint of this test: see ticket [cc42cc18a5] @@ -1366,7 +2019,7 @@ test imgPhoto-18.7 {Reject corrupted GIF (> 4Gb) (binary string)} -constraints { } -cleanup { catch {image delete gif1} } -returnCodes error -result {error reading color map|not enough free memory for image buffer} -match regexp -test imgPhoto-18.8 {Reject corrupted GIF (> 4Gb) (base 64 string)} -constraints { +test imgPhoto-20.8 {Reject corrupted GIF (> 4Gb) (base 64 string)} -constraints { nonPortable } -setup { # About the non portability constraint of this test: see ticket [cc42cc18a5] @@ -1382,7 +2035,7 @@ test imgPhoto-18.8 {Reject corrupted GIF (> 4Gb) (base 64 string)} -constraints } -cleanup { catch {image delete gif1} } -returnCodes error -result {error reading color map|not enough free memory for image buffer} -match regexp -test imgPhoto-18.9 {Reject corrupted GIF (> 4Gb) (file)} -constraints { +test imgPhoto-20.9 {Reject corrupted GIF (> 4Gb) (file)} -constraints { nonPortable } -setup { # About the non portability constraint of this test: see ticket [cc42cc18a5] @@ -1395,10 +2048,10 @@ test imgPhoto-18.9 {Reject corrupted GIF (> 4Gb) (file)} -constraints { } -cleanup { catch {image delete gif1} } -returnCodes error -result {error reading color map|not enough free memory for image buffer} -match regexp -test imgPhoto-18.10 {Valid GIF (binary string)} -setup { +test imgPhoto-20.10 {Valid GIF (binary string)} -setup { # Test the binary string reader with a valid GIF. # This is not tested elsewhere. - # Tests 18.11, 18.12, with matching data, are included for completeness. + # Tests 20.11, 20.12, with matching data, are included for completeness. set data [binary decode base64 { R0lGODlhEAAQAMIHAAAAADMz//8zM/8z/zP/MzP/////M////yH5BAEKAAcALAAA AAAQABAAAAMheLrcLTBCd6QV79qlterXB0riOFXmmapraXIvM1IdZTcJADs= @@ -1408,7 +2061,7 @@ test imgPhoto-18.10 {Valid GIF (binary string)} -setup { } -cleanup { catch {image delete gif1} } -result gif1 -test imgPhoto-18.11 {Valid GIF (base 64 string)} -setup { +test imgPhoto-20.11 {Valid GIF (base 64 string)} -setup { set data { R0lGODlhEAAQAMIHAAAAADMz//8zM/8z/zP/MzP/////M////yH5BAEKAAcALAAA AAAQABAAAAMheLrcLTBCd6QV79qlterXB0riOFXmmapraXIvM1IdZTcJADs= @@ -1418,7 +2071,7 @@ test imgPhoto-18.11 {Valid GIF (base 64 string)} -setup { } -cleanup { catch {image delete gif1} } -result gif1 -test imgPhoto-18.12 {Valid GIF (file)} -setup { +test imgPhoto-20.12 {Valid GIF (file)} -setup { set fileName [file join [file dirname [info script]] red.gif] } -body { image create photo gif1 -file $fileName @@ -1426,6 +2079,443 @@ test imgPhoto-18.12 {Valid GIF (file)} -setup { catch {image delete gif1} } -result gif1 +# imgPhoto-21.x : Tk_PhotoGetMetadata + +test imgPhoto-21.1 {option -metadata, get configure list} -setup { + image create photo photo1 -metadata {dpi 100} +} -body { + photo1 configure -metadata +} -cleanup { + catch {image delete photo1} +} -result {-metadata {} {} {} {dpi 100}} + +test imgPhoto-21.2 {option -metadata, get value} -setup { + image create photo photo1 -metadata {dpi 100} +} -body { + photo1 cget -metadata +} -cleanup { + catch {image delete photo1} +} -result {dpi 100} + +test imgPhoto-21.3 {option -metadata, get default value} -setup { + image create photo photo1 +} -body { + photo1 cget -metadata +} -cleanup { + catch {image delete photo1} +} -result {} + +# imgPhoto-22.x : Tk_PhotoSetMetadata + +test imgPhoto-22.1 {option -metadata, set value} -setup { + image create photo photo1 +} -body { + photo1 configure -metadata {dpi 100} + photo1 cget -metadata +} -cleanup { + catch {image delete photo1} +} -result {dpi 100} + +test imgPhoto-22.2 {option -metadata, change value} -setup { + image create photo photo1 -metadata {dpi 200} +} -body { + photo1 configure -metadata {dpi 100} + photo1 cget -metadata +} -cleanup { + catch {image delete photo1} +} -result {dpi 100} + +test imgPhoto-22.3 {option -metadata, clear value} -setup { + image create photo photo1 -metadata {dpi 200} +} -body { + photo1 configure -metadata {} + photo1 cget -metadata +} -cleanup { + catch {image delete photo1} +} -result {} + +# 23.x GIF images with metadata + +# The following gif core data is used by the following data. +# N.B. this is the same image as test imgPhoto-18.10 + +# size 16x16, global color table size: 8 +set gifstart "GIF89a\x10\x00\x10\x00\xc2\x07\x00" +# color table +append gifstart "\x00\x00\x00\x33\x33\xff\xff\x33\x33\xff\x33\xff\x33\xff\x33\x33\xff\xff\xff\xff\x33\xff\xff\xff" +# Graphic control extension: Transparent color index: 7 (not needed here) +# append gifdata "\x21\xf9\x04\x01\x0a\x00\x07\x00" +# Image descriptor: 16x16, no local color table +set gifdata "\x2c\x00\x00\x00\x00\x10\x00\x10\x00\x00" +# Image data +append gifdata "\x03\x21\x78\xba\xdc\x2d\x30\x42\x77\xa4\x15\xef\xda\xa5\xb5\xea\xd7\x07\x4a\xe2\x38\x55\xe6\x99\xaa\x6b\x69\x72\x2f\x33\x52\x1d\x65\x37\x09\x00" +set gifend "\x3b" + +test imgPhoto-23.1 {GIF comment before image data (-data)} -setup { + set data $::gifstart + # Append a comment extension block with data "ABCD" + append data "\x21\xfe\x04" "ABCD" "\x0" + # Trailer + append data $::gifdata $::gifend +} -body { + image create photo gif1 -data $data + gif1 cget -metadata +} -cleanup { + catch {image delete gif1} +} -result {comment ABCD} + +test imgPhoto-23.2 {GIF file comment before image data (-file)} -setup { + set data $::gifstart + # Append a comment extension block with data "ABCD" + append data "\x21\xfe\x04" "ABCD" "\x0" + # Trailer + append data $::gifdata $::gifend + set path [file join [configure -tmpdir] test.gif] + set h [open $path "WRONLY BINARY CREAT"] + puts -nonewline $h $data + close $h +} -body { + image create photo gif1 -file $path + gif1 cget -metadata +} -cleanup { + catch {image delete gif1} + file delete $path +} -result {comment ABCD} + +test imgPhoto-23.3 {GIF comment after image data (-data)} -setup { + set data $::gifstart + append data $::gifdata + # Append a comment extension block with data "ABCD" + append data "\x21\xfe\x04" "ABCD" "\x0" + # Trailer + append data $::gifend +} -body { + image create photo gif1 -data $data + gif1 cget -metadata +} -cleanup { + catch {image delete gif1} +} -result {comment ABCD} + +test imgPhoto-23.4 {GIF comment after image data (-file)} -setup { + set data $::gifstart + append data $::gifdata + # Append a comment extension block with data "ABCD" + append data "\x21\xfe\x04" "ABCD" "\x0" + # Trailer + append data $::gifend + set path [file join [configure -tmpdir] test.gif] + set h [open $path "WRONLY BINARY CREAT"] + puts $h $data + close $h +} -body { + image create photo gif1 -file $path + gif1 cget -metadata +} -cleanup { + catch {image delete gif1} + file delete $path +} -result {comment ABCD} + +test imgPhoto-23.5 {Two GIF comment blocks (-data)} -setup { + set data $::gifstart + # Append a comment extension block with data "1234" + append data "\x21\xfe\x04" "1234" "\x0" + append data $::gifdata + # Append a comment extension block with data "ABCD" + append data "\x21\xfe\x04" "ABCD" "\x0" + # Trailer + append data $::gifend +} -body { + image create photo gif1 -data $data + gif1 cget -metadata +} -cleanup { + catch {image delete gif1} +} -result {comment ABCD} + +test imgPhoto-23.6 {Two GIF comment blocks (-file)} -setup { + set data $::gifstart + # Append a comment extension block with data "1234" + append data "\x21\xfe\x04" "1234" "\x0" + append data $::gifdata + # Append a comment extension block with data "ABCD" + append data "\x21\xfe\x04" "ABCD" "\x0" + # Trailer + append data $::gifend + set path [file join [configure -tmpdir] test.gif] + set h [open $path "WRONLY BINARY CREAT"] + puts $h $data + close $h +} -body { + image create photo gif1 -file $path + gif1 cget -metadata +} -cleanup { + catch {image delete gif1} + file delete $path +} -result {comment ABCD} + +test imgPhoto-23.7 {create: test if shared metadata object is not preserved\ + (-data)}\ +-setup { + set data $::gifstart + # Append a comment extension block with data "ABCD" + append data "\x21\xfe\x04" "ABCD" "\x0" + # Trailer + append data $::gifdata $::gifend +} -body { + set metadataDict [dict create A 1] + set metadataDict2 $metadataDict + image create photo gif1 -data $data -metadata $metadataDict + list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2 +} -cleanup { + catch {image delete gif1} +} -result {{A 1 comment ABCD} {A 1} {A 1}} + +test imgPhoto-23.8 {create: test if shared metadata object is not preserved\ + (-file)}\ +-setup { + set data $::gifstart + # Append a comment extension block with data "ABCD" + append data "\x21\xfe\x04" "ABCD" "\x0" + # Trailer + append data $::gifdata $::gifend + + set path [file join [configure -tmpdir] test.gif] + set h [open $path "WRONLY BINARY CREAT"] + puts $h $data + close $h +} -body { + set metadataDict [dict create A 1] + set metadataDict2 $metadataDict + image create photo gif1 -file $path -metadata $metadataDict + list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2 +} -cleanup { + catch {image delete gif1} + file delete $path +} -result {{A 1 comment ABCD} {A 1} {A 1}} + +test imgPhoto-23.9 {configure: test if shared metadata object is not\ + preserved (empty image, -data)}\ +-setup { + set data $::gifstart + # Append a comment extension block with data "ABCD" + append data "\x21\xfe\x04" "ABCD" "\x0" + # Trailer + append data $::gifdata $::gifend +} -body { + image create photo gif1 + set metadataDict [dict create A 1] + set metadataDict2 $metadataDict + gif1 configure -data $data -format gif -metadata $metadataDict + list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2 +} -cleanup { + catch {image delete gif1} +} -result {{A 1 comment ABCD} {A 1} {A 1}} + +test imgPhoto-23.10 {configure: test if shared metadata object is not preserved\ + (empty image, -file)}\ +-setup { + set data $::gifstart + # Append a comment extension block with data "ABCD" + append data "\x21\xfe\x04" "ABCD" "\x0" + # Trailer + append data $::gifdata $::gifend + + set path [file join [configure -tmpdir] test.gif] + set h [open $path "WRONLY BINARY CREAT"] + puts $h $data + close $h +} -body { + image create photo gif1 + set metadataDict [dict create A 1] + set metadataDict2 $metadataDict + gif1 configure -file $path -format gif -metadata $metadataDict + list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2 +} -cleanup { + catch {image delete gif1} + file delete $path +} -result {{A 1 comment ABCD} {A 1} {A 1}} + +test imgPhoto-23.11 {configure: test if shared metadata object is not preserved\ + (metadata replace, -data}\ +-setup { + set data $::gifstart + # Append a comment extension block with data "ABCD" + append data "\x21\xfe\x04" "ABCD" "\x0" + # Trailer + append data $::gifdata $::gifend +} -body { + image create photo gif1 -data "$::gifstart$::gifdata$::gifend" + set metadataDict [dict create A 1] + set metadataDict2 $metadataDict + gif1 configure -data $data -format gif -metadata $metadataDict + list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2 +} -cleanup { + catch {image delete gif1} +} -result {{A 1 comment ABCD} {A 1} {A 1}} + +test imgPhoto-23.12 {configure: test if shared metadata object is not preserved\ + (metadata replace, -file}\ +-setup { + set data $::gifstart + # Append a comment extension block with data "ABCD" + append data "\x21\xfe\x04" "ABCD" "\x0" + # Trailer + append data $::gifdata $::gifend + + set path [file join [configure -tmpdir] test.gif] + set h [open $path "WRONLY BINARY CREAT"] + puts $h $data + close $h +} -body { + image create photo gif1 -data "$::gifstart$::gifdata$::gifend" + set metadataDict [dict create A 1] + set metadataDict2 $metadataDict + gif1 configure -file $path -format gif -metadata $metadataDict + list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2 +} -cleanup { + catch {image delete gif1} + file delete $path +} -result {{A 1 comment ABCD} {A 1} {A 1}} + +test imgPhoto-23.13 {configure: test if shared metadata object is not preserved\ + (-data)}\ +-setup { + set data $::gifstart$::gifdata$::gifend +} -body { + image create photo gif1 -data $data + set metadataDict [dict create A 1] + set metadataDict2 $metadataDict + set data $::gifstart + # Append a comment extension block with data "ABCD" + append data "\x21\xfe\x04" "ABCD" "\x0" + # Trailer + append data $::gifdata $::gifend + gif1 configure -data $data -format gif -metadata $metadataDict + list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2 +} -cleanup { + catch {image delete gif1} +} -result {{A 1 comment ABCD} {A 1} {A 1}} + +test imgPhoto-23.14 {configure: test if shared metadata object is not preserved\ + (-file)}\ +-setup { + set data $::gifstart + # Append a comment extension block with data "ABCD" + append data "\x21\xfe\x04" "ABCD" "\x0" + # Trailer + append data $::gifdata $::gifend + + set path [file join [configure -tmpdir] test.gif] + set h [open $path "WRONLY BINARY CREAT"] + puts $h $data + close $h +} -body { + image create photo gif1 -data "$::gifstart$::gifdata$::gifend" + set metadataDict [dict create A 1] + set metadataDict2 $metadataDict + gif1 configure -file $path -format gif -metadata $metadataDict + list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2 +} -cleanup { + catch {image delete gif1} + file delete $path +} -result {{A 1 comment ABCD} {A 1} {A 1}} + +test imgPhoto-23.15 {output data with comment (from -metadata argument)}\ +-setup { + set data $::gifstart$::gifdata$::gifend +} -body { + image create photo gif1 -data $data + set gifData [gif1 data -format gif -metadata [dict create comment ABCD]] +} -cleanup { + catch {image delete gif1} +} -match glob -result {*ABCD*} + +test imgPhoto-23.22 {output file with comment (from -metadata argument)}\ +-setup { + set data $::gifstart$::gifdata$::gifend + set path [file join [configure -tmpdir] test.gif] +} -body { + image create photo gif1 -data $data + gif1 write $path -format gif -metadata [dict create comment ABCD] + image delete gif1 + image create photo gif1 -file $path + dict get [gif1 cget -metadata] comment +} -cleanup { + catch {image delete gif1} + file delete $path +} -result {ABCD} + +test imgPhoto-23.16 {output data with comment (from -metadata property)}\ +-setup { + set data $::gifstart$::gifdata$::gifend +} -body { + image create photo gif1 -data $data + gif1 configure -metadata [dict create comment ABCD] + set gifData [gif1 data -format gif] +} -cleanup { + catch {image delete gif1} +} -match glob -result {*ABCD*} + +test imgPhoto-23.17 {output file with comment (from -metadata property)}\ +-setup { + set data $::gifstart$::gifdata$::gifend + set path [file join [configure -tmpdir] test.gif] +} -body { + image create photo gif1 -data $data + gif1 configure -metadata [dict create comment ABCD] + gif1 write $path -format gif + image delete gif1 + image create photo gif1 -file $path + dict get [gif1 cget -metadata] comment +} -cleanup { + catch {image delete gif1} + file delete $path +} -result {ABCD} + +test imgPhoto-23.18 {configure: empty metadata parameter overwrites image metadata} -setup { + image create photo gif1 -data $::gifstart$::gifdata$::gifend\ + -metadata {foo bar} + set data $::gifstart + # Append a comment extension block with data "ABCD" + append data "\x21\xfe\x04" "ABCD" "\x0" + # Trailer + append data $::gifdata $::gifend +} -body { + gif1 configure -data $data -metadata {} + gif1 cget -metadata +} -cleanup { + catch {image delete gif1} +} -result {comment ABCD} + +test imgPhoto-23.19 {write: empty metadata parameter overwrites image metadata} -setup { + image create photo gif1 -data $::gifstart$::gifdata$::gifend\ + -metadata {comment bar} + set path [file join [configure -tmpdir] test.gif] +} -body { + gif1 write $path -format gif -metadata {} + image delete gif1 + image create photo gif1 -file $path + dict size [gif1 cget -metadata] +} -cleanup { + catch {image delete gif1} + file delete $path +} -result {0} + +test imgPhoto-23.20 {data: empty metadata parameter overwrites image metadata} -setup { + image create photo gif1 -data $::gifstart$::gifdata$::gifend\ + -metadata {comment bar} +} -body { + set data [gif1 data -format gif -metadata {}] + image delete gif1 + image create photo gif1 -data $data + dict size [gif1 cget -metadata] +} -cleanup { + catch {image delete gif1} + file delete $path +} -result {0} + +unset -nocomplain gifstart gifdata gifend + + catch {rename foreachPixel {}} catch {rename checkImgTrans {}} catch {rename checkImgTransLoop {}} diff --git a/tests/imgSVGnano.test b/tests/imgSVGnano.test new file mode 100644 index 0000000..1dad3a5 --- /dev/null +++ b/tests/imgSVGnano.test @@ -0,0 +1,262 @@ +# 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 © 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 from file 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} + +# Special images +test imgSVGnano-5.0 {image without any of "width", "height" and "viewbox"} -body { + image create photo foo -data\ + {<?xml version="1.0"?><!DOCTYPE svg PUBLIC\ + "-//W3C//DTD SVG 1.0//EN\"\ + "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd">\ + <svg xmlns="http://www.w3.org/2000/svg">\ + <g style="fill-opacity:0.7;">\ + <circle cx="6.5cm" cy="2cm" r="100" style="fill:green;\ + stroke:black; stroke-width:0.1cm" transform="translate(-70,150)"/>\ + </g></svg>} +} -cleanup { + rename foo "" +} -result {foo} + +test imgSVGnano-5.1 {bug ea665e08f3 - too many values in parameters of the transform attribute} -body { + # shall not loop endlessly + image create photo foo -data\ + {<?xml version="1.0"?><!DOCTYPE svg PUBLIC\ + "-//W3C//DTD SVG 1.0//EN\"\ + "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd">\ + <svg xmlns="http://www.w3.org/2000/svg">\ + <circle cx="6.5cm" cy="2cm" r="100" transform="skewX(1 1)"/>\ + </g></svg>} +} -cleanup { + rename foo "" +} -result {foo} + +test imgSVGnano-5.2 {bug d6e9b4db40 - "<svg" and ">" must be present} -body { + image create photo foo -format svg -data\ + {<?xml version="1.0"?><!DOCTYPE svg PUBLIC\ + "-//W3C//DTD SVG 1.0//EN\" \ + "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd">\ + <sERRORvBADFILEg xmlns="http://www.w3.org/2000/svg">\ + <circle cx="6.5cm" cy="2cm" r="100" transform="skewX(1 1)"/>\ + </g></svg>} +} -returnCodes error -result {couldn't recognize image data} + +};# 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 42dc327..a17146f 100644 --- a/tests/listbox.test +++ b/tests/listbox.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test out the "listbox" command # of Tk. It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1993-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1993-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -718,13 +718,13 @@ test listbox-3.60 {ListboxWidgetCmd procedure, "index" option} -body { } -result 2 test listbox-3.61 {ListboxWidgetCmd procedure, "index" option} -body { .l index -1 -} -result {-1} +} -result -1 test listbox-3.62 {ListboxWidgetCmd procedure, "index" option} -body { .l index end } -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 -1 } -cleanup { destroy .l -} -result -1 +} -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 { @@ -2854,7 +2854,7 @@ test listbox-23.4 {ConfigureListboxItem, wrong num args} -setup { set result } -cleanup { destroy .l -} -result {wrong # args: should be ".l itemconfigure index ?-option? ?value? ?-option value ...?"} +} -result {wrong # args: should be ".l itemconfigure index ?-option value ...?"} test listbox-23.5 {ConfigureListboxItem, multiple calls} -setup { destroy .l } -body { @@ -3152,7 +3152,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 @@ -3175,7 +3175,7 @@ test listbox-31.2 {<<ListboxSelect>> event on lost selection} -setup { bind .l <<ListboxSelect>> {lappend res [list [selection own] [%W curselection]]} .l insert end a b c focus -force .l - event generate .l <1> -x 5 -y 5 ; # <<ListboxSelect>> fires + event generate .l <Button-1> -x 5 -y 5 ; # <<ListboxSelect>> fires selection clear ; # <<ListboxSelect>> fires again update set res diff --git a/tests/main.test b/tests/main.test index 4a3be63..29725de 100644 --- a/tests/main.test +++ b/tests/main.test @@ -4,8 +4,8 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -27,8 +27,7 @@ test main-2.1 {Tk_MainEx: -encoding option} -constraints stdio -setup { set f [open $script w] fconfigure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} - puts -nonewline $f {puts [string equal \u20ac } - puts $f "\u20ac]; exit" + puts $f {puts [string equal \u20AC €]; exit} close $f catch {set f [open "|[list [interpreter] -encoding utf-8 script]" r]} } -body { @@ -44,8 +43,7 @@ test main-2.2 {Tk_MainEx: -encoding option} -constraints stdio -setup { set f [open $script w] fconfigure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} - puts -nonewline $f {puts [string equal \u20ac } - puts $f "\u20ac]; exit" + puts $f {puts [string equal \u20AC €]; exit} close $f catch {set f [open "|[list [interpreter] -encoding ascii script]" r]} } -body { @@ -76,8 +74,7 @@ test main-2.3 {Tk_MainEx: -encoding option} -constraints stdio -setup { set f [open $script w] fconfigure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} - puts -nonewline $f {puts [string equal \u20ac } - puts $f "\u20ac]" + puts $f {puts [string equal \u20AC €]} close $f catch {set f [open "|[list [interpreter] -enc utf-8 script]" r+]} } -body { diff --git a/tests/menu.test b/tests/menu.test index ec43ad3..fdd5969 100644 --- a/tests/menu.test +++ b/tests/menu.test @@ -1,8 +1,8 @@ # This file is a Tcl script to test menus in Tk. It is # organized in the standard fashion for Tcl tests. # -# Copyright (c) 1995-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -29,7 +29,7 @@ test menu-1.4 {Tk_MenuCmd procedure} -body { destroy .m1 menu .m1 } -cleanup { - deleteWindows + deleteWindows } -result {.m1} test menu-1.5 {Tk_MenuCmd - creating menubar} -setup { destroy .m1 @@ -38,19 +38,19 @@ test menu-1.5 {Tk_MenuCmd - creating menubar} -setup { .m1 add cascade -label Test -menu "" list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-1.6 {Tk_MenuCmd procedure menu ref no cascade} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 menu .m1 } -cleanup { - deleteWindows + deleteWindows } -result {.m1} test menu-1.7 {Tk_MenuCmd procedure one clone cascade} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 @@ -58,10 +58,10 @@ test menu-1.7 {Tk_MenuCmd procedure one clone cascade} -setup { .m1 add cascade -menu .m2 menu .m2 } -cleanup { - deleteWindows + deleteWindows } -result {.m2} test menu-1.8 {Tk_MenuCmd procedure two clone cascades} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade -menu .m2 @@ -71,10 +71,10 @@ test menu-1.8 {Tk_MenuCmd procedure two clone cascades} -setup { wm geometry .t3 +0+0 menu .m2 } -cleanup { - deleteWindows + deleteWindows } -result {.m2} test menu-1.9 {Tk_MenuCmd procedure two clone cascades different order} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 @@ -84,10 +84,10 @@ test menu-1.9 {Tk_MenuCmd procedure two clone cascades different order} -setup { wm geometry .t3 +0+0 list [menu .m2] } -cleanup { - deleteWindows + deleteWindows } -result {.m2} test menu-1.10 {Tk_MenuCmd procedure two clone cascades menus last} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 @@ -97,10 +97,10 @@ test menu-1.10 {Tk_MenuCmd procedure two clone cascades menus last} -setup { .m1 add cascade -menu .m2 list [menu .m2] } -cleanup { - deleteWindows + deleteWindows } -result {.m2} test menu-1.11 {Tk_MenuCmd procedure three clones cascades} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 @@ -112,19 +112,19 @@ test menu-1.11 {Tk_MenuCmd procedure three clones cascades} -setup { .m1 add cascade -menu .m2 list [menu .m2] } -cleanup { - deleteWindows + deleteWindows } -result {.m2} test menu-1.12 {Tk_MenuCmd procedure} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 list [menu .m1] } -cleanup { - deleteWindows + deleteWindows } -result {.m1} test menu-1.13 {Tk_MenuCmd procedure} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 @@ -132,10 +132,10 @@ test menu-1.13 {Tk_MenuCmd procedure} -setup { wm geometry .t3 +0+0 list [menu .m1] } -cleanup { - deleteWindows + deleteWindows } -result {.m1} test menu-1.14 {Tk_MenuCmd procedure} -setup { - deleteWindows + deleteWindows } -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 @@ -145,7 +145,7 @@ test menu-1.14 {Tk_MenuCmd procedure} -setup { wm geometry .t4 +0+0 list [menu .m1] } -cleanup { - deleteWindows + deleteWindows } -result {.m1} # Used for 2.1 - 2.30 tests @@ -175,6 +175,14 @@ test menu-2.6 {configuration options -activeforeground non-existent} -body { .m1 configure -activeforeground non-existent } -returnCodes error -result {unknown color name "non-existent"} +test menu-2.6a {configuration options -activerelief sunken} -body { + .m1 configure -activerelief sunken + .m1 cget -activerelief +} -result {sunken} +test menu-2.6b {configuration options -activerelief badValue} -body { + .m1 configure -activerelief badValue +} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} + test menu-2.7 {configuration options -background #ff0000} -body { .m1 configure -background #ff0000 .m1 cget -background @@ -262,11 +270,11 @@ test menu-2.27 {configuration options -takefocus {any string}} -body { test menu-2.28 {configuration options -tearoff 0} -body { .m1 configure -tearoff 0 .m1 cget -tearoff -} -result {0} +} -result 0 test menu-2.29 {configuration options -tearoff 1} -body { .m1 configure -tearoff 1 .m1 cget -tearoff -} -result {1} +} -result 1 test menu-2.30 {configuration options -tearoffcommand {any old string}} -body { .m1 configure -tearoffcommand {any old string} .m1 cget -tearoffcommand @@ -537,12 +545,12 @@ test menu-2.85 {entry configuration options 0 -columnbreak 1 tearoff} -body { test menu-2.86 {entry configuration options 1 -columnbreak 1 command} -body { .m1 entryconfigure 1 -columnbreak 1 lindex [.m1 entryconfigure 1 -columnbreak] 4 -} -result {1} +} -result 1 test menu-2.87 {entry configuration options 2 -columnbreak 1 cascade} -body { .m1 entryconfigure 2 -columnbreak 1 lindex [.m1 entryconfigure 2 -columnbreak] 4 -} -result {1} +} -result 1 test menu-2.88 {entry configuration options 3 -columnbreak 1 separator} -body { .m1 entryconfigure 3 -columnbreak 1 @@ -551,12 +559,12 @@ test menu-2.88 {entry configuration options 3 -columnbreak 1 separator} -body { test menu-2.89 {entry configuration options 4 -columnbreak 1 checkbutton} -body { .m1 entryconfigure 4 -columnbreak 1 lindex [.m1 entryconfigure 4 -columnbreak] 4 -} -result {1} +} -result 1 test menu-2.90 {entry configuration options 5 -columnbreak 1 radiobutton} -body { .m1 entryconfigure 5 -columnbreak 1 lindex [.m1 entryconfigure 5 -columnbreak] 4 -} -result {1} +} -result 1 test menu-2.91 {entry configuration options 0 -command beep tearoff} -body { .m1 entryconfigure 0 -command beep @@ -821,12 +829,12 @@ test menu-2.142 {entry configuration options 3 -indicatoron 1 separator} -body { test menu-2.143 {entry configuration options 4 -indicatoron 1 checkbutton} -body { .m1 entryconfigure 4 -indicatoron 1 lindex [.m1 entryconfigure 4 -indicatoron] 4 -} -result {1} +} -result 1 test menu-2.144 {entry configuration options 5 -indicatoron 1 radiobutton} -body { .m1 entryconfigure 5 -indicatoron 1 lindex [.m1 entryconfigure 5 -indicatoron] 4 -} -result {1} +} -result 1 test menu-2.145 {entry configuration options 0 -label test tearoff} -body { .m1 entryconfigure 0 -label test @@ -1164,12 +1172,12 @@ test menu-2.217 {entry configuration options 0 -underline 0 tearoff} -body { test menu-2.218 {entry configuration options 1 -underline 0 command} -body { .m1 entryconfigure 1 -underline 0 lindex [.m1 entryconfigure 1 -underline] 4 -} -result {0} +} -result 0 test menu-2.219 {entry configuration options 2 -underline 0 cascade} -body { .m1 entryconfigure 2 -underline 0 lindex [.m1 entryconfigure 2 -underline] 4 -} -result {0} +} -result 0 test menu-2.220 {entry configuration options 3 -underline 0 separator} -body { .m1 entryconfigure 3 -underline 0 @@ -1178,12 +1186,12 @@ test menu-2.220 {entry configuration options 3 -underline 0 separator} -body { test menu-2.221 {entry configuration options 4 -underline 0 checkbutton} -body { .m1 entryconfigure 4 -underline 0 lindex [.m1 entryconfigure 4 -underline] 4 -} -result {0} +} -result 0 test menu-2.222 {entry configuration options 5 -underline 0 radiobutton} -body { .m1 entryconfigure 5 -underline 0 lindex [.m1 entryconfigure 5 -underline] 4 -} -result {0} +} -result 0 test menu-2.223 {entry configuration options 0 -underline 3p tearoff} -body { .m1 entryconfigure 0 -underline 3p @@ -1359,7 +1367,7 @@ test menu-3.18 {MenuWidgetCmd procedure, "configure" option} -setup { llength [.m1 configure] } -cleanup { destroy .m1 -} -result {20} +} -result 21 test menu-3.19 {MenuWidgetCmd procedure, "configure" option} -setup { destroy .m1 } -body { @@ -1511,7 +1519,7 @@ test menu-3.36 {MenuWidgetCmd procedure, "entryconfigure" option} -setup { llength [.m1 entryconfigure 1] } -cleanup { destroy .m1 -} -result {15} +} -result 15 test menu-3.37 {MenuWidgetCmd procedure, "entryconfigure" option} -setup { destroy .m1 } -body { @@ -1629,7 +1637,7 @@ test menu-3.50 {MenuWidgetCmd procedure, "post" option} -constraints { destroy .m1 } -body { menu .m1 - .m1 add command -label "menu-3.53: hit Escape" -command "puts hello" + .m1 add command -label "menu-3.50: hit Escape" -command "puts hello" .m1 post 40 40 } -cleanup { destroy .m1 @@ -1656,7 +1664,7 @@ test menu-3.53 {MenuWidgetCmd procedure, "postcascade" option} -constraints { destroy .m1 .m2 } -body { menu .m1 - .m1 add command -label "menu-3.56 - hit Escape" + .m1 add command -label "menu-3.53 - hit Escape" menu .m2 .m1 post 40 40 .m1 add cascade -menu .m2 @@ -1758,7 +1766,7 @@ test menu-3.64 {MenuWidgetCmd procedure, "unpost" option} -constraints { destroy .m1 } -body { menu .m1 - .m1 add command -label "menu-3.68 - hit Escape" + .m1 add command -label "menu-3.64 - hit Escape" .m1 post 40 40 .m1 unpost } -cleanup { @@ -1779,7 +1787,7 @@ test menu-3.66a {MenuWidgetCmd procedure, "yposition" option, no tearoff} -setup .m1 yposition 1 } -cleanup { destroy .m1 -} -result {0} +} -result 0 test menu-3.66b {MenuWidgetCmd procedure, "yposition" option, with tearoff} -constraints { notAqua } -setup { @@ -1791,7 +1799,7 @@ test menu-3.66b {MenuWidgetCmd procedure, "yposition" option, with tearoff} -con .m1 yposition 1 } -cleanup { destroy .m1 -} -result {1} +} -result 1 test menu-3.66c {MenuWidgetCmd procedure, "yposition" option, with tearoff} -constraints { aqua } -setup { @@ -1803,7 +1811,7 @@ test menu-3.66c {MenuWidgetCmd procedure, "yposition" option, with tearoff} -con .m1 yposition 1 } -cleanup { destroy .m1 -} -result {0} +} -result 0 test menu-3.67 {MenuWidgetCmd procedure, bad option} -setup { destroy .m1 } -body { @@ -1813,7 +1821,7 @@ test menu-3.67 {MenuWidgetCmd procedure, bad option} -setup { destroy .m1 } -returnCodes error -result {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, xposition, or yposition} test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} -setup { - deleteWindows + deleteWindows } -body { set t .t set m1 .t.m1 @@ -1831,7 +1839,7 @@ test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} -setup { $t configure -menu "" list [winfo exists $c1] [winfo exists $c2] } -cleanup { - deleteWindows + deleteWindows } -result {1 1} test menu-3.69 {MenuWidgetCmd procedure, "xposition" option} -setup { destroy .m1 @@ -1850,6 +1858,14 @@ test menu-3.70 {MenuWidgetCmd procedure, "xposition" option} -setup { } -cleanup { destroy .m1 } -result {} +test menu-3.71 {MenuWidgetCmd procedure, "index end" option, bug [f3cd942e9e]} -setup { + destroy .m1 +} -body { + menu .m1 + list [.m1 index "end"] +} -cleanup { + destroy .m1 +} -result none test menu-4.1 {TkInvokeMenu: disabled} -setup { @@ -1869,8 +1885,8 @@ test menu-4.2 {TkInvokeMenu: tearoff} -setup { menu .m1 catch {.m1 invoke 0} } -cleanup { - deleteWindows -} -result {0} + deleteWindows +} -result 0 test menu-4.3 {TkInvokeMenu: checkbutton -on} -setup { destroy .m1 } -body { @@ -2026,7 +2042,7 @@ test menu-5.5 {DestroyMenuInstance - cascades of cloned menus} -setup { list [destroy .m2] [.m1 entrycget 1 -menu] [. configure -menu ""] [destroy .m1] } -returnCodes ok -result {{} .m2 {} {}} test menu-5.6 {DestroyMenuInstance - cascades of cloned menus} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade -menu .m2 @@ -2122,7 +2138,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 @@ -2131,7 +2147,7 @@ test menu-6.5 {TkDestroyMenu} -setup { .m1 clone .m2 destroy .m1 winfo exists .m2 -} -result {0} +} -result 0 test menu-6.6 {TkDestroyMenu} -setup { destroy .m1 .m2 } -body { @@ -2263,7 +2279,7 @@ test menu-7.4 {UnhookCascadeEntry} -setup { list [destroy .m1] [destroy .m2] } -returnCodes ok -result {{} {}} test menu-7.5 {UnhookCascadeEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .m2 @@ -2274,7 +2290,7 @@ test menu-7.5 {UnhookCascadeEntry} -setup { list [destroy .m1] [destroy .m2 .m3] } -returnCodes ok -result {{} {}} test menu-7.6 {UnhookCascadeEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .m2 @@ -2285,7 +2301,7 @@ test menu-7.6 {UnhookCascadeEntry} -setup { list [destroy .m2] [destroy .m1 .m3] } -returnCodes ok -result {{} {}} test menu-7.7 {UnhookCascadeEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .m2 @@ -2296,7 +2312,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 @@ -2367,7 +2383,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" @@ -2384,7 +2400,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 @@ -2393,7 +2409,7 @@ test menu-9.2 {ConfigureMenu} -setup { .m1 add command -label "test" list [.m1 configure -tearoff 0] [.m1 entrycget 1 -label] } -cleanup { - deleteWindows + deleteWindows } -result {{} test} test menu-9.3 {ConfigureMenu} -setup { destroy .m1 @@ -2401,7 +2417,7 @@ test menu-9.3 {ConfigureMenu} -setup { menu .m1 list [.m1 configure -postcommand "beep"] [.m1 cget -postcommand] } -cleanup { - deleteWindows + deleteWindows } -result {{} beep} test menu-9.4 {ConfigureMenu} -setup { destroy .m1 @@ -2410,7 +2426,7 @@ test menu-9.4 {ConfigureMenu} -setup { .m1 add command -label "test" .m1 configure -fg red } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-9.5 {ConfigureMenu} -setup { destroy .m1 @@ -2420,7 +2436,7 @@ test menu-9.5 {ConfigureMenu} -setup { .m1 add command -label "two" .m1 configure -fg red } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-9.6 {ConfigureMenu} -setup { destroy .m1 @@ -2431,25 +2447,25 @@ test menu-9.6 {ConfigureMenu} -setup { .m1 add command -label "three" .m1 configure -fg red } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-9.7 {ConfigureMenu} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 tearoff list [.m1 configure -fg red] [.m2 cget -fg] } -cleanup { - deleteWindows + deleteWindows } -result {{} red} test menu-9.8 {ConfigureMenu} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 tearoff list [.m2 configure -fg red] [.m1 cget -fg] } -cleanup { - deleteWindows + deleteWindows } -result {{} red} test menu-9.9 {ConfigureMenu} -setup { destroy .m1 @@ -2457,7 +2473,7 @@ test menu-9.9 {ConfigureMenu} -setup { menu .m1 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} @@ -2470,7 +2486,7 @@ test menu-10.1 {PostProcessEntry: array variable} -setup { .m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense" set foo(1) } -cleanup { - deleteWindows + deleteWindows } -result {on} test menu-10.2 {PostProcessEntry: array variable} -setup { destroy .m1 @@ -2480,7 +2496,7 @@ test menu-10.2 {PostProcessEntry: array variable} -setup { .m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense" set foo(1) } -cleanup { - deleteWindows + deleteWindows } -result {off} @@ -2492,7 +2508,7 @@ test menu-11.1 {ConfigureMenuEntry} -setup { .m1 add checkbutton -variable foo -onvalue on -offvalue off -label "Nonsense" list [.m1 entryconfigure 1 -variable bar] [.m1 entrycget 1 -variable] } -cleanup { - deleteWindows + deleteWindows } -result {{} bar} test menu-11.2 {ConfigureMenuEntry} -setup { destroy .m1 @@ -2501,7 +2517,7 @@ test menu-11.2 {ConfigureMenuEntry} -setup { .m1 add command -label "test" list [.m1 entryconfigure 1 -label ""] [.m1 entrycget 1 -label] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-11.3 {ConfigureMenuEntry} -setup { destroy .m1 @@ -2510,83 +2526,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 @@ -2599,10 +2615,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 @@ -2613,32 +2629,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 @@ -2844,35 +2860,35 @@ test menu-13.8 {TkGetMenuIndex} -setup { .m1 entrycget -1 -label } -returnCodes error -result {bad menu entry index "-1"} test menu-13.9 {TkGetMenuIndex} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" .m1 add command -label "test2" .m1 entrycget 999 -label } -cleanup { - deleteWindows + deleteWindows } -result {test2} test menu-13.10 {TkGetMenuIndex} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 insert 999 command -label "test" .m1 entrycget 1 -label } -cleanup { - deleteWindows + deleteWindows } -result {test} test menu-13.11 {TkGetMenuIndex} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "1test" .m1 entrycget 1test -label } -cleanup { - deleteWindows + deleteWindows } -result {1test} test menu-13.12 {TkGetMenuIndex} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" @@ -2880,176 +2896,176 @@ test menu-13.12 {TkGetMenuIndex} -setup { .m1 add command -label "test3" .m1 entrycget test2 -command } -cleanup { - deleteWindows + deleteWindows } -result {beep} test menu-14.1 {MenuCmdDeletedProc} -setup { - deleteWindows + deleteWindows } -body { menu .m1 destroy .m1 } -cleanup { - deleteWindows + deleteWindows } -returnCodes ok test menu-14.2 {MenuCmdDeletedProc} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 destroy .m1 } -cleanup { - deleteWindows + deleteWindows } -returnCodes ok test menu-15.1 {MenuNewEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-15.2 {MenuNewEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" .m1 add command -label "test3" .m1 insert 2 command -label "test2" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-15.3 {MenuNewEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" .m1 add command -label "test2" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-15.4 {MenuNewEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.1 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 insert foo command -label "test" } -returnCodes error -result {bad menu entry index "foo"} test menu-16.2 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" .m1 insert test command -label "foo" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.3 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 insert -1 command -label "test" } -returnCodes error -result {bad menu entry index "-1"} test menu-16.4 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 -tearoff 1 .m1 add command -label "test" .m1 insert 0 command -label "test2" .m1 entrycget 1 -label } -cleanup { - deleteWindows + deleteWindows } -result {test2} test menu-16.5 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.6 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add checkbutton } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.7 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.8 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add radiobutton } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.9 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add separator } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.10 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add blork } -returnCodes error -result {bad menu entry type "blork": must be cascade, checkbutton, command, radiobutton, or separator} test menu-16.11 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-16.12 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 .m2 clone .m3 list [.m2 add command -label "test"] [.m1 entrycget 1 -label] [.m3 entrycget 1 -label] } -cleanup { - deleteWindows + deleteWindows } -result {{} test test} test menu-16.13 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 clone .m2 .m2 clone .m3 list [.m3 add command -label "test"] [.m1 entrycget 1 -label] [.m2 entrycget 1 -label] } -cleanup { - deleteWindows + deleteWindows } -result {{} test test} test menu-16.14 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -blork } -returnCodes error -result {unknown option "-blork"} test menu-16.15 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "File" @@ -3057,20 +3073,20 @@ test menu-16.15 {MenuAddOrInsert} -setup { . configure -menu .container list [.container add cascade -label "File" -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-16.16 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .m2 set tearoff [tk::TearOffMenu .m2] list [.m2 add cascade -menu .m1] [$tearoff unpost] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-16.17 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .container @@ -3078,10 +3094,10 @@ test menu-16.17 {MenuAddOrInsert} -setup { set tearoff [tk::TearOffMenu .container] list [.container add cascade -label "File" -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-16.18 {MenuAddOrInsert} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .container @@ -3089,10 +3105,10 @@ test menu-16.18 {MenuAddOrInsert} -setup { . configure -menu .container list [.container add cascade -label "File" -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-16.19 {MenuAddOrInsert - Insert a cascade deep into the tree} -setup { - deleteWindows + deleteWindows } -body { menu .menubar menu .menubar.test -tearoff 0 @@ -3105,12 +3121,12 @@ test menu-16.19 {MenuAddOrInsert - Insert a cascade deep into the tree} -setup { [info commands .\#menubar.\#menubar\#test.\#menubar\#test\#cascade] \ [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {0 .#menubar.#menubar#test.#menubar#test#cascade {}} test menu-17.1 {MenuVarProc} -setup { - deleteWindows + deleteWindows } -body { catch {unset foo} menu .m1 @@ -3118,21 +3134,21 @@ test menu-17.1 {MenuVarProc} -setup { list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \ [unset foo] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} # menu-17.2 - Don't know how to generate the flags in the if test menu-17.2 {MenuVarProc} -setup { - deleteWindows + deleteWindows } -body { catch {unset foo} menu .m1 list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \ [set foo ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-17.3 {MenuVarProc} -setup { - deleteWindows + deleteWindows } -body { catch {unset foo} menu .m1 @@ -3140,30 +3156,30 @@ test menu-17.3 {MenuVarProc} -setup { list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \ [set foo "hello"] [unset foo] } -cleanup { - deleteWindows + deleteWindows } -result {{} hello {}} test menu-17.4 {MenuVarProc} -setup { - deleteWindows + deleteWindows } -body { menu .m1 set foo "goodbye" list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \ [set foo "hello"] [unset foo] } -cleanup { - deleteWindows + deleteWindows } -result {{} hello {}} test menu-17.5 {MenuVarProc} -setup { - deleteWindows + deleteWindows } -body { menu .m1 set foo "hello" list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \ [set foo "goodbye"] [unset foo] } -cleanup { - deleteWindows + deleteWindows } -result {{} goodbye {}} test menu-17.6 {MenuVarProc [5d991b822e]} -setup { - deleteWindows + deleteWindows } -body { # Want this not to crash menu .b @@ -3174,10 +3190,10 @@ test menu-17.6 {MenuVarProc [5d991b822e]} -setup { }}} unset var } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-17.7 {MenuVarProc [5d991b822e]} -setup { - deleteWindows + deleteWindows } -body { # Want this not to duplicate traces menu .b @@ -3188,30 +3204,30 @@ test menu-17.7 {MenuVarProc [5d991b822e]} -setup { }}} unset var } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-18.1 {TkActivateMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" .m1 activate 1 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-18.2 {TkActivateMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" .m1 activate 0 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-18.3 {TkActivateMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" @@ -3219,10 +3235,10 @@ test menu-18.3 {TkActivateMenuEntry} -setup { .m1 activate 1 .m1 activate 2 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-18.4 {TkActivateMenuEntry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label "test" @@ -3230,112 +3246,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 @@ -3343,43 +3359,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 -} -result {0} + 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 -} -result {0} + deleteWindows +} -result 0 test menu-22.3 {GetIndexFromCoords: mapped window, y only} -setup { - deleteWindows + deleteWindows } -constraints {x11} -body { menu .m1 .m1 add command -label "test" @@ -3388,10 +3404,10 @@ test menu-22.3 {GetIndexFromCoords: mapped window, y only} -setup { tkwait visibility .m1 .m1 index @5 } -cleanup { - deleteWindows -} -result {0} + deleteWindows +} -result 0 test menu-22.4 {GetIndexFromCoords: mapped window x,y} -setup { - deleteWindows + deleteWindows } -constraints {x11} -body { menu .m1 .m1 add command -label "test" @@ -3402,10 +3418,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 -} -result {0} + deleteWindows +} -result 0 test menu-22.5 {GetIndexFromCoords: mapped wide window} -setup { - deleteWindows + deleteWindows } -constraints {x11} -body { menu .m1 .m1 add command -label "test" @@ -3417,20 +3433,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 -} -result {0} + deleteWindows +} -result 0 test menu-23.1 {RecursivelyDeleteMenu} -setup { - deleteWindows + deleteWindows } -body { menu .m1 . configure -menu .m1 . configure -menu "" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-23.2 {RecursivelyDeleteMenu} -setup { - deleteWindows + deleteWindows } -body { menu .m2 .m2 add command -label "test2" @@ -3439,28 +3455,28 @@ test menu-23.2 {RecursivelyDeleteMenu} -setup { . configure -menu .m1 . configure -menu "" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-24.1 {TkNewMenuName} -setup { - deleteWindows + deleteWindows } -body { menu .m1 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-24.2 {TkNewMenuName} -setup { - deleteWindows + deleteWindows } -body { menu .m1 menu .m1\#0 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-24.3 {TkNewMenuName} -setup { - deleteWindows + deleteWindows } -body { menu .#m rename .#m hideme @@ -3470,33 +3486,33 @@ test menu-24.3 {TkNewMenuName} -setup { test menu-25.1 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.2 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.3 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" destroy .m1 menu .m1 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.4 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3504,10 +3520,10 @@ test menu-25.4 {TkSetWindowMenuBar} -setup { menu .m2 list [. configure -menu .m2] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.5 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3516,10 +3532,10 @@ test menu-25.5 {TkSetWindowMenuBar} -setup { menu .m3 list [. configure -menu .m3] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.6 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3528,10 +3544,10 @@ test menu-25.6 {TkSetWindowMenuBar} -setup { menu .m3 list [. configure -menu .m3] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.7 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3541,10 +3557,10 @@ test menu-25.7 {TkSetWindowMenuBar} -setup { .t2 configure -menu .m1 list [.t2 configure -menu .m2] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.8 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3555,10 +3571,10 @@ test menu-25.8 {TkSetWindowMenuBar} -setup { .t2 configure -menu .m1 list [. configure -menu .m2] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.9 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3570,10 +3586,10 @@ test menu-25.9 {TkSetWindowMenuBar} -setup { wm geometry .t3 +0+0 list [.t3 configure -menu .m2] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.10 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3585,10 +3601,10 @@ test menu-25.10 {TkSetWindowMenuBar} -setup { wm geometry .t3 +0+0 list [.t2 configure -menu .m2] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.11 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3600,57 +3616,57 @@ test menu-25.11 {TkSetWindowMenuBar} -setup { wm geometry .t3 +0+0 list [. configure -menu .m2] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.12 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.13 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.14 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.15 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-25.16 {TkSetWindowMenuBar} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 . configure -menu .m1 list [toplevel .t2 -menu m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {.t2 {}} test menu-26.1 {DestroyMenuHashTable} -setup { catch {interp delete testinterp} - deleteWindows + deleteWindows } -body { interp create testinterp load {} Tk testinterp @@ -3661,48 +3677,48 @@ test menu-26.1 {DestroyMenuHashTable} -setup { test menu-27.1 {GetMenuHashTable} -setup { catch {interp delete testinterp} - deleteWindows + deleteWindows } -body { interp create testinterp load {} Tk testinterp list [catch {interp eval testinterp {menu .m1}} msg] $msg [interp delete testinterp] } -cleanup { - deleteWindows + deleteWindows } -result {0 .m1 {}} test menu-28.1 {TkCreateMenuReferences - not there before} -setup { - deleteWindows + deleteWindows } -body { menu .m1 } -cleanup { - deleteWindows + deleteWindows } -result {.m1} test menu-28.2 {TkCreateMenuReferences - there already} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade -menu .m2 menu .m2 } -cleanup { - deleteWindows + deleteWindows } -result {.m2} test menu-29.1 {TkFindMenuReferences - not there} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 .m1 add cascade -menu .m2 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-30.1 {TkFindMenuReferences - there already} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 @@ -3710,38 +3726,38 @@ test menu-30.1 {TkFindMenuReferences - there already} -setup { .m1 add cascade -menu .m2 list [. configure -menu .m1] [. configure -menu ""] } -cleanup { - deleteWindows + deleteWindows } -result {{} {}} test menu-31.1 {TkFreeMenuReferences - menuPtr} -setup { - deleteWindows + deleteWindows } -body { menu .m1 destroy .m1 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-31.2 {TkFreeMenuReferences - cascadePtr} -setup { - deleteWindows + deleteWindows } -body { . configure -menu "" menu .m1 .m1 add cascade -menu .m2 .m1 entryconfigure 1 -menu .m3 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-31.3 {TkFreeMenuReferences - topLevelListPtr} -setup { - deleteWindows + deleteWindows } -body { . configure -menu .m1 . configure -menu "" } -cleanup { - deleteWindows + deleteWindows } -returnCodes ok -result {} test menu-31.4 {TkFreeMenuReferences - not empty} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add cascade -menu .m3 @@ -3749,22 +3765,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 @@ -3775,10 +3791,10 @@ test menu-32.2 {DeleteMenuCloneEntries} -setup { .m1 clone .m2 .m1 delete 2 3 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.3 {DeleteMenuCloneEntries} -setup { - deleteWindows + deleteWindows } -body { menu .m1 -tearoff 0 .m1 add command -label one @@ -3789,10 +3805,10 @@ test menu-32.3 {DeleteMenuCloneEntries} -setup { .m2 configure -tearoff 1 .m1 delete 1 2 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.4 {DeleteMenuCloneEntries} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label one @@ -3803,10 +3819,10 @@ test menu-32.4 {DeleteMenuCloneEntries} -setup { .m2 configure -tearoff 0 .m1 delete 2 3 } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.5 {DeleteMenuCloneEntries} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label one @@ -3815,29 +3831,29 @@ test menu-32.5 {DeleteMenuCloneEntries} -setup { .m1 activate one .m1 delete one } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.6 {DeleteMenuCloneEntries - reentrancy - crashes tk8.0} -setup { - deleteWindows + deleteWindows } -body { menu .m1 .m1 add command -label test \ -command ".m1 delete test ; .m1 add command -label test -command \".m1 delete test\"; .m1 delete test" .m1 invoke test } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.7 {DeleteMenuCloneEntries - one entry} -setup { - deleteWindows + deleteWindows } -body { menu .m1 -tearoff 0 .m1 add command -label Hello .m1 delete Hello } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.8 {Ensure all menu clone commands are deleted} -setup { - deleteWindows + deleteWindows } -body { # SF bug #465324 menu .menubar @@ -3851,11 +3867,11 @@ test menu-32.8 {Ensure all menu clone commands are deleted} -setup { info commands .#menubar*test* } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} -setup { set res {} - deleteWindows + deleteWindows } -body { menu .menubar . configure -menu .menubar @@ -3873,12 +3889,12 @@ test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} -setup { lappend res [.#menubar.#menubar#test entrycget 1 -menu] return $res } -cleanup { - deleteWindows + deleteWindows } -result {.menubar.cascade .#menubar.#menubar#test.#menubar#cascade .menubar.cascade .#menubar.#menubar#test.#menubar#cascade} test menu-33.1 {menu vs command hiding} -setup { - deleteWindows + deleteWindows } -body { set l [interp hidden] menu .m @@ -3896,7 +3912,7 @@ test menu-33.1 {menu vs command hiding} -setup { test menu-34.1 {menus on multiple screens - crashes tk8.3.1, Bug 5454} -constraints { altDisplay } -setup { - deleteWindows + deleteWindows } -body { toplevel .one menu .one.m @@ -3916,7 +3932,7 @@ test menu-35.1 {menu -underline string overruns Bug 1599877} -setup { update tk::TraverseToMenu . "e" } -cleanup { - deleteWindows + deleteWindows } -result {} test menu-37.1 {menubar menues cannot be posted - bug 2160206} -setup { @@ -3941,14 +3957,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> @@ -3957,7 +3973,7 @@ test menu-38.1 {Can't dismiss ttk::menubutton menu until mouse has hovered over winfo ismapped .top.mb.m } -cleanup { destroy .top.mb.m .top.m .top -} -result {0} +} -result 0 # cleanup diff --git a/tests/menuDraw.test b/tests/menuDraw.test index 9382974..2507a0e 100644 --- a/tests/menuDraw.test +++ b/tests/menuDraw.test @@ -1,8 +1,8 @@ # This file is a Tcl script to test drawing of menus in Tk. It is # organized in the standard fashion for Tcl tests. # -# Copyright (c) 1996-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -561,7 +561,7 @@ test menuDraw-15.2 {TkPostTearoffMenu - Deactivation} -setup { $tearoff index active } -cleanup { deleteWindows -} -result {none} +} -result none test menuDraw-15.3 {TkPostTearoffMenu - post command} -setup { deleteWindows } -body { diff --git a/tests/menubut.test b/tests/menubut.test index d245fd0..f8bd175 100644 --- a/tests/menubut.test +++ b/tests/menubut.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test menubuttons in Tk. It is # organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. # XXX This test file is woefully incomplete right now. If any part @@ -71,7 +71,7 @@ test menubutton-1.9 {configuration options} -body { .mb cget -bd } -cleanup { .mb configure -bd [lindex [.mb configure -bd] 3] -} -result {4} +} -result 4 test menubutton-1.10 {configuration options} -body { .mb configure -bd badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -98,7 +98,7 @@ test menubutton-1.15 {configuration options} -body { .mb cget -borderwidth } -cleanup { .mb configure -borderwidth [lindex [.mb configure -borderwidth] 3] -} -result {1} +} -result 1 test menubutton-1.16 {configuration options} -body { .mb configure -borderwidth badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -158,7 +158,7 @@ test menubutton-1.28 {configuration options} -body { .mb cget -height } -cleanup { .mb configure -height [lindex [.mb configure -height] 3] -} -result {18} +} -result 18 test menubutton-1.29 {configuration options} -body { .mb configure -height 20.0 } -returnCodes error -result {expected integer but got "20.0"} @@ -185,7 +185,7 @@ test menubutton-1.34 {configuration options} -body { .mb cget -highlightthickness } -cleanup { .mb configure -highlightthickness [lindex [.mb configure -highlightthickness] 3] -} -result {18} +} -result 18 test menubutton-1.35 {configuration options} -body { .mb configure -highlightthickness badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -213,7 +213,7 @@ test menubutton-1.38 {configuration options} -body { .mb cget -indicatoron } -cleanup { .mb configure -indicatoron [lindex [.mb configure -indicatoron] 3] -} -result {1} +} -result 1 test menubutton-1.39 {configuration options} -body { .mb configure -indicatoron no_way } -returnCodes error -result {expected boolean value but got "no_way"} @@ -237,7 +237,7 @@ test menubutton-1.43 {configuration options} -body { .mb cget -padx } -cleanup { .mb configure -padx [lindex [.mb configure -padx] 3] -} -result {12} +} -result 12 test menubutton-1.44 {configuration options} -body { .mb configure -padx 420x } -returnCodes error -result {bad screen distance "420x"} @@ -246,7 +246,7 @@ test menubutton-1.45 {configuration options} -body { .mb cget -pady } -cleanup { .mb configure -pady [lindex [.mb configure -pady] 3] -} -result {12} +} -result 12 test menubutton-1.46 {configuration options} -body { .mb configure -pady 420x } -returnCodes error -result {bad screen distance "420x"} @@ -291,7 +291,7 @@ test menubutton-1.54 {configuration options} -body { .mb cget -underline } -cleanup { .mb configure -underline [lindex [.mb configure -underline] 3] -} -result {5} +} -result 5 test menubutton-1.55 {configuration options} -body { .mb configure -underline 3p } -returnCodes error -result {expected integer but got "3p"} @@ -300,7 +300,7 @@ test menubutton-1.56 {configuration options} -body { .mb cget -width } -cleanup { .mb configure -width [lindex [.mb configure -width] 3] -} -result {402} +} -result 402 test menubutton-1.57 {configuration options} -body { .mb configure -width 3p } -returnCodes error -result {expected integer but got "3p"} @@ -309,7 +309,7 @@ test menubutton-1.58 {configuration options} -body { .mb cget -wraplength } -cleanup { .mb configure -wraplength [lindex [.mb configure -wraplength] 3] -} -result {100} +} -result 100 test menubutton-1.59 {configuration options} -body { .mb configure -wraplength 6x } -returnCodes error -result {bad screen distance "6x"} @@ -364,10 +364,10 @@ test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} -body { test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} -body { .mb configure -highlightthickness 3 .mb cget -highlightthickness -} -result {3} +} -result 3 test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} -body { llength [.mb configure] -} -result {33} +} -result 33 test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} -body { .mb configure -gorp } -returnCodes error -result {unknown option "-gorp"} diff --git a/tests/message.test b/tests/message.test index 2ca6921..941d8c8 100644 --- a/tests/message.test +++ b/tests/message.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test out the "message" command # of Tk. It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-2000 Ajuba Solutions. # All rights reserved. package require tcltest 2.2 @@ -41,7 +41,7 @@ test message-1.3 {configuration option: "aspect"} -setup { .m cget -aspect } -cleanup { destroy .m -} -result {3} +} -result 3 test message-1.4 {configuration option: "aspect"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m @@ -81,7 +81,7 @@ test message-1.7 {configuration option: "bd"} -setup { .m cget -bd } -cleanup { destroy .m -} -result {4} +} -result 4 test message-1.8 {configuration option: "bd"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m @@ -121,7 +121,7 @@ test message-1.11 {configuration option: "borderwidth"} -setup { .m cget -borderwidth } -cleanup { destroy .m -} -result {1} +} -result 1 test message-1.12 {configuration option: "borderwidth"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m @@ -261,7 +261,7 @@ test message-1.25 {configuration option: "highlightthickness"} -setup { .m cget -highlightthickness } -cleanup { destroy .m -} -result {2} +} -result 2 test message-1.26 {configuration option: "highlightthickness"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m @@ -383,7 +383,7 @@ test message-1.37 {configuration option: "width"} -setup { .m cget -width } -cleanup { destroy .m -} -result {2} +} -result 2 test message-1.38 {configuration option: "width"} -setup { message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} pack .m @@ -452,7 +452,7 @@ test message-3.5 {MessageWidgetObjCmd procedure, "configure"} -setup { llength [.m configure] } -cleanup { destroy .m -} -result {21} +} -result 21 test message-3.6 {MessageWidgetObjCmd procedure, "configure"} -setup { message .m } -body { @@ -468,7 +468,7 @@ test message-3.7 {MessageWidgetObjCmd procedure, "configure"} -setup { lindex [.m configure -bd] 4 } -cleanup { destroy .m -} -result {4} +} -result 4 test message-4.1 {Bug [5d991b822e]} { # Want this not to segfault, or write to variable with empty name diff --git a/tests/msgbox.test b/tests/msgbox.test index 4a6de57..91e52a7 100644 --- a/tests/msgbox.test +++ b/tests/msgbox.test @@ -1,8 +1,8 @@ # This file is a Tcl script to test out Tk's "tk_messageBox" command. # It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -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/obj.test b/tests/obj.test index eece58e..87e4a95 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -1,8 +1,8 @@ # This file is a Tcl script to test new object types in Tk. # It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/oldpack.test b/tests/oldpack.test index 94e0710..a1ba276 100644 --- a/tests/oldpack.test +++ b/tests/oldpack.test @@ -2,9 +2,9 @@ # "pack" command (before release 3.3). It is organized in the # standard fashion for Tcl tests. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -30,8 +30,13 @@ frame .pack.violet -width 80 -height 20 label .pack.violet.l -text P -bd 2 -relief raised place .pack.violet.l -relwidth 1.0 -relheight 1.0 +if {![catch {pack ap .pack .pack.red top}]} { + +# Don't execute any of this file if Tk is compiled with -DTCL_NO_DEPRECATED + + test oldpack-1.1 {basic positioning} -body { - pack ap .pack .pack.red top + #pack ap .pack .pack.red top update winfo geometry .pack.red } -result 10x20+45+0 @@ -452,10 +457,10 @@ test oldpack-8.2 {syntax errors} -body { } -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"} test oldpack-8.3 {syntax errors} -body { pack gorp foo -} -returnCodes error -result {bad option "gorp": must be configure, content, forget, info, propagate, or slaves} +} -returnCodes error -result {bad option "gorp": must be configure, content, forget, info, or propagate} test oldpack-8.4 {syntax errors} -body { pack a .pack -} -returnCodes error -result {bad option "a": must be configure, content, forget, info, propagate, or slaves} +} -returnCodes error -result {bad option "a": must be configure, content, forget, info, or propagate} test oldpack-8.5 {syntax errors} -body { pack after foobar } -returnCodes error -result {bad window path name "foobar"} @@ -492,7 +497,7 @@ test oldpack-8.12 {syntax errors} -body { } -returnCodes error -result {wrong # args: window ".pack.blue" should be followed by options} test oldpack-8.13 {syntax errors} -body { pack append . .pack.blue top -} -returnCodes error -result {can't pack .pack.blue inside .} +} -returnCodes error -result {can't pack ".pack.blue" inside "."} test oldpack-8.14 {syntax errors} -body { pack append .pack .pack.blue f } -returnCodes error -result {bad option "f": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame} @@ -544,6 +549,7 @@ test oldpack-9.3 {information output} -body { [pack info .pack.green] [pack info .pack.violet] } -result {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}} +} destroy .pack # cleanup diff --git a/tests/option.test b/tests/option.test index 5e1568e..5e29344 100644 --- a/tests/option.test +++ b/tests/option.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test out the option-handling facilities # of Tk. It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -401,7 +401,7 @@ test option-15.10 {database files} -body { } -returnCodes error -result {missing colon on line 2} set option3 [file join [testsDirectory] option.file3] option read $option3 -test option-15.11 {database files} {option get . {x 4} color} br\xf3wn +test option-15.11 {database files} {option get . {x 4} color} brówn test option-16.1 {ReadOptionFile} -body { set option4 [makeFile {} option.file3] diff --git a/tests/pack.test b/tests/pack.test index f365959..a17de62 100644 --- a/tests/pack.test +++ b/tests/pack.test @@ -1,9 +1,9 @@ -# This file is a Tcl script to test out the "pack" command -# of Tk. It is organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test out the "pack" command of Tk. It is +# organized in the standard fashion for Tcl tests. # -# Copyright (c) 1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -30,7 +30,7 @@ foreach i {a b c d} { .pack.b config -width 50 -height 30 .pack.c config -width 80 -height 80 .pack.d config -width 40 -height 30 - + test pack-1.1 {-side option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -233,7 +233,6 @@ test pack-2.21 {x padding and filling} -setup { update list [winfo geometry .pack.a] [winfo geometry .pack.b] } -result {280x40+5+0 300x160+0+40} - test pack-2.22 {x padding and filling} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -253,7 +252,6 @@ test pack-2.23 {x padding and filling} -setup { expr {$res1 eq $res2} } -result 1 - test pack-3.1 {y padding and filling} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -422,7 +420,6 @@ test pack-3.21 {y padding and filling} -setup { update list [winfo geometry .pack.a] [winfo geometry .pack.b] } -result {20x50+140+1 300x130+0+70} - test pack-3.22 {y padding and filling} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -442,7 +439,6 @@ test pack-3.23 {y padding and filling} -setup { expr {$res1 eq $res2} } -result 1 - test pack-4.1 {anchors} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -507,7 +503,6 @@ test pack-4.9 {anchors} -setup { winfo geometry .pack.a } -result {30x70+135+65} - # Repeat above tests, but with a frame that isn't at (0,0), so that # we can be sure that the frame offset is being added in correctly. @@ -593,7 +588,6 @@ test pack-5.9 {more anchors} -setup { winfo geometry .pack.b } -result {60x60+160+90} - test pack-6.1 {-expand option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -699,7 +693,6 @@ test pack-6.11 {-expand option} -setup { list [winfo geometry .pack.a] [winfo geometry .pack.b] \ [winfo geometry .pack.c] [winfo geometry .pack.d] } -result {100x200+0+0 200x100+100+0 160x100+140+100 40x100+100+100} - test pack-6.12 {-expand option} -setup { toplevel .pack2 -height 400 -width 400 wm geometry .pack2 +0+0 @@ -734,7 +727,6 @@ test pack-6.13 {-expand option} -setup { destroy .pack2 } -result {38x42+181+45 38x42+181+178 38x42+181+312} - wm geometry .pack {} test pack-7.1 {requesting size for parent} -setup { pack forget .pack.a .pack.b .pack.c .pack.d @@ -793,7 +785,6 @@ test pack-7.7 {requesting size for parent} -setup { list [winfo reqwidth .pack] [winfo reqheight .pack] } -result {100 110} - # For the tests below, create a couple of "pad" windows to shrink # the available space for the remaining windows. The tests have to # be done this way rather than shrinking the whole window, because @@ -874,7 +865,6 @@ test pack-8.9 {insufficient space} -body { } -result {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1} pack forget .pack.right .pack.bottom - test pack-9.1 {window ordering} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -947,7 +937,6 @@ test pack-9.10 {window ordering} -setup { pack content .pack } -result {.pack.a .pack.c .pack.d .pack.b} - test pack-10.1 {retaining/clearing configuration state} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -977,7 +966,7 @@ test pack-10.4 {bad -in window does not change container window} -setup { } -body { winfo manager .pack.a pack .pack.a -in .pack.a -} -returnCodes error -result {can't pack .pack.a inside itself} +} -returnCodes error -result {can't pack ".pack.a" inside itself} test pack-10.5 {prevent management loops} -body { frame .f1 frame .f2 @@ -986,7 +975,7 @@ test pack-10.5 {prevent management loops} -body { } -cleanup { destroy .f1 destroy .f2 -} -returnCodes error -result {can't put .f2 inside .f1, would cause management loop} +} -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 @@ -998,8 +987,7 @@ test pack-10.6 {prevent management loops} -body { destroy .f1 destroy .f2 destroy .f3 -} -returnCodes error -result {can't put .f3 inside .f1, would cause management loop} - +} -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 @@ -1135,7 +1123,6 @@ test pack-11.19 {info option} -setup { lindex $i [expr [lsearch -exact $i -side]+1] } -result right - test pack-12.1 {command options and errors} -body { pack } -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"} @@ -1296,18 +1283,18 @@ test pack-12.33 {command options and errors} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { pack .pack.a -in . -} -returnCodes error -result {can't pack .pack.a inside .} +} -returnCodes error -result {can't pack ".pack.a" inside "."} test pack-12.34 {command options and errors} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { frame .pack.a.a pack .pack.a.a -in .pack.b -} -returnCodes error -result {can't pack .pack.a.a inside .pack.b} +} -returnCodes error -result {can't pack ".pack.a.a" inside ".pack.b"} test pack-12.35 {command options and errors} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { pack .pack.a -in .pack.a -} -returnCodes error -result {can't pack .pack.a inside itself} +} -returnCodes error -result {can't pack ".pack.a" inside itself} test pack-12.36 {command options and errors} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -1375,8 +1362,7 @@ test pack-12.46 {command options and errors} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { pack lousy .pack -} -returnCodes error -result {bad option "lousy": must be configure, content, forget, info, propagate, or slaves} - +} -returnCodes error -result {bad option "lousy": must be configure, content, forget, info, or propagate} test pack-13.1 {window deletion} -setup { pack forget .pack.a .pack.b .pack.c .pack.d .pack.right .pack.bottom @@ -1391,7 +1377,6 @@ test pack-13.1 {window deletion} -setup { [winfo geometry .pack.b] [winfo geometry .pack.c]] } -result {{.pack.right .pack.bottom .pack.a .pack.b .pack.c} 20x40+30+0 50x30+15+40 80x80+0+70} - test pack-14.1 {respond to changes in expansion} -setup { pack forget .pack.a .pack.b .pack.c .pack.d .pack.right .pack.bottom } -body { @@ -1517,7 +1502,6 @@ test pack-15.5 {managing geometry with -in option} -setup { destroy .pack.f1 .pack.f2 } -result {50x16+25+22 1 50x16+25+22 0} - test pack-16.1 {geometry manager name} -setup { pack forget .pack.a .pack.b .pack.c .pack.d set result {} @@ -1529,7 +1513,6 @@ test pack-16.1 {geometry manager name} -setup { lappend result [winfo manager .pack.a] } -result {{} pack {}} - test pack-17.1 {PackLostContentProc procedure} -setup { pack forget .pack.a .pack.b .pack.c .pack.d } -body { @@ -1565,7 +1548,6 @@ test pack-18.1 {unmap content when container unmapped} -constraints { } -setup { eval destroy [winfo child .pack] } -body { - # adjust the position of .pack before test to avoid a screen switch # that occurs with window managers that have desktops four times as big # as the screen (screen switch causes scale and other tests to fail). @@ -1595,7 +1577,6 @@ test pack-18.1 {unmap content when container unmapped} -constraints { test pack-18.2 {unmap content when container unmapped} -constraints {failsOnUbuntu failsOnXQuarz} -setup { eval destroy [winfo child .pack] } -body { - # adjust the position of .pack before test to avoid a screen switch # that occurs with window managers that have desktops four times as big # as the screen (screen switch causes scale and other tests to fail). @@ -1618,7 +1599,6 @@ test pack-18.2 {unmap content when container unmapped} -constraints {failsOnUbun lappend result [winfo ismapped .pack.b] } -result {1 0 100 30 0 1} - test pack-19.1 {test respect for internalborder} -setup { catch {eval pack forget [pack content .pack]} destroy .pack.l .pack.lf @@ -1656,10 +1636,98 @@ test pack-19.2 {test support for minreqsize} -setup { destroy .pack.l .pack.lf } -result {162x127+0+0 172x112+0+0} - +test pack-20.1 {<<NoManagedChild>> fires on last pack forget} -setup { + global A + unset -nocomplain A +} -body { + pack [frame .1] + update + bind . <<NoManagedChild>> {set A 1} + pack forget .1 + update + info exists A +} -cleanup { + bind . <<NoManagedChild>> {} + destroy .1 +} -result 1 +test pack-20.2 {<<NoManagedChild>> fires on last packed child destruction} -setup { + global A + unset -nocomplain A +} -body { + pack [frame .1] + update + bind . <<NoManagedChild>> {incr A} + destroy .1 + update + set A +} -cleanup { + bind . <<NoManagedChild>> {} + destroy .1 +} -result 1 +test pack-20.3 {<Configure> does not fire on last pack forget} -setup { + global A + unset -nocomplain A +} -body { + pack [frame .1] + update + bind . <Configure> {set A 1} + pack forget .1 + update + info exists A +} -cleanup { + bind . <Configure> {} + destroy .1 +} -result 0 +test pack-20.4 {<<NoManagedChild>> does not fire on forelast pack forget} -setup { + global A + unset -nocomplain A +} -body { + pack [frame .1] + pack [frame .2] + update + bind . <<NoManagedChild>> {set A 1} + pack forget .1 + update + info exists A +} -cleanup { + bind . <<NoManagedChild>> {} + destroy .1 .2 +} -result 0 +test pack-20.5 {<Configure> does not fire on last pack forget} -setup { + global A + unset -nocomplain A +} -body { + pack [frame .1] + pack [frame .2] + update + bind . <Configure> {set A 1} + pack forget .1 + update + info exists A +} -cleanup { + bind . <Configure> {} + destroy .1 .2 +} -result 1 +test pack-20.6 {<<NoManagedChild>> does not fire on last pack forget if propagation is off} -setup { + global A + unset -nocomplain A +} -body { + pack [frame .1] + pack propagate . 0 + update + bind . <<NoManagedChild>> {set A 1} + pack forget .1 + update + info exists A +} -cleanup { + bind . <<NoManagedChild>> {} + destroy .1 +} -result 0 + # cleanup cleanupTests return - - +# Local Variables: +# mode: tcl +# End: diff --git a/tests/packgrid.test b/tests/packgrid.test index 6dfba25..db49f60 100644 --- a/tests/packgrid.test +++ b/tests/packgrid.test @@ -2,7 +2,7 @@ # "grid" commands. # It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 2008 Peter Spjuth +# Copyright © 2008 Peter Spjuth # All rights reserved. package require tcltest 2.2 @@ -22,7 +22,7 @@ test packgrid-1.1 {pack and grid in same container window} -setup { } -returnCodes error -cleanup { destroy .p destroy .g -} -result {cannot use geometry manager pack inside . which already has slaves managed by grid} +} -result {cannot use geometry manager pack inside . because grid is already managing it's content windows} test packgrid-1.2 {pack and grid in same container window} -setup { grid propagate . true @@ -36,7 +36,7 @@ test packgrid-1.2 {pack and grid in same container window} -setup { } -returnCodes error -cleanup { destroy .p destroy .g -} -result {cannot use geometry manager grid inside . which already has slaves managed by pack} +} -result {cannot use geometry manager grid inside . because pack is already managing it's content windows} test packgrid-1.3 {pack and grid in same container window} -setup { grid propagate . false @@ -137,7 +137,7 @@ test packgrid-2.1 {pack and grid in same container window, change propagation} - } -returnCodes error -cleanup { destroy .p destroy .g -} -result {cannot use geometry manager grid inside . which already has slaves managed by pack} +} -result {cannot use geometry manager grid inside . because pack is already managing it's content windows} test packgrid-2.2 {pack and grid in same container window, change propagation} -setup { grid propagate . true @@ -153,7 +153,7 @@ test packgrid-2.2 {pack and grid in same container window, change propagation} - destroy .p update destroy .g -} -result {cannot use geometry manager pack inside . which already has slaves managed by grid} +} -result {cannot use geometry manager pack inside . because grid is already managing it's content windows} test packgrid-2.3 {pack and grid in same container window, change propagation} -setup { grid propagate . false @@ -170,7 +170,7 @@ test packgrid-2.3 {pack and grid in same container window, change propagation} - } -returnCodes error -cleanup { destroy .p destroy .g -} -result {cannot use geometry manager pack inside . which already has slaves managed by grid} +} -result {cannot use geometry manager pack inside . because grid is already managing it's content windows} test packgrid-2.4 {pack and grid in same container window, change propagation} -setup { grid propagate . false @@ -186,7 +186,7 @@ test packgrid-2.4 {pack and grid in same container window, change propagation} - } -returnCodes error -cleanup { destroy .p destroy .g -} -result {cannot use geometry manager grid inside . which already has slaves managed by pack} +} -result {cannot use geometry manager grid inside . because pack is already managing it's content windows} test packgrid-3.1 {stealing content} -setup { grid propagate . true @@ -229,7 +229,7 @@ test packgrid-3.3 {stealing content} -setup { } -returnCodes error -cleanup { destroy .p destroy .g -} -result {cannot use geometry manager pack inside . which already has slaves managed by grid} +} -result {cannot use geometry manager pack inside . because grid is already managing it's content windows} test packgrid-3.4 {stealing content} -setup { grid propagate . true @@ -244,7 +244,7 @@ test packgrid-3.4 {stealing content} -setup { } -returnCodes error -cleanup { destroy .p destroy .g -} -result {cannot use geometry manager grid inside . which already has slaves managed by pack} +} -result {cannot use geometry manager grid inside . because pack is already managing it's content windows} test packgrid-4.1 {content stolen after container destruction - bug [aa7679685e]} -setup { frame .f diff --git a/tests/panedwindow.test b/tests/panedwindow.test index bb3a7fd..f8fb3ae 100644 --- a/tests/panedwindow.test +++ b/tests/panedwindow.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test entry widgets in Tk. It is # organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -4562,7 +4562,7 @@ test panedwindow-22.2 {PanedWindowReqProc, react to pane geometry changes} -setu expr {[lindex $result 1] - [lindex $result 0]} } -cleanup { deleteWindows -} -result {10} +} -result 10 test panedwindow-23.1 {ConfigurePanes, can't add panedwindow to itself} -setup { @@ -5461,7 +5461,7 @@ test panedwindow-27.2 {destroy the window cleanly on rename [Bug #616589]} -setu winfo exists .p } -cleanup { deleteWindows -} -result {0} +} -result 0 test panedwindow-28.1 {resizing width} -setup { diff --git a/tests/pkgconfig.test b/tests/pkgconfig.test new file mode 100644 index 0000000..7d17916 --- /dev/null +++ b/tests/pkgconfig.test @@ -0,0 +1,69 @@ +# -*- 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 © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 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 + +testConstraint nodeprecated [expr {"nodeprecated" ni [tk::pkgconfig list]}] + +test pkgconfig-1.1 {query keys} -constraints {nonwin nodeprecated} -body { + lsort [::tk::pkgconfig list] +} -match glob -result [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 a809095..f0dd513 100644 --- a/tests/place.test +++ b/tests/place.test @@ -1,8 +1,8 @@ # This file is a Tcl script to test out the "place" command. It is # organized in the standard fashion for Tcl tests. # -# Copyright (c) 1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -65,7 +65,7 @@ test place-2.2 {ConfigureContent procedure, -height option} -setup { place .t.f2 -in .t.f -height 40 update winfo height .t.f2 -} -result {40} +} -result 40 test place-2.3 {ConfigureContent procedure, -height option} -setup { place forget .t.f2 } -body { @@ -74,7 +74,7 @@ test place-2.3 {ConfigureContent procedure, -height option} -setup { place .t.f2 -height {} update winfo height .t.f2 -} -result {60} +} -result 60 test place-3.1 {ConfigureContent procedure, -relheight option} -body { @@ -86,7 +86,7 @@ test place-3.2 {ConfigureContent procedure, -relheight option} -setup { place .t.f2 -in .t.f -relheight .5 update winfo height .t.f2 -} -result {40} +} -result 40 test place-3.3 {ConfigureContent procedure, -relheight option} -setup { place forget .t.f2 } -body { @@ -95,14 +95,14 @@ test place-3.3 {ConfigureContent procedure, -relheight option} -setup { place .t.f2 -relheight {} update winfo height .t.f2 -} -result {60} +} -result 60 test place-4.1 {ConfigureContent procedure, bad -in options} -setup { place forget .t.f2 } -body { place .t.f2 -in .t.f2 -} -returnCodes error -result {can't place .t.f2 relative to itself} +} -returnCodes error -result {can't place ".t.f2" relative to itself} test place-4.2 {ConfigureContent procedure, bad -in option} -setup { place forget .t.f2 } -body { @@ -115,23 +115,23 @@ test place-4.3 {ConfigureContent procedure, bad -in option} -setup { } -body { winfo manager .t.f2 place .t.f2 -in .t.f2 -} -returnCodes error -result {can't place .t.f2 relative to itself} +} -returnCodes error -result {can't place ".t.f2" relative to itself} test place-4.4 {ConfigureContent procedure, bad -in option} -setup { place forget .t.f2 } -body { place .t.f2 -in . -} -returnCodes error -result {can't place .t.f2 relative to .} +} -returnCodes error -result {can't place ".t.f2" relative to "."} test place-4.5 {ConfigureContent 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} +} -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} +} -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 @@ -140,7 +140,7 @@ test place-4.7 {prevent management loops} -setup { 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} +} -returnCodes error -result {can't put ".t.f3" inside ".t.f1": would cause management loop} test place-5.1 {ConfigureContent procedure, -relwidth option} -body { place .t.f2 -relwidth abcd @@ -151,7 +151,7 @@ test place-5.2 {ConfigureContent procedure, -relwidth option} -setup { place .t.f2 -in .t.f -relwidth .5 update winfo width .t.f2 -} -result {75} +} -result 75 test place-5.3 {ConfigureContent procedure, -relwidth option} -setup { place forget .t.f2 } -body { @@ -160,7 +160,7 @@ test place-5.3 {ConfigureContent procedure, -relwidth option} -setup { place .t.f2 -relwidth {} update winfo width .t.f2 -} -result {30} +} -result 30 test place-6.1 {ConfigureContent procedure, -width option} -body { place .t.f2 -width abcd @@ -171,7 +171,7 @@ test place-6.2 {ConfigureContent procedure, -width option} -setup { place .t.f2 -in .t.f -width 100 update winfo width .t.f2 -} -result {100} +} -result 100 test place-6.3 {ConfigureContent procedure, -width option} -setup { place forget .t.f2 } -body { @@ -180,7 +180,7 @@ test place-6.3 {ConfigureContent procedure, -width option} -setup { place .t.f2 -width {} update winfo width .t.f2 -} -result {30} +} -result 30 test place-7.1 {ReconfigurePlacement procedure, computing position} -setup { @@ -332,7 +332,7 @@ test place-9.5 {PlaceObjCmd} -setup { place badopt .foo } -cleanup { destroy .foo -} -returnCodes error -result {bad option "badopt": must be configure, content, forget, info, or slaves} +} -returnCodes error -result {bad option "badopt": must be configure, content, forget, or info} test place-9.6 {PlaceObjCmd, configure errors} -setup { destroy .foo } -body { @@ -507,16 +507,17 @@ test place-14.1 {memory leak testing} -constraints memory -setup { frame .f frame .f.f stress { - place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}] - place forget .f.f + place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}] + place forget .f.f } { - place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}] - pack .f.f + place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}] + pack .f.f + update; # Needed because of TIP #518, handle <<NoManagedChild>> event. } { - place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}] - destroy .f - frame .f - frame .f.f + place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}] + destroy .f + frame .f + frame .f.f } } -cleanup { destroy .f diff --git a/tests/raise.test b/tests/raise.test index f8674fc..7a3a063 100644 --- a/tests/raise.test +++ b/tests/raise.test @@ -3,9 +3,9 @@ # stacking order. It is organized in the standard fashion # for Tcl tests. # -# Copyright (c) 1993-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1993-1994 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/safe.test b/tests/safe.test index 31cb1b7..aeed361 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test the Safe Tk facility. It is organized in # the standard fashion for Tk tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/safePrimarySelection.test b/tests/safePrimarySelection.test index 8475ce3..fd237f0 100644 --- a/tests/safePrimarySelection.test +++ b/tests/safePrimarySelection.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test entry widgets in Tk. It is # organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -63,7 +63,7 @@ proc ::_test_tmp::unsafeInterp {name} { set ::_test_tmp::script { - package require Tk + package require tk namespace eval ::_test_tmp {} proc ::_test_tmp::getPrimarySelection {} { @@ -281,7 +281,7 @@ test safePrimarySelection-1.6 {parent interpreter, spinbox spun, no existing sel } -cleanup { destroy {*}[winfo children .] ::_test_tmp::clearPrimarySelection -} -result {2} +} -result 2 test safePrimarySelection-1.7 {parent interpreter, spinbox spun/selected/spun, no existing selection} -setup { catch {interp delete child2} @@ -293,7 +293,7 @@ test safePrimarySelection-1.7 {parent interpreter, spinbox spun/selected/spun, n } -cleanup { destroy {*}[winfo children .] ::_test_tmp::clearPrimarySelection -} -result {3} +} -result 3 test safePrimarySelection-1.8 {parent interpreter, ttk::spinbox as entry, no existing selection} -setup { catch {interp delete child2} @@ -317,7 +317,7 @@ test safePrimarySelection-1.9 {parent interpreter, ttk::spinbox spun, no existin } -cleanup { destroy {*}[winfo children .] ::_test_tmp::clearPrimarySelection -} -result {2} +} -result 2 test safePrimarySelection-1.10 {parent interpreter, ttk::spinbox spun/selected/spun, no existing selection} -setup { catch {interp delete child2} @@ -329,7 +329,7 @@ test safePrimarySelection-1.10 {parent interpreter, ttk::spinbox spun/selected/s } -cleanup { destroy {*}[winfo children .] ::_test_tmp::clearPrimarySelection -} -result {3} +} -result 3 test safePrimarySelection-2.1 {child interpreter, text, no existing selection} -setup { catch {interp delete child2} @@ -431,7 +431,7 @@ test safePrimarySelection-2.6 {child interpreter, spinbox spun, no existing sele destroy {*}[winfo children .] unset int2 ::_test_tmp::clearPrimarySelection -} -result {2} +} -result 2 test safePrimarySelection-2.7 {child interpreter, spinbox spun/selected/spun, no existing selection} -setup { catch {interp delete child2} @@ -448,7 +448,7 @@ test safePrimarySelection-2.7 {child interpreter, spinbox spun/selected/spun, no destroy {*}[winfo children .] unset int2 ::_test_tmp::clearPrimarySelection -} -result {3} +} -result 3 test safePrimarySelection-2.8 {child interpreter, ttk::spinbox as entry, no existing selection} -setup { catch {interp delete child2} @@ -482,7 +482,7 @@ test safePrimarySelection-2.9 {child interpreter, ttk::spinbox spun, no existing destroy {*}[winfo children .] unset int2 ::_test_tmp::clearPrimarySelection -} -result {2} +} -result 2 test safePrimarySelection-2.10 {child interpreter, ttk::spinbox spun/selected/spun, no existing selection} -setup { catch {interp delete child2} @@ -499,7 +499,7 @@ test safePrimarySelection-2.10 {child interpreter, ttk::spinbox spun/selected/sp destroy {*}[winfo children .] unset int2 ::_test_tmp::clearPrimarySelection -} -result {3} +} -result 3 test safePrimarySelection-3.1 {IMPORTANT, safe interpreter, text, no existing selection} -setup { catch {interp delete child2} @@ -781,7 +781,7 @@ test safePrimarySelection-4.6 {parent interpreter, spinbox spun, existing select } -cleanup { destroy {*}[winfo children .] ::_test_tmp::clearPrimarySelection -} -result {2} +} -result 2 test safePrimarySelection-4.7 {parent interpreter, spinbox spun/selected/spun, existing selection} -setup { catch {interp delete child2} @@ -793,7 +793,7 @@ test safePrimarySelection-4.7 {parent interpreter, spinbox spun/selected/spun, e } -cleanup { destroy {*}[winfo children .] ::_test_tmp::clearPrimarySelection -} -result {3} +} -result 3 test safePrimarySelection-4.8 {parent interpreter, ttk::spinbox as entry, existing selection} -setup { catch {interp delete child2} @@ -817,7 +817,7 @@ test safePrimarySelection-4.9 {parent interpreter, ttk::spinbox spun, existing s } -cleanup { destroy {*}[winfo children .] ::_test_tmp::clearPrimarySelection -} -result {2} +} -result 2 test safePrimarySelection-4.10 {parent interpreter, ttk::spinbox spun/selected/spun, existing selection} -setup { catch {interp delete child2} @@ -829,7 +829,7 @@ test safePrimarySelection-4.10 {parent interpreter, ttk::spinbox spun/selected/s } -cleanup { destroy {*}[winfo children .] ::_test_tmp::clearPrimarySelection -} -result {3} +} -result 3 test safePrimarySelection-5.1 {child interpreter, text, existing selection} -setup { catch {interp delete child2} @@ -931,7 +931,7 @@ test safePrimarySelection-5.6 {child interpreter, spinbox spun, existing selecti destroy {*}[winfo children .] unset int2 ::_test_tmp::clearPrimarySelection -} -result {2} +} -result 2 test safePrimarySelection-5.7 {child interpreter, spinbox spun/selected/spun, existing selection} -setup { catch {interp delete child2} @@ -948,7 +948,7 @@ test safePrimarySelection-5.7 {child interpreter, spinbox spun/selected/spun, ex destroy {*}[winfo children .] unset int2 ::_test_tmp::clearPrimarySelection -} -result {3} +} -result 3 test safePrimarySelection-5.8 {child interpreter, ttk::spinbox as entry, existing selection} -setup { catch {interp delete child2} @@ -982,7 +982,7 @@ test safePrimarySelection-5.9 {child interpreter, ttk::spinbox spun, existing se destroy {*}[winfo children .] unset int2 ::_test_tmp::clearPrimarySelection -} -result {2} +} -result 2 test safePrimarySelection-5.10 {child interpreter, ttk::spinbox spun/selected/spun, existing selection} -setup { catch {interp delete child2} @@ -999,7 +999,7 @@ test safePrimarySelection-5.10 {child interpreter, ttk::spinbox spun/selected/sp destroy {*}[winfo children .] unset int2 ::_test_tmp::clearPrimarySelection -} -result {3} +} -result 3 test safePrimarySelection-6.1 {IMPORTANT, safe interpreter, text, existing selection} -setup { catch {interp delete child2} diff --git a/tests/scale.test b/tests/scale.test index 34f2cd9..9c1ab21 100644 --- a/tests/scale.test +++ b/tests/scale.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test out the "scale" command # of Tk. It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -46,7 +46,7 @@ test scale-1.5 {configuration options} -body { .s cget -bd } -cleanup { .s configure -bd [lindex [.s configure -bd] 3] -} -result {4} +} -result 4 test scale-1.6 {configuration options} -body { .s configure -bd badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -73,7 +73,7 @@ test scale-1.11 {configuration options} -body { .s cget -borderwidth } -cleanup { .s configure -borderwidth [lindex [.s configure -borderwidth] 3] -} -result {1} +} -result 1 test scale-1.12 {configuration options} -body { .s configure -borderwidth badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -97,7 +97,7 @@ test scale-1.17 {configuration options} -body { .s cget -digits } -cleanup { .s configure -digits [lindex [.s configure -digits] 3] -} -result {5} +} -result 5 test scale-1.18 {configuration options} -body { .s configure -digits badValue } -returnCodes error -result {expected integer but got "badValue"} @@ -157,7 +157,7 @@ test scale-1.31 {configuration options} -body { .s cget -highlightthickness } -cleanup { .s configure -highlightthickness [lindex [.s configure -highlightthickness] 3] -} -result {2} +} -result 2 test scale-1.32 {configuration options} -body { .s configure -highlightthickness badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -172,7 +172,7 @@ test scale-1.35 {configuration options} -body { .s cget -length } -cleanup { .s configure -length [lindex [.s configure -length] 3] -} -result {130} +} -result 130 test scale-1.36 {configuration options} -body { .s configure -length badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -205,7 +205,7 @@ test scale-1.43 {configuration options} -body { .s cget -repeatdelay } -cleanup { .s configure -repeatdelay [lindex [.s configure -repeatdelay] 3] -} -result {14} +} -result 14 test scale-1.44 {configuration options} -body { .s configure -repeatdelay bogus } -returnCodes error -result {expected integer but got "bogus"} @@ -214,7 +214,7 @@ test scale-1.45 {configuration options} -body { .s cget -repeatinterval } -cleanup { .s configure -repeatinterval [lindex [.s configure -repeatinterval] 3] -} -result {14} +} -result 14 test scale-1.46 {configuration options} -body { .s configure -repeatinterval bogus } -returnCodes error -result {expected integer but got "bogus"} @@ -232,7 +232,7 @@ test scale-1.49 {configuration options} -body { .s cget -showvalue } -cleanup { .s configure -showvalue [lindex [.s configure -showvalue] 3] -} -result {0} +} -result 0 test scale-1.50 {configuration options} -body { .s configure -showvalue badValue } -returnCodes error -result {expected boolean value but got "badValue"} @@ -241,7 +241,7 @@ test scale-1.51 {configuration options} -body { .s cget -sliderlength } -cleanup { .s configure -sliderlength [lindex [.s configure -sliderlength] 3] -} -result {86} +} -result 86 test scale-1.52 {configuration options} -body { .s configure -sliderlength badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -313,7 +313,7 @@ test scale-1.69 {configuration options} -body { .s cget -width } -cleanup { .s configure -width [lindex [.s configure -width] 3] -} -result {32} +} -result 32 test scale-1.70 {configuration options} -body { .s configure -width badValue } -returnCodes error -result {bad screen distance "badValue"} @@ -359,7 +359,7 @@ test scale-3.4 {ScaleWidgetCmd procedure, cget option} -body { test scale-3.5 {ScaleWidgetCmd procedure, cget option} -body { .s configure -highlightthickness 2 .s cget -highlightthickness -} -result {2} +} -result 2 test scale-3.6 {ScaleWidgetCmd procedure, configure option} -body { list [llength [.s configure]] [lindex [.s configure] 6] } -result {33 {-command command Command {} {}}} @@ -466,7 +466,7 @@ test scale-3.28 {ScaleWidgetCmd procedure, set option} -body { .s set 181 .s configure -state normal .s get -} -result {118} +} -result 118 test scale-3.29 {ScaleWidgetCmd procedure} -body { .s dumb } -returnCodes error -result {bad option "dumb": must be cget, configure, coords, get, identify, or set} @@ -588,27 +588,27 @@ test scale-6.1 {ComputeFormat procedure} -body { .s configure -from 10 -to 100 -resolution 10 .s set 49.3 .s get -} -result {50} +} -result 50 test scale-6.2 {ComputeFormat procedure} -body { .s configure -from 100 -to 1000 -resolution 100 .s set 493 .s get -} -result {500} +} -result 500 test scale-6.3 {ComputeFormat procedure} -body { .s configure -from 1000 -to 10000 -resolution 1000 .s set 4930 .s get -} -result {5000} +} -result 5000 test scale-6.4 {ComputeFormat procedure} -body { .s configure -from 10000 -to 100000 -resolution 10000 .s set 49000 .s get -} -result {50000} +} -result 50000 test scale-6.5 {ComputeFormat procedure} -body { .s configure -from 100000 -to 1000000 -resolution 100000 .s set 493000 .s get -} -result {500000} +} -result 500000 test scale-6.6 {ComputeFormat procedure} -constraints { nonPortable } -body { @@ -617,7 +617,7 @@ test scale-6.6 {ComputeFormat procedure} -constraints { .s configure -from 1000000 -to 10000000 -resolution 1000000 .s set 4930000 .s get -} -result {5000000} +} -result 5000000 test scale-6.7 {ComputeFormat procedure} -body { .s configure -from 1000000000 -to 10000000000 -resolution 1000000000 .s set 4930000000 @@ -652,7 +652,7 @@ test scale-6.13 {ComputeFormat procedure} -body { .s configure -from .000001 -to .00001 -resolution .000001 .s set .000006 expr {[.s get] == 6.0e-06} -} -result {1} +} -result 1 test scale-6.14 {ComputeFormat procedure} -body { .s configure -to .00001 -from .0001 -resolution .00001 .s set .00006 @@ -662,17 +662,17 @@ test scale-6.15 {ComputeFormat procedure} -body { .s configure -to .000001 -from .00001 -resolution .000001 .s set .000006 expr {[.s get] == 6.0e-06} -} -result {1} +} -result 1 test scale-6.16 {ComputeFormat procedure} -body { .s configure -from .00001 -to .0001 -resolution .00001 -digits 1 .s set .00006 expr {[.s get] == 6e-05} -} -result {1} +} -result 1 test scale-6.17 {ComputeFormat procedure} -body { .s configure -from 10000000 -to 100000000 -resolution 10000000 -digits 3 .s set 49300000 .s get -} -result {50000000} +} -result 50000000 test scale-6.18 {ComputeFormat procedure} -body { .s configure -length 200 -from 0 -to 10 -resolution 0 -digits 0 .s set .111111111 @@ -1135,26 +1135,26 @@ test scale-14.5 {RoundValueToResolution procedure} -body { -orient horizontal -resolution 4.0 update .s get 84 152 -} -result {-28} +} -result -28 test scale-14.6 {RoundValueToResolution procedure} -body { .s configure -from -100 -to 0 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 4.0 update .s get 86 152 -} -result {-24} +} -result -24 test scale-14.7 {RoundValueToResolution procedure} -body { .s configure -from 0 -to -100 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 4.0 update .s get 84 152 -} -result {-72} +} -result -72 test scale-14.8 {RoundValueToResolution procedure} -body { .s configure -from 0 -to -100 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 4.0 update .s get 86 152 -} -result {-76} +} -result -76 test scale-14.9 {RoundValueToResolution procedure} -body { .s configure -from 0 -to 2.25 -sliderlength 10 -length 114 -bd 2 \ @@ -1205,7 +1205,7 @@ test scale-14a.1 {RoundValueToResolution, RoundIntervalToResolution procedures} .s get 200 0 } -cleanup { destroy .s -} -result {5} +} -result 5 test scale-14a.2 {RoundValueToResolution, RoundIntervalToResolution procedures} -setup { pack [scale .s -orient horizontal] update @@ -1226,7 +1226,7 @@ test scale-15.1 {ScaleVarProc procedure} -setup { scale .s -from 0 -to -200 -variable y -orient horizontal -length 150 pack .s return $y -} -result {-130} +} -result -130 test scale-15.2 {ScaleVarProc procedure} -setup { deleteWindows } -body { @@ -1235,7 +1235,7 @@ test scale-15.2 {ScaleVarProc procedure} -setup { pack .s set y -87 .s get -} -result {-87} +} -result -87 test scale-15.3 {ScaleVarProc procedure} -setup { deleteWindows } -body { @@ -1256,7 +1256,7 @@ test scale-15.4 {ScaleVarProc procedure} -setup { .s get } -cleanup { deleteWindows -} -result {-130} +} -result -130 test scale-15.5 {ScaleVarProc procedure} -setup { deleteWindows } -body { @@ -1344,7 +1344,7 @@ test scale-17.1 {bug fix 1786} -setup { return $x } -cleanup { deleteWindows -} -result {100} +} -result 100 test scale-18.1 {DestroyScale, -cursor option [Bug: 3897]} -setup { @@ -1364,7 +1364,7 @@ test scale-18.2 {Scale button 1 events [Bug 787065]} -setup { pack .s tkwait visibility .s list [catch { - event generate .s <1> -x 0 -y 0 + event generate .s <Button-1> -x 0 -y 0 event generate .s <ButtonRelease-1> -x 0 -y 0 update set ::error @@ -1385,7 +1385,7 @@ test scale-18.3 {Scale button 2 events [Bug 787065]} -setup { pack .s tkwait visibility .s list [catch { - event generate .s <2> -x 0 -y 0 + event generate .s <Button-2> -x 0 -y 0 event generate .s <ButtonRelease-2> -x 0 -y 0 update set ::error @@ -1411,16 +1411,16 @@ test scale-19 {Bug [3529885fff] - Click in through goes in wrong direction} \ } \ -body { foreach {x y} [.s1 coord 50] {} - event generate .s1 <1> -x $x -y $y + event generate .s1 <Button-1> -x $x -y $y event generate .s1 <ButtonRelease-1> -x $x -y $y foreach {x y} [.s2 coord 50] {} - event generate .s2 <1> -x $x -y $y + event generate .s2 <Button-1> -x $x -y $y event generate .s2 <ButtonRelease-1> -x $x -y $y foreach {x y} [.s3 coord 50] {} - event generate .s3 <1> -x $x -y $y + event generate .s3 <Button-1> -x $x -y $y event generate .s3 <ButtonRelease-1> -x $x -y $y foreach {x y} [.s4 coord 50] {} - event generate .s4 <1> -x $x -y $y + event generate .s4 <Button-1> -x $x -y $y event generate .s4 <ButtonRelease-1> -x $x -y $y update list $x1 $x2 $x3 $x4 diff --git a/tests/scrollbar.test b/tests/scrollbar.test index c48ff02..f471b15 100644 --- a/tests/scrollbar.test +++ b/tests/scrollbar.test @@ -2,9 +2,9 @@ # the "scrollbar" command of Tk. It is organized in the standard # fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -13,6 +13,7 @@ tcltest::loadTestedCommands testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] +testConstraint nodeprecated [expr {"nodeprecated" ni [tk::pkgconfig list]}] proc scroll args { global scrollInfo @@ -200,7 +201,7 @@ test scrollbar-3.14.1 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest { destroy .s2 test scrollbar-3.15 {ScrollbarWidgetCmd procedure, "configure" option} { llength [.s configure] -} {20} +} 20 test scrollbar-3.16 {ScrollbarWidgetCmd procedure, "configure" option} { list [catch {.s configure -bad} msg] $msg } {1 {unknown option "-bad"}} @@ -233,7 +234,7 @@ test scrollbar-3.24 {ScrollbarWidgetCmd procedure, "delta" option} { } {1 {expected integer but got "xxyz"}} test scrollbar-3.25 {ScrollbarWidgetCmd procedure, "delta" option} { format {%.6g} [.s delta 20 0] -} {0} +} 0 test scrollbar-3.26 {ScrollbarWidgetCmd procedure, "delta" option} { format {%.6g} [.s delta 0 20] } [format %.6g [expr {20.0/([getTroughSize .s]-1)}]] @@ -265,20 +266,20 @@ test scrollbar-3.32 {ScrollbarWidgetCmd procedure, "fraction" option} { } {1 {expected integer but got "bogus"}} test scrollbar-3.33 {ScrollbarWidgetCmd procedure, "fraction" option} { format {%.6g} [.s fraction 0 0] -} {0} +} 0 test scrollbar-3.34 {ScrollbarWidgetCmd procedure, "fraction" option} { format {%.6g} [.s fraction 0 1000] -} {1} +} 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)}]] test scrollbar-3.36 {ScrollbarWidgetCmd procedure, "fraction" option} {x11 failsOnUbuntu failsOnXQuarz} { format {%.6g} [.s fraction 4 179] -} {1} +} 1 test scrollbar-3.37 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics} { format {%.6g} [.s fraction 4 [expr {200 - [testmetrics cyvscroll .s]}]] -} {1} +} 1 test scrollbar-3.38 {ScrollbarWidgetCmd procedure, "fraction" option} {x11 failsOnUbuntu failsOnXQuarz} { format {%.6g} [.s fraction 4 178] } {0.993711} @@ -312,12 +313,12 @@ if {[testConstraint testmetrics]} { update test scrollbar-3.42 {ScrollbarWidgetCmd procedure, "fraction" option} { format {%.6g} [.t.s fraction 100 0] -} {0} +} 0 destroy .t test scrollbar-3.43 {ScrollbarWidgetCmd procedure, "get" option} { list [catch {.s get a} msg] $msg } {1 {wrong # args: should be ".s get"}} -test scrollbar-3.44 {ScrollbarWidgetCmd procedure, "get" option} { +test scrollbar-3.44 {ScrollbarWidgetCmd procedure, "get" option} nodeprecated { .s set 100 10 13 14 .s get } {100 10 13 14} @@ -402,36 +403,36 @@ test scrollbar-3.63 {ScrollbarWidgetCmd procedure, "set" option} { } set result } {0.4 0.4} -test scrollbar-3.64 {ScrollbarWidgetCmd procedure, "set" option} { +test scrollbar-3.64 {ScrollbarWidgetCmd procedure, "set" option} nodeprecated { list [catch {.s set abc def ghi jkl} msg] $msg } {1 {expected integer but got "abc"}} -test scrollbar-3.65 {ScrollbarWidgetCmd procedure, "set" option} { +test scrollbar-3.65 {ScrollbarWidgetCmd procedure, "set" option} nodeprecated { list [catch {.s set 1 def ghi jkl} msg] $msg } {1 {expected integer but got "def"}} -test scrollbar-3.66 {ScrollbarWidgetCmd procedure, "set" option} { +test scrollbar-3.66 {ScrollbarWidgetCmd procedure, "set" option} nodeprecated { list [catch {.s set 1 2 ghi jkl} msg] $msg } {1 {expected integer but got "ghi"}} -test scrollbar-3.67 {ScrollbarWidgetCmd procedure, "set" option} { +test scrollbar-3.67 {ScrollbarWidgetCmd procedure, "set" option} nodeprecated { list [catch {.s set 1 2 3 jkl} msg] $msg } {1 {expected integer but got "jkl"}} -test scrollbar-3.68 {ScrollbarWidgetCmd procedure, "set" option} { +test scrollbar-3.68 {ScrollbarWidgetCmd procedure, "set" option} nodeprecated { .s set -10 50 20 30 .s get } {0 50 0 0} -test scrollbar-3.69 {ScrollbarWidgetCmd procedure, "set" option} { +test scrollbar-3.69 {ScrollbarWidgetCmd procedure, "set" option} nodeprecated { .s set 100 -10 20 30 .s get } {100 0 20 30} -test scrollbar-3.70 {ScrollbarWidgetCmd procedure, "set" option} { +test scrollbar-3.70 {ScrollbarWidgetCmd procedure, "set" option} nodeprecated { .s set 100 50 30 20 .s get } {100 50 30 30} test scrollbar-3.71 {ScrollbarWidgetCmd procedure, "set" option} { list [catch {.s set 1 2 3} msg] $msg -} {1 {wrong # args: should be ".s set firstFraction lastFraction" or ".s set totalUnits windowUnits firstUnit lastUnit"}} +} {1 {wrong # args: should be ".s set firstFraction lastFraction"}} test scrollbar-3.72 {ScrollbarWidgetCmd procedure, "set" option} { list [catch {.s set 1 2 3 4 5} msg] $msg -} {1 {wrong # args: should be ".s set firstFraction lastFraction" or ".s set totalUnits windowUnits firstUnit lastUnit"}} +} {1 {wrong # args: should be ".s set firstFraction lastFraction"}} test scrollbar-3.73 {ScrollbarWidgetCmd procedure} { list [catch {.s bogus} msg] $msg } {1 {bad option "bogus": must be activate, cget, configure, delta, fraction, get, identify, or set}} @@ -648,7 +649,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] @@ -669,7 +670,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] @@ -688,7 +689,7 @@ test scrollbar-9.1 {scrollbar widget vs hidden commands} { list [winfo children .] [interp hidden] } [list {} $l] -test scrollbar-10.1.1 {<MouseWheel> event on scrollbar} -constraints {notAqua} -setup { +test scrollbar-10.1 {<MouseWheel> event on scrollbar} -setup { destroy .t .s } -body { pack [text .t -yscrollcommand {.s set}] -side left @@ -701,23 +702,9 @@ test scrollbar-10.1.1 {<MouseWheel> event on scrollbar} -constraints {notAqua} - .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 [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} +} -result {4.0} -test scrollbar-10.2.1 {<MouseWheel> event on scrollbar} -constraints {notAqua} -setup { +test scrollbar-10.2 {<MouseWheel> event on scrollbar} -setup { destroy .t .s } -body { pack [text .t -xscrollcommand {.s set} -wrap none] -side top @@ -730,8 +717,8 @@ test scrollbar-10.2.1 {<MouseWheel> event on scrollbar} -constraints {notAqua} - .t index @0,0 } -cleanup { destroy .t .s -} -result {1.4} -test scrollbar-10.2.2 {<MouseWheel> event on scrollbar} -constraints {aqua} -setup { +} -result {1.3} +test scrollbar-10.3 {<MouseWheel> event on horizontal scrollbar} -setup { destroy .t .s } -body { pack [text .t -xscrollcommand {.s set} -wrap none] -side top @@ -739,12 +726,12 @@ test scrollbar-10.2.2 {<MouseWheel> event on scrollbar} -constraints {aqua} -set pack [scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top update focus -force .s - event generate .s <Shift-MouseWheel> -delta -4 + event generate .s <MouseWheel> -delta -120 after 200 {set eventprocessed 1} ; vwait eventprocessed .t index @0,0 } -cleanup { destroy .t .s -} -result {1.4} +} -result {1.3} test scrollbar-11.1 {bug fix: [011706ec42] Scrollbar unsafe wrt widget destruction} -body { proc destroy_scrollbar {} { @@ -754,11 +741,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 @@ -773,11 +760,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 2177591..55f9184 100644 --- a/tests/select.test +++ b/tests/select.test @@ -2,8 +2,8 @@ # especially the "selection" command. It is organized in the standard fashion # for Tcl tests. # -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. # diff --git a/tests/send.test b/tests/send.test index ccf3eab..9ce8026 100644 --- a/tests/send.test +++ b/tests/send.test @@ -2,10 +2,10 @@ # other procedures in the file tkSend.c. It is organized in the # standard fashion for Tcl tests. # -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2001 by ActiveState Corporation. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2001 ActiveState Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -403,14 +403,14 @@ test send-10.4 {SendEventProc procedure, leading nulls, bogus commands} {secures set a null update set a -} {44} +} 44 test send-10.5 {SendEventProc procedure, extraneous command options} {secureserver testsend} { testsend prop comm Comm \ "c\n-n tktest\n-x miscellanous\n-y who knows?\n-s set a new\n" set a null update set a -} {new} +} new test send-10.6 {SendEventProc procedure, unknown interpreter} {secureserver testsend} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ diff --git a/tests/spinbox.test b/tests/spinbox.test index e4f1c5e..f1cb3fa 100644 --- a/tests/spinbox.test +++ b/tests/spinbox.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test spinbox widgets in Tk. It is # organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -717,7 +717,7 @@ test spinbox-1.61 {configuration option: "repeatinterval"} -setup { .e cget -repeatinterval } -cleanup { destroy .e -} -result {-500} +} -result -500 test spinbox-1.62 {configuration option: "repeatinterval" for spinbox} -setup { spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ -relief sunken @@ -919,14 +919,14 @@ test spinbox-1.79 {configuration option: "values" for spinbox} -setup { destroy .e } -returnCodes {error} -result {list element in braces followed by "list" instead of space} -test spinbox-1.80 {configuration option: "vcmd"} -setup { +test spinbox-1.80 {configuration option: "validatecommand"} -setup { spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ -relief sunken pack .e update } -body { - .e configure -vcmd "a command" - .e cget -vcmd + .e configure -validatecommand "a command" + .e cget -validatecommand } -cleanup { destroy .e } -result {a command} @@ -1090,7 +1090,7 @@ test spinbox-3.7 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraint update } -body { # Tcl_UtfAtIndex(): utf at end - .e insert 0 "ab\u4e4e" + .e insert 0 "ab乎" .e bbox end } -cleanup { destroy .e @@ -1103,7 +1103,7 @@ test spinbox-3.8 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraint update } -body { # Tcl_UtfAtIndex(): utf before index - .e insert 0 "ab\u4e4ec" + .e insert 0 "ab乎c" .e bbox 3 } -cleanup { destroy .e @@ -1125,7 +1125,7 @@ test spinbox-3.10 {SpinboxWidgetCmd procedure, "bbox" widget command} -constrain pack .e update } -body { - .e insert 0 "abcdefghij\u4e4eklmnop" + .e insert 0 "abcdefghij乎klmnop" list [.e bbox 0] [.e bbox 1] [.e bbox 10] [.e bbox end] } -cleanup { destroy .e @@ -1167,7 +1167,7 @@ test spinbox-3.15 {SpinboxWidgetCmd procedure, "configure" widget command} -setu llength [.e configure] } -cleanup { destroy .e -} -result 49 +} -result 51 test spinbox-3.16 {SpinboxWidgetCmd procedure, "configure" widget command} -setup { spinbox .e } -body { @@ -1239,20 +1239,20 @@ test spinbox-3.24 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { set x {} } -body { # UTF - .e insert end "01234\u4e4e67890" + .e insert end "01234乎67890" .e delete 6 lappend x [.e get] .e delete 0 end - .e insert end "012345\u4e4e7890" + .e insert end "012345乎7890" .e delete 6 lappend x [.e get] .e delete 0 end - .e insert end "0123456\u4e4e890" + .e insert end "0123456乎890" .e delete 6 lappend x [.e get] } -cleanup { destroy .e -} -result [list "01234\u4e4e7890" "0123457890" "012345\u4e4e890"] +} -result [list "01234乎7890" "0123457890" "012345乎890"] test spinbox-3.25 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { spinbox .e pack .e @@ -1356,7 +1356,7 @@ test spinbox-3.35 {SpinboxWidgetCmd procedure, "index" widget command} -setup { update } -body { # UTF - .e insert 0 abc\u4e4e\u0153def + .e insert 0 abc乎œdef list [.e index 3] [.e index 4] [.e index end] } -cleanup { destroy .e @@ -1777,7 +1777,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 @@ -1788,7 +1788,7 @@ test spinbox-3.72 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { .e xview scroll gorp units } -cleanup { destroy .e -} -returnCodes error -result {expected integer but got "gorp"} +} -returnCodes error -result {expected floating-point number but got "gorp"} test spinbox-3.73 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e @@ -1854,7 +1854,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 @@ -1898,7 +1898,7 @@ test spinbox-3.81 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { } -body { .e insert end "This is quite a long text string, so long that it " .e insert end "runs off the end of the window quite a bit." - .e insert 10 \u4e4e + .e insert 10 乎 update # UTF # If Tcl_NumUtfChars wasn't used, wrong answer would be: @@ -2079,6 +2079,21 @@ test spinbox-5.11 {ConfigureSpinbox procedure} -setup { } -cleanup { destroy .e } -result {} +test spinbox-5.12 {ConfigureSpinbox procedure, -from and -to swapping} -setup { + spinbox .e +} -body { + # this statement used to trigger error "-to value must be greater than -from value" + # because default value for -to is zero (bug [841280ffff]) + set res [catch {.e configure -from 10}] + .e configure -from 1971 -to 2016 ; # standard case + lappend res [.e cget -from] [.e cget -to] + .e configure -from 2016 -to 1971 ; # auto-swapping happens + lappend res [.e cget -from] [.e cget -to] + .e configure -to 1971 -from 2016 ; # auto-swapping, order of options does not matter + lappend res [.e cget -from] [.e cget -to] +} -cleanup { + destroy .e +} -result {0 1971.0 2016.0 1971.0 2016.0 1971.0 2016.0} # No tests for DisplaySpinbox. @@ -2614,10 +2629,25 @@ test spinbox-8.18 {DeleteChars procedure} -constraints failsOnUbuntuNoXft -setup .e insert 0 "xyzzy" update .e delete 2 4 - winfo reqwidth .e -} -cleanup { - destroy .e -} -result 42 + # To check that deletion actually happened we measure the new width + # of the widget, based on the measuring width of the remaining text ("xyy") + # in the widget. For that purpose we have to mirror the code in tkEntry.c + # for computation of the reqwidth + # note: XPAD corresponds to the hardcoded #define XPAD 1 + set XPAD 1 + set buttonWidth [expr { [font measure [.e cget -font] "0"] + 2 * (1 + $XPAD) }] + if {$buttonWidth < 11} { + set buttonWidth 11 + } + set expected [expr { [font measure [.e cget -font] "xyy"] \ + + 2 * ( [.e cget -borderwidth] + \ + [.e cget -highlightthickness] + $XPAD ) \ + + $buttonWidth } ] + expr {[winfo reqwidth .e] == $expected} +} -cleanup { + destroy .e + unset XPAD buttonWidth expected +} -result 1 test spinbox-9.1 {SpinboxValueChanged procedure} -setup { unset -nocomplain x diff --git a/tests/systray.test b/tests/systray.test new file mode 100644 index 0000000..25c7bbb --- /dev/null +++ b/tests/systray.test @@ -0,0 +1,223 @@ +# This file is a Tcl script to test systray and sysnotify features in Tk. +# It is organized in the standard fashion for Tcl tests. +# +# Copyright © 2020 Kevin Walzer/WordTech Communications LLC. +# Copyright © 2020 Francois Vogel. +# All rights reserved. + +package require tcltest 2.2 +namespace import ::tcltest::* +eval tcltest::configure $argv +tcltest::loadTestedCommands + +test systray-1 {systray icon creation, all options} -setup { + image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== +} -body { + tk systray create -image _book -text "Systray sample" \ + -button1 {puts "button 1 click"} -button3 {puts "button 3 click"} +} -cleanup { + tk systray destroy + image delete _book +} -result {} + +test systray-2 {systray create, argument checking} -body { + tk systray create +} -returnCodes {error} -result {missing required option "-image"} + +test systray-3 {systray create, argument checking} -body { + tk systray create -text Hell +} -returnCodes {error} -result {missing required option "-image"} + +test systray-4 {systray create, argument checking} -setup { + image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== +} -body { + tk systray create -image _book -gorp invalidOption +} -returnCodes {error} -result {unknown option "-gorp": must be -image, -text, -button1 or -button3} + +test systray-5 {systray icon creation, only required option present} -setup { + image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== +} -body { + tk systray create -image _book +} -cleanup { + tk systray destroy + image delete _book +} -result {} + +test systray-6 {systray icon creation, some options present} -setup { + image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== +} -body { + tk systray create -image _book -button3 {puts b3} +} -cleanup { + tk systray destroy + image delete _book +} -result {} + +test systray-7 {systray icon, all parameters modification, introspection} -setup { + image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== + image create photo _page -data R0lGODlhCwAPAKIAAP//////AMDAwICAgAAA/wAAAAAAAAAAACwAAAAACwAPAAADMzi6CzAugiAgDGE68aB0RXgRJBFVX0SNpQlUWfahQOvSsgrX7eZJMlQMWBEYj8iQchlKAAA7 +} -body { + tk systray create -image _book -text "Systray icon text" + tk systray configure -image _page + tk systray configure -text "Another text for my icon" + tk systray configure -button1 {set a 1} + tk systray configure -button3 {set b 2} + tk systray configure +} -cleanup { + tk systray destroy + image delete _book + image delete _page +} -result {-image _page -text {Another text for my icon} -button1 {set a 1} -button3 {set b 2}} + +test systray-8 {systray icon, single parameter modification, introspection} -setup { + image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== +} -body { + tk systray create -image _book -text "Systray icon text" -button1 {puts b1} + tk systray configure -button1 {set a 1} + tk systray configure -button1 +} -cleanup { + tk systray destroy + image delete _book +} -result {set a 1} + +test systray-9 {systray icon, several parameters modification at once, introspection} -setup { + image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== +} -body { + tk systray create -image _book -text "Systray icon text" -button1 {puts b1} + tk systray configure -button1 {set a 1} -text NewText + list [tk systray configure -button1] [tk systray configure -text] +} -cleanup { + tk systray destroy + image delete _book +} -result {{set a 1} NewText} + +test systray-10 {configure non-existing systray icon} -setup { + catch {tk systray destroy} +} -body { + tk systray configure +} -returnCodes {error} -result {systray not created} + +test systray-11 {destroy non-existing systray icon} -setup { + catch {tk systray destroy} +} -body { + tk systray destroy +} -returnCodes {error} -result {systray not created} + +test systray-12 {destroy systray icon works} -setup { + image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== +} -body { + tk systray create -image _book + tk systray destroy + tk systray create -image _book +} -result {} + +test systray-13 {systray icon creation, attempt to create more than one in an interp} -setup { + image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== +} -body { + tk systray create -image _book + tk systray create -image _book +} -cleanup { + tk systray destroy + image delete _book +} -returnCodes {error} -result {only one system tray icon supported per interpeter} + +test systray-14 {systray icon creation, create one per interp, visibiliy checks} -setup { + image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== +} -body { + tk systray create -image _book -text "first interp" + interp create second + # load Tk into the 'second' interp + foreach pkg [info loaded] { + if {[lindex $pkg 1] == "Tk"} { + set loadTk "load $pkg" + break + } + } + eval $loadTk second + # create the icon in the 'second' interp + second eval { + # should trigger an error: image _book unknown in 'second' interp' + # image from higer interp should not be visible by 'tk systray' + tk systray create -image _book -text "second interp" + } +} -cleanup { + tk systray destroy + image delete _book + interp delete second +} -returnCodes {error} -result {image "_book" doesn't exist} + +test systray-15 {systray icon creation, create one per interp} -setup { + image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== +} -body { + tk systray create -image _book -text "first interp" + interp create second + # load Tk into the 'second' interp + foreach pkg [info loaded] { + if {[lindex $pkg 1] == "Tk"} { + set loadTk "load $pkg" + break + } + } + eval $loadTk second + # create the icon in the 'second' interp + second eval { + image create photo _page -data R0lGODlhCwAPAKIAAP//////AMDAwICAgAAA/wAAAAAAAAAAACwAAAAACwAPAAADMzi6CzAugiAgDGE68aB0RXgRJBFVX0SNpQlUWfahQOvSsgrX7eZJMlQMWBEYj8iQchlKAAA7 + tk systray create -image _page -text "second interp" + } +} -cleanup { + second eval { + tk systray destroy + image delete _page + } + interp delete second + tk systray destroy + image delete _book +} -result {} + +test systray-16 {systray icon creation from a bitmap, on Linux and macOS only} -constraints { + nonwin +} -setup { + set data1 { + #define foo_width 16 + #define foo_height 16 + static unsigned char foo_bits[] = { + 0xff, 0xff, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, + 0x81, 0x81, 0xff, 0xff, 0xff, 0xff, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, + 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0xff, 0xff + }; + } + image create bitmap cross -data $data1 +} -body { + tk systray create -image cross +} -cleanup { + tk systray destroy + image delete cross +} -result {} + + +test sysnotify-1 {system notification popup} -setup { + image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== + tk systray create -image _book -text "Systray sample" +} -body { + tk sysnotify {Alert} {This is an alert} +} -cleanup { + tk systray destroy + image delete _book +} -result {} + +test sysnotify-2.1 {system notification stems from a systray icon on Windows} -constraints { + win +} -setup { + catch {tk systray destroy} +} -body { + tk sysnotify {Alert} {This is an alert} +} -returnCodes {error} -result {must create a system tray icon with the "tk systray" command first} +test sysnotify-2.2 {system notification is not linked to any systray icon on X11 or aqua} -constraints { + nonwin +} -setup { + catch {tk systray destroy} +} -body { + tk sysnotify {Alert} {This is an alert} +} -result {} + + +cleanupTests diff --git a/tests/teapotTransparent.png b/tests/teapotTransparent.png Binary files differnew file mode 100644 index 0000000..1e7e46d --- /dev/null +++ b/tests/teapotTransparent.png diff --git a/tests/text.test b/tests/text.test index 6bd0ae4..3778a12 100644 --- a/tests/text.test +++ b/tests/text.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test the code in the file tkText.c. # This file is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1992-1994 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -28,7 +28,7 @@ test text-1.1 {configuration option: "autoseparators"} -setup { .t cget -autoseparators } -cleanup { destroy .t -} -result {1} +} -result 1 test text-1.1b {configuration option: "autoseparators", default} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -37,7 +37,7 @@ test text-1.1b {configuration option: "autoseparators", default} -setup { .t cget -autoseparators } -cleanup { destroy .t -} -result {1} +} -result 1 test text-1.2 {configuration option: "autoseparators"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -75,7 +75,7 @@ test text-1.5 {configuration option: "bd"} -setup { .t cget -bd } -cleanup { destroy .t -} -result {4} +} -result 4 test text-1.6 {configuration option: "bd"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -113,7 +113,7 @@ test text-1.9 {configuration option: "blockcursor"} -setup { .t cget -blockcursor } -cleanup { destroy .t -} -result {0} +} -result 0 test text-1.10 {configuration option: "blockcursor"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -132,7 +132,7 @@ test text-1.11 {configuration option: "borderwidth"} -setup { .t cget -borderwidth } -cleanup { destroy .t -} -result {7} +} -result 7 test text-1.12 {configuration option: "borderwidth"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -170,7 +170,7 @@ test text-1.15 {configuration option: "exportselection"} -setup { .t cget -exportselection } -cleanup { destroy .t -} -result {0} +} -result 0 test text-1.16 {configuration option: "exportselection"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -246,7 +246,7 @@ test text-1.23 {configuration option: "height"} -setup { .t cget -height } -cleanup { destroy .t -} -result {5} +} -result 5 test text-1.24 {configuration option: "height"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -303,7 +303,7 @@ test text-1.29 {configuration option: "highlightthickness"} -setup { .t cget -highlightthickness } -cleanup { destroy .t -} -result {0} +} -result 0 test text-1.30 {configuration option: "highlightthickness"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -360,7 +360,7 @@ test text-1.35 {configuration option: "insertborderwidth"} -setup { .t cget -insertborderwidth } -cleanup { destroy .t -} -result {45} +} -result 45 test text-1.36 {configuration option: "insertborderwidth"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -379,7 +379,7 @@ test text-1.37 {configuration option: "insertofftime"} -setup { .t cget -insertofftime } -cleanup { destroy .t -} -result {100} +} -result 100 test text-1.38 {configuration option: "insertofftime"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -398,7 +398,7 @@ test text-1.39 {configuration option: "insertontime"} -setup { .t cget -insertontime } -cleanup { destroy .t -} -result {47} +} -result 47 test text-1.40 {configuration option: "insertontime"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -417,7 +417,7 @@ test text-1.41 {configuration option: "insertwidth"} -setup { .t cget -insertwidth } -cleanup { destroy .t -} -result {2} +} -result 2 test text-1.42 {configuration option: "insertwidth"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -436,7 +436,7 @@ test text-1.43 {configuration option: "maxundo"} -setup { .t cget -maxundo } -cleanup { destroy .t -} -result {5} +} -result 5 test text-1.43b {configuration option: "maxundo", default} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -445,7 +445,7 @@ test text-1.43b {configuration option: "maxundo", default} -setup { .t cget -maxundo } -cleanup { destroy .t -} -result {0} +} -result 0 test text-1.44 {configuration option: "maxundo"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -464,7 +464,7 @@ test text-1.45 {configuration option: "padx"} -setup { .t cget -padx } -cleanup { destroy .t -} -result {3} +} -result 3 test text-1.46 {configuration option: "padx"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -483,7 +483,7 @@ test text-1.47 {configuration option: "pady"} -setup { .t cget -pady } -cleanup { destroy .t -} -result {82} +} -result 82 test text-1.48 {configuration option: "pady"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -540,7 +540,7 @@ test text-1.53 {configuration option: "selectborderwidth"} -setup { .t cget -selectborderwidth } -cleanup { destroy .t -} -result {21} +} -result 21 test text-1.54 {configuration option: "selectborderwidth"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -578,7 +578,7 @@ test text-1.57 {configuration option: "spacing1"} -setup { .t cget -spacing1 } -cleanup { destroy .t -} -result {20} +} -result 20 test text-1.58 {configuration option: "spacing1"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -597,7 +597,7 @@ test text-1.59 {configuration option: "spacing1"} -setup { .t cget -spacing1 } -cleanup { destroy .t -} -result {0} +} -result 0 test text-1.60 {configuration option: "spacing1"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -616,7 +616,7 @@ test text-1.61 {configuration option: "spacing2"} -setup { .t cget -spacing2 } -cleanup { destroy .t -} -result {5} +} -result 5 test text-1.62 {configuration option: "spacing2"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -635,7 +635,7 @@ test text-1.63 {configuration option: "spacing2"} -setup { .t cget -spacing2 } -cleanup { destroy .t -} -result {0} +} -result 0 test text-1.64 {configuration option: "spacing2"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -654,7 +654,7 @@ test text-1.65 {configuration option: "spacing3"} -setup { .t cget -spacing3 } -cleanup { destroy .t -} -result {20} +} -result 20 test text-1.66 {configuration option: "spacing3"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -673,7 +673,7 @@ test text-1.67 {configuration option: "spacing3"} -setup { .t cget -spacing3 } -cleanup { destroy .t -} -result {0} +} -result 0 test text-1.68 {configuration option: "spacing3"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -749,7 +749,7 @@ test text-1.75 {configuration option: "undo"} -setup { .t cget -undo } -cleanup { destroy .t -} -result {1} +} -result 1 test text-1.75b {configuration option: "undo", default} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -758,7 +758,7 @@ test text-1.75b {configuration option: "undo", default} -setup { .t cget -undo } -cleanup { destroy .t -} -result {0} +} -result 0 test text-1.76 {configuration option: "undo"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -777,7 +777,7 @@ test text-1.77 {configuration option: "width"} -setup { .t cget -width } -cleanup { destroy .t -} -result {73} +} -result 73 test text-1.78 {configuration option: "width"} -setup { text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} pack .t @@ -1004,7 +1004,7 @@ test text-5.4 {TextWidgetCmd procedure, "cget" option} -setup { .t cget -bd } -cleanup { destroy .t -} -result {17} +} -result 17 test text-6.1 {TextWidgetCmd procedure, "compare" option} -setup { @@ -1198,7 +1198,7 @@ test text-7.3 {TextWidgetCmd procedure, "debug" option} -setup { .t deb } -cleanup { destroy .t -} -result {1} +} -result 1 test text-7.4 {TextWidgetCmd procedure, "debug" option} -setup { text .t } -body { @@ -1206,7 +1206,7 @@ test text-7.4 {TextWidgetCmd procedure, "debug" option} -setup { .t debug } -cleanup { destroy .t -} -result {0} +} -result 0 test text-8.1 {TextWidgetCmd procedure, "delete" option} -setup { @@ -1252,7 +1252,7 @@ bOy GIrl .#@? x_yz Line 7" .t configure -state disabled .t delete 2.3 - .t g 2.0 2.end + .t get 2.0 2.end } -cleanup { destroy .t } -result {abcdefghijklm} @@ -1458,7 +1458,7 @@ Line 7" string equal [.t get 1.0 end-1c] $prevtext } -cleanup { destroy .t -} -result {1} +} -result 1 test text-8.22 {TextWidgetCmd procedure, "replace" option with undo} -setup { text .t set res {} @@ -1485,7 +1485,19 @@ Line 7" rename .t {} rename test.t .t destroy .t -} -result {{edit undo} {delete 2.1 2.4} {mark set insert 2.1} {see insert} {insert 2.1 ef} {mark set insert 2.3} {see insert}} +} -result [list {edit undo} {delete 2.1 2.4} {mark set insert 2.1} {see insert} \ + {mark set tk::undoMarkL2 2.1} {mark set tk::undoMarkR2 2.4} \ + {mark gravity tk::undoMarkL2 left} {mark gravity tk::undoMarkR2 right} \ + {insert 2.1 ef} {mark set insert 2.3} {see insert} \ + {mark set tk::undoMarkL1 2.1} {mark set tk::undoMarkR1 2.3} \ + {mark gravity tk::undoMarkL1 left} {mark gravity tk::undoMarkR1 right} \ + {mark names} \ + {index tk::undoMarkL1} {index tk::undoMarkR1} \ + {mark unset tk::undoMarkL1 tk::undoMarkR1} \ + {index tk::undoMarkL2} {index tk::undoMarkR2} \ + {mark unset tk::undoMarkL2 tk::undoMarkR2} \ + {compare 2.1 > 2.3} {compare 2.6 > 2.3} ] + test text-8.23 {TextWidgetCmd procedure, "replace" option with undo} -setup { text .t } -body { @@ -1502,14 +1514,14 @@ Line 7" # Ensure that undo (even composite undo like 'replace') # works when the widget shows nothing useful. .t replace 2.1 2.3 foo - .t configure -start 1 -end 1 + .t configure -startline 1 -endline 1 .t edit undo - .t configure -start {} -end {} + .t configure -startline {} -endline {} .t configure -undo 0 string equal [.t get 1.0 end-1c] $prevtext } -cleanup { destroy .t -} -result {1} +} -result 1 test text-8.24 {TextWidgetCmd procedure, "replace" option with peers, undo} -setup { text .t } -body { @@ -1528,15 +1540,15 @@ Line 7" # works when the the event took place in one peer, which # is then deleted, before the undo takes place in another peer. .tt replace 2.1 2.3 foo - .tt configure -start 1 -end 1 + .tt configure -startline 1 -endline 1 destroy .tt .t edit undo - .t configure -start {} -end {} + .t configure -startline {} -endline {} .t configure -undo 0 string equal [.t get 1.0 end-1c] $prevtext } -cleanup { destroy .t -} -result {1} +} -result 1 test text-8.25 {TextWidgetCmd procedure, "replace" option with peers, undo} -setup { text .t } -body { @@ -1557,14 +1569,14 @@ Line 7" # which isn't showing everything. .tt replace 2.1 2.3 foo set res [.tt get 2.1 2.4] - .tt configure -start 1 -end 1 + .tt configure -startline 1 -endline 1 destroy .tt - .t configure -start 3 -end 4 + .t configure -startline 3 -endline 4 # msg will actually be set to a silently ignored error message here, # (that the .tt command doesn't exist), but that is not important. lappend res [catch {.t edit undo}] .t configure -undo 0 - .t configure -start {} -end {} + .t configure -startline {} -endline {} lappend res [string equal [.t get 1.0 end-1c] $prevtext] } -cleanup { destroy .t @@ -2056,7 +2068,7 @@ test text-10.2 {TextWidgetCmd procedure, "count" option} -setup { .t count blah 1.0 2.0 } -cleanup { destroy .t -} -returnCodes {error} -result {bad option "blah" must be -chars, -displaychars, -displayindices, -displaylines, -indices, -lines, -update, -xpixels, or -ypixels} +} -returnCodes {error} -result {bad option "blah": must be -chars, -displaychars, -displayindices, -displaylines, -indices, -lines, -update, -xpixels, or -ypixels} test text-10.3 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2091,7 +2103,7 @@ Line 7" .t count 5.7 5.3 } -cleanup { destroy .t -} -result {-4} +} -result -4 test text-10.7 {TextWidgetCmd procedure, "count" option} -setup { text .t .t insert 1.0 "Line 1 @@ -2105,7 +2117,7 @@ Line 7" .t count 5.3 5.5 } -cleanup { destroy .t -} -result {2} +} -result 2 test text-10.8 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2119,7 +2131,7 @@ Line 7" .t count 5.3 end } -cleanup { destroy .t -} -result {29} +} -result 29 test text-10.9 {TextWidgetCmd procedure, "count" option} -setup { text .t .t insert 1.0 "Line 1 @@ -2133,7 +2145,7 @@ Line 7" .t count 5.2 5.7 } -cleanup { destroy .t -} -result {5} +} -result 5 test text-10.10 {TextWidgetCmd procedure, "count" option} -setup { text .t .t insert 1.0 "Line 1 @@ -2147,7 +2159,7 @@ Line 7" .t count 5.2 5.3 } -cleanup { destroy .t -} -result {1} +} -result 1 test text-10.11 {TextWidgetCmd procedure, "count" option} -setup { text .t .t insert 1.0 "Line 1 @@ -2161,7 +2173,7 @@ Line 7" .t count 5.2 5.4 } -cleanup { destroy .t -} -result {2} +} -result 2 test text-10.12 {TextWidgetCmd procedure, "count" option} -setup { text .t .t insert 1.0 "Line 1 @@ -2191,7 +2203,7 @@ Line 7" .t count -displayindices 2.0 3.0 } -cleanup { destroy .t -} -result {2} +} -result 2 test text-10.14 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2207,7 +2219,7 @@ Line 7" .t count -displayindices 2.2 3.0 } -cleanup { destroy .t -} -result {0} +} -result 0 test text-10.15 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2224,7 +2236,7 @@ Line 7" .t count -displayindices 2.0 4.2 } -cleanup { destroy .t -} -result {5} +} -result 5 test text-10.16 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2247,7 +2259,7 @@ Line 7" .t count -displayindices 2.0 3.0 } -cleanup { destroy .t -} -result {3} +} -result 3 test text-10.17 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2270,7 +2282,7 @@ Line 7" .t count -displayindices 2.2 3.0 } -cleanup { destroy .t -} -result {1} +} -result 1 test text-10.18 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2295,7 +2307,7 @@ Line 7" .t count -displayindices a 3.0 } -cleanup { destroy .t -} -result {0} +} -result 0 test text-10.19 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2319,7 +2331,7 @@ Line 7" .t count -displayindices 2.0 4.2 } -cleanup { destroy .t -} -result {6} +} -result 6 test text-10.20 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2343,7 +2355,7 @@ Line 7" .t count -displaychars 2.0 3.0 } -cleanup { destroy .t -} -result {2} +} -result 2 test text-10.21 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2367,7 +2379,7 @@ Line 7" .t count -displaychars 2.2 3.0 } -cleanup { destroy .t -} -result {1} +} -result 1 test text-10.22 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2392,7 +2404,7 @@ Line 7" .t count -displaychars a 3.0 } -cleanup { destroy .t -} -result {0} +} -result 0 test text-10.23 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2416,7 +2428,7 @@ Line 7" .t count -displaychars 2.0 4.2 } -cleanup { destroy .t -} -result {5} +} -result 5 test text-10.24 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2491,7 +2503,7 @@ Line 7" .t count -indices 2.0 4.2 } -cleanup { destroy .t -} -result {21} +} -result 21 test text-10.27 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2516,7 +2528,7 @@ Line 7" .t count -chars 2.2 3.0 } -cleanup { destroy .t -} -result {10} +} -result 10 test text-10.28 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2541,7 +2553,7 @@ Line 7" .t count -chars a 3.0 } -cleanup { destroy .t -} -result {9} +} -result 9 test text-10.29 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2566,7 +2578,7 @@ Line 7" .t count -chars 2.0 4.2 } -cleanup { destroy .t -} -result {19} +} -result 19 test text-10.30 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2576,7 +2588,7 @@ test text-10.30 {TextWidgetCmd procedure, "count" option} -setup { .t count -lines 1.0 end } -cleanup { destroy .t -} -result {3} +} -result 3 test text-10.31 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2586,7 +2598,7 @@ test text-10.31 {TextWidgetCmd procedure, "count" option} -setup { .t count -lines end 1.0 } -cleanup { destroy .t -} -result {-3} +} -result -3 test text-10.32 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2596,7 +2608,7 @@ test text-10.32 {TextWidgetCmd procedure, "count" option} -setup { .t count -lines 1.0 2.0 3.0 } -cleanup { destroy .t -} -returnCodes {error} -result {bad option "1.0" must be -chars, -displaychars, -displayindices, -displaylines, -indices, -lines, -update, -xpixels, or -ypixels} +} -returnCodes {error} -result {bad option "1.0": must be -chars, -displaychars, -displayindices, -displaylines, -indices, -lines, -update, -xpixels, or -ypixels} test text-10.33 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2606,7 +2618,7 @@ test text-10.33 {TextWidgetCmd procedure, "count" option} -setup { .t count -lines end end } -cleanup { destroy .t -} -result {0} +} -result 0 test text-10.34 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2616,7 +2628,7 @@ test text-10.34 {TextWidgetCmd procedure, "count" option} -setup { .t count -lines 1.5 2.5 } -cleanup { destroy .t -} -result {1} +} -result 1 test text-10.35 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2626,7 +2638,7 @@ test text-10.35 {TextWidgetCmd procedure, "count" option} -setup { .t count -lines 2.5 "2.5 lineend" } -cleanup { destroy .t -} -result {0} +} -result 0 test text-10.36 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2636,7 +2648,7 @@ test text-10.36 {TextWidgetCmd procedure, "count" option} -setup { .t count -lines 2.7 "1.0 lineend" } -cleanup { destroy .t -} -result {-1} +} -result -1 test text-10.37 {TextWidgetCmd procedure, "count" option} -setup { text .t } -body { @@ -2647,7 +2659,7 @@ test text-10.37 {TextWidgetCmd procedure, "count" option} -setup { .t count -displaylines 1.0 end } -cleanup { destroy .t -} -result {3} +} -result 3 test text-10.38 {TextWidgetCmd procedure, "count" option} -setup { text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .t -expand 1 -fill both @@ -2679,7 +2691,7 @@ test text-10.39 {TextWidgetCmd procedure, "count" option} -setup { } -cleanup { destroy .t } -result {2 6 1 5} -test text-9.2.45 {TextWidgetCmd procedure, "count" option} -setup { +test text-10.40 {TextWidgetCmd procedure, "count" option} -setup { text .t pack .t update @@ -2694,8 +2706,8 @@ test text-9.2.45 {TextWidgetCmd procedure, "count" option} -setup { set res [.t count -displaylines 2.0 3.0] } -cleanup { destroy .t -} -result {0} -test text-9.2.46 {TextWidgetCmd procedure, "count" option} -setup { +} -result 0 +test text-10.41 {TextWidgetCmd procedure, "count" option} -setup { toplevel .mytop pack [text .mytop.t -font TkFixedFont -bd 0 -padx 0 -wrap char] set spec [font measure TkFixedFont "Line 1+++Line 1---Li"] ; # 20 chars @@ -2717,7 +2729,7 @@ test text-9.2.46 {TextWidgetCmd procedure, "count" option} -setup { } -cleanup { destroy .mytop } -result {1 3} -test text-9.2.47 {TextWidgetCmd procedure, "count" option} -setup { +test text-10.42 {TextWidgetCmd procedure, "count" option} -setup { text .t pack .t update @@ -2771,7 +2783,7 @@ test text-11.2 {counting with tag priority eliding} -setup { .t count -displaychars 1.0 1.5 } -cleanup { destroy .t -} -result {5} +} -result 5 test text-11.3 {counting with tag priority eliding} -setup { text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 } -body { @@ -2784,7 +2796,7 @@ test text-11.3 {counting with tag priority eliding} -setup { .t count -displaychars 1.0 1.5 } -cleanup { destroy .t -} -result {3} +} -result 3 test text-11.4 {counting with tag priority eliding} -setup { text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 set res {} @@ -3110,7 +3122,7 @@ test text-11a.41 {"sync" "pendingsync" and <<WidgetViewSync>>} -setup { destroy .top.yt .top } -result {Sync:0 Pending:1 Sync:1 Pending:0} -test text-11a.51 {<<WidgetViewSync>> calls TkSendVirtualEvent(), +test text-11a.51 {<<WidgetViewSync>> calls Tk_SendVirtualEvent(), NOT Tk_HandleEvent(). Bug [b362182e45704dd7bbd6aed91e48122035ea3d16]} -setup { destroy .top.t .top @@ -3414,7 +3426,7 @@ test text-14.14 {ConfigureText procedure} -body { selection get } -cleanup { destroy .t .t2 -} -result {1234} +} -result 1234 test text-14.15 {ConfigureText procedure} -body { text .t entry .t.e @@ -3428,7 +3440,7 @@ test text-14.15 {ConfigureText procedure} -body { selection get } -cleanup { destroy .t2 .t -} -result {1234} +} -result 1234 test text-14.16 {ConfigureText procedure} -body { text .t entry .t.e @@ -3457,7 +3469,7 @@ test text-14.17 {ConfigureText procedure} -body { return $result } -cleanup { destroy .t .t2 -} -result {1234} +} -result 1234 test text-14.18 {ConfigureText procedure} -constraints fonts -setup { toplevel .top text .top.t -font {Courier -12} -borderwidth 2 -highlightthickness 2 @@ -3960,7 +3972,7 @@ test text-20.5 {TextFetchSelection procedure, long selections} -setup { expr {[selection get] eq "$x\n"} } -cleanup { destroy .t -} -result {1} +} -result 1 test text-21.1 {TkTextLostSelection procedure} -constraints {x11} -setup { @@ -4569,25 +4581,25 @@ test text-22.68 {TextSearchCmd, freeing copy of pattern} -body { } -result {} test text-22.69 {TextSearchCmd, unicode} -body { text .t - .t insert end "foo\u30c9\u30cabar" - .t search \u30c9\u30ca 1.0 + .t insert end "fooドナbar" + .t search ドナ 1.0 } -cleanup { destroy .t } -result {1.3} test text-22.70 {TextSearchCmd, unicode} -body { text .t - .t insert end "foo\u30c9\u30cabar" - list [.t search -count n \u30c9\u30ca 1.0] $n + .t insert end "fooドナbar" + list [.t search -count n ドナ 1.0] $n } -cleanup { destroy .t } -result {1.3 2} test text-22.71 {TextSearchCmd, unicode with non-text segments} -body { text .t button .b1 -text baz - .t insert end "foo\u30c9" + .t insert end "fooド" .t window create end -window .b1 - .t insert end "\u30cabar" - list [.t search -count n \u30c9\u30ca 1.0] $n + .t insert end "ナbar" + list [.t search -count n ドナ 1.0] $n } -cleanup { destroy .t .b1 } -result {1.3 3} @@ -5812,7 +5824,7 @@ test text-22.217.1 {elide up to match, with UTF-8 chars before the match} -setup } -body { .t tag configure e -elide 0 .t insert end A {} xyz e bb\n - .t insert end \u00c4 {} xyz e bb + .t insert end Ä {} xyz e bb set res {} lappend res [.t search bb 1.0 "1.0 lineend"] lappend res [.t search bb 2.0 "2.0 lineend"] @@ -6419,19 +6431,19 @@ test text-24.24 {TextDumpCmd procedure, command script} -setup { } -result {mark 1.0 current mark 1.0 insert mark 2.4 m} test text-24.25 {TextDumpCmd procedure, unicode characters} -body { text .t - .t insert 1.0 \xb1\xb1\xb1 + .t insert 1.0 ±±± .t dump -all 1.0 2.0 } -cleanup { destroy .t -} -result "text \xb1\xb1\xb1 1.0 mark insert 1.3 mark current 1.3 text {\n} 1.3" +} -result "text ±±± 1.0 mark insert 1.3 mark current 1.3 text {\n} 1.3" test text-24.26 {TextDumpCmd procedure, unicode characters} -body { text .t .t delete 1.0 end - .t insert 1.0 abc\xb1\xb1\xb1 + .t insert 1.0 abc±±± .t dump -all 1.0 2.0 } -cleanup { destroy .t -} -result "text abc\xb1\xb1\xb1 1.0 mark insert 1.6 mark current 1.6 text {\n} 1.6" +} -result "text abc±±± 1.0 mark insert 1.6 mark current 1.6 text {\n} 1.6" test text-24.27 {TextDumpCmd procedure, peer present} -body { text .t .t peer create .t.t @@ -6447,7 +6459,7 @@ test text-25.1 {text widget vs hidden commands} -body { destroy .t set x [list [winfo children .] [interp hidden]] expr {$x eq $y} -} -result {1} +} -result 1 test text-26.1 {bug fix - 1642} -body { @@ -6540,7 +6552,7 @@ test text-27.8 {TextEditCmd procedure, modified flag} -body { .t edit modified } -cleanup { destroy .t -} -result {1} +} -result 1 test text-27.9 {TextEditCmd procedure, reset modified flag} -body { text .t pack .t @@ -6549,7 +6561,7 @@ test text-27.9 {TextEditCmd procedure, reset modified flag} -body { .t edit modified } -cleanup { destroy .t -} -result {0} +} -result 0 test text-27.10 {TextEditCmd procedure, set modified flag} -body { text .t pack .t @@ -6557,13 +6569,14 @@ test text-27.10 {TextEditCmd procedure, set modified flag} -body { .t edit modified } -cleanup { destroy .t -} -result {1} +} -result 1 test text-27.11 {TextEditCmd procedure, set modified flag repeat} -setup { text .t pack .t # Make sure the Text is mapped before we start update set ::retval {} + update } -body { bind .t <<Modified>> "lappend ::retval modified" # Shouldn't require [update idle] to trigger event [Bug 1809538] @@ -6627,7 +6640,7 @@ test text-27.14a {<<Modified>> virtual event - propagation to peers} -body { set ::retval } -cleanup { destroy .t .tt -} -result {4} +} -result 4 test text-27.15 {<<Selection>> virtual event on sel tagging} -body { set ::retval no_selection pack [text .t] @@ -6746,7 +6759,7 @@ test text-27.15g {No <<Selection>> virtual event on <<Cut>> without widget selec destroy .t } -result {no_<<Selection>>_event_fired} test text-27.16 {-maxundo configuration option} -body { - text .t -undo 1 -autoseparators 1 -maxundo 2 + text .t -undo 1 -autoseparators 1 -maxundo 2 pack .t .t insert end "line 1\n" .t delete 1.4 1.6 @@ -6810,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 @@ -6850,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 @@ -6967,6 +6980,66 @@ test text-27.25 {<<UndoStack>> virtual event} -setup { } -cleanup { destroy .t } -result {0 0 1 2 3 4 4 5 6 6 7 8 8 9} +test text-27.26 {edit undo and edit redo return ranges} -setup { + destroy .t + set res {} +} -body { + text .t -undo true -autoseparators false + .t insert end "Hello " + .t edit separator + .t insert end "World!\n" + .t insert 1.6 "GREAT " + .t insert end "Another edit here!!" + lappend res [.t edit undo] + lappend res [.t edit redo] + .t edit separator + .t delete 1.6 + .t delete 1.9 1.10 + .t insert 1.9 L + lappend res [.t edit undo] + lappend res [.t edit redo] + .t replace 1.6 1.10 Tcl/Tk + .t replace 2.8 2.12 "one bites the dust" + lappend res [.t edit undo] + lappend res [.t edit redo] +} -cleanup { + destroy .t +} -result [list {1.6 2.0} \ + {1.6 2.19} \ + {1.6 1.7 1.10 1.12} \ + {1.6 1.7 1.9 1.11} \ + {1.6 1.16 2.8 2.19} \ + {1.6 1.16 2.8 2.30} ] +test text-27.27 {edit undo and edit redo return ranges} -setup { + destroy .t + set res {} +} -body { + text .t -undo true -autoseparators false + for {set i 3} {$i >= 1} {incr i -1} { + .t insert 1.0 "Line $i\n" + } + lappend res [.t edit undo] + lappend res [.t edit redo] +} -cleanup { + destroy .t +} -result [list {1.0 2.0} \ + {1.0 4.0} ] +test text-27.28 {edit undo and edit redo do not leave \ + spurious temporary marks behind them} -setup { + destroy .t + set res {} +} -body { + pack [text .t -undo true -autoseparators false] + .t insert end "Hello World.\n" + .t edit separator + .t insert end "Again hello.\n" + .t edit undo + lappend res [expr {[lsearch [.t mark names] tk::undoMark*]<0}] + .t edit redo + lappend res [expr {[lsearch [.t mark names] tk::undoMark*]<0}] +} -cleanup { + destroy .t +} -result {1 1} test text-28.1 {bug fix - 624372, ControlUtfProc long lines} -body { @@ -6979,13 +7052,13 @@ test text-28.1 {bug fix - 624372, ControlUtfProc long lines} -body { test text-29.1 {tabs - must be positive and must be increasing} -body { pack [text .t -wrap none] - .t configure -tabs {0} + .t configure -tabs 0 } -cleanup { destroy .t } -returnCodes {error} -result {tab stop "0" is not at a positive distance} test text-29.2 {tabs - must be positive and must be increasing} -body { pack [text .t -wrap none] - .t configure -tabs {-5} + .t configure -tabs -5 } -cleanup { destroy .t } -returnCodes {error} -result {tab stop "-5" is not at a positive distance} @@ -7008,7 +7081,7 @@ test text-29.4 {tabs - must be positive and must be increasing} -body { set result 1 } -cleanup { destroy .t -} -result {1} +} -result 1 test text-30.1 {repeated insert and scroll} -body { @@ -7021,7 +7094,7 @@ test text-30.1 {repeated insert and scroll} -body { set result 1 } -cleanup { destroy .t -} -result {1} +} -result 1 test text-30.2 {repeated insert and scroll} -body { pack [text .t] for {set i 0} {$i < 30} {incr i} { @@ -7032,7 +7105,7 @@ test text-30.2 {repeated insert and scroll} -body { set result 1 } -cleanup { destroy .t -} -result {1} +} -result 1 test text-30.3 {repeated insert and scroll} -body { pack [text .t] for {set i 0} {$i < 30} {incr i} { @@ -7043,7 +7116,7 @@ test text-30.3 {repeated insert and scroll} -body { set result 1 } -cleanup { destroy .t -} -result {1} +} -result 1 test text-30.4 {repeated insert and scroll} -body { pack [text .t] for {set i 0} {$i < 30} {incr i} { @@ -7054,7 +7127,7 @@ test text-30.4 {repeated insert and scroll} -body { set result 1 } -cleanup { destroy .t -} -result {1} +} -result 1 test text-31.1 {peer widgets} -body { @@ -7099,7 +7172,7 @@ test text-31.4 {peer widgets} -body { for {set i 1} {$i < 20} {incr i} { .t insert end "Line $i\n" } - pack [.t peer create .top.t -start 5 -end 11] + pack [.t peer create .top.t -startline 5 -endline 11] update destroy .t .top } -result {} @@ -7109,7 +7182,7 @@ test text-31.5 {peer widgets} -body { for {set i 1} {$i < 20} {incr i} { .t insert end "Line $i\n" } - pack [.t peer create .top.t -start 5 -end 11] + pack [.t peer create .top.t -startline 5 -endline 11] pack [.top.t peer create .top.t2] set res [list [.top.t index end] [.top.t2 index end]] update @@ -7123,8 +7196,8 @@ test text-31.6 {peer widgets} -body { for {set i 1} {$i < 20} {incr i} { .t insert end "Line $i\n" } - pack [.t peer create .top.t -start 5 -end 11] - pack [.top.t peer create .top.t2 -start {} -end {}] + pack [.t peer create .top.t -startline 5 -endline 11] + pack [.top.t peer create .top.t2 -startline {} -endline {}] set res [list [.top.t index end] [.top.t2 index end]] update return $res @@ -7137,21 +7210,21 @@ test text-31.7 {peer widgets} -body { for {set i 1} {$i < 20} {incr i} { .t insert end "Line $i\n" } - pack [.t peer create .top.t -start 5 -end 11] + pack [.t peer create .top.t -startline 5 -endline 11] update ; update set p1 [.top.t count -update -ypixels 1.0 end] set p2 [.t count -update -ypixels 5.0 11.0] expr {$p1 eq $p2} } -cleanup { destroy .t .top -} -result {1} +} -result 1 test text-31.8 {peer widgets} -body { toplevel .top pack [text .t] for {set i 1} {$i < 20} {incr i} { .t insert end "Line $i\n" } - pack [.t peer create .top.t -start 5 -end 11] + pack [.t peer create .top.t -startline 5 -endline 11] update ; update .t delete 3.0 6.0 .top.t index end @@ -7164,7 +7237,7 @@ test text-31.9 {peer widgets} -body { for {set i 1} {$i < 20} {incr i} { .t insert end "Line $i\n" } - pack [.t peer create .top.t -start 5 -end 11] + pack [.t peer create .top.t -startline 5 -endline 11] update ; update .t delete 8.0 12.0 .top.t index end @@ -7177,7 +7250,7 @@ test text-31.10 {peer widgets} -body { for {set i 1} {$i < 20} {incr i} { .t insert end "Line $i\n" } - pack [.t peer create .top.t -start 5 -end 11] + pack [.t peer create .top.t -startline 5 -endline 11] update ; update .t delete 3.0 13.0 .top.t index end @@ -7193,7 +7266,7 @@ test text-31.11 {peer widgets} -setup { } .t tag add sel 1.0 end-1c lappend res [.t tag ranges sel] - .t configure -start 10 -end 20 + .t configure -startline 10 -endline 20 lappend res [.t tag ranges sel] return $res } -cleanup { @@ -7208,7 +7281,7 @@ test text-31.12 {peer widgets} -setup { } .t tag add sel 1.0 end-1c lappend res [.t tag ranges sel] - .t configure -start 11 + .t configure -startline 11 lappend res [.t tag ranges sel] return $res } -cleanup { @@ -7223,7 +7296,7 @@ test text-31.13 {peer widgets} -setup { } .t tag add sel 1.0 end-1c lappend res [.t tag ranges sel] - .t configure -end 90 + .t configure -endline 90 lappend res [.t tag ranges sel] destroy .t return $res @@ -7239,7 +7312,7 @@ test text-31.14 {peer widgets} -setup { } .t tag add sel 1.0 3.0 5.0 7.0 9.0 11.0 13.0 15.0 17.0 19.0 lappend res [.t tag prevrange sel 1.0] - .t configure -start 6 -end 12 + .t configure -startline 6 -endline 12 lappend res [.t tag ranges sel] lappend res "next" [.t tag nextrange sel 4.0] \ [.t tag nextrange sel 5.0] [.t tag nextrange sel 6.0] \ @@ -7259,7 +7332,7 @@ test text-31.15 {peer widgets} -setup { .t insert end "Line $i\n" } .t tag add sel 1.0 3.0 9.0 11.0 13.0 15.0 17.0 19.0 - .t configure -start 6 -end 12 + .t configure -startline 6 -endline 12 lappend res [.t tag ranges sel] lappend res "next" [.t tag nextrange sel 4.0] \ [.t tag nextrange sel 5.0] [.t tag nextrange sel 6.0] \ @@ -7279,7 +7352,7 @@ test text-31.16 {peer widgets} -setup { .t insert end "Line $i\n" } .t tag add sel 1.0 7.0 9.0 11.0 13.0 15.0 17.0 19.0 - .t configure -start 6 -end 12 + .t configure -startline 6 -endline 12 lappend res [.t tag ranges sel] lappend res "next" [.t tag nextrange sel 4.0] \ [.t tag nextrange sel 5.0] [.t tag nextrange sel 6.0] \ @@ -7300,11 +7373,11 @@ test text-31.17 {peer widgets} -setup { } .t tag add sel 1.0 11.0 lappend res [.t tag ranges sel] - lappend res [catch {.t configure -start 15 -end 10}] + lappend res [catch {.t configure -startline 15 -endline 10}] lappend res [.t tag ranges sel] - .t configure -start 6 -end 12 + .t configure -startline 6 -endline 12 lappend res [.t tag ranges sel] - .t configure -start {} -end {} + .t configure -startline {} -endline {} lappend res [.t tag ranges sel] return $res } -cleanup { @@ -7371,9 +7444,9 @@ test text-32.1 {line heights on creation} -setup { expr {$before eq $after} } -cleanup { destroy .t -} -result {1} +} -result 1 -test text-32.2 {peer widget -start, -end and deletion (bug 1630262)} -setup { +test text-32.2 {peer widget -start, -endline and deletion (bug 1630262)} -setup { destroy .t .pt set res {} } -body { @@ -7401,9 +7474,9 @@ test text-32.2 {peer widget -start, -end and deletion (bug 1630262)} -setup { set res 1 } -cleanup { destroy .pt -} -result {1} +} -result 1 -test text-32.3 {peer widget -start, -end and deletion (bug 1630262)} -setup { +test text-32.3 {peer widget -start, -endline and deletion (bug 1630262)} -setup { destroy .t .pt set res {} } -body { @@ -7424,7 +7497,7 @@ test text-32.3 {peer widget -start, -end and deletion (bug 1630262)} -setup { destroy .pt } -result {4 3} -test text-32.4 {peer widget -start, -end and deletion (bug 1630262)} -setup { +test text-32.4 {peer widget -start, -endline and deletion (bug 1630262)} -setup { destroy .t .pt set res {} } -body { @@ -7485,7 +7558,7 @@ test text-33.2 {TextWidgetCmd procedure, "peer" option} -setup { test text-33.3 {TextWidgetCmd procedure, "peer" option} -setup { text .t } -body { - .t pee names + .t peer names } -cleanup { destroy .t } -returnCodes {ok} -result {} @@ -7517,17 +7590,17 @@ test text-33.6 {TextWidgetCmd procedure, "peer" option} -setup { } -result {.t2 .t {}} test text-33.7 {peer widget -start, -end} -body { text .t - set res [.t configure -start 10 -end 5] + set res [.t configure -startline 10 -endline 5] return $res } -cleanup { destroy .t -} -returnCodes {2} -result {} +} -returnCodes 2 -result {} test text-33.8 {peer widget -start, -end} -body { text .t for {set i 1} {$i < 100} {incr i} { .t insert end "Line $i\n" } - .t configure -start 10 -end 5 + .t configure -startline 10 -endline 5 } -cleanup { destroy .t } -returnCodes {error} -result {-startline must be less than or equal to -endline} @@ -7536,7 +7609,7 @@ test text-33.9 {peer widget -start, -end} -body { for {set i 1} {$i < 100} {incr i} { .t insert end "Line $i\n" } - .t configure -start 5 -end 10 + .t configure -startline 5 -endline 10 } -cleanup { destroy .t } -returnCodes {ok} -result {} @@ -7546,11 +7619,11 @@ test text-33.10 {peer widget -start, -end} -body { .t insert end "Line $i\n" } set res [.t index end] - lappend res [catch {.t configure -start 5 -end 10 -tab foo}] + lappend res [catch {.t configure -startline 5 -endline 10 -tab foo}] lappend res [.t index end] - lappend res [catch {.t configure -tab foo -start 15 -end 20}] + lappend res [catch {.t configure -tab foo -startline 15 -endline 20}] lappend res [.t index end] - .t configure -start {} -end {} + .t configure -startline {} -endline {} lappend res [.t index end] return $res } -cleanup { @@ -7562,18 +7635,18 @@ test text-33.11 {peer widget -start, -end} -body { .t insert end "Line $i\n" } set res [.t index end] - lappend res [catch {.t configure -start 5 -end 15}] + lappend res [catch {.t configure -startline 5 -endline 15}] lappend res [.t index end] - lappend res [catch {.t configure -start 10 -end 40}] + lappend res [catch {.t configure -startline 10 -endline 40}] lappend res [.t index end] - .t configure -start {} -end {} + .t configure -startline {} -endline {} lappend res [.t index end] return $res } -cleanup { destroy .t } -result {101.0 0 11.0 0 31.0 101.0} -test text-34.1 {peer widget -start, -end and selection} -setup { +test text-34.1 {peer widget -start, -endline and selection} -setup { text .t set res {} } -body { @@ -7582,17 +7655,17 @@ test text-34.1 {peer widget -start, -end and selection} -setup { } .t tag add sel 10.0 20.0 lappend res [.t tag ranges sel] - .t configure -start 5 -end 30 + .t configure -startline 5 -endline 30 lappend res [.t tag ranges sel] - .t configure -start 5 -end 15 + .t configure -startline 5 -endline 15 lappend res [.t tag ranges sel] - .t configure -start 15 -end 30 + .t configure -startline 15 -endline 30 lappend res [.t tag ranges sel] - .t configure -start 15 -end 16 + .t configure -startline 15 -endline 16 lappend res [.t tag ranges sel] - .t configure -start 25 -end 30 + .t configure -startline 25 -endline 30 lappend res [.t tag ranges sel] - .t configure -start {} -end {} + .t configure -startline {} -endline {} lappend res [.t tag ranges sel] return $res } -cleanup { @@ -7601,7 +7674,6 @@ test text-34.1 {peer widget -start, -end and selection} -setup { test text-35.1 {widget dump -command alters tags} -setup { proc Dumpy {key value index} { -#puts "KK: $key, $value" .t tag add $value [list $index linestart] [list $index lineend] } text .t @@ -7615,7 +7687,6 @@ test text-35.1 {widget dump -command alters tags} -setup { } -result {ok} test text-35.2 {widget dump -command makes massive changes} -setup { proc Dumpy {key value index} { -#puts "KK: $key, $value" .t delete 1.0 end } text .t @@ -7629,7 +7700,6 @@ test text-35.2 {widget dump -command makes massive changes} -setup { } -result {ok} test text-35.3 {widget dump -command destroys widget} -setup { proc Dumpy {key value index} { -#puts "KK: $key, $value" destroy .t } text .t @@ -7651,8 +7721,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 { @@ -7669,8 +7739,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 { @@ -7687,8 +7757,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 fd97afa..467e8dd 100644 --- a/tests/textBTree.test +++ b/tests/textBTree.test @@ -3,9 +3,9 @@ # several file with additional tests for other features of text widgets. # This file is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1992-1994 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/textDisp.test b/tests/textDisp.test index ac80069..97fbe27 100644 --- a/tests/textDisp.test +++ b/tests/textDisp.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test the code in the file tkTextDisp.c. # This file is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -66,7 +66,15 @@ catch {destroy .f .t} frame .f -width 100 -height 20 pack .f -side left -set fixedFont {Courier -12} +# On macOS the font "Courier New" has different metrics than "Courier", +# and this causes tests 20.1 - 20.5 to fail. So we use "Courier" as the +# fixed font for testing on Aqua. + +if {[tk windowingsystem] eq "aqua"} { + set fixedFont {Courier -12} +} else { + set fixedFont {"Courier New" -12} +} # 15 on XP, 13 on Solaris 8 set fixedHeight [font metrics $fixedFont -linespace] # 7 on all platforms @@ -218,9 +226,9 @@ test textDisp-1.1 {GetStyle procedure, priorities and tab stops} { .t delete 1.0 end .t insert 1.0 "x\ty" .t tag delete x y z - .t tag configure x -tabs {50} + .t tag configure x -tabs 50 .t tag configure y -foreground black - .t tag configure z -tabs {70} + .t tag configure z -tabs 70 .t tag add x 1.0 1.end .t tag add y 1.0 1.end .t tag add z 1.0 1.end @@ -228,7 +236,7 @@ test textDisp-1.1 {GetStyle procedure, priorities and tab stops} { set x [lindex [.t bbox 1.2] 0] .t tag configure z -tabs {} lappend x [lindex [.t bbox 1.2] 0] - .t tag configure z -tabs {30} + .t tag configure z -tabs 30 .t tag raise x update idletasks lappend x [lindex [.t bbox 1.2] 0] @@ -499,7 +507,7 @@ test textDisp-2.24 {LayoutDLine, tabs, saving from first chunk} {textfonts} { .t tag add x 1.0 end .t tag add y 1.1 end lindex [.t bbox 1.3] 0 -} {75} +} 75 test textDisp-2.25 {LayoutDLine, tabs, breaking chunks at tabs} {textfonts} { .t delete 1.0 end .t tag delete x @@ -713,7 +721,7 @@ test textDisp-4.12 {UpdateDisplayInfo, filling in extra vertical space} { .t yview moveto 1 updateText winfo ismapped .b -} {0} +} 0 .t configure -wrap word .t delete 1.0 end .t insert end "Line 1\nLine 2\nLine 3\nLine 4\nLine 5\nLine 6\nLine 7\n" @@ -1341,11 +1349,11 @@ test textDisp-9.10 {TkTextRedrawTag} { .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 updateText - set tk_textRedraw {none} + set tk_textRedraw none .t tag add big 1.3 1.5 updateText set tk_textRedraw -} {none} +} none test textDisp-9.11 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end @@ -1823,7 +1831,7 @@ test textDisp-13.11 {TkTextSeeCmd procedure} {} { set res [.top2.t2 compare $ref == $new] destroy .top2 set res -} {0} +} 0 wm geom . {} .t configure -wrap none @@ -1889,13 +1897,13 @@ 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"}} +} {1 {expected floating-point number but got "gorp"}} test textDisp-14.13 {TkTextXviewCmd procedure} { .t delete 1.0 end .t insert end xxxxxxxxx\n @@ -1926,7 +1934,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}} @@ -2012,7 +2020,7 @@ test textDisp-15.8 {Scrolling near end of window} { set res [.tf.f.t compare $newind > $refind] destroy .tf set res -} {1} +} 1 .t configure -wrap char .t delete 1.0 end @@ -2109,16 +2117,16 @@ 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}} + list [catch {.t yview scroll bogus bogus} msg] $msg +} {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"}} + list [catch {.t yview scroll bogus units} msg] $msg +} {1 {expected floating-point number but got "bogus"}} test textDisp-16.22 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t yview 50.0 updateText @@ -2127,7 +2135,7 @@ test textDisp-16.22 {TkTextYviewCmd procedure, "scroll" option, back pages} { } {42.0} test textDisp-16.22.1 {TkTextYviewCmd procedure, "scroll" option, back pages} { list [catch {.t yview scroll -3 p} res] $res -} {1 {ambiguous argument "p": must be units, pages, or pixels}} +} {1 {ambiguous argument "p": must be pages, pixels, or units}} test textDisp-16.23 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t yview 50.0 updateText @@ -2172,7 +2180,7 @@ test textDisp-16.28 {TkTextYviewCmd procedure, "scroll" option, forward pages} { incr res -1 } set res -} {102} +} 102 test textDisp-16.29 {TkTextYviewCmd procedure, "scroll" option, forward pages} { .t configure -height 1 updateText @@ -2198,7 +2206,7 @@ test textDisp-16.31 {TkTextYviewCmd procedure, "scroll units" option} { } {151.40} test textDisp-16.32 {TkTextYviewCmd procedure} { list [catch {.t yview scroll 12 bogoids} msg] $msg -} {1 {bad argument "bogoids": must be units, pages, or pixels}} +} {1 {bad argument "bogoids": must be pages, pixels, or units}} test textDisp-16.33 {TkTextYviewCmd procedure} { list [catch {.t yview bad_arg 1 2} msg] $msg } {1 {bad option "bad_arg": must be moveto or scroll}} @@ -2510,8 +2518,6 @@ test textDisp-18.8 {GetXView procedure} { catch {rename bgerror {}} catch {rename bogus {}} .t configure -xscrollcommand {} -yscrollcommand scroll - -.t configure -xscrollcommand {} -yscrollcommand scroll test textDisp-19.1 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end @@ -2656,66 +2662,66 @@ test textDisp-19.11 {GetYView procedure} { } {0.5 1.0} test textDisp-19.11.2 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 1.0 end -} {20} +} 20 test textDisp-19.11.3 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines end 1.0 -} {-20} +} -20 test textDisp-19.11.4 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 1.1 1.3 -} {0} +} 0 test textDisp-19.11.5 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 16.0 16.1 -} {0} +} 0 test textDisp-19.11.5.1 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 16.0 16.5 -} {0} +} 0 test textDisp-19.11.6 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 16.0 16.24 -} {1} +} 1 test textDisp-19.11.7 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 16.0 16.40 -} {2} +} 2 test textDisp-19.11.8 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines "16.0 displaylineend +1c" "16.0 lineend" -} {3} +} 3 test textDisp-19.11.9 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 16.0 "16.0 lineend" -} {4} +} 4 test textDisp-19.11.10 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 16.0 "16.0 +4displaylines" -} {4} +} 4 test textDisp-19.11.11 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 16.0 "16.0 +2displaylines" -} {2} +} 2 test textDisp-19.11.12 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines "16.0 +1displayline" "16.0 +2displaylines -1c" -} {0} +} 0 .t tag configure elide -elide 1 test textDisp-19.11.13 {TextWidgetCmd procedure, "count -displaylines"} { .t tag remove elide 1.0 end .t tag add elide "16.0 +1displaylines" "16.0 +1displaylines +6c" .t count -displaylines 16.0 "16.0 +4displaylines" -} {4} +} 4 test textDisp-19.11.14 {TextWidgetCmd procedure, "count -displaylines"} { .t tag remove elide 1.0 end .t tag add elide "16.0 +1displaylines" "16.0 +1displaylines displaylineend" .t count -displaylines 16.0 "16.0 +4displaylines" -} {4} +} 4 test textDisp-19.11.15 {TextWidgetCmd procedure, "count -displaylines"} { .t tag remove elide 1.0 end .t tag add elide "16.0 +1displaylines" "16.0 +2displaylines" .t count -displaylines 16.0 "16.0 +4displaylines -1c" -} {3} +} 3 test textDisp-19.11.15a {TextWidgetCmd procedure, "count -displaylines"} { .t tag remove elide 1.0 end .t tag add elide "16.0 +1displaylines" "16.0 +2displaylines" .t count -displaylines 16.0 "16.0 +4displaylines" -} {4} +} 4 test textDisp-19.11.16 {TextWidgetCmd procedure, "count -displaylines"} { .t tag remove elide 1.0 end .t tag add elide "12.0" "14.0" .t count -displaylines 12.0 16.0 -} {2} +} 2 test textDisp-19.11.17 {TextWidgetCmd procedure, "index +displaylines"} { .t tag remove elide 1.0 end .t tag add elide "12.0" "14.0" @@ -2736,7 +2742,7 @@ test textDisp-19.11.19 {TextWidgetCmd procedure, "count -displaylines"} { .t tag remove elide 1.0 end .t tag add elide "12.0" "16.0 +1displaylines" .t count -displaylines 12.0 17.0 -} {4} +} 4 test textDisp-19.11.20 {TextWidgetCmd procedure, "index +displaylines"} { .t tag remove elide 1.0 end .t tag add elide "12.0" "16.0 +1displaylines" @@ -3016,7 +3022,7 @@ set res [.tt.u count -displaylines 3.10 2.173] destroy .tt unset message set res -} {-1} +} -1 .t delete 1.0 end .t insert end "Line 1" @@ -3503,7 +3509,7 @@ test textDisp-26.5 {AdjustForTab procedure, numeric alignment} { .t tag add y 1.2 .t tag add y 1.5 lindex [.t bbox 1.3] 0 -} {120} +} 120 test textDisp-26.6 {AdjustForTab procedure, numeric alignment} { .t delete 1.0 end .t insert 1.0 a\t1,456.234 @@ -3512,7 +3518,7 @@ test textDisp-26.6 {AdjustForTab procedure, numeric alignment} { .t tag add x 1.0 end .t tag add y 1.2 lindex [.t bbox 1.7] 0 -} {120} +} 120 test textDisp-26.7 {AdjustForTab procedure, numeric alignment} { .t delete 1.0 end .t insert 1.0 a\t1.456.234,7 @@ -3521,7 +3527,7 @@ test textDisp-26.7 {AdjustForTab procedure, numeric alignment} { .t tag add x 1.0 end .t tag add y 1.2 lindex [.t bbox 1.11] 0 -} {120} +} 120 test textDisp-26.8 {AdjustForTab procedure, numeric alignment} { .t delete 1.0 end .t insert 1.0 a\ttest @@ -3530,7 +3536,7 @@ test textDisp-26.8 {AdjustForTab procedure, numeric alignment} { .t tag add x 1.0 end .t tag add y 1.2 lindex [.t bbox 1.6] 0 -} {120} +} 120 test textDisp-26.9 {AdjustForTab procedure, numeric alignment} { .t delete 1.0 end .t insert 1.0 a\t1234 @@ -3539,7 +3545,7 @@ test textDisp-26.9 {AdjustForTab procedure, numeric alignment} { .t tag add x 1.0 end .t tag add y 1.2 lindex [.t bbox 1.6] 0 -} {120} +} 120 test textDisp-26.10 {AdjustForTab procedure, numeric alignment} { .t delete 1.0 end .t insert 1.0 a\t1.234567 @@ -3548,7 +3554,7 @@ test textDisp-26.10 {AdjustForTab procedure, numeric alignment} { .t tag add x 1.0 end .t tag add y 1.5 lindex [.t bbox 1.3] 0 -} {120} +} 120 test textDisp-26.11 {AdjustForTab procedure, numeric alignment} { .t delete 1.0 end .t insert 1.0 a\tx=1.234567 @@ -3558,7 +3564,7 @@ test textDisp-26.11 {AdjustForTab procedure, numeric alignment} { .t tag add y 1.7 .t tag add y 1.9 lindex [.t bbox 1.5] 0 -} {120} +} 120 test textDisp-26.12 {AdjustForTab procedure, adjusting chunks} { .t delete 1.0 end .t insert 1.0 a\tx1.234567 @@ -3571,7 +3577,7 @@ test textDisp-26.12 {AdjustForTab procedure, adjusting chunks} { .t window create 1.3 -window .b updateText lindex [.t bbox 1.5] 0 -} {120} +} 120 test textDisp-26.13 {AdjustForTab procedure, not enough space} {textfonts} { .t delete 1.0 end .t insert 1.0 "abc\txyz\tqrs\txyz\t0" @@ -3728,7 +3734,7 @@ test textDisp-27.7.2 {SizeOfTab procedure, fractional tab interpolation problem} .t configure -tabs $precisetab updateText expr {[lindex $res 0] - [lindex [.t bbox 1.20] 0]} -} {0} +} 0 .t configure -wrap char -tabs {} -width 20 updateText @@ -3744,7 +3750,7 @@ test textDisp-27.9 {SizeOfTab procedure, left alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\txyzzyabc .t tag delete x - .t tag configure x -tabs {120} + .t tag configure x -tabs 120 .t tag add x 1.0 end list [.t bbox 1.3] [.t bbox 1.4] } [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] @@ -3760,7 +3766,7 @@ test textDisp-27.11 {SizeOfTab procedure, making tabs at least as wide as a spac .t delete 1.0 end .t insert 1.0 abc\tdefghijklmnopqrst .t tag delete x - .t tag configure x -tabs {120} + .t tag configure x -tabs 120 .t tag add x 1.0 end list [.t bbox 1.5] [.t bbox 1.6] } [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] @@ -3933,14 +3939,14 @@ test textDisp-30.1 {elidden text joining multiple logical lines} { .t2.t tag configure elidden -elide 1 -background red .t2.t tag add elidden 1.2 3.2 .t2.t count -displaylines 1.0 end -} {1} +} 1 test textDisp-30.2 {elidden text joining multiple logical lines} { .t2.t delete 1.0 end .t2.t insert 1.0 "1111\n2222\n3333" .t2.t tag configure elidden -elide 1 -background red .t2.t tag add elidden 1.2 2.2 .t2.t count -displaylines 1.0 end -} {2} +} 2 catch {destroy .t2} .t configure -height 1 @@ -4247,7 +4253,7 @@ test textDisp-33.3 {one line longer than fits in the widget} { # Each line should have been recalculated just once .tt debug 0 expr {[llength $tk_textHeightCalc] == [.tt count -displaylines 1.0 end]} -} {1} +} 1 test textDisp-33.4 {one line longer than fits in the widget} { destroy .tt pack [text .tt -wrap char] @@ -4318,7 +4324,7 @@ test textDisp-34.1 {Line heights recalculation problem: bug 2677890} -setup { set negative } -cleanup { destroy .t1 -} -result {0} +} -result 0 test textDisp-35.1 {Init value of charHeight - Dancing scrollbar bug 1499165} -setup { pack [text .t1] -fill both -expand y -side left diff --git a/tests/textImage.test b/tests/textImage.test index 2666ec5..9c40045 100644 --- a/tests/textImage.test +++ b/tests/textImage.test @@ -4,7 +4,7 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/textIndex.test b/tests/textIndex.test index 31ae495..f2cccac 100644 --- a/tests/textIndex.test +++ b/tests/textIndex.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test the code in the file tkTextIndex.c. # This file is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -30,7 +30,7 @@ wm deiconify . abcdefghijklm 12345 Line 4 -b\u4e4fy GIrl .#@? x_yz +b乏y GIrl .#@? x_yz !@#$% Line 7" @@ -118,7 +118,7 @@ test textIndex-1.16 {TkTextMakeByteIndex: UTF-8 characters} {testtext} { test textIndex-1.17 {TkTextMakeByteIndex: prevent splitting UTF-8 character} \ {testtext} { # ((byteIndex > index) && (segPtr->typePtr == &tkTextCharType)) - # Wrong answer would be \xb9 (the 2nd byte of UTF rep of 0x4e4f). + # Wrong answer would be ¹ (the 2nd byte of UTF rep of 0x4e4f). set x [testtext .t byteindex 5 2] list $x [.t get insert] @@ -128,7 +128,7 @@ test textIndex-1.18 {TkTextMakeByteIndex: prevent splitting UTF-8 character} \ # ((byteIndex > index) && (segPtr->typePtr == &tkTextCharType)) testtext .t byteindex 5 1 .t get insert -} "\u4e4f" +} "乏" test textIndex-2.1 {TkTextMakeCharIndex} { # (lineIndex < 0) @@ -183,7 +183,7 @@ test textIndex-2.11 {TkTextMakeCharIndex: verify index is in range} { } 3.4 test textIndex-2.12 {TkTextMakeCharIndex: verify index is in range} { # (segPtr->typePtr == &tkTextCharType) - # Wrong answer would be \xb9 (the 2nd byte of UTF rep of 0x4e4f). + # Wrong answer would be ¹ (the 2nd byte of UTF rep of 0x4e4f). .t mark set insert 5.2 .t get insert @@ -608,7 +608,7 @@ test textIndex-14.15 {TkTextIndexBackChars: UTF} { } y test textIndex-14.16 {TkTextIndexBackChars: UTF} { .t get {5.3 - 2 chars} -} \u4e4f +} 乏 test textIndex-14.17 {TkTextIndexBackChars: UTF} { .t get {5.3 - 3 chars} } b @@ -809,7 +809,7 @@ test textIndex-19.12.1 {Display lines} { test textIndex-19.12.2 {Display lines} { .t compare [.t index "2.50 + 100 displaylines"] == "end - 1 c" -} {1} +} 1 test textIndex-19.13 {Display lines} { destroy {*}[pack content .] @@ -871,19 +871,19 @@ test textIndex-21.9 {text index wordend} { text_test_word worde "x.y" end-1 } 2 test textIndex-21.10 {text index wordend, unicode} { - text_test_word wordend "xyz\u00c7de fg" 0 + text_test_word wordend "xyzÇde fg" 0 } 6 test textIndex-21.11 {text index wordend, unicode} { - text_test_word wordend "xyz\uc700de fg" 0 + text_test_word wordend "xyz윀de fg" 0 } 6 test textIndex-21.12 {text index wordend, unicode} { - text_test_word wordend "xyz\u203fde fg" 0 + text_test_word wordend "xyz‿de fg" 0 } 6 test textIndex-21.13 {text index wordend, unicode} { - text_test_word wordend "xyz\u2045de fg" 0 + text_test_word wordend "xyz⁅de fg" 0 } 3 test textIndex-21.14 {text index wordend, unicode} { - text_test_word wordend "\uc700\uc700 abc" 8 + text_test_word wordend "윀윀 abc" 8 } 6 test textIndex-22.5 {text index wordstart} { @@ -905,19 +905,19 @@ test textIndex-22.10 {text index wordstart} { text_test_word wordstart "one two three" end-5 } 7 test textIndex-22.11 {text index wordstart, unicode} { - text_test_word wordstart "one tw\u00c7o three" 7 + text_test_word wordstart "one twÇo three" 7 } 4 test textIndex-22.12 {text index wordstart, unicode} { - text_test_word wordstart "ab\uc700\uc700 cdef ghi" 12 + text_test_word wordstart "ab윀윀 cdef ghi" 12 } 10 test textIndex-22.13 {text index wordstart, unicode} { - text_test_word wordstart "\uc700\uc700 abc" 8 + text_test_word wordstart "윀윀 abc" 8 } 3 test textIndex-22.14 {text index wordstart, unicode, start index at internal segment start} { catch {destroy .t} text .t - .t insert end "C'est du texte en fran\u00e7ais\n" - .t insert end "\u042D\u0442\u043E\u0020\u0442\u0435\u043A\u0441\u0442\u0020\u043D\u0430\u0020\u0440\u0443\u0441\u0441\u043A\u043E\u043C" + .t insert end "C'est du texte en français\n" + .t insert end "Это текст на русском" .t mark set insert 1.23 set res [.t index "1.23 wordstart"] .t mark set insert 2.16 diff --git a/tests/textMark.test b/tests/textMark.test index 4d2e623..bbe839f 100644 --- a/tests/textMark.test +++ b/tests/textMark.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test the code in the file tkTextMark.c. # This file is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -52,7 +52,7 @@ test textMark-1.4 {TkTextMarkCmd - "gravity" option} -body { } -result {right 1.4} test textMark-1.5 {TkTextMarkCmd - "gravity" option} -body { .t mark set x 1.3 - .t mark g x left + .t mark gr x left .t insert 1.3 x list [.t mark gravity x] [.t index x] } -result {left 1.3} @@ -177,7 +177,7 @@ test textMark-6.4 {TkTextMarkNameToIndex, with mark outside -startline/-endline } -result {1 {bad text index "mymark"} 1.0 1.0 1 {bad text index "mymark"} L 1 {bad text index "mymark"}} test textMark-6.5 {insert and current marks in an empty peer - bug 3487407} -body { .t mark set insert 1.0 - .t configure -start 5 -end 5 + .t configure -startline 5 -endline 5 set res [.t index insert] } -cleanup { .t configure -startline {} -endline {} diff --git a/tests/textTag.test b/tests/textTag.test index e36cf30..b703a81 100644 --- a/tests/textTag.test +++ b/tests/textTag.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test the code in the file tkTextTag.c. # This file is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -11,21 +11,32 @@ namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +set textWidgetFont {Courier 12} +set bigFont {Courier 24} + +# what is needed is a font that is both fixed-width and featuring a +# specific size because in some tests (that will be constrained by +# haveFontSizes), a tag applying the $bigFont will be set to some +# characters, which action has the effect of changing what character +# is under the mouse pointer, which is the purpose of the tests +testConstraint haveFontSizes [expr { + [font metrics $textWidgetFont -fixed] && + [font actual $textWidgetFont -size] == 12 && + [font metrics $bigFont -fixed] && + [font actual $bigFont -size] == 24 } +] + testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] testConstraint failsOnUbuntuNoXft [expr {[testConstraint failsOnUbuntu] || (![catch {tk::pkgconfig get fontsystem} fs] && ($fs eq "xft"))}] destroy .t text .t -width 20 -height 10 -testConstraint haveCourier12 [expr {[catch { - .t configure -font {Courier 12} -}] == 0}] pack .t -expand 1 -fill both update .t debug on wm geometry . {} -set bigFont {Helvetica 24} # The statements below reset the main window; it's needed if the window # manager is mwm, to make mwm forget about a previous minimum size setting. @@ -43,130 +54,96 @@ bOy GIrl .#@? x_yz !@#$% Line 7" -test textTag-1.1 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.1 {tag configuration options} -body { .t tag configure x -background #012345 .t tag cget x -background } -cleanup { .t tag configure x -background [lindex [.t tag configure x -background] 3] } -result {#012345} -test textTag-1.2 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.2 {configuration options} -body { .t tag configure x -background non-existent } -cleanup { .t tag configure x -background [lindex [.t tag configure x -background] 3] } -returnCodes error -result {unknown color name "non-existent"} -test textTag-1.3 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.3 {tag configuration options} -body { .t tag configure x -bgstipple gray50 .t tag cget x -bgstipple } -cleanup { .t tag configure x -bgstipple [lindex [.t tag configure x -bgstipple] 3] } -result {gray50} -test textTag-1.4 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.4 {configuration options} -body { .t tag configure x -bgstipple badStipple } -cleanup { .t tag configure x -bgstipple [lindex [.t tag configure x -bgstipple] 3] } -returnCodes error -result {bitmap "badStipple" not defined} -test textTag-1.5 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.5 {tag configuration options} -body { .t tag configure x -borderwidth 2 .t tag cget x -borderwidth } -cleanup { .t tag configure x -borderwidth [lindex [.t tag configure x -borderwidth] 3] -} -result {2} -test textTag-1.6 {configuration options} -constraints { - haveCourier12 -} -body { +} -result 2 +test textTag-1.6 {configuration options} -body { .t tag configure x -borderwidth 46q } -cleanup { .t tag configure x -borderwidth [lindex [.t tag configure x -borderwidth] 3] } -returnCodes error -result {bad screen distance "46q"} -test textTag-1.7 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.7 {tag configuration options} -body { .t tag configure x -fgstipple gray25 .t tag cget x -fgstipple } -cleanup { .t tag configure x -fgstipple [lindex [.t tag configure x -fgstipple] 3] } -result {gray25} -test textTag-1.8 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.8 {configuration options} -body { .t tag configure x -fgstipple bogus } -cleanup { .t tag configure x -fgstipple [lindex [.t tag configure x -fgstipple] 3] } -returnCodes error -result {bitmap "bogus" not defined} -test textTag-1.9 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.9 {tag configuration options} -body { .t tag configure x -font fixed .t tag cget x -font } -cleanup { .t tag configure x -font [lindex [.t tag configure x -font] 3] } -result {fixed} -test textTag-1.10 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.10 {tag configuration options} -body { .t tag configure x -foreground #001122 .t tag cget x -foreground } -cleanup { .t tag configure x -foreground [lindex [.t tag configure x -foreground] 3] } -result {#001122} -test textTag-1.11 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.11 {configuration options} -body { .t tag configure x -foreground {silly color} } -cleanup { .t tag configure x -foreground [lindex [.t tag configure x -foreground] 3] } -returnCodes error -result {unknown color name "silly color"} -test textTag-1.12 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.12 {tag configuration options} -body { .t tag configure x -justify left .t tag cget x -justify } -cleanup { .t tag configure x -justify [lindex [.t tag configure x -justify] 3] } -result {left} -test textTag-1.13 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.13 {configuration options} -body { .t tag configure x -justify middle } -cleanup { .t tag configure x -justify [lindex [.t tag configure x -justify] 3] } -returnCodes error -result {bad justification "middle": must be left, right, or center} -test textTag-1.14 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.14 {tag configuration options} -body { .t tag configure x -lmargin1 10 .t tag cget x -lmargin1 } -cleanup { .t tag configure x -lmargin1 [lindex [.t tag configure x -lmargin1] 3] -} -result {10} -test textTag-1.15 {configuration options} -constraints { - haveCourier12 -} -body { +} -result 10 +test textTag-1.15 {configuration options} -body { .t tag configure x -lmargin1 bad } -cleanup { .t tag configure x -lmargin1 [lindex [.t tag configure x -lmargin1] 3] } -returnCodes error -result {bad screen distance "bad"} -test textTag-1.16 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.16 {tag configuration options} -body { .t tag configure x -lmargin2 10 .t tag cget x -lmargin2 } -cleanup { .t tag configure x -lmargin2 [lindex [.t tag configure x -lmargin2] 3] -} -result {10} -test textTag-1.17 {configuration options} -constraints { - haveCourier12 -} -body { +} -result 10 +test textTag-1.17 {configuration options} -body { .t tag configure x -lmargin2 bad } -cleanup { .t tag configure x -lmargin2 [lindex [.t tag configure x -lmargin2] 3] @@ -182,32 +159,24 @@ test textTag-1.17b {configuration options} -body { } -cleanup { .t tag configure x -lmargincolor [lindex [.t tag configure x -lmargincolor] 3] } -returnCodes error -result {unknown color name "non-existent"} -test textTag-1.18 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.18 {tag configuration options} -body { .t tag configure x -offset 2 .t tag cget x -offset } -cleanup { .t tag configure x -offset [lindex [.t tag configure x -offset] 3] -} -result {2} -test textTag-1.19 {configuration options} -constraints { - haveCourier12 -} -body { +} -result 2 +test textTag-1.19 {configuration options} -body { .t tag configure x -offset 100xyz } -cleanup { .t tag configure x -offset [lindex [.t tag configure x -offset] 3] } -returnCodes error -result {bad screen distance "100xyz"} -test textTag-1.20 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.20 {tag configuration options} -body { .t tag configure x -overstrike on .t tag cget x -overstrike } -cleanup { .t tag configure x -overstrike [lindex [.t tag configure x -overstrike] 3] } -result {on} -test textTag-1.21 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.21 {configuration options} -body { .t tag configure x -overstrike stupid } -cleanup { .t tag configure x -overstrike [lindex [.t tag configure x -overstrike] 3] @@ -223,32 +192,24 @@ test textTag-1.21b {configuration options} -body { } -cleanup { .t tag configure x -overstrikefg [lindex [.t tag configure x -overstrikefg] 3] } -returnCodes error -result {unknown color name "stupid"} -test textTag-1.22 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.22 {tag configuration options} -body { .t tag configure x -relief raised .t tag cget x -relief } -cleanup { .t tag configure x -relief [lindex [.t tag configure x -relief] 3] } -result {raised} -test textTag-1.23 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.23 {configuration options} -body { .t tag configure x -relief stupid } -cleanup { .t tag configure x -relief [lindex [.t tag configure x -relief] 3] } -returnCodes error -result {bad relief "stupid": must be flat, groove, raised, ridge, solid, or sunken} -test textTag-1.24 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.24 {tag configuration options} -body { .t tag configure x -rmargin 10 .t tag cget x -rmargin } -cleanup { .t tag configure x -rmargin [lindex [.t tag configure x -rmargin] 3] -} -result {10} -test textTag-1.25 {configuration options} -constraints { - haveCourier12 -} -body { +} -result 10 +test textTag-1.25 {configuration options} -body { .t tag configure x -rmargin bad } -cleanup { .t tag configure x -rmargin [lindex [.t tag configure x -rmargin] 3] @@ -286,77 +247,57 @@ test textTag-1.25f {configuration options} -body { } -cleanup { .t tag configure x -selectforeground [lindex [.t tag configure x -selectforeground] 3] } -returnCodes error -result {unknown color name "non-existent"} -test textTag-1.26 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.26 {tag configuration options} -body { .t tag configure x -spacing1 10 .t tag cget x -spacing1 } -cleanup { .t tag configure x -spacing1 [lindex [.t tag configure x -spacing1] 3] -} -result {10} -test textTag-1.27 {configuration options} -constraints { - haveCourier12 -} -body { +} -result 10 +test textTag-1.27 {configuration options} -body { .t tag configure x -spacing1 bad } -cleanup { .t tag configure x -spacing1 [lindex [.t tag configure x -spacing1] 3] } -returnCodes error -result {bad screen distance "bad"} -test textTag-1.28 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.28 {tag configuration options} -body { .t tag configure x -spacing2 10 .t tag cget x -spacing2 } -cleanup { .t tag configure x -spacing2 [lindex [.t tag configure x -spacing2] 3] -} -result {10} -test textTag-1.29 {configuration options} -constraints { - haveCourier12 -} -body { +} -result 10 +test textTag-1.29 {configuration options} -body { .t tag configure x -spacing2 bad } -cleanup { .t tag configure x -spacing2 [lindex [.t tag configure x -spacing2] 3] } -returnCodes error -result {bad screen distance "bad"} -test textTag-1.30 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.30 {tag configuration options} -body { .t tag configure x -spacing3 10 .t tag cget x -spacing3 } -cleanup { .t tag configure x -spacing3 [lindex [.t tag configure x -spacing3] 3] -} -result {10} -test textTag-1.31 {configuration options} -constraints { - haveCourier12 -} -body { +} -result 10 +test textTag-1.31 {configuration options} -body { .t tag configure x -spacing3 bad } -cleanup { .t tag configure x -spacing3 [lindex [.t tag configure x -spacing3] 3] } -returnCodes error -result {bad screen distance "bad"} -test textTag-1.32 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.32 {tag configuration options} -body { .t tag configure x -tabs {10 20 30} .t tag cget x -tabs } -cleanup { .t tag configure x -tabs [lindex [.t tag configure x -tabs] 3] } -result {10 20 30} -test textTag-1.33 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.33 {configuration options} -body { .t tag configure x -tabs {10 fork} } -cleanup { .t tag configure x -tabs [lindex [.t tag configure x -tabs] 3] } -returnCodes error -result {bad tab alignment "fork": must be left, right, center, or numeric} -test textTag-1.34 {tag configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.34 {tag configuration options} -body { .t tag configure x -underline no .t tag cget x -underline } -cleanup { .t tag configure x -underline [lindex [.t tag configure x -underline] 3] } -result {no} -test textTag-1.35 {configuration options} -constraints { - haveCourier12 -} -body { +test textTag-1.35 {configuration options} -body { .t tag configure x -underline stupid } -cleanup { .t tag configure x -underline [lindex [.t tag configure x -underline] 3] @@ -374,43 +315,29 @@ test textTag-1.37 {configuration options} -body { } -returnCodes error -result {unknown color name "stupid"} -test textTag-2.1 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -body { +test textTag-2.1 {TkTextTagCmd - "add" option} -body { .t tag } -returnCodes error -result {wrong # args: should be ".t tag option ?arg ...?"} -test textTag-2.2 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -body { +test textTag-2.2 {TkTextTagCmd - "add" option} -body { .t tag gorp } -returnCodes error -result {bad tag option "gorp": must be add, bind, cget, configure, delete, lower, names, nextrange, prevrange, raise, ranges, or remove} -test textTag-2.3 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -body { +test textTag-2.3 {TkTextTagCmd - "add" option} -body { .t tag add foo } -returnCodes error -result {wrong # args: should be ".t tag add tagName index1 ?index2 index1 index2 ...?"} -test textTag-2.4 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -body { +test textTag-2.4 {TkTextTagCmd - "add" option} -body { .t tag add x gorp } -returnCodes error -result {bad text index "gorp"} -test textTag-2.5 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -body { +test textTag-2.5 {TkTextTagCmd - "add" option} -body { .t tag add x 1.2 gorp } -returnCodes error -result {bad text index "gorp"} -test textTag-2.6 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -setup { +test textTag-2.6 {TkTextTagCmd - "add" option} -setup { .t tag delete sel } -body { .t tag add sel 3.2 3.4 .t tag add sel 3.2 3.0 .t tag ranges sel } -result {3.2 3.4} -test textTag-2.7 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -setup { +test textTag-2.7 {TkTextTagCmd - "add" option} -setup { .t tag delete x } -body { .t tag add x 1.0 1.end @@ -418,9 +345,7 @@ test textTag-2.7 {TkTextTagCmd - "add" option} -constraints { } -cleanup { .t tag delete x } -result {1.0 1.6} -test textTag-2.8 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -setup { +test textTag-2.8 {TkTextTagCmd - "add" option} -setup { .t tag remove x 1.0 end } -body { .t tag add x 1.2 @@ -428,9 +353,7 @@ test textTag-2.8 {TkTextTagCmd - "add" option} -constraints { } -cleanup { .t tag delete x } -result {1.2 1.3} -test textTag-2.9 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -setup { +test textTag-2.9 {TkTextTagCmd - "add" option} -setup { destroy .t.e } -body { entry .t.e @@ -442,9 +365,7 @@ test textTag-2.9 {TkTextTagCmd - "add" option} -constraints { } -cleanup { destroy .t.e } -result 34 -test textTag-2.10 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -setup { +test textTag-2.10 {TkTextTagCmd - "add" option} -setup { destroy .t.e } -body { entry .t.e @@ -457,23 +378,19 @@ test textTag-2.10 {TkTextTagCmd - "add" option} -constraints { } -cleanup { destroy .t.e } -result {Text} -test textTag-2.11 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -body { +test textTag-2.11 {TkTextTagCmd - "add" option} -body { .t tag remove sel 1.0 end .t tag add sel 1.1 1.5 2.4 3.1 4.2 4.4 .t tag ranges sel } -result {1.1 1.5 2.4 3.1 4.2 4.4} -test textTag-2.12 {TkTextTagCmd - "add" option} -constraints { - haveCourier12 -} -body { +test textTag-2.12 {TkTextTagCmd - "add" option} -body { .t tag remove sel 1.0 end .t tag add sel 1.1 1.5 2.4 .t tag ranges sel } -cleanup { .t tag remove sel 1.0 end } -result {1.1 1.5 2.4 2.5} -test textTag-2.14 {tag add before -startline - Bug 1615425} haveCourier12 { +test textTag-2.14 {tag add before -startline - Bug 1615425} -body { text .tt for {set i 1} {$i <10} {incr i} { .tt insert end "Line $i\n" @@ -485,44 +402,32 @@ test textTag-2.14 {tag add before -startline - Bug 1615425} haveCourier12 { .tt tag add mytag 1.0 1.end destroy .ptt .tt set res 1 -} {1} +} -result 1 -test textTag-3.1 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.1 {TkTextTagCmd - "bind" option} -body { .t tag bind } -returnCodes error -result {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"} -test textTag-3.2 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.2 {TkTextTagCmd - "bind" option} -body { .t tag bind 1 2 3 4 } -returnCodes error -result {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"} -test textTag-3.3 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.3 {TkTextTagCmd - "bind" option} -body { .t tag bind x <Enter> script1 .t tag bind x <Enter> } -cleanup { .t tag delete x } -result {script1} -test textTag-3.4 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.4 {TkTextTagCmd - "bind" option} -body { .t tag bind x <Gorp> script2 } -returnCodes error -result {bad event type or keysym "Gorp"} -test textTag-3.5 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.5 {TkTextTagCmd - "bind" option} -body { .t tag delete x .t tag bind x <Enter> script1 .t tag bind x <FocusIn> script2 } -cleanup { .t tag delete x } -returnCodes error -result {requested illegal events; only key, button, motion, enter, leave, and virtual events may be used} -test textTag-3.6 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.6 {TkTextTagCmd - "bind" option} -body { .t tag delete x .t tag bind x <Enter> script1 catch {.t tag bind x <FocusIn> script2} @@ -530,9 +435,7 @@ test textTag-3.6 {TkTextTagCmd - "bind" option} -constraints { } -cleanup { .t tag delete x } -result {<Enter>} -test textTag-3.7 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.7 {TkTextTagCmd - "bind" option} -body { .t tag delete x .t tag bind x <Enter> script1 .t tag bind x <Leave> script2 @@ -541,9 +444,7 @@ test textTag-3.7 {TkTextTagCmd - "bind" option} -constraints { } -cleanup { .t tag delete x } -result {{<Enter> <Leave> a} script1 xyzzy} -test textTag-3.8 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.8 {TkTextTagCmd - "bind" option} -body { .t tag delete x .t tag bind x <Enter> script1 .t tag bind x <Enter> +script2 @@ -552,17 +453,13 @@ test textTag-3.8 {TkTextTagCmd - "bind" option} -constraints { .t tag delete x } -result {script1 script2} -test textTag-3.9 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.9 {TkTextTagCmd - "bind" option} -body { .t tag delete x .t tag bind x <Enter> } -cleanup { .t tag delete x } -returnCodes ok -result {} -test textTag-3.10 {TkTextTagCmd - "bind" option} -constraints { - haveCourier12 -} -body { +test textTag-3.10 {TkTextTagCmd - "bind" option} -body { .t tag delete x .t tag bind x < } -cleanup { @@ -570,30 +467,20 @@ test textTag-3.10 {TkTextTagCmd - "bind" option} -constraints { } -returnCodes error -result {no event type or button # or keysym} -test textTag-4.1 {TkTextTagCmd - "cget" option} -constraints { - haveCourier12 -} -body { +test textTag-4.1 {TkTextTagCmd - "cget" option} -body { .t tag cget a } -returnCodes error -result {wrong # args: should be ".t tag cget tagName option"} -test textTag-4.2 {TkTextTagCmd - "cget" option} -constraints { - haveCourier12 -} -body { +test textTag-4.2 {TkTextTagCmd - "cget" option} -body { .t tag cget a b c } -returnCodes error -result {wrong # args: should be ".t tag cget tagName option"} -test textTag-4.3 {TkTextTagCmd - "cget" option} -constraints { - haveCourier12 -} -body { +test textTag-4.3 {TkTextTagCmd - "cget" option} -body { .t tag delete foo .t tag cget foo bar } -returnCodes error -result {tag "foo" isn't defined in text widget} -test textTag-4.4 {TkTextTagCmd - "cget" option} -constraints { - haveCourier12 -} -body { +test textTag-4.4 {TkTextTagCmd - "cget" option} -body { .t tag cget sel bogus } -returnCodes error -result {unknown option "bogus"} -test textTag-4.5 {TkTextTagCmd - "cget" option} -constraints { - haveCourier12 -} -body { +test textTag-4.5 {TkTextTagCmd - "cget" option} -body { .t tag delete x .t tag configure x -background red .t tag cget x -background @@ -602,26 +489,18 @@ test textTag-4.5 {TkTextTagCmd - "cget" option} -constraints { } -result {red} -test textTag-5.1 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.1 {TkTextTagCmd - "configure" option} -body { .t tag configure -} -returnCodes error -result {wrong # args: should be ".t tag configure tagName ?-option? ?value? ?-option value ...?"} -test textTag-5.2 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +} -returnCodes error -result {wrong # args: should be ".t tag configure tagName ?-option value ...?"} +test textTag-5.2 {TkTextTagCmd - "configure" option} -body { .t tag configure x -foo } -returnCodes error -result {unknown option "-foo"} -test textTag-5.3 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.3 {TkTextTagCmd - "configure" option} -body { .t tag configure x -background red -underline } -cleanup { .t tag delete x } -returnCodes error -result {value for "-underline" missing} -test textTag-5.4 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.4 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -underline yes .t tag configure x -underline @@ -635,9 +514,7 @@ test textTag-5.4a {TkTextTagCmd - "configure" option} -body { } -cleanup { .t tag delete x } -result {-underlinefg {} {} {} lightgreen} -test textTag-5.5 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.5 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -overstrike on .t tag cget x -overstrike @@ -651,58 +528,44 @@ test textTag-5.5a {TkTextTagCmd - "configure" option} -body { } -cleanup { .t tag delete x } -result {-overstrikefg {} {} {} lightgreen} -test textTag-5.6 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.6 {TkTextTagCmd - "configure" option} -body { .t tag configure x -overstrike foo } -cleanup { .t tag delete x } -returnCodes error -result {expected boolean value but got "foo"} -test textTag-5.7 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.7 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -underline stupid } -cleanup { .t tag delete x } -returnCodes error -result {expected boolean value but got "stupid"} -test textTag-5.8 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.8 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -justify left .t tag configure x -justify } -cleanup { .t tag delete x } -result {-justify {} {} {} left} -test textTag-5.9 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.9 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -justify bogus } -cleanup { .t tag delete x } -returnCodes error -result {bad justification "bogus": must be left, right, or center} -test textTag-5.10 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.10 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -justify fill } -cleanup { .t tag delete x } -returnCodes error -result {bad justification "fill": must be left, right, or center} -test textTag-5.11 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.11 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -offset 2 .t tag configure x -offset } -cleanup { .t tag delete x } -result {-offset {} {} {} 2} -test textTag-5.12 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.12 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -offset 1.0q } -cleanup { @@ -721,17 +584,13 @@ test textTag-5.13 {TkTextTagCmd - "configure" option} -body { {-rmargin {} {} {} 5} \ {-lmargincolor {} {} {} darkblue} {-rmargincolor {} {} {} lightgreen} \ ] -test textTag-5.14 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.14 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -lmargin1 2.0x } -cleanup { .t tag delete x } -returnCodes error -result {bad screen distance "2.0x"} -test textTag-5.15 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.15 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -lmargin2 gorp } -cleanup { @@ -743,9 +602,7 @@ test textTag-5.15a {TkTextTagCmd - "configure" option} -body { } -cleanup { .t tag delete x } -returnCodes error -result {unknown color name "rainbow"} -test textTag-5.16 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.16 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -rmargin 140.1.1 } -cleanup { @@ -758,9 +615,7 @@ test textTag-5.16a {TkTextTagCmd - "configure" option} -body { .t tag delete x } -returnCodes error -result {unknown color name "rainbow"} .t tag delete x -test textTag-5.17 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.17 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -spacing1 2 -spacing2 4 -spacing3 6 list [.t tag configure x -spacing1] [.t tag configure x -spacing2] \ @@ -768,33 +623,25 @@ test textTag-5.17 {TkTextTagCmd - "configure" option} -constraints { } -cleanup { .t tag delete x } -result {{-spacing1 {} {} {} 2} {-spacing2 {} {} {} 4} {-spacing3 {} {} {} 6}} -test textTag-5.18 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.18 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -spacing1 2.0x } -cleanup { .t tag delete x } -returnCodes error -result {bad screen distance "2.0x"} -test textTag-5.19 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.19 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -spacing1 lousy } -cleanup { .t tag delete x } -returnCodes error -result {bad screen distance "lousy"} -test textTag-5.20 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.20 {TkTextTagCmd - "configure" option} -body { .t tag delete x .t tag configure x -spacing1 4.2.3 } -cleanup { .t tag delete x } -returnCodes error -result {bad screen distance "4.2.3"} -test textTag-5.21 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.21 {TkTextTagCmd - "configure" option} -body { .t configure -selectborderwidth 2 -selectforeground blue \ -selectbackground black .t tag configure sel -borderwidth 4 -foreground green -background yellow @@ -804,9 +651,7 @@ test textTag-5.21 {TkTextTagCmd - "configure" option} -constraints { } return $x } -result {4 green yellow} -test textTag-5.22 {TkTextTagCmd - "configure" option} -constraints { - haveCourier12 -} -body { +test textTag-5.22 {TkTextTagCmd - "configure" option} -body { .t configure -selectborderwidth 20 .t tag configure sel -borderwidth {} .t cget -selectborderwidth @@ -858,19 +703,13 @@ test textTag-5.24 {TkTextTagCmd - "configure" option} -body { return $x } -result {yellow blue red white} -test textTag-6.1 {TkTextTagCmd - "delete" option} -constraints { - haveCourier12 -} -body { +test textTag-6.1 {TkTextTagCmd - "delete" option} -body { .t tag delete } -returnCodes error -result {wrong # args: should be ".t tag delete tagName ?tagName ...?"} -test textTag-6.2 {TkTextTagCmd - "delete" option} -constraints { - haveCourier12 -} -body { +test textTag-6.2 {TkTextTagCmd - "delete" option} -body { .t tag delete zork } -returnCodes ok -result {} -test textTag-6.3 {TkTextTagCmd - "delete" option} -constraints { - haveCourier12 -} -setup { +test textTag-6.3 {TkTextTagCmd - "delete" option} -setup { .t tag delete {*}[.t tag names] } -body { .t tag config x -background black @@ -881,9 +720,7 @@ test textTag-6.3 {TkTextTagCmd - "delete" option} -constraints { } -cleanup { .t tag delete x } -result {sel x} -test textTag-6.4 {TkTextTagCmd - "delete" option} -constraints { - haveCourier12 -} -setup { +test textTag-6.4 {TkTextTagCmd - "delete" option} -setup { .t tag delete {*}[.t tag names] } -body { .t tag config x -background black @@ -892,9 +729,7 @@ test textTag-6.4 {TkTextTagCmd - "delete" option} -constraints { eval .t tag delete [.t tag names] .t tag names } -result {sel} -test textTag-6.5 {TkTextTagCmd - "delete" option} -constraints { - haveCourier12 -} -body { +test textTag-6.5 {TkTextTagCmd - "delete" option} -body { .t tag bind x <Enter> foo .t tag delete x .t tag configure x -background black @@ -904,24 +739,16 @@ test textTag-6.5 {TkTextTagCmd - "delete" option} -constraints { } -result {} -test textTag-7.1 {TkTextTagCmd - "lower" option} -constraints { - haveCourier12 -} -body { +test textTag-7.1 {TkTextTagCmd - "lower" option} -body { .t tag lower } -returnCodes error -result {wrong # args: should be ".t tag lower tagName ?belowThis?"} -test textTag-7.2 {TkTextTagCmd - "lower" option} -constraints { - haveCourier12 -} -body { +test textTag-7.2 {TkTextTagCmd - "lower" option} -body { .t tag lower foo } -returnCodes error -result {tag "foo" isn't defined in text widget} -test textTag-7.3 {TkTextTagCmd - "lower" option} -constraints { - haveCourier12 -} -body { +test textTag-7.3 {TkTextTagCmd - "lower" option} -body { .t tag lower sel bar } -returnCodes error -result {tag "bar" isn't defined in text widget} -test textTag-7.4 {TkTextTagCmd - "lower" option} -constraints { - haveCourier12 -} -setup { +test textTag-7.4 {TkTextTagCmd - "lower" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -933,9 +760,7 @@ test textTag-7.4 {TkTextTagCmd - "lower" option} -constraints { } -cleanup { .t tag delete {*}[.t tag names] } -result {c sel a b d} -test textTag-7.5 {TkTextTagCmd - "lower" option} -constraints { - haveCourier12 -} -setup { +test textTag-7.5 {TkTextTagCmd - "lower" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -947,9 +772,7 @@ test textTag-7.5 {TkTextTagCmd - "lower" option} -constraints { } -cleanup { .t tag delete {*}[.t tag names] } -result {sel a d b c} -test textTag-7.6 {TkTextTagCmd - "lower" option} -constraints { - haveCourier12 -} -setup { +test textTag-7.6 {TkTextTagCmd - "lower" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -963,16 +786,12 @@ test textTag-7.6 {TkTextTagCmd - "lower" option} -constraints { } -result {sel b a c d} -test textTag-8.1 {TkTextTagCmd - "names" option} -constraints { - haveCourier12 -} -body { +test textTag-8.1 {TkTextTagCmd - "names" option} -body { .t tag names a b } -cleanup { .t tag delete {*}[.t tag names] } -returnCodes error -result {wrong # args: should be ".t tag names ?index?"} -test textTag-8.2 {TkTextTagCmd - "names" option} -constraints { - haveCourier12 -} -setup { +test textTag-8.2 {TkTextTagCmd - "names" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -983,9 +802,7 @@ test textTag-8.2 {TkTextTagCmd - "names" option} -constraints { } -cleanup { .t tag delete {*}[.t tag names] } -result {sel a b c d} -test textTag-8.3 {TkTextTagCmd - "names" option} -constraints { - haveCourier12 -} -setup { +test textTag-8.3 {TkTextTagCmd - "names" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -1000,24 +817,16 @@ test textTag-8.3 {TkTextTagCmd - "names" option} -constraints { } -result {c {a b}} -test textTag-9.1 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -body { +test textTag-9.1 {TkTextTagCmd - "nextrange" option} -body { .t tag nextrange x } -returnCodes error -result {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"} -test textTag-9.2 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -body { +test textTag-9.2 {TkTextTagCmd - "nextrange" option} -body { .t tag nextrange x 1 2 3 } -returnCodes error -result {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"} -test textTag-9.3 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -body { +test textTag-9.3 {TkTextTagCmd - "nextrange" option} -body { .t tag nextrange foo 1.0 } -returnCodes ok -result {} -test textTag-9.4 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.4 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1025,9 +834,7 @@ test textTag-9.4 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -returnCodes error -result {bad text index "foo"} -test textTag-9.5 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.5 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1037,9 +844,7 @@ test textTag-9.5 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -returnCodes error -result {bad text index "bar"} -test textTag-9.6 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.6 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1049,9 +854,7 @@ test textTag-9.6 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.3 2.5} -test textTag-9.7 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.7 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1061,9 +864,7 @@ test textTag-9.7 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.3 2.5} -test textTag-9.8 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.8 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1073,9 +874,7 @@ test textTag-9.8 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.3 2.5} -test textTag-9.9 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.9 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1085,9 +884,7 @@ test textTag-9.9 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.9 3.1} -test textTag-9.10 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.10 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1097,9 +894,7 @@ test textTag-9.10 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {} -test textTag-9.11 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.11 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1109,9 +904,7 @@ test textTag-9.11 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.9 3.1} -test textTag-9.12 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.12 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1121,9 +914,7 @@ test textTag-9.12 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.9 3.1} -test textTag-9.13 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.13 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1133,9 +924,7 @@ test textTag-9.13 {TkTextTagCmd - "nextrange" option} -constraints { } -cleanup { .t tag delete x } -result {7.2 7.3} -test textTag-9.14 {TkTextTagCmd - "nextrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-9.14 {TkTextTagCmd - "nextrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1147,28 +936,20 @@ test textTag-9.14 {TkTextTagCmd - "nextrange" option} -constraints { } -result {} -test textTag-10.1 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -body { +test textTag-10.1 {TkTextTagCmd - "prevrange" option} -body { .t tag prevrange x } -returnCodes error -result {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"} -test textTag-10.2 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -body { +test textTag-10.2 {TkTextTagCmd - "prevrange" option} -body { .t tag prevrange x 1 2 3 } -returnCodes error -result {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"} -test textTag-10.3 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.3 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag prevrange foo end } -cleanup { .t tag delete x } -returnCodes ok -result {} -test textTag-10.4 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.4 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1178,9 +959,7 @@ test textTag-10.4 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -returnCodes error -result {bad text index "foo"} -test textTag-10.5 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.5 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1190,9 +969,7 @@ test textTag-10.5 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -returnCodes error -result {bad text index "bar"} -test textTag-10.6 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.6 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1202,9 +979,7 @@ test textTag-10.6 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {7.2 7.3} -test textTag-10.7 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.7 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1214,9 +989,7 @@ test textTag-10.7 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.3 2.5} -test textTag-10.8 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.8 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1226,9 +999,7 @@ test textTag-10.8 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.3 2.5} -test textTag-10.9 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.9 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1238,9 +1009,7 @@ test textTag-10.9 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.3 2.5} -test textTag-10.10 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.10 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1250,9 +1019,7 @@ test textTag-10.10 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {} -test textTag-10.11 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.11 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1262,9 +1029,7 @@ test textTag-10.11 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {} -test textTag-10.12 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.12 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1274,9 +1039,7 @@ test textTag-10.12 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.3 2.5} -test textTag-10.13 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.13 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1286,9 +1049,7 @@ test textTag-10.13 {TkTextTagCmd - "prevrange" option} -constraints { } -cleanup { .t tag delete x } -result {2.9 3.1} -test textTag-10.14 {TkTextTagCmd - "prevrange" option} -constraints { - haveCourier12 -} -setup { +test textTag-10.14 {TkTextTagCmd - "prevrange" option} -setup { .t tag delete x } -body { .t tag add x 2.3 2.5 @@ -1300,24 +1061,16 @@ test textTag-10.14 {TkTextTagCmd - "prevrange" option} -constraints { } -result {} -test textTag-11.1 {TkTextTagCmd - "raise" option} -constraints { - haveCourier12 -} -body { +test textTag-11.1 {TkTextTagCmd - "raise" option} -body { .t tag raise } -returnCodes error -result {wrong # args: should be ".t tag raise tagName ?aboveThis?"} -test textTag-11.2 {TkTextTagCmd - "raise" option} -constraints { - haveCourier12 -} -body { +test textTag-11.2 {TkTextTagCmd - "raise" option} -body { .t tag raise foo } -returnCodes error -result {tag "foo" isn't defined in text widget} -test textTag-11.3 {TkTextTagCmd - "raise" option} -constraints { - haveCourier12 -} -body { +test textTag-11.3 {TkTextTagCmd - "raise" option} -body { .t tag raise sel bar } -returnCodes error -result {tag "bar" isn't defined in text widget} -test textTag-11.4 {TkTextTagCmd - "raise" option} -constraints { - haveCourier12 -} -setup { +test textTag-11.4 {TkTextTagCmd - "raise" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -1329,9 +1082,7 @@ test textTag-11.4 {TkTextTagCmd - "raise" option} -constraints { } -cleanup { .t tag delete {*}[.t tag names] } -result {sel a b d c} -test textTag-11.5 {TkTextTagCmd - "raise" option} -constraints { - haveCourier12 -} -setup { +test textTag-11.5 {TkTextTagCmd - "raise" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -1343,9 +1094,7 @@ test textTag-11.5 {TkTextTagCmd - "raise" option} -constraints { } -cleanup { .t tag delete {*}[.t tag names] } -result {sel a b d c} -test textTag-11.6 {TkTextTagCmd - "raise" option} -constraints { - haveCourier12 -} -setup { +test textTag-11.6 {TkTextTagCmd - "raise" option} -setup { .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { @@ -1359,20 +1108,14 @@ test textTag-11.6 {TkTextTagCmd - "raise" option} -constraints { } -result {sel b c a d} -test textTag-12.1 {TkTextTagCmd - "ranges" option} -constraints { - haveCourier12 -} -body { +test textTag-12.1 {TkTextTagCmd - "ranges" option} -body { .t tag ranges } -returnCodes error -result {wrong # args: should be ".t tag ranges tagName"} -test textTag-12.2 {TkTextTagCmd - "ranges" option} -constraints { - haveCourier12 -} -body { +test textTag-12.2 {TkTextTagCmd - "ranges" option} -body { .t tag delete x .t tag ranges x } -result {} -test textTag-12.3 {TkTextTagCmd - "ranges" option} -constraints { - haveCourier12 -} -setup { +test textTag-12.3 {TkTextTagCmd - "ranges" option} -setup { .t tag delete x } -body { .t tag add x 2.2 @@ -1382,9 +1125,7 @@ test textTag-12.3 {TkTextTagCmd - "ranges" option} -constraints { } -cleanup { .t tag delete x } -result {2.2 2.3 2.7 4.6 5.2 5.5} -test textTag-12.4 {TkTextTagCmd - "ranges" option} -constraints { - haveCourier12 -} -setup { +test textTag-12.4 {TkTextTagCmd - "ranges" option} -setup { .t tag delete x } -body { .t tag add x 1.0 3.0 @@ -1395,14 +1136,10 @@ test textTag-12.4 {TkTextTagCmd - "ranges" option} -constraints { } -result {1.0 3.0 4.0 8.0} -test textTag-13.1 {TkTextTagCmd - "remove" option} -constraints { - haveCourier12 -} -body { +test textTag-13.1 {TkTextTagCmd - "remove" option} -body { .t tag remove } -returnCodes error -result {wrong # args: should be ".t tag remove tagName index1 ?index2 index1 index2 ...?"} -test textTag-13.2 {TkTextTagCmd - "remove" option} -constraints { - haveCourier12 -} -setup { +test textTag-13.2 {TkTextTagCmd - "remove" option} -setup { .t tag delete x } -body { .t tag add x 2.2 2.11 @@ -1411,9 +1148,7 @@ test textTag-13.2 {TkTextTagCmd - "remove" option} -constraints { } -cleanup { .t tag delete x } -result {2.2 2.3 2.7 2.11} -test textTag-13.3 {TkTextTagCmd - "remove" option} -constraints { - haveCourier12 -} -setup { +test textTag-13.3 {TkTextTagCmd - "remove" option} -setup { destroy .t.e } -body { entry .t.e @@ -1429,7 +1164,7 @@ test textTag-13.3 {TkTextTagCmd - "remove" option} -constraints { } -result {Text} -test textTag-14.1 {SortTags} -constraints haveCourier12 -setup { +test textTag-14.1 {SortTags} -setup { .t tag delete a b c d } -body { foreach i {a b c d} { @@ -1440,7 +1175,7 @@ test textTag-14.1 {SortTags} -constraints haveCourier12 -setup { .t tag delete a b c d } -result {a b c d} .t tag delete a b c d -test textTag-14.2 {SortTags} -constraints haveCourier12 -setup { +test textTag-14.2 {SortTags} -setup { .t tag delete a b c d } -body { foreach i {a b c d} { @@ -1453,7 +1188,7 @@ test textTag-14.2 {SortTags} -constraints haveCourier12 -setup { } -cleanup { .t tag delete a b c d } -result {a b c d} -test textTag-14.3 {SortTags} -constraints haveCourier12 -setup { +test textTag-14.3 {SortTags} -setup { .t tag delete {*}[.t tag names] } -body { for {set i 0} {$i < 30} {incr i} { @@ -1463,7 +1198,7 @@ test textTag-14.3 {SortTags} -constraints haveCourier12 -setup { } -cleanup { .t tag delete {*}[.t tag names] } -result {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29} -test textTag-14.4 {SortTags} -constraints haveCourier12 -setup { +test textTag-14.4 {SortTags} -setup { .t tag delete {*}[.t tag names] } -body { for {set i 0} {$i < 30} {incr i} { @@ -1478,7 +1213,8 @@ test textTag-14.4 {SortTags} -constraints haveCourier12 -setup { } -result {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29} - +set curFont [.t cget -font] +set curWrap [.t cget -wrap] set c [.t bbox 2.1] set x1 [expr {[lindex $c 0] + [lindex $c 2]/2}] set y1 [expr {[lindex $c 1] + [lindex $c 3]/2}] @@ -1488,8 +1224,17 @@ set y2 [expr {[lindex $c 1] + [lindex $c 3]/2}] set c [.t bbox 4.3] set x3 [expr {[lindex $c 0] + [lindex $c 2]/2}] set y3 [expr {[lindex $c 1] + [lindex $c 3]/2}] +.t configure -font $textWidgetFont -wrap none +update +set c [.t bbox 2.1] +set x4 [expr [lindex $c 0] + [lindex $c 2]/2] +set y4 [expr [lindex $c 1] + [lindex $c 3]/2] +set c [.t bbox 3.2] +set x5 [expr [lindex $c 0] + [lindex $c 2]/2] +set y5 [expr [lindex $c 1] + [lindex $c 3]/2] +.t configure -font $curFont -wrap $curWrap -test textTag-15.1 {TkTextBindProc} -constraints haveCourier12 -setup { +test textTag-15.1 {TkTextBindProc} -setup { .t tag delete x y wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 @@ -1515,17 +1260,17 @@ test textTag-15.1 {TkTextBindProc} -constraints haveCourier12 -setup { bind .t <ButtonRelease> {} } -result {x-up up up y-up up} -test textTag-15.2 {TkTextBindProc} -constraints haveCourier12 -setup { +test textTag-15.2 {TkTextBindProc} -setup { .t tag delete x y wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 } -body { .t tag bind x <Enter> {lappend x x-enter} - .t tag bind x <ButtonPress> {lappend x x-down} + .t tag bind x <Button> {lappend x x-down} .t tag bind x <ButtonRelease> {lappend x x-up} .t tag bind x <Leave> {lappend x x-leave} .t tag bind y <Enter> {lappend x y-enter} - .t tag bind y <ButtonPress> {lappend x y-down} + .t tag bind y <Button> {lappend x y-down} .t tag bind y <ButtonRelease> {lappend x y-up} .t tag bind y <Leave> {lappend x y-leave} event gen .t <Motion> -x 0 -y 0 @@ -1544,18 +1289,18 @@ test textTag-15.2 {TkTextBindProc} -constraints haveCourier12 -setup { .t tag delete x y } -result {x-enter | x-down | | x-up x-leave y-enter} -test textTag-15.3 {TkTextBindProc} -constraints haveCourier12 -setup { +test textTag-15.3 {TkTextBindProc} -setup { .t tag delete x y wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 } -body { .t tag bind x <Enter> {lappend x x-enter} - .t tag bind x <Any-ButtonPress-1> {lappend x x-down} - .t tag bind x <Any-ButtonRelease-1> {lappend x x-up} + .t tag bind x <Button-1> {lappend x x-down} + .t tag bind x <ButtonRelease-1> {lappend x x-up} .t tag bind x <Leave> {lappend x x-leave} .t tag bind y <Enter> {lappend x y-enter} - .t tag bind y <Any-ButtonPress-1> {lappend x y-down} - .t tag bind y <Any-ButtonRelease-1> {lappend x y-up} + .t tag bind y <Button-1> {lappend x y-down} + .t tag bind y <ButtonRelease-1> {lappend x y-up} .t tag bind y <Leave> {lappend x y-leave} event gen .t <Motion> -x 0 -y 0 set x {} @@ -1578,9 +1323,7 @@ test textTag-15.3 {TkTextBindProc} -constraints haveCourier12 -setup { } -result {x-enter | x-down | | | x-up | x-leave y-enter} -test textTag-16.1 {TkTextPickCurrent procedure} -constraints { - haveCourier12 -} -setup { +test textTag-16.1 {TkTextPickCurrent procedure} -setup { .t tag delete {*}[.t tag names] wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 @@ -1602,28 +1345,28 @@ test textTag-16.1 {TkTextPickCurrent procedure} -constraints { } -result {2.1 3.2 3.2 3.2 3.2 3.2 4.3} test textTag-16.2 {TkTextPickCurrent procedure} -constraints { - haveCourier12 failsOnUbuntuNoXft + haveFontSizes failsOnUbuntuNoXft } -setup { .t tag delete {*}[.t tag names] wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 + .t configure -font $textWidgetFont -wrap none } -body { .t tag configure big -font $bigFont # update needed here to stabilize the test update - event gen .t <ButtonRelease-1> -state 0x100 -x $x1 -y $y1 - event gen .t <Motion> -x $x2 -y $y2 + event gen .t <ButtonRelease-1> -state 0x100 -x $x4 -y $y4 + event gen .t <Motion> -x $x5 -y $y5 set x [.t index current] .t tag add big 3.0 update lappend x [.t index current] } -cleanup { .t tag delete big + .t configure -font $curFont -wrap $curWrap } -result {3.2 3.1} -test textTag-16.3 {TkTextPickCurrent procedure} -constraints { - haveCourier12 -} -setup { +test textTag-16.3 {TkTextPickCurrent procedure} -setup { foreach i {a b c d} { .t tag remove $i 1.0 end } @@ -1651,9 +1394,7 @@ test textTag-16.3 {TkTextPickCurrent procedure} -constraints { .t tag delete {*}[.t tag names] } -result {enter-a enter-b | leave-b enter-c | leave-a leave-c} -test textTag-16.4 {TkTextPickCurrent procedure} -constraints { - haveCourier12 -} -setup { +test textTag-16.4 {TkTextPickCurrent procedure} -setup { foreach i {a b c d} { .t tag remove $i 1.0 end } @@ -1681,65 +1422,71 @@ test textTag-16.4 {TkTextPickCurrent procedure} -constraints { } -result {enter-a enter-b enter-c | leave-c leave-b} test textTag-16.5 {TkTextPickCurrent procedure} -constraints { - haveCourier12 + haveFontSizes } -setup { foreach i {big a b c d} { .t tag remove $i 1.0 end } wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 + .t configure -font $textWidgetFont -wrap none } -body { .t tag configure big -font $bigFont - event gen .t <Motion> -x $x1 -y $y1 + event gen .t <Motion> -x $x4 -y $y4 .t tag bind a <Enter> {.t tag add big 3.0 3.2} .t tag add a 3.2 - event gen .t <Motion> -x $x2 -y $y2 + event gen .t <Motion> -x $x5 -y $y5 .t index current } -cleanup { .t tag delete a big + .t configure -font $curFont -wrap $curWrap } -result {3.2} test textTag-16.6 {TkTextPickCurrent procedure} -constraints { - haveCourier12 failsOnUbuntuNoXft + haveFontSizes failsOnUbuntuNoXft } -setup { foreach i {big a b c d} { .t tag remove $i 1.0 end } wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 + .t configure -font $textWidgetFont -wrap none } -body { .t tag configure big -font $bigFont - event gen .t <Motion> -x $x1 -y $y1 + event gen .t <Motion> -x $x4 -y $y4 .t tag bind a <Enter> {.t tag add big 3.0 3.2} .t tag add a 3.2 - event gen .t <Motion> -x $x2 -y $y2 + event gen .t <Motion> -x $x5 -y $y5 update .t index current } -cleanup { .t tag delete a big + .t configure -font $curFont -wrap $curWrap } -result {3.1} test textTag-16.7 {TkTextPickCurrent procedure} -constraints { - haveCourier12 failsOnUbuntuNoXft + haveFontSizes failsOnUbuntuNoXft } -setup { foreach i {big a b c d} { .t tag remove $i 1.0 end } wm geometry . +200+200 ; update event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50 + .t configure -font $textWidgetFont -wrap none } -body { .t tag configure big -font $bigFont .t tag bind a <Enter> {.t tag add big 3.0 3.2} .t tag add a 3.2 - event gen .t <Motion> -x $x1 -y $y1 + event gen .t <Motion> -x $x4 -y $y4 .t tag bind a <Leave> {.t tag add big 3.0 3.2} .t tag add a 2.1 - event gen .t <Motion> -x $x2 -y $y2 + event gen .t <Motion> -x $x5 -y $y5 update .t index current } -cleanup { .t tag delete a big + .t configure -font $curFont -wrap $curWrap } -result {3.1} diff --git a/tests/textWind.test b/tests/textWind.test index a11a418..55128be 100644 --- a/tests/textWind.test +++ b/tests/textWind.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test the code in the file tkTextWind.c. # This file is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -173,7 +173,7 @@ test textWind-2.7 {TkTextWindowCmd procedure, "cget" option} -setup { .t window cget .f -pady } -cleanup { destroy .f -} -returnCodes ok -result {2} +} -returnCodes ok -result 2 test textWind-2.8 {TkTextWindowCmd procedure} -body { .t window co } -returnCodes error -result {wrong # args: should be ".t window configure index ?-option value ...?"} @@ -1409,7 +1409,7 @@ test textWind-17.1 {peer widgets and embedded windows} -setup { update ; update destroy .t .tt winfo exists .f -} -result {0} +} -result 0 test textWind-17.2 {peer widgets and embedded windows} -setup { destroy .t .f .tt diff --git a/tests/tk.test b/tests/tk.test index f1a6b9a..f424c77 100644 --- a/tests/tk.test +++ b/tests/tk.test @@ -1,15 +1,16 @@ # This file is a Tcl script to test the tk command. # It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2002 ActiveState Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2002 ActiveState Corporation. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test +testConstraint testprintf [llength [info command testprintf]] testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] test tk-1.1 {tk command: general} -body { @@ -17,7 +18,7 @@ test tk-1.1 {tk command: general} -body { } -returnCodes error -result {wrong # args: should be "tk subcommand ?arg ...?"} test tk-1.2 {tk command: general} -body { tk xyz -} -returnCodes error -result {unknown or ambiguous subcommand "xyz": must be appname, busy, caret, fontchooser, inactive, scaling, useinputmethods, or windowingsystem} +} -returnCodes error -result {unknown or ambiguous subcommand "xyz": must be appname, busy, caret, fontchooser, inactive, scaling, sysnotify, systray, useinputmethods, or windowingsystem} # Value stored to restore default settings after 2.* tests set appname [tk appname] @@ -30,7 +31,7 @@ test tk-2.2 {tk command: appname} -body { test tk-2.3 {tk command: appname} -constraints unix -body { tk appname bazfoogarply expr {[lsearch -exact [winfo interps] [tk appname]] >= 0} -} -result {1} +} -result 1 test tk-2.4 {tk command: appname} -body { tk appname [tk appname] } -result [tk appname] @@ -66,21 +67,21 @@ test tk-3.7 {tk command: scaling: set new} -body { test tk-3.8 {tk command: scaling: negative} -body { tk scaling -1 expr {[tk scaling] > 0} -} -result {1} +} -result 1 test tk-3.9 {tk command: scaling: too big} -body { tk scaling 1000000 expr {[tk scaling] < 10000} -} -result {1} +} -result 1 test tk-3.10 {tk command: scaling: widthmm} -body { tk scaling 1.25 expr {int((25.4*[winfo screenwidth .])/(72*1.25) + 0.5) \ - [winfo screenmmwidth .]} -} -result {0} +} -result 0 test tk-3.11 {tk command: scaling: heightmm} -body { tk scaling 1.25 expr {int((25.4*[winfo screenheight .])/(72*1.25) + 0.5) \ - [winfo screenmmheight .]} -} -result {0} +} -result 0 tk scaling $scaling # Value stored to restore default settings after 4.* tests @@ -139,7 +140,7 @@ test tk-5.5 {tk caret} -body { } -result {-height 12 -x 10 -y 11} test tk-5.6 {tk caret} -body { tk caret . -x 20 -y 25 -h 30; tk caret . -hei -} -result {30} +} -result 30 # tk inactive test tk-6.1 {tk inactive} -body { @@ -179,6 +180,10 @@ test tk-7.2 {tk inactive reset in a safe interpreter} -body { ::safe::interpDelete foo } -returnCodes 1 -result {resetting the user inactivity timer is not allowed in a safe interpreter} +test tk-8.1 {Test for ticket [1cc44617e2], see if TCL_LL_MODIFIER works as expected on all platforms} -constraints testprintf -body { + testprintf -21474836480 +} -result {-21474836480 18446744052234715136} + # tests of [tk busy] in busy.test # cleanup diff --git a/tests/ttk/all.tcl b/tests/ttk/all.tcl index 8a75ba7..8f0234d 100644 --- a/tests/ttk/all.tcl +++ b/tests/ttk/all.tcl @@ -4,12 +4,12 @@ # tests. Execute it by invoking "source all.tcl" when running tktest # in this directory. # -# Copyright © 2007 by the Tk developers. +# Copyright © 2007 the Tk developers. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tk ;# This is the Tk test suite; fail early if no Tk! +package require tk ;# This is the Tk test suite; fail early if no Tk! package require tcltest 2.2 tcltest::configure {*}$argv tcltest::configure -testdir [file normalize [file dirname [info script]]] diff --git a/tests/ttk/checkbutton.test b/tests/ttk/checkbutton.test index 8b8c9b7..248db96 100644 --- a/tests/ttk/checkbutton.test +++ b/tests/ttk/checkbutton.test @@ -2,7 +2,7 @@ # ttk::checkbutton widget tests. # -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands @@ -57,7 +57,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 {} @@ -71,4 +71,18 @@ test checkbutton-1.8 "Empty -variable" -body { destroy .cbev } -result {} +test checkbutton-2.1 "style command" -body { + ttk::checkbutton .w + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {{} TCheckbutton TCheckbutton} +test checkbutton-2.2 "style command" -body { + ttk::style configure customStyle.TCheckbutton + ttk::checkbutton .w -style customStyle.TCheckbutton + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {customStyle.TCheckbutton customStyle.TCheckbutton TCheckbutton} + tcltest::cleanupTests diff --git a/tests/ttk/combobox.test b/tests/ttk/combobox.test index 48179f3..a5627d2 100644 --- a/tests/ttk/combobox.test +++ b/tests/ttk/combobox.test @@ -2,7 +2,7 @@ # ttk::combobox widget tests # -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands @@ -86,4 +86,18 @@ test combobox-1890211 "ComboboxSelected event after listbox unposted" -body { destroy .cb } +test combobox-4.1 "style command" -body { + ttk::combobox .w + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {{} TCombobox TCombobox} +test combobox-4.2 "style command" -body { + ttk::style configure customStyle.TCombobox + ttk::combobox .w -style customStyle.TCombobox + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {customStyle.TCombobox customStyle.TCombobox TCombobox} + tcltest::cleanupTests diff --git a/tests/ttk/entry.test b/tests/ttk/entry.test index 384f297..fc2f9d3 100644 --- a/tests/ttk/entry.test +++ b/tests/ttk/entry.test @@ -2,7 +2,7 @@ # Tile package: entry widget tests # -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands @@ -110,7 +110,7 @@ test entry-3.0 "Series 3 setup" -body { variable cw [font measure $fixed a] variable ch [font metrics $fixed -linespace] variable bd 2 ;# border + padding - variable ux [font measure $fixed \u4e4e] + variable ux [font measure $fixed 乎] pack [ttk::entry .e -font $fixed -width 20] update @@ -328,7 +328,37 @@ test entry-9.1 "Index range invariants" -setup { destroy .e } -test entry-10.1 {Bug [2830360fff] - Don't loose invalid at focus events} -setup { +test entry-10.1 {configuration option: "-placeholder"} -setup { + pack [ttk::entry .e] +} -body { + .e configure -placeholder {Some text} + .e cget -placeholder +} -cleanup { + destroy .e +} -result {Some text} + +test entry-10.2 {configuration option: "-placeholderforeground"} -setup { + pack [ttk::entry .e] +} -body { + .e configure -placeholder {Some text} -placeholderforeground red + .e cget -placeholderforeground +} -cleanup { + destroy .e +} -result {red} + +test entry-10.3 {styling option: "-placeholderforeground"} -setup { + pack [ttk::entry .e] +} -body { + set current [ttk::style configure TEntry -placeholderforeground] + ttk::style configure TEntry -placeholderforeground blue + set res [ttk::style configure TEntry -placeholderforeground] + ttk::style configure TEntry -placeholderforeground $current + set res +} -cleanup { + destroy .e +} -result {blue} + +test entry-11.1 {Bug [2830360fff] - Don't loose invalid at focus events} -setup { pack [ttk::entry .e] update } -body { @@ -340,4 +370,18 @@ test entry-10.1 {Bug [2830360fff] - Don't loose invalid at focus events} -setup destroy .e } +test entry-12.1 "style command" -body { + ttk::entry .w + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {{} TEntry TEntry} +test entry-12.2 "style command" -body { + ttk::style configure customStyle.TEntry + ttk::entry .w -style customStyle.TEntry + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {customStyle.TEntry customStyle.TEntry TEntry} + tcltest::cleanupTests diff --git a/tests/ttk/image.test b/tests/ttk/image.test index bb593fc..51f0f00 100644 --- a/tests/ttk/image.test +++ b/tests/ttk/image.test @@ -1,4 +1,4 @@ -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands diff --git a/tests/ttk/labelframe.test b/tests/ttk/labelframe.test index 9ffffd8..d81d33d 100644 --- a/tests/ttk/labelframe.test +++ b/tests/ttk/labelframe.test @@ -1,4 +1,4 @@ -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands @@ -128,4 +128,18 @@ test labelframe-6.1 "Stacking order" -body { destroy .t } -result [list .t.x1 .t.lf .t.lb .t.x2] +test labelframe-7.1 "style command" -body { + ttk::labelframe .w + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {{} TLabelframe TLabelframe} +test labelframe-7.2 "style command" -body { + ttk::style configure customStyle.TLabelframe + ttk::labelframe .w -style customStyle.TLabelframe + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {customStyle.TLabelframe customStyle.TLabelframe TLabelframe} + tcltest::cleanupTests diff --git a/tests/ttk/layout.test b/tests/ttk/layout.test index 5dfce9b..31ef1f5 100644 --- a/tests/ttk/layout.test +++ b/tests/ttk/layout.test @@ -1,4 +1,4 @@ -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands diff --git a/tests/ttk/notebook.test b/tests/ttk/notebook.test index e58812a..8c2e186 100644 --- a/tests/ttk/notebook.test +++ b/tests/ttk/notebook.test @@ -1,4 +1,4 @@ -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands @@ -512,4 +512,18 @@ test notebook-1343984-2 "don't autoselect on destroy" -body { set ::history } -result [list DESTROY .nb.frame1 DESTROY .nb.frame2 DESTROY .nb.frame3] +test notebook-8.1 "style command" -body { + ttk::notebook .w + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {{} TNotebook TNotebook} +test notebook-8.2 "style command" -body { + ttk::style configure customStyle.TNotebook + ttk::notebook .w -style customStyle.TNotebook + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {customStyle.TNotebook customStyle.TNotebook TNotebook} + tcltest::cleanupTests diff --git a/tests/ttk/panedwindow.test b/tests/ttk/panedwindow.test index 528d56b..d9909c0 100644 --- a/tests/ttk/panedwindow.test +++ b/tests/ttk/panedwindow.test @@ -1,4 +1,4 @@ -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands @@ -289,4 +289,22 @@ test paned-propagation-5 "Pane change after map, on-axis" -body { test paned-propagation-cleanup "Clean up." -body { destroy .pw } +test panedwindow-6.1 "style command" -body { + # Contrary to ttk::scrollbar, ttk::progressbar and ttk::scale, + # ttk::panedwindow has same style TPanedwindow whatever -orient is + ttk::panedwindow .wv ; # default is -orient vertical + ttk::panedwindow .wh -orient horizontal + list [.wv cget -style] [.wv style] [winfo class .wv]\ + [.wh cget -style] [.wh style] [winfo class .wh] +} -cleanup { + destroy .wv .wh +} -result {{} TPanedwindow TPanedwindow {} TPanedwindow TPanedwindow} +test panedwindow-6.2 "style command" -body { + ttk::style configure customStyle.TPanedwindow + ttk::panedwindow .w -style customStyle.TPanedwindow + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {customStyle.TPanedwindow customStyle.TPanedwindow TPanedwindow} + tcltest::cleanupTests diff --git a/tests/ttk/progressbar.test b/tests/ttk/progressbar.test index 464469e..80e51ea 100644 --- a/tests/ttk/progressbar.test +++ b/tests/ttk/progressbar.test @@ -1,4 +1,4 @@ -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands @@ -83,4 +83,59 @@ test progressbar-end "Cleanup" -body { destroy .pb } +# check existence and default value of each non-core option of the widget +test progressbar-3.1 "progressbar non-core options" -setup { + set res {} + ttk::progressbar .defaultpb +} -body { + foreach option {-anchor -foreground -justify -style -text -wraplength \ + -length -maximum -mode -orient -phase -value -variable} { + lappend res [.defaultpb cget $option] + } + set res +} -cleanup { + unset res + destroy .defaultpb +} -result {w black left {} {} 0 100 100 determinate horizontal 0 0.0 {}} + +test progressbar-3.2 "TIP #442 options are taken into account" -setup { + set res {} + pack [ttk::progressbar .p -value 0 -maximum 50 -orient horizontal -mode determinate -length 500] + set thefont [font actual {Arial 10}] +} -body { + .p configure -anchor c -foreground blue -justify right \ + -text "TIP #442\noptions are now tested" -wraplength 100 + update + .p step 10 + .p configure -anchor e -font $thefont -foreground green -justify center \ + -text "Changing the value of each option\nfrom TIP #442" -wraplength 250 + update + .p step 20 + .p configure -orient vertical -text "Cannot be seen" + update + foreach option {-anchor -foreground -justify -text -wraplength} { + lappend res [list $option [.p cget $option]] + } + set res +} -cleanup { + unset res thefont + destroy .p +} -result {{-anchor e} {-foreground green} {-justify center} {-text {Cannot be seen}} {-wraplength 250}} + +test progressbar-4.1 "style command" -body { + ttk::progressbar .wh ; # default is -orient horizontal + ttk::progressbar .wv -orient vertical + list [.wh cget -style] [.wh style] [winfo class .wh]\ + [.wv cget -style] [.wv style] [winfo class .wv] +} -cleanup { + destroy .wh .wv +} -result {{} Horizontal.TProgressbar TProgressbar {} Vertical.TProgressbar TProgressbar} +test progressbar-4.2 "style command" -body { + ttk::style configure customStyle.Vertical.TProgressbar + ttk::progressbar .w -orient vertical -style customStyle.Vertical.TProgressbar + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {customStyle.Vertical.TProgressbar Vertical.customStyle.Vertical.TProgressbar TProgressbar} + tcltest::cleanupTests diff --git a/tests/ttk/radiobutton.test b/tests/ttk/radiobutton.test index 09abcb8..6de5b5e 100644 --- a/tests/ttk/radiobutton.test +++ b/tests/ttk/radiobutton.test @@ -2,7 +2,7 @@ # ttk::radiobutton widget tests. # -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands @@ -46,4 +46,18 @@ test radiobutton-1.8 "Reset radiobutton variable" -body { list [info exists ::choice] [.rb1 instate alternate] [.rb2 instate alternate] } -result {1 0 0} +test radiobutton-2.1 "style command" -body { + ttk::radiobutton .w + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {{} TRadiobutton TRadiobutton} +test radiobutton-2.2 "style command" -body { + ttk::style configure customStyle.TRadiobutton + ttk::radiobutton .w -style customStyle.TRadiobutton + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {customStyle.TRadiobutton customStyle.TRadiobutton TRadiobutton} + tcltest::cleanupTests diff --git a/tests/ttk/scale.test b/tests/ttk/scale.test new file mode 100644 index 0000000..0851cb6 --- /dev/null +++ b/tests/ttk/scale.test @@ -0,0 +1,53 @@ +package require tk +package require tcltest 2.2 +namespace import -force tcltest::* +loadTestedCommands + +test scale-1.0 "Self-destruction" -body { + trace variable v w { destroy .s ;# } + ttk::scale .s -variable v + pack .s ; update + .s set 1 ; update +} -returnCodes error -match glob -result "*" + +test scale-2.1 "-state option" -setup { + ttk::scale .s + set res "" +} -body { + # defaults + lappend res [.s instate disabled] [.s cget -state] + # set -state: instate returns accordingly + .s configure -state disabled + lappend res [.s instate disabled] [.s cget -state] + # back to normal + .s configure -state normal + lappend res [.s instate disabled] [.s cget -state] + # use state command: -state does NOT reflect it + .s state disabled + lappend res [.s instate disabled] [.s cget -state] + # further use state command + .s state readonly + lappend res [.s state] [.s cget -state] +} -cleanup { + destroy .s + unset -nocomplain res +} -result {0 normal 1 disabled 0 normal 1 normal {disabled readonly} normal} + +test scale-3.1 "style command" -body { + ttk::scale .wh ; # default is -orient horizontal + ttk::scale .wv -orient vertical + list [.wh cget -style] [.wh style] [winfo class .wh] \ + [.wv cget -style] [.wv style] [winfo class .wv] +} -cleanup { + destroy .wh .wv +} -result {{} Horizontal.TScale TScale {} Vertical.TScale TScale} +test scale-3.2 "style command" -body { + ttk::style configure customStyle.Vertical.TScale + ttk::scale .w -orient vertical -style customStyle.Vertical.TScale + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {customStyle.Vertical.TScale Vertical.customStyle.Vertical.TScale TScale} + +tcltest::cleanupTests + diff --git a/tests/ttk/scrollbar.test b/tests/ttk/scrollbar.test index 9faa771..6d35bea 100644 --- a/tests/ttk/scrollbar.test +++ b/tests/ttk/scrollbar.test @@ -1,4 +1,4 @@ -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands @@ -71,39 +71,65 @@ test scrollbar-1.3 "Change orientation" -body { expr {$h < $w} } -result 1 -# -# Scale tests: -# - -test scale-1.0 "Self-destruction" -body { - trace variable v w { destroy .s ;# } - ttk::scale .s -variable v - pack .s ; update - .s set 1 ; update -} -returnCodes error -match glob -result "*" +test scrollbar-10.1.1 {<MouseWheel> event on scrollbar} -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 {4.0} -test scale-2.1 "-state option" -setup { - ttk::scale .s - set res "" +test scrollbar-10.2.1 {<Shift-MouseWheel> event on horizontal scrollbar} -setup { + destroy .t .s } -body { - # defaults - lappend res [.s instate disabled] [.s cget -state] - # set -state: instate returns accordingly - .s configure -state disabled - lappend res [.s instate disabled] [.s cget -state] - # back to normal - .s configure -state normal - lappend res [.s instate disabled] [.s cget -state] - # use state command: -state does NOT reflect it - .s state disabled - lappend res [.s instate disabled] [.s cget -state] - # further use state command - .s state readonly - lappend res [.s state] [.s cget -state] + 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.3} +test scrollbar-10.2.2 {<MouseWheel> event on horizontal scrollbar} -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.3} + +test scrollbar-11.1 "style command" -body { + ttk::scrollbar .wv ; # default is -orient vertical + ttk::scrollbar .wh -orient horizontal + list [.wv cget -style] [.wv style] [winfo class .wv] \ + [.wh cget -style] [.wh style] [winfo class .wh] +} -cleanup { + destroy .wv .wh +} -result {{} Vertical.TScrollbar TScrollbar {} Horizontal.TScrollbar TScrollbar} +test scrollbar-11.2 "style command" -body { + ttk::style configure customStyle.Horizontal.TScrollbar + ttk::scrollbar .w -orient horizontal -style customStyle.Horizontal.TScrollbar + list [.w cget -style] [.w style] [winfo class .w] } -cleanup { - destroy .s - unset -nocomplain res -} -result {0 normal 1 disabled 0 normal 1 normal {disabled readonly} normal} + destroy .w +} -result {customStyle.Horizontal.TScrollbar Horizontal.customStyle.Horizontal.TScrollbar TScrollbar} tcltest::cleanupTests diff --git a/tests/ttk/spinbox.test b/tests/ttk/spinbox.test index cd3b2ce..abd2a0f 100644 --- a/tests/ttk/spinbox.test +++ b/tests/ttk/spinbox.test @@ -2,7 +2,7 @@ # ttk::spinbox widget tests # -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands @@ -127,7 +127,7 @@ test spinbox-1.8.2 "option -validate" -setup { .sb cget -validate } -cleanup { destroy .sb -} -result {none} +} -result none test spinbox-1.8.3 "option -validate" -setup { ttk::spinbox .sb -from 0 -to 100 @@ -358,6 +358,20 @@ test spinbox-dieoctaldie-2 "Cope with general bad input" -body { destroy .sb } +test spinbox-5.1 "style command" -body { + ttk::spinbox .w + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {{} TSpinbox TSpinbox} +test spinbox-5.2 "style command" -body { + ttk::style configure customStyle.TSpinbox + ttk::spinbox .w -style customStyle.TSpinbox + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {customStyle.TSpinbox customStyle.TSpinbox TSpinbox} + tcltest::cleanupTests # Local variables: diff --git a/tests/ttk/treetags.test b/tests/ttk/treetags.test index 4243fd6..428212b 100644 --- a/tests/ttk/treetags.test +++ b/tests/ttk/treetags.test @@ -1,5 +1,5 @@ -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands @@ -12,12 +12,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 @@ -29,7 +28,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]} } } @@ -115,6 +114,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 @@ -124,28 +129,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 e936fca..3d186e1 100644 --- a/tests/ttk/treeview.test +++ b/tests/ttk/treeview.test @@ -3,7 +3,7 @@ # what it currently does) # -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands @@ -467,7 +467,7 @@ test treeview-8.6 "Selection - <<TreeviewSelect>> on selection add" -body { .tv selection add newnode.n1 update set res -} -result {1} +} -result 1 test treeview-8.7 "<<TreeviewSelect>> on selected item deletion" -body { .tv selection set {} @@ -561,7 +561,7 @@ test treeview-9.3 {scrolling on see command, requested item is closed} -setup { expr $after < $before } -cleanup { destroy .top -} -result {1} +} -result 1 ### identify tests: # @@ -700,9 +700,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 @@ -737,7 +737,7 @@ test treeview-368fa4561e "indicators cannot be clicked on leafs" -setup { set res [.tv item foo -open] # using $h even for x computation is intentional here in order to simulate # a mouse click on the (invisible since we're on a leaf) indicator - event generate .tv <ButtonPress-1> \ + event generate .tv <Button-1> \ -x [expr {$x + $h / 2}] \ -y [expr {$y + $h / 2}] lappend res [.tv item foo -open] @@ -835,4 +835,18 @@ test treeview-ce470f20fd-4 "changing -stretch resizes columns" -setup { destroy .tv } -result {60 50 60 50 60 50 1} +test treeview-11.1 "style command" -body { + ttk::treeview .w + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {{} Treeview Treeview} +test treeview-11.2 "style command" -body { + ttk::style configure customStyle.Treeview + ttk::treeview .w -style customStyle.Treeview + list [.w cget -style] [.w style] [winfo class .w] +} -cleanup { + destroy .w +} -result {customStyle.Treeview customStyle.Treeview Treeview} + tcltest::cleanupTests diff --git a/tests/ttk/ttk.test b/tests/ttk/ttk.test index 322917c..e8093a9 100644 --- a/tests/ttk/ttk.test +++ b/tests/ttk/ttk.test @@ -1,5 +1,5 @@ -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands @@ -135,8 +135,8 @@ test ttk-selfdestruct-ok-1 "Intentional self-destruction" -body { # # Basic tests. # -test ttk-1.1 "Create button" -body { - pack [ttk::button .t] -expand true -fill both +test ttk-1.1 "Create multiline button showing justified text" -body { + pack [ttk::button .t -text "Hello\nWorld!!" -justify center] -expand true -fill both update } @@ -209,8 +209,8 @@ test ttk-2.8 "bug 3223850: button state disabled during click" -setup { 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 @@ -655,6 +655,17 @@ test ttk-ensemble-5 "style element create: valid" -body { ttk::style element create plain.background from default } -returnCodes 0 -result "" +test ttk-16.1 {ttk::style theme styles - no such theme} -body { + ttk::style theme styles noSuchTheme +} -returnCodes 1 -result {theme "noSuchTheme" doesn't exist} +test ttk-16.2 {ttk::style theme styles - theme exists} -body { + # simply check this produces a list with some style names, + # without checking exact content (not needed, and may vary + # depending on platform, versions, improvements...) + expr {[llength [ttk::style theme styles alt]] > 0} +} -result 1 + + eval destroy [winfo children .] tcltest::cleanupTests diff --git a/tests/ttk/validate.test b/tests/ttk/validate.test index 5430903..8b48d2a 100644 --- a/tests/ttk/validate.test +++ b/tests/ttk/validate.test @@ -3,7 +3,7 @@ ## Derived from core test suite entry-19.1 through entry-19.20 ## -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* diff --git a/tests/ttk/vsapi.test b/tests/ttk/vsapi.test index ec4e9e7..076a815 100644 --- a/tests/ttk/vsapi.test +++ b/tests/ttk/vsapi.test @@ -1,7 +1,7 @@ # -*- tcl -*- # -package require Tk +package require tk package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands diff --git a/tests/unixButton.test b/tests/unixButton.test index f0dcde5..1b1ff04 100644 --- a/tests/unixButton.test +++ b/tests/unixButton.test @@ -3,9 +3,9 @@ # widgets defined in tkUnixButton.c). It is organized in the standard # fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test index bb7edc5..ea0063f 100644 --- a/tests/unixEmbed.test +++ b/tests/unixEmbed.test @@ -2,8 +2,8 @@ # tkUnixEmbed.c. It is organized in the standard fashion for Tcl # tests. # -# Copyright (c) 1996-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -117,7 +117,7 @@ test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} -constraints { colorsFree .x } -cleanup { deleteWindows -} -result {0} +} -result 0 test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} -constraints { unix nonPortable } -setup { @@ -130,7 +130,7 @@ test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} -constraints { colorsFree .x } -cleanup { deleteWindows -} -result {1} +} -result 1 test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} -constraints { unix testembed notAqua @@ -973,20 +973,20 @@ test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} -constrain toplevel .t1 -use $w1 } focus -force . - bind . <KeyPress> {lappend x {key %A %E}} + bind . <Key> {lappend x {key %A %E}} set x {} set y [dobg { update - bind .t1 <KeyPress> {lappend y {key %A}} + bind .t1 <Key> {lappend y {key %A}} set y {} - event generate .t1 <KeyPress> -keysym a + event generate .t1 <Key> -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. @@ -1007,13 +1007,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 [child 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 @@ -1021,7 +1021,7 @@ test unixEmbed-7.1a {TkpRedirectKeyEvent procedure, forward keystroke} -constrai } -cleanup { interp delete child deleteWindows - bind . <KeyPress> {} + bind . <Key> {} } -result {{{key a 1}} {}} test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} -constraints { unix notAqua @@ -1038,20 +1038,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 @@ -1071,13 +1071,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 [child 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 @@ -1085,7 +1085,7 @@ test unixEmbed-7.2a {TkpRedirectKeyEvent procedure, don't forward keystroke widt } -cleanup { interp delete child deleteWindows - bind . <KeyPress> {} + bind . <Key> {} } -result {{} {{key b}}} test unixEmbed-8.1 {TkpClaimFocus procedure} -constraints { diff --git a/tests/unixFont.test b/tests/unixFont.test index ff16750..ee3d36a 100644 --- a/tests/unixFont.test +++ b/tests/unixFont.test @@ -8,8 +8,8 @@ # fonts having or not having certain properties, which may not be valid # at all sites. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -75,7 +75,7 @@ test unixfont-1.1 {TkpGetNativeFont procedure: not native} {x11 noExceed} { } {1 {font "" doesn't exist}} test unixfont-1.2 {TkpGetNativeFont procedure: native} {x11 failsOnUbuntu} { font measure fixed 0 -} {6} +} 6 test unixfont-2.1 {TkpGetFontFromAttributes procedure: no family} x11 { font actual {-size 10} @@ -120,7 +120,7 @@ test unixfont-2.9 {TkpGetFontFromAttributes: reject adobe courier if possible} { } {courier} test unixfont-2.10 {TkpGetFontFromAttributes: scalable font found} {x11 failsOnUbuntuNoXft} { lindex [font actual {-family courier -size 37}] 3 -} {37} +} 37 test unixfont-2.11 {TkpGetFontFromAttributes: font cannot be loaded} x11 { # On Linux, XListFonts() was returning names for fonts that do not # actually exist, causing the subsequent XLoadQueryFont() to fail @@ -178,7 +178,7 @@ test unixfont-5.9 {Tk_MeasureChars procedure: TK_PARTIAL_OK} {x11 failsOnUbuntu} .b.c dchars $t 0 end .b.c insert $t 0 "0000" .b.c index $t @[expr int($ax*2.5)],1 -} {2} +} 2 test unixfont-5.10 {Tk_MeasureChars procedure: TK_AT_LEAST_ONE} x11 { .b.l config -text "000000000000" getsize @@ -247,7 +247,7 @@ test unixfont-8.1 {AllocFont procedure: use old font} x11 { } {} test unixfont-8.2 {AllocFont procedure: parse information from XLFD} x11 { expr {[lindex [font actual {-family times -size 0}] 3] == 0} -} {0} +} 0 test unixfont-8.3 {AllocFont procedure: can't parse info from name} x11 { catch {unset fontArray} # check that font actual returns the correct attributes. @@ -259,7 +259,7 @@ test unixfont-8.3 {AllocFont procedure: can't parse info from name} x11 { } {-family -overstrike -size -slant -underline -weight} test unixfont-8.4 {AllocFont procedure: classify characters} {x11 failsOnUbuntu failsOnXQuarz} { set x 0 - incr x [font measure $courier "\u4000"] ;# 6 + incr x [font measure $courier "䀀"] ;# 6 incr x [font measure $courier "\002"] ;# 4 incr x [font measure $courier "\012"] ;# 2 incr x [font measure $courier "\101"] ;# 1 @@ -267,7 +267,7 @@ test unixfont-8.4 {AllocFont procedure: classify characters} {x11 failsOnUbuntu } [expr $cx*13] test unixfont-8.5 {AllocFont procedure: setup widths of normal chars} x11 { font metrics $courier -fixed -} {1} +} 1 test unixfont-8.6 {AllocFont procedure: setup widths of special chars} {x11 failsOnUbuntu failsOnXQuarz} { set x 0 incr x [font measure $courier "\001"] ;# 4 diff --git a/tests/unixMenu.test b/tests/unixMenu.test index 63e4849..dafae08 100644 --- a/tests/unixMenu.test +++ b/tests/unixMenu.test @@ -3,8 +3,8 @@ # file tests the Macintosh-specific features of the menu # system. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/unixSelect.test b/tests/unixSelect.test index a702587..cb1908b 100644 --- a/tests/unixSelect.test +++ b/tests/unixSelect.test @@ -4,7 +4,7 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1999 by Scriptics Corporation. +# Copyright © 1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -115,13 +115,13 @@ test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} -constraints } -body { pack [entry .e] update - .e insert 0 \u00fcber + .e insert 0 über .e selection range 0 end dobg {string length [selection get]} } -cleanup { cleanupbg destroy .e -} -result {4} +} -result 4 test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} -constraints { x11 @@ -131,13 +131,13 @@ test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} - dobg { pack [entry .e] update - .e insert 0 \u00fc\u0444 + .e insert 0 üф .e selection range 0 end } selection get } -cleanup { cleanupbg -} -result \u00fc? +} -result ü? test unixSelect-1.3 {TkSelGetSelection procedure: simple i18n text, iso2022} -constraints { x11 @@ -148,11 +148,11 @@ test unixSelect-1.3 {TkSelGetSelection procedure: simple i18n text, iso2022} -co selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \ {handler COMPOUND_TEXT} selection own . - set selValue \u00fc\u0444 + set selValue üф set selInfo {} set result [dobg { set x [selection get -type COMPOUND_TEXT] - list [string equal \u00fc\u0444 $x] [string length $x] + list [string equal üф $x] [string length $x] }] lappend result $selInfo } -cleanup { @@ -172,12 +172,12 @@ test unixSelect-1.4 {TkSelGetSelection procedure: INCR i18n text, iso2022} -cons selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \ {handler COMPOUND_TEXT} selection own . - set selValue [string repeat x 3999]\u00fc\u0444[string repeat x 3999] + set selValue [string repeat x 3999]üф[string repeat x 3999] set selInfo {} set result [dobg { set x [selection get -type COMPOUND_TEXT] list [string equal \ - [string repeat x 3999]\u00fc\u0444[string repeat x 3999] $x] \ + [string repeat x 3999]üф[string repeat x 3999] $x] \ [string length $x] }] lappend result $selInfo @@ -194,11 +194,11 @@ test unixSelect-1.5 {TkSelGetSelection procedure: simple i18n text, iso2022} -co selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \ {handler COMPOUND_TEXT} selection own . - set selValue \u00fc\u0444 + set selValue üф set selInfo {} set result [dobg { set x [selection get -type COMPOUND_TEXT] - list [string equal \u00fc\u0444 $x] [string length $x] + list [string equal üф $x] [string length $x] }] lappend result $selInfo } -cleanup { @@ -211,7 +211,7 @@ test unixSelect-1.6 {TkSelGetSelection procedure: INCR i18n text} -constraints { setupbg } -body { dobg [subst -nobackslashes {entry .e; pack .e; update - .e insert 0 \u00fcber$longValue + .e insert 0 über$longValue .e selection range 0 end}] string length [selection get] } -cleanup { @@ -226,13 +226,13 @@ test unixSelect-1.7 {TkSelGetSelection procedure: INCR i18n text} -constraints { dobg { pack [entry .e] update - .e insert 0 [string repeat x 3999]\u00fc + .e insert 0 [string repeat x 3999]ü .e selection range 0 end } selection get } -cleanup { cleanupbg -} -result [string repeat x 3999]\u00fc +} -result [string repeat x 3999]ü test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} -constraints { x11 @@ -242,13 +242,13 @@ test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} -constraints { dobg { pack [entry .e] update - .e insert 0 \u00fc[string repeat x 3999] + .e insert 0 ü[string repeat x 3999] .e selection range 0 end } selection get } -cleanup { cleanupbg -} -result \u00fc[string repeat x 3999] +} -result ü[string repeat x 3999] test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} -constraints { x11 @@ -258,13 +258,13 @@ test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} -constraints { dobg { pack [entry .e] update - .e insert 0 [string repeat x 3999]\u00fc[string repeat x 4000] + .e insert 0 [string repeat x 3999]ü[string repeat x 4000] .e selection range 0 end } selection get } -cleanup { cleanupbg -} -result [string repeat x 3999]\u00fc[string repeat x 4000] +} -result [string repeat x 3999]ü[string repeat x 4000] # Now some tests to make sure that the right thing is done when # transferring UTF8 selections, to prevent [Bug 614650] and its ilk # from rearing its ugly head again. @@ -277,13 +277,13 @@ test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const dobg { pack [entry .e] update - .e insert 0 [string repeat x 3999]\u00fc + .e insert 0 [string repeat x 3999]ü .e selection range 0 end } selection get -type UTF8_STRING } -cleanup { cleanupbg -} -result [string repeat x 3999]\u00fc +} -result [string repeat x 3999]ü test unixSelect-1.11 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { x11 @@ -293,13 +293,13 @@ test unixSelect-1.11 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const dobg { pack [entry .e] update - .e insert 0 \u00fc[string repeat x 3999] + .e insert 0 ü[string repeat x 3999] .e selection range 0 end } selection get -type UTF8_STRING } -cleanup { cleanupbg -} -result \u00fc[string repeat x 3999] +} -result ü[string repeat x 3999] test unixSelect-1.12 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { x11 @@ -309,13 +309,13 @@ test unixSelect-1.12 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const dobg { pack [entry .e] update - .e insert 0 [string repeat x 3999]\u00fc[string repeat x 4000] + .e insert 0 [string repeat x 3999]ü[string repeat x 4000] .e selection range 0 end } selection get -type UTF8_STRING } -cleanup { cleanupbg -} -result [string repeat x 3999]\u00fc[string repeat x 4000] +} -result [string repeat x 3999]ü[string repeat x 4000] test unixSelect-1.13 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints { x11 @@ -325,13 +325,13 @@ test unixSelect-1.13 {TkSelGetSelection procedure: simple i18n text, utf-8} -con } -body { pack [entry .e] update - .e insert 0 \u00fcber\u0444 + .e insert 0 überф .e selection range 0 end dobg {string length [selection get -type UTF8_STRING]} } -cleanup { destroy .e cleanupbg -} -result {5} +} -result 5 test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints { x11 @@ -341,13 +341,13 @@ test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} -con dobg { pack [entry .e] update - .e insert 0 \u00fc\u0444 + .e insert 0 üф .e selection range 0 end } selection get -type UTF8_STRING } -cleanup { cleanupbg -} -result \u00fc\u0444 +} -result üф test unixSelect-1.15 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { x11 @@ -357,13 +357,13 @@ test unixSelect-1.15 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const dobg { pack [entry .e] update - .e insert 0 [string repeat [string repeat \u00c4\u00e4 50]\n 21] + .e insert 0 [string repeat [string repeat Ää 50]\n 21] .e selection range 0 end } selection get -type UTF8_STRING } -cleanup { cleanupbg -} -result [string repeat [string repeat \u00c4\u00e4 50]\n 21] +} -result [string repeat [string repeat Ää 50]\n 21] test unixSelect-1.16 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { x11 @@ -373,13 +373,13 @@ test unixSelect-1.16 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const dobg { pack [entry .e] update - .e insert 0 i[string repeat [string repeat \u00c4\u00e4 50]\n 21] + .e insert 0 i[string repeat [string repeat Ää 50]\n 21] .e selection range 0 end } selection get -type UTF8_STRING } -cleanup { cleanupbg -} -result i[string repeat [string repeat \u00c4\u00e4 50]\n 21] +} -result i[string repeat [string repeat Ää 50]\n 21] test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { x11 @@ -389,7 +389,7 @@ test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const dobg { pack [text .t] update - .t insert 1.0 [string repeat [string repeat \u00c4\u00e4 50]\n 21] + .t insert 1.0 [string repeat [string repeat Ää 50]\n 21] # Has to be selected in a separate stage .t tag add sel 1.0 21.end+1c } @@ -397,7 +397,7 @@ test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const selection get -type UTF8_STRING } -cleanup { cleanupbg -} -result [string repeat [string repeat \u00c4\u00e4 50]\n 21] +} -result [string repeat [string repeat Ää 50]\n 21] test unixSelect-1.18 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { x11 @@ -407,7 +407,7 @@ test unixSelect-1.18 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const dobg { pack [text .t] update - .t insert 1.0 i[string repeat [string repeat \u00c4\u00e4 50]\n 21] + .t insert 1.0 i[string repeat [string repeat Ää 50]\n 21] # Has to be selected in a separate stage .t tag add sel 1.0 21.end+1c } @@ -415,7 +415,7 @@ test unixSelect-1.18 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const selection get -type UTF8_STRING } -cleanup { cleanupbg -} -result i[string repeat [string repeat \u00c4\u00e4 50]\n 21] +} -result i[string repeat [string repeat Ää 50]\n 21] test unixSelect-1.19 {Automatic UTF8_STRING support for selection handle} -constraints { unix diff --git a/tests/unixWm.test b/tests/unixWm.test index 698a4f4..2ff2d28 100644 --- a/tests/unixWm.test +++ b/tests/unixWm.test @@ -2,9 +2,9 @@ # the window manager, including the "wm" command. It is organized # in the standard fashion for Tcl tests. # -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1992-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -415,7 +415,7 @@ test unixWm-9.3 {TkWmMapWindow procedure, iconic windows} unix { wm geom .t +0+0 wm iconify .t winfo ismapped .t -} {0} +} 0 test unixWm-9.4 {TkWmMapWindow procedure, icon windows} unix { destroy .t toplevel .t -width 100 -height 50 -bg blue @@ -423,14 +423,14 @@ test unixWm-9.4 {TkWmMapWindow procedure, icon windows} unix { wm iconwindow . .t update set result [winfo ismapped .t] -} {0} +} 0 test unixWm-9.5 {TkWmMapWindow procedure, normal windows} unix { destroy .t toplevel .t -width 200 -height 20 wm geom .t +0+0 update winfo ismapped .t -} {1} +} 1 test unixWm-10.1 {TkWmDeadWindow procedure, canceling UpdateGeometry idle handler} unix { destroy .t @@ -664,7 +664,7 @@ test unixWm-18.1 {Tk_WmCmd procedure, "frame" option} unix { } {1 {wrong # args: should be "wm frame window"}} test unixWm-18.2 {Tk_WmCmd procedure, "frame" option} {unix nonPortable} { expr [wm frame .t] == [winfo id .t] -} {0} +} 0 test unixWm-18.3 {Tk_WmCmd procedure, "frame" option} {unix nonPortable} { destroy .t2 toplevel .t2 @@ -674,7 +674,7 @@ test unixWm-18.3 {Tk_WmCmd procedure, "frame" option} {unix nonPortable} { set result [expr [wm frame .t2] == [winfo id .t2]] destroy .t2 set result -} {1} +} 1 test unixWm-19.1 {Tk_WmCmd procedure, "geometry" option} unix { list [catch {wm geometry .t 12 13} msg] $msg @@ -785,7 +785,7 @@ test unixWm-21.4 {Tk_WmCmd procedure, "group" option, make window exist} {unix t set result [expr [testwrapper .t2] - [lindex $hints 8]] destroy .t2 set result -} {0} +} 0 test unixWm-21.5 {Tk_WmCmd procedure, "group" option, create leader wrapper} {unix testwrapper} { destroy .t2 destroy .t3 @@ -853,7 +853,7 @@ test unixWm-23.4 {Tk_WmCmd procedure, "iconify" option} unix { set result [list [catch {wm iconify .t2} msg] $msg] destroy .t2 set result -} {1 {can't iconify .t2: it is an icon for .t}} +} {1 {can't iconify ".t2": it is an icon for ".t"}} test unixWm-23.5 {Tk_WmCmd procedure, "iconify" option} {unix failsOnUbuntu failsOnXQuarz} { destroy .t2 toplevel .t2 @@ -864,7 +864,7 @@ test unixWm-23.5 {Tk_WmCmd procedure, "iconify" option} {unix failsOnUbuntu fail set result [winfo ismapped .t2] destroy .t2 set result -} {0} +} 0 test unixWm-23.6 {Tk_WmCmd procedure, "iconify" option} {unix failsOnUbuntu failsOnXQuarz} { destroy .t2 toplevel .t2 @@ -1737,10 +1737,10 @@ test unixWm-48.10 {ParseGeometry procedure} unix { } {1 {bad geometry specifier "+20+10z"}} test unixWm-48.11 {ParseGeometry procedure} unix { catch {wm geometry .t +-10+20} -} {0} +} 0 test unixWm-48.12 {ParseGeometry procedure} unix { catch {wm geometry .t +30+-10} -} {0} +} 0 test unixWm-48.13 {ParseGeometry procedure, resize causes window to move} unix { destroy .t toplevel .t -width 200 -height 200 @@ -2238,7 +2238,7 @@ test unixWm-54.2 {TkpMakeMenuWindow procedure, setting override_redirect} {unix set result [wm overrideredirect .m] destroy .m set result -} {1} +} 1 # No tests for TkGetPointerCoords, CreateWrapper, or GetMaxSize. diff --git a/tests/util.test b/tests/util.test index c1ec6a5..c2baa38 100644 --- a/tests/util.test +++ b/tests/util.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test out the procedures in the file # tkUtil.c. It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -28,36 +28,36 @@ 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"} +} -returnCodes error -result {expected floating-point number but got "xyz"} test util-1.7 {Tk_GetScrollInfo procedure} -body { .l yview 0 .l yview scroll 2 pages .l nearest 0 -} -result {6} +} -result 6 test util-1.8 {Tk_GetScrollInfo procedure} -body { .l yview 15 .l yview scroll -2 pages .l nearest 0 -} -result {9} +} -result 9 test util-1.9 {Tk_GetScrollInfo procedure} -body { .l yview 0 .l yview scroll 2 units .l nearest 0 -} -result {2} +} -result 2 test util-1.10 {Tk_GetScrollInfo procedure} -body { .l yview 15 .l yview scroll -2 units .l nearest 0 -} -result {13} +} -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 13d6fd2..da6c41a 100644 --- a/tests/visual.test +++ b/tests/visual.test @@ -2,9 +2,9 @@ # procedures in the file tkVisual.c. It is organized in the standard # fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -455,7 +455,7 @@ test visual-7.1 {Tk_GetColormap, "new"} -constraints { colorsFree .t2 } -cleanup { deleteWindows -} -result {0} +} -result 0 test visual-7.2 {Tk_GetColormap, "new"} -constraints { defaultPseudocolor8 nonPortable } -setup { @@ -468,7 +468,7 @@ test visual-7.2 {Tk_GetColormap, "new"} -constraints { colorsFree .t2 } -cleanup { deleteWindows -} -result {1} +} -result 1 test visual-7.3 {Tk_GetColormap, copy from other window} -constraints { defaultPseudocolor8 nonPortable } -setup { @@ -484,7 +484,7 @@ test visual-7.3 {Tk_GetColormap, copy from other window} -constraints { colorsFree .t2 } -cleanup { deleteWindows -} -result {1} +} -result 1 test visual-7.4 {Tk_GetColormap, copy from other window} -constraints { defaultPseudocolor8 nonPortable } -setup { @@ -500,7 +500,7 @@ test visual-7.4 {Tk_GetColormap, copy from other window} -constraints { colorsFree .t2 } -cleanup { deleteWindows -} -result {0} +} -result 0 test visual-7.5 {Tk_GetColormap, copy from other window} -constraints { defaultPseudocolor8 nonPortable } -setup { diff --git a/tests/visual_bb.test b/tests/visual_bb.test index 030a369..36612a9 100644 --- a/tests/visual_bb.test +++ b/tests/visual_bb.test @@ -23,7 +23,7 @@ proc runTest {file} { global testNum test "2.$testNum" "testing $file" {userInteraction} { - uplevel \#0 source [file join [testsDirectory] $file] + uplevel #0 [list source -encoding utf-8 [file join [testsDirectory] $file]] concat "" } {} incr testNum @@ -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/winButton.test b/tests/winButton.test index 88b4345..a19f4e7 100644 --- a/tests/winButton.test +++ b/tests/winButton.test @@ -3,9 +3,9 @@ # widgets defined in tkWinButton.c). It is organized in the standard # fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/winClipboard.test b/tests/winClipboard.test index 2f72966..28e508b 100644 --- a/tests/winClipboard.test +++ b/tests/winClipboard.test @@ -6,8 +6,8 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-2000 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-2000 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -70,24 +70,23 @@ test winClipboard-1.5 {TkSelGetSelection & TkWinClipboardRender} -constraints { clipboard clear } -body { set map [list "\r" "\\r" "\n" "\\n"] - clipboard append "line 1\u00c7\nline 2" + clipboard append "line 1Ç\nline 2" list [string map $map [selection get -selection CLIPBOARD]]\ [string map $map [testclipboard]] } -cleanup { clipboard clear -} -result [list "line 1\u00c7\\nline 2" "line 1\u00c7\\nline 2"] +} -result [list "line 1Ç\\nline 2" "line 1Ç\\nline 2"] test winClipboard-1.6 {TkSelGetSelection & TkWinClipboardRender} -constraints { win testclipboard } -setup { clipboard clear } -body { - clipboard append "\u043f\u0440\u0438\u0432\u0435\u0442 \u043c\u0438\u0444" + clipboard append "привет миф" list [selection get -selection CLIPBOARD] [testclipboard] } -cleanup { clipboard clear -} -result [list "\u043f\u0440\u0438\u0432\u0435\u0442 \u043c\u0438\u0444"\ - "\u043f\u0440\u0438\u0432\u0435\u0442 \u043c\u0438\u0444"] +} -result [list "привет миф" "привет миф"] test winClipboard-2.1 {TkSelUpdateClipboard reentrancy problem} -constraints { win testclipboard diff --git a/tests/winDialog.test b/tests/winDialog.test index 1384770..a2414ec 100755 --- a/tests/winDialog.test +++ b/tests/winDialog.test @@ -3,9 +3,9 @@ # the common dialog boxes. It is organized in the standard # fashion for Tcl tests. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 1998-1999 ActiveState Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 1998-1999 ActiveState Corporation. package require tcltest 2.2 namespace import ::tcltest::* @@ -118,7 +118,7 @@ test winDialog-1.1 {Tk_ChooseColorObjCmd} -constraints { then { Click cancel } -} -result {0} +} -result 0 test winDialog-1.2 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { @@ -161,7 +161,7 @@ test winDialog-1.5 {Tk_ChooseColorObjCmd: -title} -constraints { set x {} start { set clr [tk_chooseColor -initialcolor "#ff9933" \ - -title "\u041f\u0440\u0438\u0432\u0435\u0442"] + -title "Привет"] } then { if {[catch { @@ -171,7 +171,7 @@ test winDialog-1.5 {Tk_ChooseColorObjCmd: -title} -constraints { lappend x [Click ok] } lappend x $clr -} -result [list "\u041f\u0440\u0438\u0432\u0435\u0442" 0 "#ff9933"] +} -result [list "Привет" 0 "#ff9933"] test winDialog-1.6 {Tk_ChooseColorObjCmd: -parent} -constraints { testwinevent } -setup { @@ -229,7 +229,7 @@ test winDialog-5.1 {GetFileName: no arguments} -constraints { then { Click cancel } -} -result {0} +} -result 0 test winDialog-5.2 {GetFileName: one argument} -constraints { nt } -body { @@ -242,7 +242,7 @@ test winDialog-5.3 {GetFileName: many arguments} -constraints { then { Click cancel } -} -result {0} +} -result 0 test winDialog-5.4 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} -constraints { nt } -body { @@ -259,7 +259,7 @@ test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} -constraints { # https://core.tcl-lang.org/tk/tktview/4a0451f5291b3c9168cc560747dae9264e1d2ef6 # $x is expected to be empty append x $y -} -result {0} +} -result 0 test winDialog-5.6 {GetFileName: valid option, but missing value} -constraints { nt } -body { @@ -545,7 +545,7 @@ test winDialog-5.12.3 {tk_getSaveFile: initial directory: .} -constraints { test winDialog-5.12.4 {tk_getSaveFile: initial directory: unicode} -constraints { nt testwinevent } -body { - set dir [tcltest::makeDirectory "\u0167\u00e9\u015d\u0167"] + set dir [tcltest::makeDirectory "ŧéŝŧ"] unset -nocomplain x start {set x [tk_getSaveFile \ -initialdir $dir \ @@ -646,7 +646,7 @@ test winDialog-5.12.8 {tk_getOpenFile: initial directory: .} -constraints { test winDialog-5.12.9 {tk_getOpenFile: initial directory: unicode} -constraints { nt testwinevent } -body { - set dir [tcltest::makeDirectory "\u0167\u00e9\u015d\u0167"] + set dir [tcltest::makeDirectory "ŧéŝŧ"] set path [tcltest::makeFile "" testfile $dir] unset -nocomplain x start {set x [tk_getOpenFile \ @@ -741,7 +741,7 @@ test winDialog-5.16 {GetFileName: parent} -constraints { destroy .t } return $x -} -result {1} +} -result 1 test winDialog-5.17 {GetFileName: title} -constraints { nt testwinevent } -body { @@ -751,7 +751,7 @@ test winDialog-5.17 {GetFileName: title} -constraints { then { Click cancel } -} -result {0} +} -result 0 if {[vista?]} { # In the newer file dialogs, the file type widget does not even exist # if no file types specified @@ -856,18 +856,18 @@ test winDialog-5.24 {GetFileName: file types: MakeFilter() succeeds} -constraint Click cancel } return $x -} -result {0} +} -result 0 test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} -constraints { nt } -body { # MacOS type that is correct, but has embedded high-bit chars. - start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\u2022\u2022\u2022\u2022}}}}]} + start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {••••}}}}]} then { Click cancel } return $x -} -result {0} +} -result 0 test winDialog-6.1 {MakeFilter} -constraints {emptyTest nt} -body {} @@ -892,7 +892,7 @@ test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} -constraints { }] # $x should be "" on a Cancel append x $y -} -result {0} +} -result 0 test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} -constraints { nt } -body { @@ -907,7 +907,7 @@ test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} -constraints { then { Click cancel } -} -result {0} +} -result 0 test winDialog-9.4 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() != TCL_OK} -constraints { nt } -body { @@ -920,7 +920,7 @@ test winDialog-9.5 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() == TCL_OK} - then { Click cancel } -} -result {0} +} -result 0 test winDialog-9.6 {Tk_ChooseDirectoryObjCmd: valid option, but missing value} -constraints { nt } -body { @@ -1048,7 +1048,7 @@ test winDialog-10.9 {Tk_FontchooserObjCmd: -title} -constraints { } -body { start { tk fontchooser configure -command ApplyFont \ - -title "\u041f\u0440\u0438\u0432\u0435\u0442" + -title "Привет" tk fontchooser show } then { @@ -1056,7 +1056,7 @@ test winDialog-10.9 {Tk_FontchooserObjCmd: -title} -constraints { Click cancel } set a(text) -} -result "\u041f\u0440\u0438\u0432\u0435\u0442" +} -result "Привет" if {[testConstraint testwinevent]} { catch {testwinevent debug 0} diff --git a/tests/winFont.test b/tests/winFont.test index 4a394cf..bddc69e 100644 --- a/tests/winFont.test +++ b/tests/winFont.test @@ -6,8 +6,8 @@ # underlined?"); these tests attempt to exercise the code in question, # but there are no results that can be checked. # -# Copyright (c) 1996-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -37,12 +37,12 @@ test winfont-2.1 {TkpGetFontFromAttributes procedure: pointsize} -constraints { win } -body { expr {[font actual {-size -10} -size] > 0} -} -result {1} +} -result 1 test winfont-2.2 {TkpGetFontFromAttributes procedure: pointsize} -constraints { win } -body { expr {[font actual {-family Arial} -size] > 0} -} -result {1} +} -result 1 test winfont-2.3 {TkpGetFontFromAttributes procedure: normal weight} -constraints { win } -body { @@ -71,7 +71,7 @@ test winfont-2.7 {TkpGetFontFromAttributes procedure: Times fonts} -constraints lappend x [font actual {-family "Times"} -family] lappend x [font actual {-family "New York"} -family] lappend x [font actual {-family "Times New Roman"} -family] -} -result {{Times New Roman} {Times New Roman} {Times New Roman}} +} -result {Times Times {Times New Roman}} test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} -constraints { win } -setup { @@ -80,7 +80,7 @@ test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} -constraint lappend x [font actual {-family "Courier"} -family] lappend x [font actual {-family "Monaco"} -family] lappend x [font actual {-family "Courier New"} -family] -} -result {{Courier New} {Courier New} {Courier New}} +} -match regexp -result {Courier (Courier|Monaco) {Courier New}} test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} -constraints { win } -setup { @@ -89,7 +89,7 @@ test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} -constrai lappend x [font actual {-family "Helvetica"} -family] lappend x [font actual {-family "Geneva"} -family] lappend x [font actual {-family "Arial"} -family] -} -result {Arial Arial Arial} +} -match regexp -result {Helvetica (Helvetica|Geneva) Arial} test winfont-2.10 {TkpGetFontFromAttributes procedure: fallback} -constraints { win } -body { @@ -221,7 +221,7 @@ test winfont-5.5 {Tk_MeasureChars procedure: include last partial char} -constra .t.c index $t @[expr {int($cx*2.5)}],1 } -cleanup { destroy .t.c -} -result {2} +} -result 2 test winfont-5.6 {Tk_MeasureChars procedure: at least one char on line} -constraints { win @@ -337,7 +337,7 @@ test winfont-5.11 {Tk_MeasureChars procedure: check for kerning} -constraints { expr {$x < ($width*10)} } -cleanup { destroy .t.l -} -result {1} +} -result 1 test winfont-6.1 {Tk_DrawChars procedure: loop test} -constraints win -setup { @@ -375,12 +375,12 @@ test winfont-7.3 {AllocFont procedure: extract info from textmetric} -constraint win } -body { font metric {arial 10 bold italic underline overstrike} -fixed -} -result {0} +} -result 0 test winfont-7.4 {AllocFont procedure: extract info from textmetric} -constraints { win } -body { font metric systemfixed -fixed -} -result {1} +} -result 1 # cleanup cleanupTests diff --git a/tests/winMenu.test b/tests/winMenu.test index b77e9a9..3b7dbec 100644 --- a/tests/winMenu.test +++ b/tests/winMenu.test @@ -3,8 +3,8 @@ # file tests the Macintosh-specific features of the menu # system. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/winMsgbox.test b/tests/winMsgbox.test index 0181103..cf7a05f 100644 --- a/tests/winMsgbox.test +++ b/tests/winMsgbox.test @@ -1,6 +1,6 @@ # This file is a Tcl script to test the Windows specific message box # -# Copyright (c) 2007 Pat Thoyts <patthoyts@users.sourceforge.net> +# Copyright © 2007 Pat Thoyts <patthoyts@users.sourceforge.net> package require tcltest 2.2 namespace import ::tcltest::* @@ -224,14 +224,14 @@ test winMsgbox-2.3 {tk_messageBox message (unicode)} -constraints { } -body { global windowInfo set title "winMsgbox-2.2 [pid]" - set message "\u041f\u043e\u0438\u0441\u043a\u0020\u0441\u0442\u0440\u0430\u043d\u0438\u0446" + set message "Поиск страниц" after 100 [list GetWindowInfo $title 2] set r [tk_messageBox -type ok -title $title -message $message] array set info $windowInfo lappend r $info(childtext) } -cleanup { wm deiconify . -} -result [list ok "\u041f\u043e\u0438\u0441\u043a\u0020\u0441\u0442\u0440\u0430\u043d\u0438\u0446"] +} -result [list ok "Поиск страниц"] test winMsgbox-2.4 {tk_messageBox message (empty)} -constraints { win getwindowinfo @@ -276,15 +276,15 @@ test winMsgbox-3.2 {tk_messageBox detail (unicode)} -constraints { } -body { global windowInfo set title "winMsgbox-3.1 [pid]" - set message "\u041f\u043e\u0438\u0441\u043a" - set detail "\u0441\u0442\u0440\u0430\u043d\u0438\u0446" + set message "Поиск" + set detail "страниц" after 100 [list GetWindowInfo $title 2] set r [tk_messageBox -type ok -title $title -message $message -detail $detail] array set info $windowInfo lappend r $info(childtext) } -cleanup { wm deiconify . -} -result [list ok "\u041f\u043e\u0438\u0441\u043a\n\n\u0441\u0442\u0440\u0430\u043d\u0438\u0446"] +} -result [list ok "Поиск\n\nстраниц"] # ------------------------------------------------------------------------- diff --git a/tests/winSend.test b/tests/winSend.test index d4860b4..4a7f81d 100644 --- a/tests/winSend.test +++ b/tests/winSend.test @@ -2,9 +2,9 @@ # other procedures in the file tkSend.c. It is organized in the # standard fashion for Tcl tests. # -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -152,7 +152,7 @@ test winSend-3.1 {TkGetInterpNames} winSend { set origLength [llength $currentInterps] set newLength [llength [winfo interps]] expr {($newLength - 2) == $origLength} -} {1} +} 1 test winSend-4.1 {DeleteProc - changing name of app} winSend { newApp a @@ -171,7 +171,7 @@ test winSend-5.1 {ExecuteRemoteObject - no error} winSend { } } list [send $interp {send [tk appname] {expr {2 / 1}}}] -} {2} +} 2 test winSend-5.2 {ExecuteRemoteObject - error} winSend { set newInterps [winfo interps] foreach interp $newInterps { @@ -268,7 +268,7 @@ test winSend-6.8 {SendDDEServer - XTYP_WILDCONNECT} winSend { } set command "dde services Tk {}" list [catch "send \{$interp\} \{$command\}"] -} {0} +} 0 test winSend-7.1 {DDEExitProc} winSend { newApp testApp @@ -312,10 +312,10 @@ test winSend-10.7 {Tk_DDEObjCmd - services wrong num args} winSend { } {1 {wrong # args: should be "dde services serviceName topicName"}} test winSend-10.8 {Tk_DDEObjCmd - null service name} winSend { list [catch {dde services {} {tktest #2}}] -} {0} +} 0 test winSend-10.9 {Tk_DDEObjCmd - null topic name} winSend { list [catch {dde services {Tk} {}}] -} {0} +} 0 test winSend-10.10 {Tk_DDEObjCmd - execute - nothing to execute} winSend { set newInterps [winfo interps] foreach interp $newInterps { diff --git a/tests/winWm.test b/tests/winWm.test index e19fcf2..f659a13 100644 --- a/tests/winWm.test +++ b/tests/winWm.test @@ -5,8 +5,8 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -14,6 +14,7 @@ namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands +testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] test winWm-1.1 {TkWmMapWindow} -constraints win -setup { @@ -246,7 +247,7 @@ test winWm-5.2 {UpdateGeometryInfo: menu resizing} -constraints win -setup { update set y [winfo rooty .t] lappend result [winfo height .t] - menu .t.m + menu .t.m -tearoff 1 .t configure -menu .t.m .t.m add command -label foo .t.m add command -label "thisisreallylong" @@ -275,7 +276,7 @@ test winWm-6.2 {wm attributes} -constraints win -setup { wm attributes .t -disabled } -cleanup { destroy .t -} -result {0} +} -result 0 test winWm-6.3 {wm attributes} -constraints win -setup { destroy .t } -body { @@ -449,7 +450,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 {} { @@ -493,7 +494,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/window.test b/tests/window.test index c3b507d..8a56d5a 100644 --- a/tests/window.test +++ b/tests/window.test @@ -1,8 +1,8 @@ # This file is a Tcl script to test the procedures in the file # tkWindow.c. It is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 diff --git a/tests/winfo.test b/tests/winfo.test index 750444f..ae0af64 100644 --- a/tests/winfo.test +++ b/tests/winfo.test @@ -1,9 +1,9 @@ # This file is a Tcl script to test out the "winfo" command. It is # organized in the standard fashion for Tcl tests. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -177,7 +177,7 @@ test winfo-4.7 {"winfo containing" command} -setup { expr {($x == ".") || ($x == "")} } -cleanup { destroy .t -} -result {1} +} -result 1 test winfo-5.1 {"winfo interps" command} -body { @@ -191,10 +191,10 @@ test winfo-5.3 {"winfo interps" command} -body { } -returnCodes error -result {bad window path name "geek"} test winfo-5.4 {"winfo interps" command} -constraints unix -body { expr {[lsearch -exact [winfo interps] [tk appname]] >= 0} -} -result {1} +} -result 1 test winfo-5.5 {"winfo interps" command} -constraints unix -body { expr {[lsearch -exact [winfo interps -displayof .] [tk appname]] >= 0} -} -result {1} +} -result 1 test winfo-6.1 {"winfo exists" command} -body { @@ -205,10 +205,10 @@ test winfo-6.2 {"winfo exists" command} -body { } -returnCodes error -result {wrong # args: should be "winfo exists window"} test winfo-6.3 {"winfo exists" command} -body { winfo exists gorp -} -result {0} +} -result 0 test winfo-6.4 {"winfo exists" command} -body { winfo exists . -} -result {1} +} -result 1 test winfo-6.5 {"winfo exists" command} -setup { destroy .b } -body { @@ -293,13 +293,13 @@ test winfo-9.2 {"winfo viewable" command} -body { } -returnCodes error -result {bad window path name "foo"} test winfo-9.3 {"winfo viewable" command} -body { winfo viewable . -} -result {1} +} -result 1 test winfo-9.4 {"winfo viewable" command} -constraints {failsOnUbuntu failsOnXQuarz} -body { wm iconify . winfo viewable . } -cleanup { wm deiconify . -} -result {0} +} -result 0 test winfo-9.5 {"winfo viewable" command} -setup { deleteWindows } -body { @@ -347,7 +347,7 @@ test winfo-10.2 {"winfo visualid" command} -body { } -returnCodes error -result {bad window path name "gorp"} test winfo-10.3 {"winfo visualid" command} -body { expr {2 + [winfo visualid .] - [winfo visualid .]} -} -result {2} +} -result 2 test winfo-11.1 {"winfo visualid" command} -body { @@ -361,14 +361,14 @@ test winfo-11.3 {"winfo visualid" command} -body { } -returnCodes error -result {wrong # args: should be "winfo visualsavailable window ?includeids?"} test winfo-11.4 {"winfo visualid" command} -body { llength [lindex [winfo visualsa .] 0] -} -result {2} +} -result 2 test winfo-11.5 {"winfo visualid" command} -body { llength [lindex [winfo visualsa . includeids] 0] -} -result {3} +} -result 3 test winfo-11.6 {"winfo visualid" command} -body { set x [lindex [lindex [winfo visualsa . includeids] 0] 2] expr {$x + 2 - $x} -} -result {2} +} -result 2 test winfo-12.1 {GetDisplayOf procedure} -body { diff --git a/tests/wm.test b/tests/wm.test index 7959302..e24181e 100644 --- a/tests/wm.test +++ b/tests/wm.test @@ -2,9 +2,9 @@ # manager, including the "wm" command. It is organized in the standard fashion # for Tcl tests. # -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1992-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. # This file tests window manager interactions that work across platforms. @@ -788,7 +788,7 @@ test wm-iconify-2.3 {Misc errors} -body { wm iconify .t2 } -returnCodes error -cleanup { destroy .t2 -} -result {can't iconify .t2: it is an icon for .t} +} -result {can't iconify ".t2": it is an icon for ".t"} # test embedded window for Windows test wm-iconify-2.4.1 {Misc errors} -constraints win -setup { destroy .t2 @@ -798,7 +798,7 @@ test wm-iconify-2.4.1 {Misc errors} -constraints win -setup { wm iconify .t2 } -returnCodes error -cleanup { destroy .t2 .r.f -} -result {can't iconify .t2: the container does not support the request} +} -result {can't iconify ".t2": the container does not support the request} # test embedded window for other platforms test wm-iconify-2.4.2 {Misc errors} -constraints !win -setup { destroy .t2 @@ -808,7 +808,7 @@ test wm-iconify-2.4.2 {Misc errors} -constraints !win -setup { wm iconify .t2 } -returnCodes error -cleanup { destroy .t2 .r.f -} -result {can't iconify .t2: it is an embedded window} +} -result {can't iconify ".t2": it is an embedded window} test wm-iconify-3.1 {iconify behavior} -constraints {failsOnUbuntu failsOnXQuarz} -body { toplevel .t2 @@ -1489,14 +1489,14 @@ test wm-stackorder-4.1 {wm stackorder isabove|isbelow} -body { wm stackorder . isabove .t } -cleanup { destroy .t -} -result {0} +} -result 0 test wm-stackorder-4.2 {wm stackorder isabove|isbelow} -body { toplevel .t ; update raise .t wm stackorder . isbelow .t } -cleanup { destroy .t -} -result {1} +} -result 1 test wm-stackorder-4.3 {wm stackorder isabove|isbelow} -body { toplevel .t ; update raise . @@ -1504,7 +1504,7 @@ test wm-stackorder-4.3 {wm stackorder isabove|isbelow} -body { wm stackorder .t isa . } -cleanup { destroy .t -} -result {0} +} -result 0 test wm-stackorder-4.4 {wm stackorder isabove|isbelow} -body { toplevel .t ; update raise . @@ -1512,7 +1512,7 @@ test wm-stackorder-4.4 {wm stackorder isabove|isbelow} -body { wm stackorder .t isb . } -cleanup { destroy .t -} -result {1} +} -result 1 deleteWindows test wm-stackorder-5.1 {a menu is not a toplevel} -body { @@ -1600,7 +1600,7 @@ test wm-title-2.1 {setting and reading values} -setup { test wm-transient-1.1 {usage} -returnCodes error -body { catch {destroy .t} ; toplevel .t wm transient .t 1 2 -} -result {wrong # args: should be "wm transient window ?master?"} +} -result {wrong # args: should be "wm transient window ?window?"} test wm-transient-1.2 {usage} -returnCodes error -body { catch {destroy .t} ; toplevel .t wm transient .t foo @@ -1635,13 +1635,13 @@ test wm-transient-1.6 {usage} -returnCodes error -body { wm transient .dummy .icon } -cleanup { deleteWindows -} -result {can't make ".icon" a master: it is an icon for .top} +} -result {can't make ".icon" a container: it is an icon for .top} test wm-transient-1.7 {usage} -returnCodes error -body { toplevel .top wm transient .top .top } -cleanup { deleteWindows -} -result {setting ".top" as master creates a transient/master cycle} +} -result {can't set ".top" as container: would cause management loop} test wm-transient-1.8 {usage} -returnCodes error -body { toplevel .t1 toplevel .t2 @@ -1651,14 +1651,14 @@ test wm-transient-1.8 {usage} -returnCodes error -body { wm transient .t1 .t3 } -cleanup { deleteWindows -} -result {setting ".t3" as master creates a transient/master cycle} +} -result {can't set ".t3" as container: would cause management loop} test wm-transient-1.9 {usage} -returnCodes error -body { toplevel .top frame .top.f wm transient .top .top.f } -cleanup { deleteWindows -} -result {setting ".top" as master creates a transient/master cycle} +} -result {can't set ".top" as container: would cause management loop} test wm-transient-2.1 {basic get/set of toplevel} -setup { set results [list] @@ -2282,7 +2282,7 @@ test wm-forget-1.1 "bug #2009788: forget toplevel can cause crash" -body { winfo exists .parent.child } -cleanup { deleteWindows -} -result {1} +} -result 1 test wm-forget-1.2 "bug #2009788: forget toplevel can cause crash" -body { toplevel .parent update @@ -2291,7 +2291,7 @@ test wm-forget-1.2 "bug #2009788: forget toplevel can cause crash" -body { winfo exists .parent.child } -cleanup { deleteWindows -} -result {1} +} -result 1 test wm-forget-1.3 "bug #2009788: forget toplevel can cause crash" -body { toplevel .parent toplevel .parent.child @@ -2300,7 +2300,7 @@ test wm-forget-1.3 "bug #2009788: forget toplevel can cause crash" -body { winfo exists .parent.child } -cleanup { deleteWindows -} -result {1} +} -result 1 test wm-forget-1.4 "pack into unmapped toplevel causes crash" -body { toplevel .parent toplevel .parent.child diff --git a/tests/xmfbox.test b/tests/xmfbox.test index f50329c..a6426ec 100644 --- a/tests/xmfbox.test +++ b/tests/xmfbox.test @@ -5,8 +5,8 @@ # runs in a modal loop, the only way to test it sufficiently is # to call the internal Tcl procedures in xmfbox.tcl directly. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. |
