diff options
Diffstat (limited to 'tk/tests')
99 files changed, 10961 insertions, 2206 deletions
diff --git a/tk/tests/README b/tk/tests/README index d1f4d1a46ac..ea935942dc4 100644 --- a/tk/tests/README +++ b/tk/tests/README @@ -1,30 +1,8 @@ -Tk Test Suite --------------- +README -- Tk test suite design document. RCS: @(#) $Id$ -This directory contains a set of validation tests for Tk. -Each of the files whose name ends in ".test" is intended to -fully exercise one or a few Tk features. The features -tested by a given file are listed in the first line of the -file. The test suite is nowhere near complete yet. Contributions -of additional tests would be most welcome. +This directory contains a set of validation tests for the Tk commands. +Please see the tests/README file in the Tcl source distribution for +information about the test suite. -You can run the tests in two ways: - (a) type "make test" in the directory ../unix; this will run all of - the tests. - (b) start up tktest in this directory, then "source" the test - file (for example, type "source pack.test"). To run all - of the tests, type "source all". -In either case no output will be generated if all goes well, except -for a listing of the tests. If there are errors then additional -messages will appear. - -For more details on the testing environment, see the README -file in the Tcl test directory. - -You can also run a set of visual tests, which create various screens -that you can verify visually for appropriate behavior. The visual -tests are available through the "visual" script: if you invoke this -script, it creates a main window with a bunch of menus. Each menu -runs a particular test. diff --git a/tk/tests/all.tcl b/tk/tests/all.tcl new file mode 100644 index 00000000000..dea18b63876 --- /dev/null +++ b/tk/tests/all.tcl @@ -0,0 +1,78 @@ +# all.tcl -- +# +# This file contains a top-level script to run all of the Tk +# tests. Execute it by invoking "source all.tcl" when running tktest +# in this directory. +# +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. +# +# RCS: @(#) $Id$ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} +set ::tcltest::testSingleFile false + +puts stdout "Tk $tk_patchLevel tests running in interp: [info nameofexecutable]" +puts stdout "Tests running in working dir: $::tcltest::workingDir" +if {[llength $::tcltest::skip] > 0} { + puts stdout "Skipping tests that match: $::tcltest::skip" +} +if {[llength $::tcltest::match] > 0} { + puts stdout "Only running tests that match: $::tcltest::match" +} + +# Use command line specified glob pattern (specified by -file or -f) +# if one exists. Otherwise use *.test. If given, the file pattern +# should be specified relative to the dir containing this file. If no +# files are found to match the pattern, print an error message and exit. +set fileIndex [expr {[lsearch $argv "-file"] + 1}] +set fIndex [expr {[lsearch $argv "-f"] + 1}] +if {($fileIndex < 1) || ($fIndex > $fileIndex)} { + set fileIndex $fIndex +} +if {$fileIndex > 0} { + set globPattern [file join $::tcltest::testsDir [lindex $argv $fileIndex]] + puts stdout "Sourcing files that match: $globPattern" +} else { + set globPattern [file join $::tcltest::testsDir *.test] +} +set fileList [glob -nocomplain $globPattern] +if {[llength $fileList] < 1} { + puts "Error: no files found matching $globPattern" + exit +} +set timeCmd {clock format [clock seconds]} +puts stdout "Tests began at [eval $timeCmd]" + +# source each of the specified tests +foreach file [lsort $fileList] { + set tail [file tail $file] + if {[string match l.*.test $tail]} { + # This is an SCCS lockfile; ignore it + continue + } + puts stdout $tail + if {[catch {source $file} msg]} { + puts stdout $msg + } +} + +# cleanup +puts stdout "\nTests ended at [eval $timeCmd]" +::tcltest::cleanupTests 1 +return + + + + + + + + + + + + + diff --git a/tk/tests/arc.tcl b/tk/tests/arc.tcl index f164b4b9cb1..6f754639270 100644 --- a/tk/tests/arc.tcl +++ b/tk/tests/arc.tcl @@ -138,3 +138,16 @@ bind .t.c a { bind .t.c b {set go 0} bind .t.c <Control-x> {.t.c delete current} + + + + + + + + + + + + + diff --git a/tk/tests/bell.test b/tk/tests/bell.test index 4ea8983edfe..e2d66f62be1 100644 --- a/tk/tests/bell.test +++ b/tk/tests/bell.test @@ -2,16 +2,13 @@ # 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 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } test bell-1.1 {bell command} { @@ -29,9 +26,24 @@ test bell-1.4 {bell command} { after 500 bell -displayof . after 200 - bell -dis . - after 200 bell after 200 bell } {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/bevel.tcl b/tk/tests/bevel.tcl index ea89b092565..9a55f966cbc 100644 --- a/tk/tests/bevel.tcl +++ b/tk/tests/bevel.tcl @@ -126,3 +126,16 @@ foreach i {1 2 3} { .t.t insert end rrr r1 .t.t insert end ***** .t.t insert end rrr r1 + + + + + + + + + + + + + diff --git a/tk/tests/bgerror.test b/tk/tests/bgerror.test index d98f2cac2a2..c821389b6dd 100644 --- a/tk/tests/bgerror.test +++ b/tk/tests/bgerror.test @@ -2,17 +2,15 @@ # It is organized in the standard fashion for Tcl tests. # # Copyright (c) 1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info commands test] == ""} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } - test bgerror-1.1 {bgerror / tkerror compat} { set errRes {} proc tkerror {err} { @@ -57,3 +55,19 @@ catch {rename tkerror {}} # would be needed too, but that's not easy at all # to emulate. +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/bind.test b/tk/tests/bind.test index f03961e3506..1aa7d8202b9 100644 --- a/tk/tests/bind.test +++ b/tk/tests/bind.test @@ -4,15 +4,13 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. -# Copyright (c) 1998 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] != 0} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } catch {destroy .b} @@ -220,6 +218,7 @@ test bind-5.1 {Tk_CreateBindingTable procedure} { if {[string compare testcbind [info commands testcbind]] != 0} { puts "This application hasn't been compiled with the testcbind command," puts "therefore I am skipping all of these tests." + ::tcltest::cleanupTests return } @@ -254,7 +253,7 @@ test bind-6.2 {Tk_DeleteBindTable procedure: pending bindings deleted later} { set x } {a1 bye.all2 bye.a1 b1 bye.c1} -test bind-7.1 {Tk_CreateBinding procedure: error} { +test bind-7.1 {Tk_CreateBinding procedure: bad binding} { catch {destroy .b.c} canvas .b.c list [catch {.b.c bind foo <} msg] $msg @@ -1039,8 +1038,10 @@ test bind-15.14 {MatchPatterns procedure, checking "nearby"} { bind .b.f <Double-1> {set x 1} set x 0 event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Button-1> -x 30 -y 40 event gen .b.f <Button-1> -x 31 -y 39 + event gen .b.f <ButtonRelease-1> set x } 1 test bind-15.15 {MatchPatterns procedure, checking "nearby"} { @@ -1048,8 +1049,10 @@ test bind-15.15 {MatchPatterns procedure, checking "nearby"} { bind .b.f <Double-1> {set x 1} set x 0 event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Button-1> -x 30 -y 40 event gen .b.f <Button-1> -x 29 -y 41 + event gen .b.f <ButtonRelease-1> set x } 1 test bind-15.16 {MatchPatterns procedure, checking "nearby"} { @@ -1057,8 +1060,10 @@ test bind-15.16 {MatchPatterns procedure, checking "nearby"} { bind .b.f <Double-1> {set x 1} set x 0 event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Button-1> -x 30 -y 40 event gen .b.f <Button-1> -x 40 -y 40 + event gen .b.f <ButtonRelease-2> set x } 0 test bind-15.17 {MatchPatterns procedure, checking "nearby"} { @@ -1066,8 +1071,10 @@ test bind-15.17 {MatchPatterns procedure, checking "nearby"} { bind .b.f <Double-1> {set x 1} set x 0 event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Button-1> -x 30 -y 40 event gen .b.f <Button-1> -x 20 -y 40 + event gen .b.f <ButtonRelease-1> set x } 0 test bind-15.18 {MatchPatterns procedure, checking "nearby"} { @@ -1075,8 +1082,10 @@ test bind-15.18 {MatchPatterns procedure, checking "nearby"} { bind .b.f <Double-1> {set x 1} set x 0 event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Button-1> -x 30 -y 40 event gen .b.f <Button-1> -x 30 -y 30 + event gen .b.f <ButtonRelease-1> set x } 0 test bind-15.19 {MatchPatterns procedure, checking "nearby"} { @@ -1084,8 +1093,10 @@ test bind-15.19 {MatchPatterns procedure, checking "nearby"} { bind .b.f <Double-1> {set x 1} set x 0 event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Button-1> -x 30 -y 40 event gen .b.f <Button-1> -x 30 -y 50 + event gen .b.f <ButtonRelease-1> set x } 0 test bind-15.20 {MatchPatterns procedure, checking "nearby"} { @@ -1093,8 +1104,10 @@ test bind-15.20 {MatchPatterns procedure, checking "nearby"} { bind .b.f <Double-1> {set x 1} set x 0 event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Button-1> -time 300 event gen .b.f <Button-1> -time 700 + event gen .b.f <ButtonRelease-1> set x } 1 test bind-15.21 {MatchPatterns procedure, checking "nearby"} { @@ -1102,8 +1115,10 @@ test bind-15.21 {MatchPatterns procedure, checking "nearby"} { bind .b.f <Double-1> {set x 1} set x 0 event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Button-1> -time 300 event gen .b.f <Button-1> -time 900 + event gen .b.f <ButtonRelease-1> set x } 0 test bind-15.22 {MatchPatterns procedure, time wrap-around} { @@ -1112,6 +1127,7 @@ test bind-15.22 {MatchPatterns procedure, time wrap-around} { set x 0 event gen .b.f <Button-1> -time [expr -100] event gen .b.f <Button-1> -time 200 + event gen .b.f <ButtonRelease-1> set x } 1 test bind-15.23 {MatchPatterns procedure, time wrap-around} { @@ -1120,6 +1136,7 @@ test bind-15.23 {MatchPatterns procedure, time wrap-around} { set x 0 event gen .b.f <Button-1> -time -100 event gen .b.f <Button-1> -time 500 + event gen .b.f <ButtonRelease-1> set x } 0 test bind-15.24 {MatchPatterns procedure, virtual event} { @@ -1128,6 +1145,7 @@ test bind-15.24 {MatchPatterns procedure, virtual event} { bind .b.f <<Paste>> {lappend x paste} set x {} event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> set x } {paste} test bind-15.25 {MatchPatterns procedure, reject a virtual event} { @@ -1136,6 +1154,7 @@ test bind-15.25 {MatchPatterns procedure, reject a virtual event} { bind .b.f <<Paste>> {lappend x paste} set x {} event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> set x } {} test bind-15.26 {MatchPatterns procedure, reject a virtual event} { @@ -1148,10 +1167,12 @@ test bind-15.26 {MatchPatterns procedure, reject a virtual event} { event gen .b.f <Button> -serial 101 event gen .b.f <Button-1> -serial 102 event gen .b.f <Shift-Button-1> -serial 103 + event gen .b.f <ButtonRelease-1> bind .b.f <Shift-Button-1> "lappend x Shift-Button-1" event gen .b.f <Button> -serial 104 event gen .b.f <Button-1> -serial 105 event gen .b.f <Shift-Button-1> -serial 106 + event gen .b.f <ButtonRelease-1> set x } {V2102 V2103 V2105 Shift-Button-1} test bind-15.27 {MatchPatterns procedure, conflict resolution} { @@ -1187,6 +1208,7 @@ test bind-15.30 {MatchPatterns procedure, conflict resolution} { bind .b.f <1> {set x 1} set x none event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> set x } 1 test bind-15.31 {MatchPatterns procedure, conflict resolution} { @@ -1214,6 +1236,7 @@ test bind-15.33 {MatchPatterns procedure, conflict resolution} { event gen .b.f <Button-1> event gen .b.f <Button-1> event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> set x } {single single(Test) single double(Test) single double(Test)} foreach i [bind Test] { @@ -1245,6 +1268,7 @@ test bind-16.4 {ExpandPercents procedure} { bind .b.f <Button> {set x %b} set x none event gen .b.f <Button-3> + event gen .b.f <ButtonRelease-3> set x } 3 test bind-16.5 {ExpandPercents procedure} { @@ -1398,9 +1422,10 @@ test bind-16.26 {ExpandPercents procedure} { setup bind .b.f <1> {set x "%s"} set x none - event gen .b.f <Button-1> -state 122 + event gen .b.f <Button-1> -state 1402 + event gen .b.f <ButtonRelease-1> set x -} 122 +} 1402 test bind-16.27 {ExpandPercents procedure} { setup bind .b.f <Enter> {set x "%s"} @@ -1434,6 +1459,7 @@ test bind-16.31 {ExpandPercents procedure} { bind .b.f <Button> {set x "%t"} set x none event gen .b.f <Button> -time 4294 + event gen .b.f <ButtonRelease> set x } 4294 test bind-16.32 {ExpandPercents procedure} { @@ -1441,6 +1467,7 @@ test bind-16.32 {ExpandPercents procedure} { bind .b.f <Button> {set x "%x %y"} set x none event gen .b.f <Button> -x 881 -y 432 + event gen .b.f <ButtonRelease> set x } {881 432} test bind-16.33 {ExpandPercents procedure} { @@ -1470,8 +1497,11 @@ test bind-16.35 {ExpandPercents procedure} {nonPortable} { event gen .b.f <Key-space> event gen .b.f <Key-dollar> -state 1 event gen .b.f <Key-braceleft> -state 1 + event gen .b.f <Key-Multi_key> + event gen .b.f <Key-e> + event gen .b.f <Key-apostrophe> set x -} "a A { } {\r} {{}} {{}} { } {\$} \\\{" +} "a A { } {\r} {{}} {{}} { } {\$} \\\{ {{}} {{}} \u00e9" test bind-16.36 {ExpandPercents procedure} { setup bind .b.f <Configure> {set x "%B"} @@ -1533,16 +1563,17 @@ test bind-16.43 {ExpandPercents procedure} { bind .b.f <Button> {set x "%X %Y"} set x none event gen .b.f <Button> -rootx 422 -rooty 13 + event gen .b.f <ButtonRelease> set x } {422 13} test bind-17.1 {event command} { list [catch {event} msg] $msg -} {1 {wrong # args: should be "event option ?arg1?"}} +} {1 {wrong # args: should be "event option ?arg?"}} test bind-17.2 {event command} { - list [catch {event {}} msg] $msg -} {1 {bad option "": should be add, delete, generate, info}} + list [catch {event xyz} msg] $msg +} {1 {bad option "xyz": must be add, delete, generate, or info}} test bind-17.3 {event command: add} { list [catch {event add} msg] $msg } {1 {wrong # args: should be "event add virtual sequence ?sequence ...?"}} @@ -1611,8 +1642,7 @@ test bind-17.16 {event command: generate} { } {1 {bad event type or keysym "xyz"}} test bind-17.17 {event command} { list [catch {event foo} msg] $msg -} {1 {bad option "foo": should be add, delete, generate, info}} - +} {1 {bad option "foo": must be add, delete, generate, or info}} test bind-18.1 {CreateVirtualEvent procedure: GetVirtualEventUid} { list [catch {event add asd <Ctrl-v>} msg] $msg @@ -1710,8 +1740,10 @@ test bind-19.11 {DeleteVirtualEvent procedure: owned by 1, only} { bind .b.f <<xyz>> {lappend x %#} set x {} event gen .b.f <Button-2> -serial 101 + event gen .b.f <ButtonRelease-2> event delete <<xyz>> event gen .b.f <Button-2> -serial 102 + event gen .b.f <ButtonRelease-2> set x } {101} test bind-19.12 {DeleteVirtualEvent procedure: owned by 1, first in chain} { @@ -1722,10 +1754,14 @@ test bind-19.12 {DeleteVirtualEvent procedure: owned by 1, first in chain} { bind .b.f <<abc>> {lappend x abc} set x {} event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Control-Button-2> + event gen .b.f <Control-ButtonRelease-2> event delete <<xyz>> event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Control-Button-2> + event gen .b.f <Control-ButtonRelease-2> list $x [event info <<abc>>] } {{xyz abc abc} <Control-Button-2>} test bind-19.13 {DeleteVirtualEvent procedure: owned by 1, second in chain} { @@ -1738,12 +1774,18 @@ test bind-19.13 {DeleteVirtualEvent procedure: owned by 1, second in chain} { bind .b.f <<def>> {lappend x def} set x {} event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Control-Button-2> + event gen .b.f <Control-ButtonRelease-2> event gen .b.f <Shift-Button-2> + event gen .b.f <Shift-ButtonRelease-2> event delete <<xyz>> event gen .b.f <Button-2> event gen .b.f <Control-Button-2> event gen .b.f <Shift-Button-2> + event gen .b.f <ButtonRelease-2> + event gen .b.f <Control-ButtonRelease-2> + event gen .b.f <Shift-ButtonRelease-2> list $x [event info <<def>>] [event info <<xyz>>] [event info <<abc>>] } {{xyz abc def abc def} <Shift-Button-2> {} <Control-Button-2>} test bind-19.14 {DeleteVirtualEvent procedure: owned by 1, last in chain} { @@ -1756,12 +1798,18 @@ test bind-19.14 {DeleteVirtualEvent procedure: owned by 1, last in chain} { bind .b.f <<def>> {lappend x def} set x {} event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Control-Button-2> + event gen .b.f <Control-ButtonRelease-2> event gen .b.f <Shift-Button-2> + event gen .b.f <Shift-ButtonRelease-2> event delete <<xyz>> event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Control-Button-2> + event gen .b.f <Control-ButtonRelease-2> event gen .b.f <Shift-Button-2> + event gen .b.f <Shift-ButtonRelease-2> list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>] } {{xyz abc def abc def} {} <Control-Button-2> <Shift-Button-2>} test bind-19.15 {DeleteVirtualEvent procedure: owned by many, first} { @@ -1777,12 +1825,18 @@ test bind-19.15 {DeleteVirtualEvent procedure: owned by many, first} { bind .b.h <<def>> {lappend x def} set x {} event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.g <Button-2> + event gen .b.g <ButtonRelease-2> event gen .b.h <Button-2> + event gen .b.h <ButtonRelease-2> event delete <<xyz>> event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.g <Button-2> + event gen .b.g <ButtonRelease-2> event gen .b.h <Button-2> + event gen .b.h <ButtonRelease-2> destroy .b.g destroy .b.h list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>] @@ -1800,12 +1854,18 @@ test bind-19.16 {DeleteVirtualEvent procedure: owned by many, middle} { bind .b.h <<def>> {lappend x def} set x {} event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.g <Button-2> + event gen .b.g <ButtonRelease-2> event gen .b.h <Button-2> + event gen .b.h <ButtonRelease-2> event delete <<abc>> event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.g <Button-2> + event gen .b.g <ButtonRelease-2> event gen .b.h <Button-2> + event gen .b.h <ButtonRelease-2> destroy .b.g destroy .b.h list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>] @@ -1823,12 +1883,18 @@ test bind-19.17 {DeleteVirtualEvent procedure: owned by many, last} { bind .b.h <<def>> {lappend x def} set x {} event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.g <Button-2> + event gen .b.g <ButtonRelease-2> event gen .b.h <Button-2> + event gen .b.h <ButtonRelease-2> event delete <<def>> event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.g <Button-2> + event gen .b.g <ButtonRelease-2> event gen .b.h <Button-2> + event gen .b.h <ButtonRelease-2> destroy .b.g destroy .b.h list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>] @@ -1884,9 +1950,9 @@ test bind-22.4 {HandleEventGenerate} { setup bind .b.f <Button> {set x "%s %b"} set x {} - event gen [winfo id .b.f] <Control-Button-1> + event gen [winfo id .b.f] <Control-Button-1> -state 260 set x -} {4 1} +} {260 1} test bind-22.5 {HandleEventGenerate} { list [catch {event gen . <xyz>} msg] $msg } {1 {bad event type or keysym "xyz"}} @@ -1903,7 +1969,11 @@ test bind-22.9 {HandleEventGenerate} { setup bind .b.f <Button> {set x "%s %b"} set x {} + event gen .b.f <ButtonRelease-1> + event gen .b.f <ButtonRelease-2> + event gen .b.f <ButtonRelease-3> event gen .b.f <Control-Button-1> + event gen .b.f <Control-ButtonRelease-1> set x } {4 1} test bind-22.10 {HandleEventGenerate} { @@ -1932,6 +2002,7 @@ test bind-22.13 {HandleEventGenerate} { bind .b.f <Button> {lappend x %#} set x {} event gen .b.f <Button> -when now -serial 100 + event gen .b.f <ButtonRelease> -when now set x } {100} test bind-22.14 {HandleEventGenerate} { @@ -1941,6 +2012,7 @@ test bind-22.14 {HandleEventGenerate} { event gen .b.f <Button> -when head -serial 100 event gen .b.f <Button> -when head -serial 101 event gen .b.f <Button> -when head -serial 102 + event gen .b.f <ButtonRelease> -when tail lappend x foo update set x @@ -1953,6 +2025,7 @@ test bind-22.15 {HandleEventGenerate} { event gen .b.f <Button> -when mark -serial 100 event gen .b.f <Button> -when mark -serial 101 event gen .b.f <Button> -when mark -serial 102 + event gen .b.f <ButtonRelease> -when tail lappend x foo update set x @@ -1965,95 +2038,100 @@ test bind-22.16 {HandleEventGenerate} { event gen .b.f <Button> -when tail -serial 100 event gen .b.f <Button> -when tail -serial 101 event gen .b.f <Button> -when tail -serial 102 + event gen .b.f <ButtonRelease> -when tail lappend x foo update set x } {foo 99 100 101 102} test bind-22.17 {HandleEventGenerate} { list [catch {event gen . <Button> -when xyz} msg] $msg -} {1 {bad position "xyz": should be now, head, mark, tail}} -set i 14 +} {1 {bad -when value "xyz": must be now, head, mark, or tail}} +set i 18 foreach check { {<Configure> %a {-above .xyz} {{1 {bad window path name ".xyz"}}}} {<Configure> %a {-above .b} {[winfo id .b]}} - {<Configure> %a {-above xyz} {{1 {expected integer but got "xyz"}}}} + {<Configure> %a {-above xyz} {{1 {bad window name/identifier "xyz"}}}} {<Configure> %a {-above [winfo id .b]} {[winfo id .b]}} - {<Key> %b {-above .} {{1 {bad option to <Key> event: "-above"}}}} + {<Key> %b {-above .} {{1 {<Key> event doesn't accept "-above" option}}}} {<Configure> %B {-borderwidth xyz} {{1 {bad screen distance "xyz"}}}} {<Configure> %B {-borderwidth 2i} {[winfo pixels .b.f 2i]}} - {<Key> %k {-borderwidth 2i} {{1 {bad option to <Key> event: "-borderwidth"}}}} + {<Key> %k {-borderwidth 2i} {{1 {<Key> event doesn't accept "-borderwidth" option}}}} {<Button> %b {-button xyz} {{1 {expected integer but got "xyz"}}}} {<Button> %b {-button 1} 1} - {<Key> %k {-button 1} {{1 {bad option to <Key> event: "-button"}}}} + {<ButtonRelease> %b {-button 1} 1} + {<Key> %k {-button 1} {{1 {<Key> event doesn't accept "-button" option}}}} {<Expose> %c {-count xyz} {{1 {expected integer but got "xyz"}}}} {<Expose> %c {-count 20} 20} - {<Key> %b {-count 20} {{1 {bad option to <Key> event: "-count"}}}} + {<Key> %b {-count 20} {{1 {<Key> event doesn't accept "-count" option}}}} - {<Enter> %d {-detail xyz} {{1 {bad -detail value "xyz": must be NotifyAncestor, NotifyVirtual, NotifyInferior, NotifyNonlinear, NotifyNonlinearVirtual, NotifyPointer, NotifyPointerRoot, NotifyDetailNone}}}} + {<Enter> %d {-detail xyz} {{1 {bad -detail value "xyz": must be NotifyAncestor, NotifyVirtual, NotifyInferior, NotifyNonlinear, NotifyNonlinearVirtual, NotifyPointer, NotifyPointerRoot, or NotifyDetailNone}}}} {<FocusIn> %d {-detail NotifyVirtual} {{}}} {<Enter> %d {-detail NotifyVirtual} NotifyVirtual} - {<Key> %k {-detail NotifyVirtual} {{1 {bad option to <Key> event: "-detail"}}}} + {<Key> %k {-detail NotifyVirtual} {{1 {<Key> event doesn't accept "-detail" option}}}} {<Enter> %f {-focus xyz} {{1 {expected boolean value but got "xyz"}}}} {<Enter> %f {-focus 1} 1} - {<Key> %k {-focus 1} {{1 {bad option to <Key> event: "-focus"}}}} + {<Key> %k {-focus 1} {{1 {<Key> event doesn't accept "-focus" option}}}} {<Expose> %h {-height xyz} {{1 {bad screen distance "xyz"}}}} {<Expose> %h {-height 2i} {[winfo pixels .b.f 2i]}} {<Configure> %h {-height 2i} {[winfo pixels .b.f 2i]}} - {<Key> %k {-height 2i} {{1 {bad option to <Key> event: "-height"}}}} + {<Key> %k {-height 2i} {{1 {<Key> event doesn't accept "-height" option}}}} {<Key> %k {-keycode xyz} {{1 {expected integer but got "xyz"}}}} {<Key> %k {-keycode 20} 20} - {<Button> %b {-keycode 20} {{1 {bad option to <Button> event: "-keycode"}}}} + {<Button> %b {-keycode 20} {{1 {<Button> event doesn't accept "-keycode" option}}}} {<Key> %K {-keysym xyz} {{1 {unknown keysym "xyz"}}}} {<Key> %K {-keysym a} a} - {<Button> %b {-keysym a} {{1 {bad option to <Button> event: "-keysym"}}}} + {<Button> %b {-keysym a} {{1 {<Button> event doesn't accept "-keysym" option}}}} - {<Enter> %m {-mode xyz} {{1 {bad -mode value "xyz": must be NotifyNormal, NotifyGrab, NotifyUngrab, NotifyWhileGrabbed}}}} + {<Enter> %m {-mode xyz} {{1 {bad -mode value "xyz": must be NotifyNormal, NotifyGrab, NotifyUngrab, or NotifyWhileGrabbed}}}} {<Enter> %m {-mode NotifyNormal} NotifyNormal} {<FocusIn> %m {-mode NotifyNormal} {{}}} - {<Key> %k {-mode NotifyNormal} {{1 {bad option to <Key> event: "-mode"}}}} + {<Key> %k {-mode NotifyNormal} {{1 {<Key> event doesn't accept "-mode" option}}}} {<Map> %o {-override xyz} {{1 {expected boolean value but got "xyz"}}}} {<Map> %o {-override 1} 1} {<Reparent> %o {-override 1} 1} {<Configure> %o {-override 1} 1} - {<Key> %k {-override 1} {{1 {bad option to <Key> event: "-override"}}}} + {<Key> %k {-override 1} {{1 {<Key> event doesn't accept "-override" option}}}} - {<Circulate> %p {-place xyz} {{1 {bad -place value "xyz": must be PlaceOnTop, PlaceOnBottom}}}} + {<Circulate> %p {-place xyz} {{1 {bad -place value "xyz": must be PlaceOnTop, or PlaceOnBottom}}}} {<Circulate> %p {-place PlaceOnTop} PlaceOnTop} - {<Key> %k {-place PlaceOnTop} {{1 {bad option to <Key> event: "-place"}}}} + {<Key> %k {-place PlaceOnTop} {{1 {<Key> event doesn't accept "-place" option}}}} {<Key> %R {-root .xyz} {{1 {bad window path name ".xyz"}}}} {<Key> %R {-root .b} {[winfo id .b]}} - {<Key> %R {-root xyz} {{1 {expected integer but got "xyz"}}}} + {<Key> %R {-root xyz} {{1 {bad window name/identifier "xyz"}}}} {<Key> %R {-root [winfo id .b]} {[winfo id .b]}} {<Button> %R {-root .b} {[winfo id .b]}} + {<ButtonRelease> %R {-root .b} {[winfo id .b]}} {<Motion> %R {-root .b} {[winfo id .b]}} {<<Paste>> %R {-root .b} {[winfo id .b]}} {<Enter> %R {-root .b} {[winfo id .b]}} - {<Configure> %R {-root .b} {{1 {bad option to <Configure> event: "-root"}}}} + {<Configure> %R {-root .b} {{1 {<Configure> event doesn't accept "-root" option}}}} {<Key> %X {-rootx xyz} {{1 {bad screen distance "xyz"}}}} {<Key> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} {<Button> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} + {<ButtonRelease> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} {<Motion> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} {<<Paste>> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} {<Enter> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} - {<Configure> %X {-rootx 2i} {{1 {bad option to <Configure> event: "-rootx"}}}} + {<Configure> %X {-rootx 2i} {{1 {<Configure> event doesn't accept "-rootx" option}}}} {<Key> %Y {-rooty xyz} {{1 {bad screen distance "xyz"}}}} {<Key> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} {<Button> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} + {<ButtonRelease> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} {<Motion> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} {<<Paste>> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} {<Enter> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} - {<Configure> %Y {-rooty 2i} {{1 {bad option to <Configure> event: "-rooty"}}}} + {<Configure> %Y {-rooty 2i} {{1 {<Configure> event doesn't accept "-rooty" option}}}} {<Key> %E {-sendevent xyz} {{1 {expected boolean value but got "xyz"}}}} {<Key> %E {-sendevent 1} 1} @@ -2065,41 +2143,44 @@ foreach check { {<Key> %s {-state xyz} {{1 {expected integer but got "xyz"}}}} {<Key> %s {-state 1} 1} - {<Button> %s {-state 1} 1} + {<Button> %s {-state 1025} 1025} + {<ButtonRelease> %s {-state 1025} 1025} {<Motion> %s {-state 1} 1} {<<Paste>> %s {-state 1} 1} {<Enter> %s {-state 1} 1} - {<Visibility> %s {-state xyz} {{1 {bad -state value "xyz": must be VisibilityUnobscured, VisibilityPartiallyObscured, VisibilityFullyObscured}}}} + {<Visibility> %s {-state xyz} {{1 {bad -state value "xyz": must be VisibilityUnobscured, VisibilityPartiallyObscured, or VisibilityFullyObscured}}}} {<Visibility> %s {-state VisibilityUnobscured} VisibilityUnobscured} - {<Configure> %s {-state xyz} {{1 {bad option to <Configure> event: "-state"}}}} + {<Configure> %s {-state xyz} {{1 {<Configure> event doesn't accept "-state" option}}}} {<Key> %S {-subwindow .xyz} {{1 {bad window path name ".xyz"}}}} {<Key> %S {-subwindow .b} {[winfo id .b]}} - {<Key> %S {-subwindow xyz} {{1 {expected integer but got "xyz"}}}} + {<Key> %S {-subwindow xyz} {{1 {bad window name/identifier "xyz"}}}} {<Key> %S {-subwindow [winfo id .b]} {[winfo id .b]}} {<Button> %S {-subwindow .b} {[winfo id .b]}} + {<ButtonRelease> %S {-subwindow .b} {[winfo id .b]}} {<Motion> %S {-subwindow .b} {[winfo id .b]}} {<<Paste>> %S {-subwindow .b} {[winfo id .b]}} {<Enter> %S {-subwindow .b} {[winfo id .b]}} - {<Configure> %S {-subwindow .b} {{1 {bad option to <Configure> event: "-subwindow"}}}} + {<Configure> %S {-subwindow .b} {{1 {<Configure> event doesn't accept "-subwindow" option}}}} {<Key> %t {-time xyz} {{1 {expected integer but got "xyz"}}}} {<Key> %t {-time 100} 100} {<Button> %t {-time 100} 100} + {<ButtonRelease> %t {-time 100} 100} {<Motion> %t {-time 100} 100} {<<Paste>> %t {-time 100} 100} {<Enter> %t {-time 100} 100} {<Property> %t {-time 100} 100} - {<Configure> %t {-time 100} {{1 {bad option to <Configure> event: "-time"}}}} + {<Configure> %t {-time 100} {{1 {<Configure> event doesn't accept "-time" option}}}} {<Expose> %w {-width xyz} {{1 {bad screen distance "xyz"}}}} {<Expose> %w {-width 2i} {[winfo pixels .b.f 2i]}} {<Configure> %w {-width 2i} {[winfo pixels .b.f 2i]}} - {<Key> %k {-width 2i} {{1 {bad option to <Key> event: "-width"}}}} + {<Key> %k {-width 2i} {{1 {<Key> event doesn't accept "-width" option}}}} {<Unmap> %W {-window .xyz} {{1 {bad window path name ".xyz"}}}} {<Unmap> %W {-window .b.f} .b.f} - {<Unmap> %W {-window xyz} {{1 {expected integer but got "xyz"}}}} + {<Unmap> %W {-window xyz} {{1 {bad window name/identifier "xyz"}}}} {<Unmap> %W {-window [winfo id .b.f]} .b.f} {<Unmap> %W {-window .b.f} .b.f} {<Map> %W {-window .b.f} .b.f} @@ -2107,11 +2188,12 @@ foreach check { {<Configure> %W {-window .b.f} .b.f} {<Gravity> %W {-window .b.f} .b.f} {<Circulate> %W {-window .b.f} .b.f} - {<Key> %W {-window .b.f} {{1 {bad option to <Key> event: "-window"}}}} + {<Key> %W {-window .b.f} {{1 {<Key> event doesn't accept "-window" option}}}} {<Key> %x {-x xyz} {{1 {bad screen distance "xyz"}}}} {<Key> %x {-x 2i} {[winfo pixels .b.f 2i]}} {<Button> %x {-x 2i} {[winfo pixels .b.f 2i]}} + {<ButtonRelease> %x {-x 2i} {[winfo pixels .b.f 2i]}} {<Motion> %x {-x 2i} {[winfo pixels .b.f 2i]}} {<<Paste>> %x {-x 2i} {[winfo pixels .b.f 2i]}} {<Enter> %x {-x 2i} {[winfo pixels .b.f 2i]}} @@ -2119,11 +2201,12 @@ foreach check { {<Configure> %x {-x 2i} {[winfo pixels .b.f 2i]}} {<Gravity> %x {-x 2i} {[winfo pixels .b.f 2i]}} {<Reparent> %x {-x 2i} {[winfo pixels .b.f 2i]}} - {<Map> %x {-x 2i} {{1 {bad option to <Map> event: "-x"}}}} + {<Map> %x {-x 2i} {{1 {<Map> event doesn't accept "-x" option}}}} {<Key> %y {-y xyz} {{1 {bad screen distance "xyz"}}}} {<Key> %y {-y 2i} {[winfo pixels .b.f 2i]}} {<Button> %y {-y 2i} {[winfo pixels .b.f 2i]}} + {<ButtonRelease> %y {-y 2i} {[winfo pixels .b.f 2i]}} {<Motion> %y {-y 2i} {[winfo pixels .b.f 2i]}} {<<Paste>> %y {-y 2i} {[winfo pixels .b.f 2i]}} {<Enter> %y {-y 2i} {[winfo pixels .b.f 2i]}} @@ -2131,9 +2214,9 @@ foreach check { {<Configure> %y {-y 2i} {[winfo pixels .b.f 2i]}} {<Gravity> %y {-y 2i} {[winfo pixels .b.f 2i]}} {<Reparent> %y {-y 2i} {[winfo pixels .b.f 2i]}} - {<Map> %y {-y 2i} {{1 {bad option to <Map> event: "-y"}}}} + {<Map> %y {-y 2i} {{1 {<Map> event doesn't accept "-y" option}}}} - {<Key> %k {-xyz 1} {{1 {bad option to <Key> event: "-xyz"}}}} + {<Key> %k {-xyz 1} {{1 {bad option "-xyz": must be -when, -above, -borderwidth, -button, -count, -delta, -detail, -focus, -height, -keycode, -keysym, -mode, -override, -place, -root, -rootx, -rooty, -sendevent, -serial, -state, -subwindow, -time, -warp, -width, -window, -x, or -y}}}} } { set event [lindex $check 0] test bind-22.$i "HandleEventGenerate: options $event [lindex $check 2]" { @@ -2178,16 +2261,24 @@ test bind-24.5 {FindSequence procedure, multiple bindings} { bind .b.f <1> {lappend x single} bind .b.f <Double-1> {lappend x double} bind .b.f <Triple-1> {lappend x triple} + bind .b.f <Quadruple-1> {lappend x quadruple} set x press event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> lappend x press event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> lappend x press event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> lappend x press event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> + lappend x press + event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> set x -} {press single press double press triple press triple} +} {press single press double press triple press quadruple press quadruple} test bind-24.6 {FindSequence procedure: virtual composed} { list [catch {bind .b <Control-b><<Paste>> "puts hi"} msg] $msg } {1 {virtual events may not be composed}} @@ -2196,7 +2287,9 @@ test bind-24.7 {FindSequence procedure: new pattern sequence} { bind .b.f <Button-1><Button-2> {lappend x 1-2} set x {} event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> set x } {1-2} test bind-24.8 {FindSequence procedure: similar pattern sequence} { @@ -2206,8 +2299,11 @@ test bind-24.8 {FindSequence procedure: similar pattern sequence} { set x {} event gen .b.f <Button-3> event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> set x } {2 1-2} test bind-24.9 {FindSequence procedure: similar pattern sequence} { @@ -2217,9 +2313,13 @@ test bind-24.9 {FindSequence procedure: similar pattern sequence} { set x {} event gen .b.f <Button-3> event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> set x } {2-2 1-2} test bind-24.10 {FindSequence procedure: similar pattern sequence} { @@ -2229,10 +2329,15 @@ test bind-24.10 {FindSequence procedure: similar pattern sequence} { set x {} event gen .b.f <Button-3> event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Button-2> + event gen .b.f <ButtonRelease-2> event gen .b.f <Button-1> + event gen .b.f <ButtonRelease-1> event gen .b.f <Button-2> -x 100 + event gen .b.f <ButtonRelease-2> event gen .b.f <Button-2> -x 200 + event gen .b.f <ButtonRelease-2> set x } {d-2 2-2} test bind-24.11 {FindSequence procedure: new sequence, don't create} { @@ -2244,7 +2349,17 @@ test bind-24.12 {FindSequence procedure: not new sequence, don't create} { bind .b.f <Control-Button-2> "foo" bind .b.f <Button-2> } {} - +test bind-24.13 {FindSequence procedure: no binding} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + list [catch {bind .b.f <a>} msg] $msg +} {0 {}} +test bind-24.14 {FindSequence procedure: no binding} { + catch {destroy .b.f} + canvas .b.f + set i [.b.f create rect 10 10 100 100] + list [catch {.b.f bind $i <a>} msg] $msg +} {0 {}} test bind-25.1 {ParseEventDescription procedure} { list [catch {bind .b \x7 test} msg] $msg @@ -2442,6 +2557,7 @@ foreach button {1 2 3 4 5} { bind .b.f <Button-$button> "lappend x \"button $button\"" set x [bind .b.f] event gen .b.f <Button-$button> + event gen .b.f <ButtonRelease-$button> set x } [list <Button-$button> "button $button"] incr i @@ -2511,6 +2627,7 @@ test bind-30.1 {Tk_BackgroundError procedure} { bind .b.f <Button> {error "This is a test"} set x none event gen .b.f <Button> + event gen .b.f <ButtonRelease> update set x } {{This is a test} {This is a test @@ -2520,6 +2637,7 @@ test bind-30.1 {Tk_BackgroundError procedure} { test bind-30.2 {Tk_BackgroundError procedure} { proc do {} { event gen .b.f <Button> + event gen .b.f <ButtonRelease> } setup bind .b.f <Button> {error Message2} @@ -2557,3 +2675,20 @@ test bind-31.2 {MouseWheel events} { destroy .b + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/bitmap.test b/tk/tests/bitmap.test new file mode 100644 index 00000000000..d91223938bf --- /dev/null +++ b/tk/tests/bitmap.test @@ -0,0 +1,116 @@ +# This file is a Tcl script to test out the procedures in the file +# 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. +# All rights reserved. +# +# RCS: @(#) $Id$ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {[info commands testbitmap] != "testbitmap"} { + puts "testbitmap command not available; skipping tests" + ::tcltest::cleanupTests + return +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + +test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} { + set x gray25 + lindex $x 0 + destroy .b1 + button .b1 -bitmap $x + lindex $x 0 + testbitmap gray25 +} {{1 0}} +test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} { + set x gray25 + destroy .b1 .b2 + button .b1 -bitmap $x + destroy .b1 + set result {} + lappend result [testbitmap gray25] + button .b2 -bitmap $x + lappend result [testbitmap gray25] +} {{} {{1 1}}} +test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} { + set x gray25 + destroy .b1 .b2 + button .b1 -bitmap $x + set result {} + lappend result [testbitmap gray25] + button .b2 -bitmap $x + pack .b1 .b2 -side top + lappend result [testbitmap gray25] +} {{{1 1}} {{2 1}}} + +test bitmap-2.1 {Tk_GetBitmap procedure} { + destroy .b1 + list [catch {button .b1 -bitmap bad_name} msg] $msg +} {1 {bitmap "bad_name" not defined}} +test bitmap-2.2 {Tk_GetBitmap procedure} { + destroy .b1 + list [catch {button .b1 -bitmap @xyzzy} msg] $msg +} {1 {error reading bitmap file "xyzzy"}} + +test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} { + set x questhead + destroy .b1 .b2 .b3 + button .b1 -bitmap $x + button .b3 -bitmap $x + button .b2 -bitmap $x + set result {} + lappend result [testbitmap questhead] + destroy .b1 + lappend result [testbitmap questhead] + destroy .b2 + lappend result [testbitmap questhead] + destroy .b3 + lappend result [testbitmap questhead] +} {{{3 1}} {{2 1}} {{1 1}} {}} + +test bitmap-4.1 {FreeBitmapObjProc} { + destroy .b + set x [format questhead] + button .b -bitmap $x + set y [format questhead] + .b configure -bitmap $y + set z [format questhead] + .b configure -bitmap $z + set result {} + lappend result [testbitmap questhead] + set x red + lappend result [testbitmap questhead] + set z 32 + lappend result [testbitmap questhead] + destroy .b + lappend result [testbitmap questhead] + set y bogus + set result +} {{{1 3}} {{1 2}} {{1 1}} {}} + +destroy .t + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/border.test b/tk/tests/border.test new file mode 100644 index 00000000000..483e44d36ef --- /dev/null +++ b/tk/tests/border.test @@ -0,0 +1,195 @@ +# 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. +# All rights reserved. +# +# RCS: @(#) $Id$ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {[info commands testborder] != "testborder"} { + puts "testborder command not available; skipping tests" + ::tcltest::cleanupTests + return +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + +# Create a top-level with its own colormap (so we can test under +# controlled conditions), then check to make sure that the visual +# is color-mapped with 256 borders. If not, just skip this whole +# test file. + +if [catch {toplevel .t -visual {pseudocolor 8} -colormap new}] { + ::tcltest::cleanupTests + return +} +wm geom .t +0+0 +if {[winfo depth .t] != 8} { + destroy .t + ::tcltest::cleanupTests + return +} + +test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} { + set x orange + lindex $x 0 + destroy .b1 + button .b1 -bg $x -text .b1 + lindex $x 0 + testborder orange +} {{1 0}} +test border-1.3 {Tk_AllocBorderFromObj - discard stale border} { + set x orange + destroy .b1 .b2 + button .b1 -bg $x -text First + destroy .b1 + set result {} + lappend result [testborder orange] + button .b2 -bg $x -text Second + lappend result [testborder orange] +} {{} {{1 1}}} +test border-1.2 {Tk_AllocBorderFromObj - reuse existing border} { + set x orange + destroy .b1 .b2 + button .b1 -bg $x -text First + set result {} + lappend result [testborder orange] + button .b2 -bg $x -text Second + pack .b1 .b2 -side top + lappend result [testborder orange] +} {{{1 1}} {{2 1}}} +test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} { + set x purple + destroy .b1 .b2 .t.b + button .b1 -bg $x -text First + pack .b1 -side top + set result {} + lappend result [testborder purple] + button .t.b -bg $x -text Second + pack .t.b -side top + lappend result [testborder purple] + button .b2 -bg $x -text Third + pack .b2 -side top + lappend result [testborder purple] +} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}} + +test border-3.1 {Tk_Free3DBorder - reference counts} { + set x purple + destroy .b1 .b2 .t.b + button .b1 -bg $x -text First + pack .b1 -side top + button .t.b -bg $x -text Second + pack .t.b -side top + button .b2 -bg $x -text Third + pack .b2 -side top + set result {} + lappend result [testborder purple] + destroy .b1 + lappend result [testborder purple] + destroy .b2 + lappend result [testborder purple] + destroy .t.b + lappend result [testborder purple] +} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}} +test border-3.4 {Tk_Free3DBorder - unlinking from list} { + destroy .b .t.b .t2 .t3 + toplevel .t2 -visual {pseudocolor 8} -colormap new + toplevel .t3 -visual {pseudocolor 8} -colormap new + set x purple + button .b -bg $x -text .b1 + button .t.b1 -bg $x -text .t.b1 + button .t.b2 -bg $x -text .t.b2 + button .t2.b1 -bg $x -text .t2.b1 + button .t2.b2 -bg $x -text .t2.b2 + button .t2.b3 -bg $x -text .t2.b3 + button .t3.b1 -bg $x -text .t3.b1 + button .t3.b2 -bg $x -text .t3.b2 + button .t3.b3 -bg $x -text .t3.b3 + button .t3.b4 -bg $x -text .t3.b4 + set result {} + lappend result [testborder purple] + destroy .t2 + lappend result [testborder purple] + destroy .b + lappend result [testborder purple] + destroy .t3 + lappend result [testborder purple] + destroy .t + lappend result [testborder purple] +} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}} + +test border-4.1 {FreeBorderObjProc} { + destroy .b + set x [format purple] + button .b -bg $x -text .b1 + set y [format purple] + .b configure -bg $y + set z [format purple] + .b configure -bg $z + set result {} + lappend result [testborder purple] + set x red + lappend result [testborder purple] + set z 32 + lappend result [testborder purple] + destroy .b + lappend result [testborder purple] + set y bogus + set result +} {{{1 3}} {{1 2}} {{1 1}} {}} + +catch {destroy .b} +button .b +test get-2.1 {Tk_GetReliefFromObj} { + .b configure -relief flat + .b cget -relief +} {flat} +test get-2.2 {Tk_GetReliefFromObj} { + .b configure -relief groove + .b cget -relief +} {groove} +test get-2.3 {Tk_GetReliefFromObj} { + .b configure -relief raised + .b cget -relief +} {raised} +test get-2.3 {Tk_GetReliefFromObj} { + .b configure -relief ridge + .b cget -relief +} {ridge} +test get-2.3 {Tk_GetReliefFromObj} { + .b configure -relief solid + .b cget -relief +} {solid} +test get-2.3 {Tk_GetReliefFromObj} { + .b configure -relief sunken + .b cget -relief +} {sunken} +test get-2.4 {Tk_GetReliefFromObj - error} { + list [catch {.b configure -relief upanddown} msg] $msg +} {1 {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}} + +destroy .t + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/bugs.tcl b/tk/tests/bugs.tcl index b03dd02eff6..36f30ce701f 100644 --- a/tk/tests/bugs.tcl +++ b/tk/tests/bugs.tcl @@ -28,3 +28,16 @@ test crash-1.1 {color} { . configure -bg rgb:345 set foo "" } {} + + + + + + + + + + + + + diff --git a/tk/tests/butGeom.tcl b/tk/tests/butGeom.tcl index 9d82980764c..38991e30cdd 100644 --- a/tk/tests/butGeom.tcl +++ b/tk/tests/butGeom.tcl @@ -113,3 +113,16 @@ proc config {option value} { $w configure $option $value } } + + + + + + + + + + + + + diff --git a/tk/tests/butGeom2.tcl b/tk/tests/butGeom2.tcl index f1a074a04f8..65e90fae734 100644 --- a/tk/tests/butGeom2.tcl +++ b/tk/tests/butGeom2.tcl @@ -111,3 +111,16 @@ proc config-but {option value} { $w configure $option $value } } + + + + + + + + + + + + + diff --git a/tk/tests/button.test b/tk/tests/button.test index 2d44d5dc54d..df4d883971e 100644 --- a/tk/tests/button.test +++ b/tk/tests/button.test @@ -4,23 +4,23 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\"" puts "image, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[info procs test] != "test"} { - source defs -} - foreach i [winfo children .] { destroy $i } @@ -51,255 +51,216 @@ update set i 1 foreach test { {-activebackground #012345 #012345 non-existent - {unknown color name "non-existent"}} + {unknown color name "non-existent"} {1 1 1 1}} {-activeforeground #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-anchor nw nw bogus {bad anchor position "bogus": must be n, ne, e, se, s, sw, w, nw, or center}} + {unknown color name "non-existent"} {1 1 1 1}} + {-anchor nw nw bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center} {1 1 1 1}} {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bitmap questhead questhead badValue {bitmap "badValue" not defined}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-command "set x" {set x} {} {}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}} - {-fg #110022 #110022 bogus {unknown color name "bogus"}} - {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}} - {-foreground #110022 #110022 bogus {unknown color name "bogus"}} - {-height 18 18 20.0 {expected integer but got "20.0"}} - {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} - {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}} - {-highlightthickness 18 18 badValue {bad screen distance "badValue"}} - {-image image1 image1 bogus {image "bogus" doesn't exist}} - {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}} - {-justify right right bogus {bad justification "bogus": must be left, right, or center}} - {-offvalue lousy lousy {} {}} - {-offvalue fantastic fantastic {} {}} - {-padx 12 12 420x {bad screen distance "420x"}} - {-pady 12 12 420x {bad screen distance "420x"}} - {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - {-selectcolor #110022 #110022 bogus {unknown color name "bogus"}} - {-selectimage image1 image1 bogus {image "bogus" doesn't exist}} - {-state normal normal bogus {bad state value "bogus": must be normal, active, or disabled}} - {-takefocus "any string" "any string" {} {}} - {-text "Sample text" {Sample text} {} {}} - {-textvariable i i {} {}} - {-underline 5 5 3p {expected integer but got "3p"}} - {-width 402 402 3p {expected integer but got "3p"}} - {-wraplength 100 100 6x {bad screen distance "6x"}} + {unknown color name "non-existent"} {1 1 1 1}} + {-bd 4 4 badValue {bad screen distance "badValue"} {1 1 1 1}} + {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"} + {1 1 1 1}} + {-bitmap questhead questhead badValue {bitmap "badValue" not defined} + {1 1 1 1}} + {-borderwidth 1.3 1.3 badValue {bad screen distance "badValue"} {1 1 1 1}} + {-command "set x" {set x} {} {} {0 1 1 1}} + {-cursor arrow arrow badValue {bad cursor spec "badValue"} {1 1 1 1}} + {-default active active huh? + {bad default "huh?": must be active, disabled, or normal} + {0 1 0 0}} + {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"} + {1 1 1 1}} + {-fg #110022 #110022 bogus {unknown color name "bogus"} {1 1 1 1}} + {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist} {1 1 1 1}} + {-foreground #110022 #110022 bogus {unknown color name "bogus"} {1 1 1 1}} + {-height 18 18 20.0 {expected integer but got "20.0"} {1 1 1 1}} + {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"} + {1 1 1 1}} + {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"} + {1 1 1 1}} + {-highlightthickness 6m 6m badValue {bad screen distance "badValue"} + {1 1 1 1}} + {-image image1 image1 bogus {image "bogus" doesn't exist} {1 1 1 1}} + {-indicatoron yes 1 no_way {expected boolean value but got "no_way"} + {0 0 1 1}} + {-justify right right bogus {bad justification "bogus": must be left, right, or center} {1 1 1 1}} + {-offvalue lousy lousy {} {} {0 0 1 0}} + {-offvalue fantastic fantastic {} {} {0 0 1 0}} + {-padx 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}} + {-pady 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}} + {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} {1 1 1 1}} + {-selectcolor #110022 #110022 bogus {unknown color name "bogus"} {0 0 1 1}} + {-selectimage image1 image1 bogus {image "bogus" doesn't exist} {0 0 1 1}} + {-state normal normal bogus {bad state "bogus": must be active, disabled, or normal} {1 1 1 1}} + {-takefocus "any string" "any string" {} {} {1 1 1 1}} + {-text "Sample text" {Sample text} {} {} {1 1 1 1}} + {-textvariable i i {} {} {1 1 1 1}} + {-underline 5 5 3p {expected integer but got "3p"} {1 1 1 1}} + {-value anyString anyString {} {} {0 0 0 1}} + {-width 402 402 3p {expected integer but got "3p"} {1 1 1 1}} + {-wraplength 100 100 6x {bad screen distance "6x"} {1 1 1 1}} } { set name [lindex $test 0] - test button-1.$i {configuration options} { - .c configure $name [lindex $test 1] - lindex [.c configure $name] 4 - } [lindex $test 2] - incr i - if {[lindex $test 3] != ""} { - test button-1.$i {configuration options} { - list [catch {.c configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] + set classes [lindex $test 5] + foreach w {.l .b .c .r} hasOption [lindex $test 5] { + if $hasOption { + test button-1.$i {configuration options} { + $w configure $name [lindex $test 1] + lindex [$w configure $name] 4 + } [lindex $test 2] + incr i + if {[lindex $test 3] != ""} { + test button-1.$i {configuration options} { + list [catch {$w configure $name [lindex $test 3]} msg] $msg + } [list 1 [lindex $test 4]] + } + $w configure $name [lindex [$w configure $name] 3] + } else { + test button-1.$i {configuration options} { + list [catch {$w configure $name [lindex $test 1]} msg] $msg + } "1 {unknown option \"$name\"}" + } } - .c configure $name [lindex [.c configure $name] 3] incr i } test button-1.$i {configuration options} { .c configure -selectcolor {} } {} -incr i -# the following tests only work on buttons, not checkbuttons -test button-1.$i {configuration options} { - .b configure -default active - lindex [.b configure -default] 4 -} active -incr i -test button-1.$i {configuration options} { - .b configure -default normal - lindex [.b configure -default] 4 -} normal -incr i -test button-1.$i {configuration options} { - .b configure -default disabled - lindex [.b configure -default] 4 -} disabled -incr i -test button-1.$i {configuration options} { - .b configure -default active - lindex [.b configure -default] 3 -} disabled -incr i -test button-1.$i {configuration options} { - list [catch {.b configure -default no_way} msg] $msg -} {1 {bad -default value "no_way": must be normal, active, or disabled}} -set i 1 -foreach check { - {-activebackground 1 0 0 0} - {-activeforeground 1 0 0 0} - {-anchor 0 0 0 0} - {-background 0 0 0 0} - {-bd 0 0 0 0} - {-bg 0 0 0 0} - {-bitmap 0 0 0 0} - {-borderwidth 0 0 0 0} - {-command 1 0 0 0} - {-cursor 0 0 0 0} - {-default 1 0 1 1} - {-disabledforeground 1 0 0 0} - {-fg 0 0 0 0} - {-font 0 0 0 0} - {-foreground 0 0 0 0} - {-height 0 0 0 0} - {-image 0 0 0 0} - {-indicatoron 1 1 0 0} - {-offvalue 1 1 0 1} - {-onvalue 1 1 0 1} - {-padx 0 0 0 0} - {-pady 0 0 0 0} - {-relief 0 0 0 0} - {-selectcolor 1 1 0 0} - {-selectimage 1 1 0 0} - {-state 1 0 0 0} - {-text 0 0 0 0} - {-textvariable 0 0 0 0} - {-value 1 1 1 0} - {-variable 1 1 0 0} - {-width 0 0 0 0} +test button-3.1 {ButtonCreate - not enough cd ../unix } { - test button-2.$i {label-specific options} " - catch {.l configure [lindex $check 0]} - " [lindex $check 1] - incr i - test button-2.$i {button-specific options} " - catch {.b configure [lindex $check 0]} - " [lindex $check 2] - incr i - test button-2.$i {checkbutton-specific options} " - catch {.c configure [lindex $check 0]} - " [lindex $check 3] - incr i - test button-2.$i {radiobutton-specific options} " - catch {.r configure [lindex $check 0]} - " [lindex $check 4] - incr i -} - -test button-3.1 {ButtonCreate procedure} { list [catch {button} msg] $msg } {1 {wrong # args: should be "button pathName ?options?"}} -test button-3.2 {ButtonCreate procedure} { +test button-3.2 {ButtonCreate procedure - setting label class} { catch {destroy .x} label .x winfo class .x } {Label} -test button-3.3 {ButtonCreate procedure} { +test button-3.3 {ButtonCreate - setting button class} { catch {destroy .x} button .x winfo class .x } {Button} -test button-3.4 {ButtonCreate procedure} { +test button-3.4 {ButtonCreate - setting checkbutton class} { catch {destroy .x} checkbutton .x winfo class .x } {Checkbutton} -test button-3.5 {ButtonCreate procedure} { +test button-3.5 {ButtonCreate - setting radiobutton class} { catch {destroy .x} radiobutton .x winfo class .x } {Radiobutton} rename button gorp -test button-3.6 {ButtonCreate procedure} { +test button-3.6 {ButtonCreate - setting class} { catch {destroy .x} gorp .x winfo class .x } {Button} rename gorp button -test button-3.7 {ButtonCreate procedure} { +test button-3.7 {ButtonCreate - bad window name} { list [catch {button foo} msg] $msg } {1 {bad window path name "foo"}} -test button-3.8 {ButtonCreate procedure} { +test button-3.8 {ButtonCreate procedure - error in default option value} { + catch {destroy .funny} + option add *funny.background bogus + list [catch {button .funny} msg] $msg $errorInfo +} {1 {unknown color name "bogus"} {unknown color name "bogus" + (database entry for "-background" in widget ".funny") + invoked from within +"button .funny"}} +test button-3.9 {ButtonCreate procedure - option error} { catch {destroy .x} list [catch {button .x -gorp foo} msg] $msg [winfo exists .x] } {1 {unknown option "-gorp"} 0} +test button-3.10 {ButtonCreate procedure - return value} { + catch {destroy .abcd} + set x [button .abcd] + destroy .abc + set x +} {.abcd} -test button-4.1 {ButtonWidgetCmd procedure} { +test button-4.1 {ButtonWidgetCmd - too few arguments} { list [catch {.b} msg] $msg } {1 {wrong # args: should be ".b option ?arg arg ...?"}} -test button-4.2 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.2 {ButtonWidgetCmd - bad option name} { list [catch {.b c} msg] $msg -} {1 {bad option "c": must be cget, configure, flash, or invoke}} -test button-4.3 {ButtonWidgetCmd procedure, "cget" option} { +} {1 {ambiguous option "c": must be cget, configure, flash, or invoke}} +test button-4.3 {ButtonWidgetCmd - bad option name} { + list [catch {.b bogus} msg] $msg +} {1 {bad option "bogus": must be cget, configure, flash, or invoke}} +test button-4.4 {ButtonWidgetCmd procedure, "cget" option} { list [catch {.b cget a b} msg] $msg } {1 {wrong # args: should be ".b cget option"}} -test button-4.4 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.5 {ButtonWidgetCmd procedure, "cget" option} { list [catch {.b cget -gorp} msg] $msg } {1 {unknown option "-gorp"}} -test button-4.5 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.6 {ButtonWidgetCmd procedure, "cget" option} { .b configure -highlightthickness 3 .b cget -highlightthickness } {3} -test button-4.6 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.l cget -disabledforeground} msg] $msg -} {1 {unknown option "-disabledforeground"}} test button-4.7 {ButtonWidgetCmd procedure, "cget" option} { - catch {.b cget -disabledforeground} + catch {.l cget -disabledforeground} } {0} test button-4.8 {ButtonWidgetCmd procedure, "cget" option} { + catch {.b cget -disabledforeground} +} {0} +test button-4.9 {ButtonWidgetCmd procedure, "cget" option} { list [catch {.b cget -variable} msg] $msg } {1 {unknown option "-variable"}} -test button-4.9 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.10 {ButtonWidgetCmd procedure, "cget" option} { catch {.c cget -variable} } {0} -test button-4.10 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.11 {ButtonWidgetCmd procedure, "cget" option} { list [catch {.c cget -value} msg] $msg } {1 {unknown option "-value"}} -test button-4.11 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.12 {ButtonWidgetCmd procedure, "cget" option} { catch {.r cget -value} } {0} -test button-4.12 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.13 {ButtonWidgetCmd procedure, "cget" option} { list [catch {.r cget -onvalue} msg] $msg } {1 {unknown option "-onvalue"}} -test button-4.13 {ButtonWidgetCmd procedure, "configure" option} { +test button-4.14 {ButtonWidgetCmd procedure, "configure" option} { llength [.c configure] } {36} -test button-4.14 {ButtonWidgetCmd procedure, "configure" option} { +test button-4.15 {ButtonWidgetCmd procedure, "configure" option} { list [catch {.b configure -gorp} msg] $msg } {1 {unknown option "-gorp"}} -test button-4.15 {ButtonWidgetCmd procedure, "configure" option} { +test button-4.16 {ButtonWidgetCmd procedure, "configure" option} { list [catch {.b co -bg #ffffff -fg} msg] $msg } {1 {value for "-fg" missing}} -test button-4.16 {ButtonWidgetCmd procedure, "configure" option} { +test button-4.17 {ButtonWidgetCmd procedure, "configure" option} { .b configure -fg #123456 .b configure -bg #654321 lindex [.b configure -fg] 4 } {#123456} .c configure -variable value -onvalue 1 -offvalue 0 .r configure -variable value2 -value red -test button-4.17 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.18 {ButtonWidgetCmd procedure, "deselect" option} { list [catch {.c deselect foo} msg] $msg } {1 {wrong # args: should be ".c deselect"}} -test button-4.18 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.19 {ButtonWidgetCmd procedure, "deselect" option} { list [catch {.l deselect} msg] $msg } {1 {bad option "deselect": must be cget or configure}} -test button-4.19 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.20 {ButtonWidgetCmd procedure, "deselect" option} { list [catch {.b deselect} msg] $msg } {1 {bad option "deselect": must be cget, configure, flash, or invoke}} -test button-4.20 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.21 {ButtonWidgetCmd procedure, "deselect" option} { set value 1 .c d set value } {0} -test button-4.21 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.22 {ButtonWidgetCmd procedure, "deselect" option} { set value2 green .r deselect set value2 } {green} -test button-4.22 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} { set value2 red .r deselect set value2 } {} -test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} { set value 1 trace variable value w bogusTrace set result [list [catch {.c deselect} msg] $msg $errorInfo $value] @@ -308,7 +269,7 @@ test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} { } {1 {can't set "value": trace aborted} {can't set "value": trace aborted while executing ".c deselect"} 0} -test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.25 {ButtonWidgetCmd procedure, "deselect" option} { set value2 red trace variable value2 w bogusTrace set result [list [catch {.r deselect} msg] $msg $errorInfo $value2] @@ -317,40 +278,40 @@ test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} { } {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted while executing ".r deselect"} {}} -test button-4.25 {ButtonWidgetCmd procedure, "flash" option} { +test button-4.26 {ButtonWidgetCmd procedure, "flash" option} { list [catch {.b flash foo} msg] $msg } {1 {wrong # args: should be ".b flash"}} -test button-4.26 {ButtonWidgetCmd procedure, "flash" option} { +test button-4.27 {ButtonWidgetCmd procedure, "flash" option} { list [catch {.l flash} msg] $msg } {1 {bad option "flash": must be cget or configure}} -test button-4.27 {ButtonWidgetCmd procedure, "flash" option} { +test button-4.28 {ButtonWidgetCmd procedure, "flash" option} { list [catch {.b flash} msg] $msg } {0 {}} -test button-4.28 {ButtonWidgetCmd procedure, "flash" option} { +test button-4.29 {ButtonWidgetCmd procedure, "flash" option} { list [catch {.c flash} msg] $msg } {0 {}} -test button-4.29 {ButtonWidgetCmd procedure, "flash" option} { +test button-4.30 {ButtonWidgetCmd procedure, "flash" option} { list [catch {.r f} msg] $msg } {0 {}} -test button-4.30 {ButtonWidgetCmd procedure, "invoke" option} { +test button-4.31 {ButtonWidgetCmd procedure, "invoke" option} { list [catch {.b invoke foo} msg] $msg } {1 {wrong # args: should be ".b invoke"}} -test button-4.31 {ButtonWidgetCmd procedure, "invoke" option} { +test button-4.32 {ButtonWidgetCmd procedure, "invoke" option} { list [catch {.l invoke} msg] $msg } {1 {bad option "invoke": must be cget or configure}} -test button-4.32 {ButtonWidgetCmd procedure, "invoke" option} { +test button-4.33 {ButtonWidgetCmd procedure, "invoke" option} { .b configure -command {set x invoked} set x "not invoked" .b invoke set x } {invoked} -test button-4.33 {ButtonWidgetCmd procedure, "invoke" option} { +test button-4.34 {ButtonWidgetCmd procedure, "invoke" option} { .b configure -command {set x invoked} -state disabled set x "not invoked" .b invoke set x } {not invoked} -test button-4.34 {ButtonWidgetCmd procedure, "invoke" option} { +test button-4.35 {ButtonWidgetCmd procedure, "invoke" option} { set value bogus .c configure -command {set x invoked} -variable value -onvalue 1 \ -offvalue 0 @@ -358,35 +319,35 @@ test button-4.34 {ButtonWidgetCmd procedure, "invoke" option} { .c invoke list $x $value } {invoked 1} -test button-4.35 {ButtonWidgetCmd procedure, "invoke" option} { +test button-4.36 {ButtonWidgetCmd procedure, "invoke" option} { set value2 green .r configure -command {set x invoked} -variable value2 -value red set x "not invoked" .r i list $x $value2 } {invoked red} -test button-4.36 {ButtonWidgetCmd procedure, "select" option} { +test button-4.37 {ButtonWidgetCmd procedure, "select" option} { list [catch {.l select} msg] $msg } {1 {bad option "select": must be cget or configure}} -test button-4.37 {ButtonWidgetCmd procedure, "select" option} { +test button-4.38 {ButtonWidgetCmd procedure, "select" option} { list [catch {.b select} msg] $msg } {1 {bad option "select": must be cget, configure, flash, or invoke}} -test button-4.38 {ButtonWidgetCmd procedure, "select" option} { +test button-4.39 {ButtonWidgetCmd procedure, "select" option} { list [catch {.c select foo} msg] $msg } {1 {wrong # args: should be ".c select"}} -test button-4.39 {ButtonWidgetCmd procedure, "select" option} { +test button-4.40 {ButtonWidgetCmd procedure, "select" option} { set value bogus .c configure -command {} -variable value -onvalue lovely -offvalue 0 .c s set value } {lovely} -test button-4.40 {ButtonWidgetCmd procedure, "select" option} { +test button-4.41 {ButtonWidgetCmd procedure, "select" option} { set value2 green .r configure -command {} -variable value2 -value red .r select set value2 } {red} -test button-4.41 {ButtonWidgetCmd procedure, "select" option} { +test button-4.42 {ButtonWidgetCmd procedure, "select" option} { set value2 yellow trace variable value2 w bogusTrace set result [list [catch {.r select} msg] $msg $errorInfo $value2] @@ -395,19 +356,19 @@ test button-4.41 {ButtonWidgetCmd procedure, "select" option} { } {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted while executing ".r select"} red} -test button-4.42 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.43 {ButtonWidgetCmd procedure, "toggle" option} { list [catch {.l toggle} msg] $msg } {1 {bad option "toggle": must be cget or configure}} -test button-4.43 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.44 {ButtonWidgetCmd procedure, "toggle" option} { list [catch {.b toggle} msg] $msg } {1 {bad option "toggle": must be cget, configure, flash, or invoke}} -test button-4.44 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.45 {ButtonWidgetCmd procedure, "toggle" option} { list [catch {.r toggle} msg] $msg } {1 {bad option "toggle": must be cget, configure, deselect, flash, invoke, or select}} -test button-4.45 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.46 {ButtonWidgetCmd procedure, "toggle" option} { list [catch {.c toggle foo} msg] $msg } {1 {wrong # args: should be ".c toggle"}} -test button-4.46 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.47 {ButtonWidgetCmd procedure, "toggle" option} { set value bogus .c configure -command {} -variable value -onvalue sunshine -offvalue rain .c toggle @@ -417,7 +378,7 @@ test button-4.46 {ButtonWidgetCmd procedure, "toggle" option} { .c toggle lappend result $value } {sunshine rain sunshine} -test button-4.47 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} { .c configure -onvalue xyz -offvalue abc set value xyz trace variable value w bogusTrace @@ -427,7 +388,7 @@ test button-4.47 {ButtonWidgetCmd procedure, "toggle" option} { } {1 {can't set "value": trace aborted} {can't set "value": trace aborted while executing ".c toggle"} abc} -test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.49 {ButtonWidgetCmd procedure, "toggle" option} { .c configure -onvalue xyz -offvalue abc set value abc trace variable value w bogusTrace @@ -437,9 +398,6 @@ test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} { } {1 {can't set "value": trace aborted} {can't set "value": trace aborted while executing ".c toggle"} xyz} -test button-4.49 {ButtonWidgetCmd procedure} { - list [catch {.c bad_option} msg] $msg -} {1 {bad option "bad_option": must be cget, configure, deselect, flash, invoke, select, or toggle}} test button-4.50 {ButtonWidgetCmd procedure, "toggle" option} { catch {unset value}; set value(1) 1; set result [list [catch {.c toggle} msg] $msg $errorInfo] @@ -462,7 +420,14 @@ test button-5.1 {DestroyButton procedure} { eval destroy [winfo children .] } {} -test button-6.1 {ConfigureButton procedure} { +test button-6.1 {ConfigureButton - textvariable trace} { + catch {destroy .b1} + button .b1 -bd 4 -bg green + catch {.b1 configure -bd 7 -bg green -fg bogus} + list [catch {.b1 configure -bd 7 -bg red -fg bogus} msg] \ + $msg [.b1 cget -bd] [.b1 cget -bg] +} {1 {unknown color name "bogus"} 4 green} +test button-6.2 {ConfigureButton - textvariable trace} { catch {destroy .b1} set x From-x set y From-y @@ -471,7 +436,7 @@ test button-6.1 {ConfigureButton procedure} { set x New lindex [.b1 configure -text] 4 } {From-y} -test button-6.2 {ConfigureButton procedure} { +test button-6.2 {ConfigureButton - variable traces} { catch {destroy .b1} catch {unset x} checkbutton .b1 -variable x @@ -482,7 +447,7 @@ test button-6.2 {ConfigureButton procedure} { .b1 toggle set y } {1} -test button-6.3 {ConfigureButton procedure} { +test button-6.3 {ConfigureButton - image handling} { catch {destroy .b1} eval image delete [image names] image create test image1 @@ -492,18 +457,12 @@ test button-6.3 {ConfigureButton procedure} { .b1 configure -image image2 image names } {image2} -test button-6.4 {ConfigureButton procedure} { - catch {destroy .b1} - button .b1 -text "Test" -state disabled - list [catch {.b1 configure -state bogus} msg] $msg \ - [lindex [.b1 configure -state] 4] -} {1 {bad state value "bogus": must be normal, active, or disabled} normal} -test button-6.5 {ConfigureButton procedure} { +test button-6.5 {ConfigureButton - default value for variable} { catch {destroy .b1} checkbutton .b1 .b1 cget -variable } {b1} -test button-6.6 {ConfigureButton procedure} { +test button-6.6 {ConfigureButton - setting selected state from variable} { catch {destroy .b1} set x 0 set y Shiny @@ -512,19 +471,19 @@ test button-6.6 {ConfigureButton procedure} { .b1 toggle set y } 0 -test button-6.7 {ConfigureButton procedure} { +test button-6.7 {ConfigureButton - setting selected state from variable} { catch {destroy .b1} catch {unset x} checkbutton .b1 -variable x -offvalue Bogus set x } Bogus -test button-6.8 {ConfigureButton procedure} { +test button-6.8 {ConfigureButton - setting selected state from variable} { catch {destroy .b1} catch {unset x} radiobutton .b1 -variable x set x } {} -test button-6.9 {ConfigureButton procedure} { +test button-6.9 {ConfigureButton - error in setting variable} { catch {destroy .b1} catch {unset x} trace variable x w bogusTrace @@ -532,23 +491,23 @@ test button-6.9 {ConfigureButton procedure} { trace vdelete x w bogusTrace set result } {1 {can't set "x": trace aborted}} -test button-6.10 {ConfigureButton procedure} { +test button-6.10 {ConfigureButton - bad image name} { catch {destroy .b1} list [catch {button .b1 -image bogus} msg] $msg } {1 {image "bogus" doesn't exist}} -test button-6.11 {ConfigureButton procedure} { +test button-6.11 {ConfigureButton - setting variable from current text value} { catch {destroy .b1} catch {unset x} button .b1 -textvariable x -text "Button 1" set x } {Button 1} -test button-6.12 {ConfigureButton procedure} { +test button-6.12 {ConfigureButton - using current value of variable} { catch {destroy .b1} set x Override button .b1 -textvariable x -text "Button 1" set x } {Override} -test button-6.13 {ConfigureButton procedure} { +test button-6.13 {ConfigureButton - variable handling} { catch {destroy .b1} catch {unset x} trace variable x w bogusTrace @@ -557,7 +516,7 @@ test button-6.13 {ConfigureButton procedure} { trace vdelete x w bogusTrace set result } {1 {can't set "x": trace aborted} foo} -test button-6.14 {ConfigureButton procedure} { +test button-6.14 {ConfigureButton - -width option} { catch {destroy .b1} button .b1 -text "Button 1" list [catch {.b1 configure -width 1i} msg] $msg $errorInfo @@ -565,7 +524,7 @@ test button-6.14 {ConfigureButton procedure} { (processing -width option) invoked from within ".b1 configure -width 1i"}} -test button-6.15 {ConfigureButton procedure} { +test button-6.15 {ConfigureButton - -height option} { catch {destroy .b1} button .b1 -text "Button 1" list [catch {.b1 configure -height 0.5c} msg] $msg $errorInfo @@ -573,7 +532,7 @@ test button-6.15 {ConfigureButton procedure} { (processing -height option) invoked from within ".b1 configure -height 0.5c"}} -test button-6.16 {ConfigureButton procedure} { +test button-6.16 {ConfigureButton - -width option} { catch {destroy .b1} button .b1 -bitmap questhead list [catch {.b1 configure -width abc} msg] $msg $errorInfo @@ -581,7 +540,7 @@ test button-6.16 {ConfigureButton procedure} { (processing -width option) invoked from within ".b1 configure -width abc"}} -test button-6.17 {ConfigureButton procedure} { +test button-6.17 {ConfigureButton - -height option} { catch {destroy .b1} eval image delete [image names] image create test image1 @@ -591,7 +550,7 @@ test button-6.17 {ConfigureButton procedure} { (processing -height option) invoked from within ".b1 configure -height 0.5x"}} -test button-6.18 {ConfigureButton procedure} {nonPortable fonts} { +test button-6.18 {ConfigureButton - computing geometry} {nonPortable fonts} { catch {destroy .b1} button .b1 -text "Sample text" -width 10 -height 2 pack .b1 @@ -599,7 +558,7 @@ test button-6.18 {ConfigureButton procedure} {nonPortable fonts} { .b1 configure -bitmap questhead lappend result [winfo reqwidth .b1] [winfo reqheight .b1] } {102 46 20 12} -test button-6.19 {ConfigureButton procedure} { +test button-6.19 {ConfigureButton - computing geometry} { catch {destroy .b1} button .b1 -text "Button 1" set old [winfo reqwidth .b1] @@ -820,3 +779,7 @@ eval destroy [winfo children .] option clear +# cleanup +::tcltest::cleanupTests +return + diff --git a/tk/tests/canvImg.test b/tk/tests/canvImg.test index f10115e9333..0424d8a3348 100644 --- a/tk/tests/canvImg.test +++ b/tk/tests/canvImg.test @@ -4,23 +4,23 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[info procs test] != "test"} { - source defs -} - foreach i [winfo children .] { destroy $i } @@ -60,7 +60,7 @@ test canvImg-1.5 {options for image items} { test canvImg-2.1 {CreateImage procedure} { list [catch {.c create image 40} msg] $msg -} {1 {wrong # args: should be ".c create image x y ?options?"}} +} {1 {wrong # coordinates: expected 2, got 1}} test canvImg-2.2 {CreateImage procedure} { list [catch {.c create image 40 50 60} msg] $msg } {1 {unknown option "60"}} @@ -100,7 +100,7 @@ test canvImg-3.4 {ImageCoords procedure} { .c delete all .c create image 50 100 -image foo -tags i1 list [catch {.c coords i1 250} msg] $msg -} {1 {wrong # coordinates: expected 0 or 2, got 1}} +} {1 {wrong # coordinates: expected 2, got 1}} test canvImg-3.5 {ImageCoords procedure} { .c delete all .c create image 50 100 -image foo -tags i1 @@ -395,3 +395,20 @@ test canvImg-11.3 {ImageChangedProc procedure} { update set y } {{foo2 display 0 0 20 40 50 40}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/canvPs.test b/tk/tests/canvPs.test index 98f3c950d1a..3c7cfe83f02 100644 --- a/tk/tests/canvPs.test +++ b/tk/tests/canvPs.test @@ -3,14 +3,13 @@ # TkCanvPostscriptCmd in generic/tkCanvPs.c # # Copyright (c) 1995 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -95,11 +94,24 @@ test canvPs-2.4 {test writing to channel and file, same output} {pcOnly} { set status } ok -# Clean-up - +# cleanup removeFile foo.ps removeFile bar.ps - foreach i [winfo children .] { destroy $i } +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/canvPsBmap.tcl b/tk/tests/canvPsBmap.tcl index 241b7bc9ef1..86aa55a211c 100644 --- a/tk/tests/canvPsBmap.tcl +++ b/tk/tests/canvPsBmap.tcl @@ -69,3 +69,16 @@ $c create bitmap 5.5i 5.5i \ -bitmap @[file join $tk_library demos/images/flagup.bmp] \ -background {} -foreground black -anchor se $c create rect 5.47i 5.47i 5.53i 5.53i -fill {} -outline black + + + + + + + + + + + + + diff --git a/tk/tests/canvPsGrph.tcl b/tk/tests/canvPsGrph.tcl index 8a2ddb7e875..4c02e475d0f 100644 --- a/tk/tests/canvPsGrph.tcl +++ b/tk/tests/canvPsGrph.tcl @@ -85,3 +85,16 @@ proc mkObjs c { } mkObjs $c + + + + + + + + + + + + + diff --git a/tk/tests/canvPsImg.tcl b/tk/tests/canvPsImg.tcl new file mode 100644 index 00000000000..88a0648605b --- /dev/null +++ b/tk/tests/canvPsImg.tcl @@ -0,0 +1,85 @@ +# This file creates a screen to exercise Postscript generation +# for images in canvases. It is part of the Tk visual test suite, +# which is invoked via the "visual" script. +# +# RCS: @(#) $Id$ + +# Build a test image in a canvas +proc BuildTestImage {} { + global BitmapImage PhotoImage visual level + catch {destroy .t.f} + frame .t.f -visual $visual -colormap new + pack .t.f -side top -after .t.top + bind .t.f <Enter> {wm colormapwindows .t {.t.f .t}} + bind .t.f <Leave> {wm colormapwindows .t {.t .t.f}} + canvas .t.f.c -width 550 -height 350 -borderwidth 2 -relief raised + pack .t.f.c + .t.f.c create rectangle 25 25 525 325 -fill {} -outline black + .t.f.c create image 50 50 -anchor nw -image $BitmapImage + .t.f.c create image 250 50 -anchor nw -image $PhotoImage +} + +# Put postscript in a file +proc FilePostscript { canvas } { + global level + $canvas postscript -file /tmp/test.ps -colormode $level +} + +# Send postscript output to printer +proc PrintPostcript { canvas } { + global level + $canvas postscript -file tmp.ps -colormode $level + exec lpr tmp.ps +} + +catch {destroy .t} +toplevel .t +wm title .t "Postscript Tests for Canvases: Images" +wm iconname .t "Postscript" + +message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets for images. Click the buttons below to select a Visual type for the canvas and colormode for the Postscript output. Then click "Print" to send the results to the default printer, or "Print to file" to put the Postscript output in a file called "/tmp/test.ps". You can also click on items in the canvas to delete them. +NOTE: Some Postscript printers may not be able to handle Postscript generated in color mode.} -width 6i +pack .t.m -side top -fill both + +frame .t.top +pack .t.top -side top +frame .t.top.l -relief raised -borderwidth 2 +frame .t.top.r -relief raised -borderwidth 2 +pack .t.top.l .t.top.r -side left -fill both -expand 1 + +label .t.visuals -text "Visuals" +pack .t.visuals -in .t.top.l + +set visual [lindex [winfo visualsavailable .] 0] +foreach v [winfo visualsavailable .] { + # The hack below is necessary for some systems, which have more than one + # visual of the same type... + if {![winfo exists .t.$v]} { + radiobutton .t.$v -text $v -variable visual -value $v \ + -command BuildTestImage + pack .t.$v -in .t.top.l -anchor w + } +} + +label .t.levels -text "Color Levels" +pack .t.levels -in .t.top.r +set level monochrome +foreach l { monochrome gray color } { + radiobutton .t.$l -text $l -variable level -value $l + pack .t.$l -in .t.top.r -anchor w +} + +set BitmapImage [image create bitmap -file $tk_library/demos/images/face \ + -background white -foreground black] +set PhotoImage [image create photo -file $tk_library/demos/images/teapot.ppm] + +BuildTestImage + +frame .t.bot +pack .t.bot -side top -fill x -expand 1 + +button .t.file -text "Print to File" -command { FilePostscript .t.f.c } +button .t.print -text "Print" -command { PrintPostscript .t.f.c } +button .t.quit -text "Quit" -command { destroy .t } +pack .t.file .t.print .t.quit -in .t.bot -side left -fill x -expand 1 + diff --git a/tk/tests/canvPsText.tcl b/tk/tests/canvPsText.tcl index 2274f36b9e3..02ec274e787 100644 --- a/tk/tests/canvPsText.tcl +++ b/tk/tests/canvPsText.tcl @@ -81,3 +81,16 @@ proc setStipple c { global stipple $c itemconfigure text -stipple $stipple } + + + + + + + + + + + + + diff --git a/tk/tests/canvRect.test b/tk/tests/canvRect.test index 28018935549..c83f5fc52d1 100644 --- a/tk/tests/canvRect.test +++ b/tk/tests/canvRect.test @@ -3,14 +3,13 @@ # in the standard fashion for Tcl tests. # # Copyright (c) 1994-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -33,7 +32,7 @@ foreach test { {-outline #123456 #123456 bad_color {unknown color name "bad_color"}} {-stipple gray50 gray50 bogus {bitmap "bogus" not defined}} {-tags {test a b c} {test a b c} {} {}} - {-width 6 6 abc {bad screen distance "abc"}} + {-width 6.0 6.0 abc {bad screen distance "abc"}} } { set name [lindex $test 0] test canvRect-1.$i {configuration options} { @@ -118,11 +117,10 @@ test canvRect-3.7 {RectOvalCoords procedure} { test canvRect-4.1 {ConfigureRectOval procedure} { list [catch {.c itemconfigure x -width abc} msg] $msg \ [.c itemcget x -width] -} {1 {bad screen distance "abc"} 1} +} {1 {bad screen distance "abc"} 1.0} test canvRect-4.2 {ConfigureRectOval procedure} { - .c itemconfigure x -width -5 - .c itemcget x -width -} {1} + list [catch {.c itemconfigure x -width -5} msg] $msg +} {1 {bad screen distance "-5"}} test canvRect-4.3 {ConfigureRectOval procedure} {nonPortable} { # Non-portable due to rounding differences. .c itemconfigure x -width 10 @@ -294,7 +292,7 @@ test canvRect-10.1 {TranslateRectOval procedure} { # This test is non-portable because different color information # will get generated on different displays (e.g. mono displays # vs. color). -test canvRect-11.1 {RectOvalToPostscript procedure} {nonPortable win32sCrash macCrash} { +test canvRect-11.1 {RectOvalToPostscript procedure} {nonPortable macCrash} { # Crashes on Mac because the XGetImage() call isn't implemented, causing a # dereference of NULL. @@ -327,3 +325,20 @@ restore showpage end %%EOF } + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/canvText.test b/tk/tests/canvText.test index b9d2afec87d..884a84223fc 100644 --- a/tk/tests/canvText.test +++ b/tk/tests/canvText.test @@ -3,14 +3,13 @@ # fashion for Tcl tests. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {"[info procs test]" != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -106,7 +105,7 @@ test canvText-3.4 {TextCoords procedure} { } {10.0 10.0} test canvText-3.5 {TextCoords procedure} { list [catch {.c coords test 10} msg] $msg -} {1 {wrong # coordinates: expected 0 or 2, got 1}} +} {1 {wrong # coordinates: expected 2, got 1}} test canvText-3.6 {TextCoords procedure} { list [catch {.c coords test 10 10 10} msg] $msg } {1 {wrong # coordinates: expected 0 or 2, got 3}} @@ -174,7 +173,7 @@ test canvText-5.1 {ConfigureText procedure: adjust cursor} { .c delete x } {} -test canvText-6.1 {ComputeTextBbox procedure} {fonts} { +test canvText-6.1 {ComputeTextBbox procedure} {fonts nonPortable} { .c itemconfig test -font $font -text 0 .c coords test 0 0 set x {} @@ -200,7 +199,7 @@ test canvText-6.1 {ComputeTextBbox procedure} {fonts} { focus .c .c focus test .c itemconfig test -text "abcd\nefghi\njklmnopq" -test canvText-7.1 {DisplayText procedure: stippling} { +test canvText-7.0 {DisplayText procedure: stippling} { .c itemconfig test -stipple gray50 update .c itemconfig test -stipple {} @@ -241,6 +240,20 @@ test canvText-7.8 {DisplayText procedure: not selected} { .c select clear update } {} +test canvText-7.9 {DisplayText procedure: select end} { + catch {destroy .t} + toplevel .t + wm geometry .t +0+0 + canvas .t.c + pack .t.c + set id [.t.c create text 0 0 -text Dummy -anchor nw] + update + .t.c select from $id 0 + .t.c select to $id end + update + #catch {destroy .t} + update +} {} test canvText-8.1 {TextInsert procedure: 0 length insert} { .c insert test end {} @@ -491,3 +504,34 @@ restore showpage end %%EOF " + +test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} { + catch {destroy .c} + canvas .c + pack .c + .c delete all + .c create text 100 100 -text Hello\n -anchor nw + set bbox [.c bbox 1] + set x2 [lindex $bbox 2] + set y2 [lindex $bbox 3] + incr y2 + update + .c find enclosed 99 99 [expr $x2 + $i] [expr $y2 + 1] +} 1 + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/canvWind.test b/tk/tests/canvWind.test index 7e9d7da7ab7..b408b0d9477 100644 --- a/tk/tests/canvWind.test +++ b/tk/tests/canvWind.test @@ -3,14 +3,13 @@ # fashion for Tcl tests. # # Copyright (c) 1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {"[info procs test]" != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -131,3 +130,21 @@ test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} { update lappend x [list [winfo ismapped $f] [winfo x $f]] } {{1 3} {1 -79} {0 -79} {1 255} {0 255}} +catch {destroy .t} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/canvas.test b/tk/tests/canvas.test index 9bf32d9447c..c4b76906ac3 100644 --- a/tk/tests/canvas.test +++ b/tk/tests/canvas.test @@ -3,15 +3,13 @@ # standard fashion for Tcl tests. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-2000 Ajuba Solutions. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -69,13 +67,29 @@ foreach test { incr i } +test canvas-1.40 {configure throws error on bad option} { + set res [list [catch {.c configure -gorp foo}]] + .c create rect 10 10 100 100 + lappend res [catch {.c configure -gorp foo}] + set res +} [list 1 1] + catch {destroy .c} canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \ -highlightthickness 0 pack .c update -test canvas-2.1 {CanvasWidgetCmd, xview option} { + +test canvas-2.1 {CanvasWidgetCmd, bind option} { + set i [.c create rect 10 10 100 100] + list [catch {.c bind $i <a>} msg] $msg +} {0 {}} +test canvas-2.2 {CanvasWidgetCmd, bind option} { + set i [.c create rect 10 10 100 100] + list [catch {.c bind $i <} msg] $msg +} {1 {no event type or button # or keysym}} +test canvas-2.3 {CanvasWidgetCmd, xview option} { .c configure -xscrollincrement 40 -yscrollincrement 5 .c xview moveto 0 update @@ -84,7 +98,7 @@ test canvas-2.1 {CanvasWidgetCmd, xview option} { update lappend x [.c xview] } {{0 0.3} {0.4 0.7}} -test canvas-2.2 {CanvasWidgetCmd, xview option} {nonPortable} { +test canvas-2.4 {CanvasWidgetCmd, xview option} {nonPortable} { # This test gives slightly different results on platforms such # as NetBSD. I don't know why... .c configure -xscrollincrement 0 -yscrollincrement 5 @@ -236,3 +250,124 @@ test canvas-9.1 {canvas id creation and deletion} { set x "" } {} +test canvas-10.1 {find items using tag expressions} { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 60 40 80 -fill yellow -tag [list b a] + .c create oval 20 100 40 120 -fill green -tag [list c b] + .c create oval 20 140 40 160 -fill blue -tag [list b] + .c create oval 20 180 40 200 -fill bisque -tag [list a d e] + .c create oval 20 220 40 240 -fill bisque -tag b + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] + set res {} + lappend res [.c find withtag {!a}] + lappend res [.c find withtag {b&&c}] + lappend res [.c find withtag {b||c}] + lappend res [.c find withtag {a&&!b}] + lappend res [.c find withtag {!b&&!c}] + lappend res [.c find withtag {d&&a&&c&&b}] + lappend res [.c find withtag {b^a}] + lappend res [.c find withtag {(a&&!b)||(!a&&b)}] + lappend res [.c find withtag { ( a && ! b ) || ( ! a && b ) }] + lappend res [.c find withtag {a&&!(c||d)}] + lappend res [.c find withtag {d&&"tag with spaces"}] + lappend res [.c find withtag "tag with spaces"] +} {{3 4 6 7} {1 3} {1 2 3 4 6} 5 {5 7} 1 {3 4 5 6} {3 4 5 6} {3 4 5 6} 2 7 7} +test canvas-10.2 {check errors from tag expressions} { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] + catch {.c find withtag {&&c}} err + set err +} {Unexpected operator in tag search expression} +test canvas-10.3 {check errors from tag expressions} { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] + catch {.c find withtag {!!c}} err + set err +} {Too many '!' in tag search expression} +test canvas-10.4 {check errors from tag expressions} { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] + catch {.c find withtag {b||}} err + set err +} {Missing tag in tag search expression} +test canvas-10.5 {check errors from tag expressions} { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] + catch {.c find withtag {b&&(c||)}} err + set err +} {Unexpected operator in tag search expression} +test canvas-10.6 {check errors from tag expressions} { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] + catch {.c find withtag {d&&""}} err + set err +} {Null quoted tag string in tag search expression} +test canvas-10.7 {check errors from tag expressions} { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] + catch {.c find withtag "d&&\"tag with spaces"} err + set err +} {Missing endquote in tag search expression} +test canvas-10.8 {check errors from tag expressions} { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] + catch {.c find withtag {a&&"tag with spaces"z}} err + set err +} {Invalid boolean operator in tag search expression} +test canvas-10.9 {check errors from tag expressions} { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] + catch {.c find withtag {a&&b&c}} err + set err +} {Singleton '&' in tag search expression} +test canvas-10.10 {check errors from tag expressions} { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list a b c d] + .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] + catch {.c find withtag {a||b|c}} err + set err +} {Singleton '|' in tag search expression} +test canvas-10.11 {backward compatility - strange tags that are not expressions} { + catch {destroy .c} + canvas .c + .c create oval 20 20 40 40 -fill red -tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }] + .c find withtag { strange tag(xxx&yyy|zzz) " && \" || ! ^ " } +} {1} +test canvas-10.12 {multple events bound to same tag expr} { + catch {destroy .c} + canvas .c + .c bind {a && b} <Enter> {puts Enter} + .c bind {a && b} <Leave> {puts Leave} +} {} + +test canvas-11.1 {canvas poly fill check, bug 5783} { + # This would crash in 8.3.0 and 8.3.1 + destroy .c + pack [canvas .c] + .c create polygon 0 0 100 100 200 50 \ + -fill {} -stipple gray50 -outline black +} 1 + +# cleanup +::tcltest::cleanupTests +return + diff --git a/tk/tests/choosedir.test b/tk/tests/choosedir.test new file mode 100644 index 00000000000..1b1d20ebd4d --- /dev/null +++ b/tk/tests/choosedir.test @@ -0,0 +1,150 @@ +# 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. +# All rights reserved. +# +# RCS: @(#) $Id$ +# + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +#---------------------------------------------------------------------- +# +# Procedures needed by this test file +# +#---------------------------------------------------------------------- + +proc ToPressButton {parent btn} { + after 100 SendButtonPress $parent $btn mouse +} + +proc ToEnterDirsByKey {parent dirs} { + after 100 [list EnterDirsByKey $parent $dirs] +} + +proc PressButton {btn} { + event generate $btn <Enter> + event generate $btn <1> -x 5 -y 5 + event generate $btn <ButtonRelease-1> -x 5 -y 5 +} + +proc EnterDirsByKey {parent dirs} { + global tk_strictMotif + if {$parent == "."} { + set w .__tk_choosedir + } else { + set w $parent.__tk_choosedir + } + upvar ::tk::dialog::file::__tk_choosedir data + + foreach dir $dirs { + $data(ent) delete 0 end + $data(ent) insert 0 $dir + update + SendButtonPress $parent ok mouse + after 50 + } +} + +proc SendButtonPress {parent btn type} { + global tk_strictMotif + if {$parent == "."} { + set w .__tk_choosedir + } else { + set w $parent.__tk_choosedir + } + upvar ::tk::dialog::file::__tk_choosedir data + + set button $data($btn\Btn) + if ![winfo ismapped $button] { + update + } + + if {$type == "mouse"} { + PressButton $button + } else { + event generate $w <Enter> + focus $w + event generate $button <Enter> + event generate $w <KeyPress> -keysym Return + } +} + + +#---------------------------------------------------------------------- +# +# The test suite proper +# +#---------------------------------------------------------------------- +# Make a dir for us to rely on for tests +makeDirectory choosedirTest +set dir [pwd] +set fake [file join $dir non-existant] +set real [file join $dir choosedirTest] + +set parent . + +foreach opt {-initialdir -mustexist -parent -title} { + test choosedir-1.1 "tk_chooseDirectory command" unixOnly { + list [catch {tk_chooseDirectory $opt} msg] $msg + } [list 1 "value for \"$opt\" missing"] +} +test choosedir-1.2 "tk_chooseDirectory command" unixOnly { + list [catch {tk_chooseDirectory -foo bar} msg] $msg +} [list 1 "bad option \"-foo\": must be -initialdir, -mustexist, -parent, or -title"] +test choosedir-1.3 "tk_chooseDirectory command" unixOnly { + list [catch {tk_chooseDirectory -parent foo.bar} msg] $msg +} {1 {bad window path name "foo.bar"}} + + +test choosedir-2.1 "tk_chooseDirectory command, cancel gives null" {unixOnly} { + ToPressButton $parent cancel + tk_chooseDirectory -title "Press Cancel" -parent $parent +} "" + +test choosedir-3.1 "tk_chooseDirectory -mustexist 1" {unixOnly} { + # first enter a bogus dirname, then enter a real one. + ToEnterDirsByKey $parent [list $fake $real $real] + set result [tk_chooseDirectory \ + -title "Enter \"$fake\", press OK, enter \"$real\", press OK" \ + -parent $parent -mustexist 1] + set result +} $real +test choosedir-3.2 "tk_chooseDirectory -mustexist 0" {unixOnly} { + ToEnterDirsByKey $parent [list $fake $fake] + tk_chooseDirectory -title "Enter \"$fake\", press OK" \ + -parent $parent -mustexist 0 +} $fake + +test choosedir-4.1 "tk_chooseDirectory command, initialdir" {unixOnly} { + ToPressButton $parent ok + tk_chooseDirectory -title "Press Ok" -parent $parent -initialdir $real +} $real +test choosedir-4.2 "tk_chooseDirectory command, initialdir" {unixOnly} { + ToEnterDirsByKey $parent [list $fake $fake] + tk_chooseDirectory \ + -title "Enter \"$fake\" and press Ok" \ + -parent $parent -initialdir $real +} $fake +test choosedir-4.3 "tk_chooseDirectory, -initialdir {}" {unixOnly} { + catch {unset ::tk::dialog::file::__tk_choosedir} + ToPressButton $parent ok + tk_chooseDirectory \ + -title "Press OK" \ + -parent $parent -initialdir "" +} [pwd] + +test choosedir-5.1 "tk_chooseDirectory, handles {} entry text" {unixOnly} { + ToEnterDirsByKey $parent [list "" $real $real] + tk_chooseDirectory -title "Clear entry, Press OK; Enter $real, press OK" \ + -parent $parent +} $real + +# cleanup +::tcltest::cleanupTests +return diff --git a/tk/tests/clipboard.test b/tk/tests/clipboard.test index b730b09a852..240ae7e044f 100644 --- a/tk/tests/clipboard.test +++ b/tk/tests/clipboard.test @@ -3,9 +3,8 @@ # fashion for Tcl tests. # # Copyright (c) 1994 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ @@ -14,8 +13,8 @@ # environment variable TK_ALT_DISPLAY is set to an alternate display. # -if {[string compare test [info procs test]] == 1} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } eval destroy [winfo child .] @@ -232,3 +231,20 @@ test clipboard-7.13 {Tk_ClipboardCmd procedure} { test clipboard-7.14 {Tk_ClipboardCmd procedure} { list [catch {clipboard error} msg] $msg } {1 {bad option "error": must be clear or append}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/clrpick.test b/tk/tests/clrpick.test index 69b621dc999..8bb7039c23c 100644 --- a/tk/tests/clrpick.test +++ b/tk/tests/clrpick.test @@ -2,22 +2,27 @@ # It is organized in the standard fashion for Tcl tests. # # Copyright (c) 1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ # -if {[string compare test [info procs test]] == 1} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } +# Some tests require user interaction on non-unix platform + +set ::tcltest::testConfig(nonUnixUserInteraction) \ + [expr {$::tcltest::testConfig(userInteraction) || \ + $::tcltest::testConfig(unixOnly)}] + test clrpick-1.1 {tk_chooseColor command} { list [catch {tk_chooseColor -foo} msg] $msg -} {1 {unknown option "-foo", must be -initialcolor, -parent or -title}} +} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}} -catch {tk_chooseColor -foo} msg +catch {tk_chooseColor -foo 1} msg regsub -all , $msg "" options regsub \"-foo\" $options "" options @@ -31,7 +36,7 @@ foreach option $options { test clrpick-1.3 {tk_chooseColor command} { list [catch {tk_chooseColor -foo bar} msg] $msg -} {1 {unknown option "-foo", must be -initialcolor, -parent or -title}} +} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}} test clrpick-1.4 {tk_chooseColor command} { list [catch {tk_chooseColor -initialcolor} msg] $msg @@ -55,14 +60,6 @@ if {[info commands tkColorDialog] == ""} { set isNative 0 } -if {$isNative && ![info exists INTERACTIVE]} { - puts " Some tests were skipped because they could not be performed" - puts " automatically on this platform. If you wish to execute them" - puts " interactively, set the TCL variable INTERACTIVE and re-run" - puts " the test." - return -} - proc ToPressButton {parent btn} { global isNative if {!$isNative} { @@ -141,8 +138,9 @@ set verylongstring $verylongstring$verylongstring # let's soak up a bunch of colors...so that # machines with small color palettes still fail. +# some tests will be skipped if there are no more colors set numcolors 32 -set nomorecolors 0 +set ::tcltest::testConfig(colorsLeftover) 1 set i 0 canvas .c pack .c -expand 1 -fill both @@ -160,7 +158,7 @@ while {$i<$numcolors} { set g [expr $g/256] set b [expr $b/256] if {"$color" != "#[format %02x%02x%02x $r $g $b]"} { - set nomorecolors 1 + set ::tcltest::testConfig(colorsLeftover) 0 } } .c delete $i @@ -169,47 +167,57 @@ while {$i<$numcolors} { destroy .c -if {!$nomorecolors} { - set color #404040 - test clrpick-2.1 {tk_chooseColor command} { - ToPressButton $parent ok - tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color -parent $parent - } "$color" - - set color #808040 - test clrpick-2.2 {tk_chooseColor command} { - if {$tcl_platform(platform) == "macintosh"} { - set colors "32768 32768 16384" - } else { - set colors "128 128 64" - } - ToChooseColorByKey $parent 128 128 64 - tk_chooseColor -parent $parent -title "choose $colors" - } "$color" - - test clrpick-2.3 {tk_chooseColor command} { - ToPressButton $parent ok - tk_chooseColor -parent $parent -title "Press OK" - } "$color" -} else { - puts "Skipped tests clrpick2.1, clrpick2.2 and clrpick2.3 because" - puts "you ran out of colors in your color palette, and this would" - puts "have caused the tests to generate errors." -} - -test clrpick-2.4 {tk_chooseColor command} { +set color #404040 +test clrpick-2.1 {tk_chooseColor command} \ + {nonUnixUserInteraction colorsLeftover} { + ToPressButton $parent ok + tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color \ + -parent $parent +} "$color" + +set color #808040 +test clrpick-2.2 {tk_chooseColor command} \ + {nonUnixUserInteraction colorsLeftover} { + if {$tcl_platform(platform) == "macintosh"} { + set colors "32768 32768 16384" + } else { + set colors "128 128 64" + } + ToChooseColorByKey $parent 128 128 64 + tk_chooseColor -parent $parent -title "choose $colors" +} "$color" + +test clrpick-2.3 {tk_chooseColor command} \ + {nonUnixUserInteraction colorsLeftover} { + ToPressButton $parent ok + tk_chooseColor -parent $parent -title "Press OK" +} "$color" + +test clrpick-2.4 {tk_chooseColor command} {nonUnixUserInteraction} { ToPressButton $parent cancel tk_chooseColor -parent $parent -title "Press Cancel" } "" -set color #000000 -test clrpick-3.1 {tk_chooseColor: background events} { +set color "#000000" +test clrpick-3.1 {tk_chooseColor: background events} {nonUnixUserInteraction} { after 1 {set x 53} ToPressButton $parent ok tk_chooseColor -parent $parent -title "Press OK" -initialcolor $color } "#000000" -test clrpick-3.2 {tk_chooseColor: background events} { +test clrpick-3.2 {tk_chooseColor: background events} {nonUnixUserInteraction} { after 1 {set x 53} ToPressButton $parent cancel tk_chooseColor -parent $parent -title "Press Cancel" } "" + +test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} unixOnly { + after 50 {set ::scr [winfo screen .__tk__color]} + ToPressButton $parent cancel + tk_chooseColor -parent $parent + set ::scr +} [winfo screen $parent] + +# cleanup +::tcltest::cleanupTests +return + diff --git a/tk/tests/cmap.tcl b/tk/tests/cmap.tcl index 8fe0207ce15..f39d1786c60 100644 --- a/tk/tests/cmap.tcl +++ b/tk/tests/cmap.tcl @@ -59,3 +59,16 @@ pack .t2.quit -side bottom -pady 3 -ipadx 4 -ipady 2 frame .t2.f -height 320 -width 320 pack .t2.f -side bottom colors .t2.f 0 0 4 + + + + + + + + + + + + + diff --git a/tk/tests/cmds.test b/tk/tests/cmds.test index 23a46700b88..cc86061ecab 100644 --- a/tk/tests/cmds.test +++ b/tk/tests/cmds.test @@ -2,14 +2,13 @@ # tkCmds.c. It is organized in the standard fashion for Tcl tests. # # Copyright (c) 1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } eval destroy [winfo child .] @@ -41,3 +40,20 @@ test cmds-1.5 {tkwait visibility, window gets deleted} { after 100 {set x deleted; destroy .f} list [catch {tkwait visibility .f.b} msg] $msg $x } {1 {window ".f.b" was deleted before its visibility changed} deleted} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/color.test b/tk/tests/color.test index 37867f6100f..a12b941127a 100644 --- a/tk/tests/color.test +++ b/tk/tests/color.test @@ -1,15 +1,20 @@ # 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 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1995-1998 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {[info commands testcolor] != "testcolor"} { + puts "testcolor command not available; skipping tests" + ::tcltest::cleanupTests + return } eval destroy [winfo children .] @@ -103,11 +108,13 @@ proc colorsFree {w {red 31} {green 245} {blue 192}} { # test file. if [catch {toplevel .t -visual {pseudocolor 8} -colormap new}] { + ::tcltest::cleanupTests return } wm geom .t +0+0 if {[winfo depth .t] != 8} { destroy .t + ::tcltest::cleanupTests return } mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40 @@ -115,31 +122,81 @@ pack .t.c update if ![colorsFree .t.c 101 233 17] { destroy .t + ::tcltest::cleanupTests return } mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0 pack .t.c2 if [colorsFree .t.c] { destroy .t + ::tcltest::cleanupTests return } destroy .t.c .t.c2 -test color-1.1 {Tk_GetColor procedure} { - c255 [winfo rgb .t red] +test color-1.1 {Tk_AllocColorFromObj - converting internal reps} { + set x green + lindex $x 0 + destroy .b1 + button .b1 -foreground $x -text .b1 + lindex $x 0 + testcolor green +} {{1 0}} +test color-1.2 {Tk_AllocColorFromObj - discard stale color} { + set x green + destroy .b1 .b2 + button .b1 -foreground $x -text First + destroy .b1 + set result {} + lappend result [testcolor green] + button .b2 -foreground $x -text Second + lappend result [testcolor green] +} {{} {{1 1}}} +test color-1.3 {Tk_AllocColorFromObj - reuse existing color} { + set x green + destroy .b1 .b2 + button .b1 -foreground $x -text First + set result {} + lappend result [testcolor green] + button .b2 -foreground $x -text Second + pack .b1 .b2 -side top + lappend result [testcolor green] +} {{{1 1}} {{2 1}}} +test color-1.4 {Tk_AllocColorFromObj - try other colors in list} { + set x purple + destroy .b1 .b2 .t.b + button .b1 -foreground $x -text First + pack .b1 -side top + set result {} + lappend result [testcolor purple] + button .t.b -foreground $x -text Second + pack .t.b -side top + lappend result [testcolor purple] + button .b2 -foreground $x -text Third + pack .b2 -side top + lappend result [testcolor purple] +} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}} + +test color-2.1 {Tk_GetColor procedure} { + c255 [winfo rgb .t #FF0000] } {255 0 0} -test color-1.2 {Tk_GetColor procedure} { +test color-2.2 {Tk_GetColor procedure} { list [catch {winfo rgb .t noname} msg] $msg } {1 {unknown color name "noname"}} - -test color-1.3 {Tk_GetColor procedure} { +test color-2.3 {Tk_GetColor procedure} { c255 [winfo rgb .t #123456] } {18 52 86} -test color-1.4 {Tk_GetColor procedure} { +test color-2.4 {Tk_GetColor procedure} { list [catch {winfo rgb .t #xyz} msg] $msg } {1 {invalid color name "#xyz"}} +test color-2.5 {Tk_GetColor procedure} { + winfo rgb .t #00FF00 +} {0 65535 0} +test color-2.6 {Tk_GetColor procedure} { + winfo rgb .t red +} {65535 0 0} -test color-2.1 {Tk_FreeColor procedure, reference counting} { +test color-3.1 {Tk_FreeColor procedure, reference counting} { eval destroy [winfo child .t] mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40 pack .t.c @@ -153,7 +210,7 @@ test color-2.1 {Tk_FreeColor procedure, reference counting} { .t.c2 delete $last lappend result [colorsFree .t] } {0 1} -test color-2.2 {Tk_FreeColor procedure, flushing stressed cmap information} { +test color-3.2 {Tk_FreeColor procedure, flushing stressed cmap information} { eval destroy [winfo child .t] mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40 pack .t.c @@ -163,5 +220,74 @@ test color-2.2 {Tk_FreeColor procedure, flushing stressed cmap information} { update closest .t 241 241 1 } {240 240 0} +test color-3.3 {Tk_FreeColorFromObj - reference counts} { + set x purple + destroy .b1 .b2 .t.b + button .b1 -foreground $x -text First + pack .b1 -side top + button .t.b -foreground $x -text Second + pack .t.b -side top + button .b2 -foreground $x -text Third + pack .b2 -side top + set result {} + lappend result [testcolor purple] + destroy .b1 + lappend result [testcolor purple] + destroy .b2 + lappend result [testcolor purple] + destroy .t.b + lappend result [testcolor purple] +} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}} +test color-3.4 {Tk_FreeColorFromObj - unlinking from list} { + destroy .b .t.b .t2 .t3 + toplevel .t2 -visual {pseudocolor 8} -colormap new + toplevel .t3 -visual {pseudocolor 8} -colormap new + set x purple + button .b -foreground $x -text .b1 + button .t.b1 -foreground $x -text .t.b1 + button .t.b2 -foreground $x -text .t.b2 + button .t2.b1 -foreground $x -text .t2.b1 + button .t2.b2 -foreground $x -text .t2.b2 + button .t2.b3 -foreground $x -text .t2.b3 + button .t3.b1 -foreground $x -text .t3.b1 + button .t3.b2 -foreground $x -text .t3.b2 + button .t3.b3 -foreground $x -text .t3.b3 + button .t3.b4 -foreground $x -text .t3.b4 + set result {} + lappend result [testcolor purple] + destroy .t2 + lappend result [testcolor purple] + destroy .b + lappend result [testcolor purple] + destroy .t3 + lappend result [testcolor purple] + destroy .t + lappend result [testcolor purple] +} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}} + +test color-4.1 {FreeColorObjProc} { + destroy .b + set x [format purple] + button .b -foreground $x -text .b1 + set y [format purple] + .b configure -foreground $y + set z [format purple] + .b configure -foreground $z + set result {} + lappend result [testcolor purple] + set x red + lappend result [testcolor purple] + set z 32 + lappend result [testcolor purple] + destroy .b + lappend result [testcolor purple] + set y bogus + set result +} {{{1 3}} {{1 2}} {{1 1}} {}} destroy .t + +# cleanup +::tcltest::cleanupTests +return + diff --git a/tk/tests/config.test b/tk/tests/config.test new file mode 100644 index 00000000000..f5e4b0c6699 --- /dev/null +++ b/tk/tests/config.test @@ -0,0 +1,838 @@ +# This file is a Tcl script to test the procedures in tkConfig.c, +# 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. +# All rights reserved. +# +# RCS: @(#) $Id$ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {[info command testobjconfig] != "testobjconfig"} { + puts "This application hasn't been compiled with the \"testobjconfig\"" + puts "command, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + ::tcltest::cleanupTests + return +} + +proc killTables {} { + # Note: it's important to delete chain2 before chain1, because + # chain2 depends on chain1. If chain1 is deleted first, the + # delete of chain2 will crash. + + foreach t {alltypes chain2 chain1 configerror internal new notenoughparams + twowindows} { + while {[testobjconfig info $t] != ""} { + testobjconfig delete $t + } + } +} + +foreach i [winfo children .] { + destroy $i +} +killTables +wm geometry . {} +raise . + +test config-1.1 {Tk_CreateOptionTable - reference counts} { + eval destroy [winfo children .] + killTables + set x {} + testobjconfig alltypes .a + lappend x [testobjconfig info alltypes] + testobjconfig alltypes .b + lappend x [testobjconfig info alltypes] + eval destroy [winfo children .] + set x +} {{1 15 -boolean} {2 15 -boolean}} +test config-1.2 {Tk_CreateOptionTable - synonym initialization} { + eval destroy [winfo children .] + testobjconfig alltypes .a -synonym green + .a cget -color +} {green} +test config-1.3 {Tk_CreateOptionTable - option database initialization} { + eval destroy [winfo children .] + option clear + testobjconfig alltypes .a + option add *b.string different + testobjconfig alltypes .b + list [.a cget -string] [.b cget -string] +} {foo different} +test config-1.4 {Tk_CreateOptionTable - option database initialization} { + eval destroy [winfo children .] + option clear + testobjconfig alltypes .a + option add *b.String bar + testobjconfig alltypes .b + list [.a cget -string] [.b cget -string] +} {foo bar} +test config-1.5 {Tk_CreateOptionTable - default initialization} { + eval destroy [winfo children .] + testobjconfig alltypes .a + .a cget -relief +} {raised} +test config-1.6 {Tk_CreateOptionTable - chained tables} { + eval destroy [winfo children .] + killTables + testobjconfig chain1 .a + testobjconfig chain2 .b + testobjconfig info chain2 +} {1 4 -three 2 2 -one} +test config-1.7 {Tk_CreateOptionTable - chained tables} { + eval destroy [winfo children .] + killTables + testobjconfig chain2 .b + testobjconfig chain1 .a + testobjconfig info chain2 +} {1 4 -three 2 2 -one} +test config-1.8 {Tk_CreateOptionTable - chained tables} { + eval destroy [winfo children .] + testobjconfig chain1 .a + testobjconfig chain2 .b + list [catch {.a cget -four} msg] $msg [.a cget -one] \ + [.b cget -four] [.b cget -one] +} {1 {unknown option "-four"} one four one} + +test config-2.1 {Tk_DeleteOptionTable - reference counts} { + eval destroy [winfo children .] + killTables + testobjconfig chain1 .a + testobjconfig chain2 .b + testobjconfig chain2 .c + eval destroy [winfo children .] + set x {} + testobjconfig delete chain2 + lappend x [testobjconfig info chain2] [testobjconfig info chain1] + testobjconfig delete chain2 + lappend x [testobjconfig info chain2] [testobjconfig info chain1] +} {{1 4 -three 2 2 -one} {2 2 -one} {} {1 2 -one}} + +# No tests for DestroyOptionHashTable; couldn't figure out how to test. + +test config-3.1 {Tk_InitOptions - priority of chained tables} { + eval destroy [winfo children .] + testobjconfig chain1 .a + testobjconfig chain2 .b + list [.a cget -two] [.b cget -two] +} {two {two and a half}} +test config-3.2 {Tk_InitOptions - initialize from database} { + eval destroy [winfo children .] + option clear + option add *a.color blue + testobjconfig alltypes .a + list [.a cget -color] +} {blue} +test config-3.3 {Tk_InitOptions - initialize from database} { + eval destroy [winfo children .] + option clear + option add *a.justify bogus + testobjconfig alltypes .a + list [.a cget -justify] +} {left} +test config-3.4 {Tk_InitOptions - initialize from widget class} { + eval destroy [winfo children .] + testobjconfig alltypes .a + list [.a cget -color] +} {red} +test config-3.5 {Tk_InitOptions - no initial value} { + eval destroy [winfo children .] + testobjconfig alltypes .a + .a cget -anchor +} {} +test config-3.6 {Tk_InitOptions - bad initial value} { + eval destroy [winfo children .] + option clear + option add *a.color non-existent + list [catch {testobjconfig alltypes .a} msg] $msg $errorInfo +} {1 {unknown color name "non-existent"} {unknown color name "non-existent" + (database entry for "-color" in widget ".a") + invoked from within +"testobjconfig alltypes .a"}} +option clear +test config-3.7 {Tk_InitOptions - bad initial value} { + eval destroy [winfo children .] + list [catch {testobjconfig configerror} msg] $msg $errorInfo +} {1 {expected integer but got "bogus"} {expected integer but got "bogus" + (default value for "-int") + invoked from within +"testobjconfig configerror"}} +option clear + +test config-4.1 {DoObjConfig - boolean} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -boolean 0} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}] +} {0 .foo 0 0 0} +test config-4.2 {DoObjConfig - boolean} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -boolean 1} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}] +} {0 .foo 0 1 0} +test config-4.3 {DoObjConfig - invalid boolean} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -boolean {}} msg] $msg +} {1 {expected boolean value but got ""}} +test config-4.4 {DoObjConfig - boolean internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -boolean 0 + .foo cget -boolean +} {0} +test config-4.5 {DoObjConfig - integer} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -integer 3} msg] $msg [catch {.foo cget -integer} result] $result [catch {rename .foo {}}] +} {0 .foo 0 3 0} +test config-4.6 {DoObjConfig - invalid integer} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -integer bar} msg] $msg +} {1 {expected integer but got "bar"}} +test config-4.7 {DoObjConfig - integer internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -integer 421 + .foo cget -integer +} {421} +test config-4.8 {DoObjConfig - double} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -double 3.14} msg] $msg [catch {.foo cget -double} result] $result [catch {rename .foo {}}] +} {0 .foo 0 3.14 0} +test config-4.9 {DoObjConfig - invalid double} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -double bar} msg] $msg +} {1 {expected floating-point number but got "bar"}} +test config-4.10 {DoObjConfig - double internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -double 62.75 + .foo cget -double +} {62.75} +test config-4.11 {DoObjConfig - string} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -string test} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo] +} {0 .foo 0 test {}} +test config-4.12 {DoObjConfig - null string} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -string {}} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo] +} {0 .foo 0 {} {}} +test config-4.13 {DoObjConfig - string internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -string "this is a test" + .foo cget -string +} {this is a test} +test config-4.14 {DoObjConfig - string table} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -stringtable two} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo] +} {0 .foo 0 two {}} +test config-4.15 {DoObjConfig - invalid string table} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -stringtable foo} msg] $msg +} {1 {bad stringtable "foo": must be one, two, three, or four}} +test config-4.16 {DoObjConfig - new string table} { + catch {destroy .foo} + testobjconfig alltypes .foo -stringtable two + list [catch {.foo configure -stringtable three} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo] +} {0 16 0 three {}} +test config-4.17 {DoObjConfig - stringtable internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -stringtable "four" + .foo cget -stringtable +} {four} +test config-4.18 {DoObjConfig - color} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -color blue} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo] +} {0 .foo 0 blue {}} +test config-4.19 {DoObjConfig - invalid color} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -color xxx} msg] $msg +} {1 {unknown color name "xxx"}} +test config-4.20 {DoObjConfig - color internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -color purple + .foo cget -color +} {purple} +test config-4.21 {DoObjConfig - null color} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -color {}} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo] +} {0 .foo 0 {} {}} +test config-4.22 {DoObjConfig - getting rid of old color} { + catch {destroy .foo} + testobjconfig alltypes .foo -color #333333 + list [catch {.foo configure -color #444444} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo] +} {0 32 0 #444444 {}} +test config-4.23 {DoObjConfig - font} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo] +} {0 .foo 0 {Helvetica 72} {}} +test config-4.24 {DoObjConfig - new font} { + catch {rename .foo {}} + testobjconfig alltypes .foo -font {Courier 12} + list [catch {.foo configure -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo] +} {0 64 0 {Helvetica 72} {}} +test config-4.25 {DoObjConfig - invalid font} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -font {Helvetica 12 foo}} msg] $msg +} {1 {unknown font style "foo"}} +test config-4.26 {DoObjConfig - null font} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -font {}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo] +} {0 .foo 0 {} {}} +test config-4.27 {DoObjConfig - font internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -font {Times 16} + .foo cget -font +} {Times 16} +test config-4.28 {DoObjConfig - bitmap} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -bitmap gray75} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo] +} {0 .foo 0 gray75 {}} +test config-4.29 {DoObjConfig - new bitmap} { + catch {destroy .foo} + testobjconfig alltypes .foo -bitmap gray75 + list [catch {.foo configure -bitmap gray50} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo] +} {0 128 0 gray50 {}} +test config-4.30 {DoObjConfig - invalid bitmap} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -bitmap foo} msg] $msg +} {1 {bitmap "foo" not defined}} +test config-4.31 {DoObjConfig - null bitmap} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -bitmap {}} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo] +} {0 .foo 0 {} {}} +test config-4.32 {DoObjConfig - bitmap internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -bitmap gray25 + .foo cget -bitmap +} {gray25} +test config-4.33 {DoObjConfig - border} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -border green} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo] +} {0 .foo 0 green {}} +test config-4.34 {DoObjConfig - invalid border} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -border xxx} msg] $msg +} {1 {unknown color name "xxx"}} +test config-4.35 {DoObjConfig - null border} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -border {}} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo] +} {0 .foo 0 {} {}} +test config-4.36 {DoObjConfig - border internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -border #123456 + .foo cget -border +} {#123456} +test config-4.37 {DoObjConfig - getting rid of old border} { + catch {destroy .foo} + testobjconfig alltypes .foo -border #333333 + list [catch {.foo configure -border #444444} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo] +} {0 256 0 #444444 {}} +test config-4.38 {DoObjConfig - relief} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo] +} {0 .foo 0 flat {}} +test config-4.39 {DoObjConfig - invalid relief} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -relief foo} msg] $msg +} {1 {bad relief "foo": must be flat, groove, raised, ridge, solid, or sunken}} +test config-4.40 {DoObjConfig - new relief} { + catch {destroy .foo} + testobjconfig alltypes .foo -relief raised + list [catch {.foo configure -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo] +} {0 512 0 flat {}} +test config-4.41 {DoObjConfig - relief internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -relief ridge + .foo cget -relief +} {ridge} +test config-4.42 {DoObjConfig - cursor} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo] +} {0 .foo 0 arrow {}} +test config-4.43 {DoObjConfig - invalid cursor} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -cursor foo} msg] $msg +} {1 {bad cursor spec "foo"}} +test config-4.44 {DoObjConfig - null cursor} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -cursor {}} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo] +} {0 .foo 0 {} {}} +test config-4.45 {DoObjConfig - new cursor} { + catch {destroy .foo} + testobjconfig alltypes .foo -cursor xterm + list [catch {.foo configure -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo] +} {0 1024 0 arrow {}} +test config-4.46 {DoObjConfig - cursor internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -cursor watch + .foo cget -cursor +} {watch} +test config-4.47 {DoObjConfig - justify} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -justify center} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo] +} {0 .foo 0 center {}} +test config-4.48 {DoObjConfig - invalid justify} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -justify foo} msg] $msg +} {1 {bad justification "foo": must be left, right, or center}} +test config-4.49 {DoObjConfig - new justify} { + catch {destroy .foo} + testobjconfig alltypes .foo -justify left + list [catch {.foo configure -justify right} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo] +} {0 2048 0 right {}} +test config-4.50 {DoObjConfig - justify internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -justify center + .foo cget -justify +} {center} +test config-4.51 {DoObjConfig - anchor} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -anchor center} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo] +} {0 .foo 0 center {}} +test config-4.52 {DoObjConfig - invalid anchor} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -anchor foo} msg] $msg +} {1 {bad anchor "foo": must be n, ne, e, se, s, sw, w, nw, or center}} +test config-4.53 {DoObjConfig - new anchor} { + catch {destroy .foo} + testobjconfig alltypes .foo -anchor e + list [catch {.foo configure -anchor n} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo] +} {0 4096 0 n {}} +test config-4.54 {DoObjConfig - anchor internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -anchor sw + .foo cget -anchor +} {sw} +test config-4.55 {DoObjConfig - pixel} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -pixel 42} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo] +} {0 .foo 0 42 {}} +test config-4.56 {DoObjConfig - invalid pixel} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -pixel foo} msg] $msg +} {1 {bad screen distance "foo"}} +test config-4.57 {DoObjConfig - new pixel} { + catch {destroy .foo} + testobjconfig alltypes .foo -pixel 42m + list [catch {.foo configure -pixel 3c} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo] +} {0 8192 0 3c {}} +test config-4.58 {DoObjConfig - pixel internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -pixel [winfo screenmmwidth .]m + .foo cget -pixel +} [winfo screenwidth .] +test config-4.59 {DoObjConfig - window} { + catch {destroy .foo} + catch {destroy .bar} + toplevel .bar + list [catch {testobjconfig twowindows .foo -window .bar} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar] +} {0 .foo 0 .bar {} {}} +test config-4.60 {DoObjConfig - invalid window} { + catch {destroy .foo} + toplevel .bar + list [catch {testobjconfig twowindows .foo -window foo} msg] $msg [destroy .bar] +} {1 {bad window path name "foo"} {}} +test config-4.61 {DoObjConfig - null window} { + catch {destroy .foo} + catch {destroy .bar} + toplevel .bar + list [catch {testobjconfig twowindows .foo -window {}} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] +} {0 .foo 0 {} {}} +test config-4.62 {DoObjConfig - new window} { + catch {destroy .foo} + catch {destroy .bar} + catch {destroy .blamph} + toplevel .bar + toplevel .blamph + testobjconfig twowindows .foo -window .bar + list [catch {.foo configure -window .blamph} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar] [destroy .blamph] +} {0 0 0 .blamph {} {} {}} +test config-4.63 {DoObjConfig - window internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -window . + .foo cget -window +} {.} +test config-4.64 {DoObjConfig - releasing old values} { + # This test doesn't generate a useful value to check; if an + # error occurs, it will be detected only by memory checking software + # such as Purify or Tcl's built-in checker. + + catch {rename .foo {}} + testobjconfig alltypes .foo -string {Test string} -color yellow \ + -font {Courier 18} -bitmap questhead -border green -cursor cross + .foo configure -string {new string} -color brown \ + -font {Times 8} -bitmap gray75 -border pink -cursor watch + concat {} +} {} +test config-4.65 {DoObjConfig - releasing old values} { + # This test doesn't generate a useful value to check; if an + # error occurs, it will be detected only by memory checking software + # such as Purify or Tcl's built-in checker. + + catch {rename .foo {}} + testobjconfig internal .foo -string {Test string} -color yellow \ + -font {Courier 18} -bitmap questhead -border green -cursor cross + .foo configure -string {new string} -color brown \ + -font {Times 8} -bitmap gray75 -border pink -cursor watch + concat {} +} {} + +test config-5.1 {ObjectIsEmpty - object is already string} { + catch {destroy .foo} + testobjconfig alltypes .foo -color [format ""] + .foo cget -color +} {} +test config-5.2 {ObjectIsEmpty - object is already string} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -color [format " "]} msg] $msg +} {1 {unknown color name " "}} +test config-5.3 {ObjectIsEmpty - must convert back to string} { + catch {destroy .foo} + testobjconfig alltypes .foo -color [list] + .foo cget -color +} {} + +eval destroy [winfo children .] +testobjconfig chain2 .a +testobjconfig alltypes .b +test config-6.1 {GetOptionFromObj - cached answer} { + list [.a cget -three] [.a cget -three] +} {three three} +test config-6.2 {GetOptionFromObj - exact match} { + .a cget -one +} {one} +test config-6.3 {GetOptionFromObj - abbreviation} { + .a cget -fo +} {four} +test config-6.4 {GetOptionFromObj - ambiguous abbreviation} { + list [catch {.a cget -on} msg] $msg +} {1 {unknown option "-on"}} +test config-6.5 {GetOptionFromObj - duplicate options in different tables} { + .a cget -tw +} {two and a half} +test config-6.6 {GetOptionFromObj - synonym} { + .b cget -synonym +} {red} + +eval destroy [winfo children .] +testobjconfig alltypes .a +test config-7.1 {Tk_SetOptions - basics} { + .a configure -color green -rel sunken + list [.a cget -color] [.a cget -relief] +} {green sunken} +test config-7.2 {Tk_SetOptions - bogus option name} { + list [catch {.a configure -bogus} msg] $msg +} {1 {unknown option "-bogus"}} +test config-7.3 {Tk_SetOptions - synonym} { + .a configure -synonym blue + .a cget -color +} {blue} +test config-7.4 {Tk_SetOptions - missing value} { + list [catch {.a configure -color green -relief} msg] $msg [.a cget -color] +} {1 {value for "-relief" missing} green} +test config-7.5 {Tk_SetOptions - saving old values} { + .a configure -color red -int 7 -relief raised -double 3.14159 + list [catch {.a csave -color green -int 432 -relief sunken \ + -double 2.0 -color bogus} msg] $msg [.a cget -color] \ + [.a cget -int] [.a cget -relief] [.a cget -double] +} {1 {unknown color name "bogus"} red 7 raised 3.14159} +test config-7.6 {Tk_SetOptions - error in DoObjConfig call} { + list [catch {.a configure -color bogus} msg] $msg $errorInfo +} {1 {unknown color name "bogus"} {unknown color name "bogus" + (processing "-color" option) + invoked from within +".a configure -color bogus"}} +test config-7.7 {Tk_SetOptions - synonym name in error message} { + list [catch {.a configure -synonym bogus} msg] $msg $errorInfo +} {1 {unknown color name "bogus"} {unknown color name "bogus" + (processing "-synonym" option) + invoked from within +".a configure -synonym bogus"}} +test config-7.8 {Tk_SetOptions - returning mask} { + format %x [.a configure -color red -int 7 -relief raised -double 3.14159] +} {226} + +test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} { + eval destroy [winfo children .] + testobjconfig alltypes .a + list [catch {.a csave -color green -color black -color blue \ + -color #ffff00 -color #ff00ff -color bogus} msg] $msg \ + [.a cget -color] +} {1 {unknown color name "bogus"} red} +test config-8.2 {Tk_RestoreSavedOptions - freeing object memory} { + eval destroy [winfo children .] + testobjconfig alltypes .a + .a csave -color green -color black -color blue -color #ffff00 \ + -color #ff00ff +} {32} +test config-8.3 {Tk_RestoreSavedOptions - boolean internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -boolean 0 -color bogus}] [.a cget -boolean] +} {1 1} +test config-8.4 {Tk_RestoreSavedOptions - integer internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -integer 24 -color bogus}] [.a cget -integer] +} {1 148962237} +test config-8.5 {Tk_RestoreSavedOptions - double internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -double 62.4 -color bogus}] [.a cget -double] +} {1 3.14159} +test config-8.6 {Tk_RestoreSavedOptions - string internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -string "A long string" -color bogus}] \ + [.a cget -string] +} {1 foo} +test config-8.7 {Tk_RestoreSavedOptions - string table internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -stringtable three -color bogus}] \ + [.a cget -stringtable] +} {1 one} +test config-8.8 {Tk_RestoreSavedOptions - color internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -color green -color bogus}] [.a cget -color] +} {1 red} +test config-8.9 {Tk_RestoreSavedOptions - font internal form} {nonPortable} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -font {Times 12} -color bogus}] [.a cget -font] +} {1 {Helvetica 12}} +test config-8.10 {Tk_RestoreSavedOptions - bitmap internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -bitmap questhead -color bogus}] [.a cget -bitmap] +} {1 gray50} +test config-8.11 {Tk_RestoreSavedOptions - border internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -border brown -color bogus}] [.a cget -border] +} {1 blue} +test config-8.12 {Tk_RestoreSavedOptions - relief internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -relief sunken -color bogus}] [.a cget -relief] +} {1 raised} +test config-8.13 {Tk_RestoreSavedOptions - cursor internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -cursor watch -color bogus}] [.a cget -cursor] +} {1 xterm} +test config-8.14 {Tk_RestoreSavedOptions - justify internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -justify right -color bogus}] [.a cget -justify] +} {1 left} +test config-8.15 {Tk_RestoreSavedOptions - anchor internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -anchor center -color bogus}] [.a cget -anchor] +} {1 n} +test config-8.16 {Tk_RestoreSavedOptions - window internal form} { + eval destroy [winfo children .] + testobjconfig internal .a -window .a + list [catch {.a csave -window .a -color bogus}] [.a cget -window] +} {1 .a} + +# Most of the tests below will cause memory leakage if there is a +# problem. This may not be evident unless the tests are run in +# conjunction with a memory usage analyzer such as Purify. + +test config-9.1 {Tk_FreeConfigOptions/FreeResources - string internal form} { + catch {destroy .foo} + testobjconfig internal .foo + .foo configure -string "two words" + destroy .foo +} {} +test config-9.2 {Tk_FreeConfigOptions/FreeResources - color internal form} { + catch {destroy .foo} + testobjconfig internal .foo + .foo configure -color yellow + destroy .foo +} {} +test config-9.3 {Tk_FreeConfigOptions/FreeResources - color} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -color [format blue] + destroy .foo +} {} +test config-9.4 {Tk_FreeConfigOptions/FreeResources - font internal form} { + catch {destroy .foo} + testobjconfig internal .foo + .foo configure -font {Courier 20} + destroy .foo +} {} +test config-9.5 {Tk_FreeConfigOptions/FreeResources - font} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -font [format {Courier 24}] + destroy .foo +} {} +test config-9.6 {Tk_FreeConfigOptions/FreeResources - bitmap internal form} { + catch {destroy .foo} + testobjconfig internal .foo + .foo configure -bitmap gray75 + destroy .foo +} {} +test config-9.7 {Tk_FreeConfigOptions/FreeResources - bitmap} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -bitmap [format gray75] + destroy .foo +} {} +test config-9.8 {Tk_FreeConfigOptions/FreeResources - border internal form} { + catch {destroy .foo} + testobjconfig internal .foo + .foo configure -border orange + destroy .foo +} {} +test config-9.9 {Tk_FreeConfigOptions/FreeResources - border} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -border [format blue] + destroy .foo +} {} +test config-9.10 {Tk_FreeConfigOptions/FreeResources - cursor internal form} { + catch {destroy .foo} + testobjconfig internal .foo + .foo configure -cursor cross + destroy .foo +} {} +test config-9.11 {Tk_FreeConfigOptions/FreeResources - cursor} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -cursor [format watch] + destroy .foo +} {} +test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -integer [format 27] + destroy .foo +} {} + +test config-10.1 {Tk_GetOptionInfo - one item} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -relief groove + .foo configure -relief +} {-relief relief Relief raised groove} +test config-10.2 {Tk_GetOptionInfo - one item, synonym} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -color black + .foo configure -synonym +} {-color color Color red black} +test config-10.3 {Tk_GetOptionInfo - all items} { + catch {destroy .foo} + testobjconfig alltypes .foo -font {Helvetica 18} -integer 13563 + .foo configure +} {{-boolean boolean Boolean 1 1} {-integer integer Integer 7 13563} {-double double Double 3.14159 3.14159} {-string string String foo foo} {-stringtable StringTable stringTable one one} {-color color Color red red} {-font font Font {Helvetica 12} {Helvetica 18}} {-bitmap bitmap Bitmap gray50 gray50} {-border border Border blue blue} {-relief relief Relief raised raised} {-cursor cursor Cursor xterm xterm} {-justify {} {} left left} {-anchor anchor Anchor {} {}} {-pixel pixel Pixel 1 1} {-synonym -color}} +test config-10.4 {Tk_GetOptionInfo - chaining through tables} { + catch {destroy .foo} + testobjconfig chain2 .foo -one asdf -three xyzzy + .foo configure +} {{-three three Three three xyzzy} {-four four Four four four} {-two two Two {two and a half} {two and a half}} {-oneAgain oneAgain OneAgain {one again} {one again}} {-one one One one asdf} {-two two Two two {two and a half}}} + +eval destroy [winfo children .] +testobjconfig alltypes .a +test config-11.1 {GetConfigList - synonym} { + lindex [.a configure] end +} {-synonym -color} +test config-11.2 {GetConfigList - null database names} { + .a configure -justify +} {-justify {} {} left left} +test config-11.3 {GetConfigList - null default and current value} { + .a configure -anchor +} {-anchor anchor Anchor {} {}} + +eval destroy [winfo children .] +testobjconfig internal .a +test config-12.1 {GetObjectForOption - boolean} { + .a configure -boolean 0 + .a cget -boolean +} {0} +test config-12.2 {GetObjectForOption - integer} { + .a configure -integer 1247 + .a cget -integer +} {1247} +test config-12.3 {GetObjectForOption - double} { + .a configure -double -88.82 + .a cget -double +} {-88.82} +test config-12.4 {GetObjectForOption - string} { + .a configure -string "test value" + .a cget -string +} {test value} +test config-12.5 {GetObjectForOption - stringTable} { + .a configure -stringtable "two" + .a cget -stringtable +} {two} +test config-12.6 {GetObjectForOption - color} { + .a configure -color "green" + .a cget -color +} {green} +test config-12.7 {GetObjectForOption - font} { + .a configure -font {Times 36} + .a cget -font +} {Times 36} +test config-12.8 {GetObjectForOption - bitmap} { + .a configure -bitmap "questhead" + .a cget -bitmap +} {questhead} +test config-12.9 {GetObjectForOption - border} { + .a configure -border #33217c + .a cget -border +} {#33217c} +test config-12.10 {GetObjectForOption - relief} { + .a configure -relief groove + .a cget -relief +} {groove} +test config-12.11 {GetObjectForOption - cursor} { + .a configure -cursor watch + .a cget -cursor +} {watch} +test config-12.12 {GetObjectForOption - justify} { + .a configure -justify right + .a cget -justify +} {right} +test config-12.13 {GetObjectForOption - anchor} { + .a configure -anchor e + .a cget -anchor +} {e} +test config-12.14 {GetObjectForOption - pixels} { + .a configure -pixel 193.2 + .a cget -pixel +} {193} +test config-12.15 {GetObjectForOption - window} { + .a configure -window .a + .a cget -window +} {.a} +test config-12.16 {GetObjectForOption - null values} { + .a configure -string {} -color {} -font {} -bitmap {} -border {} \ + -cursor {} -window {} + list [.a cget -string] [.a cget -color] [.a cget -font] \ + [.a cget -string] [.a cget -bitmap] [.a cget -border] \ + [.a cget -cursor] [.a cget -window] +} {{} {} {} {} {} {} {} {}} + +test config-13.1 {proper cleanup of options with widget destroy} { + foreach type { + button canvas entry frame listbox menu menubutton message + scale scrollbar text radiobutton checkbutton + } { + destroy .w + $type .w -cursor crosshair + destroy .w + } +} {} + +# cleanup +eval destroy [winfo children .] +killTables +::tcltest::cleanupTests +return + diff --git a/tk/tests/cursor.test b/tk/tests/cursor.test new file mode 100644 index 00000000000..a0e80f14a95 --- /dev/null +++ b/tk/tests/cursor.test @@ -0,0 +1,116 @@ +# This file is a Tcl script to test out the procedures in the file +# 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. +# All rights reserved. +# +# RCS: @(#) $Id$ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {[info commands testcursor] != "testcursor"} { + puts "testcursor command not available; skipping tests" + ::tcltest::cleanupTests + return +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + +test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} { + set x watch + lindex $x 0 + destroy .b1 + button .b1 -cursor $x + lindex $x 0 + testcursor watch +} {{1 0}} +test cursor-1.2 {Tk_AllocCursorFromObj - discard stale cursor} { + set x watch + destroy .b1 .b2 + button .b1 -cursor $x + destroy .b1 + set result {} + lappend result [testcursor watch] + button .b2 -cursor $x + lappend result [testcursor watch] +} {{} {{1 1}}} +test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} { + set x watch + destroy .b1 .b2 + button .b1 -cursor $x + set result {} + lappend result [testcursor watch] + button .b2 -cursor $x + pack .b1 .b2 -side top + lappend result [testcursor watch] +} {{{1 1}} {{2 1}}} + +test cursor-2.1 {Tk_GetCursor procedure} { + destroy .b1 + list [catch {button .b1 -cursor bad_name} msg] $msg +} {1 {bad cursor spec "bad_name"}} +test cursor-2.2 {Tk_GetCursor procedure} { + destroy .b1 + list [catch {button .b1 -cursor @xyzzy} msg] $msg +} {1 {bad cursor spec "@xyzzy"}} + +test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} { + set x arrow + destroy .b1 .b2 .b3 + button .b1 -cursor $x + button .b3 -cursor $x + button .b2 -cursor $x + set result {} + lappend result [testcursor arrow] + destroy .b1 + lappend result [testcursor arrow] + destroy .b2 + lappend result [testcursor arrow] + destroy .b3 + lappend result [testcursor arrow] +} {{{3 1}} {{2 1}} {{1 1}} {}} + +test cursor-4.1 {FreeCursorObjProc} { + destroy .b + set x [format arrow] + button .b -cursor $x + set y [format arrow] + .b configure -cursor $y + set z [format arrow] + .b configure -cursor $z + set result {} + lappend result [testcursor arrow] + set x red + lappend result [testcursor arrow] + set z 32 + lappend result [testcursor arrow] + destroy .b + lappend result [testcursor arrow] + set y bogus + set result +} {{{1 3}} {{1 2}} {{1 1}} {}} + +destroy .t + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/defs.tcl b/tk/tests/defs.tcl new file mode 100644 index 00000000000..a2e55cdbb6a --- /dev/null +++ b/tk/tests/defs.tcl @@ -0,0 +1,1097 @@ +# defs.tcl -- +# +# This file contains support code for the Tcl/Tk test suite.It is +# It is normally sourced by the individual files in the test suite +# before they run their tests. This improved approach to testing +# was designed and initially implemented by Mary Ann May-Pumphrey +# of Sun Microsystems. +# +# Copyright (c) 1990-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. +# +# RCS: @(#) $Id$ + +# Initialize wish shell + +if {[info exists tk_version]} { + tk appname tktest + wm title . tktest +} else { + + # Ensure that we have a minimal auto_path so we don't pick up extra junk. + + set auto_path [list [info library]] +} + +# create the "tcltest" namespace for all testing variables and procedures + +namespace eval tcltest { + set procList [list test cleanupTests dotests saveState restoreState \ + normalizeMsg makeFile removeFile makeDirectory removeDirectory \ + viewFile bytestring set_iso8859_1_locale restore_locale \ + safeFetch threadReap] + if {[info exists tk_version]} { + lappend procList setupbg dobg bgReady cleanupbg fixfocus + } + foreach proc $procList { + namespace export $proc + } + + # setup ::tcltest default vars + foreach {var default} {verbose b match {} skip {}} { + if {![info exists $var]} { + variable $var $default + } + } + + # Tests should not rely on the current working directory. + # Files that are part of the test suite should be accessed relative to + # ::tcltest::testsDir. + + set originalDir [pwd] + set tDir [file join $originalDir [file dirname [info script]]] + cd $tDir + variable testsDir [pwd] + cd $originalDir + + # Count the number of files tested (0 if all.tcl wasn't called). + # The all.tcl file will set testSingleFile to false, so stats will + # not be printed until all.tcl calls the cleanupTests proc. + # The currentFailure var stores the boolean value of whether the + # current test file has had any failures. The failFiles list + # stores the names of test files that had failures. + + variable numTestFiles 0 + variable testSingleFile true + variable currentFailure false + variable failFiles {} + + # Tests should remove all files they create. The test suite will + # check the current working dir for files created by the tests. + # ::tcltest::filesMade keeps track of such files created using the + # ::tcltest::makeFile and ::tcltest::makeDirectory procedures. + # ::tcltest::filesExisted stores the names of pre-existing files. + + variable filesMade {} + variable filesExisted {} + + # ::tcltest::numTests will store test files as indices and the list + # of files (that should not have been) left behind by the test files. + + array set ::tcltest::createdNewFiles {} + + # initialize ::tcltest::numTests array to keep track fo the number of + # tests that pass, fial, and are skipped. + + array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0] + + # initialize ::tcltest::skippedBecause array to keep track of + # constraints that kept tests from running + + array set ::tcltest::skippedBecause {} + + # tests that use thread need to know which is the main thread + + variable ::tcltest::mainThread 1 + if {[info commands testthread] != {}} { + puts "Tk with threads enabled is known to have problems with X" + set ::tcltest::mainThread [testthread names] + } +} + +# If there is no "memory" command (because memory debugging isn't +# enabled), generate a dummy command that does nothing. + +if {[info commands memory] == ""} { + proc memory args {} +} + +# ::tcltest::initConfig -- +# +# Check configuration information that will determine which tests +# to run. To do this, create an array ::tcltest::testConfig. Each +# element has a 0 or 1 value. If the element is "true" then tests +# with that constraint will be run, otherwise tests with that constraint +# will be skipped. See the README file for the list of built-in +# constraints defined in this procedure. +# +# Arguments: +# none +# +# Results: +# The ::tcltest::testConfig array is reset to have an index for +# each built-in test constraint. + +proc ::tcltest::initConfig {} { + + global tcl_platform tcl_interactive tk_version + + catch {unset ::tcltest::testConfig} + + # The following trace procedure makes it so that we can safely refer to + # non-existent members of the ::tcltest::testConfig array without causing an + # error. Instead, reading a non-existent member will return 0. This is + # necessary because tests are allowed to use constraint "X" without ensuring + # that ::tcltest::testConfig("X") is defined. + + trace variable ::tcltest::testConfig r ::tcltest::safeFetch + + proc ::tcltest::safeFetch {n1 n2 op} { + if {($n2 != {}) && ([info exists ::tcltest::testConfig($n2)] == 0)} { + set ::tcltest::testConfig($n2) 0 + } + } + + set ::tcltest::testConfig(unixOnly) \ + [expr {$tcl_platform(platform) == "unix"}] + set ::tcltest::testConfig(macOnly) \ + [expr {$tcl_platform(platform) == "macintosh"}] + set ::tcltest::testConfig(pcOnly) \ + [expr {$tcl_platform(platform) == "windows"}] + + set ::tcltest::testConfig(unix) $::tcltest::testConfig(unixOnly) + set ::tcltest::testConfig(mac) $::tcltest::testConfig(macOnly) + set ::tcltest::testConfig(pc) $::tcltest::testConfig(pcOnly) + + set ::tcltest::testConfig(unixOrPc) \ + [expr {$::tcltest::testConfig(unix) || $::tcltest::testConfig(pc)}] + set ::tcltest::testConfig(macOrPc) \ + [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(pc)}] + set ::tcltest::testConfig(macOrUnix) \ + [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(unix)}] + + set ::tcltest::testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}] + set ::tcltest::testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}] + + # The following config switches are used to mark tests that should work, + # but have been temporarily disabled on certain platforms because they don't + # and we haven't gotten around to fixing the underlying problem. + + set ::tcltest::testConfig(tempNotPc) [expr {!$::tcltest::testConfig(pc)}] + set ::tcltest::testConfig(tempNotMac) [expr {!$::tcltest::testConfig(mac)}] + set ::tcltest::testConfig(tempNotUnix) [expr {!$::tcltest::testConfig(unix)}] + + # The following config switches are used to mark tests that crash on + # certain platforms, so that they can be reactivated again when the + # underlying problem is fixed. + + set ::tcltest::testConfig(pcCrash) [expr {!$::tcltest::testConfig(pc)}] + set ::tcltest::testConfig(macCrash) [expr {!$::tcltest::testConfig(mac)}] + set ::tcltest::testConfig(unixCrash) [expr {!$::tcltest::testConfig(unix)}] + + # Set the "fonts" constraint for wish apps + + if {[info exists tk_version]} { + set ::tcltest::testConfig(fonts) 1 + catch {destroy .e} + entry .e -width 0 -font {Helvetica -12} -bd 1 + .e insert end "a.bcd" + if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} { + set ::tcltest::testConfig(fonts) 0 + } + destroy .e + catch {destroy .t} + text .t -width 80 -height 20 -font {Times -14} -bd 1 + pack .t + .t insert end "This is\na dot." + update + set x [list [.t bbox 1.3] [.t bbox 2.5]] + destroy .t + if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} { + set ::tcltest::testConfig(fonts) 0 + } + + # Test to see if we have are running Unix apps on Exceed, + # which won't return font failures (Windows-like), which is + # not what we want from ann X server (other Windows X servers + # operate as expected) + + set ::tcltest::testConfig(noExceed) 1 + if {$::tcltest::testConfig(unixOnly) && \ + [catch {font actual "\{xyz"}] == 0} { + puts "Running X app on Exceed, skipping problematic font tests..." + set ::tcltest::testConfig(noExceed) 0 + } + } + + # Skip empty tests + + set ::tcltest::testConfig(emptyTest) 0 + + # By default, tests that expost known bugs are skipped. + + set ::tcltest::testConfig(knownBug) 0 + + # By default, non-portable tests are skipped. + + set ::tcltest::testConfig(nonPortable) 0 + + # Some tests require user interaction. + + set ::tcltest::testConfig(userInteraction) 0 + + # Some tests must be skipped if the interpreter is not in interactive mode + + set ::tcltest::testConfig(interactive) $tcl_interactive + + # Some tests must be skipped if you are running as root on Unix. + # Other tests can only be run if you are running as root on Unix. + + set ::tcltest::testConfig(root) 0 + set ::tcltest::testConfig(notRoot) 1 + set user {} + if {$tcl_platform(platform) == "unix"} { + catch {set user [exec whoami]} + if {$user == ""} { + catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} + } + if {($user == "root") || ($user == "")} { + set ::tcltest::testConfig(root) 1 + set ::tcltest::testConfig(notRoot) 0 + } + } + + # Set nonBlockFiles constraint: 1 means this platform supports + # setting files into nonblocking mode. + + if {[catch {set f [open defs r]}]} { + set ::tcltest::testConfig(nonBlockFiles) 1 + } else { + if {[catch {fconfigure $f -blocking off}] == 0} { + set ::tcltest::testConfig(nonBlockFiles) 1 + } else { + set ::tcltest::testConfig(nonBlockFiles) 0 + } + close $f + } + + # Set asyncPipeClose constraint: 1 means this platform supports + # async flush and async close on a pipe. + # + # Test for SCO Unix - cannot run async flushing tests because a + # potential problem with select is apparently interfering. + # (Mark Diekhans). + + if {$tcl_platform(platform) == "unix"} { + if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { + set ::tcltest::testConfig(asyncPipeClose) 0 + } else { + set ::tcltest::testConfig(asyncPipeClose) 1 + } + } else { + set ::tcltest::testConfig(asyncPipeClose) 1 + } + + # Test to see if we have a broken version of sprintf with respect + # to the "e" format of floating-point numbers. + + set ::tcltest::testConfig(eformat) 1 + if {[string compare "[format %g 5e-5]" "5e-05"] != 0} { + set ::tcltest::testConfig(eformat) 0 + } + + # Test to see if execed commands such as cat, echo, rm and so forth are + # present on this machine. + + set ::tcltest::testConfig(unixExecs) 1 + if {$tcl_platform(platform) == "macintosh"} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ($tcl_platform(platform) == "windows")} { + if {[catch {exec cat defs}] == 1} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec echo hello}] == 1)} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec sh -c echo hello}] == 1)} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec wc defs}] == 1)} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {$::tcltest::testConfig(unixExecs) == 1} { + exec echo hello > removeMe + if {[catch {exec rm removeMe}] == 1} { + set ::tcltest::testConfig(unixExecs) 0 + } + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec sleep 1}] == 1)} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec fgrep unixExecs defs}] == 1)} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec ps}] == 1)} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec echo abc > removeMe}] == 0) && \ + ([catch {exec chmod 644 removeMe}] == 1) && \ + ([catch {exec rm removeMe}] == 0)} { + set ::tcltest::testConfig(unixExecs) 0 + } else { + catch {exec rm -f removeMe} + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec mkdir removeMe}] == 1)} { + set ::tcltest::testConfig(unixExecs) 0 + } else { + catch {exec rm -r removeMe} + } + } +} + +::tcltest::initConfig + + +# ::tcltest::processCmdLineArgs -- +# +# Use command line args to set the verbose, skip, and +# match variables. This procedure must be run after +# constraints are initialized, because some constraints can be +# overridden. +# +# Arguments: +# none +# +# Results: +# ::tcltest::verbose is set to <value> + +proc ::tcltest::processCmdLineArgs {} { + global argv + + # The "argv" var doesn't exist in some cases, so use {} + # The "argv" var doesn't exist in some cases. + + if {(![info exists argv]) || ([llength $argv] < 2)} { + set flagArray {} + } else { + set flagArray $argv + } + + if {[catch {array set flag $flagArray}]} { + puts stderr "Error: odd number of command line args specified:" + puts stderr " $argv" + exit + } + + # Allow for 1-char abbreviations, where applicable (e.g., -match == -m). + # Note that -verbose cannot be abbreviated to -v in wish because it + # conflicts with the wish option -visual. + + foreach arg {-verbose -match -skip -constraints} { + set abbrev [string range $arg 0 1] + if {([info exists flag($abbrev)]) && \ + ([lsearch -exact $flagArray $arg] < \ + [lsearch -exact $flagArray $abbrev])} { + set flag($arg) $flag($abbrev) + } + } + + # Set ::tcltest::workingDir to [pwd]. + # Save the names of files that already exist in ::tcltest::workingDir. + + set ::tcltest::workingDir [pwd] + foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] { + lappend ::tcltest::filesExisted [file tail $file] + } + + # Set ::tcltest::verbose to the arg of the -verbose flag, if given + + if {[info exists flag(-verbose)]} { + set ::tcltest::verbose $flag(-verbose) + } + + # Set ::tcltest::match to the arg of the -match flag, if given + + if {[info exists flag(-match)]} { + set ::tcltest::match $flag(-match) + } + + # Set ::tcltest::skip to the arg of the -skip flag, if given + + if {[info exists flag(-skip)]} { + set ::tcltest::skip $flag(-skip) + } + + # Use the -constraints flag, if given, to turn on constraints that are + # turned off by default: userInteractive knownBug nonPortable. This + # code fragment must be run after constraints are initialized. + + if {[info exists flag(-constraints)]} { + foreach elt $flag(-constraints) { + set ::tcltest::testConfig($elt) 1 + } + } +} + +::tcltest::processCmdLineArgs + + +# ::tcltest::cleanupTests -- +# +# Remove files and dirs created using the makeFile and makeDirectory +# commands since the last time this proc was invoked. +# +# Print the names of the files created without the makeFile command +# since the tests were invoked. +# +# Print the number tests (total, passed, failed, and skipped) since the +# tests were invoked. +# + +proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { + set tail [file tail [info script]] + + # Remove files and directories created by the :tcltest::makeFile and + # ::tcltest::makeDirectory procedures. + # Record the names of files in ::tcltest::workingDir that were not + # pre-existing, and associate them with the test file that created them. + + if {!$calledFromAllFile} { + + foreach file $::tcltest::filesMade { + if {[file exists $file]} { + catch {file delete -force $file} + } + } + set currentFiles {} + foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] { + lappend currentFiles [file tail $file] + } + set newFiles {} + foreach file $currentFiles { + if {[lsearch -exact $::tcltest::filesExisted $file] == -1} { + lappend newFiles $file + } + } + set ::tcltest::filesExisted $currentFiles + if {[llength $newFiles] > 0} { + set ::tcltest::createdNewFiles($tail) $newFiles + } + } + + if {$calledFromAllFile || $::tcltest::testSingleFile} { + + # print stats + + puts -nonewline stdout "$tail:" + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + puts -nonewline stdout "\t$index\t$::tcltest::numTests($index)" + } + puts stdout "" + + # print number test files sourced + # print names of files that ran tests which failed + + if {$calledFromAllFile} { + puts stdout "Sourced $::tcltest::numTestFiles Test Files." + set ::tcltest::numTestFiles 0 + if {[llength $::tcltest::failFiles] > 0} { + puts stdout "Files with failing tests: $::tcltest::failFiles" + set ::tcltest::failFiles {} + } + } + + # if any tests were skipped, print the constraints that kept them + # from running. + + set constraintList [array names ::tcltest::skippedBecause] + if {[llength $constraintList] > 0} { + puts stdout "Number of tests skipped for each constraint:" + foreach constraint [lsort $constraintList] { + puts stdout \ + "\t$::tcltest::skippedBecause($constraint)\t$constraint" + unset ::tcltest::skippedBecause($constraint) + } + } + + # report the names of test files in ::tcltest::createdNewFiles, and + # reset the array to be empty. + + set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]] + if {[llength $testFilesThatTurded] > 0} { + puts stdout "Warning: test files left files behind:" + foreach testFile $testFilesThatTurded { + puts "\t$testFile:\t$::tcltest::createdNewFiles($testFile)" + unset ::tcltest::createdNewFiles($testFile) + } + } + + # reset filesMade, filesExisted, and numTests + + set ::tcltest::filesMade {} + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + set ::tcltest::numTests($index) 0 + } + + # exit only if running Tk in non-interactive mode + + global tk_version tcl_interactive + if {[info exists tk_version] && !$tcl_interactive} { + exit + } + } else { + + # if we're deferring stat-reporting until all files are sourced, + # then add current file to failFile list if any tests in this file + # failed + + incr ::tcltest::numTestFiles + if {($::tcltest::currentFailure) && \ + ([lsearch -exact $::tcltest::failFiles $tail] == -1)} { + lappend ::tcltest::failFiles $tail + } + set ::tcltest::currentFailure false + } +} + + +# test -- +# +# This procedure runs a test and prints an error message if the test fails. +# If ::tcltest::verbose has been set, it also prints a message even if the +# test succeeds. The test will be skipped if it doesn't match the +# ::tcltest::match variable, if it matches an element in +# ::tcltest::skip, or if one of the elements of "constraints" turns +# out not to be true. +# +# Arguments: +# name - Name of test, in the form foo-1.2. +# description - Short textual description of the test, to +# help humans understand what it does. +# constraints - A list of one or more keywords, each of +# which must be the name of an element in +# the array "::tcltest::testConfig". If any of these +# elements is zero, the test is skipped. +# This argument may be omitted. +# script - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. +# expectedAnswer - Expected result from script. + +proc ::tcltest::test {name description script expectedAnswer args} { + incr ::tcltest::numTests(Total) + + # skip the test if it's name matches an element of skip + + foreach pattern $::tcltest::skip { + if {[string match $pattern $name]} { + incr ::tcltest::numTests(Skipped) + return + } + } + # skip the test if it's name doesn't match any element of match + + if {[llength $::tcltest::match] > 0} { + set ok 0 + foreach pattern $::tcltest::match { + if {[string match $pattern $name]} { + set ok 1 + break + } + } + if {!$ok} { + incr ::tcltest::numTests(Skipped) + return + } + } + set i [llength $args] + if {$i == 0} { + set constraints {} + } elseif {$i == 1} { + + # "constraints" argument exists; shuffle arguments down, then + # make sure that the constraints are satisfied. + + set constraints $script + set script $expectedAnswer + set expectedAnswer [lindex $args 0] + set doTest 0 + if {[string match {*[$\[]*} $constraints] != 0} { + + # full expression, e.g. {$foo > [info tclversion]} + + catch {set doTest [uplevel #0 expr $constraints]} + + } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { + + # something like {a || b} should be turned into + # $::tcltest::testConfig(a) || $::tcltest::testConfig(b). + + regsub -all {[.a-zA-Z0-9]+} $constraints \ + {$::tcltest::testConfig(&)} c + catch {set doTest [eval expr $c]} + } else { + + # just simple constraints such as {unixOnly fonts}. + + set doTest 1 + foreach constraint $constraints { + if {![info exists ::tcltest::testConfig($constraint)] + || !$::tcltest::testConfig($constraint)} { + set doTest 0 + + # store the constraint that kept the test from running + + set constraints $constraint + break + } + } + } + if {$doTest == 0} { + incr ::tcltest::numTests(Skipped) + if {[string first s $::tcltest::verbose] != -1} { + puts stdout "++++ $name SKIPPED: $constraints" + } + + # add the constraint to the list of constraints the kept tests + # from running + + if {[info exists ::tcltest::skippedBecause($constraints)]} { + incr ::tcltest::skippedBecause($constraints) + } else { + set ::tcltest::skippedBecause($constraints) 1 + } + return + } + } else { + error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\"" + } + memory tag $name + set code [catch {uplevel $script} actualAnswer] + if {$code != 0 || [string compare $actualAnswer $expectedAnswer] != 0} { + incr ::tcltest::numTests(Failed) + set ::tcltest::currentFailure true + if {[string first b $::tcltest::verbose] == -1} { + set script "" + } + puts stdout "\n==== $name $description FAILED" + if {$script != ""} { + puts stdout "==== Contents of test case:" + puts stdout $script + } + if {$code != 0} { + if {$code == 1} { + puts stdout "==== Test generated error:" + puts stdout $actualAnswer + } elseif {$code == 2} { + puts stdout "==== Test generated return exception; result was:" + puts stdout $actualAnswer + } elseif {$code == 3} { + puts stdout "==== Test generated break exception" + } elseif {$code == 4} { + puts stdout "==== Test generated continue exception" + } else { + puts stdout "==== Test generated exception $code; message was:" + puts stdout $actualAnswer + } + } else { + puts stdout "---- Result was:\n$actualAnswer" + } + puts stdout "---- Result should have been:\n$expectedAnswer" + puts stdout "==== $name FAILED\n" + } else { + incr ::tcltest::numTests(Passed) + if {[string first p $::tcltest::verbose] != -1} { + puts stdout "++++ $name PASSED" + } + } +} + +# ::tcltest::dotests -- +# +# takes two arguments--the name of the test file (such +# as "parse.test"), and a pattern selecting the tests you want to +# execute. It sets ::tcltest::matching to the second argument, calls +# "source" on the file specified in the first argument, and restores +# ::tcltest::matching to its pre-call value at the end. +# +# Arguments: +# file name of tests file to source +# args pattern selecting the tests you want to execute +# +# Results: +# none + +proc ::tcltest::dotests {file args} { + set savedTests $::tcltest::match + set ::tcltest::match $args + source $file + set ::tcltest::match $savedTests +} + +proc ::tcltest::openfiles {} { + if {[catch {testchannel open} result]} { + return {} + } + return $result +} + +proc ::tcltest::leakfiles {old} { + if {[catch {testchannel open} new]} { + return {} + } + set leak {} + foreach p $new { + if {[lsearch $old $p] < 0} { + lappend leak $p + } + } + return $leak +} + +set ::tcltest::saveState {} + +proc ::tcltest::saveState {} { + uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]} +} + +proc ::tcltest::restoreState {} { + foreach p [info procs] { + if {[lsearch [lindex $::tcltest::saveState 0] $p] < 0} { + rename $p {} + } + } + foreach p [uplevel #0 {info vars}] { + if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} { + uplevel #0 "unset $p" + } + } +} + +proc ::tcltest::normalizeMsg {msg} { + regsub "\n$" [string tolower $msg] "" msg + regsub -all "\n\n" $msg "\n" msg + regsub -all "\n\}" $msg "\}" msg + return $msg +} + +# makeFile -- +# +# Create a new file with the name <name>, and write <contents> to it. +# +# If this file hasn't been created via makeFile since the last time +# cleanupTests was called, add it to the $filesMade list, so it will +# be removed by the next call to cleanupTests. +# +proc ::tcltest::makeFile {contents name} { + set fd [open $name w] + fconfigure $fd -translation lf + if {[string index $contents [expr {[string length $contents] - 1}]] == "\n"} { + puts -nonewline $fd $contents + } else { + puts $fd $contents + } + close $fd + + set fullName [file join [pwd] $name] + if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { + lappend ::tcltest::filesMade $fullName + } +} + +proc ::tcltest::removeFile {name} { + file delete $name +} + +# makeDirectory -- +# +# Create a new dir with the name <name>. +# +# If this dir hasn't been created via makeDirectory since the last time +# cleanupTests was called, add it to the $directoriesMade list, so it will +# be removed by the next call to cleanupTests. +# +proc ::tcltest::makeDirectory {name} { + file mkdir $name + + set fullName [file join [pwd] $name] + if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { + lappend ::tcltest::filesMade $fullName + } +} + +proc ::tcltest::removeDirectory {name} { + file delete -force $name +} + +proc ::tcltest::viewFile {name} { + global tcl_platform + if {($tcl_platform(platform) == "macintosh") || \ + ($::tcltest::testConfig(unixExecs) == 0)} { + set f [open $name] + set data [read -nonewline $f] + close $f + return $data + } else { + exec cat $name + } +} + +# +# Construct a string that consists of the requested sequence of bytes, +# as opposed to a string of properly formed UTF-8 characters. +# This allows the tester to +# 1. Create denormalized or improperly formed strings to pass to C procedures +# that are supposed to accept strings with embedded NULL bytes. +# 2. Confirm that a string result has a certain pattern of bytes, for instance +# to confirm that "\xe0\0" in a Tcl script is stored internally in +# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". +# +# Generally, it's a bad idea to examine the bytes in a Tcl string or to +# construct improperly formed strings in this manner, because it involves +# exposing that Tcl uses UTF-8 internally. + +proc ::tcltest::bytestring {string} { + encoding convertfrom identity $string +} + +# Locate tcltest executable + +if {![info exists tk_version]} { + set tcltest [info nameofexecutable] + + if {$tcltest == "{}"} { + set tcltest {} + } +} + +set ::tcltest::testConfig(stdio) 0 +catch { + catch {file delete -force tmp} + set f [open tmp w] + puts $f { + exit + } + close $f + + set f [open "|[list $tcltest tmp]" r] + close $f + + set ::tcltest::testConfig(stdio) 1 +} +catch {file delete -force tmp} + +# Deliberately call the socket with the wrong number of arguments. The error +# message you get will indicate whether sockets are available on this system. + +catch {socket} msg +set ::tcltest::testConfig(socket) \ + [expr {$msg != "sockets are not available on this system"}] + +# +# Internationalization / ISO support procs -- dl +# + +if {[info commands testlocale]==""} { + + # No testlocale command, no tests... + # (it could be that we are a sub interp and we could just load + # the Tcltest package but that would interfere with tests + # that tests packages/loading in slaves...) + + set ::tcltest::testConfig(hasIsoLocale) 0 +} else { + proc ::tcltest::set_iso8859_1_locale {} { + set ::tcltest::previousLocale [testlocale ctype] + testlocale ctype $::tcltest::isoLocale + } + + proc ::tcltest::restore_locale {} { + testlocale ctype $::tcltest::previousLocale + } + + if {![info exists ::tcltest::isoLocale]} { + set ::tcltest::isoLocale fr + switch $tcl_platform(platform) { + "unix" { + + # Try some 'known' values for some platforms: + + switch -exact -- $tcl_platform(os) { + "FreeBSD" { + set ::tcltest::isoLocale fr_FR.ISO_8859-1 + } + HP-UX { + set ::tcltest::isoLocale fr_FR.iso88591 + } + Linux - + IRIX { + set ::tcltest::isoLocale fr + } + default { + + # Works on SunOS 4 and Solaris, and maybe others... + # define it to something else on your system + #if you want to test those. + + set ::tcltest::isoLocale iso_8859_1 + } + } + } + "windows" { + set ::tcltest::isoLocale French + } + } + } + + set ::tcltest::testConfig(hasIsoLocale) \ + [string length [::tcltest::set_iso8859_1_locale]] + ::tcltest::restore_locale +} + +# +# procedures that are Tk specific +# + +if {[info exists tk_version]} { + + # If the main window isn't already mapped (e.g. because the tests are + # being run automatically) , specify a precise size for it so that the + # user won't have to position it manually. + + if {![winfo ismapped .]} { + wm geometry . +0+0 + update + } + + # The following code can be used to perform tests involving a second + # process running in the background. + + # Locate the tktest executable + + set ::tcltest::tktest [info nameofexecutable] + if {$::tcltest::tktest == "{}"} { + set ::tcltest::tktest {} + puts stdout \ + "Unable to find tktest executable, skipping multiple process tests." + } + + # Create background process + + proc ::tcltest::setupbg args { + if {$::tcltest::tktest == ""} { + error "you're not running tktest so setupbg should not have been called" + } + if {[info exists ::tcltest::fd] && ($::tcltest::fd != "")} { + cleanupbg + } + + # The following code segment cannot be run on Windows prior + # to Tk 8.1b3 due to a channel I/O bug (bugID 1495). + + global tcl_platform + set ::tcltest::fd [open "|[list $::tcltest::tktest -geometry +0+0 -name tktest] $args" r+] + puts $::tcltest::fd "puts foo; flush stdout" + flush $::tcltest::fd + if {[gets $::tcltest::fd data] < 0} { + error "unexpected EOF from \"$::tcltest::tktest\"" + } + if {[string compare $data foo]} { + error "unexpected output from background process \"$data\"" + } + fileevent $::tcltest::fd readable bgReady + } + + # Send a command to the background process, catching errors and + # flushing I/O channels + + proc ::tcltest::dobg {command} { + puts $::tcltest::fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout" + flush $::tcltest::fd + set ::tcltest::bgDone 0 + set ::tcltest::bgData {} + tkwait variable ::tcltest::bgDone + set ::tcltest::bgData + } + + # Data arrived from background process. Check for special marker + # indicating end of data for this command, and make data available + # to dobg procedure. + + proc ::tcltest::bgReady {} { + set x [gets $::tcltest::fd] + if {[eof $::tcltest::fd]} { + fileevent $::tcltest::fd readable {} + set ::tcltest::bgDone 1 + } elseif {$x == "**DONE**"} { + set ::tcltest::bgDone 1 + } else { + append ::tcltest::bgData $x + } + } + + # Exit the background process, and close the pipes + + proc ::tcltest::cleanupbg {} { + catch { + puts $::tcltest::fd "exit" + close $::tcltest::fd + } + set ::tcltest::fd "" + } + + # Clean up focus after using generate event, which + # can leave the window manager with the wrong impression + # about who thinks they have the focus. (BW) + + proc ::tcltest::fixfocus {} { + catch {destroy .focus} + toplevel .focus + wm geometry .focus +0+0 + entry .focus.e + .focus.e insert 0 "fixfocus" + pack .focus.e + update + focus -force .focus.e + destroy .focus + } +} + +# threadReap -- +# +# Kill all threads except for the main thread. +# Do nothing if testthread is not defined. +# +# Arguments: +# none. +# +# Results: +# Returns the number of existing threads. + +if {[info commands testthread] != {}} { + proc ::tcltest::threadReap {} { + testthread errorproc ThreadNullError + while {[llength [testthread names]] > 1} { + foreach tid [testthread names] { + if {$tid != $::tcltest::mainThread} { + catch {testthread send -async $tid {testthread exit}} + update + } + } + } + testthread errorproc ThreadError + return [llength [testthread names]] + } +} else { + proc ::tcltest::threadReap {} { + return 1 + } +} + +# Need to catch the import because it fails if defs.tcl is sourced +# more than once. + +catch {namespace import ::tcltest::*} +return diff --git a/tk/tests/entry.test b/tk/tests/entry.test index 0a45f2086e1..db7d8a5b0a6 100644 --- a/tk/tests/entry.test +++ b/tk/tests/entry.test @@ -3,23 +3,23 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\"" puts "image, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[info procs test] != "test"} { - source defs -} - foreach i [winfo children .] { destroy $i } @@ -51,6 +51,7 @@ option add *Entry.font {Helvetica -12} entry .e -bd 2 -relief sunken pack .e update + set i 1 foreach test { {-background #ff0000 #ff0000 non-existent @@ -74,25 +75,25 @@ foreach test { {-insertofftime 100 100 3.2 {expected integer but got "3.2"}} {-insertontime 100 100 3.2 {expected integer but got "3.2"}} {-justify right right bogus {bad justification "bogus": must be left, right, or center}} - {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} + {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}} {-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}} {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}} {-show * * {} {}} - {-state normal normal bogus {bad state value "bogus": must be normal or disabled}} + {-state n normal bogus {bad state "bogus": must be disabled or normal}} {-takefocus "any string" "any string" {} {}} {-textvariable i i {} {}} {-width 402 402 3p {expected integer but got "3p"}} {-xscrollcommand {Some command} {Some command} {} {}} } { set name [lindex $test 0] - test entry-1.1 {configuration options} { + test entry-1.$i {configuration options} { .e configure $name [lindex $test 1] list [lindex [.e configure $name] 4] [.e cget $name] } [list [lindex $test 2] [lindex $test 2]] incr i if {[lindex $test 3] != ""} { - test entry-1.2 {configuration options} { + test entry-1.$i {configuration options} { list [catch {.e configure $name [lindex $test 3]} msg] $msg } [list 1 [lindex $test 4]] } @@ -128,6 +129,7 @@ update set cx [font measure $fixed a] set cy [font metrics $fixed -linespace] +set ux [font measure $fixed \u4e4e] test entry-3.1 {EntryWidgetCmd procedure} { list [catch {.e} msg] $msg @@ -145,66 +147,106 @@ test entry-3.5 {EntryWidgetCmd procedure, "bbox" widget command} { .e delete 0 end .e bbox 0 } [list 5 5 0 $cy] -test entry-3.6 {EntryWidgetCmd procedure, "bbox" widget command} {fonts} { +test entry-3.6 {EntryWidgetCmd procedure, "bbox" widget command} { + # Tcl_UtfAtIndex(): no utf chars + + .e delete 0 end + .e insert 0 "abc" + list [.e bbox 3] [.e bbox end] +} [list "[expr 5+2*$cx] 5 $cx $cy" "[expr 5+2*$cx] 5 $cx $cy"] +test entry-3.7 {EntryWidgetCmd procedure, "bbox" widget command} { + # Tcl_UtfAtIndex(): utf at end .e delete 0 end - .e insert 0 "abcdefghijklmnop" - list [.e bbox 0] [.e bbox 1] [.e bbox end] -} [list "5 5 $cx $cy" "[expr 5+$cx] 5 $cx $cy" "[expr 5+15*$cx] 5 $cx $cy"] -test entry-3.7 {EntryWidgetCmd procedure, "cget" widget command} { + .e insert 0 "ab\u4e4e" + .e bbox end +} "[expr 5+2*$cx] 5 $ux $cy" +test entry-3.8 {EntryWidgetCmd procedure, "bbox" widget command} { + # Tcl_UtfAtIndex(): utf before index + .e delete 0 end + .e insert 0 "ab\u4e4ec" + .e bbox 3 +} "[expr 5+2*$cx+$ux] 5 $cx $cy" +test entry-3.9 {EntryWidgetCmd procedure, "bbox" widget command} { + # Tcl_UtfAtIndex(): no chars + .e delete 0 end + .e bbox end +} "5 5 0 $cy" +test entry-3.10 {EntryWidgetCmd procedure, "bbox" widget command} { + .e delete 0 end + .e insert 0 "abcdefghij\u4e4eklmnop" + list [.e bbox 0] [.e bbox 1] [.e bbox 10] [.e bbox end] +} [list "5 5 $cx $cy" "[expr 5+$cx] 5 $cx $cy" "[expr 5+10*$cx] 5 $ux $cy" "[expr 5+$ux+15*$cx] 5 $cx $cy"] +test entry-3.11 {EntryWidgetCmd procedure, "cget" widget command} { list [catch {.e cget} msg] $msg } {1 {wrong # args: should be ".e cget option"}} -test entry-3.8 {EntryWidgetCmd procedure, "cget" widget command} { +test entry-3.12 {EntryWidgetCmd procedure, "cget" widget command} { list [catch {.e cget a b} msg] $msg } {1 {wrong # args: should be ".e cget option"}} -test entry-3.9 {EntryWidgetCmd procedure, "cget" widget command} { +test entry-3.13 {EntryWidgetCmd procedure, "cget" widget command} { list [catch {.e cget -gorp} msg] $msg } {1 {unknown option "-gorp"}} -test entry-3.10 {EntryWidgetCmd procedure, "cget" widget command} { +test entry-3.14 {EntryWidgetCmd procedure, "cget" widget command} { .e configure -bd 4 .e cget -bd } {4} -test entry-3.11 {EntryWidgetCmd procedure, "configure" widget command} { +test entry-3.15 {EntryWidgetCmd procedure, "configure" widget command} { llength [.e configure] -} {28} -test entry-3.12 {EntryWidgetCmd procedure, "configure" widget command} { +} {33} +test entry-3.16 {EntryWidgetCmd procedure, "configure" widget command} { list [catch {.e configure -foo} msg] $msg } {1 {unknown option "-foo"}} -test entry-3.13 {EntryWidgetCmd procedure, "configure" widget command} { +test entry-3.17 {EntryWidgetCmd procedure, "configure" widget command} { .e configure -bd 4 .e configure -bg #ffffff lindex [.e configure -bd] 4 } {4} -test entry-3.14 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.18 {EntryWidgetCmd procedure, "delete" widget command} { list [catch {.e delete} msg] $msg } {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}} -test entry-3.15 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.19 {EntryWidgetCmd procedure, "delete" widget command} { list [catch {.e delete a b c} msg] $msg } {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}} -test entry-3.16 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.20 {EntryWidgetCmd procedure, "delete" widget command} { list [catch {.e delete foo} msg] $msg } {1 {bad entry index "foo"}} -test entry-3.17 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} { list [catch {.e delete 0 bar} msg] $msg } {1 {bad entry index "bar"}} -test entry-3.18 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.22 {EntryWidgetCmd procedure, "delete" widget command} { .e delete 0 end .e insert end "01234567890" .e delete 2 4 .e get } {014567890} -test entry-3.19 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.23 {EntryWidgetCmd procedure, "delete" widget command} { .e delete 0 end .e insert end "01234567890" .e delete 6 .e get } {0123457890} -test entry-3.20 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.24 {EntryWidgetCmd procedure, "delete" widget command} { + # UTF + set x {} + .e delete 0 end + .e insert end "01234\u4e4e67890" + .e delete 6 + lappend x [.e get] + .e delete 0 end + .e insert end "012345\u4e4e7890" + .e delete 6 + lappend x [.e get] + .e delete 0 end + .e insert end "0123456\u4e4e890" + .e delete 6 + lappend x [.e get] +} [list "01234\u4e4e7890" "0123457890" "012345\u4e4e890"] +test entry-3.25 {EntryWidgetCmd procedure, "delete" widget command} { .e delete 0 end .e insert end "01234567890" .e delete 6 5 .e get } {01234567890} -test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.26 {EntryWidgetCmd procedure, "delete" widget command} { .e delete 0 end .e insert end "01234567890" .e configure -state disabled @@ -212,49 +254,55 @@ test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} { .e configure -state normal .e get } {01234567890} -test entry-3.22 {EntryWidgetCmd procedure, "get" widget command} { +test entry-3.27 {EntryWidgetCmd procedure, "get" widget command} { list [catch {.e get foo} msg] $msg } {1 {wrong # args: should be ".e get"}} -test entry-3.23 {EntryWidgetCmd procedure, "icursor" widget command} { +test entry-3.28 {EntryWidgetCmd procedure, "icursor" widget command} { list [catch {.e icursor} msg] $msg } {1 {wrong # args: should be ".e icursor pos"}} -test entry-3.24 {EntryWidgetCmd procedure, "icursor" widget command} { +test entry-3.29 {EntryWidgetCmd procedure, "icursor" widget command} { list [catch {.e icursor foo} msg] $msg } {1 {bad entry index "foo"}} -test entry-3.25 {EntryWidgetCmd procedure, "icursor" widget command} { +test entry-3.30 {EntryWidgetCmd procedure, "icursor" widget command} { .e delete 0 end .e insert end "01234567890" .e icursor 4 .e index insert } {4} -test entry-3.26 {EntryWidgetCmd procedure, "index" widget command} { +test entry-3.31 {EntryWidgetCmd procedure, "index" widget command} { list [catch {.e in} msg] $msg -} {1 {bad option "in": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, or xview}} -test entry-3.27 {EntryWidgetCmd procedure, "index" widget command} { +} {1 {ambiguous option "in": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, validate, or xview}} +test entry-3.32 {EntryWidgetCmd procedure, "index" widget command} { list [catch {.e index} msg] $msg } {1 {wrong # args: should be ".e index string"}} -test entry-3.28 {EntryWidgetCmd procedure, "index" widget command} { +test entry-3.33 {EntryWidgetCmd procedure, "index" widget command} { list [catch {.e index foo} msg] $msg } {1 {bad entry index "foo"}} -test entry-3.29 {EntryWidgetCmd procedure, "index" widget command} { +test entry-3.34 {EntryWidgetCmd procedure, "index" widget command} { list [catch {.e index 0} msg] $msg } {0 0} -test entry-3.30 {EntryWidgetCmd procedure, "insert" widget command} { +test entry-3.35 {EntryWidgetCmd procedure, "index" widget command} { + # UTF + .e delete 0 end + .e insert 0 abc\u4e4e\u0153def + list [.e index 3] [.e index 4] [.e index end] +} {3 4 8} +test entry-3.36 {EntryWidgetCmd procedure, "insert" widget command} { list [catch {.e insert a} msg] $msg } {1 {wrong # args: should be ".e insert index text"}} -test entry-3.31 {EntryWidgetCmd procedure, "insert" widget command} { +test entry-3.37 {EntryWidgetCmd procedure, "insert" widget command} { list [catch {.e insert a b c} msg] $msg } {1 {wrong # args: should be ".e insert index text"}} -test entry-3.32 {EntryWidgetCmd procedure, "insert" widget command} { +test entry-3.38 {EntryWidgetCmd procedure, "insert" widget command} { list [catch {.e insert foo Text} msg] $msg } {1 {bad entry index "foo"}} -test entry-3.33 {EntryWidgetCmd procedure, "insert" widget command} { +test entry-3.39 {EntryWidgetCmd procedure, "insert" widget command} { .e delete 0 end .e insert end "01234567890" .e insert 3 xxx .e get } {012xxx34567890} -test entry-3.34 {EntryWidgetCmd procedure, "insert" widget command} { +test entry-3.40 {EntryWidgetCmd procedure, "insert" widget command} { .e delete 0 end .e insert end "01234567890" .e configure -state disabled @@ -262,24 +310,24 @@ test entry-3.34 {EntryWidgetCmd procedure, "insert" widget command} { .e configure -state normal .e get } {01234567890} -test entry-3.35 {EntryWidgetCmd procedure, "insert" widget command} { +test entry-3.41 {EntryWidgetCmd procedure, "insert" widget command} { list [catch {.e insert a b c} msg] $msg } {1 {wrong # args: should be ".e insert index text"}} -test entry-3.36 {EntryWidgetCmd procedure, "scan" widget command} { +test entry-3.42 {EntryWidgetCmd procedure, "scan" widget command} { list [catch {.e scan a} msg] $msg } {1 {wrong # args: should be ".e scan mark|dragto x"}} -test entry-3.37 {EntryWidgetCmd procedure, "scan" widget command} { +test entry-3.43 {EntryWidgetCmd procedure, "scan" widget command} { list [catch {.e scan a b c} msg] $msg } {1 {wrong # args: should be ".e scan mark|dragto x"}} -test entry-3.38 {EntryWidgetCmd procedure, "scan" widget command} { +test entry-3.44 {EntryWidgetCmd procedure, "scan" widget command} { list [catch {.e scan foobar 20} msg] $msg } {1 {bad scan option "foobar": must be mark or dragto}} -test entry-3.39 {EntryWidgetCmd procedure, "scan" widget command} { +test entry-3.45 {EntryWidgetCmd procedure, "scan" widget command} { list [catch {.e scan mark 20.1} msg] $msg } {1 {expected integer but got "20.1"}} # This test is non-portable because character sizes vary. -test entry-3.40 {EntryWidgetCmd procedure, "scan" widget command} {fonts} { +test entry-3.46 {EntryWidgetCmd procedure, "scan" widget command} {fonts} { .e delete 0 end update .e insert end "This is quite a long string, in fact a " @@ -288,16 +336,16 @@ test entry-3.40 {EntryWidgetCmd procedure, "scan" widget command} {fonts} { .e scan dragto 28 .e index @0 } {2} -test entry-3.41 {EntryWidgetCmd procedure, "select" widget command} { +test entry-3.47 {EntryWidgetCmd procedure, "select" widget command} { list [catch {.e select} msg] $msg -} {1 {wrong # args: should be ".e select option ?index?"}} -test entry-3.42 {EntryWidgetCmd procedure, "select" widget command} { +} {1 {wrong # args: should be ".e selection option ?index?"}} +test entry-3.48 {EntryWidgetCmd procedure, "select" widget command} { list [catch {.e select foo} msg] $msg } {1 {bad selection option "foo": must be adjust, clear, from, present, range, or to}} -test entry-3.43 {EntryWidgetCmd procedure, "select clear" widget command} { +test entry-3.49 {EntryWidgetCmd procedure, "select clear" widget command} { list [catch {.e select clear gorp} msg] $msg } {1 {wrong # args: should be ".e selection clear"}} -test entry-3.44 {EntryWidgetCmd procedure, "select clear" widget command} { +test entry-3.50 {EntryWidgetCmd procedure, "select clear" widget command} { .e delete 0 end .e insert end "0123456789" .e select from 1 @@ -306,17 +354,17 @@ test entry-3.44 {EntryWidgetCmd procedure, "select clear" widget command} { .e select clear list [catch {selection get} msg] $msg [selection own] } {1 {PRIMARY selection doesn't exist or form "STRING" not defined} .e} -test entry-3.45 {EntryWidgetCmd procedure, "selection present" widget command} { +test entry-3.51 {EntryWidgetCmd procedure, "selection present" widget command} { list [catch {.e selection present foo} msg] $msg } {1 {wrong # args: should be ".e selection present"}} -test entry-3.46 {EntryWidgetCmd procedure, "selection present" widget command} { +test entry-3.52 {EntryWidgetCmd procedure, "selection present" widget command} { .e delete 0 end .e insert end 0123456789 .e select from 3 .e select to 6 .e selection present } {1} -test entry-3.47 {EntryWidgetCmd procedure, "selection present" widget command} { +test entry-3.53 {EntryWidgetCmd procedure, "selection present" widget command} { .e delete 0 end .e insert end 0123456789 .e select from 3 @@ -325,7 +373,7 @@ test entry-3.47 {EntryWidgetCmd procedure, "selection present" widget command} { .e selection present } {1} .e configure -exportselection true -test entry-3.48 {EntryWidgetCmd procedure, "selection present" widget command} { +test entry-3.54 {EntryWidgetCmd procedure, "selection present" widget command} { .e delete 0 end .e insert end 0123456789 .e select from 3 @@ -333,13 +381,13 @@ test entry-3.48 {EntryWidgetCmd procedure, "selection present" widget command} { .e delete 0 end .e selection present } {0} -test entry-3.49 {EntryWidgetCmd procedure, "selection adjust" widget command} { +test entry-3.55 {EntryWidgetCmd procedure, "selection adjust" widget command} { list [catch {.e select adjust x} msg] $msg } {1 {bad entry index "x"}} -test entry-3.50 {EntryWidgetCmd procedure, "selection adjust" widget command} { +test entry-3.56 {EntryWidgetCmd procedure, "selection adjust" widget command} { list [catch {.e select adjust 2 3} msg] $msg } {1 {wrong # args: should be ".e selection adjust index"}} -test entry-3.51 {EntryWidgetCmd procedure, "selection adjust" widget command} { +test entry-3.57 {EntryWidgetCmd procedure, "selection adjust" widget command} { .e delete 0 end .e insert end "0123456789" .e select from 1 @@ -348,7 +396,7 @@ test entry-3.51 {EntryWidgetCmd procedure, "selection adjust" widget command} { .e select adjust 4 selection get } {123} -test entry-3.52 {EntryWidgetCmd procedure, "selection adjust" widget command} { +test entry-3.58 {EntryWidgetCmd procedure, "selection adjust" widget command} { .e delete 0 end .e insert end "0123456789" .e select from 1 @@ -357,16 +405,16 @@ test entry-3.52 {EntryWidgetCmd procedure, "selection adjust" widget command} { .e select adjust 2 selection get } {234} -test entry-3.53 {EntryWidgetCmd procedure, "selection from" widget command} { +test entry-3.59 {EntryWidgetCmd procedure, "selection from" widget command} { list [catch {.e select from 2 3} msg] $msg } {1 {wrong # args: should be ".e selection from index"}} -test entry-3.54 {EntryWidgetCmd procedure, "selection range" widget command} { +test entry-3.60 {EntryWidgetCmd procedure, "selection range" widget command} { list [catch {.e select range 2} msg] $msg } {1 {wrong # args: should be ".e selection range start end"}} -test entry-3.55 {EntryWidgetCmd procedure, "selection range" widget command} { +test entry-3.61 {EntryWidgetCmd procedure, "selection range" widget command} { list [catch {.e selection range 2 3 4} msg] $msg } {1 {wrong # args: should be ".e selection range start end"}} -test entry-3.56 {EntryWidgetCmd procedure, "selection range" widget command} { +test entry-3.62 {EntryWidgetCmd procedure, "selection range" widget command} { .e delete 0 end .e insert end 0123456789 .e select from 1 @@ -374,7 +422,7 @@ test entry-3.56 {EntryWidgetCmd procedure, "selection range" widget command} { .e select range 4 4 list [catch {.e index sel.first} msg] $msg } {1 {selection isn't in entry}} -test entry-3.57 {EntryWidgetCmd procedure, "selection range" widget command} { +test entry-3.63 {EntryWidgetCmd procedure, "selection range" widget command} { .e delete 0 end .e insert end 0123456789 .e select from 3 @@ -385,80 +433,94 @@ test entry-3.57 {EntryWidgetCmd procedure, "selection range" widget command} { .e delete 0 end .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." -test entry-3.58 {EntryWidgetCmd procedure, "selection to" widget command} { +test entry-3.64 {EntryWidgetCmd procedure, "selection to" widget command} { list [catch {.e select to 2 3} msg] $msg } {1 {wrong # args: should be ".e selection to index"}} -test entry-3.59 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.65 {EntryWidgetCmd procedure, "xview" widget command} { .e xview 5 .e xview } {0.0537634 0.268817} -test entry-3.60 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.66 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview gorp} msg] $msg } {1 {bad entry index "gorp"}} -test entry-3.61 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.67 {EntryWidgetCmd procedure, "xview" widget command} { .e xview 0 .e icursor 10 .e xview insert .e xview } {0.107527 0.322581} -test entry-3.62 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.68 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview moveto foo bar} msg] $msg } {1 {wrong # args: should be ".e xview moveto fraction"}} -test entry-3.63 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.69 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview moveto foo} msg] $msg } {1 {expected floating-point number but got "foo"}} -test entry-3.64 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.70 {EntryWidgetCmd procedure, "xview" widget command} { .e xview moveto 0.5 .e xview } {0.505376 0.72043} -test entry-3.65 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview scroll 24} msg] $msg } {1 {wrong # args: should be ".e xview scroll number units|pages"}} -test entry-3.66 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview scroll gorp units} msg] $msg } {1 {expected integer but got "gorp"}} -test entry-3.67 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} { .e xview moveto 0 .e xview scroll 1 pages .e xview } {0.193548 0.408602} -test entry-3.68 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.74 {EntryWidgetCmd procedure, "xview" widget command} { .e xview moveto .9 update .e xview scroll -2 p .e xview } {0.397849 0.612903} -test entry-3.69 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.75 {EntryWidgetCmd procedure, "xview" widget command} { .e xview 30 update .e xview scroll 2 units .e index @0 } {32} -test entry-3.70 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.76 {EntryWidgetCmd procedure, "xview" widget command} { .e xview 30 update .e xview scroll -1 units .e index @0 } {29} -test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.77 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview scroll 23 foobars} msg] $msg } {1 {bad argument "foobars": must be units or pages}} -test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.78 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview eat 23 hamburgers} msg] $msg } {1 {unknown option "eat": must be moveto or scroll}} -test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.79 {EntryWidgetCmd procedure, "xview" widget command} { .e xview 0 update .e xview -4 .e index @0 } {0} -test entry-3.74 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.80 {EntryWidgetCmd procedure, "xview" widget command} { .e xview 300 .e index @0 } {73} -test entry-3.75 {EntryWidgetCmd procedure} { +.e insert 10 \u4e4e +test entry-3.81 {EntryWidgetCmd procedure, "xview" widget command} { + # UTF + # If Tcl_NumUtfChars wasn't used, wrong answer would be: + # 0.106383 0.117021 0.117021 + + set x {} + .e xview moveto .1 + lappend x [lindex [.e xview] 0] + .e xview moveto .11 + lappend x [lindex [.e xview] 0] + .e xview moveto .12 + lappend x [lindex [.e xview] 0] +} {0.0957447 0.106383 0.117021} +test entry-3.82 {EntryWidgetCmd procedure} { list [catch {.e gorp} msg] $msg -} {1 {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, or xview}} +} {1 {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, validate, or xview}} # The test below doesn't actually check anything directly, but if run # with Purify or some other memory-allocation-checking program it will @@ -662,7 +724,7 @@ test entry-6.9 {EntryComputeGeometry procedure} {fonts} { update list [winfo reqwidth .e] [winfo reqheight .e] } {25 39} -test entry-6.10 {EntryComputeGeometry procedure} {fonts} { +test entry-6.10 {EntryComputeGeometry procedure} {unixOnly fonts} { catch {destroy .e} entry .e -bd 1 -relief raised -width 0 -show . .e insert 0 12345 @@ -674,6 +736,21 @@ test entry-6.10 {EntryComputeGeometry procedure} {fonts} { .e configure -show "" lappend x [winfo reqwidth .e] } {23 53 43} +test entry-6.11 {EntryComputeGeometry procedure} {pcOnly} { + catch {destroy .e} + entry .e -bd 1 -relief raised -width 0 -show . -font {helvetica 12} + .e insert 0 12345 + pack .e + update + set x [winfo reqwidth .e] + .e configure -show X + lappend x [winfo reqwidth .e] + .e configure -show "" + lappend x [winfo reqwidth .e] +} [list \ + [expr 8+5*[font measure {helvetica 12} .]] \ + [expr 8+5*[font measure {helvetica 12} X]] \ + [expr 8+[font measure {helvetica 12} 12345]]] catch {destroy .e} entry .e -width 10 -font $fixed -textvariable contents -xscrollcommand scroll @@ -1089,52 +1166,62 @@ test entry-13.9 {GetEntryIndex procedure} { list [.e index sel.first] [.e index sel.last] } {1 6} selection clear .e -test entry-13.10 {GetEntryIndex procedure} {pc} { - .e index sel.first -} {1} -test entry-13.11 {GetEntryIndex procedure} {!pc} { +test entry-13.10 {GetEntryIndex procedure} {unixOnly} { + # On unix, when selection is cleared, entry widget's internal + # selection range is reset. + list [catch {.e index sel.first} msg] $msg } {1 {selection isn't in entry}} -test entry-13.12 {GetEntryIndex procedure} {pc} { - list [catch {.e index sbogus} msg] $msg -} {1 {bad entry index "sbogus"}} -test entry-13.13 {GetEntryIndex procedure} {!pc} { +test entry-13.11 {GetEntryIndex procedure} {macOrPc} { + # On mac and pc, when selection is cleared, entry widget remembers + # last selected range. When selection ownership is restored to + # entry, the old range will be rehighlighted. + + list [catch {selection get}] [.e index sel.first] +} {1 1} +test entry-13.12 {GetEntryIndex procedure} {unixOnly} { list [catch {.e index sbogus} msg] $msg } {1 {selection isn't in entry}} -test entry-13.14 {GetEntryIndex procedure} { +test entry-13.13 {GetEntryIndex procedure} {macOrPc} { + list [catch {.e index sbogus} msg] $msg +} {1 {bad entry index "sbogus"}} +test entry-13.14 {GetEntryIndex procedure} {macOrPc} { + list [catch {selection get}] [catch {.e index sbogus}] +} {1 1} +test entry-13.15 {GetEntryIndex procedure} { list [catch {.e index @xyz} msg] $msg } {1 {bad entry index "@xyz"}} -test entry-13.15 {GetEntryIndex procedure} {fonts} { +test entry-13.16 {GetEntryIndex procedure} {fonts} { .e index @4 } {4} -test entry-13.16 {GetEntryIndex procedure} {fonts} { +test entry-13.17 {GetEntryIndex procedure} {fonts} { .e index @11 } {4} -test entry-13.17 {GetEntryIndex procedure} {fonts} { +test entry-13.18 {GetEntryIndex procedure} {fonts} { .e index @12 } {5} -test entry-13.18 {GetEntryIndex procedure} {fonts} { +test entry-13.19 {GetEntryIndex procedure} {fonts} { .e index @[expr [winfo width .e] - 6] } {8} -test entry-13.19 {GetEntryIndex procedure} {fonts} { +test entry-13.20 {GetEntryIndex procedure} {fonts} { .e index @[expr [winfo width .e] - 5] } {9} -test entry-13.20 {GetEntryIndex procedure} { +test entry-13.21 {GetEntryIndex procedure} { .e index @1000 } {9} -test entry-13.21 {GetEntryIndex procedure} { +test entry-13.22 {GetEntryIndex procedure} { list [catch {.e index 1xyz} msg] $msg } {1 {bad entry index "1xyz"}} -test entry-13.22 {GetEntryIndex procedure} { +test entry-13.23 {GetEntryIndex procedure} { .e index -10 } {0} -test entry-13.23 {GetEntryIndex procedure} { +test entry-13.24 {GetEntryIndex procedure} { .e index 12 } {12} -test entry-13.24 {GetEntryIndex procedure} { +test entry-13.25 {GetEntryIndex procedure} { .e index 49 } {21} -test entry-13.25 {GetEntryIndex procedure} {fonts} { +test entry-13.26 {GetEntryIndex procedure} {fonts} { catch {destroy .e} entry .e -show . .e insert 0 XXXYZZY @@ -1199,14 +1286,20 @@ test entry-16.1 {EntryVisibleRange procedure} {fonts} { .e insert 0 ............................. .e xview } {0 0.827586} -test entry-16.2 {EntryVisibleRange procedure} {fonts} { +test entry-15.2 {EntryVisibleRange procedure} {unixOnly fonts} { .e configure -show X .e delete 0 end .e insert 0 ............................. .e xview } {0 0.275862} +test entry-15.3 {EntryVisibleRange procedure} {pcOnly} { + .e configure -show . + .e delete 0 end + .e insert 0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXX + .e xview +} {0 0.827586} .e configure -show "" -test entry-16.3 {EntryVisibleRange procedure} { +test entry-15.4 {EntryVisibleRange procedure} { .e delete 0 end .e xview } {0 1} @@ -1236,34 +1329,194 @@ test entry-17.3 {EntryUpdateScrollbar procedure} { set scrollInfo } {0.315789 0.842105} test entry-17.4 {EntryUpdateScrollbar procedure} { - catch {destroy .e} + destroy .e proc bgerror msg { global x set x $msg } - entry .e -width 5 -xscrollcommand bogus + entry .e -width 5 -xscrollcommand thisisnotacommand pack .e update rename bgerror {} list $x $errorInfo -} {{invalid command name "bogus"} {invalid command name "bogus" +} {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand" while executing -"bogus 0 1" +"thisisnotacommand 0 1" (horizontal scrolling command executed by entry)}} set l [interp hidden] eval destroy [winfo children .] test entry-18.1 {Entry widget vs hiding} { - catch {destroy .e} + destroy .e entry .e interp hide {} .e destroy .e list [winfo children .] [interp hidden] } [list {} $l] - + +## +## Entry widget VALIDATION tests +## + +destroy .e +catch {unset ::e} +catch {unset ::vVals} +entry .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white +pack .e +proc doval {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + return 1 +} + +# The validation tests build each one upon the previous, so cascading +# failures aren't good +# +test entry-19.1 {entry widget validation} { + .e insert 0 a + set ::vVals +} {.e 1 0 a {} a all key} +test entry-19.2 {entry widget validation} { + .e insert 1 b + set ::vVals +} {.e 1 1 ab a b all key} +test entry-19.3 {entry widget validation} { + .e insert end c + set ::vVals +} {.e 1 2 abc ab c all key} +test entry-19.4 {entry widget validation} { + .e insert 1 123 + list $::vVals $::e +} {{.e 1 1 a123bc abc 123 all key} a123bc} +test entry-19.5 {entry widget validation} { + .e delete 2 + set ::vVals +} {.e 0 2 a13bc a123bc 2 all key} +test entry-19.6 {entry widget validation} { + .e configure -validate key + .e delete 1 3 + set ::vVals +} {.e 0 1 abc a13bc 13 key key} +test entry-19.7 {entry widget validation} { + set ::vVals {} + .e configure -validate focus + .e insert end d + set ::vVals +} {} +test entry-19.8 {entry widget validation} { + focus -force .e + # update necessary to process FocusIn event + update + set ::vVals +} {.e -1 -1 abcd abcd {} focus focusin} +test entry-19.9 {entry widget validation} { + focus -force . + # update necessary to process FocusOut event + update + set ::vVals +} {.e -1 -1 abcd abcd {} focus focusout} +.e configure -validate all +test entry-19.10 {entry widget validation} { + focus -force .e + # update necessary to process FocusIn event + update + set ::vVals +} {.e -1 -1 abcd abcd {} all focusin} +test entry-19.11 {entry widget validation} { + focus -force . + # update necessary to process FocusOut event + update + set ::vVals +} {.e -1 -1 abcd abcd {} all focusout} +.e configure -validate focusin +test entry-19.12 {entry widget validation} { + focus -force .e + # update necessary to process FocusIn event + update + set ::vVals +} {.e -1 -1 abcd abcd {} focusin focusin} +test entry-19.13 {entry widget validation} { + set ::vVals {} + focus -force . + # update necessary to process FocusOut event + update + set ::vVals +} {} +.e configure -validate focuso +test entry-19.14 {entry widget validation} { + focus -force .e + # update necessary to process FocusIn event + update + set ::vVals +} {} +test entry-19.15 {entry widget validation} { + focus -force . + # update necessary to process FocusOut event + update + set ::vVals +} {.e -1 -1 abcd abcd {} focusout focusout} +test entry-19.16 {entry widget validation} { + list [.e validate] $::vVals +} {1 {.e -1 -1 abcd abcd {} all forced}} +test entry-19.17 {entry widget validation} { + set ::e newdata + list [.e cget -validate] $::vVals +} {focusout {.e -1 -1 newdata abcd {} focusout forced}} + +proc doval {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + return 0 +} +.e configure -validate all + +test entry-19.18 {entry widget validation} { + set ::e nextdata + list [.e cget -validate] $::vVals +} {none {.e -1 -1 nextdata newdata {} all forced}} + +proc doval {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + set ::e mydata + return 1 +} +.e configure -validate all + +## This sets validate to none because it shows that we prevent a possible +## loop condition in the validation, when the entry textvar is also set +test entry-19.19 {entry widget validation} { + .e validate + list [.e cget -validate] [.e get] $::vVals +} {none mydata {.e -1 -1 nextdata nextdata {} all forced}} + +.e configure -validate all + +## This leaves validate alone because we trigger validation through the +## textvar (a write trace), and the write during validation triggers +## nothing (by definition of avoiding loops on var traces). This is +## one of those "dangerous" conditions where the user will have a +## different value in the entry widget shown as is in the textvar. +test entry-19.20 {entry widget validation} { + set ::e testdata + list [.e cget -validate] [.e get] $::e $::vVals +} {all testdata mydata {.e -1 -1 testdata mydata {} all forced}} + +destroy .e +catch {unset ::e ::vVals} + +## +## End validation tests +## + # XXX Still need to write tests for EntryBlinkProc, EntryFocusProc, # and EntryTextVarProc. - option clear + +# cleanup +::tcltest::cleanupTests +return + diff --git a/tk/tests/event.test b/tk/tests/event.test index 5cbfffe817f..b6ca6fe44ba 100644 --- a/tk/tests/event.test +++ b/tk/tests/event.test @@ -3,14 +3,13 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -31,6 +30,7 @@ test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} { bind .b <Destroy> { lappend x destroy event generate .b <1> + event generate .b <ButtonRelease-1> } bind .b <1> { lappend x button @@ -39,3 +39,32 @@ test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} { destroy .b set x } {destroy} + +test event-1.2 {event generate <Alt-z>} { + catch {destroy .e} + catch {unset ::event12result} + set ::event12result 0 + pack [entry .e] + update + bind .e <Alt-z> {set ::event12result "1"} + focus -force .e ; event generate .e <Alt-z> + destroy .e + set ::event12result +} 1 +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + + diff --git a/tk/tests/filebox.test b/tk/tests/filebox.test index 98ae0d36af9..c9112bf405a 100644 --- a/tk/tests/filebox.test +++ b/tk/tests/filebox.test @@ -3,15 +3,24 @@ # for Tcl tests. # # Copyright (c) 1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ # +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + set tk_strictMotif_old $tk_strictMotif +# Some tests require user interaction on non-unix platform + +set ::tcltest::testConfig(nonUnixUserInteraction) \ + [expr {$::tcltest::testConfig(userInteraction) || \ + $::tcltest::testConfig(unixOnly)}] + #---------------------------------------------------------------------- # # Procedures needed by this test file @@ -45,7 +54,7 @@ proc EnterFileByKey {parent fileName fileDir} { } else { set w $parent.__tk_filedialog } - upvar #0 [winfo name $w] data + upvar ::tk::dialog::file::__tk_filedialog data if {$tk_strictMotif} { $data(sEnt) delete 0 end @@ -66,7 +75,7 @@ proc SendButtonPress {parent btn type} { } else { set w $parent.__tk_filedialog } - upvar #0 [winfo name $w] data + upvar ::tk::dialog::file::__tk_filedialog data set button $data($btn\Btn) if ![winfo ismapped $button] { @@ -90,16 +99,19 @@ proc SendButtonPress {parent btn type} { # #---------------------------------------------------------------------- -if {[string compare test [info procs test]] == 1} { - source defs -} - if {$tcl_platform(platform) == "unix"} { set modes "0 1" } else { set modes 1 } +set unknownOptionsMsg {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent, or -title}} + +set tmpFile "filebox.tmp" +makeFile { + # this file can be empty! +} $tmpFile + foreach mode $modes { # @@ -116,17 +128,11 @@ foreach mode $modes { # foreach command "tk_getOpenFile tk_getSaveFile" { - - if {$command == "tk_getOpenFile" && $mode == 0} { - set unknownOptionsMsg {1 {unknown option "-foo", must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent or -title}} - } else { - set unknownOptionsMsg {1 {unknown option "-foo", must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent or -title}} - } - test filebox-1.1 "$command command" { list [catch {$command -foo} msg] $msg } $unknownOptionsMsg + catch {$command -foo 1} msg regsub -all , $msg "" options regsub \"-foo\" $options "" options @@ -154,16 +160,12 @@ foreach mode $modes { list [catch {$command -filetypes {Foo}} msg] $msg } {1 {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}} - if {[info commands tkMotifFDialog] == "" && [info commands tkFDialog] == ""} { + if {[info commands tkMotifFDialog] == "" && [info commands ::tk::dialog::file::tkFDialog] == ""} { set isNative 1 } else { set isNative 0 } - if {$isNative && ![info exists INTERACTIVE]} { - continue - } - set parent . set verylongstring longstring: @@ -178,54 +180,51 @@ foreach mode $modes { # set verylongstring $verylongstring$verylongstring set color #404040 - test filebox-2.1 "$command command" { + test filebox-2.1 "$command command" {nonUnixUserInteraction} { ToPressButton $parent cancel $command -title "Press Cancel ($verylongstring)" -parent $parent } "" - if {$command == "tk_getSaveFile"} { set fileName "12x 455" set fileDir [pwd] set pathName [file join [pwd] $fileName] } else { - set thisFile [info script] - set fileName [file tail $thisFile] - set appPWD [pwd] - cd [file dirname $thisFile] + set fileName $tmpFile set fileDir [pwd] - cd $appPWD set pathName [file join $fileDir $fileName] } - test filebox-2.2 "$command command" { + test filebox-2.2 "$command command" {nonUnixUserInteraction} { ToPressButton $parent ok set choice [$command -title "Press Ok" \ -parent $parent -initialfile $fileName -initialdir $fileDir] } $pathName - test filebox-2.3 "$command command" { + test filebox-2.3 "$command command" {nonUnixUserInteraction} { ToEnterFileByKey $parent $fileName $fileDir set choice [$command -title "Enter \"$fileName\" and press Ok" \ -parent $parent -initialdir $fileDir] } $pathName - test filebox-2.4 "$command command" { + test filebox-2.4 "$command command" {nonUnixUserInteraction} { ToPressButton $parent ok set choice [$command -title "Enter \"$fileName\" and press Ok" \ -parent $parent -initialdir . \ -initialfile $fileName] } $pathName - test filebox-2.5 "$command command" { + test filebox-2.5 "$command command" {nonUnixUserInteraction} { ToPressButton $parent ok set choice [$command -title "Enter \"$fileName\" and press Ok" \ -parent $parent -initialdir /badpath \ -initialfile $fileName] } $pathName - test filebox-2.6 "$command command" { + test filebox-2.6 "$command command" {nonUnixUserInteraction} { toplevel .t1; toplevel .t2 + wm geometry .t1 +0+0 + wm geometry .t2 +0+0 ToPressButton .t1 ok set choice {} lappend choice [$command \ @@ -269,21 +268,17 @@ foreach mode $modes { } foreach x [lsort -integer [array names filters]] { - test filebox-3.$x "$command command" { + test filebox-3.$x "$command command" {nonUnixUserInteraction} { ToPressButton $parent ok set choice [$command -title "Press Ok" -filetypes $filters($x)\ -parent $parent -initialfile $fileName -initialdir $fileDir] } $pathName } - # - # The rest of the tests need to be executed on Unix only. The test whether - # the dialog box widgets were implemented correctly. These tests are not + # The rest of the tests need to be executed on Unix only. + # The test whether the dialog box widgets were implemented correctly. + # These tests are not # needed on the other platforms because they use native file dialogs. - # - - - # end inner if } @@ -293,10 +288,7 @@ foreach mode $modes { set tk_strictMotif $tk_strictMotif_old -if {$isNative && ![info exists INTERACTIVE]} { - puts " Some tests were skipped because they could not be performed" - puts " automatically on this platform. If you wish to execute them" - puts " interactively, set the TCL variable INTERACTIVE and re-run" - puts " the test." - return -} +# cleanup +::tcltest::cleanupTests +return + diff --git a/tk/tests/focus.test b/tk/tests/focus.test index b10ee5e89e2..05c3c839781 100644 --- a/tk/tests/focus.test +++ b/tk/tests/focus.test @@ -3,18 +3,13 @@ # standard fashion for Tcl tests. # # Copyright (c) 1994-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {$tcl_platform(platform) != "unix"} { - return -} - -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } eval destroy [winfo children .] @@ -38,7 +33,6 @@ proc focusSetupAlt {} { global env catch {destroy .alt} toplevel .alt -screen $env(TK_ALT_DISPLAY) - wm withdraw .alt foreach i {a b c d} { button .alt.$i -text .alt.$i -relief raised -bd 2 pack .alt.$i @@ -47,7 +41,7 @@ proc focusSetupAlt {} { } # Make sure the window manager knows who has focus -fixfocus +catch {fixfocus} # The following procedure ensures that there is no input focus # in this application. It does it by arranging for another @@ -65,8 +59,8 @@ proc focusClear {} { } focusSetup -set altDisplay [info exists env(TK_ALT_DISPLAY)] -if $altDisplay { +set ::tcltest::testConfig(altDisplay) [info exists env(TK_ALT_DISPLAY)] +if {$::tcltest::testConfig(altDisplay)} { focusSetupAlt } update @@ -81,37 +75,35 @@ bind all <KeyPress> { append focusInfo "press %W %K" } -test focus-1.1 {Tk_FocusCmd procedure} { +test focus-1.1 {Tk_FocusCmd procedure} {unixOnly} { focusClear focus } {} -if $altDisplay { - test focus-1.2 {Tk_FocusCmd procedure} { - focus .alt.b - focus - } {} -} -test focus-1.3 {Tk_FocusCmd procedure} { +test focus-1.2 {Tk_FocusCmd procedure} {unixOnly altDisplay} { + focus .alt.b + focus +} {} +test focus-1.3 {Tk_FocusCmd procedure} {unixOnly} { focusClear focus .t.b3 focus } {} -test focus-1.4 {Tk_FocusCmd procedure} { +test focus-1.4 {Tk_FocusCmd procedure} {unixOnly} { list [catch {focus ""} msg] $msg } {0 {}} -test focus-1.5 {Tk_FocusCmd procedure} { +test focus-1.5 {Tk_FocusCmd procedure} {unixOnly} { focusClear focus -force .t focus .t.b3 focus } {.t.b3} -test focus-1.6 {Tk_FocusCmd procedure} { +test focus-1.6 {Tk_FocusCmd procedure} {unixOnly} { list [catch {focus .gorp} msg] $msg } {1 {bad window path name ".gorp"}} -test focus-1.7 {Tk_FocusCmd procedure} { +test focus-1.7 {Tk_FocusCmd procedure} {unixOnly} { list [catch {focus .gorp a} msg] $msg } {1 {bad option ".gorp": must be -displayof, -force, or -lastfor}} -test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} { +test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} {unixOnly} { toplevel .t2 wm geom .t2 +10+10 frame .t2.f -width 200 -height 100 -bd 2 -relief raised @@ -130,90 +122,88 @@ test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} { destroy .t2 set x } {.t2.f2 .t2 .t2} -test focus-1.9 {Tk_FocusCmd procedure, -displayof option} { +test focus-1.9 {Tk_FocusCmd procedure, -displayof option} {unixOnly} { list [catch {focus -displayof} msg] $msg } {1 {wrong # args: should be "focus -displayof window"}} -test focus-1.10 {Tk_FocusCmd procedure, -displayof option} { +test focus-1.10 {Tk_FocusCmd procedure, -displayof option} {unixOnly} { list [catch {focus -displayof a b} msg] $msg } {1 {wrong # args: should be "focus -displayof window"}} -test focus-1.11 {Tk_FocusCmd procedure, -displayof option} { +test focus-1.11 {Tk_FocusCmd procedure, -displayof option} {unixOnly} { list [catch {focus -displayof .lousy} msg] $msg } {1 {bad window path name ".lousy"}} -test focus-1.12 {Tk_FocusCmd procedure, -displayof option} { +test focus-1.12 {Tk_FocusCmd procedure, -displayof option} {unixOnly} { focusClear focus .t focus -displayof .t.b3 } {} -test focus-1.13 {Tk_FocusCmd procedure, -displayof option} { +test focus-1.13 {Tk_FocusCmd procedure, -displayof option} {unixOnly} { focusClear focus -force .t focus -displayof .t.b3 } {.t} -if $altDisplay { - test focus-1.14 {Tk_FocusCmd procedure, -displayof option} { - focus -force .alt.c - focus -displayof .alt - } {.alt.c} -} -test focus-1.15 {Tk_FocusCmd procedure, -force option} { +test focus-1.14 {Tk_FocusCmd procedure, -displayof option} {unixOnly altDisplay} { + focus -force .alt.c + focus -displayof .alt +} {.alt.c} +test focus-1.15 {Tk_FocusCmd procedure, -force option} {unixOnly} { list [catch {focus -force} msg] $msg } {1 {wrong # args: should be "focus -force window"}} -test focus-1.16 {Tk_FocusCmd procedure, -force option} { +test focus-1.16 {Tk_FocusCmd procedure, -force option} {unixOnly} { list [catch {focus -force a b} msg] $msg } {1 {wrong # args: should be "focus -force window"}} -test focus-1.17 {Tk_FocusCmd procedure, -force option} { +test focus-1.17 {Tk_FocusCmd procedure, -force option} {unixOnly} { list [catch {focus -force foo} msg] $msg } {1 {bad window path name "foo"}} -test focus-1.18 {Tk_FocusCmd procedure, -force option} { +test focus-1.18 {Tk_FocusCmd procedure, -force option} {unixOnly} { list [catch {focus -force ""} msg] $msg } {0 {}} -test focus-1.19 {Tk_FocusCmd procedure, -force option} { +test focus-1.19 {Tk_FocusCmd procedure, -force option} {unixOnly} { focusClear focus .t.b1 set x [list [focus]] focus -force .t.b1 lappend x [focus] } {{} .t.b1} -test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} { +test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} {unixOnly} { list [catch {focus -lastfor} msg] $msg } {1 {wrong # args: should be "focus -lastfor window"}} -test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} { +test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} {unixOnly} { list [catch {focus -lastfor 1 2} msg] $msg } {1 {wrong # args: should be "focus -lastfor window"}} -test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} { +test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} {unixOnly} { list [catch {focus -lastfor who_knows?} msg] $msg } {1 {bad window path name "who_knows?"}} -test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} { +test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} {unixOnly} { focus .b focus .t.b1 list [focus -lastfor .] [focus -lastfor .t.b3] } {.b .t.b1} -test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} { +test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} {unixOnly} { destroy .t focusSetup update focus -lastfor .t.b2 } {.t} -test focus-1.25 {Tk_FocusCmd procedure} { +test focus-1.25 {Tk_FocusCmd procedure} {unixOnly} { list [catch {focus -unknown} msg] $msg } {1 {bad option "-unknown": must be -displayof, -force, or -lastfor}} -if {[string compare testwrapper [info commands testwrapper]] != 0} { - puts "This application hasn't been compiled with the testwrapper command," - puts "therefore I am skipping all of these tests." - return -} +# Some tests require the testwrapper command + +set ::tcltest::testConfig(testwrapper) \ + [expr {[info commands testwrapper] != {}}] -test focus-2.1 {TkFocusFilterEvent procedure} {nonPortable} { +test focus-2.1 {TkFocusFilterEvent procedure} {unixOnly nonPortable testwrapper} { focus -force .b destroy .t focusSetup update set focusInfo {} - event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor -sendevent 0x54217567 + event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor \ + -sendevent 0x54217567 list $focusInfo } {{}} -test focus-2.2 {TkFocusFilterEvent procedure} {nonPortable} { +test focus-2.2 {TkFocusFilterEvent procedure} {unixOnly nonPortable testwrapper} { focus -force .b destroy .t focusSetup @@ -223,7 +213,7 @@ test focus-2.2 {TkFocusFilterEvent procedure} {nonPortable} { list $focusInfo [focus] } {{in .t NotifyAncestor } .b} -test focus-2.3 {TkFocusFilterEvent procedure} {nonPortable} { +test focus-2.3 {TkFocusFilterEvent procedure} {unixOnly nonPortable testwrapper} { focus -force .b destroy .t focusSetup @@ -236,7 +226,8 @@ test focus-2.3 {TkFocusFilterEvent procedure} {nonPortable} { out . NotifyNonlinearVirtual in .t NotifyNonlinear } .t} -test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} {nonPortable} { +test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} \ + {unixOnly nonPortable testwrapper} { set result {} focus .t.b1 # Important to end with NotifyAncestor, which is an @@ -266,7 +257,8 @@ in .t.b1 NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear }} -test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} {nonPortable} { +test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} \ + {unixOnly nonPortable testwrapper} { focusSetup focus .t.b1 update @@ -276,7 +268,8 @@ test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} {nonPor in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear } .t.b1} -test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} { +test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} \ + {unixOnly testwrapper} { focus .t.b1 focus . update @@ -286,7 +279,8 @@ test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} { event gen . <KeyPress-x> list $x $focusInfo } {.t.b1 {press .t.b1 x}} -test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} { +test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} \ + {unixOnly testwrapper} { set result {} foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot @@ -298,17 +292,20 @@ test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} { } set result } {{} .t.b1 {} {} .t.b1 .t.b1 {}} -test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} { +test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} \ + {unixOnly testwrapper} { focus -force .t.b1 event gen .t.b1 <FocusOut> -detail NotifyAncestor focus } {.t.b1} -test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} { +test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} \ + {unixOnly testwrapper} { focus .t.b1 event gen [testwrapper .] <FocusOut> -detail NotifyAncestor focus } {} -test focus-2.10 {TkFocusFilterEvent procedure, Enter events} { +test focus-2.10 {TkFocusFilterEvent procedure, Enter events} \ + {unixOnly testwrapper} { set result {} focus .t.b1 focusClear @@ -322,14 +319,16 @@ test focus-2.10 {TkFocusFilterEvent procedure, Enter events} { } set result } {.t.b1 {} .t.b1 .t.b1 .t.b1} -test focus-2.11 {TkFocusFilterEvent procedure, Enter events} { +test focus-2.11 {TkFocusFilterEvent procedure, Enter events} \ + {unixOnly testwrapper} { focusClear set focusInfo {} event gen [testwrapper .t] <Enter> -detail NotifyAncestor update set focusInfo } {} -test focus-2.12 {TkFocusFilterEvent procedure, Enter events} { +test focus-2.12 {TkFocusFilterEvent procedure, Enter events} \ + {unixOnly testwrapper} { focus -force .b update set focusInfo {} @@ -337,7 +336,8 @@ test focus-2.12 {TkFocusFilterEvent procedure, Enter events} { update set focusInfo } {} -test focus-2.13 {TkFocusFilterEvent procedure, Enter events} { +test focus-2.13 {TkFocusFilterEvent procedure, Enter events} \ + {unixOnly testwrapper} { focus .t.b1 focusClear event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 @@ -347,7 +347,7 @@ test focus-2.13 {TkFocusFilterEvent procedure, Enter events} { } {in .t NotifyVirtual in .t.b1 NotifyAncestor } -test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} { +test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} {unixOnly testwrapper} { focusClear catch {destroy .t2} toplevel .t2 @@ -358,7 +358,8 @@ test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when update destroy .t2 } {} -test focus-2.15 {TkFocusFilterEvent procedure, Leave events} { +test focus-2.15 {TkFocusFilterEvent procedure, Leave events} \ + {unixOnly testwrapper} { set result {} focus .t.b1 foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear @@ -372,7 +373,8 @@ test focus-2.15 {TkFocusFilterEvent procedure, Leave events} { } set result } {{} .t.b1 {} {} {}} -test focus-2.16 {TkFocusFilterEvent procedure, Leave events} { +test focus-2.16 {TkFocusFilterEvent procedure, Leave events} \ + {unixOnly testwrapper} { set result {} focus .t.b1 event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 @@ -384,7 +386,8 @@ test focus-2.16 {TkFocusFilterEvent procedure, Leave events} { } {out .t.b1 NotifyAncestor out .t NotifyVirtual } -test focus-2.17 {TkFocusFilterEvent procedure, Leave events} { +test focus-2.17 {TkFocusFilterEvent procedure, Leave events} \ + {unixOnly testwrapper} { set result {} focus .t.b1 event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 @@ -398,7 +401,8 @@ test focus-2.17 {TkFocusFilterEvent procedure, Leave events} { out .t NotifyVirtual } {}} -test focus-3.1 {SetFocus procedure, create record on focus} { +test focus-3.1 {SetFocus procedure, create record on focus} \ + {unixOnly testwrapper} { toplevel .t2 -width 250 -height 100 wm geometry .t2 +0+0 update @@ -410,7 +414,8 @@ catch {destroy .t2} # This test produces no result, but it will generate a protocol # error if Tk forgets to make the window exist before focussing # on it. -test focus-3.2 {SetFocus procedure, making window exist} { +test focus-3.2 {SetFocus procedure, making window exist} \ + {unixOnly testwrapper} { update button .b2 -text "Another button" focus .b2 @@ -420,12 +425,14 @@ catch {destroy .b2} update # The following test doesn't produce a check-able result, but if # there are bugs it may generate an X protocol error. -test focus-3.3 {SetFocus procedure, delaying claim of X focus} { +test focus-3.3 {SetFocus procedure, delaying claim of X focus} \ + {unixOnly testwrapper} { focusSetup focus -force .t.b2 update } {} -test focus-3.4 {SetFocus procedure, delaying claim of X focus} { +test focus-3.4 {SetFocus procedure, delaying claim of X focus} \ + {unixOnly testwrapper} { focusSetup wm withdraw .t focus -force .t.b2 @@ -438,7 +445,8 @@ test focus-3.4 {SetFocus procedure, delaying claim of X focus} { wm deiconify .t } {} catch {destroy .t2} -test focus-3.5 {SetFocus procedure, generating events} { +test focus-3.5 {SetFocus procedure, generating events} \ + {unixOnly testwrapper} { focusSetup focusClear set focusInfo {} @@ -448,7 +456,8 @@ test focus-3.5 {SetFocus procedure, generating events} { } {in .t NotifyVirtual in .t.b2 NotifyAncestor } -test focus-3.6 {SetFocus procedure, generating events} { +test focus-3.6 {SetFocus procedure, generating events} \ + {unixOnly testwrapper} { focusSetup focus -force .b update @@ -461,7 +470,8 @@ out . NotifyNonlinearVirtual in .t NotifyNonlinearVirtual in .t.b2 NotifyNonlinear } -test focus-3.7 {SetFocus procedure, generating events} {nonPortable} { +test focus-3.7 {SetFocus procedure, generating events} \ + {unixOnly nonPortable testwrapper} { # Non-portable because some platforms generate extra events. focusSetup @@ -472,7 +482,7 @@ test focus-3.7 {SetFocus procedure, generating events} {nonPortable} { set focusInfo } {} -test focus-4.1 {TkFocusDeadWindow procedure} { +test focus-4.1 {TkFocusDeadWindow procedure} {unixOnly testwrapper} { focusSetup update focus -force .b @@ -480,7 +490,7 @@ test focus-4.1 {TkFocusDeadWindow procedure} { destroy .t focus } {.b} -test focus-4.2 {TkFocusDeadWindow procedure} { +test focus-4.2 {TkFocusDeadWindow procedure} {unixOnly testwrapper} { focusSetup update focus -force .t.b2 @@ -494,7 +504,7 @@ test focus-4.2 {TkFocusDeadWindow procedure} { # Non-portable due to wm-specific redirection of input focus when # windows are deleted: -test focus-4.3 {TkFocusDeadWindow procedure} {nonPortable} { +test focus-4.3 {TkFocusDeadWindow procedure} {unixOnly nonPortable testwrapper} { focusSetup update focus .t @@ -503,7 +513,7 @@ test focus-4.3 {TkFocusDeadWindow procedure} {nonPortable} { update focus } {} -test focus-4.4 {TkFocusDeadWindow procedure} { +test focus-4.4 {TkFocusDeadWindow procedure} {unixOnly testwrapper} { focusSetup focus -force .t.b2 update @@ -514,7 +524,21 @@ test focus-4.4 {TkFocusDeadWindow procedure} { # I don't know how to test most of the remaining procedures of this file # explicitly; they've already been exercised by the preceding tests. -test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} { +# If send is disabled because of inadequate security, don't run any +# of these tests at all. + +setupbg +set app [dobg {tk appname}] +set ::tcltest::testConfig(secureServer) 1 +if {[catch {send $app set a 0} msg] == 1} { + if [string match "X server insecure *" $msg] { + set ::tcltest::testConfig(secureServer) 0 + } +} +cleanupbg +setupbg +test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} \ + {unixOnly testwrapper secureServer} { focusSetup focus -force .t update @@ -524,7 +548,7 @@ test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} { focus .t.b2 update lappend result [focus] -} {.t .t {}} +} {.t {} {}} catch {destroy .t} bind all <FocusIn> {} @@ -533,7 +557,8 @@ bind all <KeyPress> {} cleanupbg fixfocus -test focus-6.1 {miscellaneous - embedded application in same process} {unixOnly} { +test focus-6.1 {miscellaneous - embedded application in same process} \ + {unixOnly testwrapper} { eval interp delete [interp slaves] catch {destroy .t} toplevel .t @@ -582,7 +607,8 @@ test focus-6.1 {miscellaneous - embedded application in same process} {unixOnly} interp delete child set result } {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} -test focus-6.2 {miscellaneous - embedded application in different process} {unixOnly} { +test focus-6.2 {miscellaneous - embedded application in different process} \ + {unixOnly testwrapper} { eval interp delete [interp slaves] catch {destroy .t} setupbg @@ -634,3 +660,21 @@ test focus-6.2 {miscellaneous - embedded application in different process} {unix eval destroy [winfo children .] bind all <FocusIn> {} bind all <FocusOut> {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + + diff --git a/tk/tests/focusTcl.test b/tk/tests/focusTcl.test index 19dc0a09c47..bacf1a27f48 100644 --- a/tk/tests/focusTcl.test +++ b/tk/tests/focusTcl.test @@ -4,14 +4,13 @@ # standard fashion for Tcl tests. # # Copyright (c) 1995 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } eval destroy [winfo children .] @@ -277,3 +276,20 @@ test focusTcl-5.11 {tkFocusOK procedure, -takefocus "", check for bindings} { bind Frame <Key> {} . configure -takefocus 0 -highlightthickness 0 option clear + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/font.test b/tk/tests/font.test index f36fe049544..1df9e7dfb97 100644 --- a/tk/tests/font.test +++ b/tk/tests/font.test @@ -1,16 +1,21 @@ # This file is a Tcl script to test out Tk's "font" command # plus the procedures in tkFont.c. It is organized in the -# standard fashion for Tcl tests. +# standard white-box fashion for Tcl tests. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1996-1998 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] != 0} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {[info commands testfont] != "testfont"} { + puts "testfont command not available; skipping tests" + ::tcltest::cleanupTests + return } catch {destroy .b} @@ -20,7 +25,7 @@ update idletasks proc setup {} { catch {destroy .b.f} - catch {font delete xyz} + catch {eval font delete [font names]} label .b.f pack .b.f update @@ -56,243 +61,357 @@ case $tcl_platform(platform) { } set times [font actual {times 0} -family] -test font-1.1 {font command: general} { +test font-1.1 {TkFontPkgInit} { + catch {interp delete foo} + interp create foo + foo eval { + load {} Tk + wm geometry . +0+0 + update + } + interp delete foo +} {} + +test font-2.1 {TkFontPkgFree} { + catch {interp delete foo} + interp create foo + set x {} + + # Makes sure that named font was visible only to child interp. + + foo eval { + load {} Tk + wm geometry . +0+0 + button .b -font {times 16} -text "hi" + pack .b + font create wiggles -family courier -underline 1 + update + } + lappend x [catch {font configure wiggles} msg; set msg] + + # Tests cancelling the idle handler for TheWorldHasChanged, + # because app goes away before idle serviced. + + foo eval { + .b config -font wiggles + font config wiggles -size 24 + destroy . + } + lappend x [foo eval {catch {font families} msg; set msg}] + + interp delete foo + set x +} {{named font "wiggles" doesn't exist} {can't invoke "font" command: application has been destroyed}} + + +test font-3.1 {font command: general} { list [catch {font} msg] $msg } {1 {wrong # args: should be "font option ?arg?"}} -test font-1.2 {font command: actual: arguments} { +test font-3.2 {font command: general} { + list [catch {font xyz} msg] $msg +} {1 {bad option "xyz": must be actual, configure, create, delete, families, measure, metrics, or names}} + +test font-4.1 {font command: actual: arguments} { + # (skip < 0) list [catch {font actual xyz -displayof} msg] $msg } {1 {value for "-displayof" missing}} -test font-1.3 {font command: actual: arguments} { +test font-4.2 {font command: actual: arguments} { + # (objc < 3) list [catch {font actual} msg] $msg } {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} -test font-1.4 {font command: actual: arguments} { +test font-4.3 {font command: actual: arguments} { + # (objc - skip > 4) when skip == 0 list [catch {font actual xyz abc def} msg] $msg } {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} -test font-1.5 {font command: actual: arguments} { - list [catch {font actual {}} msg] $msg -} {1 {font "" doesn't exist}} -test font-1.6 {font command: actual: displayof specified, so skip to next} { +test font-4.4 {font command: actual: displayof specified, so skip to next} { catch {font actual xyz -displayof . -size} } {0} -test font-1.7 {font command: actual: displayof specified, so skip to next} { +test font-4.5 {font command: actual: displayof specified, so skip to next} { lindex [font actual xyz -displayof .] 0 } {-family} -test font-1.8 {font command: actual} {unix || mac} { +test font-4.6 {font command: actual: arguments} { + # (objc - skip > 4) when skip == 2 + list [catch {font actual xyz -displayof . abc def} msg] $msg +} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} +test font-4.7 {font command: actual: arguments} {noExceed} { + # (tkfont == NULL) + list [catch {font actual "\{xyz"} msg] $msg +} [list 1 "font \"{xyz\" doesn't exist"] +test font-4.8 {font command: actual: all attributes} { + # not (objc > 3) so objPtr = NULL + lindex [font actual {-family times}] 0 +} {-family} +test font-4.9 {font command: actual} {macOrUnix noExceed} { + # (objc > 3) so objPtr = objv[3 + skip] string tolower [font actual {-family times} -family] } {times} -test font-1.9 {font command: actual} {pcOnly} { +test font-4.10 {font command: actual} {pcOnly} { + # (objc > 3) so objPtr = objv[3 + skip] font actual {-family times} -family } {Times New Roman} -test font-1.10 {font command: actual} { - lindex [font actual {-family times}] 0 -} {-family} -test font-1.11 {font command: bad option} { +test font-4.11 {font command: bad option} { list [catch {font actual xyz -style} msg] $msg } {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-2.1 {font command: configure} { +test font-5.1 {font command: configure} { + # (objc < 3) list [catch {font configure} msg] $msg } {1 {wrong # args: should be "font configure fontname ?options?"}} -test font-2.2 {font command: configure: non-existent font} { +test font-5.2 {font command: configure: non-existent font} { + # (namedHashPtr == NULL) list [catch {font configure xyz} msg] $msg } {1 {named font "xyz" doesn't exist}} -test font-2.3 {font command: configure: "deleted" font} { +test font-5.3 {font command: configure: "deleted" font} { + # (nfPtr->deletePending != 0) setup font create xyz .b.f configure -font xyz font delete xyz list [catch {font configure xyz} msg] $msg } {1 {named font "xyz" doesn't exist}} -test font-2.4 {font command: configure: get all options} { +test font-5.4 {font command: configure: get all options} { + # (objc == 3) so objPtr = NULL setup font create xyz -family xyz lindex [font configure xyz] 1 } xyz -test font-2.5 {font command: configure: get one option} { +test font-5.5 {font command: configure: get one option} { + # (objc == 4) so objPtr = objv[3] setup font create xyz -family xyz font configure xyz -family } xyz -test font-2.6 {font command: configure: update existing font} { +test font-5.6 {font command: configure: update existing font} { + # else result = ConfigAttributesObj() setup font create xyz font configure xyz -family xyz update font configure xyz -family } xyz -test font-2.7 {font command: configure: bad option} { +test font-5.7 {font command: configure: bad option} { setup font create xyz list [catch {font configure xyz -style} msg] $msg } {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-3.1 {font command: create: make up name} { - font delete [font create] - font delete [font create -family xyz] -} {} -test font-3.2 {font command: create: already exists} { +test font-6.1 {font command: create: make up name} { + # (objc < 3) so name = NULL setup - font create xyz - list [catch {font create xyz} msg] $msg -} {1 {font "xyz" already exists}} -test font-3.3 {font command: create: error recreating "deleted" font} { + font create + font names +} {font1} +test font-6.2 {font command: create: name specified} { + # not (objc < 3) setup font create xyz - .b.f configure -font xyz - font delete xyz - list [catch {font create xyz -xyz times} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-3.4 {font command: create: recreate "deleted" font} { + font names +} {xyz} +test font-6.3 {font command: create: name not really specified} { + # (name[0] == '-') so name = NULL setup - font create xyz - .b.f configure -font xyz - font delete xyz - font actual xyz - font create xyz -family times - update - font configure xyz -family -} {times} -test font-3.5 {font command: create: bad option creating new font} { + font create -family xyz + font names +} {font1} +test font-6.4 {font command: create: generate name} { + # (name == NULL) + setup + font create -family one + font create -family two + font create -family three + font delete font2 + font create -family four + font configure font2 -family +} {four} +test font-6.5 {font command: create: bad option creating new font} { + # name was specified so skip = 3 setup list [catch {font create xyz -xyz times} msg] $msg } {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-3.6 {font command: create: totally new font} { +test font-6.6 {font command: create: bad option creating new font} { + # name was not specified so skip = 2 setup - font create xyz -family xyz - font configure xyz -family -} {xyz} + list [catch {font create -xyz times} msg] $msg +} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} +test font-6.7 {font command: create: already exists} { + # (CreateNamedFont() != TCL_OK) + setup + font create xyz + list [catch {font create xyz} msg] $msg +} {1 {named font "xyz" already exists}} -test font-4.1 {font command: delete: arguments} { +test font-7.1 {font command: delete: arguments} { + # (objc < 3) list [catch {font delete} msg] $msg } {1 {wrong # args: should be "font delete fontname ?fontname ...?"}} -test font-4.2 {font command: delete: loop test} { +test font-7.2 {font command: delete: loop test} { + # for (i = 2; i < objc; i++) + setup + set x {} font create a -underline 1 font create b -underline 1 font create c -underline 1 - font delete a b c - list [font actual a -underline] [font actual b -underline] [font actual c -underline] -} {0 0 0} -test font-4.3 {font command: delete: non-existent} { + font create d -underline 1 + font create e -underline 1 + lappend x [lsort [font names]] + font delete a e c b + lappend x [lsort [font names]] +} {{a b c d e} d} +test font-7.3 {font command: delete: loop test} { + # (namedHashPtr == NULL) in middle of loop + setup + set x {} + font create a -underline 1 + font create b -underline 1 + font create c -underline 1 + font create d -underline 1 + font create e -underline 1 + lappend x [lsort [font names]] + catch {font delete a d q c e b} + lappend x [lsort [font names]] +} {{a b c d e} {b c e}} +test font-7.4 {font command: delete: non-existent} { + # (namedHashPtr == NULL) setup list [catch {font delete xyz} msg] $msg } {1 {named font "xyz" doesn't exist}} -test font-4.4 {font command: delete: mark for later deletion} { +test font-7.5 {font command: delete: mark for later deletion} { + # (nfPtr->refCount != 0) setup font create xyz .b.f configure -font xyz font delete xyz font actual xyz - list [catch {font configure xyz} msg] $msg -} {1 {named font "xyz" doesn't exist}} -test font-4.5 {font command: delete: actually delete} { + list [catch {font configure xyz} msg] $msg [.b.f cget -font] +} {1 {named font "xyz" doesn't exist} xyz} +test font-7.6 {font command: delete: actually delete} { + # not (nfPtr->refCount != 0) setup font create xyz -underline 1 font delete xyz - font actual xyz -underline -} {0} + catch {font config xyz} +} {1} +setup -test font-5.1 {font command: families: arguments} { +test font-8.1 {font command: families: arguments} { + # (skip < 0) list [catch {font families -displayof} msg] $msg } {1 {value for "-displayof" missing}} -test font-5.2 {font command: families: arguments} { +test font-8.2 {font command: families: arguments} { + # (objc - skip != 2) when skip == 0 list [catch {font families xyz} msg] $msg } {1 {wrong # args: should be "font families ?-displayof window?"}} -test font-5.3 {font command: families} { - font families - set x {} -} {} +test font-8.3 {font command: families: arguments} { + # (objc - skip != 2) when skip == 2 + list [catch {font families -displayof . xyz} msg] $msg +} {1 {wrong # args: should be "font families ?-displayof window?"}} +test font-8.4 {font command: families} { + # TkpGetFontFamilies() + regexp -nocase times [font families] +} {1} -test font-6.1 {font command: measure: arguments} { +test font-9.1 {font command: measure: arguments} { + # (skip < 0) list [catch {font measure xyz -displayof} msg] $msg } {1 {value for "-displayof" missing}} -test font-6.2 {font command: measure: arguments} { +test font-9.2 {font command: measure: arguments} { + # (objc - skip != 4) list [catch {font measure} msg] $msg } {1 {wrong # args: should be "font measure font ?-displayof window? text"}} -test font-6.3 {font command: measure: arguments} { +test font-9.3 {font command: measure: arguments} { + # (objc - skip != 4) list [catch {font measure xyz abc def} msg] $msg } {1 {wrong # args: should be "font measure font ?-displayof window? text"}} -test font-6.4 {font command: measure: arguments} { - list [catch {font measure {} abc} msg] $msg -} {1 {font "" doesn't exist}} -test font-6.5 {font command: measure} { +test font-9.4 {font command: measure: arguments} {noExceed} { + # (tkfont == NULL) + list [catch {font measure "\{xyz" abc} msg] $msg +} [list 1 "font \"{xyz\" doesn't exist"] +test font-9.5 {font command: measure} { + # Tk_TextWidth() expr [font measure $fixed "abcdefg"]==[font measure $fixed "a"]*7 } {1} -test font-7.1 {font command: metrics: arguments} { +test font-10.1 {font command: metrics: arguments} { + list [catch {font metrics xyz -displayof} msg] $msg +} {1 {value for "-displayof" missing}} +test font-10.2 {font command: metrics: arguments} { + # (skip < 0) list [catch {font metrics xyz -displayof} msg] $msg } {1 {value for "-displayof" missing}} -test font-7.2 {font command: metrics: arguments} { +test font-10.3 {font command: metrics: arguments} { + # (objc < 3) list [catch {font metrics} msg] $msg } {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}} -test font-7.3 {font command: metrics: get all metrics} { +test font-10.4 {font command: metrics: arguments} { + # (objc - skip) > 4) when skip == 0 + list [catch {font metrics xyz abc def} msg] $msg +} {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}} +test font-10.5 {font command: metrics: arguments} { + # (objc - skip) > 4) when skip == 2 + list [catch {font metrics xyz -displayof . abc} msg] $msg +} {1 {bad metric "abc": must be -ascent, -descent, -linespace, or -fixed}} +test font-10.6 {font command: metrics: bad font} {noExceed} { + # (tkfont == NULL) + list [catch {font metrics "\{xyz"} msg] $msg +} [list 1 "font \"{xyz\" doesn't exist"] +test font-10.7 {font command: metrics: get all metrics} { + # (objc == 3) catch {unset a} array set a [font metrics {-family xyz}] set x [lsort [array names a]] unset a set x } {-ascent -descent -fixed -linespace} -test font-7.4 {font command: metrics: get ascent} { - catch {expr [font metrics $fixed -ascent]} -} {0} -test font-7.5 {font command: metrics: get descent} { - catch {expr [font metrics {-family xyz} -descent]} -} {0} -test font-7.6 {font command: metrics: get linespace} { - catch {expr [font metrics {-family fixed} -linespace]} -} {0} -test font-7.7 {font command: metrics: get fixed} { - catch {expr [font metrics {-family fixed} -fixed]} -} {0} -test font-7.8 {font command: metrics: get ascent} { - catch {expr [font metrics {-family xyz} -ascent]} -} {0} -test font-7.9 {font command: metrics: get descent} { - catch {expr [font metrics {-family xyz} -descent]} -} {0} -test font-7.10 {font command: metrics: get linespace} { - catch {expr [font metrics {-family fixed} -linespace]} -} {0} -test font-7.11 {font command: metrics: get fixed} { - catch {expr [font metrics {-family fixed} -fixed]} -} {0} -test font-7.12 {font command: metrics: bad metric} { - list [catch {font metrics {-family fixed} -xyz} msg] $msg +test font-10.8 {font command: metrics: bad metric} { + # (Tcl_GetIndexFromObj() != TCL_OK) + list [catch {font metrics $fixed -xyz} msg] $msg } {1 {bad metric "-xyz": must be -ascent, -descent, -linespace, or -fixed}} +test font-10.9 {font command: metrics: get individual metrics} { + font metrics $fixed -ascent + font metrics $fixed -descent + font metrics $fixed -linespace + font metrics $fixed -fixed +} {1} -test font-8.1 {font command: names: arguments} { +test font-11.1 {font command: names: arguments} { + # (objc != 2) list [catch {font names xyz} msg] $msg } {1 {wrong # args: should be "font names"}} -test font-8.2 {font command: names} { +test font-11.2 {font command: names: loop test: no passes} { + setup + font names +} {} +test font-11.3 {font command: names: loop test: one pass} { + setup + font create + font names +} {font1} +test font-11.4 {font command: names: loop test: multiple passes} { setup font create xyz font create abc - set x [lsort [font names]] - font delete abc - font delete xyz - set x -} {abc xyz} -test font-8.3 {font command: names} { + font create def + lsort [font names] +} {abc def xyz} +test font-11.5 {font command: names: skip deletePending fonts} { + # (nfPtr->deletePending == 0) setup + set x {} font create xyz font create abc - set x [lsort [font names]] + lappend x [lsort [font names]] .b.f config -font xyz font delete xyz lappend x [font names] - font delete abc - set x -} {abc xyz abc} +} {{abc xyz} abc} -test font-9.1 {font command: unknown option} { - list [catch {font xyz} msg] $msg -} {1 {bad option "xyz": must be actual, configure, create, delete, families, measure, metrics, or names}} - -test font-10.1 {UpdateDependantFonts procedure: no users} { +test font-12.1 {UpdateDependantFonts procedure: no users} { + # (nfPtr->refCount == 0) setup font create xyz font configure xyz -family times } {} -test font-10.2 {UpdateDependantFonts procedure: pings the widgets} { +test font-12.2 {UpdateDependantFonts procedure: pings the widgets} { setup font create xyz -family times -size 20 .b.f config -font xyz -text "abcd" -padx 0 -bd 0 -highlightthickness 0 @@ -306,56 +425,155 @@ test font-10.2 {UpdateDependantFonts procedure: pings the widgets} { expr {$a1==$b1 && $a2==$b2} } {1} -test font-11.1 {Tk_GetFont procedure: bump ref count} { +test font-13.1 {CreateNamedFont: new named font} { + # not (new == 0) + setup + set x {} + lappend x [font names] + font create xyz + lappend x [font names] +} {{} xyz} +test font-13.2 {CreateNamedFont: named font already exists} { + # (new == 0) + setup + font create xyz + list [catch {font create xyz} msg] $msg +} {1 {named font "xyz" already exists}} +test font-13.3 {CreateNamedFont: named font already exists} { + # (nfPtr->deletePending == 0) + setup + font create xyz + list [catch {font create xyz} msg] $msg +} {1 {named font "xyz" already exists}} +test font-13.4 {CreateNamedFont: recreate "deleted" font} { + # not (nfPtr->deletePending == 0) + setup + font create xyz -family times + .b.f configure -font xyz + font delete xyz + font create xyz -family courier + font configure xyz -family +} {courier} + +test font-14.1 {Tk_GetFont procedure} { +} {} + +test font-15.1 {Tk_AllocFontFromObj - converting internal reps} { + set x {Times 16} + lindex $x 0 + destroy .b1 .b2 + button .b1 -font $x + lindex $x 0 + testfont counts {Times 16} +} {{1 0}} +test font-15.2 {Tk_AllocFontFromObj - discard stale font} { + set x {Times 16} + destroy .b1 .b2 + button .b1 -font $x + destroy .b1 + set result {} + lappend result [testfont counts {Times 16}] + button .b2 -font $x + lappend result [testfont counts {Times 16}] +} {{} {{1 1}}} +test font-15.3 {Tk_AllocFontFromObj - reuse existing font} { + set x {Times 16} + destroy .b1 .b2 + button .b1 -font $x + set result {} + lappend result [testfont counts {Times 16}] + button .b2 -font $x + pack .b1 .b2 -side top + lappend result [testfont counts {Times 16}] +} {{{1 1}} {{2 1}}} +test font-15.4 {Tk_AllocFontFromObj procedure: bump ref count} { + # (new == 0) setup .b.f config -font {-family fixed} lindex [font actual {-family fixed}] 0 } {-family} -test font-11.2 {Tk_GetFont procedure: bump ref count of named font, too} { +test font-15.5 {Tk_AllocFontFromObj procedure: get named font} { + # (namedHashPtr != NULL) setup - font create xyz - .b.f config -font xyz - lindex [font actual xyz] 0 -} {-family} -test font-11.3 {Tk_GetFont procedure: get named font} { + font create xyz + .b.f config -font xyz +} {} +test font-15.6 {Tk_AllocFontFromObj procedure: not a named font} { + # not (namedHashPtr != NULL) setup - font create xyz - .b.f config -font xyz + .b.f config -font {times 20} } {} -test font-11.4 {Tk_GetFont procedure: get native font} {unixOnly} { +test font-15.7 {Tk_AllocFontFromObj procedure: get native font} {unixOnly} { + # not (fontPtr == NULL) setup .b.f config -font fixed } {} -test font-11.5 {Tk_GetFont procedure: get native font} {pcOnly} { +test font-15.8 {Tk_AllocFontFromObj procedure: get native font} {pcOnly} { + # not (fontPtr == NULL) setup .b.f config -font oemfixed } {} -test font-11.6 {Tk_GetFont procedure: get native font} {macOnly} { +test font-15.9 {Tk_AllocFontFromObj procedure: get native font} {macOnly} { + # not (fontPtr == NULL) setup .b.f config -font application } {} -test font-11.7 {Tk_GetFont procedure: get attribute font} { +test font-15.10 {Tk_AllocFontFromObj procedure: get attribute font} { + # (fontPtr == NULL) list [catch {.b.f config -font {xxx yyy zzz}} msg] $msg } {1 {expected integer but got "yyy"}} -test font-11.8 {Tk_GetFont procedure: get attribute font} { +test font-15.11 {Tk_AllocFontFromObj procedure: no match} {noExceed} { + # (ParseFontNameObj() != TCL_OK) + list [catch {font actual "\{xyz"} msg] $msg +} [list 1 "font \"{xyz\" doesn't exist"] +test font-15.12 {Tk_AllocFontFromObj procedure: get attribute font} { + # not (ParseFontNameObj() != TCL_OK) lindex [font actual {plan 9}] 0 } {-family} -test font-11.9 {Tk_GetFont procedure: no match} { - list [catch {font actual {}} msg] $msg -} {1 {font "" doesn't exist}} +test font-15.13 {Tk_AllocFontFromObj procedure: setup tab width} { + # Tk_MeasureChars(fontPtr, "0", ...) + label .l -bd 0 -padx 0 -highlightthickness 0 -font $fixed -text "a\tb" + update + set x [winfo reqwidth .l] + destroy .l + set x +} [expr [font measure $fixed "0"]*9] +test font-15.14 {Tk_AllocFontFromObj procedure: underline position} { + # (fontPtr->underlineHeight == 0) because size was < 10 + setup + .b.f config -text "underline" -font "times -8 underline" + update +} {} -test font-12.1 {Tk_NameOfFont procedure} { +test font-16.1 {Tk_NameOfFont procedure} { setup - .b.f config -font {-family fixed} + .b.f config -font -family\ fixed .b.f cget -font } {-family fixed} -test font-13.1 {Tk_FreeFont procedure: one ref} { +test font-17.1 {Tk_FreeFontFromObj - reference counts} { + set x {Courier 12} + destroy .b1 .b2 .b3 + button .b1 -font $x + button .b3 -font $x + button .b2 -font $x + set result {} + lappend result [testfont counts {Courier 12}] + destroy .b1 + lappend result [testfont counts {Courier 12}] + destroy .b2 + lappend result [testfont counts {Courier 12}] + destroy .b3 + lappend result [testfont counts {Courier 12}] +} {{{3 1}} {{2 1}} {{1 1}} {}} +test font-17.2 {Tk_FreeFont procedure: one ref} { + # (fontPtr->refCount == 0) setup .b.f config -font {-family fixed} destroy .b.f } {} -test font-13.2 {Tk_FreeFont procedure: multiple ref} { +test font-17.3 {Tk_FreeFont procedure: multiple ref} { + # not (fontPtr->refCount == 0) setup .b.f config -font {-family fixed} button .b.b -font {-family fixed} @@ -364,14 +582,16 @@ test font-13.2 {Tk_FreeFont procedure: multiple ref} { destroy .b.b set x } {-family fixed} -test font-13.3 {Tk_FreeFont procedure: named font} { +test font-17.4 {Tk_FreeFont procedure: named font} { + # (fontPtr->namedHashPtr != NULL) setup font create xyz .b.f config -font xyz destroy .b.f font names } {xyz} -test font-13.4 {Tk_FreeFont procedure: named font} { +test font-17.5 {Tk_FreeFont procedure: named font} { + # not (fontPtr->refCount == 0) setup font create xyz -underline 1 .b.f config -font xyz @@ -380,9 +600,9 @@ test font-13.4 {Tk_FreeFont procedure: named font} { destroy .b.f list [font actual xyz -underline] $x } {0 1} -test font-13.5 {Tk_FreeFont procedure: named font not deleted yet} { +test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} { setup - font create xyz + font create xyz .b.f config -font xyz button .b.b -font xyz font delete xyz @@ -391,12 +611,32 @@ test font-13.5 {Tk_FreeFont procedure: named font not deleted yet} { list [lindex [font actual xyz] 0] [lindex $x 0] } {-family -family} -test font-14.1 {Tk_FontId} { +test font-18.1 {FreeFontObjProc} { + destroy .b1 + set x [format {Courier 12}] + button .b1 -font $x + set y [format {Courier 12}] + .b1 configure -font $y + set z [format {Courier 12}] + .b1 configure -font $z + set result {} + lappend result [testfont counts {Courier 12}] + set x red + lappend result [testfont counts {Courier 12}] + set z 32 + lappend result [testfont counts {Courier 12}] + destroy .b1 + lappend result [testfont counts {Courier 12}] + set y bogus + set result +} {{{1 3}} {{1 2}} {{1 1}} {}} + +test font-19.1 {Tk_FontId} { .b.f config -font "times 20" update } {} -test font-15.1 {Tk_FontMetrics procedure} { +test font-20.1 {Tk_GetFontMetrics procedure} { button .b.w1 -text abc entry .b.w2 -text abcd update @@ -405,7 +645,7 @@ test font-15.1 {Tk_FontMetrics procedure} { proc psfontname {name} { set a [.b.c itemcget text -font] - .b.c itemconfig text -font $name + .b.c itemconfig text -text "We need text" -font $name set post [.b.c postscript] .b.c itemconfig text -font $a set end [string first "findfont" $post] @@ -414,7 +654,7 @@ proc psfontname {name} { set start [string first "gsave" $post] return [string range $post [expr $start+7] end] } -test font-16.1 {Tk_PostscriptFontName procedure: native} {unixOnly} { +test font-21.1 {Tk_PostscriptFontName procedure: native} {unixOnly} { set x [font actual {{itc avant garde} 10} -family] if {[string match *avant*garde $x]} { psfontname "{itc avant garde} 10" @@ -422,25 +662,25 @@ test font-16.1 {Tk_PostscriptFontName procedure: native} {unixOnly} { set x {AvantGarde-Book} } } {AvantGarde-Book} -test font-16.2 {Tk_PostscriptFontName procedure: native} {pcOnly} { +test font-21.2 {Tk_PostscriptFontName procedure: native} {pcOnly} { psfontname "arial 10" } {Helvetica} -test font-16.3 {Tk_PostscriptFontName procedure: native} {pcOnly} { +test font-21.3 {Tk_PostscriptFontName procedure: native} {pcOnly} { psfontname "{times new roman} 10" } {Times-Roman} -test font-16.4 {Tk_PostscriptFontName procedure: native} {pcOnly} { +test font-21.4 {Tk_PostscriptFontName procedure: native} {pcOnly} { psfontname "{courier new} 10" } {Courier} -test font-16.5 {Tk_PostscriptFontName procedure: native} {macOnly} { +test font-21.5 {Tk_PostscriptFontName procedure: native} {macOnly} { psfontname "geneva 10" } {Helvetica} -test font-16.6 {Tk_PostscriptFontName procedure: native} {macOnly} { +test font-21.6 {Tk_PostscriptFontName procedure: native} {macOnly} { psfontname "{new york} 10" } {Times-Roman} -test font-16.7 {Tk_PostscriptFontName procedure: native} {macOnly} { +test font-21.7 {Tk_PostscriptFontName procedure: native} {macOnly} { psfontname "monaco 10" } {Courier} -test font-16.8 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { +test font-21.8 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { set x [font actual {{lucida bright} 10} -family] if {[string match lucida*bright $x]} { psfontname "{lucida bright} 10" @@ -448,7 +688,7 @@ test font-16.8 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { set x {LucidaBright} } } {LucidaBright} -test font-16.9 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { +test font-21.9 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { psfontname "{new century schoolbook} 10" } {NewCenturySchlbk-Roman} set i 10 @@ -464,7 +704,7 @@ foreach p { {"zapfchancery" ZapfChancery-MediumItalic ZapfChancery-MediumItalic ZapfChancery-MediumItalic ZapfChancery-MediumItalic} {"zapfdingbats" ZapfDingbats ZapfDingbats ZapfDingbats ZapfDingbats} } { - test font-16.$i {Tk_PostscriptFontName procedure: exhaustive} {unixOnly} { + test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {unixOnly} { set family [lindex $p 0] set x {} set i 1 @@ -490,7 +730,7 @@ foreach p { {"symbol" Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic} {"times new roman" Times-Roman Times-Bold Times-Italic Times-BoldItalic} } { - test font-16.$i {Tk_PostscriptFontName procedure: exhaustive} {pcOnly} { + test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {pcOnly} { set family [lindex $p 0] set x {} foreach slant {roman italic} { @@ -511,7 +751,7 @@ foreach p { {"symbol" Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic} {"times" Times-Roman Times-Bold Times-Italic Times-BoldItalic} } { - test font-16.$i {Tk_PostscriptFontName procedure: exhaustive} {macOnly} { + test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {macOnly} { set family [lindex $p 0] set x {} foreach slant {roman italic} { @@ -524,7 +764,11 @@ foreach p { } [lrange $p 1 end] } -test font-17.1 {Tk_UnderlineChars procedure} { +test font-22.1 {Tk_TextWidth procedure} { + font measure [.b.l cget -font] "000" +} [expr $ax*3] + +test font-23.1 {Tk_UnderlineChars procedure} { text .b.t .b.t insert 1.0 abc\tdefg .b.t tag config sel -underline 1 @@ -533,39 +777,39 @@ test font-17.1 {Tk_UnderlineChars procedure} { } {} setup -test font-18.1 {Tk_ComputeTextLayout: empty string} { +test font-24.1 {Tk_ComputeTextLayout: empty string} { .b.l config -text "" } {} -test font-18.2 {Tk_ComputeTextLayout: simple string} { +test font-24.2 {Tk_ComputeTextLayout: simple string} { .b.l config -text "000" getsize } "[expr $ax*3] $ay" -test font-18.3 {Tk_ComputeTextLayout: find special chars} { +test font-24.3 {Tk_ComputeTextLayout: find special chars} { .b.l config -text "000\n000" getsize } "[expr $ax*3] [expr $ay*2]" -test font-18.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} { +test font-24.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} { .b.l config -text "000\n000" getsize } "[expr $ax*3] [expr $ay*2]" -test font-18.5 {Tk_ComputeTextLayout: break line} { +test font-24.5 {Tk_ComputeTextLayout: break line} { .b.l config -text "000\t00000" -wrap [expr 9*$ax] set x [getsize] .b.l config -wrap 0 set x } "[expr 8*$ax] [expr 2*$ay]" -test font-18.6 {Tk_ComputeTextLayout: normal ended on special char} { +test font-24.6 {Tk_ComputeTextLayout: normal ended on special char} { .b.l config -text "000\n000" } {} -test font-18.7 {Tk_ComputeTextLayout: special char was \n} { +test font-24.7 {Tk_ComputeTextLayout: special char was \n} { .b.l config -text "000\n0000" getsize } "[expr $ax*4] [expr $ay*2]" -test font-18.8 {Tk_ComputeTextLayout: special char was \t} { +test font-24.8 {Tk_ComputeTextLayout: special char was \t} { .b.l config -text "000\t00" getsize } "[expr $ax*10] $ay" -test font-18.9 {Tk_ComputeTextLayout: tab didn't cause break} { +test font-24.9 {Tk_ComputeTextLayout: tab didn't cause break} { set x {} .b.l config -text "000\t000" lappend x [getsize] @@ -574,7 +818,7 @@ test font-18.9 {Tk_ComputeTextLayout: tab didn't cause break} { .b.l config -wrap 0 set x } "{[expr $ax*11] $ay} {[expr $ax*11] $ay}" -test font-18.10 {Tk_ComputeTextLayout: tab caused break} { +test font-24.10 {Tk_ComputeTextLayout: tab caused break} { set x {} .b.l config -text "000\t" lappend x [getsize] @@ -583,7 +827,7 @@ test font-18.10 {Tk_ComputeTextLayout: tab caused break} { .b.l config -wrap 0 set x } "{[expr $ax*3] $ay} {[expr $ax*3] [expr $ay*2]}" -test font-18.11 {Tk_ComputeTextLayout: absorb spaces at eol} { +test font-24.11 {Tk_ComputeTextLayout: absorb spaces at eol} { set x {} .b.l config -text "000 000" -wrap [expr $ax*5] lappend x [getsize] @@ -592,7 +836,7 @@ test font-18.11 {Tk_ComputeTextLayout: absorb spaces at eol} { .b.l config -wrap 0 set x } "{[expr $ax*3] [expr $ay*2]} {[expr $ax*3] $ay}" -test font-18.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} { +test font-24.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} { set x {} .b.l config -text "000 0000" -wrap [expr $ax*5] lappend x [getsize] @@ -601,14 +845,14 @@ test font-18.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} { .b.l config -wrap 0 set x } "{[expr $ax*4] [expr $ay*2]} {[expr $ax*10] [expr $ay*2]}" -test font-18.13 {Tk_ComputeTextLayout: many lines -> realloc line array} { +test font-24.13 {Tk_ComputeTextLayout: many lines -> realloc line array} { .b.l config -text "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n" getsize } "1 [expr $ay*129]" -test font-18.14 {Tk_ComputeTextLayout: text ended with \n} { +test font-24.14 {Tk_ComputeTextLayout: text ended with \n} { list [.b.l config -text "0000"; getsize] [.b.l config -text "0000\n"; getsize] } "{[expr $ax*4] $ay} {[expr $ax*4] [expr $ay*2]}" -test font-18.15 {Tk_ComputeTextLayout: justification} { +test font-24.15 {Tk_ComputeTextLayout: justification} { csetup "000\n00000" set x {} .b.c itemconfig text -just left @@ -621,52 +865,52 @@ test font-18.15 {Tk_ComputeTextLayout: justification} { set x } {2 1 0} -test font-19.1 {Tk_FreeTextLayout procedure} { +test font-25.1 {Tk_FreeTextLayout procedure} { setup .b.f config -text foo .b.f config -text boo } {} -test font-20.1 {Tk_DrawTextLayout procedure: auto-detect last char} { +test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} { .b.f config -text foo } {} -test font-20.2 {Tk_DrawTextLayout procedure: multiple chunks} { +test font-26.2 {Tk_DrawTextLayout procedure: multiple chunks} { csetup "000\t00\n000" } {} -test font-20.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} { +test font-26.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} { csetup "000\t00" .b.c select from text 3 .b.c select to text 5 } {} -test font-20.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} { +test font-26.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} { .b.c select from text 3 .b.c select to text 5 } {} -test font-20.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} { +test font-26.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} { .b.c select from text 2 .b.c select to text 2 } {} -test font-20.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} { +test font-26.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} { .b.c select from text 4 .b.c select to text 4 } {} -test font-21.1 {Tk_UnderlineTextLayout procedure: no underline chosen} { +test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} { .b.f config -text "foo" -under -1 } {} -test font-21.2 {Tk_UnderlineTextLayout procedure: underline not visible} { +test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} { .b.f config -text "000 00000" -wrap [expr $ax*7] -under 10 } {} -test font-21.3 {Tk_UnderlineTextLayout procedure: underline is visible} { +test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} { .b.f config -text "000 00000" -wrap [expr $ax*7] -under 5 .b.f config -wrap -1 -under -1 } {} -test font-22.1 {Tk_PointToChar procedure: above all lines} { +test font-28.1 {Tk_PointToChar procedure: above all lines} { csetup "000" .b.c index text @-1,0 } {0} -test font-22.2 {Tk_PointToChar procedure: no chars} { +test font-28.2 {Tk_PointToChar procedure: no chars} { # After fixing the following bug: # # In canvas text item, it was impossible to click to position the @@ -678,103 +922,103 @@ test font-22.2 {Tk_PointToChar procedure: no chars} { csetup "" .b.c index text @100,100 } {0} -test font-22.3 {Tk_PointToChar procedure: loop test} { +test font-28.3 {Tk_PointToChar procedure: loop test} { csetup "000\n000\n000\n000" .b.c index text @10000,0 } {3} -test font-22.4 {Tk_PointToChar procedure: intersect line} { +test font-28.4 {Tk_PointToChar procedure: intersect line} { csetup "000\n000\n000" .b.c index text @0,$ay } {4} -test font-22.5 {Tk_PointToChar procedure: to the left of all chunks} { +test font-28.5 {Tk_PointToChar procedure: to the left of all chunks} { .b.c index text @-100,$ay } {4} -test font-22.6 {Tk_PointToChar procedure: past any possible chunk} { +test font-28.6 {Tk_PointToChar procedure: past any possible chunk} { .b.c index text @100000,$ay } {7} -test font-22.7 {Tk_PointToChar procedure: which chunk on this line} { +test font-28.7 {Tk_PointToChar procedure: which chunk on this line} { csetup "000\n000\t000\t000\n000" .b.c index text @[expr $ax*2],$ay } {6} -test font-22.8 {Tk_PointToChar procedure: which chunk on this line} { +test font-28.8 {Tk_PointToChar procedure: which chunk on this line} { csetup "000\n000\t000\t000\n000" .b.c index text @[expr $ax*10],$ay } {10} -test font-22.9 {Tk_PointToChar procedure: in special chunk} { +test font-28.9 {Tk_PointToChar procedure: in special chunk} { csetup "000\n000\t000\t000\n000" .b.c index text @[expr $ax*6],$ay } {7} -test font-22.10 {Tk_PointToChar procedure: past all chars in chunk} { +test font-28.10 {Tk_PointToChar procedure: past all chars in chunk} { csetup "000 0000000" .b.c itemconfig text -width [expr $ax*5] set x [.b.c index text @[expr $ax*5],0] .b.c itemconfig text -width 0 set x } {3} -test font-22.11 {Tk_PointToChar procedure: below all chunks} { +test font-28.11 {Tk_PointToChar procedure: below all chunks} { csetup "000 0000000" .b.c index text @0,1000000 } {11} -test font-23.1 {Tk_CharBBox procedure: index < 0} { +test font-29.1 {Tk_CharBBox procedure: index < 0} { .b.f config -text "000" -underline -1 } {} -test font-23.2 {Tk_CharBBox procedure: loop} { +test font-29.2 {Tk_CharBBox procedure: loop} { .b.f config -text "000\t000\t000\t000" -underline 9 } {} -test font-23.3 {Tk_CharBBox procedure: special char} { +test font-29.3 {Tk_CharBBox procedure: special char} { .b.f config -text "000\t000\t000" -underline 7 } {} -test font-23.4 {Tk_CharBBox procedure: normal char} { +test font-29.4 {Tk_CharBBox procedure: normal char} { .b.f config -text "000" -underline 1 } {} -test font-23.5 {Tk_CharBBox procedure: right edge of bbox truncated} { +test font-29.5 {Tk_CharBBox procedure: right edge of bbox truncated} { .b.f config -text "0 0000" -wrap [expr $ax*4] -under 2 .b.f config -wrap 0 } {} -test font-23.6 {Tk_CharBBox procedure: bbox pegged to right edge} { +test font-29.6 {Tk_CharBBox procedure: bbox pegged to right edge} { .b.f config -text "0 0000" -wrap [expr $ax*4] -under 3 .b.f config -wrap 0 } {} .b.c bind all <Enter> {lappend x [.b.c index current @%x,%y]} -test font-24.1 {Tk_TextLayoutToPoint procedure: loop once} { +test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} { csetup "000\n000\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x 0 -y 0 set x } {0} -test font-24.2 {Tk_TextLayoutToPoint procedure: loop multiple} { +test font-30.2 {Tk_DistanceToTextLayout procedure: loop multiple} { csetup "000\n000\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x $ax -y $ay set x } {5} -test font-24.3 {Tk_TextLayoutToPoint procedure: loop to end} { +test font-30.3 {Tk_DistanceToTextLayout procedure: loop to end} { csetup "000\n0\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x [expr $ax*2] -y $ay set x } {} -test font-24.4 {Tk_TextLayoutToPoint procedure: hit a special char (tab)} { +test font-30.4 {Tk_DistanceToTextLayout procedure: hit a special char (tab)} { csetup "000\t000\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x [expr $ax*6] -y 0 set x } {3} -test font-24.5 {Tk_TextLayoutToPoint procedure: ignore newline} { +test font-30.5 {Tk_DistanceToTextLayout procedure: ignore newline} { csetup "000\n0\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x [expr $ax*2] -y $ay set x } {} -test font-24.6 {Tk_TextLayoutToPoint procedure: ignore spaces at eol} { +test font-30.6 {Tk_DistanceToTextLayout procedure: ignore spaces at eol} { csetup "000\n000 000000000" .b.c itemconfig text -width [expr $ax*10] set x {} @@ -784,42 +1028,42 @@ test font-24.6 {Tk_TextLayoutToPoint procedure: ignore spaces at eol} { set x } {} .b.c itemconfig text -justify center -test font-24.7 {Tk_TextLayoutToPoint procedure: on left side} { +test font-30.7 {Tk_DistanceToTextLayout procedure: on left side} { csetup "0\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x 0 -y 0 set x } {} -test font-24.8 {Tk_TextLayoutToPoint procedure: on right side} { +test font-30.8 {Tk_DistanceToTextLayout procedure: on right side} { csetup "0\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x [expr $ax*2] -y 0 set x } {} -test font-24.9 {Tk_TextLayoutToPoint procedure: inside line} { +test font-30.9 {Tk_DistanceToTextLayout procedure: inside line} { csetup "0\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x $ax -y 0 set x } {0} -test font-24.10 {Tk_TextLayoutToPoint procedure: above line} { +test font-30.10 {Tk_DistanceToTextLayout procedure: above line} { csetup "0\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x 0 -y 0 set x } {} -test font-24.11 {Tk_TextLayoutToPoint procedure: below line} { +test font-30.11 {Tk_DistanceToTextLayout procedure: below line} { csetup "000\n0" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x 0 -y $ay set x } {} -test font-24.12 {Tk_TextLayoutToPoint procedure: in line} { +test font-30.12 {Tk_DistanceToTextLayout procedure: in line} { csetup "0\n000" set x {} event generate .b.c <Leave> @@ -827,7 +1071,7 @@ test font-24.12 {Tk_TextLayoutToPoint procedure: in line} { set x } {3} .b.c itemconfig text -justify left -test font-24.13 {Tk_TextLayoutToPoint procedure: exact hit} { +test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} { csetup "000" set x {} event generate .b.c <Leave> @@ -835,27 +1079,27 @@ test font-24.13 {Tk_TextLayoutToPoint procedure: exact hit} { set x } {1} -test font-25.1 {Tk_TextLayoutToArea procedure: loop once} { +test font-31.1 {Tk_IntersectTextLayout procedure: loop once} { csetup "000\n000\n000" .b.c find overlapping 0 0 0 0 } [.b.c find withtag text] -test font-25.2 {Tk_TextLayoutToArea procedure: loop multiple} { +test font-31.2 {Tk_IntersectTextLayout procedure: loop multiple} { csetup "000\t000\t000" .b.c find overlapping [expr $ax*10] 0 [expr $ax*10] 0 } [.b.c find withtag text] -test font-25.3 {Tk_TextLayoutToArea procedure: loop to end} { +test font-31.3 {Tk_IntersectTextLayout procedure: loop to end} { csetup "0\n000" .b.c find overlapping [expr $ax*2] 0 [expr $ax*2] 0 } {} -test font-25.4 {Tk_TextLayoutToArea procedure: hit a special char (tab)} { +test font-31.4 {Tk_IntersectTextLayout procedure: hit a special char (tab)} { csetup "000\t000" .b.c find overlapping [expr $ax*6] 0 [expr $ax*6] 0 } [.b.c find withtag text] -test font-25.5 {Tk_TextLayoutToArea procedure: ignore newlines} { +test font-31.5 {Tk_IntersectTextLayout procedure: ignore newlines} { csetup "000\n0\n000" .b.c find overlapping $ax $ay $ax $ay } {} -test font-25.6 {Tk_TextLayoutToArea procedure: ignore spaces at eol} { +test font-31.6 {Tk_IntersectTextLayout procedure: ignore spaces at eol} { csetup "000\n000 000000000" .b.c itemconfig text -width [expr $ax*10] set x [.b.c find overlapping [expr $ax*5] $ay [expr $ax*5] $ay] @@ -863,7 +1107,7 @@ test font-25.6 {Tk_TextLayoutToArea procedure: ignore spaces at eol} { set x } {} -test font-26.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { +test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { # If there were a whole bunch of returns or tabs in a row, then the # temporary buffer could overflow and write on the stack. @@ -910,29 +1154,19 @@ test font-26.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { (end) } -test font-27.1 {Tk_TextWidth procedure} { - font measure [.b.l cget -font] "000" -} [expr $ax*3] - -test font-28.1 {SetupFontMetrics procedure} { - setup - .b.f config -font $fixed +test font-33.1 {Tk_TextWidth procedure} { } {} -test font-29.1 {TkInitFontAttributes procedure} { +test font-33.2 {ConfigAttributesObj procedure: arguments} { + # (Tcl_GetIndexFromObj() != TCL_OK) setup - font create xyz - font config xyz -} {-family {} -size 0 -weight normal -slant roman -underline 0 -overstrike 0} - -test font-30.1 {ConfigAttributes procedure: arguments} { + list [catch {font create xyz -xyz} msg] $msg +} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} +test font-34.1 {ConfigAttributesObj procedure: arguments} { + # (objc & 1) setup list [catch {font create xyz -family} msg] $msg -} {1 {missing value for "-family" option}} -test font-30.2 {ConfigAttributes procedure: arguments} { - setup - list [catch {font create xyz -xyz xyz} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} +} {1 {value for "-family" option missing}} set i 3 foreach p { {family xyz times} @@ -943,7 +1177,7 @@ foreach p { {overstrike 0 1} } { set opt [lindex $p 0] - test font-30.$i "ConfigAttributes procedure: $opt" { + test font-34.$i "ConfigAttributesObj procedure: $opt" { setup set x {} font create xyz -$opt [lindex $p 1] @@ -955,27 +1189,37 @@ foreach p { } foreach p { {size xyz {1 {expected integer but got "xyz"}}} - {weight xyz {1 {bad -weight value "xyz": must be normal, bold}}} - {slant xyz {1 {bad -slant value "xyz": must be roman, italic}}} + {weight xyz {1 {bad -weight value "xyz": must be normal, or bold}}} + {slant xyz {1 {bad -slant value "xyz": must be roman, or italic}}} {underline xyz {1 {expected boolean value but got "xyz"}}} {overstrike xyz {1 {expected boolean value but got "xyz"}}} } { - test font-30.$i "ConfigAttributes procedure: [lindex $p 0]" { + test font-34.$i "ConfigAttributesObj procedure: [lindex $p 0]" { setup list [catch {font create xyz -[lindex $p 0] [lindex $p 1]} msg] $msg } [lindex $p 2] incr i } -test font-31.1 {GetAttributeInfo procedure: error} { - list [catch {font actual xyz -style} msg] $msg -} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-31.2 {GetAttributeInfo procedure: all attributes} { +test font-35.1 {GetAttributeInfoObj procedure: one attribute} { + # (objPtr != NULL) + setup + font create xyz -family xyz + font config xyz -family +} {xyz} +test font-36.1 {GetAttributeInfoObj procedure: unknown attribute} { + # (Tcl_GetIndexFromObj() != TCL_OK) + setup + font create xyz + list [catch {font config xyz -xyz} msg] $msg +} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} +test font-37.1 {GetAttributeInfoObj procedure: all attributes} { + # not (objPtr != NULL) setup font create xyz -family xyz font config xyz } {-family xyz -size 0 -weight normal -slant roman -underline 0 -overstrike 0} -set i 3 +set i 4 foreach p { {family xyz xyz} {size 20 20} @@ -993,100 +1237,148 @@ foreach p { } # In tests below, one field is set to "xyz" so that font name doesn't -# look like a native X font, so that ParseFontName or TkParseXLFD will +# look like a native X font, so that ParseFontNameObj or TkParseXLFD will # be called. setup -test font-32.1 {ParseFontName procedure: begins with -} { +test font-38.1 {ParseFontNameObj procedure: begins with -} { lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 } $times -test font-32.2 {ParseFontName procedure: begins with -*} { +test font-38.2 {ParseFontNameObj procedure: begins with -*} { lindex [font actual -*-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 } $times -test font-32.3 {ParseFontName procedure: begins with -, doesn't look like list} { +test font-38.3 {ParseFontNameObj procedure: begins with -, doesn't look like list} { lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 } $times -test font-32.4 {ParseFontName procedure: begins with -, looks like list} { +test font-38.4 {ParseFontNameObj procedure: begins with -, looks like list} { lindex [font actual {-family times}] 1 } $times -test font-32.5 {ParseFontName procedure: begins with *} { +test font-38.5 {ParseFontNameObj procedure: begins with *} { lindex [font actual *-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 } $times -test font-32.6 {ParseFontName procedure: begins with *} { +test font-38.6 {ParseFontNameObj procedure: begins with *} { font actual *-times-xyz -family } $times -test font-32.7 {ParseFontName procedure: arguments} { - list [catch {font actual {}} msg] $msg +test font-38.7 {ParseFontNameObj procedure: arguments} {noExceed} { + list [catch {font actual "\{xyz"} msg] $msg +} [list 1 "font \"{xyz\" doesn't exist"] +test font-38.8 {ParseFontNameObj procedure: arguments} {noExceed} { + list [catch {font actual ""} msg] $msg } {1 {font "" doesn't exist}} -test font-32.8 {ParseFontName procedure: arguments} { +test font-38.9 {ParseFontNameObj procedure: arguments} { list [catch {font actual {times 20 xyz xyz}} msg] $msg } {1 {unknown font style "xyz"}} -test font-32.9 {ParseFontName procedure: arguments} { +test font-38.10 {ParseFontNameObj procedure: arguments} { list [catch {font actual {times xyz xyz}} msg] $msg } {1 {expected integer but got "xyz"}} -test font-32.10 {ParseFontName procedure: stylelist loop} {macOnly} { +test font-38.11 {ParseFontNameObj procedure: stylelist loop} {macOnly} { lrange [font actual {times 12 bold italic overstrike underline}] 4 end } {-weight bold -slant italic -underline 1 -overstrike 0} -test font-32.11 {ParseFontName procedure: stylelist loop} {unixOrPc} { +test font-38.12 {ParseFontNameObj procedure: stylelist loop} {unixOrPc} { lrange [font actual {times 12 bold italic overstrike underline}] 4 end } {-weight bold -slant italic -underline 1 -overstrike 1} -test font-32.12 {ParseFontName procedure: stylelist error} { +test font-38.13 {ParseFontNameObj procedure: stylelist error} { list [catch {font actual {times 12 bold xyz}} msg] $msg } {1 {unknown font style "xyz"}} -test font-33.1 {TkParseXLFD procedure: initial dash} { +test font-39.1 {NewChunk procedure: test realloc} { + .b.f config -text "xxx\nxxx\txxx\nxxx\t\t\t" +} {} + +test font-40.1 {TkFontParseXLFD procedure: initial dash} { font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-* -family } $times -test font-33.2 {TkParseXLFD procedure: no initial dash} { +test font-40.2 {TkFontParseXLFD procedure: no initial dash} { font actual *-times-*-*-*-*-*-*-*-*-*-*-*-xyz -family } $times -test font-33.3 {TkParseXLFD procedure: not enough fields} { +test font-40.3 {TkFontParseXLFD procedure: not enough fields} { font actual -xyz-times-*-*-* -family } $times -test font-33.4 {TkParseXLFD procedure: all fields unspecified} { +test font-40.4 {TkFontParseXLFD procedure: all fields unspecified} { lindex [font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-*] 0 } {-family} -test font-33.5 {TkParseXLFD procedure: all fields specified} { +test font-40.5 {TkFontParseXLFD procedure: all fields specified} { lindex [font actual -foundry-times-weight-slant-setwidth-addstyle-10-10-10-10-spacing-avgwidth-registry-encoding] 1 } $times -test font-33.6 {TkParseXLFD procedure: arguments} { +test font-41.1 {TkParseXLFD procedure: arguments} { # XLFD with bad pointsize: fallback to some system font. font actual -*-*-*-*-*-*-xyz-*-*-*-*-*-*-* set x {} } {} -test font-33.7 {TkParseXLFD procedure: arguments} { +test font-42.1 {TkFontParseXLFD procedure: arguments} { # XLFD with bad pixelsize: fallback to some system font. font actual -*-*-*-*-*-*-*-xyz-*-*-*-*-*-* set x {} } {} -test font-33.8 {TkParseXLFD procedure: pixelsize specified} { +test font-42.2 {TkFontParseXLFD procedure: pixelsize specified} { font metrics -xyz-times-*-*-*-*-12-*-*-*-*-*-*-* -linespace set x {} } {} -test font-33.9 {TkParseXLFD procedure: weird pixelsize specified} { +test font-42.3 {TkFontParseXLFD procedure: weird pixelsize specified} { font metrics {-xyz-times-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*-*} -linespace set x {} } {} -test font-33.10 {TkParseXLFD procedure: pointsize specified} { +test font-42.4 {TkFontParseXLFD procedure: pointsize specified} { font metrics -xyz-times-*-*-*-*-*-120-*-*-*-*-*-* -linespace set x {} } {} -test font-33.11 {TkParseXLFD procedure: weird pointsize specified} { +test font-42.5 {TkFontParseXLFD procedure: weird pointsize specified} { font metrics {-xyz-times-*-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*} -linespace set x {} } {} -test font-34.1 {FieldSpecified procedure: specified vs. non-specified} { +test font-43.1 {FieldSpecified procedure: specified vs. non-specified} { font actual -xyz--*-*-*-*-*-*-*-*-*-*-*-* font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-* font actual -xyz-?-*-*-*-*-*-*-*-*-*-*-*-* lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 } $times -test font-35.1 {NewChunk procedure: test realloc} { - .b.f config -text "xxx\nxxx\txxx\nxxx\t\t\t" -} {} +set oldscale [tk scaling] +tk scaling 0.5 +test font-44.1 {TkFontGetPixels: size < 0} { + font actual {times -12} -size +} {24} +test font-44.2 {TkFontGetPoints: size >= 0} {noExceed} { + font actual {times 12} -size +} {12} + +tk scaling $oldscale + +test font-45.1 {TkFontGetAliasList: no match} { + font actual {snarky 10} -family +} [font actual {-size 10} -family] +test font-45.2 {TkFontGetAliasList: match} {macOnly} { + # Result could be either "Times" or "New York" + font actual {{times new roman} 10} -family +} [font actual {times 10} -family] +test font-45.3 {TkFontGetAliasList: match} {pcOnly} { + font actual {times 10} -family +} {Times New Roman} +test font-45.4 {TkFontGetAliasList: match} {unixOnly noExceed} { + # can fail on Unix systems that have a real "times new roman" font + font actual {{times new roman} 10} -family +} [font actual {times 10} -family] + +setup destroy .b + +# cleanup +::tcltest::cleanupTests return + + + + + + + + + + + + + + diff --git a/tk/tests/frame.test b/tk/tests/frame.test index 3919f576a97..24ccb984d46 100644 --- a/tk/tests/frame.test +++ b/tk/tests/frame.test @@ -4,14 +4,13 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -538,18 +537,21 @@ test frame-8.2 {FrameCmdDeletedProc procedure} { update list [info command .f*] [winfo children .] } {{} {}} -test frame-8.3 {FrameCmdDeletedProc procedure} { - eval destroy [winfo children .] - toplevel .f1 -menu .m - wm geometry .f1 +0+0 - menu .m - update - rename .f1 {} - update - set result [list [info command .f*] [winfo children .]] - eval destroy [winfo children .] - set result -} {{} .m} +# +# This one fails with the dash-patch!!!! Still don't know why :-( +# +#test frame-8.3 {FrameCmdDeletedProc procedure} { +# eval destroy [winfo children .] +# toplevel .f1 -menu .m +# wm geometry .f1 +0+0 +# menu .m +# update +# rename .f1 {} +# update +# set result [list [info command .f*] [winfo children .]] +# eval destroy [winfo children .] +# set result +#} {{} .m} test frame-9.1 {MapFrame procedure} { catch {destroy .t} @@ -615,3 +617,20 @@ test frame-11.2 {TkInstallFrameMenu - frame renamed} { catch {destroy .f} rename eatColors {} rename colorsFree {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/geometry.test b/tk/tests/geometry.test index 1144e3ef95c..5a0c495229b 100644 --- a/tk/tests/geometry.test +++ b/tk/tests/geometry.test @@ -4,14 +4,13 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -247,5 +246,22 @@ test geometry-4.10 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { update winfo ismapped .t.quit } {1} + catch {destroy .t} -concat + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/get.test b/tk/tests/get.test new file mode 100644 index 00000000000..0bfa5b9af9c --- /dev/null +++ b/tk/tests/get.test @@ -0,0 +1,97 @@ +# This file is a Tcl script to test out the procedures in the file +# 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. +# All rights reserved. +# +# RCS: @(#) $Id$ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + +button .b +test get-1.1 {Tk_GetAnchorFromObj} { + .b configure -anchor n + .b cget -anchor +} {n} +test get-1.2 {Tk_GetAnchorFromObj} { + .b configure -anchor ne + .b cget -anchor +} {ne} +test get-1.3 {Tk_GetAnchorFromObj} { + .b configure -anchor e + .b cget -anchor +} {e} +test get-1.4 {Tk_GetAnchorFromObj} { + .b configure -anchor se + .b cget -anchor +} {se} +test get-1.5 {Tk_GetAnchorFromObj} { + .b configure -anchor s + .b cget -anchor +} {s} +test get-1.6 {Tk_GetAnchorFromObj} { + .b configure -anchor sw + .b cget -anchor +} {sw} +test get-1.7 {Tk_GetAnchorFromObj} { + .b configure -anchor w + .b cget -anchor +} {w} +test get-1.8 {Tk_GetAnchorFromObj} { + .b configure -anchor nw + .b cget -anchor +} {nw} +test get-1.9 {Tk_GetAnchorFromObj} { + .b configure -anchor n + .b cget -anchor +} {n} +test get-1.10 {Tk_GetAnchorFromObj} { + .b configure -anchor center + .b cget -anchor +} {center} +test get-1.11 {Tk_GetAnchorFromObj - error} { + list [catch {.b configure -anchor unknown} msg] $msg +} {1 {bad anchor "unknown": must be n, ne, e, se, s, sw, w, nw, or center}} + +catch {destroy .b} +button .b +test get-2.1 {Tk_GetJustifyFromObj} { + .b configure -justify left + .b cget -justify +} {left} +test get-2.2 {Tk_GetJustifyFromObj} { + .b configure -justify right + .b cget -justify +} {right} +test get-2.3 {Tk_GetJustifyFromObj} { + .b configure -justify center + .b cget -justify +} {center} +test get-2.4 {Tk_GetJustifyFromObj - error} { + list [catch {.b configure -justify stupid} msg] $msg +} {1 {bad justification "stupid": must be left, right, or center}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/grid.test b/tk/tests/grid.test index f4e27626efc..e9720cb9480 100644 --- a/tk/tests/grid.test +++ b/tk/tests/grid.test @@ -2,28 +2,14 @@ # of Tk. It is (almost) organized in the standard fashion for Tcl tests. # # Copyright (c) 1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} then \ - {source ../tests/defs} - -# Test Arguments: -# name - Name of test, in the form foo-1.2. -# description - Short textual description of the test, to -# help humans understand what it does. -# constraints - A list of one or more keywords, each of -# which must be the name of an element in -# the array "testConfig". If any of these -# elements is zero, the test is skipped. -# This argument may be omitted. -# script - Script to run to carry out the test. It must -# return a result that can be checked for -# correctness. -# answer - Expected result from script. +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # helper routine to return "." to a sane state after a test # The variable GRID_VERBOSE can be used to "look" at the result @@ -310,18 +296,18 @@ test grid-6.7 {location (y)} { grid_reset 6.7 test grid-6.8 {location (weights)} { - frame .f -width 200 -height 100 -highlightthickness 0 -bg red + frame .f -width 300 -height 100 -highlightthickness 0 -bg red frame .a grid .a grid .f -in .a grid rowconfigure .f 0 -weight 1 grid columnconfigure .f 0 -weight 1 grid propagate .a 0 - .a configure -width 110 -height 15 + .a configure -width 200 -height 15 update set got "" set result "" - for {set y -10} { $y < 120} { incr y} { + for {set y -10} { $y < 210} { incr y} { set a [grid location . $y $y] if {$a != $got} { lappend result $y->$a @@ -329,10 +315,10 @@ test grid-6.8 {location (weights)} { } } set result -} {{-10->-1 -1} {0->0 0} {16->0 1} {111->1 1}} +} {{-10->-1 -1} {0->0 0} {16->0 1} {201->1 1}} grid_reset 6.8 -test grid-6.9 {location: check updates pending} { +test grid-6.9 {location: check updates pending} {nonPortable} { set a "" foreach i {0 1 2} { frame .$i -width 120 -height 75 -bg red @@ -384,7 +370,16 @@ test grid-7.6 {propagate} { set a } {100x100 100x100 75x85} grid_reset 7.6 - +test grid-7.7 {propagate} { + grid propagate . 1 + set res [list [grid propagate .]] + grid propagate . 0 + lappend res [grid propagate .] + grid propagate . 0 + lappend res [grid propagate .] + set res +} [list 1 0 0] +grid_reset 7.7 test grid-8.1 {size} { list [catch {grid size . foo} msg] $msg @@ -798,6 +793,22 @@ test grid-11.14 {default widget placement} { } {{0,25 50,50} {50,0 50,50} {50,50 50,50}} grid_reset 11.14 +test grid-11.15 {^ ^ test with multiple windows} { + foreach i {1 2 3 4} { + frame .f$i -width 50 -height 50 -bd 1 -relief solid + } + grid .f1 .f2 .f3 -sticky ns + grid .f4 ^ ^ + update + set a "" + foreach i {1 2 3 4} { + lappend a "[winfo x .f$i],[winfo y .f$i]\ + [winfo width .f$i],[winfo height .f$i]" + } + set a +} {{0,0 50,50} {50,0 50,100} {100,0 50,100} {0,50 50,50}} +grid_reset 11.15 + test grid-12.1 {-sticky} { catch {unset data} frame .f -width 200 -height 100 -highlightthickness 0 -bg red @@ -1002,23 +1013,26 @@ test grid-14.2 {structure notify} { } {{0 0 200 100,0 0 200 100} {0 0 240 140,20 20 200 100}} grid_reset 14.2 -test grid-14.3 {map notify} { - global A - catch {unset A} - bind . <Configure> {incr A(%W)} - set A(.) 0 - foreach i {0 1 2} { - frame .$i -width 100 -height 75 - set A(.$i) 0 - } - grid .0 .1 .2 - update - bind <Configure> .1 {destroy .0} - .2 configure -bd 10 - update - bind . <Configure> {} - array get A -} {.2 2 .0 1 . 1 .1 1} +test grid-14.3 {map notify: bug 1648} {nonPortable} { + # This test is nonPortable because the number of times + # A(.) will be incremented is unspecified--the behavior + # is different accross window managers. + global A + catch {unset A} + bind . <Configure> {incr A(%W)} + set A(.) 0 + foreach i {0 1 2} { + frame .$i -width 100 -height 75 + set A(.$i) 0 + } + grid .0 .1 .2 + update + bind <Configure> .1 {destroy .0} + .2 configure -bd 10 + update + bind . <Configure> {} + array get A +} {.2 2 .0 1 . 2 .1 1} grid_reset 14.3 test grid-15.1 {lost slave} { @@ -1203,3 +1217,44 @@ test grid-16.8 {layout internal constraints} { } set a } {0 30 70 250 280 , 0 30 130 230 260 , 0 30 113 197 280 , 0 30 60 90 120 } + +test grid-17.1 {forget and pending idle handlers} { + # This test is intended to detect a crash caused by a failure to remove + # pending idle handlers when grid forget is invoked. + + toplevel .t + wm geometry .t +0+0 + frame .t.f + label .t.f.l -text foobar + grid .t.f.l + grid .t.f + update + grid forget .t.f.l + grid forget .t.f + destroy .t + + toplevel .t + frame .t.f + label .t.f.l -text foobar + grid .t.f.l + destroy .t + set result ok +} ok + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + + diff --git a/tk/tests/id.test b/tk/tests/id.test index c6ee46f9714..91d75c6112a 100644 --- a/tk/tests/id.test +++ b/tk/tests/id.test @@ -3,19 +3,19 @@ # the standard fashion for Tcl tests. # # Copyright (c) 1995 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } if {[string compare testwrapper [info commands testwrapper]] != 0} { puts "This application hasn't been compiled with the testwrapper command," puts "therefore I am skipping all of these tests." + ::tcltest::cleanupTests return } @@ -100,3 +100,20 @@ test id-1.1 {WindowIdCleanup, delaying window release} {unixOnly} { lappend result [lsort $reused] [lsort $x] } {{.f .f.a .f.b .f.c .f.d .f.e .f.f .f.g .f.h .f.i .f.j .f.k .f.l .f.m .f.n .f.o .f.p .f.q} {} {} {.f.o .f.p .f.q wrapper.f.p wrapper.f.q} {}} bind all <Destroy> {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/image.test b/tk/tests/image.test index fc899c0939a..ea0f0be00d5 100644 --- a/tk/tests/image.test +++ b/tk/tests/image.test @@ -4,23 +4,23 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[info procs test] != "test"} { - source defs -} - foreach i [winfo children .] { destroy $i } @@ -355,3 +355,20 @@ test image-13.1 {image command vs hidden commands} { destroy .c eval image delete [image names] + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/imgBmap.test b/tk/tests/imgBmap.test index ec8d7d1fa11..2ce431f302f 100644 --- a/tk/tests/imgBmap.test +++ b/tk/tests/imgBmap.test @@ -4,14 +4,13 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -472,3 +471,20 @@ removeFile foo.bm removeFile foo2.bm destroy .c eval image delete [image names] + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/imgPPM.test b/tk/tests/imgPPM.test index e0ffb0a3393..39e2a66485f 100644 --- a/tk/tests/imgPPM.test +++ b/tk/tests/imgPPM.test @@ -3,14 +3,13 @@ # The files is organized in the standard fashion for Tcl tests. # # Copyright (c) 1994-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -75,7 +74,7 @@ test imgPPM-2.1 {FileWritePPM procedure} { } {1 {couldn't open "not_a_dir/bar/baz/gorp": no such file or directory} {posix enoent {no such file or directory}}} test imgPPM-2.2 {FileWritePPM procedure} { catch {unset data} - p1 write test2.ppm + p1 write -format ppm test2.ppm set fd [open test2.ppm] set data [read $fd] close $fd @@ -154,3 +153,20 @@ test imgPPM-3.13 {ReadPPMFileHeader procedure, file ends too soon} { removeFile test.ppm removeFile test2.ppm eval image delete [image names] + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/imgPhoto.test b/tk/tests/imgPhoto.test index e0c6f568ea1..a221a3e65e0 100644 --- a/tk/tests/imgPhoto.test +++ b/tk/tests/imgPhoto.test @@ -4,16 +4,15 @@ # # Copyright (c) 1994 The Australian National University # Copyright (c) 1994-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # Author: Paul Mackerras (paulus@cs.anu.edu.au) # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -28,6 +27,30 @@ canvas .c pack .c update +# temporarily copy the README fiel from testsDir to tmpDir +if {![file exists README]} { + set newREADME [file join $::tcltest::workingDir README] + file copy [file join $::tcltest::testsDir README] $newREADME + set removeREADME 1 +} + +# find the teapot.ppm file for use in these tests +# first look in $tk_library/demos/images/teapot.ppm +# then look in <this file>/../../library/demos/images/teapot.ppm +# skip this file if you can't find the teapot.ppm file. +set teapotPhotoFile [file join $tk_library demos images teapot.ppm] +if {![file exists $teapotPhotoFile]} { + set newLib [file dirname $::tcltest::testsDir] + set teapotPhotoFile \ + [file join $newLib library demos images teapot.ppm] + if {![file exists $teapotPhotoFile]} { + puts "Can't find [file join demos images teapot.ppm] in $tk_library" + puts "your Tk library is incomplete, so I am skipping imgPhoto tests." + ::tcltest::cleanupTests + return 0 + } +} + test imgPhoto-1.1 {options for photo images} { image create photo p1 -width 79 -height 83 list [lindex [p1 configure -width] 4] [lindex [p1 configure -height] 4] \ @@ -38,21 +61,19 @@ test imgPhoto-1.2 {options for photo images} { [string tolower $err] } {1 {couldn't open "no.such.file": no such file or directory}} test imgPhoto-1.3 {options for photo images} { - list [catch {image create photo p1 -file \ - [file join $tk_library demos/images/teapot.ppm] \ + list [catch {image create photo p1 -file $teapotPhotoFile \ -format no.such.format} err] $err } {1 {image file format "no.such.format" is not supported}} test imgPhoto-1.4 {options for photo images} { - image create photo p1 -file [file join $tk_library demos/images/teapot.ppm] + image create photo p1 -file $teapotPhotoFile list [image width p1] [image height p1] } {256 256} test imgPhoto-1.5 {options for photo images} { - image create photo p1 \ - -file [file join $tk_library demos/images/teapot.ppm] \ + image create photo p1 -file $teapotPhotoFile \ -format ppm -width 79 -height 83 list [image width p1] [image height p1] \ [lindex [p1 configure -file] 4] [lindex [p1 configure -format] 4] -} [list 79 83 [file join $tk_library demos/images/teapot.ppm] ppm] +} [list 79 83 $teapotPhotoFile ppm] test imgPhoto-1.6 {options for photo images} { image create photo p1 -palette 2/2/2 -gamma 2.2 list [format %.1f [lindex [p1 configure -gamma] 4]] \ @@ -85,11 +106,11 @@ test imgPhoto-2.2 {ImgPhotoCreate procedure} { # } {couldn't open "bogus.img": no such file or directory} test imgPhoto-3.1 {ImgPhotoConfigureMaster procedure} { - image create photo p1 -file [file join $tk_library demos/images/teapot.ppm] - p1 configure -file [file join $tk_library demos/images/teapot.ppm] + image create photo p1 -file $teapotPhotoFile + p1 configure -file $teapotPhotoFile } {} test imgPhoto-3.2 {ImgPhotoConfigureMaster procedure} { - image create photo p1 -file [file join $tk_library demos/images/teapot.ppm] + image create photo p1 -file $teapotPhotoFile list [catch {p1 configure -file bogus} err] [string tolower $err] \ [image width p1] [image height p1] } {1 {couldn't open "bogus": no such file or directory} 256 256} @@ -98,7 +119,7 @@ test imgPhoto-3.3 {ImgPhotoConfigureMaster procedure} { .c create image 10 10 -image p1 -tags p1.1 -anchor nw .c create image 300 10 -image p1 -tags p1.2 -anchor nw update - p1 configure -file [file join $tk_library demos/images/teapot.ppm] + p1 configure -file $teapotPhotoFile update list [image width p1] [image height p1] [.c bbox p1.1] [.c bbox p1.2] } {256 256 {10 10 266 266} {300 10 556 266}} @@ -113,7 +134,7 @@ test imgPhoto-4.1 {ImgPhotoCmd procedure} { } {1 {wrong # args: should be "p1 option ?arg arg ...?"}} test imgPhoto-4.2 {ImgPhotoCmd procedure} { list [catch {p1 blah} err] $err -} {1 {bad option "blah": must be blank, cget, configure, copy, get, put, read, redither, or write}} +} {1 {bad option "blah": must be blank, cget, configure, copy, data, get, put, read, redither, or write}} test imgPhoto-4.3 {ImgPhotoCmd procedure: blank option} { p1 blank list [catch {p1 blank x} err] $err @@ -139,7 +160,7 @@ test imgPhoto-4.9 {ImgPhotoCmd procedure: configure option} { list [catch {p1 configure -palette {} -gamma} msg] $msg } {1 {value for "-gamma" missing}} test imgPhoto-4.10 {ImgPhotoCmd procedure: copy option} { - image create photo p2 -file [file join $tk_library demos/images/teapot.ppm] + image create photo p2 -file $teapotPhotoFile p1 configure -width 0 -height 0 -palette {} -gamma 1 p1 copy p2 list [image width p1] [image height p1] [p1 get 100 100] @@ -198,7 +219,7 @@ test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} { lappend result [image width p1] [image height p1] } {256 256 49 51 49 51 49 51 10 51 10 10} test imgPhoto-4.22 {ImgPhotoCmd procedure: get option} { - p1 read [file join $tk_library demos/images/teapot.ppm] + p1 read $teapotPhotoFile list [p1 get 100 100] [p1 get 150 100] [p1 get 100 150] } {{169 117 90} {172 115 84} {35 35 35}} test imgPhoto-4.23 {ImgPhotoCmd procedure: get option} { @@ -212,7 +233,7 @@ test imgPhoto-4.25 {ImgPhotoCmd procedure: get option} { } {1 {wrong # args: should be "p1 get x y"}} test imgPhoto-4.26 {ImgPhotoCmd procedure: put option} { list [catch {p1 put} err] $err -} {1 {wrong # args: should be "p1 put data ?-format format? ?-to x1 y1 x2 y2?"}} +} {1 {wrong # args: should be "p1 put data ?options?"}} test imgPhoto-4.27 {ImgPhotoCmd procedure: put option} { list [catch {p1 put {{white} {white white}}} err] $err } {1 {all elements of color list must have the same number of elements}} @@ -225,28 +246,25 @@ test imgPhoto-4.29 {ImgPhotoCmd procedure: put option} { } {255 255 255} test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} { list [catch {p1 read} err] $err -} {1 {wrong # args: should be "p1 read fileName ?-format format-name? ?-from x1 y1 x2 y2? ?-to x y? ?-shrink?"}} +} {1 {wrong # args: should be "p1 read fileName ?options?"}} test imgPhoto-4.31 {ImgPhotoCmd procedure: read option} { - list [catch {p1 read [file join $tk_library demos/images/teapot.ppm] \ - -zoom 2} err] $err + list [catch {p1 read $teapotPhotoFile -zoom 2} err] $err } {1 {unrecognized option "-zoom": must be -format, -from, -shrink, or -to}} test imgPhoto-4.32 {ImgPhotoCmd procedure: read option} { list [catch {p1 read bogus} err] [string tolower $err] } {1 {couldn't open "bogus": no such file or directory}} test imgPhoto-4.33 {ImgPhotoCmd procedure: read option} { - list [catch {p1 read [file join $tk_library demos/images/teapot.ppm] \ - -format bogus} err] $err + list [catch {p1 read $teapotPhotoFile -format bogus} err] $err } {1 {image file format "bogus" is not supported}} test imgPhoto-4.34 {ImgPhotoCmd procedure: read option} { list [catch {p1 read README} err] $err } {1 {couldn't recognize data in image file "README"}} test imgPhoto-4.35 {ImgPhotoCmd procedure: read option} { - p1 read [file join $tk_library demos/images/teapot.ppm] -shrink + p1 read $teapotPhotoFile list [image width p1] [image height p1] [p1 get 120 120] } {256 256 {161 109 82}} test imgPhoto-4.36 {ImgPhotoCmd procedure: read option} { - p1 read [file join $tk_library demos/images/teapot.ppm] \ - -from 0 70 60 120 -to 10 10 -shrink + p1 read $teapotPhotoFile -from 0 70 60 120 -to 10 10 -shrink list [image width p1] [image height p1] [p1 get 29 19] } {70 60 {244 180 144}} test imgPhoto-4.37 {ImgPhotoCmd procedure: redither option} { @@ -255,7 +273,7 @@ test imgPhoto-4.37 {ImgPhotoCmd procedure: redither option} { } {1 {wrong # args: should be "p1 redither"}} test imgPhoto-4.38 {ImgPhotoCmd procedure: write option} { list [catch {p1 write} err] $err -} {1 {wrong # args: should be "p1 write fileName ?-format format-name??-from x1 y1 x2 y2?"}} +} {1 {wrong # args: should be "p1 write fileName ?options?"}} test imgPhoto-4.39 {ImgPhotoCmd procedure: write option} { list [catch {p1 write teapot.tmp -format bogus} err] $err } {1 {image file format "bogus" is unknown}} @@ -263,7 +281,7 @@ test imgPhoto-4.39 {ImgPhotoCmd procedure: write option} { test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} { eval image delete [image names] .c delete all - image create photo p1 -file [file join $tk_library demos/images/teapot.ppm] + image create photo p1 -file $teapotPhotoFile .c create image 0 0 -image p1 -tags p1.1 .c create image 256 0 -image p1 -tags p1.2 .c create image 0 256 -image p1 -tags p1.3 @@ -288,14 +306,14 @@ test imgPhoto-6.1 {ImgPhotoDisplay procedure, blank display} { test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} { eval image delete [image names] .c delete all - image create photo p1 -file [file join $tk_library demos/images/teapot.ppm] + image create photo p1 -file $teapotPhotoFile .c create image 0 0 -image p1 -anchor nw update .c delete all image delete p1 } {} test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} { - image create photo p1 -file [file join $tk_library demos/images/teapot.ppm] + image create photo p1 -file $teapotPhotoFile .c create image 10 10 -image p1 -anchor nw button .b1 -image p1 button .b2 -image p1 @@ -311,7 +329,7 @@ test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} { .c delete all } {} test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} { - image create photo p1 -file [file join $tk_library demos/images/teapot.ppm] + image create photo p1 -file $teapotPhotoFile button .b1 -image p1 frame .f -visual best button .f.b2 -image p1 @@ -327,16 +345,16 @@ test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} { } {} test imgPhoto-8.1 {ImgPhotoDelete procedure} { - image create photo p2 -file [file join $tk_library demos/images/teapot.ppm] + image create photo p2 -file $teapotPhotoFile image delete p2 } {} test imagePhoto-8.2 {ImgPhotoDelete procedure} { - image create photo p2 -file [file join $tk_library demos/images/teapot.ppm] + image create photo p2 -file $teapotPhotoFile rename p2 newp2 set x [list [info command p2] [info command new*] [newp2 cget -file]] image delete p2 - lappend x [info command new*] -} [list {} newp2 [file join $tk_library demos/images/teapot.ppm] {}] + append x [info command new*] +} [list {} newp2 $teapotPhotoFile] test imagePhoto-8.3 {ImgPhotoDelete procedure, name cleanup} { image create photo p1 image create photo p2 -width 10 -height 10 @@ -345,7 +363,7 @@ test imagePhoto-8.3 {ImgPhotoDelete procedure, name cleanup} { } {1 {image "p2" doesn't exist or is not a photo image}} test imagePhoto-9.1 {ImgPhotoCmdDeletedProc procedure} { - image create photo p2 -file [file join $tk_library demos/images/teapot.ppm] + image create photo p2 -file $teapotPhotoFile rename p2 {} list [lsearch -exact [image names] p2] [catch {p2 foo} msg] $msg } {-1 1 {invalid command name "p2"}} @@ -353,8 +371,7 @@ test imagePhoto-9.1 {ImgPhotoCmdDeletedProc procedure} { test imgPhoto-10.1 {Tk_ImgPhotoPutBlock procedure} { eval image delete [image names] image create photo p1 - p1 put {{#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000}} \ - -to 0 0 + p1 put {{#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000}} -to 0 0 p1 put {{#00ff00 #00ff00}} -to 2 0 list [p1 get 2 0] [p1 get 3 0] [p1 get 4 0] } {{0 255 0} {0 255 0} {255 0 0}} @@ -367,7 +384,7 @@ test imgPhoto-11.1 {Tk_FindPhoto} { } {1 {image "i1" doesn't exist or is not a photo image}} test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} { - image create photo p3 -file [file join $tk_library demos/images/teapot.ppm] + image create photo p3 -file $teapotPhotoFile set result [list [p3 get 50 50] [p3 get 100 100]] p3 copy p3 -zoom 2 lappend result [image width p3] [image height p3] [p3 get 100 100] @@ -421,3 +438,23 @@ test imgPhoto-13.1 {check separation of images in different interpreters} { destroy .c eval image delete [image names] + +# cleanup +if {[info exists removeREADME]} { + catch {file delete -force $newREADME} +} +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/listbox.test b/tk/tests/listbox.test index 40e65d6218e..900ad1f963a 100644 --- a/tk/tests/listbox.test +++ b/tk/tests/listbox.test @@ -3,14 +3,14 @@ # # Copyright (c) 1993-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} then \ - {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} foreach i [winfo children .] { destroy $i @@ -88,7 +88,7 @@ foreach test { {-highlightcolor #123456 #123456 bogus {unknown color name "bogus"}} {-highlightthickness 6 6 bogus {bad screen distance "bogus"}} {-highlightthickness -2 0 {} {}} - {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} + {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}} {-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}} {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}} @@ -98,6 +98,7 @@ foreach test { {-width 45 45 3p {expected integer but got "3p"}} {-xscrollcommand {Some command} {Some command} {} {}} {-yscrollcommand {Another command} {Another command} {} {}} + {-listvar testVariable testVariable {} {}} } { set name [lindex $test 0] test listbox-1.$i {configuration options} { @@ -238,7 +239,7 @@ test listbox-3.22 {ListboxWidgetCmd procedure, "cget" option} { } {0} test listbox-3.23 {ListboxWidgetCmd procedure, "configure" option} { llength [.l configure] -} {23} +} {24} test listbox-3.24 {ListboxWidgetCmd procedure, "configure" option} { list [catch {.l configure -gorp} msg] $msg } {1 {unknown option "-gorp"}} @@ -335,10 +336,10 @@ test listbox-3.41 {ListboxWidgetCmd procedure, "delete" option} { } {el0 el1 el2 el3 el4 el5 el6 el7} test listbox-3.42 {ListboxWidgetCmd procedure, "get" option} { list [catch {.l get} msg] $msg -} {1 {wrong # args: should be ".l get first ?last?"}} +} {1 {wrong # args: should be ".l get firstIndex ?lastIndex?"}} test listbox-3.43 {ListboxWidgetCmd procedure, "get" option} { list [catch {.l get a b c} msg] $msg -} {1 {wrong # args: should be ".l get first ?last?"}} +} {1 {wrong # args: should be ".l get firstIndex ?lastIndex?"}} test listbox-3.44 {ListboxWidgetCmd procedure, "get" option} { list [catch {.l get 2.4} msg] $msg } {1 {bad listbox index "2.4": must be active, anchor, end, @x,y, or a number}} @@ -481,7 +482,7 @@ test listbox-3.78 {ListboxWidgetCmd procedure, "scan" option} {fonts} { } {{0.249364 0.427481} {0.0714286 0.428571}} test listbox-3.79 {ListboxWidgetCmd procedure, "scan" option} { list [catch {.l scan foo 2 4} msg] $msg -} {1 {bad scan option "foo": must be mark or dragto}} +} {1 {bad option "foo": must be mark or dragto}} test listbox-3.80 {ListboxWidgetCmd procedure, "see" option} { list [catch {.l see} msg] $msg } {1 {wrong # args: should be ".l see index"}} @@ -618,7 +619,7 @@ test listbox-3.110 {ListboxWidgetCmd procedure, "selection" option} { } {2 5 6 7} test listbox-3.111 {ListboxWidgetCmd procedure, "selection" option} { list [catch {.l selection badOption 0 0} msg] $msg -} {1 {bad selection option "badOption": must be anchor, clear, includes, or set}} +} {1 {bad option "badOption": must be anchor, clear, includes, or set}} test listbox-3.112 {ListboxWidgetCmd procedure, "size" option} { list [catch {.l size a} msg] $msg } {1 {wrong # args: should be ".l size"}} @@ -740,19 +741,19 @@ test listbox-3.132 {ListboxWidgetCmd procedure, "xview" option} { } {0.55 0.65} test listbox-3.133 {ListboxWidgetCmd procedure, "xview" option} { list [catch {.l whoknows} msg] $msg -} {1 {bad option "whoknows": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, nearest, scan, see, selection, size, xview, or yview}} +} {1 {bad option "whoknows": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}} test listbox-3.134 {ListboxWidgetCmd procedure, "xview" option} { list [catch {.l c} msg] $msg -} {1 {bad option "c": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, nearest, scan, see, selection, size, xview, or yview}} +} {1 {ambiguous option "c": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}} test listbox-3.135 {ListboxWidgetCmd procedure, "xview" option} { list [catch {.l in} msg] $msg -} {1 {bad option "in": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, nearest, scan, see, selection, size, xview, or yview}} +} {1 {ambiguous option "in": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}} test listbox-3.136 {ListboxWidgetCmd procedure, "xview" option} { list [catch {.l s} msg] $msg -} {1 {bad option "s": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, nearest, scan, see, selection, size, xview, or yview}} +} {1 {ambiguous option "s": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}} test listbox-3.137 {ListboxWidgetCmd procedure, "xview" option} { list [catch {.l se} msg] $msg -} {1 {bad option "se": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, nearest, scan, see, selection, size, xview, or yview}} +} {1 {ambiguous option "se": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}} # No tests for DestroyListbox: I can't come up with anything to test # in this procedure. @@ -865,6 +866,83 @@ test listbox-4.8 {ConfigureListbox procedure} { update set log } {{y 0 1} {x 0 1}} +test listbox-4.9 {ConfigureListbox procedure, -listvar} { + catch {destroy .l} + set x [list a b c d] + listbox .l -listvar x + .l get 0 end +} [list a b c d] +test listbox-4.10 {ConfigureListbox, no listvar -> existing listvar} { + catch {destroy .l} + set x [list a b c d] + listbox .l + .l insert end 1 2 3 4 + .l configure -listvar x + .l get 0 end +} [list a b c d] +test listbox-4.11 {ConfigureListbox procedure, listvar -> no listvar} { + catch {destroy .l} + set x [list a b c d] + listbox .l -listvar x + .l configure -listvar {} + .l insert end 1 2 3 4 + list $x [.l get 0 end] +} [list [list a b c d] [list a b c d 1 2 3 4]] +test listbox-4.12 {ConfigureListbox procedure, listvar -> different listvar} { + catch {destroy .l} + set x [list a b c d] + set y [list 1 2 3 4] + listbox .l + .l configure -listvar x + .l configure -listvar y + .l insert end 5 6 7 8 + list $x $y +} [list [list a b c d] [list 1 2 3 4 5 6 7 8]] +test listbox-4.13 {ConfigureListbox, no listvar -> non-existant listvar} { + catch {destroy .l} + catch {unset x} + listbox .l + .l insert end a b c d + .l configure -listvar x + set x +} [list a b c d] +test listbox-4.14 {ConfigureListbox, non-existant listvar} { + catch {destroy .l} + catch {unset x} + listbox .l -listvar x + list [info exists x] $x +} [list 1 {}] +test listbox-4.15 {ConfigureListbox, listvar -> non-existant listvar} { + catch {destroy .l} + catch {unset y} + set x [list a b c d] + listbox .l -listvar x + .l configure -listvar y + list [info exists y] $y +} [list 1 [list a b c d]] +test listbox-4.16 {ConfigureListbox, listvar -> same listvar} { + catch {destroy .l} + set x [list a b c d] + listbox .l -listvar x + .l configure -listvar x + set x +} [list a b c d] +test listbox-4.17 {ConfigureListbox, no listvar -> no listvar} { + catch {destroy .l} + listbox .l + .l insert end a b c d + .l configure -listvar {} + .l get 0 end +} [list a b c d] +test listbox-4.18 {ConfigureListbox, no listvar -> bad listvar} { + catch {destroy .l} + listbox .l + .l insert end a b c d + set x {this is a " bad list} + catch {.l configure -listvar x} result + list [.l get 0 end] [.l cget -listvar] $result +} [list [list a b c d] {} \ + "unmatched open quote in list: invalid listvar value"] # No tests for DisplayListbox: I don't know how to test this procedure. @@ -1007,6 +1085,22 @@ test listbox-6.12 {InsertEls procedure} {fonts} { .l2 insert 0 "much longer entry" lappend x [winfo reqwidth .l2] [winfo reqheight .l2] } {80 93 122 110} +test listbox-6.13 {InsertEls procedure, check -listvar update} { + catch {destroy .l2} + set x [list a b c d] + listbox .l2 -listvar x + .l2 insert 0 1 2 3 4 + set x +} [list 1 2 3 4 a b c d] +test listbox-6.14 {InsertEls procedure, check selection update} { + catch {destroy .l2} + listbox .l2 + .l2 insert 0 0 1 2 3 4 + .l2 selection set 2 4 + .l2 insert 0 a + .l2 curselection +} [list 3 4 5] + test listbox-7.1 {DeleteEls procedure} { .l delete 0 end @@ -1163,6 +1257,13 @@ test listbox-7.20 {DeleteEls procedure} {fonts} { lappend x [winfo reqwidth .l2] [winfo reqheight .l2] } {80 144 17 93} catch {destroy .l2} +test listbox-7.21 {DeleteEls procedure, check -listvar update} { + catch {destroy .l2} + set x [list a b c d] + listbox .l2 -listvar x + .l2 delete 0 1 + set x +} [list c d] test listbox-8.1 {ListboxEventProc procedure} {fonts} { catch {destroy .l} @@ -1649,6 +1750,309 @@ test listbox-20.1 {listbox vs hidden commands} { list [winfo children .] [interp hidden] } [list {} $l] +# tests for ListboxListVarProc +test listbox-21.1 {ListboxListVarProc} { + catch {destroy .l} + catch {unset x} + listbox .l -listvar x + set x [list a b c d] + .l get 0 end +} [list a b c d] +test listbox-21.2 {ListboxListVarProc} { + catch {destroy .l} + set x [list a b c d] + listbox .l -listvar x + unset x + set x +} [list a b c d] +test listbox-21.3 {ListboxListVarProc} { + catch {destroy .l} + set x [list a b c d] + listbox .l -listvar x + .l configure -listvar {} + unset x + info exists x +} 0 +test listbox-21.4 {ListboxListVarProc} { + catch {destroy .l} + set x [list a b c d] + listbox .l -listvar x + lappend x e f g + .l size +} 7 +test listbox-21.5 {ListboxListVarProc, test selection after listvar mod} { + catch {destroy .l} + set x [list a b c d e f g] + listbox .l -listvar x + .l selection set end + set x [list a b c d] + set x [list 0 1 2 3 4 5 6] + .l curselection +} {} +test listbox-21.6 {ListboxListVarProc, test selection after listvar mod} { + catch {destroy .l} + set x [list a b c d] + listbox .l -listvar x + .l selection set 3 + lappend x e f g + .l curselection +} 3 +test listbox-21.7 {ListboxListVarProc, test selection after listvar mod} { + catch {destroy .l} + set x [list a b c d] + listbox .l -listvar x + .l selection set 0 + set x [linsert $x 0 1 2 3 4] + .l curselection +} 0 +test listbox-21.8 {ListboxListVarProc, test selection after listvar mod} { + catch {destroy .l} + set x [list a b c d] + listbox .l -listvar x + .l selection set 2 + set x [list a b c] + .l curselection +} 2 +test listbox-21.9 {ListboxListVarProc, test hscrollbar after listvar mod} { + catch {destroy .l} + catch {unset x} + set log {} + listbox .l -font $fixed -width 10 -xscrollcommand "record x" -listvar x + pack .l + update + lappend x "0000000000" + update + lappend x "00000000000000000000" + update + set log +} [list {x 0 1} {x 0 1} {x 0 0.5}] +test listbox-21.10 {ListboxListVarProc, test hscrollbar after listvar mod} { + catch {destroy .l} + catch {unset x} + set log {} + listbox .l -font $fixed -width 10 -xscrollcommand "record x" -listvar x + pack .l + update + lappend x "0000000000" + update + lappend x "00000000000000000000" + update + set x [list "0000000000"] + update + set log +} [list {x 0 1} {x 0 1} {x 0 0.5} {x 0 1}] +test listbox-21.11 {ListboxListVarProc, bad list} { + catch {destroy .l} + catch {unset x} + listbox .l -listvar x + set x [list a b c d] + catch {set x {this is a " bad list}} result + set result +} {can't set "x": invalid listvar value} +test listbox-21.12 {ListboxListVarProc, cleanup item attributes} { + catch {destroy .l} + set x [list a b c d e f g] + listbox .l -listvar x + .l itemconfigure end -fg red + set x [list a b c d] + set x [list 0 1 2 3 4 5 6] + .l itemcget end -fg +} {} +test listbox-21.12 {ListboxListVarProc, cleanup item attributes} { + catch {destroy .l} + set x [list a b c d e f g] + listbox .l -listvar x + .l itemconfigure end -fg red + set x [list a b c d] + set x [list 0 1 2 3 4 5 6] + .l itemcget end -fg +} {} +test listbox-21.13 {listbox item configurations and listvar based deletions} { + catch {destroy .l} + catch {unset x} + listbox .l -listvar x + .l insert end a b c + .l itemconfigure 1 -fg red + set x [list b c] + .l itemcget 1 -fg +} red +test listbox-21.14 {listbox item configurations and listvar based inserts} { + catch {destroy .l} + catch {unset x} + listbox .l -listvar x + .l insert end a b c + .l itemconfigure 0 -fg red + set x [list 1 2 3 4 a b c] + .l itemcget 0 -fg +} red +test listbox-21.15 {ListboxListVarProc, update vertical scrollbar} { + catch {destroy .l} + catch {unset x} + set log {} + listbox .l -listvar x -yscrollcommand "record y" -font fixed -height 3 + pack .l + update + lappend x a b c d e f + update + set log +} [list {y 0 1} {y 0 0.5}] +test listbox-21.16 {ListboxListVarProc, update vertical scrollbar} { + catch {destroy .l} + catch {unset x} + listbox .l -listvar x -height 3 + pack .l + update + set x [list 0 1 2 3 4 5] + .l yview scroll 3 units + update + set result {} + lappend result [.l yview] + set x [lreplace $x 3 3] + set x [lreplace $x 3 3] + set x [lreplace $x 3 3] + update + lappend result [.l yview] + set result +} [list {0.5 1} {0 1}] + +# UpdateHScrollbar +test listbox-22.1 {UpdateHScrollbar} { + catch {destroy .l} + set log {} + listbox .l -font $fixed -width 10 -xscrollcommand "record x" + pack .l + update + .l insert end "0000000000" + update + .l insert end "00000000000000000000" + update + set log +} [list {x 0 1} {x 0 1} {x 0 0.5}] + +# ConfigureListboxItem +test listbox-23.1 {ConfigureListboxItem} { + catch {destroy .l} + listbox .l + catch {.l itemconfigure 0} result + set result +} {item number "0" out of range} +test listbox-23.2 {ConfigureListboxItem} { + catch {destroy .l} + listbox .l + .l insert end a b c d + .l itemconfigure 0 +} [list {-background background Background {} {}} \ + {-bg -background} \ + {-fg -foreground} \ + {-foreground foreground Foreground {} {}} \ + {-selectbackground selectBackground Foreground {} {}} \ + {-selectforeground selectForeground Background {} {}}] +test listbox-23.3 {ConfigureListboxItem, itemco shortcut} { + catch {destroy .l} + listbox .l + .l insert end a b c d + .l itemco 0 -background +} {-background background Background {} {}} +test listbox-23.4 {ConfigureListboxItem, wrong num args} { + catch {destroy .l} + listbox .l + .l insert end a + catch {.l itemco} result + set result +} {wrong # args: should be ".l itemconfigure index ?option? ?value? ?option value ...?"} +test listbox-23.5 {ConfigureListboxItem, multiple calls} { + catch {destroy .l} + listbox .l + set i 0 + foreach color {red orange yellow green blue darkblue violet} { + .l insert end $color + .l itemconfigure $i -bg $color + incr i + } + pack .l + update + list [.l itemcget 0 -bg] [.l itemcget 1 -bg] [.l itemcget 2 -bg] \ + [.l itemcget 3 -bg] [.l itemcget 4 -bg] [.l itemcget 5 -bg] \ + [.l itemcget 6 -bg] +} {red orange yellow green blue darkblue violet} +catch {destroy .l} +listbox .l +.l insert end a b c d +set i 6 +foreach test { + {-background #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} + {-fg #110022 #110022 bogus {unknown color name "bogus"}} + {-foreground #110022 #110022 bogus {unknown color name "bogus"}} + {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}} + {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}} +} { + set name [lindex $test 0] + test listbox-23.$i {configuration options} { + .l itemconfigure 0 $name [lindex $test 1] + list [lindex [.l itemconfigure 0 $name] 4] [.l itemcget 0 $name] + } [list [lindex $test 2] [lindex $test 2]] + incr i + if {[lindex $test 3] != ""} { + test listbox-1.$i {configuration options} { + list [catch {.l configure $name [lindex $test 3]} msg] $msg + } [list 1 [lindex $test 4]] + } + .l configure $name [lindex [.l configure $name] 3] + incr i +} + +# ListboxWidgetObjCmd, itemcget +test listbox-24.1 {itemcget} { + catch {destroy .l} + listbox .l + .l insert end a b c d + .l itemcget 0 -fg +} {} +test listbox-24.2 {itemcget} { + catch {destroy .l} + listbox .l + .l insert end a b c d + .l itemconfigure 0 -fg red + .l itemcget 0 -fg +} red +test listbox-24.3 {itemcget} { + catch {destroy .l} + listbox .l + .l insert end a b c d + catch {.l itemcget 0} result + set result +} {wrong # args: should be ".l itemcget index option"} +test listbox-24.3 {itemcget, itemcg shortcut} { + catch {destroy .l} + listbox .l + .l insert end a b c d + catch {.l itemcg 0} result + set result +} {wrong # args: should be ".l itemcget index option"} + +# General item configuration issues +test listbox-25.1 {listbox item configurations and widget based deletions} { + catch {destroy .l} + listbox .l + .l insert end a + .l itemconfigure 0 -fg red + .l delete 0 end + .l insert end a + .l itemcget 0 -fg +} {} +test listbox-25.2 {listbox item configurations and widget based inserts} { + catch {destroy .l} + listbox .l + .l insert end a b c + .l itemconfigure 0 -fg red + .l insert 0 1 2 3 4 + list [.l itemcget 0 -fg] [.l itemcget 4 -fg] +} [list {} red] + + + resetGridInfo catch {destroy .l2} catch {destroy .t} @@ -1656,3 +2060,6 @@ catch {destroy .e} catch {destroy .partial} option clear +# cleanup +::tcltest::cleanupTests +return diff --git a/tk/tests/macEmbed.test b/tk/tests/macEmbed.test index 6765c37d375..74df7ad2a91 100644 --- a/tk/tests/macEmbed.test +++ b/tk/tests/macEmbed.test @@ -3,18 +3,13 @@ # tests. # # Copyright (c) 1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {$tcl_platform(platform) != "macintosh"} { - return -} - -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } eval destroy [winfo children .] @@ -22,11 +17,11 @@ wm geometry . {} raise . -test macEmbed-1.1 {TkpUseWindow procedure, bad window identifier} { +test macEmbed-1.1 {TkpUseWindow procedure, bad window identifier} {macOnly} { catch {destroy .t} list [catch {toplevel .t -use xyz} msg] $msg } {1 {expected integer but got "xyz"}} -test macEmbed-1.2 {TkpUseWindow procedure, bad window identifier} { +test macEmbed-1.2 {TkpUseWindow procedure, bad window identifier} {macOnly} { catch {destroy .t} list [catch {toplevel .t -use 47} msg] $msg } {1 {The window ID 47 does not correspond to a valid Tk Window.}} @@ -34,10 +29,11 @@ test macEmbed-1.2 {TkpUseWindow procedure, bad window identifier} { if {[string compare testembed [info commands testembed]] != 0} { puts "This application hasn't been compiled with the testembed command," puts "therefore I am skipping all of these tests." + ::tcltest::cleanupTests return } -test macEmbed-1.3 {TkpUseWindow procedure, creating Container records} { +test macEmbed-1.3 {TkpUseWindow procedure, creating Container records} {macOnly} { eval destroy [winfo child .] frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 @@ -46,7 +42,7 @@ test macEmbed-1.3 {TkpUseWindow procedure, creating Container records} { toplevel .t -use $w list [testembed] [expr [lindex [lindex [testembed all] 1] 0] - $w] } {{{XXX .f2 {} {}} {XXX .f1 XXX .t}} 0} -test macEmbed-1.4 {TkpUseWindow procedure, creating Container records} { +test macEmbed-1.4 {TkpUseWindow procedure, creating Container records} {macOnly} { eval destroy [winfo child .] frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 @@ -61,7 +57,7 @@ test macEmbed-1.4 {TkpUseWindow procedure, creating Container records} { # Can't think of any way to test the procedures TkpMakeWindow, # TkpMakeContainer, or EmbedErrorProc. -test macEmbed-2.1 {EmbeddedEventProc procedure} { +test macEmbed-2.1 {EmbeddedEventProc procedure} {macOnly} { foreach w [winfo child .] { catch {destroy $w} } @@ -74,7 +70,7 @@ test macEmbed-2.1 {EmbeddedEventProc procedure} { update testembed } {} -test macEmbed-2.2 {EmbeddedEventProc procedure} { +test macEmbed-2.2 {EmbeddedEventProc procedure} {macOnly} { foreach w [winfo child .] { catch {destroy $w} } @@ -85,7 +81,7 @@ test macEmbed-2.2 {EmbeddedEventProc procedure} { destroy .f1 testembed } {} -test macEmbed-2.3 {EmbeddedEventProc procedure} { +test macEmbed-2.3 {EmbeddedEventProc procedure} {macOnly} { foreach w [winfo child .] { catch {destroy $w} } @@ -98,7 +94,7 @@ test macEmbed-2.3 {EmbeddedEventProc procedure} { list [testembed] [winfo children .] } {{} {}} -test macEmbed-3.1 {EmbeddedEventProc procedure, detect creation} { +test macEmbed-3.1 {EmbeddedEventProc procedure, detect creation} {macOnly} { foreach w [winfo child .] { catch {destroy $w} } @@ -110,7 +106,8 @@ test macEmbed-3.1 {EmbeddedEventProc procedure, detect creation} { wm withdraw .t1 list $x [testembed] } {{{XXX .f1 {} {}}} {{XXX .f1 XXX .t1}}} -test macEmbed-3.2 {EmbeddedEventProc procedure, disallow position changes} { +test macEmbed-3.2 {EmbeddedEventProc procedure, disallow position changes} \ + {macOnly} { foreach w [winfo child .] { catch {destroy $w} } @@ -123,7 +120,8 @@ test macEmbed-3.2 {EmbeddedEventProc procedure, disallow position changes} { update wm geometry .t1 } {200x200+0+0} -test macEmbed-3.3 {EmbeddedEventProc procedure, disallow position changes} { +test macEmbed-3.3 {EmbeddedEventProc procedure, disallow position changes} \ + {macOnly} { foreach w [winfo child .] { catch {destroy $w} } @@ -136,7 +134,7 @@ test macEmbed-3.3 {EmbeddedEventProc procedure, disallow position changes} { update wm geometry .t1 } {300x100+0+0} -test macEmbed-3.4 {EmbeddedEventProc procedure, geometry requests} { +test macEmbed-3.4 {EmbeddedEventProc procedure, geometry requests} {macOnly} { foreach w [winfo child .] { catch {destroy $w} } @@ -148,7 +146,7 @@ test macEmbed-3.4 {EmbeddedEventProc procedure, geometry requests} { update list [winfo width .t1] [winfo height .t1] [wm geometry .t2] } {300 80 300x80+0+0} -test macEmbed-3.5 {EmbeddedEventProc procedure, map requests} { +test macEmbed-3.5 {EmbeddedEventProc procedure, map requests} {macOnly} { foreach w [winfo child .] { catch {destroy $w} } @@ -163,7 +161,7 @@ test macEmbed-3.5 {EmbeddedEventProc procedure, map requests} { update set x } {mapped} -test macEmbed-3.6 {EmbeddedEventProc procedure, destroy events} { +test macEmbed-3.6 {EmbeddedEventProc procedure, destroy events} {macOnly} { foreach w [winfo child .] { catch {destroy $w} } @@ -179,7 +177,7 @@ test macEmbed-3.6 {EmbeddedEventProc procedure, destroy events} { list $x [winfo exists .f1] } {dead 0} -test macEmbed-4.1 {EmbedStructureProc procedure, configure events} { +test macEmbed-4.1 {EmbedStructureProc procedure, configure events} {macOnly} { foreach w [winfo child .] { catch {destroy $w} } @@ -192,7 +190,7 @@ test macEmbed-4.1 {EmbedStructureProc procedure, configure events} { update winfo geometry .t1 } {180x100+0+0} -test macEmbed-4.2 {EmbedStructureProc procedure, destroy events} { +test macEmbed-4.2 {EmbedStructureProc procedure, destroy events} {macOnly} { foreach w [winfo child .] { catch {destroy $w} } @@ -208,7 +206,7 @@ test macEmbed-4.2 {EmbedStructureProc procedure, destroy events} { # Can't think up any tests for TkpGetOtherWindow procedure. -test unixEmbed-5.1 {TkpClaimFocus procedure} {tempNotMac} { +test unixEmbed-5.1 {TkpClaimFocus procedure} {macOnly tempNotMac} { catch {interp delete child} foreach w [winfo child .] { catch {destroy $w} @@ -233,7 +231,7 @@ test unixEmbed-5.1 {TkpClaimFocus procedure} {tempNotMac} { } {{{} .} .f1} catch {interp delete child} -test macEmbed-6.1 {EmbedWindowDeleted procedure, check parentPtr} { +test macEmbed-6.1 {EmbedWindowDeleted procedure, check parentPtr} {macOnly} { foreach w [winfo child .] { catch {destroy $w} } @@ -250,7 +248,7 @@ test macEmbed-6.1 {EmbedWindowDeleted procedure, check parentPtr} { } set x } {{{XXX .f4 {} {}} {XXX .f3 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f4 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}}} {}} -test macEmbed-6.2 {EmbedWindowDeleted procedure, check embeddedPtr} { +test macEmbed-6.2 {EmbedWindowDeleted procedure, check embeddedPtr} {macOnly} { foreach w [winfo child .] { catch {destroy $w} } @@ -265,7 +263,7 @@ test macEmbed-6.2 {EmbedWindowDeleted procedure, check embeddedPtr} { lappend x [testembed] } {{{XXX .f1 XXX .t1}} {}} -test macEmbed-7.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} { +test macEmbed-7.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {macOnly} { foreach w [winfo child .] { catch {destroy $w} } @@ -277,7 +275,7 @@ test macEmbed-7.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} { update wm geometry .t1 } {150x80+0+0} -test macEmbed-7.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} { +test macEmbed-7.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {macOnly} { foreach w [winfo child .] { catch {destroy $w} } @@ -295,3 +293,20 @@ test macEmbed-7.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} { foreach w [winfo child .] { catch {destroy $w} } + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/macFont.test b/tk/tests/macFont.test index e0636aa4023..5bbe38b115c 100644 --- a/tk/tests/macFont.test +++ b/tk/tests/macFont.test @@ -7,28 +7,30 @@ # but there are no results that can be checked. # # Copyright (c) 1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {$tcl_platform(platform)!="macintosh"} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } -if {[string compare test [info procs test]] != 0} { - source defs +if {$tcl_platform(platform)!="macintosh"} { + puts "skipping: Mac only tests..." + ::tcltest::cleanupTests + return } catch {destroy .b} toplevel .b update idletasks -set courier {Courier 10} +set courier {Courier 12} set cx [font measure $courier 0] -label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font "Monaco 9" +set fixed {Monaco 12} +label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font $fixed pack .b.l canvas .b.c -closeenough 0 @@ -43,125 +45,226 @@ proc getsize {} { return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" } -test macfont-1.1 {TkpGetNativeFont procedure: not native} { +set ::tcltest::testConfig(gothic) 0 +set gothic {gothic 12} +set mx [font measure $gothic \u4e4e] +if {[font actual $gothic -family] != [font actual system -family]} { + set ::tcltest::testConfig(gothic) 1 +} + +test macFont-1.1 {TkpFontPkgInit} { +} {} + +test macfont-2.1 {TkpGetNativeFont: not native} { list [catch {font measure {} xyz} msg] $msg } {1 {font "" doesn't exist}} -test macfont-1.2 {TkpGetNativeFont procedure: native} { +test macFont-2.2 {TkpGetNativeFont: native} { font measure system "0" font measure application "0" set x {} } {} -test macfont-2.1 {TkpGetFontFromAttributes procedure: no family} { +test macFont-3.1 {TkpGetFontFromAttributes: no family} { font actual {-underline 1} -family } [font actual system -family] -test macfont-2.2 {TkpGetFontFromAttributes procedure: long family name} { +test macFont-3.2 {TkpGetFontFromAttributes: long family name} { set x "12345678901234567890123456789012345678901234567890" set x "$x$x$x$x$x$x" font actual "-family $x" -family } [font actual system -family] -test macfont-2.3 {TkpGetFontFromAttributes procedure: family} { +test macFont-3.3 {TkpGetFontFromAttributes: family} { font actual {-family Courier} -family } {Courier} -test macfont-2.4 {TkpGetFontFromAttributes procedure: Times fonts} { +test macFont-3.4 {TkpGetFontFromAttributes: Times fonts} { set x {} lappend x [font actual {-family "Times"} -family] lappend x [font actual {-family "Times New Roman"} -family] } {Times Times} -test macfont-2.5 {TkpGetFontFromAttributes procedure: Courier fonts} { +test macFont-3.5 {TkpGetFontFromAttributes: Courier fonts} { set x {} lappend x [font actual {-family "Courier"} -family] lappend x [font actual {-family "Courier New"} -family] } {Courier Courier} -test macfont-2.6 {TkpGetFontFromAttributes procedure: Helvetica fonts} { +test macFont-3.6 {TkpGetFontFromAttributes: Helvetica fonts} { set x {} lappend x [font actual {-family "Geneva"} -family] lappend x [font actual {-family "Helvetica"} -family] lappend x [font actual {-family "Arial"} -family] } {Geneva Helvetica Helvetica} -test macfont-2.7 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.7 {TkpGetFontFromAttributes: try aliases} { + font actual {arial 10} -family +} {Helvetica} +test macFont-3.8 {TkpGetFontFromAttributes: try fallbacks} { + font actual {{ms sans serif} 10} -family +} {Chicago} +test macFont-3.9 {TkpGetFontFromAttributes: styles} { font actual {-weight normal} -weight } {normal} -test macfont-2.8 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.10 {TkpGetFontFromAttributes: styles} { font actual {-weight bold} -weight } {bold} -test macfont-2.9 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.11 {TkpGetFontFromAttributes: styles} { font actual {-slant roman} -slant } {roman} -test macfont-2.10 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.12 {TkpGetFontFromAttributes: styles} { font actual {-slant italic} -slant } {italic} -test macfont-2.11 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.13 {TkpGetFontFromAttributes: styles} { font actual {-underline false} -underline } {0} -test macfont-2.12 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.14 {TkpGetFontFromAttributes: styles} { font actual {-underline true} -underline } {1} -test macfont-2.13 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.15 {TkpGetFontFromAttributes: styles} { font actual {-overstrike false} -overstrike } {0} -test macfont-2.14 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.16 {TkpGetFontFromAttributes: styles} { font actual {-overstrike true} -overstrike } {0} -test macfont-3.1 {TkpDeleteFont procedure} { +test macFont-4.1 {TkpDeleteFont} { font actual {-family xyz} set x {} } {} -test macfont-4.1 {TkpGetFontFamilies procedure} { - font families - set x {} -} {} +test macFont-5.1 {TkpGetFontFamilies} { + expr {[lsearch [font families] Geneva] > 0} +} {1} + +test macFont-6.1 {TkpGetSubFonts} {gothic} { + .b.l config -text "abc\u4e4e" + update + set x [testfont subfonts $fixed] +} "Monaco [font actual $gothic -family]" -test macfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} { +test macFont-7.1 {Tk_MeasureChars: unbounded right margin} { .b.l config -wrap 0 -text "000000" getsize } "[expr $ax*6] $ay" -test macfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} { +test macFont-7.2 {Tk_MeasureChars: static width buffer exceeded} { .b.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" getsize } "[expr $ax*256] $ay" -test macfont-5.3 {Tk_MeasureChars procedure: all chars did fit} { +test macFont-7.3 {Tk_MeasureChars: all chars did fit} { .b.l config -wrap [expr $ax*10] -text "00000000" getsize } "[expr $ax*8] $ay" -test macfont-5.4 {Tk_MeasureChars procedure: not all chars fit} { +test macFont-7.4 {Tk_MeasureChars: not all chars fit} { .b.l config -wrap [expr $ax*6] -text "00000000" getsize } "[expr $ax*6] [expr $ay*2]" -test macfont-5.5 {Tk_MeasureChars procedure: already saw space in line} { +test macFont-7.5 {Tk_MeasureChars: already saw space in line} { .b.l config -wrap [expr $ax*12] -text "000000 0000000" getsize } "[expr $ax*7] [expr $ay*2]" -test macfont-5.6 {Tk_MeasureChars procedure: internal spaces significant} { +test macFont-7.6 {Tk_MeasureChars: internal spaces significant} { .b.l config -wrap [expr $ax*12] -text "000 00 00000" getsize } "[expr $ax*7] [expr $ay*2]" -test macfont-5.7 {Tk_MeasureChars procedure: include last partial char} { +test macFont-7.7 {Tk_MeasureChars: include last partial char} { .b.c dchars $t 0 end .b.c insert $t 0 "0000" .b.c index $t @[expr int($ax*2.5)],1 } {2} -test macfont-5.8 {Tk_MeasureChars procedure: at least one char on line} { +test macFont-7.8 {Tk_MeasureChars: at least one char on line} { .b.l config -text "000000" -wrap 1 getsize } "$ax [expr $ay*6]" -test macfont-5.9 {Tk_MeasureChars procedure: whole words} { +test macFont-7.9 {Tk_MeasureChars: whole words} { .b.l config -wrap [expr $ax*8] -text "000000 0000" getsize } "[expr $ax*6] [expr $ay*2]" -test macfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} { +test macFont-7.10 {Tk_MeasureChars: make first part of word fit} { .b.l config -wrap [expr $ax*12] -text "0000000000000000" getsize } "[expr $ax*12] [expr $ay*2]" +test macFont-7.11 {Tk_MeasureChars: numBytes == 0} { + font measure system {} +} {0} +test macFont-7.12 {Tk_MeasureChars: maxLength < 0} { + font measure $courier abcd +} "[expr $cx*4]" +test macFont-7.13 {Tk_MeasureChars: loop on each char} { + font measure $courier abcd +} "[expr $cx*4]" +test macFont-7.14 {Tk_MeasureChars: p == end} { + font measure $courier abcd +} "[expr $cx*4]" +test macFont-7.15 {Tk_MeasureChars: p > end} { + font measure $courier abc\xc2 +} "[expr $cx*4]" +test macFont-7.16 {Tk_MeasureChars: thisFamilyPtr != lastFamilyPtr} {gothic} { + font measure $courier abc\u4e4edef +} [expr $cx*6+$mx] +test macFont-7.17 {Tk_MeasureChars: measure no chars (in loop)} {gothic} { + font measure $courier \u4e4edef +} [expr $mx+$cx*3] +test macFont-7.18 {Tk_MeasureChars: final measure} {gothic} { + font measure $courier \u4e4edef +} [expr $mx+$cx*3] +test macFont-7.19 {Tk_MeasureChars: final measure (no chars)} {gothic} { + font measure $courier \u4e4e +} [expr $mx] +test macFont-7.20 {Tk_MeasureChars: maxLength >= 0} { + .b.l config -wrap [expr $ax*8] -text "000" + getsize +} "[expr $ax*3] $ay" +test macFont-7.21 {Tk_MeasureChars: loop on each char} { + .b.l config -wrap [expr $ax*8] -text "000" + getsize +} "[expr $ax*3] $ay" +test macFont-7.22 {Tk_MeasureChars: p == end} { + .b.l config -wrap [expr $ax*8] -text "000" + getsize +} "[expr $ax*3] $ay" +test macFont-7.23 {Tk_MeasureChars: p > end} { + .b.l config -wrap [expr $ax*8] -text "00\xc2" + getsize +} "[expr $ax*3] $ay" +test macFont-7.24 {Tk_MeasureChars: thisFamilyPtr != lastFamilyPtr} {gothic} { + .b.l config -wrap [expr $ax*8] -text "00\u4e4e00" + getsize +} "[expr $ax*4+$mx] $ay" +test macFont-7.25 {Tk_MeasureChars: measure no chars (in loop)} {gothic} { + .b.l config -wrap [expr $ax*8] -text "\u4e4e00" + getsize +} "[expr $mx+$ax*2] $ay" +test macFont-7.26 {Tk_MeasureChars: rest == NULL} {gothic} { + .b.l config -wrap [expr $ax*20] -text "000000\u4e4e\u4e4e00" + getsize +} "[expr $ax*8+$mx*2] $ay" +test macFont-7.27 {Tk_MeasureChars: rest != NULL in first segment} {gothic} { + .b.l config -wrap [expr $ax*5] -text "000000\u4e4e\u4e4f00" + getsize +} "[expr $ax*5] [expr $ay*3]" +test macFont-7.28 {Tk_MeasureChars: rest != NULL in next segment} {gothic} { + # even some of the "0"s would fit after \u4e4d, they should all wrap to next line. + .b.l config -wrap [expr $ax*8] -text "\u4e4d\u4e4d000000\u4e4e\u4e4f00" + getsize +} "[expr $ax*6+$mx] [expr $ay*3]" +test macFont-7.29 {Tk_MeasureChars: final measure} {gothic} { + .b.l config -wrap [expr $ax*8] -text "\u4e4e00" + getsize +} "[expr $mx+$ax*2] $ay" +test macFont-7.30 {Tk_MeasureChars: final measure (no chars)} {gothic} { + .b.l config -wrap [expr $ax*8] -text "\u4e4e" + getsize +} "$mx $ay" +test macFont-7.31 {Tk_MeasureChars: rest == NULL} { + .b.l config -wrap [expr $ax*1000] -text 0000 + getsize +} "[expr $ax*4] $ay" +test macFont-7.32 {Tk_MeasureChars: rest != NULL} { + .b.l config -wrap [expr $ax*6] -text "00000000" + getsize +} "[expr $ax*6] [expr $ay*2]" -test macfont-6.1 {Tk_DrawChars procedure} { +test macFont-8.1 {Tk_DrawChars procedure} { .b.l config -text "a" update } {} -test macfont-7.1 {AllocMacFont procedure: use old font} { +test macFont-9.1 {AllocMacFont: use old font} { font create xyz button .c -font xyz font configure xyz -family times @@ -169,14 +272,31 @@ test macfont-7.1 {AllocMacFont procedure: use old font} { destroy .c font delete xyz } {} -test macfont-7.2 {AllocMacFont procedure: extract info from style} { +test macFont-9.2 {AllocMacFont: extract info from style} { font actual {Monaco 9 bold italic underline overstrike} } {-family Monaco -size 9 -weight bold -slant italic -underline 1 -overstrike 0} -test macfont-7.3 {AllocMacFont procedure: extract text metrics} { +test macFont-9.3 {AllocMacFont: extract text metrics} { font metric {Geneva 10} -fixed } {0} -test macfont-7.4 {AllocMacFont procedure: extract text metrics} { +test macFont-9.4 {AllocMacFont: extract text metrics} { font metric "Monaco 9" -fixed } {1} destroy .b + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/macMenu.test b/tk/tests/macMenu.test index 0cd39899dca..0cbed04c75d 100644 --- a/tk/tests/macMenu.test +++ b/tk/tests/macMenu.test @@ -4,13 +4,18 @@ # system. # # Copyright (c) 1995-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + if {$tcl_platform(platform) != "macintosh"} { + puts "skipping: Mac only tests..." + ::tcltest::cleanupTests return } @@ -18,13 +23,10 @@ if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[info procs test] != "test"} { - source defs -} - proc deleteWindows {} { foreach i [winfo children .] { catch [destroy $i] @@ -1561,5 +1563,20 @@ test macMenu-44.2 {DrawMenuEntryBackground} { test macMenu-45.1 {TkpMenuInit - called at boot time} {} {} +# cleanup deleteWindows +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tk/tests/macWinMenu.test b/tk/tests/macWinMenu.test index 013138f4f6f..8e59d00ce57 100644 --- a/tk/tests/macWinMenu.test +++ b/tk/tests/macWinMenu.test @@ -3,26 +3,27 @@ # the common implementation of Macintosh and Windows menus. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {$tcl_platform(platform) == "unix"} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[info procs test] != "test"} { - source defs -} +# Some tests require user interaction on non-unix platform +set ::tcltest::testConfig(nonUnixUserInteraction) \ + [expr {$::tcltest::testConfig(userInteraction) || \ + $::tcltest::testConfig(unixOnly)}] proc deleteWindows {} { foreach i [winfo children .] { @@ -34,33 +35,26 @@ deleteWindows wm geometry . {} raise . -if {$tcl_platform(platform) == "windows" && ![info exists INTERACTIVE]} { - puts " Some tests were skipped because they could not be performed" - puts " automatically on this platform. If you wish to execute them" - puts " interactively, set the TCL variable INTERACTIVE and re-run" - puts " the test." -} - -test macWinMenu-1.1 {PreprocessMenu} { +test macWinMenu-1.1 {PreprocessMenu} {macOrPc nonUnixUserInteraction} { catch {destroy .m1} menu .m1 -postcommand "destroy .m1" .m1 add command -label "macWinMenu-1.1: Hit Escape" list [catch {.m1 post 40 40} msg] $msg } {0 {}} -if {$tcl_platform(platform) != "windows" || [info exists INTERACTIVE]} { - test macWinMenu-1.2 {PreprocessMenu} { - catch {destroy .m1} - catch {destroy .m2} - set foo1 foo - set foo2 foo - menu .m1 -postcommand "set foo1 .m1" - .m1 add cascade -menu .m2 -label "macWinMenu-1.2: Hit Escape" - menu .m2 -postcommand "set foo2 .m2" - update idletasks - list [catch {.m1 post 40 40} msg] $msg [set foo1] [set foo2] [destroy .m1 .m2] [catch {unset foo1}] [catch {unset foo2}] - } {0 .m2 .m1 .m2 {} 0 0} -} -test macWinMenu-1.3 {PreprocessMenu} { +test macWinMenu-1.2 {PreprocessMenu} {macOrPc nonUnixUserInteraction} { + catch {destroy .m1} + catch {destroy .m2} + set foo1 foo + set foo2 foo + menu .m1 -postcommand "set foo1 .m1" + .m1 add cascade -menu .m2 -label "macWinMenu-1.2: Hit Escape" + menu .m2 -postcommand "set foo2 .m2" + update idletasks + list [catch {.m1 post 40 40} msg] $msg [set foo1] [set foo2] \ + [destroy .m1 .m2] [catch {unset foo1}] [catch {unset foo2}] +} {0 .m2 .m1 .m2 {} 0 0} + +test macWinMenu-1.3 {PreprocessMenu} {macOrPc nonUnixUserInteraction} { catch {destroy .l1} catch {destroy .m1} catch {destroy .m2} @@ -76,7 +70,7 @@ test macWinMenu-1.3 {PreprocessMenu} { update idletasks list [catch {.m1 post 40 40} msg] $msg [destroy .l1 .m2 .m3] } {0 {} {}} -test macWinMenu-1.4 {PreprocessMenu} { +test macWinMenu-1.4 {PreprocessMenu} {macOrPc} { catch {destroy .l1} catch {destroy .m1} catch {destroy .m2} @@ -95,7 +89,7 @@ test macWinMenu-1.4 {PreprocessMenu} { update idletasks list [catch {.m1 post 40 40} msg] $msg [destroy .l1 .m2 .m3 .m4] } {0 {} {}} -test macWinMenu-1.5 {PreprocessMenu} { +test macWinMenu-1.5 {PreprocessMenu} {macOrPc} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -104,14 +98,28 @@ test macWinMenu-1.5 {PreprocessMenu} { list [catch {.m1 post 40 40} msg] $msg [destroy .m1 .m2] } {1 {invalid command name "glorp"} {}} -if {$tcl_platform(platform) != "windows" || [info exists INTERACTIVE]} { - test macWinMenu-2.1 {TkPreprocessMenu} { - catch {destroy .m1} - set foo test - menu .m1 -postcommand "set foo 2.1" - .m1 add command -label "macWinMenu-2.1: Hit Escape" - list [catch {.m1 post 40 40} msg] $msg [set foo] [destroy .m1] [unset foo] - } {0 2.1 2.1 {} {}} -} +test macWinMenu-2.1 {TkPreprocessMenu} {macOrPc nonUnixUserInteraction} { + catch {destroy .m1} + set foo test + menu .m1 -postcommand "set foo 2.1" + .m1 add command -label "macWinMenu-2.1: Hit Escape" + list [catch {.m1 post 40 40} msg] $msg [set foo] [destroy .m1] [unset foo] +} {0 2.1 2.1 {} {}} +# cleanup deleteWindows +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/macscrollbar.test b/tk/tests/macscrollbar.test index 24f49362d9f..4ebfd79f2af 100644 --- a/tk/tests/macscrollbar.test +++ b/tk/tests/macscrollbar.test @@ -4,17 +4,20 @@ # Tcl tests. # # Copyright (c) 1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -# Only run this test on the Macintosh -if {$tcl_platform(platform) != "macintosh"} return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} -if {[info procs test] != "test"} { - source defs +# Only run this test on the Macintosh +if {$tcl_platform(platform) != "macintosh"} { + puts "skipping: Mac only tests..." + ::tcltest::cleanupTests + return } foreach i [winfo children .] { @@ -98,4 +101,20 @@ test macscroll-1.7 {TkpDisplayScrollbar procedure} { foreach i [winfo children .] { destroy $i } -concat {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/main.test b/tk/tests/main.test index 21bd20956ee..56b6690e328 100644 --- a/tk/tests/main.test +++ b/tk/tests/main.test @@ -5,14 +5,13 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } test main-1.1 {StdinProc} {unixOnly} { @@ -22,10 +21,29 @@ test main-1.1 {StdinProc} {unixOnly} { close stdin; exit } close $fd - if {[catch {exec $tktest <script} msg]} { + if {[catch {exec $::tcltest::tktest <script} msg]} { set error 1 } else { set error 0 } + file delete -force script list $error $msg } {0 {}} + +# cleanup +catch {removeFile script} +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/menu.test b/tk/tests/menu.test index cc07d9269e2..a0163f73f67 100644 --- a/tk/tests/menu.test +++ b/tk/tests/menu.test @@ -2,32 +2,27 @@ # organized in the standard fashion for Tcl tests. # # Copyright (c) 1995-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[info procs test] != "test"} { - source defs -} - -if {$tcl_platform(platform) == "windows" && ![info exists INTERACTIVE]} { - puts " Some tests were skipped because they could not be performed" - puts " automatically on this platform. If you wish to execute them" - puts " interactively, set the TCL variable INTERACTIVE and re-run" - puts " the test." - set testConfig(menuInteractive) 0 -} else { - set testConfig(menuInteractive) 1 -} +# Some tests require user interaction on non-unix platform +set ::tcltest::testConfig(nonUnixUserInteraction) \ + [expr {$::tcltest::testConfig(userInteraction) || \ + $::tcltest::testConfig(unixOnly)}] proc deleteWindows {} { foreach i [winfo children .] { @@ -164,16 +159,16 @@ test menu-1.14 {Tk_MenuCmd procedure} { catch {destroy .m1} menu .m1 set i 1 -foreach test { +foreach configTest { {-activebackground #012345 #012345 non-existent {unknown color name "non-existent"}} - {-activeborderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-activeborderwidth 1.3 1.3 badValue {bad screen distance "badValue"}} {-activeforeground #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} {-background #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} {-bg #110022 #110022 bogus {unknown color name "bogus"}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-borderwidth 1.3 1.3 badValue {bad screen distance "badValue"}} {-cursor arrow arrow badValue {bad cursor spec "badValue"}} {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}} {-fg #110022 #110022 bogus {unknown color name "bogus"}} @@ -182,23 +177,27 @@ foreach test { {font "" doesn't exist}} {-foreground #110022 #110022 bogus {unknown color name "bogus"}} {-postcommand "any old string" "any old string" {} {}} - {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} + {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} {-selectcolor #110022 #110022 bogus {unknown color name "bogus"}} {-takefocus "any string" "any string" {} {}} {-tearoff 0 0} {-tearoff 1 1} {-tearoffcommand "any old string" "any old string" {} {}} } { - set name [lindex $test 0] - test menu-2.$i {configuration options} { - .m1 configure $name [lindex $test 1] + set name [lindex $configTest 0] + set value [lindex $configTest 1] + set result [lindex $configTest 2] + test menu-2.$i [list configuration options $name $value $result] { + .m1 configure $name $value lindex [.m1 configure $name] 4 - } [lindex $test 2] + } $result incr i - if {[lindex $test 3] != ""} { - test menu-2.$i {configuration options} { - list [catch {.m1 configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] + if {[lindex $configTest 3] != ""} { + set value [lindex $configTest 3] + set result [lindex $configTest 4] + test menu-2.$i [list configuration options $name $value $result] { + list [catch {.m1 configure $name $value} msg] $msg + } [list 1 $result] } .m1 configure $name [lindex [.m1 configure $name] 3] incr i @@ -221,7 +220,7 @@ menu .m2 .m1 add radiobutton -label "radiobutton" -variable radio image create photo image1 -file [file join $tk_library demos images earth.gif] -foreach test { +foreach configTest { {-activebackground {{#012345 {{unknown option "-activebackground"} #012345 #012345 @@ -240,7 +239,7 @@ foreach test { } {-activeforeground {{#ff0000 - {{unknown option "-activeforeground"} + {{unknown option "-activeforeground"} #ff0000 #ff0000 {unknown option "-activeforeground"} #ff0000 #ff0000 } } @@ -256,7 +255,7 @@ foreach test { } {-accelerator {{"Ctrl+S" - {{unknown option "-accelerator"} + {{unknown option "-accelerator"} "Ctrl+S" "Ctrl+S" {unknown option "-accelerator"} "Ctrl+S" "Ctrl+S" } @@ -279,8 +278,8 @@ foreach test { } {-bitmap {{questhead - {{unknown option "-bitmap"} questhead questhead - {unknown option "-bitmap"} questhead questhead + {{unknown option "-bitmap"} questhead questhead + {unknown option "-bitmap"} questhead questhead } } {badValue @@ -295,22 +294,23 @@ foreach test { } {-columnbreak {{1 - {{unknown option "-columnbreak"} 1 1 {unknown option "-columnbreak"} 1 1} + {{unknown option "-columnbreak"} 1 1 + {unknown option "-columnbreak"} 1 1} }} } {-command {{beep - {{unknown option "-command"} beep beep - {unknown option "-command"} beep beep + {{unknown option "-command"} beep beep + {unknown option "-command"} beep beep } }} } {-font {{-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* - {{unknown option "-font"} + {{unknown option "-font"} -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* - {unknown option "-font"} + {unknown option "-font"} -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* } @@ -327,8 +327,8 @@ foreach test { } {-foreground {{#110022 - {{unknown option "-foreground"} #110022 #110022 - {unknown option "-foreground"} #110022 #110022 + {{unknown option "-foreground"} #110022 #110022 + {unknown option "-foreground"} #110022 #110022 } } {non-existent @@ -343,8 +343,8 @@ foreach test { } {-image {{image1 - {{unknown option "-image"} image1 image1 - {unknown option "-image"} image1 image1 + {{unknown option "-image"} image1 image1 + {unknown option "-image"} image1 image1 } } {bogus @@ -368,58 +368,58 @@ foreach test { } {-indicatoron {{1 - {{unknown option "-indicatoron"} - {unknown option "-indicatoron"} - {unknown option "-indicatoron"} - {unknown option "-indicatoron"} 1 1 + {{unknown option "-indicatoron"} + {unknown option "-indicatoron"} + {unknown option "-indicatoron"} + {unknown option "-indicatoron"} 1 1 } }} } {-label {{test - {{unknown option "-label"} test test - {unknown option "-label"} test test + {{unknown option "-label"} test test + {unknown option "-label"} test test } }} } {-menu {{.m2 - {{unknown option "-menu"} - {unknown option "-menu"} .m2 - {unknown option "-menu"} - {unknown option "-menu"} - {unknown option "-menu"} + {{unknown option "-menu"} + {unknown option "-menu"} .m2 + {unknown option "-menu"} + {unknown option "-menu"} + {unknown option "-menu"} } }} } {-offvalue {{off - {{unknown option "-offvalue"} - {unknown option "-offvalue"} + {{unknown option "-offvalue"} + {unknown option "-offvalue"} + {unknown option "-offvalue"} {unknown option "-offvalue"} - {unknown option "-offvalue"} off - {unknown option "-offvalue"} + {unknown option "-offvalue"} } }} } {-onvalue {{on - {{unknown option "-onvalue"} - {unknown option "-onvalue"} - {unknown option "-onvalue"} - {unknown option "-onvalue"} + {{unknown option "-onvalue"} + {unknown option "-onvalue"} + {unknown option "-onvalue"} + {unknown option "-onvalue"} on - {unknown option "-onvalue"} + {unknown option "-onvalue"} } }} } {-selectcolor {{#110022 - {{unknown option "-selectcolor"} - {unknown option "-selectcolor"} - {unknown option "-selectcolor"} - {unknown option "-selectcolor"} + {{unknown option "-selectcolor"} + {unknown option "-selectcolor"} + {unknown option "-selectcolor"} + {unknown option "-selectcolor"} #110022 #110022 } @@ -463,8 +463,7 @@ foreach test { } {-state {{normal - {normal normal normal - {unknown option "-state"} normal normal + {normal normal normal {unknown option "-state"} normal normal } }} } @@ -506,13 +505,13 @@ foreach test { }} } } { - set name [lindex $test 0] - foreach attempt [lindex $test 1] { + set name [lindex $configTest 0] + foreach attempt [lindex $configTest 1] { set value [lindex $attempt 0] set options [lindex $attempt 1] foreach item {0 1 2 3 4 5} { catch {unset msg} - test menu-2.$i [list entry configuration options $name $item $value] { + test menu-2.$i [list entry configuration options $name $item $value [.m1 type $item]] { set result [catch {.m1 entryconfigure $item $name $value} msg] if {$result == 1} { set msg @@ -534,7 +533,7 @@ test menu-3.1 {MenuWidgetCmd procedure} { menu .m1 list [catch {.m1} msg] $msg [destroy .m1] } {1 {wrong # args: should be ".m1 option ?arg arg ...?"} {}} -test menu-3.2 {MenuWidgetCmd, Tcl_Preserve and Tcl_Release} {menuInteractive} { +test menu-3.2 {MenuWidgetCmd, Tcl_Preserve and Tcl_Release} {nonUnixUserInteraction } { catch {destroy .m1} menu .m1 -postcommand "destroy .m1" .m1 add command -label "menu-3.2: Hit Escape" @@ -551,21 +550,21 @@ test menu-3.4 {MenuWidgetCmd procedure, "activate" option} { menu .m1 list [catch {.m1 activate "foo"} msg] $msg [destroy .m1] } {1 {bad menu entry index "foo"} {}} -test menu-3.5 {MenuWidgetCmd procedure, "activate" option} { +test menu-3.5 {MenuWidgetCmd procedure, "activate" option} { catch {destroy .m1} menu .m1 .m1 add command -label "test" .m1 add separator list [catch {.m1 activate 2} msg] $msg [destroy .m1] } {0 {} {}} -test menu-3.6 {MenuWidgetCmd procedure, "activate" option} { +test menu-3.6 {MenuWidgetCmd procedure, "activate" option} { catch {destroy .m1} menu .m1 .m1 add command -label "test" .m1 entryconfigure 1 -state disabled list [catch {.m1 activate 1} msg] $msg [destroy .m1] } {0 {} {}} -test menu-3.7 {MenuWidgetCmd procedure, "activate" option} { +test menu-3.7 {MenuWidgetCmd procedure, "activate" option} { catch {destroy .m1} menu .m1 .m1 add command -label "test" @@ -805,7 +804,7 @@ test menu-3.49 {MenuWidgetCmd procedure, "post" option} { menu .m1 list [catch {.m1 post 40 bar} msg] $msg [destroy .m1] } {1 {expected integer but got "bar"} {}} -test menu-3.50 {MenuWidgetCmd procedure, "post" option} {menuInteractive} { +test menu-3.50 {MenuWidgetCmd procedure, "post" option} {nonUnixUserInteraction } { catch {destroy .m1} menu .m1 .m1 add command -label "menu-3.53: hit Escape" -command "puts hello" @@ -821,7 +820,7 @@ test menu-3.52 {MenuWidgetCmd procedure, "postcascade" option} { menu .m1 list [catch {.m1 postcascade foo} msg] $msg [destroy .m1] } {1 {bad menu entry index "foo"} {}} -test menu-3.53 {MenuWidgetCmd procedure, "postcascade" option} {menuInteractive} { +test menu-3.53 {MenuWidgetCmd procedure, "postcascade" option} {nonUnixUserInteraction } { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -890,7 +889,7 @@ test menu-3.63 {MenuWidgetCmd procedure, "unpost" option} { menu .m1 list [catch {.m1 unpost foo} msg] $msg [destroy .m1] } {1 {wrong # args: should be ".m1 unpost"} {}} -test menu-3.64 {MenuWidgetCmd procedure, "unpost" option} {menuInteractive} { +test menu-3.64 {MenuWidgetCmd procedure, "unpost" option} {nonUnixUserInteraction } { catch {destroy .m1} menu .m1 .m1 add command -label "menu-3.68 - hit Escape" @@ -913,19 +912,27 @@ test menu-3.67 {MenuWidgetCmd procedure, bad option} { list [catch {.m1 foo} msg] $msg [destroy .m1] } {1 {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, or yposition} {}} -test menu-4.1 {TkInvokeMenu} { +test menu-4.1 {TkInvokeMenu: disabled} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + .m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off \ + -state disabled + list [catch {.m1 invoke 1} msg] [destroy .m1] $foo +} {0 {} off} +test menu-4.2 {TkInvokeMenu: tearoff} { catch {destroy .m1} menu .m1 list [catch {.m1 invoke 0} msg] [destroy .m1] } {0 {}} -test menu-4.2 {TkInvokeMenu} { +test menu-4.3 {TkInvokeMenu: checkbutton -on} { catch {destroy .m1} catch {unset foo} menu .m1 .m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] } {0 {} 0 on 0 {} {}} -test menu-4.3 {TkInvokeMenu} { +test menu-4.4 {TkInvokeMenu: checkbutton -off} { catch {destroy .m1} catch {unset foo} menu .m1 @@ -933,7 +940,14 @@ test menu-4.3 {TkInvokeMenu} { .m1 invoke 1 list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] } {0 {} 0 off 0 {} {}} -test menu-4.4 {TkInvokeMenu} { +test menu-4.5 {TkInvokeMenu: checkbutton array element} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + .m1 add checkbutton -label "test" -variable foo(1) -onvalue on + list [catch {.m1 invoke 1} msg] $msg [catch {set foo(1)} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] +} {0 {} 0 on 0 {} {}} +test menu-4.6 {TkInvokeMenu: radiobutton} { catch {destroy .m1} catch {unset foo} menu .m1 @@ -942,7 +956,7 @@ test menu-4.4 {TkInvokeMenu} { .m1 add radiobutton -label "3" -variable foo -value three list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] } {0 {} 0 one 0 {} {}} -test menu-4.5 {TkInvokeMenu} { +test menu-4.7 {TkInvokeMenu: radiobutton} { catch {destroy .m1} catch {unset foo} menu .m1 @@ -951,7 +965,7 @@ test menu-4.5 {TkInvokeMenu} { .m1 add radiobutton -label "3" -variable foo -value three list [catch {.m1 invoke 2} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] } {0 {} 0 two 0 {} {}} -test menu-4.6 {TkInvokeMenu} { +test menu-4.8 {TkInvokeMenu: radiobutton} { catch {destroy .m1} catch {unset foo} menu .m1 @@ -960,20 +974,29 @@ test menu-4.6 {TkInvokeMenu} { .m1 add radiobutton -label "3" -variable foo -value three list [catch {.m1 invoke 3} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] } {0 {} 0 three 0 {} {}} -test menu-4.7 {TkInvokeMenu} { +test menu-4.9 {TkInvokeMenu: radiobutton array element} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + .m1 add radiobutton -label "1" -variable foo(2) -value one + .m1 add radiobutton -label "2" -variable foo(2) -value two + .m1 add radiobutton -label "3" -variable foo(2) -value three + list [catch {.m1 invoke 3} msg] $msg [catch {set foo(2)} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] +} {0 {} 0 three 0 {} {}} +test menu-4.10 {TkInvokeMenu} { catch {destroy .m1} catch {unset menu_test} menu .m1 .m1 add command -label "test" -command "set menu_test menu-4.8" list [catch {.m1 invoke 1} msg] $msg [catch {set menu_test} msg2] $msg2 [catch {unset menu_test} msg3] $msg3 [destroy .m1] } {0 menu-4.8 0 menu-4.8 0 {} {}} -test menu-4.8 {TkInvokeMenu} { +test menu-4.11 {TkInvokeMenu} { catch {destroy .m1} menu .m1 .m1 add cascade -label "test" -menu .m1.m2 list [catch {.m1 invoke 1} msg] $msg [destroy .m1] } {0 {} {}} -test menu-4.9 {TkInvokeMenu} { +test menu-4.12 {TkInvokeMenu} { catch {destroy .m1} menu .m1 .m1 add command -label "test" -command ".m1 delete 1" @@ -1431,44 +1454,60 @@ test menu-9.9 {ConfigureMenu} { list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test menu-10.1 {ConfigureMenuEntry} { +test menu-10.1 {PostProcessEntry: array variable} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + set foo(1) on + .m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense" + list [catch {set foo(1)} msg] $msg [destroy .m1] +} {0 on {}} +test menu-10.2 {PostProcessEntry: array variable} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + .m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense" + list [catch {set foo(1)} msg] $msg [destroy .m1] +} {0 off {}} + +test menu-11.1 {ConfigureMenuEntry} { catch {destroy .m1} catch {unset foo} menu .m1 .m1 add checkbutton -variable foo -onvalue on -offvalue off -label "Nonsense" list [catch {.m1 entryconfigure 1 -variable bar} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1] } {0 {} bar {}} -test menu-10.2 {ConfigureMenuEntry} { +test menu-11.2 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [catch {.m1 entryconfigure 1 -label ""} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] } {0 {} {} {}} -test menu-10.3 {ConfigureMenuEntry} { +test menu-11.3 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command list [catch {.m1 entryconfigure 1 -label "test"} cmd] $cmd [.m1 entrycget 1 -label] [destroy .m1] } {0 {} test {}} -test menu-10.4 {ConfigureMenuEntry} { +test menu-11.4 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command list [catch {.m1 entryconfigure 1 -accel "S"} msg] $msg [.m1 entrycget 1 -accel] [destroy .m1] } {0 {} S {}} -test menu-10.5 {ConfigureMenuEntry} { +test menu-11.5 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command list [catch {.m1 entryconfigure 1 -label "test"} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] } {0 {} test {}} -test menu-10.6 {ConfigureMenuEntry} { +test menu-11.6 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command list [catch {.m1 entryconfigure 1 -label "test"} msg] $msg [destroy .m1] } {0 {} {}} -test menu-10.7 {ConfigureMenuEntry} { +test menu-11.7 {ConfigureMenuEntry} { catch {destroy .m1} catch {destroy .m2} menu .m2 @@ -1476,31 +1515,31 @@ test menu-10.7 {ConfigureMenuEntry} { .m1 add cascade list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1 .m2] } {0 {} {}} -test menu-10.8 {ConfigureMenuEntry} { +test menu-11.8 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add cascade list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] } {0 {} {}} -test menu-10.9 {ConfigureMenuEntry} { +test menu-11.9 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add cascade -menu .m3 list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] } {0 {} {}} -test menu-10.10 {ConfigureMenuEntry} { +test menu-11.10 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add cascade list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] } {0 {} {}} -test menu-10.11 {ConfigureMenuEntry} { +test menu-11.11 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add cascade -menu .m2 list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] } {0 {} {}} -test menu-10.12 {ConfigureMenuEntry} { +test menu-11.12 {ConfigureMenuEntry} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -1517,7 +1556,7 @@ test menu-10.12 {ConfigureMenuEntry} { .m5 add cascade list [catch {.m5 entryconfigure 1 -label "test" -menu .m1} msg] $msg [destroy .m1 .m2 .m3 .m4 .m5] } {0 {} {}} -test menu-10.13 {ConfigureMenuEntry} { +test menu-11.13 {ConfigureMenuEntry} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -1531,29 +1570,29 @@ test menu-10.13 {ConfigureMenuEntry} { .m4 add cascade -menu .m1 list [catch {.m3 entryconfigure 1 -label "test" -menu .m1} msg] $msg [destroy .m1 .m2 .m3 .m4] } {0 {} {}} -test menu-10.14 {ConfigureMenuEntry} { +test menu-11.14 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add checkbutton list [catch {.m1 entryconfigure 1 -variable "test"} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1] } {0 {} test {}} -test menu-10.15 {ConfigureMenuEntry} { +test menu-11.15 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 list [catch {.m1 add checkbutton -label "test"} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1] } {0 {} test {}} -test menu-10.16 {ConfigureMenuEntry} { +test menu-11.16 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 list [catch {.m1 add radiobutton -label "test"} msg] $msg [destroy .m1] } {0 {} {}} -test menu-10.17 {ConfigureMenuEntry} { +test menu-11.17 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add checkbutton list [catch {.m1 entryconfigure 1 -onvalue "test"} msg] $msg [.m1 entrycget 1 -onvalue] [destroy .m1] } {0 {} test {}} -test menu-10.18 {ConfigureMenuEntry} { +test menu-11.18 {ConfigureMenuEntry} { catch {destroy .m1} catch {image delete image1} menu .m1 @@ -1561,7 +1600,7 @@ test menu-10.18 {ConfigureMenuEntry} { image create test image1 list [catch {.m1 entryconfigure 1 -image image1} msg] $msg [destroy .m1] [image delete image1] } {0 {} {} {}} -test menu-10.19 {ConfigureMenuEntry} { +test menu-11.19 {ConfigureMenuEntry} { catch {destroy .m1} catch {image delete image1} catch {image delete image2} @@ -1571,7 +1610,7 @@ test menu-10.19 {ConfigureMenuEntry} { .m1 add command -image image1 list [catch {.m1 entryconfigure 1 -image image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2] } {0 {} {} {} {}} -test menu-10.20 {ConfigureMenuEntry} { +test menu-11.20 {ConfigureMenuEntry} { catch {destroy .m1} catch {image delete image1} catch {image delete image2} @@ -1581,7 +1620,7 @@ test menu-10.20 {ConfigureMenuEntry} { .m1 add checkbutton -image image1 list [catch {.m1 entryconfigure 1 -selectimage image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2] } {0 {} {} {} {}} -test menu-10.21 {ConfigureMenuEntry} { +test menu-11.21 {ConfigureMenuEntry} { catch {destroy .m1} catch {image delete image1} catch {image delete image2} @@ -1594,7 +1633,7 @@ test menu-10.21 {ConfigureMenuEntry} { list [catch {.m1 entryconfigure 1 -selectimage image3} msg] $msg [destroy .m1] [image delete image1] [image delete image2] [image delete image3] } {0 {} {} {} {} {}} -test menu-11.1 {ConfigureMenuCloneEntries} { +test menu-12.1 {ConfigureMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -1606,7 +1645,7 @@ test menu-11.1 {ConfigureMenuCloneEntries} { .m1 add command -label "test2" list [list [catch {.m1 entryconfigure 1 -gork "foo"} msg] $msg] [destroy .m1] } {{1 {unknown option "-gork"}} {}} -test menu-11.2 {ConfigureMenuCloneEntries} { +test menu-12.2 {ConfigureMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -1618,7 +1657,7 @@ test menu-11.2 {ConfigureMenuCloneEntries} { menu .m4 list [catch {.m1 entryconfigure 1 -menu .m4} msg] $msg [destroy .m1] [destroy .m3] [destroy .m4] } {0 {} {} {} {}} -test menu-11.3 {ConfigureMenuCloneEntries} { +test menu-12.3 {ConfigureMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -1627,7 +1666,18 @@ test menu-11.3 {ConfigureMenuCloneEntries} { list [catch {.m1 entryconfigure dummy -menu .m3} msg] $msg [destroy .m1] } {0 {} {}} -test menu-12.1 {TkGetMenuIndex} { +test menu-12.4 {ConfigureMenuCloneEntries} { + catch {destroy .m1} + catch {destroy .m2} + menu .m1 + .m1 add cascade -label File -menu .m1.foo + menu .m1.foo + .m1.foo add command -label bar + .m1 clone .m2 + list [catch {.m1 entryconfigure File -state disabled} msg1] $msg1 [destroy .m1] +} {0 {} {}} + +test menu-13.1 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "active" @@ -1636,7 +1686,7 @@ test menu-12.1 {TkGetMenuIndex} { .m1 activate 2 list [catch {.m1 entrycget active -label} msg] $msg [destroy .m1] } {0 test2 {}} -test menu-12.2 {TkGetMenuIndex} { +test menu-13.2 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "last" @@ -1645,7 +1695,7 @@ test menu-12.2 {TkGetMenuIndex} { .m1 activate 2 list [catch {.m1 entrycget last -label} msg] $msg [destroy .m1] } {0 test3 {}} -test menu-12.3 {TkGetMenuIndex} { +test menu-13.3 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "last" @@ -1654,19 +1704,19 @@ test menu-12.3 {TkGetMenuIndex} { .m1 activate 2 list [catch {.m1 entrycget end -label} msg] $msg [destroy .m1] } {0 test3 {}} -test menu-12.4 {TkGetMenuIndex} { +test menu-13.4 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [catch {.m1 insert last command -label "test2"} msg] $msg [.m1 entrycget last -label] [destroy .m1] } {0 {} test2 {}} -test menu-12.5 {TkGetMenuIndex} { +test menu-13.5 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [catch {.m1 insert end command -label "test2"} msg] $msg [.m1 entrycget end -label] [destroy .m1] } {0 {} test2 {}} -test menu-12.6 {TkGetMenuIndex} { +test menu-13.6 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "active" @@ -1676,7 +1726,7 @@ test menu-12.6 {TkGetMenuIndex} { list [catch {.m1 entrycget none -label} msg] $msg [destroy .m1] } {0 {} {}} #test menu-13.7 - Need to add @test here. -test menu-12.7 {TkGetMenuIndex} { +test menu-13.7 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "active" @@ -1684,32 +1734,32 @@ test menu-12.7 {TkGetMenuIndex} { .m1 add command -label "test3" list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] } {0 active {}} -test menu-12.8 {TkGetMenuIndex} { +test menu-13.8 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "active" list [catch {.m1 entrycget -1 -label} msg] $msg [destroy .m1] } {1 {bad menu entry index "-1"} {}} -test menu-12.9 {TkGetMenuIndex} { +test menu-13.9 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "test" .m1 add command -label "test2" list [catch {.m1 entrycget 999 -label} msg] $msg [destroy .m1] } {0 test2 {}} -test menu-12.10 {TkGetMenuIndex} { +test menu-13.10 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 insert 999 command -label "test" list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] } {0 test {}} -test menu-12.11 {TkGetMenuIndex} { +test menu-13.11 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "1test" list [catch {.m1 entrycget 1test -label} msg] $msg [destroy .m1] } {0 1test {}} -test menu-12.12 {TkGetMenuIndex} { +test menu-13.12 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "test" @@ -1718,101 +1768,101 @@ test menu-12.12 {TkGetMenuIndex} { list [catch {.m1 entrycget test2 -command} msg] $msg [destroy .m1] } {0 beep {}} -test menu-13.1 {MenuCmdDeletedProc} { +test menu-14.1 {MenuCmdDeletedProc} { catch {destroy .m1} menu .m1 list [catch {destroy .m1} msg] $msg } {0 {}} -test menu-13.2 {MenuCmdDeletedProc} { +test menu-14.2 {MenuCmdDeletedProc} { catch {destroy .m1} menu .m1 .m1 clone .m2 list [catch {destroy .m1} msg] $msg } {0 {}} -test menu-14.1 {MenuNewEntry} { +test menu-15.1 {MenuNewEntry} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "test"} msg] $msg [destroy .m1] } {0 {} {}} -test menu-14.2 {MenuNewEntry} { +test menu-15.2 {MenuNewEntry} { catch {destroy .m1} menu .m1 .m1 add command -label "test" .m1 add command -label "test3" list [catch {.m1 insert 2 command -label "test2"} msg] $msg [destroy .m1] } {0 {} {}} -test menu-14.3 {MenuNewEntry} { +test menu-15.3 {MenuNewEntry} { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [catch {.m1 add command -label "test2"} msg] $msg [destroy .m1] } {0 {} {}} -test menu-14.4 {MenuNewEntry} { +test menu-15.4 {MenuNewEntry} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "test"} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.1 {MenuAddOrInsert} { +test menu-16.1 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 insert foo command -label "test"} msg] $msg [destroy .m1] } {1 {bad menu entry index "foo"} {}} -test menu-15.2 {MenuAddOrInsert} { +test menu-16.2 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [catch {.m1 insert test command -label "foo"} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.3 {MenuAddOrInsert} { +test menu-16.3 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 insert -1 command -label "test"} msg] $msg [destroy .m1] } {1 {bad menu entry index "-1"} {}} -test menu-15.4 {MenuAddOrInsert} { +test menu-16.4 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 .m1 add command -label "test" .m1 insert 0 command -label "test2" list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] } {0 test2 {}} -test menu-15.5 {MenuAddOrInsert} { +test menu-16.5 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add cascade} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.6 {MenuAddOrInsert} { +test menu-16.6 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add checkbutton} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.7 {MenuAddOrInsert} { +test menu-16.7 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add command} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.8 {MenuAddOrInsert} { +test menu-16.8 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add radiobutton} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.9 {MenuAddOrInsert} { +test menu-16.9 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add separator} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.10 {MenuAddOrInsert} { +test menu-16.10 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add blork} msg] $msg [destroy .m1] } {1 {bad menu entry type "blork": must be cascade, checkbutton, command, radiobutton, or separator} {}} -test menu-15.11 {MenuAddOrInsert} { +test menu-16.11 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add command} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.12 {MenuAddOrInsert} { +test menu-16.12 {MenuAddOrInsert} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -1821,7 +1871,7 @@ test menu-15.12 {MenuAddOrInsert} { .m2 clone .m3 list [catch {.m2 add command -label "test"} msg1] $msg1 [catch {.m1 entrycget 1 -label} msg2] $msg2 [catch {.m3 entrycget 1 -label} msg3] $msg3 [destroy .m1] } {0 {} 0 test 0 test {}} -test menu-15.13 {MenuAddOrInsert} { +test menu-16.13 {MenuAddOrInsert} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -1830,12 +1880,12 @@ test menu-15.13 {MenuAddOrInsert} { .m2 clone .m3 list [catch {.m3 add command -label "test"} msg1] $msg1 [catch {.m1 entrycget 1 -label} msg2] $msg2 [catch {.m2 entrycget 1 -label} msg3] $msg3 [destroy .m1] } {0 {} 0 test 0 test {}} -test menu-15.14 {MenuAddOrInsert} { +test menu-16.14 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -blork} msg] $msg [destroy .m1] } {1 {unknown option "-blork"} {}} -test menu-15.15 {MenuAddOrInsert} { +test menu-16.15 {MenuAddOrInsert} { catch {destroy .m1} catch {destroy .container} menu .m1 @@ -1844,7 +1894,7 @@ test menu-15.15 {MenuAddOrInsert} { . configure -menu .container list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .container .m1] } {0 {} {} {}} -test menu-15.16 {MenuAddOrInsert} { +test menu-16.16 {MenuAddOrInsert} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -1852,7 +1902,7 @@ test menu-15.16 {MenuAddOrInsert} { set tearoff [tkTearOffMenu .m2] list [catch {.m2 add cascade -menu .m1} msg] $msg [$tearoff unpost] [catch {destroy .m1} msg2] $msg2 [catch {destroy .m2} msg3] $msg3 } {0 {} {} 0 {} 0 {}} -test menu-15.17 {MenuAddOrInsert} { +test menu-16.17 {MenuAddOrInsert} { catch {destroy .m1} catch {destroy .container} menu .m1 @@ -1861,7 +1911,7 @@ test menu-15.17 {MenuAddOrInsert} { set tearoff [tkTearOffMenu .container] list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .container] } {0 {} {} {}} -test menu-15.18 {MenuAddOrInsert} { +test menu-16.18 {MenuAddOrInsert} { catch {destroy .m1} catch {destroy .container} menu .m1 @@ -1870,7 +1920,7 @@ test menu-15.18 {MenuAddOrInsert} { . configure -menu .container list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .container] } {0 {} {} {}} -test menu-15.19 {MenuAddOrInsert - Insert a cascade deep into the tree} { +test menu-16.19 {MenuAddOrInsert - Insert a cascade deep into the tree} { catch {destroy .menubar} menu .menubar menu .menubar.test -tearoff 0 @@ -1884,7 +1934,7 @@ test menu-15.19 {MenuAddOrInsert - Insert a cascade deep into the tree} { [. configure -menu ""] [destroy .menubar] } {0 .#menubar.#menubar#test.#menubar#test#cascade {} {}} -test menu-16.1 {MenuVarProc} { +test menu-17.1 {MenuVarProc} { catch {destroy .m1} catch {unset foo} menu .m1 @@ -1892,45 +1942,45 @@ test menu-16.1 {MenuVarProc} { list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [catch {unset foo} msg2] $msg2 [destroy .m1] } {0 {} 0 {} {}} # menu-17.2 - Don't know how to generate the flags in the if -test menu-16.2 {MenuVarProc} { +test menu-17.2 {MenuVarProc} { catch {destroy .m1} catch {unset foo} menu .m1 list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo ""] [destroy .m1] } {0 {} {} {}} -test menu-16.3 {MenuVarProc} { +test menu-17.3 {MenuVarProc} { catch {destroy .m1} catch {unset foo} menu .m1 set foo "hello" list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "hello"] [destroy .m1] [catch {unset foo} msg2] $msg2 } {0 {} hello {} 0 {}} -test menu-16.4 {MenuVarProc} { +test menu-17.4 {MenuVarProc} { catch {destroy .m1} menu .m1 set foo "goodbye" list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "hello"] [destroy .m1] [catch {unset foo} msg2] $msg2 } {0 {} hello {} 0 {}} -test menu-16.5 {MenuVarProc} { +test menu-17.5 {MenuVarProc} { catch {destroy .m1} menu .m1 set foo "hello" list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "goodbye"] [destroy .m1] [catch {unset foo} msg2] $msg2 } {0 {} goodbye {} 0 {}} -test menu-17.1 {TkActivateMenuEntry} { +test menu-18.1 {TkActivateMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [catch {.m1 activate 1} msg] $msg [destroy .m1] } {0 {} {}} -test menu-17.2 {TkActivateMenuEntry} { +test menu-18.2 {TkActivateMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [catch {.m1 activate 0} msg] $msg [destroy .m1] } {0 {} {}} -test menu-17.3 {TkActivateMenuEntry} { +test menu-18.3 {TkActivateMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command -label "test" @@ -1938,7 +1988,7 @@ test menu-17.3 {TkActivateMenuEntry} { .m1 activate 1 list [catch {.m1 activate 2} msg] $msg [destroy .m1] } {0 {} {}} -test menu-17.4 {TkActivateMenuEntry} { +test menu-18.4 {TkActivateMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command -label "test" @@ -1947,56 +1997,56 @@ test menu-17.4 {TkActivateMenuEntry} { list [catch {.m1 activate 1} msg] $msg [destroy .m1] } {0 {} {}} -test menu-18.1 {TkPostCommand} {menuInteractive} { +test menu-19.1 {TkPostCommand} {nonUnixUserInteraction } { catch {destroy .m1} menu .m1 -postcommand "set menu_test menu-19.1" .m1 add command -label "menu-19.1 - hit Escape" list [catch {.m1 post 40 40} msg] $msg [.m1 unpost] [set menu_test] [destroy .m1] } {0 menu-19.1 {} menu-19.1 {}} -test menu-18.2 {TkPostCommand} {menuInteractive} { +test menu-19.2 {TkPostCommand} {nonUnixUserInteraction } { catch {destroy .m1} menu .m1 .m1 add command -label "menu-19.2 - hit Escape" list [catch {.m1 post 40 40} msg] $msg [.m1 unpost] [destroy .m1] } {0 {} {} {}} -test menu-19.1 {CloneMenu} { +test menu-20.1 {CloneMenu} { catch {destroy .m1} catch {destroy .m2} menu .m1 list [catch {.m1 clone .m2} msg1] $msg1 [destroy .m1] } {0 {} {}} -test menu-19.2 {CloneMenu} { +test menu-20.2 {CloneMenu} { catch {destroy .m1} catch {destroy .m2} menu .m1 list [catch {.m1 clone .m2 normal} msg1] $msg1 [destroy .m1] } {0 {} {}} -test menu-19.3 {CloneMenu} { +test menu-20.3 {CloneMenu} { catch {destroy .m1} catch {destroy .m2} menu .m1 list [catch {.m1 clone .m2 tearoff} msg1] $msg1 [destroy .m1] } {0 {} {}} -test menu-19.4 {CloneMenu} { +test menu-20.4 {CloneMenu} { catch {destroy .m1} catch {destroy .m2} menu .m1 list [catch {.m1 clone .m2 menubar} msg1] $msg1 [destroy .m1] } {0 {} {}} -test menu-19.5 {CloneMenu} { +test menu-20.5 {CloneMenu} { catch {destroy .m1} catch {destroy .m2} menu .m1 list [catch {.m1 clone .m2 foo} msg1] $msg1 [destroy .m1] -} {1 {bad menu type - must be normal, tearoff, or menubar} {}} -test menu-19.6 {CloneMenu - hooking up bookeeping ptrs} { +} {1 {bad menu type "foo": must be normal, tearoff, or menubar} {}} +test menu-20.6 {CloneMenu - hooking up bookeeping ptrs} { catch {destroy .m1} catch {destroy .m2} menu .m1 list [catch {.m1 clone .m2} msg] $msg [destroy .m1] } {0 {} {}} - test menu-19.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} { + test menu-20.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -2004,14 +2054,14 @@ test menu-19.6 {CloneMenu - hooking up bookeeping ptrs} { .m1 clone .m2 list [catch {.m1 clone .m3} msg] $msg [destroy .m1] } {0 {} {}} - test menu-19.8 {CloneMenu - cascade entries} { + test menu-20.8 {CloneMenu - cascade entries} { catch {destroy .m1} catch {destroy .foo} menu .m1 .m1 add cascade -menu .m2 list [catch {.m1 clone .foo} msg] $msg [destroy .m1] } {0 {} {}} - test menu-19.9 {CloneMenu - cascades entries} { + test menu-20.9 {CloneMenu - cascades entries} { catch {destroy .m1} catch {destroy .m2} catch {destroy .foo} @@ -2020,13 +2070,13 @@ test menu-19.6 {CloneMenu - hooking up bookeeping ptrs} { menu .m2 list [catch {.m1 clone .foo} msg] $msg [destroy .m1 .m2] } {0 {} {}} -test menu-19.10 {CloneMenu - tearoff fields} { +test menu-20.10 {CloneMenu - tearoff fields} { catch {destroy .m1} catch {destroy .m2} menu .m1 list [catch {.m1 clone .m2 normal} msg1] $msg1 [catch {.m2 cget -tearoff} msg2] $msg2 [destroy .m1] } {0 {} 0 1 {}} -test menu-19.11 {CloneMenu} { +test menu-20.11 {CloneMenu} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -2034,26 +2084,26 @@ test menu-19.11 {CloneMenu} { list [catch {.m1 clone .m2} msg] $msg [destroy .m1 .m2] } {1 {window name "m2" already exists in parent} {}} -test menu-20.1 {MenuDoYPosition} { +test menu-21.1 {MenuDoYPosition} { catch {destroy .m1} menu .m1 list [catch {.m1 yposition glorp} msg] $msg [destroy .m1] } {1 {bad menu entry index "glorp"} {}} -test menu-20.2 {MenuDoYPosition} { +test menu-21.2 {MenuDoYPosition} { catch {destroy .m1} menu .m1 .m1 add command -label "Test" list [catch {.m1 yposition 1}] [destroy .m1] } {0 {}} -test menu-21.1 {GetIndexFromCoords} { +test menu-22.1 {GetIndexFromCoords} { catch {destroy .m1} menu .m1 .m1 add command -label "test" .m1 configure -tearoff 0 list [catch {.m1 index @5} msg] $msg [destroy .m1] } {0 0 {}} -test menu-21.2 {GetIndexFromCoords} { +test menu-22.2 {GetIndexFromCoords} { catch {destroy .m1} menu .m1 .m1 add command -label "test" @@ -2061,13 +2111,13 @@ test menu-21.2 {GetIndexFromCoords} { list [catch {.m1 index @5,5} msg] $msg [destroy .m1] } {0 0 {}} -test menu-22.1 {RecursivelyDeleteMenu} { +test menu-23.1 {RecursivelyDeleteMenu} { catch {destroy .m1} menu .m1 . configure -menu .m1 list [catch {. configure -menu ""} msg] $msg [destroy .m1] } {0 {} {}} -test menu-22.2 {RecursivelyDeleteMenu} { +test menu-23.2 {RecursivelyDeleteMenu} { catch {destroy .m1} catch {destroy .m2} menu .m2 @@ -2078,40 +2128,40 @@ test menu-22.2 {RecursivelyDeleteMenu} { list [catch {. configure -menu ""} msg] $msg [destroy .m1 .m2] } {0 {} {}} -test menu-23.1 {TkNewMenuName} { +test menu-24.1 {TkNewMenuName} { catch {destroy .m1} menu .m1 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test menu-23.2 {TkNewMenuName} { +test menu-24.2 {TkNewMenuName} { catch {destroy .m1} catch {destroy .m1\#0} menu .m1 menu .m1\#0 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test menu-23.3 {TkNewMenuName} { +test menu-24.3 {TkNewMenuName} { catch {destroy .#m} menu .#m rename .#m hideme list [catch {. configure -menu [menu .m]} $msg] [. configure -menu ""] [destroy .#m] [destroy .m] [destroy hideme] } {0 {} {} {} {}} -test menu-24.1 {TkSetWindowMenuBar} { +test menu-25.1 {TkSetWindowMenuBar} { . configure -menu "" list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] } {0 {} {}} -test menu-24.2 {TkSetWindowMenuBar} { +test menu-25.2 {TkSetWindowMenuBar} { . configure -menu "" list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] } {0 {} {}} -test menu-24.3 {TkSetWindowMenuBar} { +test menu-25.3 {TkSetWindowMenuBar} { . configure -menu "" catch {destroy .m1} menu .m1 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test menu-24.4 {TkSetWindowMenuBar} { +test menu-25.4 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} . configure -menu "" @@ -2120,7 +2170,7 @@ test menu-24.4 {TkSetWindowMenuBar} { menu .m2 list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .m1 .m2] } {0 {} {} {}} -test menu-24.5 {TkSetWindowMenuBar} { +test menu-25.5 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -2131,7 +2181,7 @@ test menu-24.5 {TkSetWindowMenuBar} { menu .m3 list [catch {. configure -menu .m3} msg] $msg [. configure -menu ""] [destroy .m1 .m3] } {0 {} {} {}} -test menu-24.6 {TkSetWindowMenuBar} { +test menu-25.6 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -2142,7 +2192,7 @@ test menu-24.6 {TkSetWindowMenuBar} { menu .m3 list [catch {. configure -menu .m3} msg] $msg [. configure -menu ""] [destroy .m1 .m3] } {0 {} {} {}} -test menu-24.7 {TkSetWindowMenuBar} { +test menu-25.7 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} . configure -menu "" @@ -2153,7 +2203,7 @@ test menu-24.7 {TkSetWindowMenuBar} { .t2 configure -menu .m1 list [catch {.t2 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1 .m2] } {0 {} {} {}} -test menu-24.8 {TkSetWindowMenuBar} { +test menu-25.8 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} catch {destroy .t2} @@ -2166,7 +2216,7 @@ test menu-24.8 {TkSetWindowMenuBar} { .t2 configure -menu .m1 list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1 .m2] } {0 {} {} {}} -test menu-24.9 {TkSetWindowMenuBar} { +test menu-25.9 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} catch {destroy .t2} @@ -2181,7 +2231,7 @@ test menu-24.9 {TkSetWindowMenuBar} { wm geometry .t3 +0+0 list [catch {.t3 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2] } {0 {} {} {}} -test menu-24.10 {TkSetWindowMenuBar} { +test menu-25.10 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} catch {destroy .t2} @@ -2196,7 +2246,7 @@ test menu-24.10 {TkSetWindowMenuBar} { wm geometry .t3 +0+0 list [catch {.t2 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2] } {0 {} {} {}} -test menu-24.11 {TkSetWindowMenuBar} { +test menu-25.11 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} catch {destroy .t2} @@ -2211,27 +2261,27 @@ test menu-24.11 {TkSetWindowMenuBar} { wm geometry .t3 +0+0 list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2] } {0 {} {} {}} -test menu-24.12 {TkSetWindowMenuBar} { +test menu-25.12 {TkSetWindowMenuBar} { catch {destroy .m1} . configure -menu "" menu .m1 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test menu-24.13 {TkSetWindowMenuBar} { +test menu-25.13 {TkSetWindowMenuBar} { . configure -menu "" list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] } {0 {} {}} -test menu-24.14 {TkSetWindowMenuBar} { +test menu-25.14 {TkSetWindowMenuBar} { catch {destroy .m1} . configure -menu "" menu .m1 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test menu-24.15 {TkSetWindowMenuBar} { +test menu-25.15 {TkSetWindowMenuBar} { . configure -menu "" list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] } {0 {} {}} -test menu-24.16 {TkSetWindowMenuBar} { +test menu-25.16 {TkSetWindowMenuBar} { catch {destroy .m1} . configure -menu "" menu .m1 @@ -2239,7 +2289,7 @@ test menu-24.16 {TkSetWindowMenuBar} { list [catch {toplevel .t2 -menu m1} msg] $msg [. configure -menu ""] [destroy .t2 .m1] } {0 .t2 {} {}} -test menu-25.1 {DestroyMenuHashTable} { +test menu-26.1 {DestroyMenuHashTable} { catch {interp destroy testinterp} interp create testinterp load {} Tk testinterp @@ -2247,18 +2297,18 @@ test menu-25.1 {DestroyMenuHashTable} { list [catch {interp delete testinterp} msg] $msg } {0 {}} -test menu-26.1 {GetMenuHashTable} { +test menu-27.1 {GetMenuHashTable} { catch {interp destroy testinterp} interp create testinterp load {} tk testinterp list [catch {interp eval testinterp {menu .m1}} msg] $msg [interp delete testinterp] } {0 .m1 {}} -test menu-27.1 {TkCreateMenuReferences - not there before} { +test menu-28.1 {TkCreateMenuReferences - not there before} { catch {destroy .m1} list [catch {menu .m1} msg] $msg [destroy .m1] } {0 .m1 {}} -test menu-27.2 {TkCreateMenuReferences - there already} { +test menu-28.2 {TkCreateMenuReferences - there already} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -2266,14 +2316,14 @@ test menu-27.2 {TkCreateMenuReferences - there already} { list [catch {menu .m2} msg] $msg [destroy .m1 .m2] } {0 .m2 {}} -test menu-28.1 {TkFindMenuReferences - not there} { +test menu-29.1 {TkFindMenuReferences - not there} { catch {destroy .m1} . configure -menu "" menu .m1 .m1 add cascade -menu .m2 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test menu-29.1 {TkFindMenuReferences - there already} { +test menu-30.1 {TkFindMenuReferences - there already} { catch {destroy .m1} catch {destroy .m2} . configure -menu "" @@ -2283,23 +2333,23 @@ test menu-29.1 {TkFindMenuReferences - there already} { list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .m2] } {0 {} {} {}} -test menu-30.1 {TkFreeMenuReferences - menuPtr} { +test menu-31.1 {TkFreeMenuReferences - menuPtr} { catch {destroy .m1} menu .m1 list [catch {destroy .m1} msg] $msg } {0 {}} -test menu-30.2 {TkFreeMenuReferences - cascadePtr} { +test menu-31.2 {TkFreeMenuReferences - cascadePtr} { catch {destroy .m1} . configure -menu "" menu .m1 .m1 add cascade -menu .m2 list [catch {.m1 entryconfigure 1 -menu .m3} msg] $msg [destroy .m1] } {0 {} {}} -test menu-30.3 {TkFreeMenuReferences - topLevelListPtr} { +test menu-31.3 {TkFreeMenuReferences - topLevelListPtr} { . configure -menu .m1 list [catch {. configure -menu ""} msg] $msg } {0 {}} -test menu-30.4 {TkFreeMenuReferences - not empty} { +test menu-31.4 {TkFreeMenuReferences - not empty} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -2309,7 +2359,7 @@ test menu-30.4 {TkFreeMenuReferences - not empty} { list [catch {.m2 entryconfigure 1 -menu ".foo"} msg] $msg [destroy .m1 .m2] } {0 {} {}} -test menu-31.1 {DeleteMenuCloneEntries} { +test menu-32.1 {DeleteMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -2317,7 +2367,7 @@ test menu-31.1 {DeleteMenuCloneEntries} { .m1 clone .m2 list [catch {.m1 delete 1} msg] $msg [destroy .m1] } {0 {} {}} -test menu-31.2 {DeleteMenuCloneEntries} { +test menu-32.2 {DeleteMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -2328,7 +2378,7 @@ test menu-31.2 {DeleteMenuCloneEntries} { .m1 clone .m2 list [catch {.m1 delete 2 3} msg] $msg [destroy .m1] } {0 {} {}} -test menu-31.3 {DeleteMenuCloneEntries} { +test menu-32.3 {DeleteMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} menu .m1 -tearoff 0 @@ -2340,7 +2390,7 @@ test menu-31.3 {DeleteMenuCloneEntries} { .m2 configure -tearoff 1 list [catch {.m1 delete 1 2} msg] $msg [destroy .m1] } {0 {} {}} -test menu-31.4 {DeleteMenuCloneEntries} { +test menu-32.4 {DeleteMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -2352,7 +2402,7 @@ test menu-31.4 {DeleteMenuCloneEntries} { .m2 configure -tearoff 0 list [catch {.m1 delete 2 3} msg] $msg [destroy .m1] } {0 {} {}} -test menu-31.5 {DeleteMenuCloneEntries} { +test menu-32.5 {DeleteMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -2362,17 +2412,23 @@ test menu-31.5 {DeleteMenuCloneEntries} { .m1 activate one list [catch {.m1 delete one} msg] $msg [destroy .m1] } {0 {} {}} -test menu-31.6 {DeleteMenuCloneEntries - reentrancy - crashes tk8.0} { +test menu-32.6 {DeleteMenuCloneEntries - reentrancy - crashes tk8.0} { catch {destroy .m1} menu .m1 .m1 add command -label test -command ".m1 delete test ; .m1 add command -label test -command \".m1 delete test\"; .m1 delete test" list [catch {.m1 invoke test} msg] $msg [destroy .m1] } {0 {} {}} +test menu-32.7 {DeleteMenuCloneEntries - one entry} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add command -label Hello + list [catch {.m1 delete Hello} msg] $msg [destroy .m1] +} {0 {} {}} set l [interp hidden] eval destroy [winfo children .] -test menu-32.1 {menu vs command hiding} { +test menu-33.1 {menu vs command hiding} { catch {destroy .m} menu .m interp hide {} .m @@ -2382,4 +2438,22 @@ test menu-32.1 {menu vs command hiding} { # menu-34 MenuInit only called at boot time +# creating menus on two different screens then deleting the +# menu from the first screen crashes Tk8.3.1 +# +test menu-35.1 {menus on multiple screens - crashes tk8.3.1, Bug 5454} { + if {[info exists ::env(TK_ALT_DISPLAY)]} { + toplevel .one + menu .one.m + toplevel .two -screen $::env(TK_ALT_DISPLAY) + menu .two.m + destroy .one + destroy .two + } +} {} + +# cleanup deleteWindows +::tcltest::cleanupTests +return + diff --git a/tk/tests/menuDraw.test b/tk/tests/menuDraw.test index 7a1b660df85..f6902a73e0d 100644 --- a/tk/tests/menuDraw.test +++ b/tk/tests/menuDraw.test @@ -2,23 +2,23 @@ # organized in the standard fashion for Tcl tests. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[info procs test] != "test"} { - source defs -} - proc deleteWindows {} { foreach i [winfo children .] { catch [destroy $i] @@ -29,16 +29,6 @@ deleteWindows wm geometry . {} raise . -if {$tcl_platform(platform) == "windows" && ![info exists INTERACTIVE]} { - puts " Some tests were skipped because they could not be performed" - puts " automatically on this platform. If you wish to execute them" - puts " interactively, set the TCL variable INTERACTIVE and re-run" - puts " the test." - set testConfig(menuInteractive) 0 -} else { - set testConfig(menuInteractive) 1 -} - test menuDraw-1.1 {TkMenuInitializeDrawingFields} { catch {destroy .m1} list [menu .m1] [destroy .m1] @@ -118,7 +108,7 @@ test menuDraw-6.6 {TkMenuConfigureEntryDrawOptions - bad state} { menu .m1 .m1 add command -label "foo" list [catch {.m1 entryconfigure 1 -state foo} msg] $msg [destroy .m1] -} {1 {bad state value "foo": must be normal, active, or disabled} {}} +} {1 {bad state "foo": must be active, normal, or disabled} {}} test menuDraw-6.7 {TkMenuConfigureEntryDrawOptions - tkfont specified} { catch {destroy .m1} menu .m1 @@ -191,7 +181,7 @@ test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} { } {{} {}} -test menuDraw-8.1 {TkRecomputeMenu} {menuInteractive} { +test menuDraw-8.1 {TkRecomputeMenu} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 configure -postcommand [.m1 add command -label foo] @@ -506,7 +496,7 @@ test menuDraw-16.5 {TkPostSubMenu} {unixOnly} { set tearoff [tkTearOffMenu .m1 40 40] list [catch {$tearoff postcascade test} msg] $msg [destroy .m1] [destroy .m2] } {1 {invalid command name "glorp"} {} {}} -test menuDraw-16.6 {TkPostSubMenu} {menuInteractive} { +test menuDraw-16.6 {TkPostSubMenu} {pcOnly userInteraction} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -532,7 +522,7 @@ test menuDraw-17.1 {AdjustMenuCoords - menubar} {unixOnly} { } list [$w postcascade 0] [. configure -menu ""] [destroy .m1] [destroy .m2] } {{} {} {} {}} -test menuDraw-17.2 {AdjustMenuCoords - menu} {menuInteractive} { +test menuDraw-17.2 {AdjustMenuCoords - menu} {pcOnly userInteraction} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -543,4 +533,20 @@ test menuDraw-17.2 {AdjustMenuCoords - menu} {menuInteractive} { list [$tearoff postcascade 0] [destroy .m1] [destroy .m2] } {{} {} {}} +# cleanup deleteWindows +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/menubut.test b/tk/tests/menubut.test index eb510cfe823..a3031957544 100644 --- a/tk/tests/menubut.test +++ b/tk/tests/menubut.test @@ -3,9 +3,8 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ @@ -13,17 +12,18 @@ # XXX of a procedure has tests then the whole procedure has tests, # XXX but many procedures have no tests. +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[info procs test] != "test"} { - source defs -} - foreach i [winfo children .] { destroy $i } @@ -51,7 +51,7 @@ foreach test { {unknown color name "non-existent"}} {-activeforeground #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} - {-anchor nw nw bogus {bad anchor position "bogus": must be n, ne, e, se, s, sw, w, nw, or center}} + {-anchor nw nw bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}} {-background #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} {-bd 4 4 badValue {bad screen distance "badValue"}} @@ -59,7 +59,7 @@ foreach test { {-bitmap questhead questhead badValue {bitmap "badValue" not defined}} {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-direction below below badValue {bad direction value "badValue": must be above, below, left, right, or flush}} + {-direction below below badValue {bad direction "badValue": must be above, below, flush, left, or right}} {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}} {-fg #110022 #110022 bogus {unknown color name "bogus"}} {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}} @@ -74,8 +74,8 @@ foreach test { {-menu "any old string" "any old string" {} {}} {-padx 12 12 420x {bad screen distance "420x"}} {-pady 12 12 420x {bad screen distance "420x"}} - {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - {-state normal normal bogus {bad state value "bogus": must be normal, active, or disabled}} + {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} + {-state normal normal bogus {bad state "bogus": must be active, disabled, or normal}} {-takefocus "any string" "any string" {} {}} {-text "Sample text" {Sample text} {} {}} {-textvariable i i {} {}} @@ -122,7 +122,7 @@ test menubutton-3.1 {MenuButtonWidgetCmd procedure} { } {1 {wrong # args: should be ".mb option ?arg arg ...?"}} test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} { list [catch {.mb c} msg] $msg -} {1 {bad option "c": must be cget or configure}} +} {1 {ambiguous option "c": must be cget or configure}} test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} { list [catch {.mb cget} msg] $msg } {1 {wrong # args: should be ".mb cget option"}} @@ -191,7 +191,7 @@ test menubutton-4.4 {ConfigureMenuButton procedure} { (processing -height option) invoked from within ".mb1 configure -height 0.5x"}} -test menubutton-4.5 {ConfigureMenuButton procedure} {fonts} { +test menubutton-4.5 {ConfigureMenuButton procedure} {nonPortable fonts} { catch {destroy .mb1} button .mb1 -text "Sample text" -width 10 -height 2 pack .mb1 @@ -204,7 +204,7 @@ test menubutton-4.6 {ConfigureMenuButton procedure - bad direction} { menubutton .mb -text "Test" list [catch {.mb configure -direction badValue} msg] $msg \ [.mb cget -direction] [destroy .mb] -} {1 {bad direction value "badValue": must be above, below, left, right, or flush} below {}} +} {1 {bad direction "badValue": must be above, below, flush, left, or right} below {}} # XXX Need to add tests for several procedures here. XXX @@ -307,14 +307,14 @@ test menubutton-7.12 {ComputeMenuButtonGeometry procedure} {fonts} { pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } {62 30} -test menubutton-7.13 {ComputeMenuButtonGeometry procedure} {fonts} { +test menubutton-7.13 {ComputeMenuButtonGeometry procedure} {nonPortable fonts} { catch {destroy .mb} menubutton .mb -text String -bd 2 -relief raised \ -highlightthickness 1 -indicatoron 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } {78 28} -test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {unix nonPortable} { +test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {unixOnly nonPortable} { # The following test is non-portable because the indicator's pixel # size varies to maintain constant absolute size. @@ -324,7 +324,7 @@ test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {unix nonPortable} { pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } {64 23} -test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {pc nonPortable} { +test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {pcOnly nonPortable} { # The following test is non-portable because the indicator's pixel # size varies to maintain constant absolute size. @@ -350,3 +350,19 @@ eval image delete [image names] eval destroy [winfo children .] option clear +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/msgbox.test b/tk/tests/msgbox.test index 26b4746c2f6..d1be52d21e3 100644 --- a/tk/tests/msgbox.test +++ b/tk/tests/msgbox.test @@ -2,23 +2,27 @@ # It is organized in the standard fashion for Tcl tests. # # Copyright (c) 1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ # -if {[string compare test [info procs test]] == 1} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } +# Some tests require user interaction on non-unix platform +set ::tcltest::testConfig(nonUnixUserInteraction) \ + [expr {$::tcltest::testConfig(userInteraction) || \ + $::tcltest::testConfig(unixOnly)}] + test msgbox-1.1 {tk_messageBox command} { list [catch {tk_messageBox -foo} msg] $msg -} {1 {unknown option "-foo", must be -default, -icon, -message, -modal, -parent, -title or -type}} +} {1 {bad option "-foo": must be -default, -icon, -message, -parent, -title, or -type}} test msgbox-1.2 {tk_messageBox command} { list [catch {tk_messageBox -foo bar} msg] $msg -} {1 {unknown option "-foo", must be -default, -icon, -message, -modal, -parent, -title or -type}} +} {1 {bad option "-foo": must be -default, -icon, -message, -parent, -title, or -type}} catch {tk_messageBox -foo bar} msg regsub -all , $msg "" options @@ -38,23 +42,31 @@ test msgbox-1.4 {tk_messageBox command} { test msgbox-1.5 {tk_messageBox command} { list [catch {tk_messageBox -type foo} msg] $msg -} {1 {invalid message box type "foo", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel}} +} {1 {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel}} + +proc createPlatformMsg {val} { + global tcl_platform + if {$tcl_platform(platform) == "unix"} { + return "invalid default button \"$val\"" + } + return "bad -default value \"$val\": must be abort, retry, ignore, ok, cancel, no, or yes" +} test msgbox-1.6 {tk_messageBox command} { list [catch {tk_messageBox -default 1.1} msg] $msg -} {1 {invalid default button "1.1"}} +} [list 1 [createPlatformMsg "1.1"]] test msgbox-1.7 {tk_messageBox command} { list [catch {tk_messageBox -default foo} msg] $msg -} {1 {invalid default button "foo"}} +} [list 1 [createPlatformMsg "foo"]] test msgbox-1.8 {tk_messageBox command} { list [catch {tk_messageBox -type yesno -default 3} msg] $msg -} {1 {invalid default button "3"}} +} [list 1 [createPlatformMsg "3"]] test msgbox-1.9 {tk_messageBox command} { list [catch {tk_messageBox -icon foo} msg] $msg -} {1 {invalid icon "foo", must be error, info, question or warning}} +} {1 {bad -icon value "foo": must be error, info, question, or warning}} test msgbox-1.10 {tk_messageBox command} { list [catch {tk_messageBox -parent foo.bar} msg] $msg @@ -66,14 +78,6 @@ if {[info commands tkMessageBox] == ""} { set isNative 0 } -if {$isNative && ![info exists INTERACTIVE]} { - puts " Some tests were skipped because they could not be performed" - puts " automatically on this platform. If you wish to execute them" - puts " interactively, set the TCL variable INTERACTIVE and re-run" - puts " the test" - return -} - proc ChooseMsg {parent btn} { global isNative if {!$isNative} { @@ -128,30 +132,57 @@ set specs { # Try out all combinations of (type) x (default button) and # (type) x (icon). # +set count 1 foreach spec $specs { set type [lindex $spec 0] set buttons [lindex $spec 3] set button [lindex $buttons 0] - test msgbox-2.1 {tk_messageBox command} { + test msgbox-2.$count {tk_messageBox command} {nonUnixUserInteraction} { ChooseMsg $parent $button tk_messageBox -title Hi -message "Please press $button" \ -type $type } $button + incr count foreach icon {warning error info question} { - test msgbox-2.2 {tk_messageBox command -icon option} { + test msgbox-2.$count {tk_messageBox command -icon option} \ + {nonUnixUserInteraction} { ChooseMsg $parent $button tk_messageBox -title Hi -message "Please press $button" \ -type $type -icon $icon } $button + incr count } foreach button $buttons { - test msgbox-2.3 {tk_messageBox command} { + test msgbox-2.$count {tk_messageBox command} {nonUnixUserInteraction} { ChooseMsg $parent $button tk_messageBox -title Hi -message "Please press $button" \ -type $type -default $button } "$button" + incr count } } + +# These tests will hang your test suite if they fail. +test msgbox-3.1 {tk_messageBox handles withdrawn parent} {nonUnixUserInteraction} { + wm withdraw . + ChooseMsg . "ok" + tk_messageBox -title Hi -message "Please press ok" \ + -type ok -default ok +} "ok" +wm deiconify . + +test msgbox-3.2 {tk_messageBox handles iconified parent} {nonUnixUserInteraction} { + wm iconify . + ChooseMsg . "ok" + tk_messageBox -title Hi -message "Please press ok" \ + -type ok -default ok +} "ok" +wm deiconify . + +# cleanup +::tcltest::cleanupTests +return + diff --git a/tk/tests/obj.test b/tk/tests/obj.test index 1e3c52490c8..8edf93bc826 100644 --- a/tk/tests/obj.test +++ b/tk/tests/obj.test @@ -2,14 +2,13 @@ # It is organized in the standard fashion for Tcl tests. # # Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# SCCS: @(#) obj.test 1.2 97/11/17 11:20:18 +# RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -34,4 +33,20 @@ test obj-4.1 {SetPixelFromAny} { eval destroy [winfo children .] +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/oldpack.test b/tk/tests/oldpack.test index 0d2f9ccf292..7676da2410d 100644 --- a/tk/tests/oldpack.test +++ b/tk/tests/oldpack.test @@ -4,14 +4,14 @@ # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} then \ - {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # First, test a single window packed in various ways in a parent @@ -505,4 +505,20 @@ test pack-9.3 {information output} { } {{.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}} catch {destroy .pack} -concat {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/option.test b/tk/tests/option.test index 42c4d3bc980..aaa55ed0ea6 100644 --- a/tk/tests/option.test +++ b/tk/tests/option.test @@ -3,14 +3,14 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} then \ - {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {destroy .op1} catch {destroy .op2} @@ -185,15 +185,9 @@ test option-14.12 {error conditions} { list [catch {option get .gorp.gorp a A} msg] $msg } {1 {bad window path name ".gorp.gorp"}} -if {$tcl_platform(os) == "Win32s"} { - set option1 OPTION~2.FIL - set option2 OPTION~1.FIL - set option3 OPTION~3.FIL -} else { - set option1 option.file1 - set option2 option.file2 - set option3 option.file3 -} +set option1 [file join $::tcltest::testsDir option.file1] +set option2 [file join $::tcltest::testsDir option.file2] +set option3 [file join $::tcltest::testsDir option.file3] test option-15.1 {database files} { list [catch {option read non-existent} msg] $msg @@ -229,4 +223,20 @@ test option-16.1 {ReadOptionFile} { catch {destroy .op1} catch {destroy .op2} -concat {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/pack.test b/tk/tests/pack.test index e4f604ef062..c325b7d4c2d 100644 --- a/tk/tests/pack.test +++ b/tk/tests/pack.test @@ -3,14 +3,14 @@ # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} then \ - {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # Utility procedures: @@ -924,6 +924,13 @@ test pack-17.1 {PackLostSlaveProc procedure} { } {place 20x40+40+10 1 {window ".pack.a" isn't packed}} test pack-18.1 {unmap slaves when master unmapped} {tempNotPc} { + + # 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). + + wm geometry .pack +100+100 + # On the PC, when the width/height is configured while the window is # unmapped, the changes don't take effect until the window is remapped. # Who knows why? @@ -945,6 +952,12 @@ test pack-18.1 {unmap slaves when master unmapped} {tempNotPc} { lappend result [winfo ismapped .pack.a] } {1 0 200 75 0 1} test pack-18.2 {unmap slaves when master unmapped} { + + # 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). + + wm geometry .pack +100+100 eval destroy [winfo child .pack] frame .pack.a -relief raised -bd 2 frame .pack.b -width 70 -height 30 -relief sunken -bd 2 @@ -967,3 +980,20 @@ destroy .pack foreach i {pack1 pack2 pack3 pack4} { rename $i {} } + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/place.test b/tk/tests/place.test index f84903fc097..0d5722bdd21 100644 --- a/tk/tests/place.test +++ b/tk/tests/place.test @@ -2,14 +2,13 @@ # organized in the standard fashion for Tcl tests. # # Copyright (c) 1995 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -218,4 +217,20 @@ test place-8.2 {MasterStructureProc, mapping and unmapping slaves} { } {1 0 42 32 0 1} catch {destroy .t} -concat + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/raise.test b/tk/tests/raise.test index e315db69839..b0017ba99e5 100644 --- a/tk/tests/raise.test +++ b/tk/tests/raise.test @@ -5,22 +5,23 @@ # # Copyright (c) 1993-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + if {[info commands testmakeexist] == {}} { puts "This application hasn't been compiled with the \"testmakeexist\"" puts "command, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[string compare test [info procs test]] == 1} then \ - {source defs} - # Procedure to create a bunch of overlapping windows, which should # make it easy to detect differences in order. @@ -297,3 +298,20 @@ test raise-7.8 {errors in raise/lower commands} { foreach i [winfo child .] { destroy $i } + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/safe.test b/tk/tests/safe.test index 6b4cbee3b9f..508bf58e19a 100644 --- a/tk/tests/safe.test +++ b/tk/tests/safe.test @@ -3,14 +3,13 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -20,11 +19,11 @@ foreach i [winfo children .] { # The set of hidden commands is platform dependent: if {"$tcl_platform(platform)" == "macintosh"} { - set hidden_cmds {beep bell cd clipboard echo exit fconfigure file glob grab load ls menu open pwd selection socket source tk tk_chooseColor tk_getOpenFile tk_getSaveFile tk_messageBox toplevel wm} + set hidden_cmds {beep bell cd clipboard echo encoding exit fconfigure file glob grab load ls menu open pwd selection send socket source tk tk_chooseColor tk_chooseDirectory tk_getOpenFile tk_getSaveFile toplevel wm} } elseif {"$tcl_platform(platform)" == "windows"} { - set hidden_cmds {bell cd clipboard exec exit fconfigure file glob grab load menu open pwd selection socket source tk tk_chooseColor tk_getOpenFile tk_getSaveFile tk_messageBox toplevel wm} + set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection socket source tk tk_chooseColor tk_chooseDirectory tk_getOpenFile tk_getSaveFile tk_messageBox toplevel wm} } else { - set hidden_cmds {bell cd clipboard exec exit fconfigure file glob grab load menu open pwd selection send socket source tk tk_chooseColor tk_getOpenFile tk_getSaveFile tk_messageBox toplevel wm} + set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection send socket source tk toplevel wm} } test safe-1.1 {Safe Tk loading into an interpreter} { @@ -49,7 +48,7 @@ test safe-1.3 {Safe Tk loading into an interpreter} { set l [lsort [interp aliases a]] safe::interpDelete a set l -} {exit file load source} +} {encoding exit file load source} test safe-2.1 {Unsafe commands not available} { catch {safe::interpDelete a} @@ -102,9 +101,9 @@ test safe-4.1 {testing loadTk} { # eventually see a new toplevel set i [safe::loadTk [safe::interpCreate]] interp eval $i {button .b -text "hello world!"; pack .b} -# lets don't update because it might impy that the user has -# to position the window (if the wm does not do it automatically) -# and thus make the test suite not runable non interactively + # lets don't update because it might imply that the user has + # to position the window (if the wm does not do it automatically) + # and thus make the test suite not runable non interactively safe::interpDelete $i } {} @@ -166,4 +165,27 @@ test safe-6.2 {loadTk -use windowPath, conflicting -display} { } {conflicting -display :23.56 and -use } +test safe-7.1 {canvas printing} { + set i [safe::loadTk [safe::interpCreate]] + set r [catch {interp eval $i {canvas .c; .c postscript}}] + safe::interpDelete $i + set r +} 0 + +# cleanup unset hidden_cmds +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/scale.test b/tk/tests/scale.test index d4050f582e0..73d21846785 100644 --- a/tk/tests/scale.test +++ b/tk/tests/scale.test @@ -3,14 +3,13 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -56,19 +55,19 @@ foreach test { {-label "Some text" {Some text} {} {}} {-length 130 130 badValue {bad screen distance "badValue"}} {-orient horizontal horizontal badValue - {bad orientation "badValue": must be vertical or horizontal}} + {bad orient "badValue": must be horizontal or vertical}} {-orient horizontal horizontal {} {}} - {-relief ridge ridge badValue {bad relief type "badValue": must be flat, groove, raised, ridge, solid, or sunken}} + {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} {-repeatdelay 14 14 bogus {expected integer but got "bogus"}} {-repeatinterval 14 14 bogus {expected integer but got "bogus"}} {-resolution 2.0 2.0 badValue {expected floating-point number but got "badValue"}} {-showvalue 0 0 badValue {expected boolean value but got "badValue"}} {-sliderlength 86 86 badValue {bad screen distance "badValue"}} - {-sliderrelief raised raised badValue {bad relief type "badValue": must be flat, groove, raised, ridge, solid, or sunken}} - {-state disabled disabled badValue - {bad state value "badValue": must be normal, active, or disabled}} - {-state normal normal {} {}} + {-sliderrelief raised raised badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} + {-state d disabled badValue + {bad state "badValue": must be active, disabled, or normal}} + {-state n normal {} {}} {-takefocus "any string" "any string" {} {}} {-tickinterval 4.3 4.0 badValue {expected floating-point number but got "badValue"}} @@ -93,8 +92,8 @@ foreach test { .s configure $name [lindex [.s configure $name] 3] incr i } - destroy .s + test scale-2.1 {Tk_ScaleCmd procedure} { list [catch {scale} msg] $msg } {1 {wrong # args: should be "scale pathName ?options?"}} @@ -124,8 +123,8 @@ test scale-3.5 {ScaleWidgetCmd procedure, cget option} { .s cget -highlightthickness } {2} test scale-3.6 {ScaleWidgetCmd procedure, configure option} { - list [llength [.s configure]] [lindex [.s configure] 5] -} {33 {-borderwidth borderWidth BorderWidth 2 2}} + list [llength [.s configure]] [lindex [.s configure] 6] +} {33 {-command command Command {} {}}} test scale-3.7 {ScaleWidgetCmd procedure, configure option} { list [catch {.s configure -foo} msg] $msg } {1 {unknown option "-foo"}} @@ -212,10 +211,10 @@ test scale-3.29 {ScaleWidgetCmd procedure} { } {1 {bad option "dumb": must be cget, configure, coords, get, identify, or set}} test scale-3.30 {ScaleWidgetCmd procedure} { list [catch {.s c} msg] $msg -} {1 {bad option "c": must be cget, configure, coords, get, identify, or set}} +} {1 {ambiguous option "c": must be cget, configure, coords, get, identify, or set}} test scale-3.31 {ScaleWidgetCmd procedure} { list [catch {.s co} msg] $msg -} {1 {bad option "co": must be cget, configure, coords, get, identify, or set}} +} {1 {ambiguous option "co": must be cget, configure, coords, get, identify, or set}} test scale-3.32 {ScaleWidgetCmd procedure, Tk_Preserve} { proc kill args { destroy .s @@ -270,7 +269,7 @@ test scale-5.4 {ConfigureScale procedure} { catch {destroy .s} scale .s -from 0 -to 100 list [catch {.s configure -orient dumb} msg] $msg -} {1 {bad orientation "dumb": must be vertical or horizontal}} +} {1 {bad orient "dumb": must be horizontal or vertical}} test scale-5.5 {ConfigureScale procedure} { catch {destroy .s} scale .s -from 1.11 -to 1.89 -resolution .1 -tickinterval .76 @@ -288,7 +287,7 @@ test scale-5.6 {ConfigureScale procedure} { test scale-5.7 {ConfigureScale procedure} { catch {destroy .s} list [catch {scale .s -from 0 -to 100 -state bogus} msg] $msg -} {1 {bad state value "bogus": must be normal, active, or disabled}} +} {1 {bad state "bogus": must be active, disabled, or normal}} catch {destroy .s} scale .s -orient horizontal -length 200 @@ -360,7 +359,7 @@ test scale-6.13 {ComputeFormat procedure} { .s configure -from .000001 -to .00001 -resolution .000001 .s set .000006 expr {[.s get] == 6.0e-06} -} 1 +} {1} test scale-6.14 {ComputeFormat procedure} { .s configure -to .00001 -from .0001 -resolution .00001 .s set .00006 @@ -370,12 +369,12 @@ test scale-6.15 {ComputeFormat procedure} { .s configure -to .000001 -from .00001 -resolution .000001 .s set .000006 expr {[.s get] == 6.0e-06} -} 1 +} {1} test scale-6.16 {ComputeFormat procedure} { .s configure -from .00001 -to .0001 -resolution .00001 -digits 1 .s set .00006 expr {[.s get] == 6e-05} -} 1 +} {1} test scale-6.17 {ComputeFormat procedure} { .s configure -from 10000000 -to 100000000 -resolution 10000000 -digits 3 .s set 49300000 @@ -397,7 +396,7 @@ test scale-6.20 {ComputeFormat procedure} { .s get } {1001.235} -test scale-7.1 {ComputeScaleGeometry procedure} {fonts} { +test scale-7.1 {ComputeScaleGeometry procedure} {nonPortable fonts} { catch {destroy .s} scale .s -from 0 -to 10 -label "Short" -orient vertical -length 5i pack .s @@ -427,7 +426,7 @@ test scale-7.4 {ComputeScaleGeometry procedure} {fonts} { update list [winfo reqwidth .s] [winfo reqheight .s] } {39 114} -test scale-7.5 {ComputeScaleGeometry procedure} {fonts} { +test scale-7.5 {ComputeScaleGeometry procedure} {nonPortable fonts} { catch {destroy .s} scale .s -from 0 -to 10 -label "Short" -orient horizontal -length 5i pack .s @@ -797,5 +796,34 @@ test scale-16.1 {scale widget vs hidden commands} { list [winfo children .] [interp hidden] } [list {} $l] +test scale-17.1 {bug fix 1786} { + # Perhaps x is set to {}, depending on what other tests have run. + # If x is unset, or set to something not convertable to a double, + # then the scale try to initialize its value with the contents + # of uninitialized memory. Sometimes that causes an FPE. + + set x {} + scale .s -from 100 -to 300 + pack .s + update + .s configure -variable x ;# CRASH! -> Floating point exception + + # Bug 4833 changed the result to realize that x should pick up + # a value from the scale. In an FPE occurs, it is due to the + # lack of errno being set to 0 by some libc's. (see bug 4942) + set x +} {100} + +test scale-18.1 {DestroyScale, -cursor option [Bug: 3897]} { + catch {destroy .s} + scale .s -cursor trek + destroy .s +} {} + catch {destroy .s} option clear + +# cleanup +::tcltest::cleanupTests +return + diff --git a/tk/tests/scrollbar.test b/tk/tests/scrollbar.test index 43709c74ac1..025375fdf0d 100644 --- a/tk/tests/scrollbar.test +++ b/tk/tests/scrollbar.test @@ -4,14 +4,22 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +## testmetrics is a win/mac only test command +## +if {[string compare unix $tcl_platform(platform)] && \ + [string equal {} [info commands testmetrics]]} { + puts "\"testmetrics\" isn't defined, skipping scrollbar tests" + ::tcltest::cleanupTests + return } foreach i [winfo children .] { @@ -37,14 +45,14 @@ proc getTroughSize {w} { } else { if [string match v* [$w cget -orient]] { return [expr [winfo height $w] \ - - ([winfo width $w] \ - - [$w cget -highlightthickness] \ - - [$w cget -bd] + 1)*2] + - ([winfo width $w] \ + - [$w cget -highlightthickness] \ + - [$w cget -bd] + 1)*2] } else { return [expr [winfo width $w] \ - - ([winfo height $w] \ - - [$w cget -highlightthickness] \ - - [$w cget -bd] + 1)*2] + - ([winfo height $w] \ + - [$w cget -highlightthickness] \ + - [$w cget -bd] + 1)*2] } } } @@ -90,7 +98,7 @@ foreach test { {-repeatdelay 140 140 129.3 {expected integer but got "129.3"}} {-repeatinterval 140 140 129.3 {expected integer but got "129.3"}} {-takefocus "any string" "any string" {} {}} - {-trough #432 #432 lousy {unknown color name "lousy"}} + {-troughcolor #432 #432 lousy {unknown color name "lousy"}} {-width 32 32 badValue {bad screen distance "badValue"}} } { set name [lindex $test 0] @@ -170,16 +178,16 @@ test scrollbar-3.10 {ScrollbarWidgetCmd procedure, "cget" option} { list [catch {.s cget -orient} msg] $msg } {0 vertical} scrollbar .s2 -test scrollbar-3.11 {ScrollbarWidgetCmd procedure, "cget" option} {pc} { +test scrollbar-3.11 {ScrollbarWidgetCmd procedure, "cget" option} {pcOnly} { list [catch {.s2 cget -bd} msg] $msg } {0 0} -test scrollbar-3.12 {ScrollbarWidgetCmd procedure, "cget" option} {!pc} { +test scrollbar-3.12 {ScrollbarWidgetCmd procedure, "cget" option} {macOrUnix} { list [catch {.s2 cget -bd} msg] $msg } {0 2} -test scrollbar-3.13 {ScrollbarWidgetCmd procedure, "cget" option} {pc} { +test scrollbar-3.13 {ScrollbarWidgetCmd procedure, "cget" option} {pcOnly} { list [catch {.s2 cget -highlightthickness} msg] $msg } {0 0} -test scrollbar-3.14 {ScrollbarWidgetCmd procedure, "cget" option} {!pc} { +test scrollbar-3.14 {ScrollbarWidgetCmd procedure, "cget" option} {macOrUnix} { list [catch {.s2 cget -highlightthickness} msg] $msg } {0 1} destroy .s2 @@ -626,6 +634,7 @@ test scrollbar-8.1 {TkScrollbarEventProc: recursive deletion} { 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 <ButtonRelease> -button 1 update lappend result [winfo exists .t.f.s] [winfo exists .t.f] rename bgerror {} @@ -643,6 +652,7 @@ test scrollbar-8.2 {TkScrollbarEventProc: recursive deletion} { 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 <ButtonRelease> -button 1 update lappend result [winfo exists .t.f.s] [winfo exists .t.f] rename bgerror {} @@ -662,4 +672,20 @@ test scrollbar-9.1 {scrollbar widget vs hidden commands} { catch {destroy .s} catch {destroy .t} -concat {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/select.test b/tk/tests/select.test index 1ebaad629bc..1ea604c9d76 100644 --- a/tk/tests/select.test +++ b/tk/tests/select.test @@ -3,9 +3,8 @@ # fashion for Tcl tests. # # Copyright (c) 1994 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ @@ -14,8 +13,8 @@ # environment variable TK_ALT_DISPLAY is set to an alternate display. # -if {[string compare test [info procs test]] == 1} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } eval destroy [winfo child .] @@ -449,10 +448,10 @@ test select-5.10 {Tk_GetSelection procedure} {unixOnly} { set selInfo "" selection own .f1 set result "" - fileevent $fd readable {} - puts $fd {catch {selection get TEST} msg; update; puts $msg; flush stdout} - flush $fd - lappend result [gets $fd] + fileevent $::tcltest::fd readable {} + puts $::tcltest::fd {catch {selection get TEST} msg; update; puts $msg; flush stdout} + flush $::tcltest::fd + lappend result [gets $::tcltest::fd] cleanupbg lappend result $selInfo } {{selection owner didn't respond} {}} @@ -814,14 +813,14 @@ test select-10.1 {ConvertSelection procedure, race with selection clear} {unixOn set selInfo "" selection handle .f1 {handler STRING} update - puts $fd {puts "[catch {selection get} msg] $msg"; puts **DONE**; flush stdout} - flush $fd + puts $::tcltest::fd {puts "[catch {selection get} msg] $msg"; puts **DONE**; flush stdout} + flush $::tcltest::fd after 200 selection own . - set bgData {} - tkwait variable bgDone + set ::tcltest::bgData {} + tkwait variable ::tcltest::bgDone cleanupbg - list $bgData $selInfo + list $::tcltest::bgData $selInfo } {{1 PRIMARY selection doesn't exist or form "STRING" not defined} {}} test select-10.2 {ConvertSelection procedure} {unixOnly} { setup @@ -844,7 +843,8 @@ test select-10.3 {ConvertSelection procedure} {unixOnly} { set result } {{PRIMARY selection doesn't exist or form "ERROR" not defined}} # testing timers -test select-10.4 {ConvertSelection procedure} {unixOnly} { +# This one hangs in Exceed +test select-10.4 {ConvertSelection procedure} {unixOnly noExceed} { setup setupbg set selValue $longValue @@ -984,4 +984,20 @@ test select-13.1 {SelectionSize procedure, handler deleted} {unixOnly} { } {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000 .f1 STRING 4000 4000}} catch {rename weirdHandler {}} -concat + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/send.test b/tk/tests/send.test index 427cd972d86..30a7940469b 100644 --- a/tk/tests/send.test +++ b/tk/tests/send.test @@ -4,28 +4,31 @@ # # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1994-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + if {$tcl_platform(platform) == "macintosh"} { puts "send is not available on the Mac - skipping tests" + ::tcltest::cleanupTests return } if {$tcl_platform(platform) == "window"} { puts "send is not available under Windows - skipping tests" + ::tcltest::cleanupTests return } if {[auto_execok xhost] == ""} { puts "xhost application isn't available - skipping tests" + ::tcltest::cleanupTests return } -if {[info procs test] != "test"} { - source defs -} if {[info commands testsend] == "testsend"} { set gotTestCmds 1 } else { @@ -48,6 +51,7 @@ if {[catch {send $app set a 0} msg] == 1} { puts -nonewline "Your X server is insecure, so \"send\" can't be used;" puts " skipping \"send\" tests." cleanupbg + ::tcltest::cleanupTests return } } @@ -325,6 +329,8 @@ if $gotTestCmds { while executing "open bogus_file_name" invoked from within +"if 1 {open bogus_file_name}" + invoked from within "send t_s_1 {if 1 {open bogus_file_name}}"} {POSIX ENOENT {no such file or directory}}} test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} { testsend prop root InterpRegistry "10234 bogus\n" @@ -546,7 +552,7 @@ r setupbg dobg {tk appname t_s_3} set x [list [catch {send t_s_3 exit} msg] $msg] - close $fd + close $::tcltest::fd set x } {1 {target application died}} @@ -577,15 +583,15 @@ test send-12.2 {TimeoutProc procedure} { tk appname tktest update setupbg - puts $fd {after 10 {after 5000; exit}; puts [tk appname]; puts **DONE**; flush stdout} - set bgDone 0 - set bgData {} - flush $fd - tkwait variable bgDone - set app $bgData + puts $::tcltest::fd {after 10 {after 5000; exit}; puts [tk appname]; puts **DONE**; flush stdout} + set ::tcltest::bgDone 0 + set ::tcltest::bgData {} + flush $::tcltest::fd + tkwait variable ::tcltest::bgDone + set app $::tcltest::bgData after 200 set result [list [catch {send $app foo} msg] $msg] - close $fd + close $::tcltest::fd set result } {1 {target application died}} @@ -654,3 +660,20 @@ if $gotTestCmds { testdeleteapps } rename newApp {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/text.test b/tk/tests/text.test index 533fd4e9ad3..e002c7e43b5 100644 --- a/tk/tests/text.test +++ b/tk/tests/text.test @@ -3,14 +3,14 @@ # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} then \ - {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} eval destroy [winfo child .] @@ -81,10 +81,10 @@ foreach test { {-spacing2 -1 0 bogus} {-spacing3 20 20 bogus} {-spacing3 -10 0 bogus} - {-state disabled disabled foo} + {-state d disabled foo} {-tabs {1i 2i 3i 4i} {1i 2i 3i 4i} bad_tabs} {-width 73 73 2.4} - {-wrap word word bad_wrap} + {-wrap w word bad_wrap} } { test text-1.[incr i] {text options} { set result {} @@ -150,7 +150,7 @@ test text-3.1 {TextWidgetCmd procedure, basics} { } {1 {wrong # args: should be ".t option ?arg arg ...?"}} test text-3.2 {TextWidgetCmd procedure} { list [catch {.t gorp 1.0 z 1.2} msg] $msg -} {1 {bad option "gorp": must be bbox, cget, compare, configure, debug, delete, dlineinfo, get, image, index, insert, mark, scan, search, see, tag, window, xview, or yview}} +} {1 {bad option "gorp": must be bbox, cget, compare, configure, debug, delete, dlineinfo, dump, get, image, index, insert, mark, scan, search, see, tag, window, xview, or yview}} test text-4.1 {TextWidgetCmd procedure, "bbox" option} { list [catch {.t bbox} msg] $msg @@ -218,7 +218,7 @@ test text-6.13 {TextWidgetCmd procedure, "compare" option} { } {1 {bad comparison operator "z": must be <, <=, ==, >=, >, or !=}} test text-6.14 {TextWidgetCmd procedure, "compare" option} { list [catch {.t co 1.0 z 1.2} msg] $msg -} {1 {bad option "co": must be bbox, cget, compare, configure, debug, delete, dlineinfo, get, image, index, insert, mark, scan, search, see, tag, window, xview, or yview}} +} {1 {bad option "co": must be bbox, cget, compare, configure, debug, delete, dlineinfo, dump, get, image, index, insert, mark, scan, search, see, tag, window, xview, or yview}} # "configure" option is already covered above @@ -227,7 +227,7 @@ test text-7.1 {TextWidgetCmd procedure, "debug" option} { } {1 {wrong # args: should be ".t debug boolean"}} test text-7.2 {TextWidgetCmd procedure, "debug" option} { list [catch {.t de 0 1} msg] $msg -} {1 {bad option "de": must be bbox, cget, compare, configure, debug, delete, dlineinfo, get, image, index, insert, mark, scan, search, see, tag, window, xview, or yview}} +} {1 {bad option "de": must be bbox, cget, compare, configure, debug, delete, dlineinfo, dump, get, image, index, insert, mark, scan, search, see, tag, window, xview, or yview}} test text-7.3 {TextWidgetCmd procedure, "debug" option} { .t debug true .t deb @@ -310,7 +310,7 @@ test text-10.2 {TextWidgetCmd procedure, "index" option} { } {1 {wrong # args: should be ".t index index"}} test text-10.3 {TextWidgetCmd procedure, "index" option} { list [catch {.t in a b} msg] $msg -} {1 {bad option "in": must be bbox, cget, compare, configure, debug, delete, dlineinfo, get, image, index, insert, mark, scan, search, see, tag, window, xview, or yview}} +} {1 {bad option "in": must be bbox, cget, compare, configure, debug, delete, dlineinfo, dump, get, image, index, insert, mark, scan, search, see, tag, window, xview, or yview}} test text-10.4 {TextWidgetCmd procedure, "index" option} { list [catch {.t index @xyz} msg] $msg } {1 {bad text index "@xyz"}} @@ -854,7 +854,7 @@ test text-19.3 {TkTextLostSelection procedure} { .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" test text-20.1 {TextSearchCmd procedure, argument parsing} { list [catch {.t search -} msg] $msg -} {1 {bad switch "-": must be -forward, -backward, -exact, -regexp, -nocase, -count, or --}} +} {1 {bad switch "-": must be --, -backward, -count, -elide, -exact, -forward, -nocase, or -regexp}} test text-20.2 {TextSearchCmd procedure, -backwards option} { .t search -backwards xyz 1.4 } {1.1} @@ -885,10 +885,10 @@ test text-20.10 {TextSearchCmd procedure, -- option} { } {2.4} test text-20.11 {TextSearchCmd procedure, argument parsing} { list [catch {.t search abc} msg] $msg -} {1 {wrong # args: should be ".t search ?switches? pattern index ?stopIndex?}} +} {1 {wrong # args: should be ".t search ?switches? pattern index ?stopIndex?"}} test text-20.12 {TextSearchCmd procedure, argument parsing} { list [catch {.t search abc d e f} msg] $msg -} {1 {wrong # args: should be ".t search ?switches? pattern index ?stopIndex?}} +} {1 {wrong # args: should be ".t search ?switches? pattern index ?stopIndex?"}} test text-20.13 {TextSearchCmd procedure, check index} { list [catch {.t search abc gorp} msg] $msg } {1 {bad text index "gorp"}} @@ -906,7 +906,7 @@ test text-20.17 {TextSearchCmd procedure, pattern case conversion} { } {2.13 {}} test text-20.18 {TextSearchCmd procedure, bad regular expression pattern} { list [catch {.t search -regexp a( 1.0} msg] $msg -} {1 {couldn't compile regular expression pattern: unmatched ()}} +} {1 {couldn't compile regular expression pattern: parentheses () not balanced}} test text-20.19 {TextSearchCmd procedure, skip dummy last line} { .t search -backwards BaR end 1.0 } {2.23} @@ -961,6 +961,13 @@ test text-20.34 {TextSearchCmd procedure, firstChar and lastChar} { test text-20.35 {TextSearchCmd procedure, firstChar and lastChar} { .t search {} end } {1.0} +test text-20.36 {TextSearchCmd procedure, regexp finds empty lines} { + # Test for fix of bug #1643 + .t insert end "\n" + tkTextSetCursor .t 4.0 + .t search -forward -regexp {^$} insert end +} {4.0} + catch {destroy .t2} toplevel .t2 wm geometry .t2 +0+0 @@ -1082,7 +1089,81 @@ test text-20.62 {TextSearchCmd, freeing copy of pattern} { set p $p$p$p$p$p .t search -nocase $p 1.0 } {} +test text-20.63 {TextSearchCmd, unicode} { + .t delete 1.0 end + .t insert end "foo\u30c9\u30cabar" + .t search \u30c9\u30ca 1.0 +} 1.3 +test text-20.64 {TextSearchCmd, unicode} { + .t delete 1.0 end + .t insert end "foo\u30c9\u30cabar" + list [.t search -count n \u30c9\u30ca 1.0] $n +} {1.3 2} +test text-20.65 {TextSearchCmd, unicode with non-text segments} { + .t delete 1.0 end + button .b1 -text baz + .t insert end "foo\u30c9" + .t window create end -window .b1 + .t insert end "\u30cabar" + set result [list [.t search -count n \u30c9\u30ca 1.0] $n] + destroy .b1 + set result +} {1.3 3} + +test text-20.66 {TextSearchCmd, hidden text does not affect match index} { + eval destroy [winfo child .] + pack [text .t2] + .t2 insert end "12345H7890" + .t2 search 7 1.0 +} 1.6 +test text-20.67 {TextSearchCmd, hidden text does not affect match index} { + eval destroy [winfo child .] + pack [text .t2] + .t2 insert end "12345H7890" + .t2 tag configure hidden -elide true + .t2 tag add hidden 1.5 + .t2 search 7 1.0 +} 1.6 +test text-20.68 {TextSearchCmd, hidden text does not affect match index} { + eval destroy [winfo child .] + pack [text .t2] + .t2 insert end "foobar\nbarbaz\nbazboo" + .t2 search boo 1.0 +} 3.3 +test text-20.69 {TextSearchCmd, hidden text does not affect match index} { + eval destroy [winfo child .] + pack [text .t2] + .t2 insert end "foobar\nbarbaz\nbazboo" + .t2 tag configure hidden -elide true + .t2 tag add hidden 2.0 3.0 + .t2 search boo 1.0 +} 3.3 +test text-20.70 {TextSearchCmd, -regexp -nocase searches} { + catch {destroy .t} + pack [text .t] + .t insert end "word1 word2" + set res [.t search -nocase -regexp {\mword.} 1.0 end] + destroy .t + set res +} 1.0 +test text-20.71 {TextSearchCmd, -regexp -nocase searches} { + catch {destroy .t} + pack [text .t] + .t insert end "word1 word2" + set res [.t search -nocase -regexp {word.\M} 1.0 end] + destroy .t + set res +} 1.0 +test text-20.72 {TextSearchCmd, -regexp -nocase searches} { + catch {destroy .t} + pack [text .t] + .t insert end "word1 word2" + set res [.t search -nocase -regexp {word.\W} 1.0 end] + destroy .t + set res +} 1.0 + eval destroy [winfo child .] text .t2 -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100 pack .t2 @@ -1246,6 +1327,20 @@ test text-22.24 {TextDumpCmd procedure, command script} { set x } {mark 1.0 current mark 1.0 insert mark 2.4 m} catch {unset x} +test text-22.25 {TextDumpCmd procedure, unicode characters} { + catch {destroy .t} + text .t + .t delete 1.0 end + .t insert 1.0 \xb1\xb1\xb1 + .t dump -all 1.0 2.0 +} "text \xb1\xb1\xb1 1.0 mark insert 1.3 mark current 1.3 text {\n} 1.3" +test text-22.26 {TextDumpCmd procedure, unicode characters} { + catch {destroy .t} + text .t + .t delete 1.0 end + .t insert 1.0 abc\xb1\xb1\xb1 + .t dump -all 1.0 2.0 +} "text abc\xb1\xb1\xb1 1.0 mark insert 1.6 mark current 1.6 text {\n} 1.6" set l [interp hidden] eval destroy [winfo children .] @@ -1258,5 +1353,36 @@ test text-23.1 {text widget vs hidden commands} { list [winfo children .] [interp hidden] } [list {} $l] +test text-24.1 {bug fix - 1642} { + catch {destroy .t} + text .t + pack .t + .t insert end "line 1\n" + .t insert end "line 2\n" + .t insert end "line 3\n" + .t insert end "line 4\n" + .t insert end "line 5\n" + tkTextSetCursor .t 3.0 + .t search -backward -regexp "\$" insert 1.0 +} {2.6} + eval destroy [winfo child .] option clear + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + + diff --git a/tk/tests/textBTree.test b/tk/tests/textBTree.test index 415ed5c3b9f..a59960d555b 100644 --- a/tk/tests/textBTree.test +++ b/tk/tests/textBTree.test @@ -5,14 +5,14 @@ # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} then \ - {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {destroy .t} text .t @@ -893,5 +893,21 @@ test btree-18.9 {tag search back, large complex btree spans} { list [.t tag prev x end] [.t tag prev x 433.0] } {{500.0 520.0} {200.0 220.0}} - destroy .t + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/textDisp.test b/tk/tests/textDisp.test index d6b460f46a3..95d3e90ff29 100644 --- a/tk/tests/textDisp.test +++ b/tk/tests/textDisp.test @@ -3,17 +3,16 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} { - source defs - if {$testConfig(fonts) == 0} { - puts "skipping font-sensitive tests" - } +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} +if {$::tcltest::testConfig(fonts) == 0} { + puts "skipping font-sensitive tests" } # The procedure below is used as the scrolling command for the text; @@ -1794,10 +1793,10 @@ foreach i {a b c d e f g h i j k l m n o p q r s t u v w x y z} { .t configure -wrap none test textDisp-17.1 {TkTextScanCmd procedure} { list [catch {.t scan a b} msg] $msg -} {1 {wrong # args: should be ".t scan mark|dragto x y"}} +} {1 {wrong # args: should be ".t scan mark x y" or ".t scan dragto x y ?gain?"}} test textDisp-17.2 {TkTextScanCmd procedure} { list [catch {.t scan a b c d} msg] $msg -} {1 {wrong # args: should be ".t scan mark|dragto x y"}} +} {1 {expected integer but got "b"}} test textDisp-17.3 {TkTextScanCmd procedure} { list [catch {.t scan stupid b 20} msg] $msg } {1 {expected integer but got "b"}} @@ -2866,3 +2865,20 @@ foreach i [winfo children .] { catch {destroy $i} } option clear + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/textImage.test b/tk/tests/textImage.test index 4734711a55c..7bc8e4b3557 100644 --- a/tk/tests/textImage.test +++ b/tk/tests/textImage.test @@ -1,7 +1,17 @@ +# textImage.test -- test images embedded in text widgets +# +# This file contains a collection of tests for one or more of the Tcl +# 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. +# All rights reserved. +# # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} then \ - {source ../tests/defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # Test Arguments: # name - Name of test, in the form foo-1.2. @@ -9,7 +19,7 @@ if {[string compare test [info procs test]] == 1} then \ # help humans understand what it does. # constraints - A list of one or more keywords, each of # which must be the name of an element in -# the array "testConfig". If any of these +# the array "::tcltest::testConfig". If any of these # elements is zero, the test is skipped. # This argument may be omitted. # script - Script to run to carry out the test. It must @@ -351,3 +361,20 @@ test textImage-4.3 {alignment and padding checking} {fonts} { catch {destroy .t} foreach image [image names] {image delete $image} font delete test_font + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/textIndex.test b/tk/tests/textIndex.test index dce76a1b50d..67b9ba816c1 100644 --- a/tk/tests/textIndex.test +++ b/tk/tests/textIndex.test @@ -3,21 +3,22 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} then \ - {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +# Some tests require the testtext command + +set ::tcltest::testConfig(testtext) \ + [expr {[info commands testtext] != {}}] catch {destroy .t} -if [catch {text .t -font {Courier 12} -width 20 -height 10}] { - puts "The font needed by these tests isn't available, so I'm" - puts "going to skip the tests." - return -} +text .t -font {Courier -12} -width 20 -height 10 pack append . .t {top expand fill} update .t debug on @@ -35,73 +36,181 @@ wm deiconify . abcdefghijklm 12345 Line 4 -bOy GIrl .#@? x_yz +b\u4e4fy GIrl .#@? x_yz !@#$% Line 7" -test textIndex-1.1 {TkTextMakeIndex} { +image create photo textimage -width 10 -height 10 +textimage put red -to 0 0 9 9 + +test textIndex-1.1 {TkTextMakeByteIndex} {testtext} { + # (lineIndex < 0) + testtext .t byteindex -1 3 +} {1.0 0} +test textIndex-1.2 {TkTextMakeByteIndex} {testtext} { + # (lineIndex < 0), because lineIndex == strtol(argv[2]) - 1 + testtext .t byteindex 0 3 +} {1.0 0} +test textIndex-1.3 {TkTextMakeByteIndex} {testtext} { + # not (lineIndex < 0) + testtext .t byteindex 1 3 +} {1.3 3} +test textIndex-1.4 {TkTextMakeByteIndex} {testtext} { + # (byteIndex < 0) + testtext .t byteindex 3 -1 +} {3.0 0} +test textIndex-1.5 {TkTextMakeByteIndex} {testtext} { + # not (byteIndex < 0) + testtext .t byteindex 3 3 +} {3.3 3} +test textIndex-1.6 {TkTextMakeByteIndex} {testtext} { + # (indexPtr->linePtr == NULL) + testtext .t byteindex 9 2 +} {8.0 0} +test textIndex-1.7 {TkTextMakeByteIndex} {testtext} { + # not (indexPtr->linePtr == NULL) + testtext .t byteindex 7 2 +} {7.2 2} +test textIndex-1.8 {TkTextMakeByteIndex: shortcut for 0} {testtext} { + # (byteIndex == 0) + testtext .t byteindex 1 0 +} {1.0 0} +test textIndex-1.9 {TkTextMakeByteIndex: shortcut for 0} {testtext} { + # not (byteIndex == 0) + testtext .t byteindex 3 80 +} {3.5 5} +test textIndex-1.10 {TkTextMakeByteIndex: verify index is in range} {testtext} { + # for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) + # one segment + + testtext .t byteindex 3 5 +} {3.5 5} +test textIndex-1.11 {TkTextMakeByteIndex: verify index is in range} {testtext} { + # for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) + # index += segPtr->size + # Multiple segments, make sure add segment size to index. + + .t mark set foo 3.2 + set x [testtext .t byteindex 3 7] + .t mark unset foo + set x +} {3.5 5} +test textIndex-1.12 {TkTextMakeByteIndex: verify index is in range} {testtext} { + # (segPtr == NULL) + testtext .t byteindex 3 7 +} {3.5 5} +test textIndex-1.13 {TkTextMakeByteIndex: verify index is in range} {testtext} { + # not (segPtr == NULL) + testtext .t byteindex 3 4 +} {3.4 4} +test textIndex-1.14 {TkTextMakeByteIndex: verify index is in range} {testtext} { + # (index + segPtr->size > byteIndex) + # in this segment. + + testtext .t byteindex 3 4 +} {3.4 4} +test textIndex-1.15 {TkTextMakeByteIndex: verify index is in range} {testtext} { + # (index + segPtr->size > byteIndex), index != 0 + # in this segment. + + .t mark set foo 3.2 + set x [testtext .t byteindex 3 4] + .t mark unset foo + set x +} {3.4 4} +test textIndex-1.16 {TkTextMakeByteIndex: UTF-8 characters} {testtext} { + testtext .t byteindex 5 100 +} {5.18 20} +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). + + set x [testtext .t byteindex 5 2] + list $x [.t get insert] +} {{5.2 4} y} +test textIndex-1.18 {TkTextMakeByteIndex: prevent splitting UTF-8 character} \ + {testtext} { + # ((byteIndex > index) && (segPtr->typePtr == &tkTextCharType)) + testtext .t byteindex 5 1 + .t get insert +} "\u4e4f" + +test textIndex-2.1 {TkTextMakeCharIndex} { + # (lineIndex < 0) .t index -1.3 } 1.0 -test textIndex-1.2 {TkTextMakeIndex} { +test textIndex-2.2 {TkTextMakeCharIndex} { + # (lineIndex < 0), because lineIndex == strtol(argv[2]) - 1 .t index 0.3 } 1.0 -test textIndex-1.3 {TkTextMakeIndex} { +test textIndex-2.3 {TkTextMakeCharIndex} { + # not (lineIndex < 0) .t index 1.3 } 1.3 -test textIndex-1.4 {TkTextMakeIndex} { +test textIndex-2.4 {TkTextMakeCharIndex} { + # (charIndex < 0) .t index 3.-1 } 3.0 -test textIndex-1.5 {TkTextMakeIndex} { +test textIndex-2.5 {TkTextMakeCharIndex} { + # (charIndex < 0) .t index 3.3 } 3.3 -test textIndex-1.6 {TkTextMakeIndex} { +test textIndex-2.6 {TkTextMakeCharIndex} { + # (indexPtr->linePtr == NULL) + .t index 9.2 +} 8.0 +test textIndex-2.7 {TkTextMakeCharIndex} { + # not (indexPtr->linePtr == NULL) + .t index 7.2 +} 7.2 +test textIndex-2.8 {TkTextMakeCharIndex: verify index is in range} { + # for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) + # one segment + .t index 3.5 } 3.5 -test textIndex-1.7 {TkTextMakeIndex} { - .t index 3.6 +test textIndex-2.9 {TkTextMakeCharIndex: verify index is in range} { + # for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) + # Multiple segments, make sure add segment size to index. + + .t mark set foo 3.2 + set x [.t index 3.7] + .t mark unset foo + set x } 3.5 -test textIndex-1.8 {TkTextMakeIndex} { +test textIndex-2.10 {TkTextMakeCharIndex: verify index is in range} { + # (segPtr == NULL) .t index 3.7 } 3.5 -test textIndex-1.9 {TkTextMakeIndex} { - .t index 7.2 -} 7.2 -test textIndex-1.10 {TkTextMakeIndex} { - .t index 8.0 -} 8.0 -test textIndex-1.11 {TkTextMakeIndex} { - .t index 8.1 -} 8.0 -test textIndex-1.12 {TkTextMakeIndex} { - .t index 9.0 -} 8.0 +test textIndex-2.11 {TkTextMakeCharIndex: verify index is in range} { + # not (segPtr == NULL) + .t index 3.4 +} 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). + + .t mark set insert 5.2 + .t get insert +} y +test textIndex-2.13 {TkTextMakeCharIndex: verify index is in range} { + # not (segPtr->typePtr == &tkTextCharType) + + .t image create 5.2 -image textimage + .t mark set insert 5.5 + set x [.t get insert] + .t delete 5.2 + set x +} "G" +test textIndex-2.14 {TkTextMakeCharIndex: verify index is in range} { + # (charIndex < segPtr->size) -.t tag add x 2.3 2.6 -test textIndex-2.1 {TkTextIndexToSeg} { - .t get 2.0 -} a -test textIndex-2.2 {TkTextIndexToSeg} { - .t get 2.2 -} c -test textIndex-2.3 {TkTextIndexToSeg} { - .t get 2.3 -} d -test textIndex-2.4 {TkTextIndexToSeg} { - .t get 2.6 -} g -test textIndex-2.5 {TkTextIndexToSeg} { - .t get 2.7 -} h -test textIndex-2.6 {TkTextIndexToSeg} { - .t get 2.12 -} m -test textIndex-2.7 {TkTextIndexToSeg} { - .t get 2.13 -} \n -test textIndex-2.8 {TkTextIndexToSeg} { - .t get 2.14 -} \n -.t tag delete x + .t image create 5.0 -image textimage + set x [.t index 5.0] + .t delete 5.0 + set x +} 5.0 .t mark set foo 3.2 .t tag add x 2.8 2.11 @@ -143,7 +252,7 @@ test textIndex-4.8 {TkTextGetIndex, tags} { set result } {1.0 1.1} -test textIndex-5.1 {TkTextGetIndex, "@"} {fonts} { +test textIndex-5.1 {TkTextGetIndex, "@"} {nonPortable fonts} { .t index @12,9 } 1.1 test textIndex-5.2 {TkTextGetIndex, "@"} {fonts} { @@ -242,8 +351,8 @@ test textIndex-10.4 {ForwBack} { list [catch {.t index {2.3 - 3ch}} msg] $msg } {0 2.0} test textIndex-10.5 {ForwBack} { - list [catch {.t index {2.3 + 3 lines}} msg] $msg -} {0 5.3} + list [catch {.t index {1.3 + 3 lines}} msg] $msg +} {0 4.3} test textIndex-10.6 {ForwBack} { list [catch {.t index {2.3 -1l}} msg] $msg } {0 1.3} @@ -253,97 +362,325 @@ test textIndex-10.7 {ForwBack} { test textIndex-10.8 {ForwBack} { list [catch {.t index {2.3 - 4 lines}} msg] $msg } {0 1.3} +test textIndex-10.9 {ForwBack} { + .t mark set insert 2.0 + list [catch {.t index {insert -0 chars}} msg] $msg +} {0 2.0} +test textIndex-10.10 {ForwBack} { + .t mark set insert 2.end + list [catch {.t index {insert +0 chars}} msg] $msg +} {0 2.13} -test textIndex-11.1 {TkTextIndexForwChars} { +test textIndex-11.1 {TkTextIndexForwBytes} {testtext} { + testtext .t forwbytes 2.3 -7 +} {1.3 3} +test textIndex-11.2 {TkTextIndexForwBytes} {testtext} { + testtext .t forwbytes 2.3 5 +} {2.8 8} +test textIndex-11.3 {TkTextIndexForwBytes} {testtext} { + testtext .t forwbytes 2.3 10 +} {2.13 13} +test textIndex-11.4 {TkTextIndexForwBytes} {testtext} { + testtext .t forwbytes 2.3 11 +} {3.0 0} +test textIndex-11.5 {TkTextIndexForwBytes} {testtext} { + testtext .t forwbytes 2.3 57 +} {7.6 6} +test textIndex-11.6 {TkTextIndexForwBytes} {testtext} { + testtext .t forwbytes 2.3 58 +} {8.0 0} +test textIndex-11.7 {TkTextIndexForwBytes} {testtext} { + testtext .t forwbytes 2.3 59 +} {8.0 0} + +test textIndex-12.1 {TkTextIndexForwChars} { + # (charCount < 0) .t index {2.3 + -7 chars} } 1.3 -test textIndex-11.2 {TkTextIndexForwChars} { +test textIndex-12.2 {TkTextIndexForwChars} { + # not (charCount < 0) .t index {2.3 + 5 chars} } 2.8 -test textIndex-11.3 {TkTextIndexForwChars} { +test textIndex-12.3 {TkTextIndexForwChars: find index} { + # for ( ; segPtr != NULL; segPtr = segPtr->nextPtr) + # one loop + .t index {2.3 + 9 chars} +} 2.12 +test textIndex-12.4 {TkTextIndexForwChars: find index} { + # for ( ; segPtr != NULL; segPtr = segPtr->nextPtr) + # multiple loops + .t mark set foo 2.5 + set x [.t index {2.3 + 9 chars}] + .t mark unset foo + set x +} 2.12 +test textIndex-12.5 {TkTextIndexForwChars: find index} { + # for ( ; segPtr != NULL; segPtr = segPtr->nextPtr) + # border condition: last char + .t index {2.3 + 10 chars} } 2.13 -test textIndex-11.4 {TkTextIndexForwChars} { +test textIndex-12.6 {TkTextIndexForwChars: find index} { + # for ( ; segPtr != NULL; segPtr = segPtr->nextPtr) + # border condition: segPtr == NULL -> beginning of next line + .t index {2.3 + 11 chars} } 3.0 -test textIndex-11.5 {TkTextIndexForwChars} { - .t index {2.3 + 55 chars} -} 7.6 -test textIndex-11.6 {TkTextIndexForwChars} { +test textIndex-12.7 {TkTextIndexForwChars: find index} { + # (segPtr->typePtr == &tkTextCharType) + .t index {2.3 + 2 chars} +} 2.5 +test textIndex-12.8 {TkTextIndexForwChars: find index} { + # (charCount == 0) + # No more chars, so we found byte offset. + + .t index {2.3 + 2 chars} +} 2.5 +test textIndex-12.9 {TkTextIndexForwChars: find index} { + # not (segPtr->typePtr == &tkTextCharType) + + .t image create 2.4 -image textimage + set x [.t get {2.3 + 3 chars}] + .t delete 2.4 + set x +} "f" +test textIndex-12.10 {TkTextIndexForwChars: find index} { + # dstPtr->byteIndex += segPtr->size - byteOffset + # When moving to next segment, account for bytes in last segment. + # Wrong answer would be 2.4 + + .t mark set foo 2.4 + set x [.t index {2.3 + 5 chars}] + .t mark unset foo + set x +} 2.8 +test textIndex-12.11 {TkTextIndexForwChars: go to next line} { + # (linePtr == NULL) + .t index {7.6 + 3 chars} +} 8.0 +test textIndex-12.12 {TkTextIndexForwChars: go to next line} { + # Reset byteIndex to 0 now that we are on a new line. + # Wrong answer would be 2.9 + .t index {1.3 + 6 chars} +} 2.2 +test textIndex-12.13 {TkTextIndexForwChars} { + # right to end .t index {2.3 + 56 chars} } 8.0 -test textIndex-11.7 {TkTextIndexForwChars} { +test textIndex-12.14 {TkTextIndexForwChars} { + # try to go past end .t index {2.3 + 57 chars} } 8.0 -test textIndex-12.1 {TkTextIndexBackChars} { +test textIndex-13.1 {TkTextIndexBackBytes} {testtext} { + testtext .t backbytes 3.2 -10 +} {4.6 6} +test textIndex-13.2 {TkTextIndexBackBytes} {testtext} { + testtext .t backbytes 3.2 2 +} {3.0 0} +test textIndex-13.3 {TkTextIndexBackBytes} {testtext} { + testtext .t backbytes 3.2 3 +} {2.13 13} +test textIndex-13.4 {TkTextIndexBackBytes} {testtext} { + testtext .t backbytes 3.2 22 +} {1.1 1} +test textIndex-13.5 {TkTextIndexBackBytes} {testtext} { + testtext .t backbytes 3.2 23 +} {1.0 0} +test textIndex-13.6 {TkTextIndexBackBytes} {testtext} { + testtext .t backbytes 3.2 24 +} {1.0 0} + +test textIndex-14.1 {TkTextIndexBackChars} { + # (charCount < 0) .t index {3.2 - -10 chars} } 4.6 -test textIndex-12.2 {TkTextIndexBackChars} { +test textIndex-14.2 {TkTextIndexBackChars} { + # not (charCount < 0) .t index {3.2 - 2 chars} } 3.0 -test textIndex-12.3 {TkTextIndexBackChars} { +test textIndex-14.3 {TkTextIndexBackChars: find starting segment} { + # for (segPtr = dstPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) + # single loop + .t index {3.2 - 3 chars} } 2.13 -test textIndex-12.4 {TkTextIndexBackChars} { +test textIndex-14.4 {TkTextIndexBackChars: find starting segment} { + # for (segPtr = dstPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) + # multiple loop + + .t mark set foo1 2.5 + .t mark set foo2 2.7 + .t mark set foo3 2.10 + set x [.t index {2.9 - 1 chars}] + .t mark unset foo1 foo2 foo3 + set x +} 2.8 +test textIndex-14.5 {TkTextIndexBackChars: find starting seg and offset} { + # for (segPtr = dstPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) + # Make sure segSize was decremented. Wrong answer would be 2.10 + + .t mark set foo 2.2 + set x [.t index {2.9 - 1 char}] + .t mark unset foo + set x +} 2.8 +test textIndex-14.6 {TkTextIndexBackChars: back over characters} { + # (segPtr->typePtr == &tkTextCharType) + .t index {3.2 - 22 chars} } 1.1 -test textIndex-12.5 {TkTextIndexBackChars} { - .t index {3.2 - 23 chars} -} 1.0 -test textIndex-12.6 {TkTextIndexBackChars} { - .t index {3.2 - 24 chars} +test textIndex-14.7 {TkTextIndexBackChars: loop backwards over chars} { + # (charCount == 0) + # No more chars, so we found byte offset. + + .t index {3.4 - 2 chars} +} 3.2 +test textIndex-14.8 {TkTextIndexBackChars: loop backwards over chars} { + # (p == start) + # Still more chars, but we reached beginning of segment + + .t image create 5.6 -image textimage + set x [.t index {5.8 - 3 chars}] + .t delete 5.6 + set x +} 5.5 +test textIndex-14.9 {TkTextIndexBackChars: back over image} { + # not (segPtr->typePtr == &tkTextCharType) + + .t image create 5.6 -image textimage + set x [.t get {5.8 - 4 chars}] + .t delete 5.6 + set x +} "G" +test textIndex-14.10 {TkTextIndexBackChars: move to previous segment} { + # (segPtr != oldPtr) + # More segments to go + + .t mark set foo 3.4 + set x [.t index {3.5 - 2 chars}] + .t mark unset foo + set x +} 3.3 +test textIndex-14.11 {TkTextIndexBackChars: move to previous segment} { + # not (segPtr != oldPtr) + # At beginning of line. + + .t mark set foo 3.4 + set x [.t index {3.5 - 10 chars}] + .t mark unset foo + set x +} 2.9 +test textIndex-14.12 {TkTextIndexBackChars: move to previous line} { + # (lineIndex == 0) + .t index {1.5 - 10 chars} } 1.0 +test textIndex-14.13 {TkTextIndexBackChars: move to previous line} { + # not (lineIndex == 0) + .t index {2.5 - 10 chars} +} 1.2 +test textIndex-14.14 {TkTextIndexBackChars: move to previous line} { + # for (segPtr = oldPtr; segPtr != NULL; segPtr = segPtr->nextPtr) + # Set byteIndex to end of previous line so we can subtract more + # bytes from it. Otherwise we get an TkTextIndex with a negative + # byteIndex. + + .t index {2.5 - 6 chars} +} 1.6 +test textIndex-14.15 {TkTextIndexBackChars: UTF} { + .t get {5.3 - 1 chars} +} 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 proc getword index { .t get [.t index "$index wordstart"] [.t index "$index wordend"] } -test textIndex-13.1 {StartEnd} { +test textIndex-15.1 {StartEnd} { list [catch {.t index {2.3 lineend}} msg] $msg } {0 2.13} -test textIndex-13.2 {StartEnd} { +test textIndex-15.2 {StartEnd} { list [catch {.t index {2.3 linee}} msg] $msg } {0 2.13} -test textIndex-13.3 {StartEnd} { +test textIndex-15.3 {StartEnd} { list [catch {.t index {2.3 line}} msg] $msg } {1 {bad text index "2.3 line"}} -test textIndex-13.4 {StartEnd} { +test textIndex-15.4 {StartEnd} { list [catch {.t index {2.3 linestart}} msg] $msg } {0 2.0} -test textIndex-13.5 {StartEnd} { +test textIndex-15.5 {StartEnd} { list [catch {.t index {2.3 lines}} msg] $msg } {0 2.0} -test textIndex-13.6 {StartEnd} { +test textIndex-15.6 {StartEnd} { getword 5.3 } { } -test textIndex-13.7 {StartEnd} { +test textIndex-15.7 {StartEnd} { getword 5.4 } GIrl -test textIndex-13.8 {StartEnd} { +test textIndex-15.8 {StartEnd} { getword 5.7 } GIrl -test textIndex-13.9 {StartEnd} { +test textIndex-15.9 {StartEnd} { getword 5.8 } { } -test textIndex-13.10 {StartEnd} { +test textIndex-15.10 {StartEnd} { getword 5.14 } x_yz -test textIndex-13.11 {StartEnd} { +test textIndex-15.11 {StartEnd} { getword 6.2 } # -test textIndex-13.12 {StartEnd} { +test textIndex-15.12 {StartEnd} { getword 3.4 } 12345 .t tag add x 2.8 2.11 -test textIndex-13.13 {StartEnd} { +test textIndex-15.13 {StartEnd} { list [catch {.t index {2.2 worde}} msg] $msg } {0 2.13} -test textIndex-13.14 {StartEnd} { +test textIndex-15.14 {StartEnd} { list [catch {.t index {2.12 words}} msg] $msg } {0 2.0} -test textIndex-13.15 {StartEnd} { +test textIndex-15.15 {StartEnd} { list [catch {.t index {2.12 word}} msg] $msg } {1 {bad text index "2.12 word"}} +test testIndex-16.1 {TkTextPrintIndex} { + set t [text .t2] + $t insert end \n + $t window create end -window [button $t.b] + set result [$t index end-2c] + pack $t + catch {destroy $t} +} 0 + + +test testIndex-16.2 {TkTextPrintIndex} { + set t [text .t2] + $t insert end \n + $t window create end -window [button $t.b] + set result [$t tag add {} end-2c] + pack $t + catch {destroy $t} +} 0 + +# cleanup +rename textimage {} catch {destroy .t} -concat +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/textMark.test b/tk/tests/textMark.test index 9680a98c5c7..02f1208091c 100644 --- a/tk/tests/textMark.test +++ b/tk/tests/textMark.test @@ -3,19 +3,20 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} then \ - {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {destroy .t} if [catch {text .t -font {Courier 12} -width 20 -height 10}] { puts "The font needed by these tests isn't available, so I'm" puts "going to skip the tests." + ::tcltest::cleanupTests return } pack append . .t {top expand fill} @@ -219,4 +220,20 @@ test textMark-8.8 {MarkFindPrev - no previous mark} { } {} catch {destroy .t} -concat {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/textTag.test b/tk/tests/textTag.test index dee46079fef..ed642da6b87 100644 --- a/tk/tests/textTag.test +++ b/tk/tests/textTag.test @@ -3,19 +3,20 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} then \ - {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {destroy .t} if [catch {text .t -font {Courier 12} -width 20 -height 10}] { puts "The font needed by these tests isn't available, so I'm" puts "going to skip the tests." + ::tcltest::cleanupTests return } pack append . .t {top expand fill} @@ -183,7 +184,14 @@ test textTag-3.7 {TkTextTagCmd - "bind" option} { .t tag bind x <Enter> } {script1 script2} - +test textTag-3.7 {TkTextTagCmd - "bind" option} { + .t tag delete x + list [catch {.t tag bind x <Enter>} msg] $msg +} {0 {}} +test textTag-3.8 {TkTextTagCmd - "bind" option} { + .t tag delete x + list [catch {.t tag bind x <} msg] $msg +} {1 {no event type or button # or keysym}} test textTag-4.1 {TkTextTagCmd - "cget" option} { list [catch {.t tag cget a} msg] $msg @@ -587,10 +595,13 @@ test textTag-15.1 {TkTextBindProc} { set x {} .t tag add x 2.0 2.4 .t tag add y 4.3 + event gen .t <Button> -x $x1 -y $y1 event gen .t <Motion> -x $x1 -y $y1 event gen .t <ButtonRelease> -x $x1 -y $y1 + event gen .t <Button> -x $x1 -y $y1 event gen .t <Motion> -x $x2 -y $y2 event gen .t <ButtonRelease> -x $x2 -y $y2 + event gen .t <Button> -x $x2 -y $y2 event gen .t <Motion> -x $x3 -y $y3 event gen .t <ButtonRelease> -x $x3 -y $y3 bind .t <ButtonRelease> {} @@ -753,4 +764,20 @@ test textTag-16.7 {TkTextPickCurrent procedure} { } {3.1} catch {destroy .t} -concat {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/textWind.test b/tk/tests/textWind.test index f75c66c2a6f..85a959b6bd4 100644 --- a/tk/tests/textWind.test +++ b/tk/tests/textWind.test @@ -3,14 +3,14 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} then \ - {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} foreach i [winfo child .] { catch {destroy $i} @@ -824,3 +824,20 @@ pack .t catch {destroy .t} option clear + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/tk.test b/tk/tests/tk.test index 408ce7173cf..0d0ec2b9839 100644 --- a/tk/tests/tk.test +++ b/tk/tests/tk.test @@ -2,14 +2,13 @@ # It is organized in the standard fashion for Tcl tests. # # Copyright (c) 1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info commands test] == ""} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } test tk-1.1 {tk command: general} { @@ -17,7 +16,7 @@ test tk-1.1 {tk command: general} { } {1 {wrong # args: should be "tk option ?arg?"}} test tk-1.2 {tk command: general} { list [catch {tk xyz} msg] $msg -} {1 {bad option "xyz": must be appname, or scaling}} +} {1 {bad option "xyz": must be appname, scaling, or useinputmethods}} set appname [tk appname] test tk-2.1 {tk command: appname} { @@ -34,7 +33,7 @@ test tk-2.4 {tk command: appname} { tk appname $appname } $appname tk appname $appname - + set scaling [tk scaling] test tk-3.1 {tk command: scaling} { list [catch {tk scaling -displayof} msg] $msg @@ -78,3 +77,40 @@ test tk-3.11 {tk command: scaling: heightmm} { expr {int((25.4*[winfo screenheight .])/(72*1.25)+0.5)-[winfo screenmmheight .]} } {0} tk scaling $scaling + +set useim [tk useinputmethods] +test tk-4.1 {tk command: useinputmethods} { + list [catch {tk useinputmethods -displayof} msg] $msg +} {1 {value for "-displayof" missing}} +test tk-4.2 {tk command: useinputmethods: get current} { + tk useinputmethods no +} 0 +test tk-4.3 {tk command: useinputmethods: get current} { + tk useinputmethods -displayof . +} 0 +test tk-4.4 {tk command: useinputmethods: set new} { + list [catch {tk useinputmethods xyz} msg] $msg +} {1 {expected boolean value but got "xyz"}} +test tk-4.5 {tk command: useinputmethods: set new} { + list [catch {tk useinputmethods -displayof . xyz} msg] $msg +} {1 {expected boolean value but got "xyz"}} +test tk-4.6 {tk command: useinputmethods: set new} {unixOnly} { + # This isn't really a test, but more of a check... + # The answer is what was given, because we may be on a Unix + # system that doesn't have the XIM stuff + if {[tk useinputmethods 1] == 0} { + puts "this wish doesn't have XIM (X Input Methods) support" + } + # We should always start with XIM support off + set useim +} 0 +test tk-4.7 {tk command: useinputmethods: set new} {macOrPc} { + # Mac and Windows don't have X Input Methods, so this should + # always return 0 + tk useinputmethods 1 +} 0 +tk useinputmethods $useim + +# cleanup +::tcltest::cleanupTests +return diff --git a/tk/tests/unixButton.test b/tk/tests/unixButton.test index 1ee15affafd..087b7d1a1cc 100644 --- a/tk/tests/unixButton.test +++ b/tk/tests/unixButton.test @@ -5,13 +5,18 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + if {$tcl_platform(platform)!="unix"} { + puts "skipping: Unix only tests..." + ::tcltest::cleanupTests return } @@ -19,13 +24,10 @@ if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\"" puts "image, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[info procs test] != "test"} { - source defs -} - foreach i [winfo children .] { destroy $i } @@ -180,3 +182,20 @@ test unixbutton-1.11 {TkpComputeButtonGeometry procedure} { } {27 37} eval destroy [winfo children .] + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/unixEmbed.test b/tk/tests/unixEmbed.test index 824c8833828..54d548a4cda 100644 --- a/tk/tests/unixEmbed.test +++ b/tk/tests/unixEmbed.test @@ -3,18 +3,19 @@ # tests. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {$tcl_platform(platform) != "unix"} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } -if {[info procs test] != "test"} { - source defs +if {$tcl_platform(platform) != "unix"} { + puts "skipping: Unix only tests..." + ::tcltest::cleanupTests + return } eval destroy [winfo children .] @@ -72,7 +73,7 @@ test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} { catch {destroy .t} list [catch {toplevel .t -use 47} msg] $msg } {1 {couldn't create child of window "47"}} -test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} { +test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} {nonPortable} { catch {destroy .t} catch {destroy .x} toplevel .t -colormap new @@ -84,7 +85,7 @@ test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} { destroy .t set result } {0} -test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} { +test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} {nonPortable} { catch {destroy .t} catch {destroy .t2} catch {destroy .x} @@ -100,6 +101,8 @@ test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} { if {[string compare testembed [info commands testembed]] != 0} { puts "This application hasn't been compiled with the testembed command," puts "therefore I am skipping all of these tests." + cleanupbg + ::tcltest::cleanupTests return } @@ -200,7 +203,8 @@ test unixEmbed-2.4 {EmbeddedEventProc procedure} { list $x [testembed] } {{{XXX .f1 {} {}}} {}} -test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} { +test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} \ + {nonPortable} { foreach w [winfo child .] { catch {destroy $w} } @@ -620,8 +624,23 @@ test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} { wm geometry .t1 } {70x300+0+0} - +# cleanup foreach w [winfo child .] { catch {destroy $w} } cleanupbg +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/unixFont.test b/tk/tests/unixFont.test index 7df571a69a4..b39697a9a79 100644 --- a/tk/tests/unixFont.test +++ b/tk/tests/unixFont.test @@ -9,18 +9,19 @@ # at all sites. # # Copyright (c) 1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {$tcl_platform(platform)!="unix"} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } -if {[string compare test [info procs test]] != 0} { - source defs +if {$tcl_platform(platform)!="unix"} { + puts "skipping: Unix only tests..." + ::tcltest::cleanupTests + return } catch {destroy .b} @@ -49,7 +50,7 @@ proc getsize {} { return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" } -test unixfont-1.1 {TkpGetNativeFont procedure: not native} { +test unixfont-1.1 {TkpGetNativeFont procedure: not native} {noExceed} { list [catch {font measure {} xyz} msg] $msg } {1 {font "" doesn't exist}} test unixfont-1.2 {TkpGetNativeFont procedure: native} { @@ -60,19 +61,22 @@ test unixfont-2.1 {TkpGetFontFromAttributes procedure: no family} { font actual {-size 10} set x {} } {} -test unixfont-2.2 {TkpGetFontFromAttributes procedure: Times relatives} { +test unixfont-2.2 {TkpGetFontFromAttributes procedure: Times relatives} \ + {noExceed} { set x {} lappend x [lindex [font actual {-family "Times New Roman"}] 1] lappend x [lindex [font actual {-family "New York"}] 1] lappend x [lindex [font actual {-family "Times"}] 1] } {times times times} -test unixfont-2.3 {TkpGetFontFromAttributes procedure: Courier relatives} { +test unixfont-2.3 {TkpGetFontFromAttributes procedure: Courier relatives} \ + {noExceed} { set x {} lappend x [lindex [font actual {-family "Courier New"}] 1] lappend x [lindex [font actual {-family "Monaco"}] 1] lappend x [lindex [font actual {-family "Courier"}] 1] } {courier courier courier} -test unixfont-2.4 {TkpGetFontFromAttributes procedure: Helvetica relatives} { +test unixfont-2.4 {TkpGetFontFromAttributes procedure: Helvetica relatives} \ + {noExceed} { set x {} lappend x [lindex [font actual {-family "Arial"}] 1] lappend x [lindex [font actual {-family "Geneva"}] 1] @@ -91,7 +95,7 @@ test unixfont-2.7 {TkpGetFontFromAttributes: fixed family not available!} { test unixfont-2.8 {TkpGetFontFromAttributes: loop over returned font names} { lindex [font actual {-family fixed -size 31}] 1 } {fixed} -test unixfont-2.9 {TkpGetFontFromAttributes: reject adobe courier if possible} { +test unixfont-2.9 {TkpGetFontFromAttributes: reject adobe courier if possible} {noExceed} { lindex [font actual {-family courier}] 1 } {courier} test unixfont-2.10 {TkpGetFontFromAttributes: scalable font found} { @@ -222,23 +226,25 @@ test unixfont-8.1 {AllocFont procedure: use old font} { font delete xyz } {} test unixfont-8.2 {AllocFont procedure: parse information from XLFD} { - expr [lindex [font actual {-family times -size 0}] 3]==0 + expr {[lindex [font actual {-family times -size 0}] 3] == 0} } {0} test unixfont-8.3 {AllocFont procedure: can't parse info from name} { - if [catch {set a [font actual a12biluc]}]==0 { - string compare $a "-family a12biluc -size 0 -weight normal -slant roman -underline 0 -overstrike 0" - } else { - set a 0 - } -} {0} + catch {unset fontArray} + # check that font actual returns the correct attributes. + # the values of those attributes are system dependent. + array set fontArray [font actual a12biluc] + set result [lsort [array names fontArray]] + catch {unset fontArray} + set result +} {-family -overstrike -size -slant -underline -weight} test unixfont-8.4 {AllocFont procedure: classify characters} { set x 0 - incr x [font measure $courier "\001"] ;# 4 + incr x [font measure $courier "\u4000"] ;# 6 incr x [font measure $courier "\002"] ;# 4 incr x [font measure $courier "\012"] ;# 2 incr x [font measure $courier "\101"] ;# 1 set x -} [expr $cx*11] +} [expr $cx*13] test unixfont-8.5 {AllocFont procedure: setup widths of normal chars} { font metrics $courier -fixed } {1} @@ -281,7 +287,7 @@ test unixfont-9.1 {GetControlCharSubst procedure: 2 chars subst} { } {0 1 1 2} test unixfont-9.2 {GetControlCharSubst procedure: 4 chars subst} { .b.c dchars $t 0 end - .b.c insert $t 0 "0\1770" + .b.c insert $t 0 "0\0010" set x {} lappend x [.b.c index $t @[expr $ax*0],0] lappend x [.b.c index $t @[expr $ax*1],0] @@ -291,3 +297,19 @@ test unixfont-9.2 {GetControlCharSubst procedure: 4 chars subst} { lappend x [.b.c index $t @[expr $ax*5],0] } {0 1 1 1 1 2} +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/unixMenu.test b/tk/tests/unixMenu.test index ed4532d7851..f93e2a14402 100644 --- a/tk/tests/unixMenu.test +++ b/tk/tests/unixMenu.test @@ -4,13 +4,18 @@ # system. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + if {$tcl_platform(platform) != "unix"} { + puts "skipping: Unix only tests..." + ::tcltest::cleanupTests return } @@ -18,13 +23,10 @@ if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[info procs test] != "test"} { - source defs -} - proc deleteWindows {} { foreach i [winfo children .] { catch [destroy $i] @@ -332,8 +334,8 @@ test unixMenu-18.1 {GetTearoffEntryGeometry} { .mb.m add command -label test pack .mb raise . - list [catch {tkMbPost .mb} msg] $msg [destroy .mb] -} {0 {} {}} + list [catch {tkMbPost .mb} msg] $msg [tkMenuUnpost .mb.m] [destroy .mb] +} {0 {} {} {}} # Don't know how to reproduce the case where the tkwin has been deleted. test unixMenu-19.1 {TkpComputeMenubarGeometry - zero entries} { @@ -848,8 +850,8 @@ test unixMenu-25.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unixOnly} { .mb.m add command -label test pack .mb catch {tkMbPost .mb} - list [update] [destroy .mb] -} {{} {}} + list [update] [tkMenuUnpost .mb.m] [destroy .mb] +} {{} {} {}} test unixMenu-25.6 {TkpComputeStandardMenuGeometry - standard label geometry} { catch {destroy .m1} menu .m1 @@ -966,4 +968,7 @@ test unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} { test unixMenu-26.1 {TkpMenuInit - nothing to do} {} {} +# cleanup deleteWindows +::tcltest::cleanupTests +return diff --git a/tk/tests/unixSelect.test b/tk/tests/unixSelect.test new file mode 100644 index 00000000000..9a29d0abcdc --- /dev/null +++ b/tk/tests/unixSelect.test @@ -0,0 +1,244 @@ +# This file contains tests for the tkUnixSelect.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id$ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {$tcl_platform(platform) != "unix"} { + puts "skipping: Unix only tests..." + ::tcltest::cleanupTests + return +} + +eval destroy [winfo child .] + +global longValue selValue selInfo + +set selValue {} +set selInfo {} + +proc handler {type offset count} { + global selValue selInfo + lappend selInfo $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr $numBytes+$offset] +} + +proc errIncrHandler {type offset count} { + global selValue selInfo pass + if {$offset == 4000} { + if {$pass == 0} { + # Just sizing the selection; don't do anything here. + set pass 1 + } else { + # Fetching the selection; wait long enough to cause a timeout. + after 6000 + } + } + lappend selInfo $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr $numBytes+$offset] +} + +proc errHandler args { + error "selection handler aborted" +} + +proc badHandler {path type offset count} { + global selValue selInfo + selection handle -type $type $path {} + lappend selInfo $path $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr $numBytes+$offset] +} +proc reallyBadHandler {path type offset count} { + global selValue selInfo pass + if {$offset == 4000} { + if {$pass == 0} { + set pass 1 + } else { + selection handle -type $type $path {} + } + } + lappend selInfo $path $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr $numBytes+$offset] +} + +# Eliminate any existing selection on the screen. This is needed in case +# there is a selection in some other application, in order to prevent races +# from causing false errors in the tests below. + +selection clear . +after 1500 + +# common setup code +proc setup {{path .f1} {display {}}} { + catch {destroy $path} + if {$display == {}} { + frame $path + } else { + toplevel $path -screen $display + wm geom $path +0+0 + } + selection own $path +} + +# set up a very large buffer to test INCR retrievals +set longValue "" +foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { + set j $i.1$i.2$i.3$i.4$i.5$i.6$i.7$i.8$i.9$i.10$i.11$i.12$i.13$i.14 + append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j +} + +test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} {unixOnly} { + setupbg + entry .e + pack .e + update + .e insert 0 [encoding convertfrom identity \u00fcber] + .e selection range 0 end + set result [dobg {string bytelength [selection get]}] + cleanupbg + destroy .e + set result +} {5} +test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} {unixOnly} { + setupbg + dobg { + entry .e; pack .e; update + .e insert 0 \u00fc\u0444 + .e selection range 0 end + } + set x [selection get] + cleanupbg + list [string equal \u00fc? $x] \ + [string length $x] [string bytelength $x] +} {1 2 3} +test unixSelect-1.4 {TkSelGetSelection procedure: simple i18n text, iso2022} {unixOnly} { + setupbg + setup + selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \ + {handler COMPOUND_TEXT} + selection own . + set selValue \u00fc\u0444 + set selInfo {} + set result [dobg { + set x [selection get -type COMPOUND_TEXT] + list [string equal \u00fc\u0444 $x] \ + [string length $x] [string bytelength $x] + }] + cleanupbg + lappend result $selInfo +} {1 2 4 {COMPOUND_TEXT 0 4000}} +test unixSelect-1.5 {TkSelGetSelection procedure: INCR i18n text, iso2022} {unixOnly} { + + # This test is subtle. The selection ends up getting fetched twice by + # Tk: once to compute the length, and again to actually send the data. + # The first time through, we don't convert the data to ISO2022, so the + # buffer boundaries end up being different in the two passes. + + setupbg + setup + 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 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 length $x] [string bytelength $x] + }] + cleanupbg + lappend result $selInfo +} {1 8000 8002 {COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3999 COMPOUND_TEXT 7998 4000 COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3998 COMPOUND_TEXT 7997 4000}} +test unixSelect-1.6 {TkSelGetSelection procedure: simple i18n text, iso2022} {unixOnly} { + setupbg + setup + selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \ + {handler COMPOUND_TEXT} + selection own . + set selValue \u00fc\u0444 + set selInfo {} + set result [dobg { + set x [selection get -type COMPOUND_TEXT] + list [string equal \u00fc\u0444 $x] \ + [string length $x] [string bytelength $x] + }] + cleanupbg + lappend result $selInfo +} {1 2 4 {COMPOUND_TEXT 0 4000}} +test unixSelect-1.7 {TkSelGetSelection procedure: INCR i18n text} {unixOnly} { + setupbg + dobg "entry .e; pack .e; update + .e insert 0 \[encoding convertfrom identity \\u00fcber\]$longValue + .e selection range 0 end" + set result [string bytelength [selection get]] + cleanupbg + set result +} [expr {5 + [string bytelength $longValue]}] +test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} {unixOnly} { + setupbg + dobg { + entry .e; pack .e; update + .e insert 0 [string repeat x 3999]\u00fc + .e selection range 0 end + } + set x [selection get] + cleanupbg + list [string equal [string repeat x 3999]\u00fc $x] \ + [string length $x] [string bytelength $x] +} {1 4000 4001} +test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} {unixOnly} { + setupbg + dobg { + entry .e; pack .e; update + .e insert 0 \u00fc[string repeat x 3999] + .e selection range 0 end + } + set x [selection get] + cleanupbg + list [string equal \u00fc[string repeat x 3999] $x] \ + [string length $x] [string bytelength $x] +} {1 4000 4001} +test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text} {unixOnly} { + setupbg + dobg { + entry .e; pack .e; update + .e insert 0 [string repeat x 3999]\u00fc[string repeat x 4000] + .e selection range 0 end + } + set x [selection get] + cleanupbg + list [string equal [string repeat x 3999]\u00fc[string repeat x 4000] $x] \ + [string length $x] [string bytelength $x] +} {1 8000 8001} + +# cleanup +::tcltest::cleanupTests +return diff --git a/tk/tests/unixSend.test b/tk/tests/unixSend.test new file mode 100644 index 00000000000..0afdd4974d9 --- /dev/null +++ b/tk/tests/unixSend.test @@ -0,0 +1,679 @@ +# This file is a Tcl script to test out the "send" command and the +# 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. +# All rights reserved. +# +# RCS: @(#) $Id$ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {$tcl_platform(platform) == "macintosh"} { + puts "send is not available on the Mac - skipping tests" + ::tcltest::cleanupTests + return +} +if {$tcl_platform(platform) == "windows"} { + puts "skipping: Unix only tests..." + ::tcltest::cleanupTests + return +} +if {[auto_execok xhost] == ""} { + puts "xhost application isn't available - skipping tests" + ::tcltest::cleanupTests + return +} + +if {[info commands testsend] == "testsend"} { + set gotTestCmds 1 +} else { + set gotTestCmds 0 +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +# If send is disabled because of inadequate security, don't run any +# of these tests at all. + +setupbg +set app [dobg {tk appname}] +if {[catch {send $app set a 0} msg] == 1} { + if [string match "X server insecure *" $msg] { + puts -nonewline "Your X server is insecure, so \"send\" can't be used;" + puts " skipping \"send\" tests." + cleanupbg + ::tcltest::cleanupTests + return + } +} +cleanupbg + +# Compute a script that will load Tk into a child interpreter. + +foreach pkg [info loaded] { + if {[lindex $pkg 1] == "Tk"} { + set loadTk "load $pkg" + break + } +} + +# Procedure to create a new application with a given name and class. + +proc newApp {screen name class} { + global loadTk + interp create $name + $name eval [list set argv [list -display $screen -name $name -class $class]] + eval $loadTk $name +} + +set name [tk appname] +if $gotTestCmds { + set registry [testsend prop root InterpRegistry] + set commId [lindex [testsend prop root InterpRegistry] 0] +} +tk appname tktest +catch {send t_s_1 destroy .} +catch {send t_s_2 destroy .} + +if $gotTestCmds { + test unixSend-1.1 {RegOpen procedure, bogus property} { + testsend bogus + set result [winfo interps] + tk appname tktest + list $result [winfo interps] + } {{} tktest} + test unixSend-1.2 {RegOpen procedure, bogus property} { + testsend prop root InterpRegistry {} + set result [winfo interps] + tk appname tktest + list $result [winfo interps] + } {{} tktest} + test unixSend-1.3 {RegOpen procedure, bogus property} { + testsend prop root InterpRegistry abcdefg + tk appname tktest + set x [testsend prop root InterpRegistry] + string range $x [string first " " $x] end + } " tktest\nabcdefg\n" + + frame .f -width 1 -height 1 + set id [string range [winfo id .f] 2 end] + test unixSend-2.1 {RegFindName procedure} { + testsend prop root InterpRegistry {} + list [catch {send foo bar} msg] $msg + } {1 {no application named "foo"}} + test unixSend-2.2 {RegFindName procedure} { + testsend prop root InterpRegistry " abc\n def\nghi\n\n$id foo\n" + tk appname foo + } {foo #2} + test unixSend-2.3 {RegFindName procedure} { + testsend prop root InterpRegistry "gyz foo\n" + tk appname foo + } {foo} + test unixSend-2.4 {RegFindName procedure} { + testsend prop root InterpRegistry "${id}z foo\n" + tk appname foo + } {foo} + + test unixSend-3.1 {RegDeleteName procedure} { + tk appname tktest + testsend prop root InterpRegistry "012345 gorp\n12345 foo\n12345 tktest" + tk appname x + set x [testsend prop root InterpRegistry] + string range $x [string first " " $x] end + } " x\n012345 gorp\n12345 foo\n" + test unixSend-3.2 {RegDeleteName procedure} { + tk appname tktest + testsend prop root InterpRegistry "012345 gorp\n12345 tktest\n23456 tktest" + tk appname x + set x [testsend prop root InterpRegistry] + string range $x [string first " " $x] end + } " x\n012345 gorp\n23456 tktest\n" + test unixSend-3.3 {RegDeleteName procedure} { + tk appname tktest + testsend prop root InterpRegistry "012345 tktest\n12345 bar\n23456 tktest" + tk appname x + set x [testsend prop root InterpRegistry] + string range $x [string first " " $x] end + } " x\n12345 bar\n23456 tktest\n" + test unixSend-3.4 {RegDeleteName procedure} { + tk appname tktest + testsend prop root InterpRegistry "foo" + tk appname x + set x [testsend prop root InterpRegistry] + string range $x [string first " " $x] end + } " x\nfoo\n" + test unixSend-3.5 {RegDeleteName procedure} { + tk appname tktest + testsend prop root InterpRegistry "" + tk appname x + set x [testsend prop root InterpRegistry] + string range $x [string first " " $x] end + } " x\n" + + test unixSend-4.1 {RegAddName procedure} { + testsend prop root InterpRegistry "" + tk appname bar + testsend prop root InterpRegistry + } "$commId bar\n" + test unixSend-4.2 {RegAddName procedure} { + testsend prop root InterpRegistry "abc def" + tk appname bar + tk appname foo + testsend prop root InterpRegistry + } "$commId foo\nabc def\n" + + # Previous checks should already cover the Regclose procedure. + + test unixSend-5.1 {ValidateName procedure} { + testsend prop root InterpRegistry "123 abc\n" + winfo interps + } {} + test unixSend-5.2 {ValidateName procedure} { + testsend prop root InterpRegistry "$id Hi there" + winfo interps + } {{Hi there}} + test unixSend-5.3 {ValidateName procedure} { + testsend prop root InterpRegistry "$id Bogus" + list [catch {send Bogus set a 44} msg] $msg + } {1 {target application died or uses a Tk version before 4.0}} + test unixSend-5.4 {ValidateName procedure} { + tk appname test + testsend prop root InterpRegistry "$commId Bogus\n$commId test\n" + winfo interps + } {test} +} + +winfo interps +tk appname tktest +update +setupbg +set x [split [exec xhost] \n] +foreach i [lrange $x 1 end] { + exec xhost - $i +} +test unixSend-6.1 {ServerSecure procedure} {nonPortable} { + set a 44 + list [dobg [list send [tk appname] set a 55]] $a +} {55 55} +test unixSend-6.2 {ServerSecure procedure} {nonPortable} { + set a 22 + exec xhost [exec hostname] + list [catch {dobg [list send [tk appname] set a 33]} msg] $a $msg +} {0 22 {X server insecure (must use xauth-style authorization); command ignored}} +test unixSend-6.3 {ServerSecure procedure} {nonPortable} { + set a abc + exec xhost - [exec hostname] + list [dobg [list send [tk appname] set a new]] $a +} {new new} +cleanupbg + +if $gotTestCmds { + test unixSend-7.1 {Tk_SetAppName procedure} { + testsend prop root InterpRegistry "" + tk appname newName + list [tk appname oldName] [testsend prop root InterpRegistry] + } "oldName {$commId oldName\n}" + test unixSend-7.2 {Tk_SetAppName procedure, name not in use} { + testsend prop root InterpRegistry "" + list [tk appname gorp] [testsend prop root InterpRegistry] + } "gorp {$commId gorp\n}" + test unixSend-7.3 {Tk_SetAppName procedure, name in use by us} { + tk appname name1 + testsend prop root InterpRegistry "$commId name2\n" + list [tk appname name2] [testsend prop root InterpRegistry] + } "name2 {$commId name2\n}" + test unixSend-7.4 {Tk_SetAppName procedure, name in use} { + tk appname name1 + testsend prop root InterpRegistry "$id foo\n$id foo #2\n$id foo #3\n" + list [tk appname foo] [testsend prop root InterpRegistry] + } "{foo #4} {$commId foo #4\n$id foo\n$id foo #2\n$id foo #3\n}" +} + +test unixSend-8.1 {Tk_SendCmd procedure, options} { + setupbg + set app [dobg {tk appname}] + set a 66 + send -async $app [list send [tk appname] set a 77] + set result $a + after 200 set x 40 + tkwait variable x + cleanupbg + lappend result $a +} {66 77} +if [info exists env(TK_ALT_DISPLAY)] { + test unixSend-8.2 {Tk_SendCmd procedure, options} { + setupbg -display $env(TK_ALT_DISPLAY) + tk appname xyzgorp + set a homeDisplay + set result [dobg " + toplevel .t -screen [winfo screen .] + wm geometry .t +0+0 + set a altDisplay + tk appname xyzgorp + list \[send xyzgorp set a\] \[send -displayof .t xyzgorp set a\] + "] + cleanupbg + set result + } {altDisplay homeDisplay} +} +test unixSend-8.3 {Tk_SendCmd procedure, options} { + list [catch {send -- -async foo bar baz} msg] $msg +} {1 {no application named "-async"}} +test unixSend-8.4 {Tk_SendCmd procedure, options} { + list [catch {send -gorp foo bar baz} msg] $msg +} {1 {bad option "-gorp": must be -async, -displayof, or --}} +test unixSend-8.5 {Tk_SendCmd procedure, options} { + list [catch {send -async foo} msg] $msg +} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} +test unixSend-8.6 {Tk_SendCmd procedure, options} { + list [catch {send foo} msg] $msg +} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} +test unixSend-8.7 {Tk_SendCmd procedure, local execution} { + set a initial + send [tk appname] {set a new} + set a +} {new} +test unixSend-8.8 {Tk_SendCmd procedure, local execution} { + set a initial + send [tk appname] set a new + set a +} {new} +test unixSend-8.9 {Tk_SendCmd procedure, local execution} { + set a initial + string tolower [list [catch {send [tk appname] open bad_file} msg] \ + $msg $errorInfo $errorCode] +} {1 {couldn't open "bad_file": no such file or directory} {couldn't open "bad_file": no such file or directory + while executing +"open bad_file" + invoked from within +"send [tk appname] open bad_file"} {posix enoent {no such file or directory}}} +test unixSend-8.10 {Tk_SendCmd procedure, no such interpreter} { + list [catch {send bogus_name bogus_command} msg] $msg +} {1 {no application named "bogus_name"}} +if $gotTestCmds { + newApp "" t_s_1 Test + t_s_1 eval wm withdraw . + test unixSend-8.11 {Tk_SendCmd procedure, local execution, different interp} { + set a us + send t_s_1 set a them + list $a [send t_s_1 set a] + } {us them} + test unixSend-8.12 {Tk_SendCmd procedure, local execution, different interp} { + set a us + send t_s_1 {set a them} + list $a [send t_s_1 {set a}] + } {us them} + test unixSend-8.13 {Tk_SendCmd procedure, local execution, different interp} { + set a us + send t_s_1 {set a them} + list $a [send t_s_1 {set a}] + } {us them} + test unixSend-8.14 {Tk_SendCmd procedure, local interp killed by send} { + newApp "" t_s_2 Test + list [catch {send t_s_2 {destroy .; concat result}} msg] $msg + } {0 result} + interp delete t_s_2 + test unixSend-8.15 {Tk_SendCmd procedure, local interp, error info} { + catch {error foo} + list [catch {send t_s_1 {if 1 {open bogus_file_name}}} msg] $msg $errorInfo $errorCode + } {1 {couldn't open "bogus_file_name": no such file or directory} {couldn't open "bogus_file_name": no such file or directory + while executing +"open bogus_file_name" + invoked from within +"if 1 {open bogus_file_name}" + invoked from within +"send t_s_1 {if 1 {open bogus_file_name}}"} {POSIX ENOENT {no such file or directory}}} + test unixSend-8.16 {Tk_SendCmd procedure, bogusCommWindow} { + testsend prop root InterpRegistry "10234 bogus\n" + set result [list [catch {send bogus bogus command} msg] $msg] + winfo interps + tk appname tktest + set result + } {1 {no application named "bogus"}} + interp delete t_s_1 +} +test unixSend-8.17 {Tk_SendCmd procedure, deferring events} {nonPortable} { + # Non-portable because some window managers ignore "raise" + # requests so can't guarantee that new app's window won't + # obscure .f, thereby masking the Expose event. + + setupbg + set app [dobg {tk appname}] + raise . ; # Don't want new app obscuring .f + catch {destroy .f} + frame .f + place .f -x 0 -y 0 + bind .f <Expose> {set a exposed} + set a {no event yet} + set result "" + lappend result [send $app send [list [tk appname]] set a] + lappend result $a + update + cleanupbg + lappend result $a +} {{no event yet} {no event yet} exposed} +test unixSend-8.18 {Tk_SendCmd procedure, error in remote app} { + setupbg + set app [dobg {tk appname}] + set result [string tolower [list [catch {send $app open bad_name} msg] \ + $msg $errorInfo $errorCode]] + cleanupbg + set result +} {1 {couldn't open "bad_name": no such file or directory} {couldn't open "bad_name": no such file or directory + while executing +"open bad_name" + invoked from within +"send $app open bad_name"} {posix enoent {no such file or directory}}} +test unixSend-8.19 {Tk_SendCmd, using modal timeouts} { + setupbg + set app [dobg {tk appname}] + set x no + set result "" + after 0 {set x yes} + lappend result [send $app {concat x y z}] + lappend result $x + update + cleanupbg + lappend result $x +} {{x y z} no yes} + +tk appname tktest +catch {destroy .f} +frame .f +set id [string range [winfo id .f] 2 end] +if $gotTestCmds { + test unixSend-9.1 {Tk_GetInterpNames procedure} { + testsend prop root InterpRegistry \ + "$commId tktest\nfoo bar\n$commId tktest\n$id frame .f\n\n\n" + list [winfo interps] [testsend prop root InterpRegistry] + } "{tktest tktest {frame .f}} {$commId tktest\n$commId tktest\n$id frame .f +}" + test unixSend-9.2 {Tk_GetInterpNames procedure} { + testsend prop root InterpRegistry \ + "$commId tktest\nfoobar\n$commId gorp\n" + list [winfo interps] [testsend prop root InterpRegistry] + } "tktest {$commId tktest\n}" + test unixSend-9.3 {Tk_GetInterpNames procedure} { + testsend prop root InterpRegistry {} + list [winfo interps] [testsend prop root InterpRegistry] + } {{} {}} + + testsend prop root InterpRegistry "$commId tktest\n$id dummy\n" + test unixSend-10.1 {SendEventProc procedure, bogus comm property} { + testsend prop comm Comm {abc def} + testsend prop comm Comm {} + update + } {} + test unixSend-10.2 {SendEventProc procedure, simultaneous messages} { + testsend prop comm Comm \ + "c\n-n tktest\n-s set a 44\nc\n-n tktest\n-s set b 45\n" + set a null + set b xyzzy + update + list $a $b + } {44 45} + test unixSend-10.3 {SendEventProc procedure, simultaneous messages} { + testsend prop comm Comm \ + "c\n-n tktest\n-s set a newA\nr\n-s [testsend serial]\n-r 12345\nc\n-n tktest\n-s set b newB\n" + set a null + set b xyzzy + set x [send dummy bogus] + list $x $a $b + } {12345 newA newB} + test unixSend-10.4 {SendEventProc procedure, leading nulls, bogus commands} { + testsend prop comm Comm \ + "\n\nx\n-bogus\n\nc\n-n tktest\n-s set a 44\n" + set a null + update + set a + } {44} + test unixSend-10.5 {SendEventProc procedure, extraneous command options} { + 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} + test unixSend-10.6 {SendEventProc procedure, unknown interpreter} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n unknown\n-r $id 44\n-s set a new\n" + set a null + update + list [testsend prop [winfo id .f] Comm] $a + } "{\nr\n-s 44\n-r receiver never heard of interpreter \"unknown\"\n-c 1\n} null" + test unixSend-10.7 {SendEventProc procedure, error in script} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n tktest\n-r $id 62\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n" + update + testsend prop [winfo id .f] Comm + } { +r +-s 62 +-r test error +-i Initial errorInfo + ("foreach" body line 1) + invoked from within +"foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}" +-e test code +-c 1 +} + test unixSend-10.8 {SendEventProc procedure, exceptional return} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n tktest\n-r $id 62\n-s break\n" + update + testsend prop [winfo id .f] Comm + } { +r +-s 62 +-r +-c 3 +} + test unixSend-10.9 {SendEventProc procedure, empty return} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n tktest\n-r $id 62\n-s concat\n" + update + testsend prop [winfo id .f] Comm + } { +r +-s 62 +-r +} + test unixSend-10.10 {SendEventProc procedure, asynchronous calls} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n tktest\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n" + update + testsend prop [winfo id .f] Comm + } {} + test unixSend-10.11 {SendEventProc procedure, exceptional return} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n tktest\n-s break\n" + update + testsend prop [winfo id .f] Comm + } {} + test unixSend-10.12 {SendEventProc procedure, empty return} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n tktest\n-s concat\n" + update + testsend prop [winfo id .f] Comm + } {} + test unixSend-10.13 {SendEventProc procedure, return processing} { + testsend prop comm Comm \ + "r\n-c 1\n-e test1\n-i test2\n-r test3\n-s [testsend serial]\n" + list [catch {send dummy foo} msg] $msg $errorInfo $errorCode + } {1 test3 {test2 + invoked from within +"send dummy foo"} test1} + test unixSend-10.14 {SendEventProc procedure, extraneous return options} { + testsend prop comm Comm \ + "r\n-x test1\n-y test2\n-r result\n-s [testsend serial]\n" + list [catch {send dummy foo} msg] $msg + } {0 result} + test unixSend-10.15 {SendEventProc procedure, serial number} { + testsend prop comm Comm \ + "r\n-r response\n" + list [catch {send dummy foo} msg] $msg + } {1 {target application died or uses a Tk version before 4.0}} + test unixSend-10.16 {SendEventProc procedure, serial number} { + testsend prop comm Comm \ + "r\n-r response\n\n-s 0" + list [catch {send dummy foo} msg] $msg + } {1 {target application died or uses a Tk version before 4.0}} + test unixSend-10.17 {SendEventProc procedure, errorCode and errorInfo} { + testsend prop comm Comm \ + "r\n-i test1\n-e test2\n-c 4\n-s [testsend serial]\n" + set errorCode oldErrorCode + set errorInfo oldErrorInfo + list [catch {send dummy foo} msg] $msg $errorInfo $errorCode + } {4 {} oldErrorInfo oldErrorCode} + test unixSend-10.18 {SendEventProc procedure, send kills application} { + setupbg + dobg {tk appname t_s_3} + set x [list [catch {send t_s_3 destroy .} msg] $msg] + cleanupbg + set x + } {0 {}} + test unixSend-10.19 {SendEventProc procedure, send exits} { + setupbg + dobg {tk appname t_s_3} + set x [list [catch {send t_s_3 exit} msg] $msg] + close $::tcltest::fd + set x + } {1 {target application died}} + + test unixSend-11.1 {AppendPropCarefully and AppendErrorProc procedures} { + testsend prop root InterpRegistry "0x21447 dummy\n" + list [catch {send dummy foo} msg] $msg + } {1 {no application named "dummy"}} + test unixSend-11.2 {AppendPropCarefully and AppendErrorProc procedures} { + testsend prop comm Comm "c\n-r0x123 44\n-n tktest\n-s concat a b c\n" + update + } {} +} + +winfo interps +tk appname tktest +catch {destroy .f} +frame .f +set id [string range [winfo id .f] 2 end] +if $gotTestCmds { + test unixSend-12.1 {TimeoutProc procedure} { + testsend prop root InterpRegistry "$id dummy\n" + list [catch {send dummy foo} msg] $msg + } {1 {target application died or uses a Tk version before 4.0}} + testsend prop root InterpRegistry "" +} +test unixSend-12.2 {TimeoutProc procedure} { + winfo interps + tk appname tktest + update + setupbg + puts $::tcltest::fd {after 10 {after 5000; exit}; puts [tk appname]; puts **DONE**; flush stdout} + set ::tcltest::bgDone 0 + set ::tcltest::bgData {} + flush $::tcltest::fd + tkwait variable ::tcltest::bgDone + set app $::tcltest::bgData + after 200 + set result [list [catch {send $app foo} msg] $msg] + close $::tcltest::fd + set result +} {1 {target application died}} + +winfo interps +tk appname tktest +test unixSend-13.1 {DeleteProc procedure} { + setupbg + set app [dobg {rename send {}; tk appname}] + set result [list [catch {send $app foo} msg] $msg [winfo interps]] + cleanupbg + set result +} {1 {no application named "tktest #2"} tktest} +test unixSend-13.2 {DeleteProc procedure} { + winfo interps + tk appname tktest + rename send {} + set result {} + lappend result [winfo interps] [info commands send] + tk appname foo + lappend result [winfo interps] [info commands send] +} {{} {} foo send} + +if [info exists env(TK_ALT_DISPLAY)] { + test unixSend-14.1 {SendRestrictProc procedure, sends crossing from different displays} { + setupbg -display $env(TK_ALT_DISPLAY) + set result [dobg " + toplevel .t -screen [winfo screen .] + wm geometry .t +0+0 + tk appname xyzgorp1 + set x child + "] + toplevel .t -screen $env(TK_ALT_DISPLAY) + wm geometry .t +0+0 + tk appname xyzgorp2 + update + set y parent + set result [send -displayof .t xyzgorp1 {list $x [send -displayof .t xyzgorp2 set y]}] + destroy .t + cleanupbg + set result + } {child parent} +} + +if $gotTestCmds { + testsend prop root InterpRegister $registry + tk appname tktest + test unixSend-15.1 {UpdateCommWindow procedure} { + set x [list [testsend prop comm TK_APPLICATION]] + newApp "" t_s_1 Test + send t_s_1 wm withdraw . + newApp "" t_s_2 Test + send t_s_2 wm withdraw . + lappend x [testsend prop comm TK_APPLICATION] + interp delete t_s_1 + lappend x [testsend prop comm TK_APPLICATION] + interp delete t_s_2 + lappend x [testsend prop comm TK_APPLICATION] + } {tktest {t_s_2 t_s_1 tktest} {t_s_2 tktest} tktest} +} + +tk appname $name +if $gotTestCmds { + testsend prop root InterpRegistry $registry +} +if $gotTestCmds { + testdeleteapps +} +rename newApp {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/unixWm.test b/tk/tests/unixWm.test index 376026d8256..78cb9e4b058 100644 --- a/tk/tests/unixWm.test +++ b/tk/tests/unixWm.test @@ -4,18 +4,19 @@ # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {$tcl_platform(platform) != "unix"} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } -if {[string compare test [info procs test]] == 1} { - source defs +if {$tcl_platform(platform) != "unix"} { + puts "skipping: Unix only tests..." + ::tcltest::cleanupTests + return } proc sleep ms { @@ -195,7 +196,7 @@ test unixWm-6.3 {size changes} { update wm geom .t } 170x140+10+10 -test unixWm-6.4 {size changes} {nonPortable} { +test unixWm-6.4 {size changes} {nonPortable userInteraction} { wm minsize .t 1 1 update puts stdout "Please resize window \"t\" with the mouse (but don't move it!)," @@ -352,9 +353,35 @@ test unixWm-8.9 {icon windows} {nonPortable} { lappend result [winfo ismapped .icon] [wm state .icon] } {icon 1 0 0 withdrawn 1 normal} +test unixWm-59.1 {test for memory leaks} { + wm title .t "This is a long long long long long long title" + wm title .t "This is a long long long long long long title" + wm title .t "This is a long long long long long long title" + wm title .t "This is a long long long long long long title" + wm title .t "This is a long long long long long long title" + wm title .t "This is a long long long long long long title" + wm title .t "This is a long long long long long long title" + wm title .t "This is a long long long long long long title" + set x 1 +} 1 +test unixWm-59.2 {test for memory leaks} { + wm group .t . + wm group .t . + wm group .t . + wm group .t . + wm group .t . + wm group .t . + wm group .t . + wm group .t . + wm group .t . + wm group .t . + set x 1 +} 1 + if {[string compare testwrapper [info commands testwrapper]] != 0} { puts "This application hasn't been compiled with the testwrapper command," puts "therefore I am skipping all of these tests." + ::tcltest::cleanupTests return } @@ -820,6 +847,7 @@ test unixWm-23.5 {Tk_WmCmd procedure, "iconify" option} { catch {destroy .t2} toplevel .t2 wm geom .t2 +0+0 + update wm iconify .t2 update set result [winfo ismapped .t2] @@ -833,6 +861,7 @@ test unixWm-23.6 {Tk_WmCmd procedure, "iconify" option} { update set result [winfo ismapped .t2] wm iconify .t2 + update lappend result [winfo ismapped .t2] destroy .t2 set result @@ -1182,8 +1211,11 @@ test unixWm-34.3 {Tk_WmCmd procedure, "sizefrom" option} { test unixWm-35.1 {Tk_WmCmd procedure, "state" option} { list [catch {wm state .t 1} msg] $msg -} {1 {wrong # arguments: must be "wm state window"}} +} {1 {bad argument "1": must be normal, iconic or withdrawn}} test unixWm-35.2 {Tk_WmCmd procedure, "state" option} { + list [catch {wm state .t iconic 1} msg] $msg +} {1 {wrong # arguments: must be "wm state window ?state?"}} +test unixWm-35.3 {Tk_WmCmd procedure, "state" option} { set result {} catch {destroy .t2} toplevel .t2 -width 120 -height 300 @@ -1200,6 +1232,23 @@ test unixWm-35.2 {Tk_WmCmd procedure, "state" option} { destroy .t2 set result } {normal normal withdrawn iconic normal} +test unixWm-35.4 {Tk_WmCmd procedure, "state" option} { + set result {} + catch {destroy .t2} + toplevel .t2 -width 120 -height 300 + wm geometry .t2 +0+0 + lappend result [wm state .t2] + update + lappend result [wm state .t2] + wm state .t2 withdrawn + lappend result [wm state .t2] + wm state .t2 iconic + lappend result [wm state .t2] + wm state .t2 normal + lappend result [wm state .t2] + destroy .t2 + set result +} {normal normal withdrawn iconic normal} test unixWm-36.1 {Tk_WmCmd procedure, "title" option} { list [catch {wm title .t 1 2} msg] $msg @@ -1309,7 +1358,7 @@ test unixWm-41.1 {ConfigureEvent procedure, internally generated size changes} { sleep 500 lappend result [winfo width .t] [winfo height .t] } {400 150 200 300} -test unixWm-41.2 {ConfigureEvent procedure, menubars} {unixOnly} { +test unixWm-41.2 {ConfigureEvent procedure, menubars} {nonPortable} { catch {destroy .t} toplevel .t -width 300 -height 200 -bd 2 -relief raised wm geom .t +0+0 @@ -1473,22 +1522,26 @@ test unixWm-44.6 {UpdateGeometryInfo procedure, negative height} { update list [winfo width .t] [winfo height .t] } {100 1} + +catch {destroy .t} +toplevel .t -width 80 -height 60 test unixWm-44.7 {UpdateGeometryInfo procedure, computing position} { - catch {destroy .t} - toplevel .t -width 80 -height 60 wm geometry .t +5-10 wm overrideredirect .t 1 tkwait visibility .t list [winfo x .t] [winfo y .t] -} "5 [expr [winfo screenheight .t] - 70]" +} [list 5 [expr [winfo screenheight .t] - 70]] + +catch {destroy .t} +toplevel .t -width 80 -height 60 test unixWm-44.8 {UpdateGeometryInfo procedure, computing position} { - catch {destroy .t} - toplevel .t -width 80 -height 60 wm geometry .t -30+2 wm overrideredirect .t 1 tkwait visibility .t list [winfo x .t] [winfo y .t] -} "[expr [winfo screenwidth .t] - 110] 2" +} [list [expr [winfo screenwidth .t] - 110] 2] +catch {destroy .t} + test unixWm-44.9 {UpdateGeometryInfo procedure, updating fixed dimensions} {unixOnly} { catch {destroy .t} toplevel .t -width 80 -height 60 @@ -1588,7 +1641,7 @@ test unixWm-46.1 {WaitForEvent procedure, use of modal timeout} { list $result $x } {no yes} -test unixWm-47.1 {WaitRestrictProc procedure} { +test unixWm-47.1 {WaitRestrictProc procedure} {nonPortable} { catch {destroy .t} toplevel .t -width 300 -height 200 frame .t.f -bd 2 -relief raised @@ -1603,6 +1656,7 @@ test unixWm-47.1 {WaitRestrictProc procedure} { event generate .t.f <Configure> -when tail event generate .t <Configure> -when tail event generate .t <Button> -button 3 -when tail + event generate .t <ButtonRelease> -button 3 -when tail event generate .t <Map> -when tail lappend result iconify wm iconify .t @@ -2291,6 +2345,37 @@ test unixWm-57.2 {MenubarReqProc procedure} {unixOnly} { lappend result [expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y] } {0 20 0 1} +test unixWm-58.1 {UpdateCommand procedure, DString gets reallocated} {unixOnly} { + catch {destroy .t} + toplevel .t -width 100 -height 50 + wm geom .t +0+0 + wm command .t "argumentNumber0 argumentNumber1 argumentNumber2 argumentNumber0 argumentNumber3 argumentNumber4 argumentNumber5 argumentNumber6 argumentNumber0 argumentNumber7 argumentNumber8 argumentNumber9 argumentNumber10 argumentNumber0 argumentNumber11 argumentNumber12 argumentNumber13 argumentNumber14 argumentNumber15 argumentNumber16 argumentNumber17 argumentNumber18" + update + testprop [testwrapper .t] WM_COMMAND +} {argumentNumber0 +argumentNumber1 +argumentNumber2 +argumentNumber0 +argumentNumber3 +argumentNumber4 +argumentNumber5 +argumentNumber6 +argumentNumber0 +argumentNumber7 +argumentNumber8 +argumentNumber9 +argumentNumber10 +argumentNumber0 +argumentNumber11 +argumentNumber12 +argumentNumber13 +argumentNumber14 +argumentNumber15 +argumentNumber16 +argumentNumber17 +argumentNumber18 +} + # Test exit processing and cleanup: test unixWm-58.1 {exit processing} { @@ -2301,7 +2386,7 @@ test unixWm-58.1 {exit processing} { exit } close $fd - if {[catch {exec $tktest script -geometry 10x10+0+0} msg]} { + if {[catch {exec $::tcltest::tktest script -geometry 10x10+0+0} msg]} { set error 1 } else { set error 0 @@ -2320,7 +2405,7 @@ test unixWm-58.2 {exit processing} { exit } close $fd - if {[catch {exec $tktest script -geometry 10x10+0+0} msg]} { + if {[catch {exec $::tcltest::tktest script -geometry 10x10+0+0} msg]} { set error 1 } else { set error 0 @@ -2345,7 +2430,7 @@ test unixWm-58.3 {exit processing} { exit } close $fd - if {[catch {exec $tktest script -geometry 10x10+0+0} msg]} { + if {[catch {exec $::tcltest::tktest script -geometry 10x10+0+0} msg]} { set error 1 } else { set error 0 @@ -2353,6 +2438,23 @@ test unixWm-58.3 {exit processing} { list $error $msg } {0 {}} - + +# cleanup catch {destroy .t} -concat {} +catch {removeFile script} +::tcltest::cleanupTests +return + + + + + + + + + + + + + + diff --git a/tk/tests/util.test b/tk/tests/util.test index 416de65957f..b7399427898 100644 --- a/tk/tests/util.test +++ b/tk/tests/util.test @@ -3,14 +3,14 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[string compare test [info procs test]] == 1} then \ - {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} foreach i [winfo children .] { destroy $i @@ -68,3 +68,20 @@ test util-1.11 {Tk_GetScrollInfo procedure} { test util-1.12 {Tk_GetScrollInfo procedure} { list [catch {.l yview dropdead 3 times} msg] $msg } {1 {unknown option "dropdead": must be moveto or scroll}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/visual.test b/tk/tests/visual.test index 82408bf061b..4b2ef3e05b6 100644 --- a/tk/tests/visual.test +++ b/tk/tests/visual.test @@ -4,14 +4,13 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -310,3 +309,20 @@ foreach w [winfo child .] { } rename eatColors {} rename colorsFree {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/visual_bb.test b/tk/tests/visual_bb.test new file mode 100644 index 00000000000..e0eea2fc5b2 --- /dev/null +++ b/tk/tests/visual_bb.test @@ -0,0 +1,111 @@ +#!/usr/local/bin/wish -f +# +# This script displays provides visual tests for many of Tk's features. +# Each test displays a window with various information in it, along +# with instructions about how the window should appear. You can look +# at the window to make sure it appears as expected. Individual tests +# are kept in separate ".tcl" files in this directory. +# +# RCS: @(#) $Id$ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +set auto_path ". $auto_path" +wm title . "Visual Tests for Tk" + +set testNum 1 + +# Each menu entry invokes a visual test file + +proc runTest {file} { + global testNum + + test "2.$testNum" "testing $file" {userInteraction} { + uplevel \#0 source [file join $::tcltest::testsDir $file] + concat "" + } {} + incr testNum +} + +# The following procedure is invoked to print the contents of a canvas: + +proc lpr c { + exec rm -f tmp.ps + $c postscript -file tmp.ps + exec lpr tmp.ps + exec rm -f tmp.ps +} + +test 1.1 "running visual tests" {userInteraction} { + + #------------------------------------------------------- + # The code below create the main window, consisting of a + # menu bar and a message explaining the basic operation + # of the program. + #------------------------------------------------------- + + frame .menu -relief raised -borderwidth 1 + message .msg -font {Times 18} -relief raised -width 4i \ + -borderwidth 1 -text "This application provides a collection of visual tests for the Tk toolkit. Each menu entry invokes a test, which displays information on the screen. You can then verify visually that the information is being displayed in the correct way. The tests under the \"Postscript\" menu exercise the Postscript-generation capabilities of canvas widgets." + + pack .menu -side top -fill x + pack .msg -side bottom -expand yes -fill both + + #------------------------------------------------------- + # The code below creates all the menus, which invoke procedures + # to create particular demonstrations of various widgets. + #------------------------------------------------------- + + menubutton .menu.file -text "File" -menu .menu.file.m + menu .menu.file.m + .menu.file.m add command -label "Quit" -command ::tcltest::cleanupTests + + menubutton .menu.group1 -text "Group 1" -menu .menu.group1.m + menu .menu.group1.m + .menu.group1.m add command -label "Canvas arcs" -command {runTest arc.tcl} + .menu.group1.m add command -label "Beveled borders in text widgets" \ + -command {runTest bevel.tcl} + .menu.group1.m add command -label "Colormap management" \ + -command {runTest cmap.tcl} + .menu.group1.m add command -label "Label/button geometry" \ + -command {runTest butGeom.tcl} + .menu.group1.m add command -label "Label/button colors" \ + -command {runTest butGeom2.tcl} + + menubutton .menu.ps -text "Canvas Postscript" -menu .menu.ps.m + menu .menu.ps.m + .menu.ps.m add command -label "Rectangles and other graphics" \ + -command {runTest canvPsGrph.tcl} + .menu.ps.m add command -label "Text" \ + -command {runTest canvPsText.tcl} + .menu.ps.m add command -label "Bitmaps" \ + -command {runTest canvPsBmap.tcl} + .menu.ps.m add command -label "Images" \ + -command {source canvPsImg.tcl} + .menu.ps.m add command -label "Arcs" \ + -command {runTest canvPsArc.tcl} + + pack .menu.file .menu.group1 .menu.ps -side left -padx 1m + + # Set up for keyboard-based menu traversal + + bind . <Any-FocusIn> { + if {("%d" == "NotifyVirtual") && ("%m" == "NotifyNormal")} { + focus .menu + } + } + tk_menuBar .menu .menu.file .menu.group1 .menu.ps + + # 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]} + + concat "" +} {} + +if {!$::tcltest::testConfig(userInteraction)} { + ::tcltest::cleanupTests +} diff --git a/tk/tests/winButton.test b/tk/tests/winButton.test index 509aaa258c7..9e2a2e17b88 100644 --- a/tk/tests/winButton.test +++ b/tk/tests/winButton.test @@ -5,27 +5,23 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {$tcl_platform(platform)!="windows"} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\"" puts "image, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[info procs test] != "test"} { - source defs -} - foreach i [winfo children .] { destroy $i } @@ -47,7 +43,7 @@ radiobutton .r -text Radiobutton pack .l .b .c .r update -test winbutton-1.1 {TkpComputeButtonGeometry procedure} { +test winbutton-1.1 {TkpComputeButtonGeometry procedure} {pcOnly} { eval destroy [winfo children .] image create test image1 image1 changed 0 0 0 0 60 40 @@ -62,7 +58,7 @@ test winbutton-1.1 {TkpComputeButtonGeometry procedure} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {68 48 71 51 96 50 96 50} -test winbutton-1.2 {TkpComputeButtonGeometry procedure} { +test winbutton-1.2 {TkpComputeButtonGeometry procedure} {pcOnly} { eval destroy [winfo children .] label .b1 -bitmap question -bd 3 -padx 0 -pady 2 button .b2 -bitmap question -bd 3 -padx 0 -pady 2 @@ -75,7 +71,7 @@ test winbutton-1.2 {TkpComputeButtonGeometry procedure} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {23 33 26 36 51 35 51 35} -test winbutton-1.3 {TkpComputeButtonGeometry procedure} { +test winbutton-1.3 {TkpComputeButtonGeometry procedure} {pcOnly} { eval destroy [winfo children .] label .b1 -bitmap question -bd 3 -highlightthickness 4 button .b2 -bitmap question -bd 3 -highlightthickness 0 @@ -89,7 +85,7 @@ test winbutton-1.3 {TkpComputeButtonGeometry procedure} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {31 41 24 34 26 36 26 36} -test winbutton-1.4 {TkpComputeButtonGeometry procedure} {nonPortable} { +test winbutton-1.4 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { eval destroy [winfo children .] label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -font {{MS Sans Serif} 8} button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -font {{MS Sans Serif} 8} @@ -102,21 +98,21 @@ test winbutton-1.4 {TkpComputeButtonGeometry procedure} {nonPortable} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {58 24 67 33 88 30 90 28} -test winbutton-1.5 {TkpComputeButtonGeometry procedure} {nonPortable} { +test winbutton-1.5 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { eval destroy [winfo children .] label .l1 -text "This is a long string that will wrap around on several lines.\n\nIt also has a blank line (above)." -wraplength 1.5i -padx 0 -pady 0 pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] } {178 84} -test winbutton-1.6 {TkpComputeButtonGeometry procedure} {nonPortable} { +test winbutton-1.6 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { eval destroy [winfo children .] label .l1 -text "This is a long string without wrapping.\n\nIt also has a blank line (above)." -padx 0 -pady 0 pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] } {222 52} -test winbutton-1.7 {TkpComputeButtonGeometry procedure} {nonPortable} { +test winbutton-1.7 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { eval destroy [winfo children .] label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10 button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5 @@ -129,7 +125,7 @@ test winbutton-1.7 {TkpComputeButtonGeometry procedure} {nonPortable} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {74 24 67 97 174 46 64 28} -test winbutton-1.8 {TkpComputeButtonGeometry procedure} {nonPortable} { +test winbutton-1.8 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { eval destroy [winfo children .] label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \ -highlightthickness 4 @@ -145,10 +141,26 @@ test winbutton-1.8 {TkpComputeButtonGeometry procedure} {nonPortable} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {66 32 65 31 69 31 71 29} -test winbutton-1.9 {TkpComputeButtonGeometry procedure} { +test winbutton-1.9 {TkpComputeButtonGeometry procedure} {pcOnly} { eval destroy [winfo children .] button .b2 -bitmap question -default normal list [winfo reqwidth .b2] [winfo reqheight .b2] } {24 34} +# cleanup eval destroy [winfo children .] +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/winClipboard.test b/tk/tests/winClipboard.test index 58a2b2c1c79..aaf29678ece 100644 --- a/tk/tests/winClipboard.test +++ b/tk/tests/winClipboard.test @@ -7,41 +7,80 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-2000 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {$tcl_platform(platform)!="windows"} { - return -} - -if {[string compare test [info procs test]] == 1} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } # Note that these tests may fail if another application is grabbing the # clipboard (e.g. an X server) -test winClipboard-1.1 {TkSelGetSelection} { +if {[llength [info command testclipboard]] == 0} { + puts "\"testclipboard\" isn't defined, skipping winClipboard tests" + ::tcltest::cleanupTests + return +} + +test winClipboard-1.1 {TkSelGetSelection} {pcOnly} { clipboard clear catch {selection get -selection CLIPBOARD} msg set msg } {CLIPBOARD selection doesn't exist or form "STRING" not defined} -test winClipboard-1.2 {TkSelGetSelection} { +test winClipboard-1.2 {TkSelGetSelection} {pcOnly} { clipboard clear clipboard append {} list [selection get -selection CLIPBOARD] [testclipboard] } {{} {}} -test winClipboard-1.3 {TkSelGetSelection & TkWinClipboardRender} { +test winClipboard-1.3 {TkSelGetSelection & TkWinClipboardRender} {pcOnly} { clipboard clear clipboard append abcd + update list [selection get -selection CLIPBOARD] [testclipboard] } {abcd abcd} -test winClipboard-1.4 {TkSelGetSelection & TkWinClipboardRender} { +test winClipboard-1.4 {TkSelGetSelection & TkWinClipboardRender} {pcOnly} { clipboard clear clipboard append "line 1\nline 2" list [selection get -selection CLIPBOARD] [testclipboard] } [list "line 1\nline 2" "line 1\r\nline 2"] +test winClipboard-1.5 {TkSelGetSelection & TkWinClipboardRender} {pcOnly} { + clipboard clear + clipboard append "line 1\u00c7\nline 2" + list [selection get -selection CLIPBOARD] [testclipboard] +} [list "line 1\u00c7\nline 2" [bytestring "line 1\u00c7\r\nline 2"]] + +test winClipboard-2.1 {TkSelUpdateClipboard reentrancy problem} {pcOnly} { + clipboard clear + clipboard append -type OUR_ACTION "action data" + clipboard append "string data" + update + list [selection get -selection CLIPBOARD -type OUR_ACTION] [testclipboard] +} [list "action data" "string data"] +test winClipboard-2.2 {TkSelUpdateClipboard reentrancy problem} {pcOnly} { + clipboard clear + clipboard append -type OUR_ACTION "new data" + clipboard append "more data in string" + update + list [testclipboard] [selection get -selection CLIPBOARD -type OUR_ACTION] +} [list "more data in string" "new data"] + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tk/tests/winDialog.test b/tk/tests/winDialog.test new file mode 100644 index 00000000000..4d01ae9d1c3 --- /dev/null +++ b/tk/tests/winDialog.test @@ -0,0 +1,333 @@ +# This file is a Tcl script to test the Windows specific behavior of +# 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. +# All rights reserved. +# +# RCS: @(#) $Id$ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {[info command testwinevent] == ""} { + puts "skipping: tests require the testwinevent command" + ::tcltest::cleanupTests + return +} + +testwinevent debug 1 + +eval destroy [winfo children .] +wm geometry . {} +raise . + +proc start {arg} { + set ::tk_dialog 0 + set ::iter_after 0 + + after 1 $arg +} + +proc then {cmd} { + set ::command $cmd + set ::dialogresult {} + + afterbody + vwait ::dialogresult + return $::dialogresult +} + +proc afterbody {} { + if {$::tk_dialog == 0} { + if {[incr ::iter_after] > 30} { + set ::dialogresult ">30 iterations waiting on tk_dialog" + return + } + after 100 {afterbody} + return + } + uplevel #0 {set dialogresult [eval $command]} +} + +proc Click {button} { + testwinevent $::tk_dialog $button WM_LBUTTONDOWN 1 0x000a000b + testwinevent $::tk_dialog $button WM_LBUTTONUP 0 0x000a000b +} + +proc GetText {button} { + return [testwinevent $::tk_dialog $button WM_GETTEXT] +} + +proc SetText {button text} { + return [testwinevent $::tk_dialog $button WM_SETTEXT $text] +} + +test winDialog-1.1 {Tk_ChooseColorObjCmd} {nt} { +} {} + +test winDialog-2.1 {ColorDlgHookProc} {nt} { +} {} + +test winDialog-3.1 {Tk_GetOpenFileObjCmd} {nt} { + start {tk_getOpenFile} + then { + set x [GetText 2] + Click 2 + } + set x +} {Cancel} + +test winDialog-4.1 {Tk_GetSaveFileObjCmd} {nt} { + start {tk_getSaveFile} + then { + set x [GetText 2] + Click 2 + } + set x +} {Cancel} + +test winDialog-5.1 {GetFileName: no arguments} {nt} { + start {tk_getOpenFile -title Open} + then { + Click cancel + } +} {0} +test winDialog-5.2 {GetFileName: one argument} {nt} { + list [catch {tk_getOpenFile -foo} msg] $msg +} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent, or -title}} +test winDialog-5.4 {GetFileName: many arguments} {nt} { + start {tk_getOpenFile -initialdir c:/ -parent . -title test -initialfile foo} + then { + Click cancel + } +} {0} +test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} {nt} { + list [catch {tk_getOpenFile -foo bar -abc} msg] $msg +} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent, or -title}} +test winDialog-5.6 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} {nt} { + start {tk_getOpenFile -title bar} + then { + Click cancel + } +} {0} +test winDialog-5.7 {GetFileName: valid option, but missing value} {nt} { + list [catch {tk_getOpenFile -initialdir bar -title} msg] $msg +} {1 {value for "-title" missing}} +test winDialog-5.8 {GetFileName: extension begins with .} {nt} { +# if (string[0] == '.') { +# string++; +# } + + start {set x [tk_getSaveFile -defaultextension .foo -title Save]} + then { + SetText 0x480 bar + Click 1 + } + set x +} [file join [pwd] bar.foo] +test winDialog-5.9 {GetFileName: extension doesn't begin with .} {nt} { + start {set x [tk_getSaveFile -defaultextension foo -title Save]} + then { + SetText 0x480 bar + Click 1 + } + set x +} [file join [pwd] bar.foo] +test winDialog-5.10 {GetFileName: file types} {nt} { +# case FILE_TYPES: + + start {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo} + then { + set x [GetText 0x470] + Click cancel + } + set x +} {foo files (*.foo)} +test winDialog-5.11 {GetFileName: file types: MakeFilter() fails} {nt} { +# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK) + + list [catch {tk_getSaveFile -filetypes {{"foo" .foo FOO}}} msg] $msg +} {1 {bad Macintosh file type "FOO"}} +test winDialog-5.12 {GetFileName: initial directory} {nt} { +# case FILE_INITDIR: + + start {set x [tk_getSaveFile -initialdir c:/ -initialfile "12x 455" -title Foo]} + then { + Click 1 + } + set x +} {C:/12x 455} +test winDialog-5.13 {GetFileName: initial directory: Tcl_TranslateFilename()} \ + {nt} { +# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) + + list [catch {tk_getOpenFile -initialdir ~12x/455} msg] $msg +} {1 {user "12x" doesn't exist}} +test winDialog-5.14 {GetFileName: initial file} {nt} { +# case FILE_INITFILE: + + start {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]} + then { + Click 1 + } + set x +} [file join [pwd] "12x 456"] +test winDialog-5.15 {GetFileName: initial file: Tcl_TranslateFileName()} {nt} { +# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) + list [catch {tk_getOpenFile -initialfile ~12x/455} msg] $msg +} {1 {user "12x" doesn't exist}} +set a aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa +append a $a +append a $a +append a $a +append a $a +test winDialog-5.16 {GetFileName: initial file: long name} {nt} { + start {set x [tk_getSaveFile -initialfile $a -title Long]} + then { + Click 1 + } + set x +} [string range [file join [pwd] $a] 0 257] +test winDialog-5.17 {GetFileName: parent} {nt} { +# case FILE_PARENT: + + toplevel .t + set x 0 + start {tk_getOpenFile -parent .t -title Parent; set x 1} + then { + destroy .t + } + set x +} {1} +test winDialog-5.18 {GetFileName: title} {nt} { +# case FILE_TITLE: + + start {tk_getOpenFile -title Narf} + then { + Click 2 + } +} {0} +test winDialog-5.19 {GetFileName: no filter specified} {nt} { +# if (ofn.lpstrFilter == NULL) + + start {tk_getOpenFile -title Filter} + then { + set x [GetText 0x470] + Click 2 + } + set x +} {All Files (*.*)} +test winDialog-5.20 {GetFileName: parent HWND doesn't yet exist} {nt} { +# if (Tk_WindowId(parent) == None) + + toplevel .t + start {tk_getOpenFile -parent .t -title Open} + then { + destroy .t + } +} {} +test winDialog-5.21 {GetFileName: parent HWND already exists} {nt} { + toplevel .t + update + start {tk_getOpenFile -parent .t -title Open} + then { + destroy .t + } +} {} +test winDialog-5.22 {GetFileName: call GetOpenFileName} {nt} { +# winCode = GetOpenFileName(&ofn); + + start {tk_getOpenFile -title Open} + then { + set x [GetText 1] + Click 2 + } + set x +} {&Open} +test winDialog-5.23 {GetFileName: call GetSaveFileName} {nt} { +# winCode = GetSaveFileName(&ofn); + + start {tk_getSaveFile -title Save} + then { + set x [GetText 1] + Click 2 + } + set x +} {&Save} +test winDialog-5.24 {GetFileName: convert \ to /} {nt} { + start {set x [tk_getSaveFile -title Back]} + then { + SetText 0x480 "c:\\12x 457" + Click 1 + } + set x +} {c:/12x 457} + +test winDialog-6.1 {MakeFilter} {emptyTest nt} {} {} + +test winDialog-7.1 {Tk_MessageBoxObjCmd} {emptyTest nt} {} {} + +test winDialog-8.1 {OFNHookProc} {emptyTest nt} {} {} + +## The Tk_ChooseDirectoryObjCmd hang on the static build of Windows +## because somehow the GetOpenFileName ends up a noop in the static +## build. +## +test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} {nt} { + start {tk_chooseDirectory} + then { + Click cancel + } +} {0} +test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} {nt} { + list [catch {tk_chooseDirectory -foo} msg] $msg +} {1 {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}} +test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} {nt} { + start { + tk_chooseDirectory -initialdir c:/ -mustexist 1 -parent . -title test + } + then { + Click cancel + } +} {0} +test winDialog-9.4 {Tk_ChooseDirectoryObjCmd:\ + Tcl_GetIndexFromObj() != TCL_OK} {nt} { + list [catch {tk_chooseDirectory -foo bar -abc} msg] $msg +} {1 {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}} +test winDialog-9.5 {Tk_ChooseDirectoryObjCmd:\ + Tcl_GetIndexFromObj() == TCL_OK} {nt} { + start {tk_chooseDirectory -title bar} + then { + Click cancel + } +} {0} +test winDialog-9.6 {Tk_ChooseDirectoryObjCmd:\ + valid option, but missing value} {nt} { + list [catch {tk_chooseDirectory -initialdir bar -title} msg] $msg +} {1 {value for "-title" missing}} +test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} {nt} { +# case DIR_INITIAL: + + start {set x [tk_chooseDirectory -initialdir c:/ -title Foo]} + then { + Click 1 + } + string tolower [set x] +} {c:/} +test winDialog-9.8 {Tk_ChooseDirectoryObjCmd:\ + initial directory: Tcl_TranslateFilename()} {nt} { +# if (Tcl_TranslateFileName(interp, string, +# &utfDirString) == NULL) + + list [catch {tk_chooseDirectory -initialdir ~12x/455} msg] $msg +} {1 {user "12x" doesn't exist}} + +testwinevent debug 0 + +# cleanup +::tcltest::cleanupTests +return + diff --git a/tk/tests/winFont.test b/tk/tests/winFont.test index 294f4e0dd7e..9e8949a7d30 100644 --- a/tk/tests/winFont.test +++ b/tk/tests/winFont.test @@ -7,24 +7,20 @@ # but there are no results that can be checked. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {$tcl_platform(platform)!="windows"} { - return -} - -if {[string compare test [info procs test]] != 0} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } catch {destroy .b} catch {font delete xyz} toplevel .b +wm geometry .b +0+0 update idletasks set courier {Courier 14} @@ -45,10 +41,10 @@ proc getsize {} { return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" } -test winfont-1.1 {TkpGetNativeFont procedure: not native} { +test winfont-1.1 {TkpGetNativeFont procedure: not native} {pcOnly} { list [catch {font measure {} xyz} msg] $msg } {1 {font "" doesn't exist}} -test winfont-1.2 {TkpGetNativeFont procedure: native} { +test winfont-1.2 {TkpGetNativeFont procedure: native} {pcOnly} { font measure ansifixed 0 font measure ansi 0 font measure device 0 @@ -58,98 +54,99 @@ test winfont-1.2 {TkpGetNativeFont procedure: native} { set x {} } {} -test winfont-2.1 {TkpGetFontFromAttributes procedure: pointsize} { +test winfont-2.1 {TkpGetFontFromAttributes procedure: pointsize} {pcOnly} { expr [font actual {-size -10} -size]>0 } {1} -test winfont-2.2 {TkpGetFontFromAttributes procedure: pointsize} { +test winfont-2.2 {TkpGetFontFromAttributes procedure: pointsize} {pcOnly} { expr [font actual {-family Arial} -size]>0 } {1} -test winfont-2.3 {TkpGetFontFromAttributes procedure: normal weight} { +test winfont-2.3 {TkpGetFontFromAttributes procedure: normal weight} {pcOnly} { font actual {-weight normal} -weight } {normal} -test winfont-2.4 {TkpGetFontFromAttributes procedure: bold weight} { +test winfont-2.4 {TkpGetFontFromAttributes procedure: bold weight} {pcOnly} { font actual {-weight bold} -weight } {bold} -test winfont-2.5 {TkpGetFontFromAttributes procedure: no family} { +test winfont-2.5 {TkpGetFontFromAttributes procedure: no family} {pcOnly} { catch {expr {[font actual {-size 10} -size]}} } 0 -test winfont-2.6 {TkpGetFontFromAttributes procedure: family} { +test winfont-2.6 {TkpGetFontFromAttributes procedure: family} {pcOnly} { font actual {-family Arial} -family } {Arial} -test winfont-2.7 {TkpGetFontFromAttributes procedure: Times fonts} { +test winfont-2.7 {TkpGetFontFromAttributes procedure: Times fonts} {pcOnly} { set x {} lappend x [font actual {-family "Times"} -family] lappend x [font actual {-family "New York"} -family] lappend x [font actual {-family "Times New Roman"} -family] } {{Times New Roman} {Times New Roman} {Times New Roman}} -test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} { +test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} {pcOnly} { set x {} lappend x [font actual {-family "Courier"} -family] lappend x [font actual {-family "Monaco"} -family] lappend x [font actual {-family "Courier New"} -family] } {{Courier New} {Courier New} {Courier New}} -test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} { +test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} {pcOnly} { set x {} lappend x [font actual {-family "Helvetica"} -family] lappend x [font actual {-family "Geneva"} -family] lappend x [font actual {-family "Arial"} -family] } {Arial Arial Arial} -test winfont-2.10 {TkpGetFontFromAttributes procedure: fallback} { +test winfont-2.10 {TkpGetFontFromAttributes procedure: fallback} {pcOnly} { # No way to get it to fail! Any font name is acceptable. } {} -test winfont-3.1 {TkpDeleteFont procedure} { +test winfont-3.1 {TkpDeleteFont procedure} {pcOnly} { font actual {-family xyz} set x {} } {} -test winfont-4.1 {TkpGetFontFamilies procedure} { +test winfont-4.1 {TkpGetFontFamilies procedure} {pcOnly} { font families set x {} } {} -test winfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} { +test winfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} {pcOnly} { .b.l config -wrap 0 -text "000000" getsize } "[expr $ax*6] $ay" -test winfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} { +test winfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} {pcOnly} { .b.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" getsize } "[expr $ax*256] $ay" -test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} { +test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} {pcOnly} { .b.l config -wrap [expr $ax*10] -text "00000000" getsize } "[expr $ax*8] $ay" -test winfont-5.4 {Tk_MeasureChars procedure: not all chars fit} { +test winfont-5.4 {Tk_MeasureChars procedure: not all chars fit} {pcOnly} { .b.l config -wrap [expr $ax*6] -text "00000000" getsize } "[expr $ax*6] [expr $ay*2]" -test winfont-5.5 {Tk_MeasureChars procedure: include last partial char} { +test winfont-5.5 {Tk_MeasureChars procedure: include last partial char} {pcOnly} { .b.c dchars $t 0 end .b.c insert $t 0 "0000" .b.c index $t @[expr int($cx*2.5)],1 } {2} -test winfont-5.6 {Tk_MeasureChars procedure: at least one char on line} { +test winfont-5.6 {Tk_MeasureChars procedure: at least one char on line} {pcOnly} { .b.l config -text "000000" -wrap 1 getsize } "$ax [expr $ay*6]" -test winfont-5.7 {Tk_MeasureChars procedure: whole words} { +test winfont-5.7 {Tk_MeasureChars procedure: whole words} {pcOnly} { .b.l config -wrap [expr $ax*8] -text "000000 0000" getsize } "[expr $ax*6] [expr $ay*2]" -test winfont-5.8 {Tk_MeasureChars procedure: already saw space in line} { +test winfont-5.8 {Tk_MeasureChars procedure: already saw space in line} {pcOnly} { .b.l config -wrap [expr $ax*12] -text "000000 0000000" getsize } "[expr $ax*7] [expr $ay*2]" -test winfont-5.9 {Tk_MeasureChars procedure: internal spaces significant} { +test winfont-5.9 {Tk_MeasureChars procedure: internal spaces significant} {pcOnly} { .b.l config -wrap [expr $ax*12] -text "000 00 00000" getsize } "[expr $ax*7] [expr $ay*2]" -test winfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} { +test winfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} {pcOnly} { .b.l config -wrap [expr $ax*12] -text "0000000000000000" getsize } "[expr $ax*12] [expr $ay*2]" -test winfont-5.10 {Tk_MeasureChars procedure: check for kerning} {nonPortable} { +test winfont-5.10 {Tk_MeasureChars procedure: check for kerning} \ + {pcOnly nonPortable} { set font [.b.l cget -font] .b.l config -font {{MS Sans Serif} 8} -text "W" set width [winfo reqwidth .b.l] @@ -158,12 +155,12 @@ test winfont-5.10 {Tk_MeasureChars procedure: check for kerning} {nonPortable} { .b.l config -font $font expr $x < ($width*10) } 1 -test winfont-6.1 {Tk_DrawChars procedure: loop test} { +test winfont-6.1 {Tk_DrawChars procedure: loop test} {pcOnly} { .b.l config -text "a" update } {} -test winfont-7.1 {AllocFont procedure: use old font} { +test winfont-7.1 {AllocFont procedure: use old font} {pcOnly} { font create xyz catch {destroy .c} button .c -font xyz @@ -172,14 +169,29 @@ test winfont-7.1 {AllocFont procedure: use old font} { destroy .c font delete xyz } {} -test winfont-7.2 {AllocFont procedure: extract info from logfont} { +test winfont-7.2 {AllocFont procedure: extract info from logfont} {pcOnly} { font actual {arial 10 bold italic underline overstrike} } {-family Arial -size 10 -weight bold -slant italic -underline 1 -overstrike 1} -test winfont-7.3 {AllocFont procedure: extract info from textmetric} { +test winfont-7.3 {AllocFont procedure: extract info from textmetric} {pcOnly} { font metric {arial 10 bold italic underline overstrike} -fixed } {0} -test winfont-7.4 {AllocFont procedure: extract info from textmetric} { +test winfont-7.4 {AllocFont procedure: extract info from textmetric} {pcOnly} { font metric systemfixed -fixed } {1} +# cleanup destroy .b +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tk/tests/winMenu.test b/tk/tests/winMenu.test index 9274d604d91..ae9d74a0d92 100644 --- a/tk/tests/winMenu.test +++ b/tk/tests/winMenu.test @@ -4,37 +4,23 @@ # system. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {$tcl_platform(platform) != "windows"} { - return -} - -if {![info exists INTERACTIVE]} { - puts " Some tests were skipped because they could not be performed" - puts " automatically on this platform. If you wish to execute them" - puts " interactively, set the TCL variable INTERACTIVE and re-run" - puts " the test." - set testConfig(menuInteractive) 0 -} else { - set testConfig(menuInteractive) 1 +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" puts "type, so I can't run this test. Are you sure you're using" puts "tktest instead of wish?" + ::tcltest::cleanupTests return } -if {[info procs test] != "test"} { - source defs -} - proc deleteWindows {} { foreach i [winfo children .] { catch [destroy $i] @@ -45,23 +31,23 @@ deleteWindows wm geometry . {} raise . -test winMenu-1.1 {GetNewID} { +test winMenu-1.1 {GetNewID} {pcOnly} { catch {destroy .m1} list [catch {menu .m1} msg] $msg [destroy .m1] } {0 .m1 {}} # Basically impossible to test menu IDs wrapping. -test winMenu-2.1 {FreeID} { +test winMenu-2.1 {FreeID} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {destroy .m1} msg] $msg } {0 {}} -test winMenu-3.1 {TkpNewMenu} { +test winMenu-3.1 {TkpNewMenu} {pcOnly} { catch {destroy .m1} list [catch {menu .m1} msg] $msg [catch {destroy .m1} msg2] $msg2 } {0 .m1 0 {}} -test winMenu-3.2 {TkpNewMenu} { +test winMenu-3.2 {TkpNewMenu} {pcOnly} { catch {destroy .m1} . configure -menu "" menu .m1 @@ -69,12 +55,12 @@ test winMenu-3.2 {TkpNewMenu} { list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [catch {destroy .m1} msg2] $msg2 } {0 {} {} 0 {}} -test winMenu-4.1 {TkpDestroyMenu} { +test winMenu-4.1 {TkpDestroyMenu} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {destroy .m1} msg] $msg } {0 {}} -test winMenu-4.2 {TkpDestroyMenu - help menu} { +test winMenu-4.2 {TkpDestroyMenu - help menu} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add cascade -menu .m1.system @@ -82,7 +68,7 @@ test winMenu-4.2 {TkpDestroyMenu - help menu} { list [catch {destroy .m1.system} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test winMenu-5.1 {TkpDestroyMenuEntry} { +test winMenu-5.1 {TkpDestroyMenuEntry} {pcOnly} { catch {destroy .m1} . configure -menu "" menu .m1 @@ -91,89 +77,89 @@ test winMenu-5.1 {TkpDestroyMenuEntry} { list [catch {.m1 delete 1} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.1 {GetEntryText} { +test winMenu-6.1 {GetEntryText} {pcOnly} { catch {destroy .m1} list [catch {menu .m1} msg] $msg [destroy .m1] } {0 .m1 {}} -test winMenu-6.2 {GetEntryText} { +test winMenu-6.2 {GetEntryText} {pcOnly} { catch {destroy .m1} catch {image delete image1} menu .m1 image create test image1 list [catch {.m1 add command -image image1} msg] $msg [destroy .m1] [image delete image1] } {0 {} {} {}} -test winMenu-6.3 {GetEntryText} { +test winMenu-6.3 {GetEntryText} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -bitmap questhead} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.4 {GetEntryText} { +test winMenu-6.4 {GetEntryText} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {.m1 add command} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.5 {GetEntryText} { +test winMenu-6.5 {GetEntryText} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "foo"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.6 {GetEntryText} { +test winMenu-6.6 {GetEntryText} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "This string has one & in it"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.7 {GetEntryText} { +test winMenu-6.7 {GetEntryText} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "The & should be underlined." -underline 4} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.8 {GetEntryText} { +test winMenu-6.8 {GetEntryText} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "The * should be underlined." -underline 4} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.9 {GetEntryText} { +test winMenu-6.9 {GetEntryText} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "foo" -accel "bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.10 {GetEntryText} { +test winMenu-6.10 {GetEntryText} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "This string has one & in it" -accel "bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.11 {GetEntryText} { +test winMenu-6.11 {GetEntryText} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "The & should be underlined." -underline 4 -accel "bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.12 {GetEntryText} { +test winMenu-6.12 {GetEntryText} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "The * should be underlined." -underline 4 -accel "bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.13 {GetEntryText} { +test winMenu-6.13 {GetEntryText} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "foo" -accel "&bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.14 {GetEntryText} { +test winMenu-6.14 {GetEntryText} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "This string has one & in it" -accel "&bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.15 {GetEntryText} { +test winMenu-6.15 {GetEntryText} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "The & should be underlined." -underline 4 -accel "&bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-6.16 {GetEntryText} { +test winMenu-6.16 {GetEntryText} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "The * should be underlined." -underline 4 -accel "&bar"} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.1 {ReconfigureWindowsMenu - system menu item removal} { +test winMenu-7.1 {ReconfigureWindowsMenu - system menu item removal} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add cascade -menu .m1.system @@ -183,7 +169,7 @@ test winMenu-7.1 {ReconfigureWindowsMenu - system menu item removal} { .m1.system add command -label bar list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test winMenu-7.2 {ReconfigureWindowsMenu - menu item removal} { +test winMenu-7.2 {ReconfigureWindowsMenu - menu item removal} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label Hello @@ -191,77 +177,77 @@ test winMenu-7.2 {ReconfigureWindowsMenu - menu item removal} { .m1 add command -label foo list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.3 {ReconfigureWindowsMenu - zero items} { +test winMenu-7.3 {ReconfigureWindowsMenu - zero items} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label Hello .m1 delete Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.4 {ReconfigureWindowsMenu - one item} { +test winMenu-7.4 {ReconfigureWindowsMenu - one item} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.5 {ReconfigureWindowsMenu - two items} { +test winMenu-7.5 {ReconfigureWindowsMenu - two items} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label One .m1 add command -label Two list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.6 {ReconfigureWindowsMenu - separator item} { +test winMenu-7.6 {ReconfigureWindowsMenu - separator item} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add separator list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.7 {ReconfigureWindowsMenu - non-text item} { +test winMenu-7.7 {ReconfigureWindowsMenu - non-text item} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.8 {ReconfigureWindowsMenu - disabled item} { +test winMenu-7.8 {ReconfigureWindowsMenu - disabled item} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label Hello -state disabled list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.9 {ReconfigureWindowsMenu - non-selected checkbutton} { +test winMenu-7.9 {ReconfigureWindowsMenu - non-selected checkbutton} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add checkbutton -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.10 {ReconfigureWindowsMenu - non-selected radiobutton} { +test winMenu-7.10 {ReconfigureWindowsMenu - non-selected radiobutton} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add radiobutton -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.11 {ReconfigureWindowsMenu - selected checkbutton} { +test winMenu-7.11 {ReconfigureWindowsMenu - selected checkbutton} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add checkbutton -label Hello .m1 invoke Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.12 {ReconfigureWindowsMenu - selected radiobutton} { +test winMenu-7.12 {ReconfigureWindowsMenu - selected radiobutton} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add radiobutton -label Hello .m1 invoke Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.13 {ReconfigureWindowsMenu - cascade missing} { +test winMenu-7.13 {ReconfigureWindowsMenu - cascade missing} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-7.14 {ReconfigureWindowsMenu - cascade} { +test winMenu-7.14 {ReconfigureWindowsMenu - cascade} {pcOnly} { catch {destroy .m1} catch {destroy .m2} menu .m1 -tearoff 0 @@ -269,7 +255,7 @@ test winMenu-7.14 {ReconfigureWindowsMenu - cascade} { .m1 add cascade -menu .m2 -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] [destroy .m2] } {0 {} {} {}} -test winMenu-7.15 {ReconfigureWindowsMenu - menubar without system menu} { +test winMenu-7.15 {ReconfigureWindowsMenu - menubar without system menu} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -menu .m1.file @@ -277,7 +263,7 @@ test winMenu-7.15 {ReconfigureWindowsMenu - menubar without system menu} { . configure -menu .m1 list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test winMenu-7.16 {ReconfigureWindowsMenu - system menu already created} { +test winMenu-7.16 {ReconfigureWindowsMenu - system menu already created} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -menu .m1.system @@ -287,7 +273,7 @@ test winMenu-7.16 {ReconfigureWindowsMenu - system menu already created} { .m1.system add command -label Hello list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test winMenu-7.17 {ReconfigureWindowsMenu - system menu update pending} { +test winMenu-7.17 {ReconfigureWindowsMenu - system menu update pending} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -menu .m1.system @@ -295,7 +281,7 @@ test winMenu-7.17 {ReconfigureWindowsMenu - system menu update pending} { . configure -menu .m1 list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test winMenu-7.18 {ReconfigureWindowsMenu - system menu update not pending} { +test winMenu-7.18 {ReconfigureWindowsMenu - system menu update not pending} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -menu .m1.system @@ -305,7 +291,7 @@ test winMenu-7.18 {ReconfigureWindowsMenu - system menu update not pending} { . configure -menu .m1 list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test winMenu-7.19 {ReconfigureWindowsMenu - column break} { +test winMenu-7.19 {ReconfigureWindowsMenu - column break} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label one @@ -314,23 +300,23 @@ test winMenu-7.19 {ReconfigureWindowsMenu - column break} { } {0 {} {}} #Don't know how to generate nested post menus -test winMenu-8.1 {TkpPostMenu} { +test winMenu-8.1 {TkpPostMenu} {pcOnly} { catch {destroy .m1} menu .m1 -postcommand "blork" list [catch {.m1 post 40 40} msg] $msg [destroy .m1] } {1 {invalid command name "blork"} {}} -test winMenu-8.2 {TkpPostMenu} { +test winMenu-8.2 {TkpPostMenu} {pcOnly} { catch {destroy .m1} menu .m1 -postcommand "destroy .m1" list [.m1 post 40 40] [winfo exists .m1] } {{} 0} -test winMenu-8.3 {TkpPostMenu - popup menu} {menuInteractive} { +test winMenu-8.3 {TkpPostMenu - popup menu} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-8.3: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-8.4 {TkpPostMenu - menu button} {menuInteractive} { +test winMenu-8.4 {TkpPostMenu - menu button} {pcOnly userInteraction} { catch {destroy .mb} menubutton .mb -text test -menu .mb.menu menu .mb.menu @@ -338,7 +324,7 @@ test winMenu-8.4 {TkpPostMenu - menu button} {menuInteractive} { pack .mb list [tkMbPost .mb] [destroy .m1] } {{} {}} -test winMenu-8.5 {TkpPostMenu - update not pending} {menuInteractive} { +test winMenu-8.5 {TkpPostMenu - update not pending} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-8.5 - Hit ESCAPE." @@ -346,13 +332,13 @@ test winMenu-8.5 {TkpPostMenu - update not pending} {menuInteractive} { list [catch {.m1 post 40 40} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-9.1 {TkpMenuNewEntry} { +test winMenu-9.1 {TkpMenuNewEntry} {pcOnly} { catch {destroy .m1} menu .m1 list [catch {.m1 add command} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-10.1 {TkwinMenuProc} {menuInteractive} { +test winMenu-10.1 {TkwinMenuProc} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-10.1: Hit ESCAPE." @@ -360,46 +346,63 @@ test winMenu-10.1 {TkwinMenuProc} {menuInteractive} { } {{} {}} # Can't generate a WM_INITMENU without a Tk menu yet. -test winMenu-11.1 {TkWinHandleMenuEvent - WM_INITMENU} {menuInteractive} { +test winMenu-11.1 {TkWinHandleMenuEvent - WM_INITMENU} {pcOnly userInteraction} { catch {destroy .m1} catch {unset foo} menu .m1 -postcommand "set foo test" .m1 add command -label "winMenu-11.1: Hit ESCAPE." list [.m1 post 40 40] [set foo] [unset foo] [destroy .m1] } {test test {} {}} -test winMenu-11.2 {TkWinHandleMenuEvent - WM_COMMAND} {menuInteractive} { +test winMenu-11.2 {TkWinHandleMenuEvent - WM_COMMAND} {pcOnly userInteraction} { catch {destroy .m1} catch {unset foo} menu .m1 .m1 add checkbutton -variable foo -label "winMenu-11.2: Please select this menu item." list [.m1 post 40 40] [update] [set foo] [unset foo] [destroy .m1] } {{} {} 1 {} {}} +test winMenu-11.3 {TkWinHandleMenuEvent - WM_COMMAND} {pcOnly userInteraction} { + catch {destroy .m1} + catch {unset foo} + proc bgerror {args} { + global foo errorInfo + set foo [list $args $errorInfo] + } + menu .m1 + .m1 add command -command {error 1} -label "winMenu-11.2: Please select this menu item." + list [.m1 post 40 40] [update] [set foo] [unset foo] [destroy .m1] +} {{} {} {1 {1 + while executing +"error 1" + (menu invoke)}} {} {}} + # Can't test WM_MENUCHAR -test winMenu-11.3 {TkWinHandleMenuEvent - WM_MEASUREITEM} {menuInteractive} { +test winMenu-11.4 {TkWinHandleMenuEvent - WM_MEASUREITEM} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-11.3: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-11.4 {TkWinHandleMenuEvent - WM_MEASUREITEM} {menuInteractive} { +test winMenu-11.5 {TkWinHandleMenuEvent - WM_MEASUREITEM} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label "winMenu-11.4: Hit ESCAPE" -hidemargin 1 list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-11.5 {TkWinHandleMenuEvent - WM_DRAWITEM} {menuInteractive} { +test winMenu-11.6 {TkWinHandleMenuEvent - WM_DRAWITEM} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-11.5: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-11.6 {TkWinHandleMenuEvent - WM_DRAWITEM - item disabled} {menuInteractive} { +test winMenu-11.7 {TkWinHandleMenuEvent - WM_DRAWITEM - item disabled} \ + {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-11.6: Hit ESCAPE." -state disabled list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-11.7 {TkWinHandleMenuEvent - WM_INITMENU - not pending} {menuInteractive} { +test winMenu-11.8 {TkWinHandleMenuEvent - WM_INITMENU - not pending} \ + {pcOnly userInteraction} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label "winMenu-11.7: Hit ESCAPE" @@ -407,14 +410,14 @@ test winMenu-11.7 {TkWinHandleMenuEvent - WM_INITMENU - not pending} {menuIntera list [catch {.m1 post 40 40} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-12.1 {TkpSetWindowMenuBar} { +test winMenu-12.1 {TkpSetWindowMenuBar} {pcOnly} { catch {destroy .m1} . configure -menu "" menu .m1 .m1 add command -label foo list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [catch {destroy .m1} msg2] $msg2 } {0 {} {} 0 {}} -test winMenu-12.2 {TkpSetWindowMenuBar} { +test winMenu-12.2 {TkpSetWindowMenuBar} {pcOnly} { catch {destroy .m1} . configure -menu "" menu .m1 @@ -422,7 +425,7 @@ test winMenu-12.2 {TkpSetWindowMenuBar} { . configure -menu .m1 list [catch {. configure -menu ""} msg] $msg [catch {destroy .m1} msg2] $msg2 } {0 {} 0 {}} -test winMenu-12.3 {TkpSetWindowMenuBar - no update pending} { +test winMenu-12.3 {TkpSetWindowMenuBar - no update pending} {pcOnly} { catch {destroy .m1} . configure -menu "" menu .m1 -tearoff 0 @@ -431,48 +434,48 @@ test winMenu-12.3 {TkpSetWindowMenuBar - no update pending} { list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test winMenu-13.1 {TkpSetMainMenubar - nothing to do} {} {} +test winMenu-13.1 {TkpSetMainMenubar - nothing to do} {emptyTest pcOnly} {} {} -test winMenu-14.1 {GetMenuIndicatorGeometry} { +test winMenu-14.1 {GetMenuIndicatorGeometry} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test winMenu-14.2 {GetMenuIndicatorGeometry} { +test winMenu-14.2 {GetMenuIndicatorGeometry} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo -hidemargin 1 list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test winMenu-15.1 {GetMenuAccelGeometry} { +test winMenu-15.1 {GetMenuAccelGeometry} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add cascade -label foo -accel Ctrl+U list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test winMenu-15.2 {GetMenuAccelGeometry} { +test winMenu-15.2 {GetMenuAccelGeometry} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test winMenu-15.3 {GetMenuAccelGeometry} { +test winMenu-15.3 {GetMenuAccelGeometry} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo -accel "Ctrl+U" list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test winMenu-16.1 {GetTearoffEntryGeometry} {menuInteractive} { +test winMenu-16.1 {GetTearoffEntryGeometry} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-19.1: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-17.1 {GetMenuSeparatorGeometry} { +test winMenu-17.1 {GetMenuSeparatorGeometry} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add separator @@ -481,7 +484,7 @@ test winMenu-17.1 {GetMenuSeparatorGeometry} { # Currently, the only callers to DrawWindowsSystemBitmap want things # centered vertically, and either centered or right aligned horizontally. -test winMenu-18.1 {DrawWindowsSystemBitmap - center aligned} { +test winMenu-18.1 {DrawWindowsSystemBitmap - center aligned} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo @@ -489,7 +492,7 @@ test winMenu-18.1 {DrawWindowsSystemBitmap - center aligned} { set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-18.2 {DrawWindowsSystemBitmap - right aligned} { +test winMenu-18.2 {DrawWindowsSystemBitmap - right aligned} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add cascade -label foo @@ -497,21 +500,22 @@ test winMenu-18.2 {DrawWindowsSystemBitmap - right aligned} { list [update] [destroy .m1] } {{} {}} -test winMenu-19.1 {DrawMenuEntryIndicator - not checkbutton or radiobutton} { +test winMenu-19.1 {DrawMenuEntryIndicator - not checkbutton or radiobutton} \ + {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-19.2 {DrawMenuEntryIndicator - not selected} { +test winMenu-19.2 {DrawMenuEntryIndicator - not selected} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-19.3 {DrawMenuEntryIndicator - checkbutton} { +test winMenu-19.3 {DrawMenuEntryIndicator - checkbutton} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo @@ -519,7 +523,7 @@ test winMenu-19.3 {DrawMenuEntryIndicator - checkbutton} { set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-19.4 {DrawMenuEntryIndicator - radiobutton} { +test winMenu-19.4 {DrawMenuEntryIndicator - radiobutton} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add radiobutton -label foo @@ -527,7 +531,7 @@ test winMenu-19.4 {DrawMenuEntryIndicator - radiobutton} { set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-19.5 {DrawMenuEntryIndicator - disabled} { +test winMenu-19.5 {DrawMenuEntryIndicator - disabled} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo @@ -536,7 +540,7 @@ test winMenu-19.5 {DrawMenuEntryIndicator - disabled} { set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-19.6 {DrawMenuEntryIndicator - indicator not on} { +test winMenu-19.6 {DrawMenuEntryIndicator - indicator not on} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo -indicatoron 0 @@ -545,42 +549,44 @@ test winMenu-19.6 {DrawMenuEntryIndicator - indicator not on} { list [update] [destroy .m1] } {{} {}} -test winMenu-20.1 {DrawMenuEntryAccelerator - disabled} { +test winMenu-20.1 {DrawMenuEntryAccelerator - disabled} {pcOnly} { catch {destroy .m1} menu .m1 -disabledforeground red .m1 add command -label foo -accel "Ctrl+U" -state disabled set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-20.2 {DrawMenuEntryAccelerator - normal text} { +test winMenu-20.2 {DrawMenuEntryAccelerator - normal text} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo -accel "Ctrl+U" set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-20.3 {DrawMenuEntryAccelerator - disabled, no disabledforeground} { +test winMenu-20.3 {DrawMenuEntryAccelerator - disabled, no disabledforeground} \ + {pcOnly} { catch {destroy .m1} menu .m1 -disabledforeground "" .m1 add command -label foo -accel "Ctrl+U" -state disabled set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-20.4 {DrawMenuEntryAccelerator - cascade, drawArrow true} { +test winMenu-20.4 {DrawMenuEntryAccelerator - cascade, drawArrow true} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add cascade -label foo set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-20.5 {DrawMenuEntryAccelerator - cascade, drawArrow false} {menuInteractive} { +test winMenu-20.5 {DrawMenuEntryAccelerator - cascade, drawArrow false} \ + {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add cascade -label "winMenu-23.5: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-21.1 {DrawMenuSeparator} { +test winMenu-21.1 {DrawMenuSeparator} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add separator @@ -588,7 +594,7 @@ test winMenu-21.1 {DrawMenuSeparator} { list [update] [destroy .m1] } {{} {}} -test winMenu-22.1 {DrawMenuUnderline} { +test winMenu-22.1 {DrawMenuUnderline} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo -underline 0 @@ -596,24 +602,26 @@ test winMenu-22.1 {DrawMenuUnderline} { list [update] [destroy .m1] } {{} {}} -test winMenu-23.1 {Don't know how to test MenuKeyBindProc} {} {} -test winMenu-24.1 {TkpInitializeMenuBindings called at boot time} {} {} +test winMenu-23.1 {Don't know how to test MenuKeyBindProc} \ + {pcOnly emptyTest} {} {} +test winMenu-24.1 {TkpInitializeMenuBindings called at boot time} \ + {pcOnly emptyTest} {} {} -test winMenu-25.1 {DrawMenuEntryLabel - normal} { +test winMenu-25.1 {DrawMenuEntryLabel - normal} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-25.2 {DrawMenuEntryLabel - disabled with fg} { +test winMenu-25.2 {DrawMenuEntryLabel - disabled with fg} {pcOnly} { catch {destroy .m1} menu .m1 -disabledforeground red .m1 add command -label foo -state disabled set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-25.3 {DrawMenuEntryLabel - disabled with no fg} { +test winMenu-25.3 {DrawMenuEntryLabel - disabled with no fg} {pcOnly} { catch {destroy .m1} menu .m1 -disabledforeground "" .m1 add command -label foo -state disabled @@ -621,27 +629,27 @@ test winMenu-25.3 {DrawMenuEntryLabel - disabled with no fg} { list [update] [destroy .m1] } {{} {}} -test winMenu-26.1 {TkpComputeMenubarGeometry} { +test winMenu-26.1 {TkpComputeMenubarGeometry} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add cascade -label File list [. configure -menu .m1] [. configure -menu ""] [destroy .m1] } {{} {} {}} -test winMenu-27.1 {DrawTearoffEntry} {menuInteractive} { +test winMenu-27.1 {DrawTearoffEntry} {pcOnly userInteraction} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-24.4: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-28.1 {TkpConfigureMenuEntry - update pending} { +test winMenu-28.1 {TkpConfigureMenuEntry - update pending} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label Hello list [catch {.m1 add command -label Two} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-28.2 {TkpConfigureMenuEntry - update not pending} { +test winMenu-28.2 {TkpConfigureMenuEntry - update not pending} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label One @@ -649,7 +657,8 @@ test winMenu-28.2 {TkpConfigureMenuEntry - update not pending} { list [catch {.m1 add command -label Two} msg] $msg [destroy .m1] } {0 {} {}} -test winMenu-29.1 {TkpDrawMenuEntry - gc for active and not strict motif} { +test winMenu-29.1 {TkpDrawMenuEntry - gc for active and not strict motif} \ + {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -657,7 +666,8 @@ test winMenu-29.1 {TkpDrawMenuEntry - gc for active and not strict motif} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test winMenu-29.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} { +test winMenu-29.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} \ + {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo -activeforeground red @@ -665,7 +675,7 @@ test winMenu-29.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test winMenu-29.3 {TkpDrawMenuEntry - gc for active and strict motif} { +test winMenu-29.3 {TkpDrawMenuEntry - gc for active and strict motif} {pcOnly} { catch {destroy .m1} menu .m1 set tk_strictMotif 1 @@ -674,42 +684,44 @@ test winMenu-29.3 {TkpDrawMenuEntry - gc for active and strict motif} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] [set tk_strictMotif 0] } {{} {} 0} -test winMenu-29.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} { +test winMenu-29.4 \ + {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} \ + {pcOnly} { catch {destroy .m1} menu .m1 -disabledforeground blue .m1 add command -label foo -state disabled -background red set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} { +test winMenu-29.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} {pcOnly} { catch {destroy .m1} menu .m1 -disabledforeground blue .m1 add command -label foo -state disabled set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} { +test winMenu-29.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} {pcOnly} { catch {destroy .m1} menu .m1 -disabledforeground "" .m1 add command -label foo -state disabled set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.7 {TkpDrawMenuEntry - gc for normal - custom entry} { +test winMenu-29.7 {TkpDrawMenuEntry - gc for normal - custom entry} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo -foreground red set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.8 {TkpDrawMenuEntry - gc for normal} { +test winMenu-29.8 {TkpDrawMenuEntry - gc for normal} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.9 {TkpDrawMenuEntry - gc for indicator - custom entry} { +test winMenu-29.9 {TkpDrawMenuEntry - gc for indicator - custom entry} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo -selectcolor orange @@ -717,7 +729,7 @@ test winMenu-29.9 {TkpDrawMenuEntry - gc for indicator - custom entry} { set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.10 {TkpDrawMenuEntry - gc for indicator} { +test winMenu-29.10 {TkpDrawMenuEntry - gc for indicator} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo @@ -725,7 +737,7 @@ test winMenu-29.10 {TkpDrawMenuEntry - gc for indicator} { set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.11 {TkpDrawMenuEntry - border - custom entry} { +test winMenu-29.11 {TkpDrawMenuEntry - border - custom entry} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo -activebackground green @@ -733,7 +745,7 @@ test winMenu-29.11 {TkpDrawMenuEntry - border - custom entry} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test winMenu-29.12 {TkpDrawMenuEntry - border} { +test winMenu-29.12 {TkpDrawMenuEntry - border} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -741,7 +753,7 @@ test winMenu-29.12 {TkpDrawMenuEntry - border} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test winMenu-29.13 {TkpDrawMenuEntry - active border - strict motif} { +test winMenu-29.13 {TkpDrawMenuEntry - active border - strict motif} {pcOnly} { catch {destroy .m1} set tk_strictMotif 1 menu .m1 @@ -750,7 +762,7 @@ test winMenu-29.13 {TkpDrawMenuEntry - active border - strict motif} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] [set tk_strictMotif 0] } {{} {} 0} -test winMenu-29.14 {TkpDrawMenuEntry - active border - custom entry} { +test winMenu-29.14 {TkpDrawMenuEntry - active border - custom entry} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo -activeforeground yellow @@ -758,7 +770,7 @@ test winMenu-29.14 {TkpDrawMenuEntry - active border - custom entry} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test winMenu-29.15 {TkpDrawMenuEntry - active border} { +test winMenu-29.15 {TkpDrawMenuEntry - active border} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -766,35 +778,35 @@ test winMenu-29.15 {TkpDrawMenuEntry - active border} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test winMenu-29.16 {TkpDrawMenuEntry - font - custom entry} { +test winMenu-29.16 {TkpDrawMenuEntry - font - custom entry} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo -font "Helvectica 72" set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.17 {TkpDrawMenuEntry - font} { +test winMenu-29.17 {TkpDrawMenuEntry - font} {pcOnly} { catch {destroy .m1} menu .m1 -font "Courier 72" .m1 add command -label foo set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.18 {TkpDrawMenuEntry - separator} { +test winMenu-29.18 {TkpDrawMenuEntry - separator} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add separator set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.19 {TkpDrawMenuEntry - standard} { +test winMenu-29.19 {TkpDrawMenuEntry - standard} {pcOnly} { catch {destroy .mb} menu .m1 .m1 add command -label foo set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.20 {TkpDrawMenuEntry - disabled cascade item} { +test winMenu-29.20 {TkpDrawMenuEntry - disabled cascade item} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add cascade -label File -menu .m1.file @@ -804,7 +816,7 @@ test winMenu-29.20 {TkpDrawMenuEntry - disabled cascade item} { set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.21 {TkpDrawMenuEntry - indicator} { +test winMenu-29.21 {TkpDrawMenuEntry - indicator} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label winMenu-31.20 @@ -812,7 +824,7 @@ test winMenu-29.21 {TkpDrawMenuEntry - indicator} { set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-29.22 {TkpDrawMenuEntry - indicator} { +test winMenu-29.22 {TkpDrawMenuEntry - indicator} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label winMenu-31.21 -hidemargin 1 @@ -821,7 +833,7 @@ test winMenu-29.22 {TkpDrawMenuEntry - indicator} { list [update] [destroy .m1] } {{} {}} -test winMenu-30.1 {GetMenuLabelGeometry - image} { +test winMenu-30.1 {GetMenuLabelGeometry - image} {pcOnly} { catch {destroy .m1} catch {image delete image1} menu .m1 @@ -829,33 +841,33 @@ test winMenu-30.1 {GetMenuLabelGeometry - image} { .m1 add command -image image1 list [update idletasks] [destroy .m1] [image delete image1] } {{} {} {}} -test winMenu-30.2 {GetMenuLabelGeometry - bitmap} { +test winMenu-30.2 {GetMenuLabelGeometry - bitmap} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -bitmap questhead list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-30.3 {GetMenuLabelGeometry - no text} { +test winMenu-30.3 {GetMenuLabelGeometry - no text} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-30.4 {GetMenuLabelGeometry - text} { +test winMenu-30.4 {GetMenuLabelGeometry - text} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label "This is a test." list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-31.1 {DrawMenuEntryBackground} { +test winMenu-31.1 {DrawMenuEntryBackground} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo set tearoff [tkTearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test winMenu-31.2 {DrawMenuEntryBackground} { +test winMenu-31.2 {DrawMenuEntryBackground} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -864,25 +876,25 @@ test winMenu-31.2 {DrawMenuEntryBackground} { list [update] [destroy .m1] } {{} {}} -test winMenu-32.1 {TkpComputeStandardMenuGeometry - no entries} { +test winMenu-32.1 {TkpComputeStandardMenuGeometry - no entries} {pcOnly} { catch {destroy .m1} menu .m1 list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.2 {TkpComputeStandardMenuGeometry - one entry} { +test winMenu-32.2 {TkpComputeStandardMenuGeometry - one entry} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label "one" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.3 {TkpComputeStandardMenuGeometry - more than one entry} { +test winMenu-32.3 {TkpComputeStandardMenuGeometry - more than one entry} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label "one" .m1 add command -label "two" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.4 {TkpComputeStandardMenuGeometry - separator} { +test winMenu-32.4 {TkpComputeStandardMenuGeometry - separator} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add separator @@ -897,60 +909,65 @@ test winMenu-32.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unixOnly} { catch {tkMbPost .mb} list [update] [destroy .mb] } {{} {}} -test winMenu-32.6 {TkpComputeStandardMenuGeometry - standard label geometry} { +test winMenu-32.6 {TkpComputeStandardMenuGeometry - standard label geometry} \ + {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.7 {TkpComputeStandardMenuGeometry - different font for entry} { +test winMenu-32.7 {TkpComputeStandardMenuGeometry - different font for entry} \ + {pcOnly} { catch {destroy .m1} menu .m1 -font "Helvetica 12" .m1 add command -label "test" -font "Courier 12" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.8 {TkpComputeStandardMenuGeometry - second entry larger} { +test winMenu-32.8 {TkpComputeStandardMenuGeometry - second entry larger} \ + {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label "test" .m1 add command -label "test test" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.9 {TkpComputeStandardMenuGeometry - first entry larger} { +test winMenu-32.9 {TkpComputeStandardMenuGeometry - first entry larger} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label "test test" .m1 add command -label "test" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.10 {TkpComputeStandardMenuGeometry - accelerator} { +test winMenu-32.10 {TkpComputeStandardMenuGeometry - accelerator} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label "test" -accel "Ctrl+S" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.11 {TkpComputeStandardMenuGeometry - second accel larger} { +test winMenu-32.11 {TkpComputeStandardMenuGeometry - second accel larger} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label "test" -accel "1" .m1 add command -label "test" -accel "1 1" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.12 {TkpComputeStandardMenuGeometry - second accel smaller} { +test winMenu-32.12 {TkpComputeStandardMenuGeometry - second accel smaller} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label "test" -accel "1 1" .m1 add command -label "test" -accel "1" list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.13 {TkpComputeStandardMenuGeometry - indicator} { +test winMenu-32.13 {TkpComputeStandardMenuGeometry - indicator} {pcOnly} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label test .m1 invoke 1 list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.14 {TkpComputeStandardMenuGeometry - second indicator less or equal } { +test winMenu-32.14 \ + {TkpComputeStandardMenuGeometry - second indicator less or equal} \ + {pcOnly} { catch {destroy .m1} catch {image delete image1} image create test image1 @@ -961,7 +978,8 @@ test winMenu-32.14 {TkpComputeStandardMenuGeometry - second indicator less or eq .m1 invoke 2 list [update idletasks] [destroy .m1] [image delete image1] } {{} {} {}} -test winMenu-32.15 {TkpComputeStandardMenuGeometry - second indicator larger } {unixOnly} { +test winMenu-32.15 {TkpComputeStandardMenuGeometry - second indicator larger} \ + {unixOnly} { catch {destroy .m1} catch {image delete image1} image create test image1 @@ -972,12 +990,14 @@ test winMenu-32.15 {TkpComputeStandardMenuGeometry - second indicator larger } { .m1 invoke 2 list [update idletasks] [destroy .m1] [image delete image1] } {{} {} {}} -test winMenu-32.16 {TkpComputeStandardMenuGeometry - zero sized menus} { +test winMenu-32.16 {TkpComputeStandardMenuGeometry - zero sized menus} \ + {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.17 {TkpComputeStandardMenuGeometry - first column bigger} { +test winMenu-32.17 {TkpComputeStandardMenuGeometry - first column bigger} \ + {pcOnly} { catch {destroy .m1} menu .m1 .m1 add command -label one @@ -985,7 +1005,8 @@ test winMenu-32.17 {TkpComputeStandardMenuGeometry - first column bigger} { .m1 add command -label three -columnbreak 1 list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.18 {TkpComputeStandardMenuGeometry - second column bigger} { +test winMenu-32.18 {TkpComputeStandardMenuGeometry - second column bigger} \ + {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label one @@ -993,7 +1014,7 @@ test winMenu-32.18 {TkpComputeStandardMenuGeometry - second column bigger} { .m1 add command -label three list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-32.19 {TkpComputeStandardMenuGeometry - three columns} { +test winMenu-32.19 {TkpComputeStandardMenuGeometry - three columns} {pcOnly} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label one @@ -1005,14 +1026,14 @@ test winMenu-32.19 {TkpComputeStandardMenuGeometry - three columns} { list [update idletasks] [destroy .m1] } {{} {}} -test winMenu-33.1 {TkpNotifyTopLevelCreate - no menu yet} { +test winMenu-33.1 {TkpNotifyTopLevelCreate - no menu yet} {pcOnly} { catch {destroy .t2} catch {destroy .m1} toplevel .t2 -menu .m1 wm geometry .t2 +0+0 list [update idletasks] [destroy .t2] } {{} {}} -test winMenu-33.2 {TkpNotifyTopLevelCreate - menu} { +test winMenu-33.2 {TkpNotifyTopLevelCreate - menu} {pcOnly} { catch {destroy .t2} catch {destroy .m1} menu .m1 @@ -1025,6 +1046,21 @@ test winMenu-33.2 {TkpNotifyTopLevelCreate - menu} { list [update idletasks] [destroy .m1] [destroy .t2] } {{} {} {}} -test winMenu-34.1 {TkpMenuInit called at boot time} {} {} +test winMenu-34.1 {TkpMenuInit called at boot time} {emptyTest pcOnly} {} {} +# cleanup deleteWindows +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tk/tests/winSend.test b/tk/tests/winSend.test new file mode 100644 index 00000000000..54cec4ce8ff --- /dev/null +++ b/tk/tests/winSend.test @@ -0,0 +1,428 @@ +# This file is a Tcl script to test out the "send" command and the +# 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. +# All rights reserved. +# +# RCS: @(#) $Id$ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {$tcl_platform(platform) != "windows"} { + puts "skipping: Windows only tests..." + ::tcltest::cleanupTests + return +} + +if {[info commands send] != "send"} { + puts "skipping: Unimplemented send command" + ::tcltest::cleanupTests + return +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +set currentInterps [winfo interps] + +if {[catch {exec tktest &}] == 1} { + puts "Could not run winSend.test because another instance of tktest could not be loaded." + ::tcltest::cleanupTests + return; +} + +# Compute a script that will load Tk into a child interpreter. + +foreach pkg [info loaded] { + if {[lindex $pkg 1] == "Tk"} { + set loadTk "load $pkg" + break + } +} + +# Procedure to create a new application with a given name and class. + +proc newApp {name {safe {}}} { + global loadTk + if {[string compare $safe "-safe"] == 0} { + interp create -safe $name + } else { + interp create $name + } + $name eval [list set argv [list -name $name]] + catch {eval $loadTk $name} +} + +# Wait until the child application has launched. + +while {[llength [winfo interps]] == [llength $currentInterps]} { +} + +# Now find an interp to send to +set newInterps [winfo interps] +foreach interp $newInterps { + if {[lsearch -exact $currentInterps $interp] < 0} { + break + } +} + +# Now we have found our interpreter we are going to send to. Make sure that +# it works first. +if {[catch {send $interp {console hide; update}}] == 1} { + puts "Could not send to child interpreter $interp" + ::tcltest::cleanupTests + return +} + +# setting up dde server is done when the first interp is created and +# cannot be tested very easily. +test winSend-1.1 {Tk_SetAppName - changing name of interp} { + newApp testApp + list [testApp eval tk appname testApp2] [interp delete testApp] +} {testApp2 {}} +test winSend-1.2 {Tk_SetAppName - changing name - not front of linked list} { + newApp testApp + newApp testApp2 + list [testApp eval tk appname testApp3] [interp delete testApp] [interp delete testApp2] +} {testApp3 {} {}} +test winSend-1.3 {Tk_SetAppName - unique name - no conflicts} { + newApp testApp + list [testApp eval tk appname testApp] [interp delete testApp] +} {testApp {}} +test winSend-1.4 {Tk_SetAppName - unique name - one conflict} { + newApp testApp + newApp foobar + list [foobar eval tk appname testApp] [interp delete foobar] [interp delete testApp] +} {{testApp #2} {} {}} +test winSend-1.5 {Tk_SetAppName - unique name - one conflict} { + newApp testApp + newApp foobar + newApp blaz + foobar eval tk appname testApp + list [blaz eval tk appname testApp] [interp delete foobar] [interp delete testApp] [interp delete blaz] +} {{testApp #3} {} {} {}} +test winSend-1.6 {Tk_SetAppName - safe interps} { + newApp testApp -safe + list [catch {testApp eval send testApp {set foo a}} msg] $msg [interp delete testApp] +} {1 {invalid command name "send"} {}} + +test winSend-2.1 {Tk_SendObjCmd - # of args} { + list [catch {send tktest} msg] $msg +} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} +test winSend-2.1 {Tk_SendObjCmd: arguments} { + list [catch {send -bogus tktest} msg] $msg +} {1 {bad option "-bogus": must be -async, -displayof, or --}} +test winSend-2.1 {Tk_SendObjCmd: arguments} { + list [catch {send -async bogus foo} msg] $msg +} {1 {no registered server named "bogus"}} +test winSend-2.1 {Tk_SendObjCmd: arguments} { + list [catch {send -displayof . bogus foo} msg] $msg +} {1 {no registered server named "bogus"}} +test winSend-2.1 {Tk_SendObjCmd: arguments} { + list [catch {send -- -bogus foo} msg] $msg +} {1 {no registered server named "-bogus"}} +test winSend-2.2 {Tk_SendObjCmd - sending to ourselves} { + list [send [tk appname] {set foo a}] +} {a} +test winSend-2.3 {Tk_SendObjCmd - sending to ourselves in a different interpreter} { + newApp testApp + list [catch {send testApp {set foo b}} msg] $msg [interp delete testApp] +} {0 b {}} +test winSend-2.4 {Tk_SendObjCmd - sending to ourselves in a different interp with errors} { + newApp testApp + list [catch {send testApp {expr 2 / 0}} msg] $msg $errorCode $errorInfo [interp delete testApp] +} "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr 2 / 0\"\n invoked from within\n\"send testApp {expr 2 / 0}\"} {}" +test winSend-2.5 {Tk_SendObjCmd - sending to another app async} { + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + list [catch {send -async $interp {set foo a}} msg] $msg +} {0 {}} +test winSend-2.6 {Tk_SendObjCmd - sending to another app sync - no error} { + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + list [catch {send $interp {set foo a}} msg] $msg +} {0 a} +test winSend-2.7 {Tk_SendObjCmd - sending to another app - error} { + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + list [catch {send $interp {expr 2 / 0}} msg] $msg $errorCode $errorInfo +} "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr 2 / 0\"\n invoked from within\n\"send \$interp {expr 2 / 0}\"}" + +test winSend-3.1 {TkGetInterpNames} { + set origLength [llength $currentInterps] + set newLength [llength [winfo interps]] + expr {($newLength - 2) == $origLength} +} {1} + +test winSend-4.1 {DeleteProc - changing name of app} { + newApp a + list [a eval tk appname foo] [interp delete a] +} {foo {}} +test winSend-4.2 {DeleteProc - normal} { + newApp a + list [interp delete a] +} {{}} + +test winSend-5.1 {ExecuteRemoteObject - no error} { + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + list [send $interp {send [tk appname] {expr 2 / 1}}] +} {2} +test winSend-5.2 {ExecuteRemoteObject - error} { + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + list [catch {send $interp {send [tk appname] {expr 2 / 0}}} msg] $msg +} {1 {divide by zero}} + +test winSend-6.1 {SendDDEServer - XTYP_CONNECT} { + set foo "Hello, World" + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + set command "dde request Tk [tk appname] foo" + list [catch "send \{$interp\} \{$command\}" msg] $msg +} {0 {Hello, World}} +test winSend-6.2 {SendDDEServer - XTYP_CONNECT_CONFIRM} { + set foo "Hello, World" + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + set command "dde request Tk [tk appname] foo" + list [catch "send \{$interp\} \{$command\}" msg] $msg +} {0 {Hello, World}} +test winSend-6.3 {SendDDEServer - XTYP_DISCONNECT} { + set foo "Hello, World" + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + set command "dde request Tk [tk appname] foo" + list [catch "send \{$interp\} \{$command\}" msg] $msg +} {0 {Hello, World}} +test winSend-6.4 {SendDDEServer - XTYP_REQUEST variable} { + set foo "Hello, World" + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + set command "dde request Tk [tk appname] foo" + list [catch "send \{$interp\} \{$command\}" msg] $msg +} {0 {Hello, World}} +test winSend-6.5 {SendDDEServer - XTYP_REQUEST array} { + catch {unset foo} + set foo(test) "Hello, World" + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + set command "dde request Tk [tk appname] foo(test)" + list [catch "send \{$interp\} \{$command\}" msg] $msg [catch {unset foo}] +} {0 {Hello, World} 0} +test winSend-6.6 {SendDDEServer - XTYP_REQUEST return results} { + set foo 3 + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + set command "send [tk appname] {expr $foo + 1}" + list [catch "send \{$interp\} \{$command\}" msg] $msg +} {0 4} +test winSend-6.7 {SendDDEServer - XTYP_EXECUTE} { + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + set command "send [tk appname] {expr 4 / 2}" + list [catch "send \{$interp\} \{$command\}" msg] $msg +} {0 2} +test winSend-6.8 {SendDDEServer - XTYP_WILDCONNECT} { + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + set command "dde services Tk {}" + list [catch "send \{$interp\} \{$command\}"] +} {0} + +test winSend-7.1 {DDEExitProc} { + newApp testApp + list [interp delete testApp] +} {{}} + +test winSend-8.1 {SendDdeConnect} { + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + list [send $interp {set tk foo}] +} {foo} + +test winSend-9.1 {SetDDEError} { + list [catch {dde execute Tk foo {set foo hello}} msg] $msg +} {1 {dde command failed}} + +test winSend-10.1 {Tk_DDEObjCmd - wrong num args} { + list [catch {dde} msg] $msg +} {1 {wrong # args: should be "dde ?-async? serviceName topicName value"}} +test winSend-10.2 {Tk_DDEObjCmd - unknown subcommand} { + list [catch {dde foo} msg] $msg +} {1 {bad command "foo": must be execute, request, or services}} +test winSend-10.3 {Tk_DDEObjCmd - execute - wrong num args} { + list [catch {dde execute} msg] $msg +} {1 {wrong # args: should be "dde execute ?-async? serviceName topicName value"}} +test winSend-10.4 {Tk_DDEObjCmd - execute - wrong num args} { + list [catch {dde execute 3 4 5 6 7} msg] $msg +} {1 {wrong # args: should be "dde execute ?-async? serviceName topicName value"}} +test winSend-10.5 {Tk_DDEObjCmd - execute async - wrong num args} { + list [catch {dde execute -async} msg] $msg +} {1 {wrong # args: should be "dde execute ?-async? serviceName topicName value"}} +test winSend-10.6 {Tk_DDEObjCmd - request - wrong num args} { + list [catch {dde request} msg] $msg +} {1 {wrong # args: should be "dde request serviceName topicName value"}} +test winSend-10.7 {Tk_DDEObjCmd - services wrong num args} { + list [catch {dde services} msg] $msg +} {1 {wrong # args: should be "dde services serviceName topicName"}} +test winSend-10.8 {Tk_DDEObjCmd - null service name} { + list [catch {dde services {} {tktest #2}}] +} {0} +test winSend-10.9 {Tk_DDEObjCmd - null topic name} { + list [catch {dde services {Tk} {}}] +} {0} +test winSend-10.10 {Tk_DDEObjCmd - execute - nothing to execute} { + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + list [catch {dde execute Tk $interp {}} msg] $msg +} {1 {cannot execute null data}} +test winSend-10.11 {Tk_DDEObjCmd - execute - no such conversation} { + list [catch {dde execute Tk foo {set foo hello}} msg] $msg +} {1 {dde command failed}} +test winSend-10.12 {Tk_DDEObjCmd - execute - async} { + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + list [catch {dde execute -async Tk $interp {set foo hello}} msg] $msg +} {0 {}} +test winSend-10.13 {Tk_DDEObjCmd - execute} { + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + list [catch {dde execute Tk $interp {set foo goodbye}} msg] $msg +} {0 {}} +test winSend-10.14 {Tk_DDEObjCmd - request - nothing to request} { + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + list [catch {dde request Tk $interp {}} msg] $msg +} {1 {cannot request value of null data}} +test winSend-10.15 {Tk_DDEObjCmd - request - invalid interp} { + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + list [catch {dde request Tk foo foo} msg] $msg +} {1 {dde command failed}} +test winSend-10.16 {Tk_DDEObjCmd - invalid variable} { + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + send $interp {unset foo} + list [catch {dde request Tk $interp foo} msg] $msg +} {1 {remote server cannot handle this command}} +test winSend-10.17 {Tk_DDEObjCmd - valid variable} { + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch $currentInterps $interp] < 0} { + break + } + } + send $interp {set foo winSend-10.17} + list [catch {dde request Tk $interp foo} msg] $msg +} {0 winSend-10.17} +test winSend-10.18 {Tk_DDEObjCmd - services} { + set currentService [list Tk [tk appname]] + list [catch {dde services Tk {}} msg] [expr [lsearch $msg $currentService] >= 0] +} {0 1} + +# Get rid of the other app and all of its interps + +set newInterps [winfo interps] +while {[llength $newInterps] != [llength $currentInterps]} { + foreach interp $newInterps { + if {[lsearch -exact $currentInterps $interp] < 0} { + catch {send $interp exit} + set newInterps [winfo interps] + break + } + } +} + +# cleanup +::tcltest::cleanupTests +return + diff --git a/tk/tests/winWm.test b/tk/tests/winWm.test index abe478eba2c..e3d15ea5529 100644 --- a/tk/tests/winWm.test +++ b/tk/tests/winWm.test @@ -6,18 +6,13 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1996 by Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {$tcl_platform(platform) != "windows"} { - return -} - -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -41,7 +36,7 @@ update set menuheight [expr $menuheight - [winfo y .t]] destroy .t -test winWm-1.1 {TkWmMapWindow} { +test winWm-1.1 {TkWmMapWindow} {pcOnly} { toplevel .t wm override .t 1 wm geometry .t +0+0 @@ -50,7 +45,7 @@ test winWm-1.1 {TkWmMapWindow} { destroy .t set result } {0 0} -test winWm-1.2 {TkWmMapWindow} { +test winWm-1.2 {TkWmMapWindow} {pcOnly} { toplevel .t wm transient .t . update @@ -62,7 +57,7 @@ test winWm-1.2 {TkWmMapWindow} { destroy .t set msg } {can't iconify ".t": it is a transient} -test winWm-1.3 {TkWmMapWindow} { +test winWm-1.3 {TkWmMapWindow} {pcOnly} { toplevel .t update toplevel .t2 @@ -71,7 +66,7 @@ test winWm-1.3 {TkWmMapWindow} { destroy .t .t2 set result } 1 -test winWm-1.4 {TkWmMapWindow} { +test winWm-1.4 {TkWmMapWindow} {pcOnly} { toplevel .t wm geometry .t +10+10 update @@ -82,7 +77,7 @@ test winWm-1.4 {TkWmMapWindow} { destroy .t .t2 set result } {10 40} -test winWm-1.5 {TkWmMapWindow} { +test winWm-1.5 {TkWmMapWindow} {pcOnly} { toplevel .t wm iconify .t update @@ -91,7 +86,7 @@ test winWm-1.5 {TkWmMapWindow} { set result } iconic -test winWm-2.1 {TkpWmSetState} { +test winWm-2.1 {TkpWmSetState} {pcOnly} { toplevel .t wm geometry .t 150x50+10+10 update @@ -105,7 +100,7 @@ test winWm-2.1 {TkpWmSetState} { destroy .t set result } {normal iconic normal} -test winWm-2.2 {TkpWmSetState} { +test winWm-2.2 {TkpWmSetState} {pcOnly} { toplevel .t wm geometry .t 150x50+10+10 update @@ -122,7 +117,24 @@ test winWm-2.2 {TkpWmSetState} { destroy .t set result } {normal withdrawn iconic normal} -test winWm-2.3 {TkpWmSetState} { +test winWm-2.2 {TkpWmSetState} {pcOnly} { + toplevel .t + wm geometry .t 150x50+10+10 + update + set result [wm state .t] + wm state .t withdrawn + update + lappend result [wm state .t] + wm state .t iconic + update + lappend result [wm state .t] + wm state .t normal + update + lappend result [wm state .t] + destroy .t + set result +} {normal withdrawn iconic normal} +test winWm-2.4 {TkpWmSetState} {pcOnly} { set result {} toplevel .t wm geometry .t 150x50+10+10 @@ -141,8 +153,7 @@ test winWm-2.3 {TkpWmSetState} { set result } {{normal 150x50+10+10} {iconic 150x50+10+10} {iconic 150x50+10+10} {normal 200x50+10+10}} - -test winWm-3.1 {ConfigureTopLevel: window geometry propagation} { +test winWm-3.1 {ConfigureTopLevel: window geometry propagation} {pcOnly} { toplevel .t wm geometry .t +0+0 button .t.b @@ -161,7 +172,7 @@ test winWm-3.1 {ConfigureTopLevel: window geometry propagation} { set x } 1 -test winWm-4.1 {ConfigureTopLevel: menu resizing} { +test winWm-4.1 {ConfigureTopLevel: menu resizing} {pcOnly} { set result {} toplevel .t frame .t.f -width 150 -height 50 -bg red @@ -178,7 +189,7 @@ test winWm-4.1 {ConfigureTopLevel: menu resizing} { set result } [expr $menuheight + 1] -test winWm-5.1 {UpdateGeometryInfo: menu resizing} { +test winWm-5.1 {UpdateGeometryInfo: menu resizing} {pcOnly} { set result {} toplevel .t frame .t.f -width 150 -height 50 -bg red @@ -197,7 +208,7 @@ test winWm-5.1 {UpdateGeometryInfo: menu resizing} { destroy .t set result } {50 50 50} -test winWm-5.2 {UpdateGeometryInfo: menu resizing} { +test winWm-5.2 {UpdateGeometryInfo: menu resizing} {pcOnly} { set result {} toplevel .t frame .t.f -width 150 -height 50 -bg red @@ -217,3 +228,19 @@ test winWm-5.2 {UpdateGeometryInfo: menu resizing} { destroy .t set result } {50 50 0} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tk/tests/window.test b/tk/tests/window.test index fca332f2cb4..6d9371ba14d 100644 --- a/tk/tests/window.test +++ b/tk/tests/window.test @@ -2,14 +2,13 @@ # tkWindow.c. It is organized in the standard fashion for Tcl tests. # # Copyright (c) 1995 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -80,13 +79,12 @@ test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} { destroy .f } {} -if {[string compare testmenubar [info commands testmenubar]] != 0} { - puts "This application hasn't been compiled with the testmenubar command," - puts "therefore I am skipping all of these tests." - return -} +# Some tests require the testmenubar command +set ::tcltest::testConfig(testmenubar) \ + [expr {[info commands testmenubar] != {}}] -test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} unixOnly { +test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ + {unixOnly testmenubar} { catch {destroy .t} toplevel .t -width 300 -height 200 wm geometry .t +0+0 @@ -96,7 +94,8 @@ test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} unix update # If stacking order isn't handle properly, generates an X error. } {} -test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} unixOnly { +test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} \ + {unixOnly testmenubar} { catch {destroy .t} toplevel .t -width 300 -height 200 wm geometry .t +0+0 @@ -110,11 +109,11 @@ test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} unix # If stacking order isn't handled properly, generates an X error. } {} -test window-4.1 {Tk_NameToWindow procedure} { +test window-4.1 {Tk_NameToWindow procedure} {testmenubar} { catch {destroy .t} list [catch {winfo geometry .t} msg] $msg } {1 {bad window path name ".t"}} -test window-4.2 {Tk_NameToWindow procedure} { +test window-4.2 {Tk_NameToWindow procedure} {testmenubar} { catch {destroy .t} frame .t -width 100 -height 50 place .t -x 10 -y 10 @@ -122,7 +121,8 @@ test window-4.2 {Tk_NameToWindow procedure} { list [catch {winfo geometry .t} msg] $msg } {0 100x50+10+10} -test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} unixOnly { +test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ + {unixOnly testmenubar} { catch {destroy .t} toplevel .t -width 300 -height 200 wm geometry .t +0+0 @@ -135,3 +135,19 @@ test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} unix update # If stacking order isn't handled properly, generates an X error. } {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tk/tests/winfo.test b/tk/tests/winfo.test index f2cb6250119..12af58b4f6f 100644 --- a/tk/tests/winfo.test +++ b/tk/tests/winfo.test @@ -3,14 +3,13 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # # RCS: @(#) $Id$ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } foreach i [winfo children .] { @@ -19,6 +18,10 @@ foreach i [winfo children .] { wm geometry . {} raise . +# Some tests require the testwrapper command +set ::tcltest::testConfig(testwrapper) \ + [expr {[info commands testwrapper] != {}}] + # eatColors -- # Creates a toplevel window and allocates enough colors in it to # use up all the slots in the colormap. @@ -88,32 +91,33 @@ test winfo-2.7 {"winfo atom" command} { winfo atomname -displayof . 2 } SECONDARY -if {([winfo depth .] == 8) && ([winfo visual .] == "pseudocolor")} { - test winfo-3.1 {"winfo colormapfull" command} { - list [catch {winfo colormapfull} msg] $msg - } {1 {wrong # args: should be "winfo colormapfull window"}} - test winfo-3.2 {"winfo colormapfull" command} { - list [catch {winfo colormapfull a b} msg] $msg - } {1 {wrong # args: should be "winfo colormapfull window"}} - test winfo-3.3 {"winfo colormapfull" command} { - list [catch {winfo colormapfull foo} msg] $msg - } {1 {bad window path name "foo"}} - test winfo-3.4 {"winfo colormapfull" command} {macOrUnix} { - eatColors .t {-colormap new} - set result [list [winfo colormapfull .] [winfo colormapfull .t]] - .t.c delete 34 - lappend result [winfo colormapfull .t] - .t.c create rectangle 30 30 80 80 -fill #441739 - lappend result [winfo colormapfull .t] - .t.c create rectangle 40 40 90 90 -fill #ffeedd - lappend result [winfo colormapfull .t] - destroy .t.c - lappend result [winfo colormapfull .t] - } {0 1 0 0 1 0} - catch {destroy .t} -} +# Some tests require the "pseudocolor" visual class. +set ::tcltest::testConfig(pseudocolor) \ + [expr {([winfo depth .] == 8) && ([winfo visual .] == "pseudocolor")}] +test winfo-3.1 {"winfo colormapfull" command} {pseudocolor} { + list [catch {winfo colormapfull} msg] $msg +} {1 {wrong # args: should be "winfo colormapfull window"}} +test winfo-3.2 {"winfo colormapfull" command} {pseudocolor} { + list [catch {winfo colormapfull a b} msg] $msg +} {1 {wrong # args: should be "winfo colormapfull window"}} +test winfo-3.3 {"winfo colormapfull" command} {pseudocolor} { + list [catch {winfo colormapfull foo} msg] $msg +} {1 {bad window path name "foo"}} +test winfo-3.4 {"winfo colormapfull" command} {macOrUnix pseudocolor} { + eatColors .t {-colormap new} + set result [list [winfo colormapfull .] [winfo colormapfull .t]] + .t.c delete 34 + lappend result [winfo colormapfull .t] + .t.c create rectangle 30 30 80 80 -fill #441739 + lappend result [winfo colormapfull .t] + .t.c create rectangle 40 40 90 90 -fill #ffeedd + lappend result [winfo colormapfull .t] + destroy .t.c + lappend result [winfo colormapfull .t] +} {0 1 0 0 1 0} catch {destroy .t} + toplevel .t -width 550 -height 400 frame .t.f -width 80 -height 60 -bd 2 -relief raised place .t.f -x 50 -y 50 @@ -206,15 +210,9 @@ test winfo-7.6 {"winfo pathname" command} { test winfo-7.7 {"winfo pathname" command} { winfo pathname -displayof .b [winfo id .] } {.} - -if {[string compare testwrapper [info commands testwrapper]] == 0} { - puts "This application hasn't been compiled with the testwrapper command," - puts "therefore I am skipping all of these tests." - - test winfo-7.8 {"winfo pathname" command} {unixOnly} { - winfo pathname [testwrapper .] - } {} -} +test winfo-7.8 {"winfo pathname" command} {unixOnly testwrapper} { + winfo pathname [testwrapper .] +} {} test winfo-8.1 {"winfo pointerx" command} { catch [winfo pointerx .b] @@ -317,7 +315,7 @@ proc MakeEmbed {} { pack .emb.b -expand yes -fill both update } -test winfo-13.1 {root coordinates of embedded toplevel} {macOrUnix} { +test winfo-13.1 {root coordinates of embedded toplevel} { MakeEmbed set z [expr [winfo rootx .emb] == [winfo rootx .con] && \ [winfo rooty .emb] == [winfo rooty .con]] @@ -325,8 +323,8 @@ test winfo-13.1 {root coordinates of embedded toplevel} {macOrUnix} { destroy .con set z } {1} -test winfo-13.2 {destroying embedded toplevel} {macOrUnix} { - catch {destroy .emb} +test winfo-13.2 {destroying embedded toplevel} { + destroy .emb update expr [winfo exists .emb.b] || [winfo exists .con] } 0 @@ -335,7 +333,7 @@ foreach i [winfo children .] { destroy $i } -test winfo-13.3 {destroying container window} {macOrUnix} { +test winfo-13.3 {destroying container window} { MakeEmbed destroy .con update @@ -349,7 +347,7 @@ foreach i [winfo children .] { destroy $i } -test winfo-13.4 {[winfo containing] with embedded windows} {macOrUnix} { +test winfo-13.4 {[winfo containing] with embedded windows} { MakeEmbed button .b pack .b -expand yes -fill both @@ -365,3 +363,8 @@ test winfo-13.4 {[winfo containing] with embedded windows} {macOrUnix} { foreach i [winfo children .] { catch {destroy $i} } + +# cleanup +::tcltest::cleanupTests +return + diff --git a/tk/tests/wm.test b/tk/tests/wm.test new file mode 100644 index 00000000000..e6963548346 --- /dev/null +++ b/tk/tests/wm.test @@ -0,0 +1,674 @@ +# This file is a Tcl script to test out Tk's interactions with +# 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-1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) wm.test 1.31 96/03/01 11:36:58 + +if {[string compare test [info procs test]] == 1} { + source defs +} + +proc sleep ms { + global x + after $ms {set x 1} + tkwait variable x +} + +set i 1 +foreach geom {+20+80 +80+20 +0+0} { + catch {destroy .t} + test wm-1.$i {initial window position} { + toplevel .t -width 200 -height 150 + wm geom .t $geom + update + wm geom .t + } 200x150$geom + incr i +} + +# The tests below are tricky because window managers don't all move +# windows correctly. Try one motion and compute the window manager's +# error, then factor this error into the actual tests. In other words, +# this just makes sure that things are consistent between moves. + +set i 1 +catch {destroy .t} +toplevel .t -width 100 -height 150 +wm geom .t +200+200 +update +wm geom .t +150+150 +update +scan [wm geom .t] %dx%d+%d+%d width height x y +set xerr [expr 150-$x] +set yerr [expr 150-$y] +foreach geom {+20+80 +80+20 +0+0 -0-0 +0-0 -0+0 -10-5 -10+5 +10-5} { + test wm-2.$i {moving window while mapped} { + wm geom .t $geom + update + scan [wm geom .t] %dx%d%1s%d%1s%d width height xsign x ysign y + format "%s%d%s%d" $xsign [expr $x$xsign$xerr] $ysign \ + [expr $y$ysign$yerr] + } $geom + incr i +} + +set i 1 +foreach geom {+20+80 +80+20 +0+0 -0-0 +0-0 -0+0 -10-5 -10+5 +10-5} { + test wm-3.$i {moving window while iconified} { + wm iconify .t + sleep 200 + wm geom .t $geom + update + wm deiconify .t + scan [wm geom .t] %dx%d%1s%d%1s%d width height xsign x ysign y + format "%s%d%s%d" $xsign [expr $x$xsign$xerr] $ysign \ + [expr $y$ysign$yerr] + } $geom + incr i +} + +set i 1 +foreach geom {+20+80 +100+40 +0+0} { + test wm-4.$i {moving window while withdrawn} { + wm withdraw .t + sleep 200 + wm geom .t $geom + update + wm deiconify .t + wm geom .t + } 100x150$geom + incr i +} + +test wm-5.1 {compounded state changes} {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +100+100 + update + wm withdraw .t + wm deiconify .t + list [winfo ismapped .t] [wm state .t] +} {1 normal} +test wm-5.2 {compounded state changes} {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +100+100 + update + wm withdraw .t + wm deiconify .t + wm withdraw .t + list [winfo ismapped .t] [wm state .t] +} {0 withdrawn} +test wm-5.3 {compounded state changes} {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +100+100 + update + wm iconify .t + wm deiconify .t + wm iconify .t + wm deiconify .t + list [winfo ismapped .t] [wm state .t] +} {1 normal} +test wm-5.4 {compounded state changes} {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +100+100 + update + wm iconify .t + wm deiconify .t + wm iconify .t + list [winfo ismapped .t] [wm state .t] +} {0 iconic} +test wm-5.5 {compounded state changes} {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +100+100 + update + wm iconify .t + wm withdraw .t + list [winfo ismapped .t] [wm state .t] +} {0 withdrawn} +test wm-5.6 {compounded state changes} {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +100+100 + update + wm iconify .t + wm withdraw .t + wm deiconify .t + list [winfo ismapped .t] [wm state .t] +} {1 normal} +test wm-5.7 {compounded state changes} {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +100+100 + update + wm withdraw .t + wm iconify .t + list [winfo ismapped .t] [wm state .t] +} {0 iconic} + +catch {destroy .t} +toplevel .t -width 200 -height 100 +wm geom .t +10+10 +wm minsize .t 1 1 +update +test wm-6.1 {size changes} { + .t config -width 180 -height 150 + update + wm geom .t +} 180x150+10+10 +test wm-6.2 {size changes} { + wm geom .t 250x60 + .t config -width 170 -height 140 + update + wm geom .t +} 250x60+10+10 +test wm-6.3 {size changes} { + wm geom .t 250x60 + .t config -width 170 -height 140 + wm geom .t {} + update + wm geom .t +} 170x140+10+10 +test wm-6.4 {size changes} {nonPortable} { + wm minsize .t 1 1 + update + puts stdout "Please resize window \"t\" with the mouse (but don't move it!)," + puts -nonewline stdout "then hit return: " + flush stdout + gets stdin + update + set width [winfo width .t] + set height [winfo height .t] + .t config -width 230 -height 110 + update + incr width -[winfo width .t] + incr height -[winfo height .t] + wm geom .t {} + update + set w2 [winfo width .t] + set h2 [winfo height .t] + .t config -width 114 -height 261 + update + list $width $height $w2 $h2 [wm geom .t] +} {0 0 230 110 114x261+10+10} + +test wm-7.1 {window initially withdrawn} { + catch {destroy .t} + toplevel .t -width 100 -height 30 + wm geometry .t +0+0 + wm withdraw .t + sleep 200 + set result [winfo ismapped .t] + wm deiconify .t + list $result [winfo ismapped .t] +} {0 1} +test wm-7.2 {window initially withdrawn} { + catch {destroy .t} + toplevel .t -width 100 -height 30 + wm geometry .t +0+0 + wm withdraw .t + wm deiconify .t + sleep 200 + winfo ismapped .t +} 1 + +test wm-8.1 {window initially iconic} { + catch {destroy .t} + toplevel .t -width 100 -height 30 + wm geometry .t +0+0 + wm title .t 1 + wm iconify .t + update idletasks + list [winfo ismapped .t] [wm state .t] +} {0 iconic} + +# I don't know why the wait below is needed, but without it the test +# fails under twm. +sleep 200 + +test wm-8.2 {window initially iconic} {nonPortable} { + catch {destroy .t} + toplevel .t -width 100 -height 30 + wm geometry .t +0+0 + wm title .t 2 + wm iconify .t + update idletasks + wm withdraw .t + wm deiconify .t + list [winfo ismapped .t] [wm state .t] +} {1 normal} + +catch {destroy .m} +menu .m +foreach i {{Test label} Another {Yet another} {Last label}} { + .m add command -label $i +} +.m post 100 200 +test wm-9.1 {override_redirect and Tk_MoveTopLevelWindow} { + list [winfo ismapped .m] [wm state .m] [winfo x .m] [winfo y .m] +} {1 normal 100 200} +.m post 150 210 +test wm-9.2 {override_redirect and Tk_MoveTopLevelWindow} { + list [winfo ismapped .m] [wm state .m] [winfo x .m] [winfo y .m] +} {1 normal 150 210} +.m unpost +test wm-9.3 {override_redirect and Tk_MoveTopLevelWindow} { + list [winfo ismapped .m] +} 0 +destroy .m +catch {destroy .t} + +test wm-10.1 {icon windows} { + catch {destroy .t} + catch {destroy .icon} + toplevel .t -width 100 -height 30 + wm geometry .t +0+0 + toplevel .icon -width 50 -height 50 -bg red + wm iconwindow .t .icon + list [catch {wm iconify .icon} msg] $msg +} {1 {can't iconify .icon: it is an icon for .icon}} +test wm-10.2 {icon windows} { + catch {destroy .t} + catch {destroy .icon} + toplevel .t -width 100 -height 30 + wm geometry .t +0+0 + toplevel .icon -width 50 -height 50 -bg red + wm iconwindow .t .icon + list [catch {wm deiconify .icon} msg] $msg +} {1 {can't deiconify .icon: it is an icon for .icon}} +test wm-10.3 {icon windows} { + catch {destroy .t} + catch {destroy .icon} + toplevel .t -width 100 -height 30 + wm geometry .t +0+0 + toplevel .icon -width 50 -height 50 -bg red + wm iconwindow .t .icon + list [catch {wm withdraw .icon} msg] $msg +} {1 {can't withdraw .icon: it is an icon for .t}} +test wm-10.4 {icon windows} { + catch {destroy .t} + toplevel .t -width 100 -height 30 + list [catch {wm iconwindow} msg] $msg +} {1 {wrong # args: should be "wm option window ?arg ...?"}} +test wm-10.5 {icon windows} { + catch {destroy .t} + toplevel .t -width 100 -height 30 + list [catch {wm iconwindow .t b c} msg] $msg +} {1 {wrong # arguments: must be "wm iconwindow window ?pathName?"}} +test wm-10.6 {icon windows} { + catch {destroy .t} + catch {destroy .icon} + toplevel .t -width 100 -height 30 + wm geom .t +0+0 + set result [wm iconwindow .t] + toplevel .icon -width 50 -height 50 -bg red + wm iconwindow .t .icon + lappend result [wm iconwindow .t] [wm state .icon] + wm iconwindow .t {} + lappend result [wm iconwindow .t] [wm state .icon] + update + lappend result [winfo ismapped .t] [winfo ismapped .icon] + wm iconify .t + update + lappend result [winfo ismapped .t] [winfo ismapped .icon] +} {.icon icon {} withdrawn 1 0 0 0} +test wm-10.7 {icon windows} { + catch {destroy .t} + toplevel .t -width 100 -height 30 + list [catch {wm iconwindow .t .gorp} msg] $msg +} {1 {bad window path name ".gorp"}} +test wm-10.8 {icon windows} { + catch {destroy .t} + toplevel .t -width 100 -height 30 + frame .t.icon -width 50 -height 50 -bg red + list [catch {wm iconwindow .t .t.icon} msg] $msg +} {1 {can't use .t.icon as icon window: not at top level}} +test wm-10.9 {icon windows} { + catch {destroy .t} + catch {destroy .icon} + toplevel .t -width 100 -height 30 + wm geom .t +0+0 + toplevel .icon -width 50 -height 50 -bg red + toplevel .icon2 -width 50 -height 50 -bg green + wm iconwindow .t .icon + set result "[wm iconwindow .t] [wm state .icon] [wm state .icon2]" + wm iconwindow .t .icon2 + lappend result [wm iconwindow .t] [wm state .icon] [wm state .icon2] +} {.icon icon normal .icon2 withdrawn icon} +catch {destroy .icon2} +test wm-10.10 {icon windows} { + catch {destroy .t} + catch {destroy .icon} + toplevel .icon -width 50 -height 50 -bg red + wm geom .icon +0+0 + update + set result [winfo ismapped .icon] + toplevel .t -width 100 -height 30 + wm geom .t +0+0 + wm iconwindow .t .icon + after 500 {set x 1} + tkwait variable x + lappend result [winfo ismapped .t] [winfo ismapped .icon] +} {1 1 0} +test wm-10.11 {icon windows} {nonPortable} { + # This test is non-portable because some window managers will + # destroy an icon window when it's associated window is destroyed. + + catch {destroy .t} + catch {destroy .icon} + toplevel .t -width 100 -height 30 + toplevel .icon -width 50 -height 50 -bg red + wm geom .t +0+0 + wm iconwindow .t .icon + update + set result "[wm state .icon] [winfo ismapped .t] [winfo ismapped .icon]" + destroy .t + wm geom .icon +0+0 + update + lappend result [winfo ismapped .icon] [wm state .icon] + wm deiconify .icon + update + lappend result [winfo ismapped .icon] [wm state .icon] +} {icon 1 0 0 withdrawn 1 normal} + +test wm-11.1 {colormapwindows} { + catch {destroy .t} + toplevel .t -width 200 -height 200 -colormap new + wm geom .t +0+0 + frame .t.a -width 100 -height 30 + frame .t.b -width 100 -height 30 -colormap new + pack .t.a .t.b -side top + update + set x [wm colormapwindows .t] + frame .t.c -width 100 -height 30 -colormap new + pack .t.c -side top + update + list $x [wm colormapwindows .t] +} {{.t.b .t} {.t.b .t.c .t}} +test wm-11.2 {colormapwindows} { + list [catch {wm colormapwindows . 1 2} msg] $msg +} {1 {wrong # arguments: must be "wm colormapwindows window ?windowList?"}} +test wm-11.3 {colormapwindows} { + list [catch {wm col . "a \{"} msg] $msg +} {1 {unmatched open brace in list}} +test wm-11.4 {colormapwindows} { + list [catch {wm colormapwindows . foo} msg] $msg +} {1 {bad window path name "foo"}} +test wm-11.5 {colormapwindows} { + catch {destroy .t} + toplevel .t -width 200 -height 200 -colormap new + wm geom .t +0+0 + frame .t.a -width 100 -height 30 + frame .t.b -width 100 -height 30 + frame .t.c -width 100 -height 30 + pack .t.a .t.b .t.c -side top + wm colormapwindows .t {.t.c .t .t.a} + wm colormapwindows .t +} {.t.c .t .t.a} +test wm-11.6 {colormapwindows} { + catch {destroy .t} + toplevel .t -width 200 -height 200 + wm geom .t +0+0 + frame .t.a -width 100 -height 30 + frame .t.b -width 100 -height 30 + frame .t.c -width 100 -height 30 + pack .t.a .t.b .t.c -side top + wm colormapwindows .t {.t.b .t.a} + wm colormapwindows .t +} {.t.b .t.a} +test wm-11.7 {colormapwindows} { + catch {destroy .t} + toplevel .t -width 200 -height 200 -colormap new + wm geom .t +0+0 + set x [wm colormapwindows .t] + wm colormapwindows .t {} + list $x [wm colormapwindows .t] +} {{} {}} + +catch {destroy .t} +catch {destroy .icon} + +toplevel .t -width 100 -height 50 +wm geom .t +0+0 +update +test wm-12.1 {Tk_WmCmd procedure, "maxsize" option} { + list [catch {wm maxsize} msg] $msg +} {1 {wrong # args: should be "wm option window ?arg ...?"}} +test wm-12.2 {Tk_WmCmd procedure, "maxsize" option} { + list [catch {wm maxsize . a} msg] $msg +} {1 {wrong # arguments: must be "wm maxsize window ?width height?"}} +test wm-12.3 {Tk_WmCmd procedure, "maxsize" option} { + list [catch {wm maxsize . a b c} msg] $msg +} {1 {wrong # arguments: must be "wm maxsize window ?width height?"}} +test wm-12.4 {Tk_WmCmd procedure, "maxsize" option} {nonPortable} { + wm maxsize .t +} {1137 870} +test wm-12.5 {Tk_WmCmd procedure, "maxsize" option} { + list [catch {wm maxsize . x 100} msg] $msg +} {1 {expected integer but got "x"}} +test wm-12.6 {Tk_WmCmd procedure, "maxsize" option} { + list [catch {wm maxsize . 100 bogus} msg] $msg +} {1 {expected integer but got "bogus"}} +test wm-12.7 {Tk_WmCmd procedure, "maxsize" option} { + wm maxsize .t 200 150 + wm maxsize .t +} {200 150} +test wm-12.8 {Tk_WmCmd procedure, "maxsize" option} {nonPortable} { + # Not portable, because some window managers let applications override + # minsize and maxsize. + + wm maxsize .t 200 150 + wm geom .t 300x200 + update + list [winfo width .t] [winfo height .t] +} {200 150} +destroy .t + +toplevel .t -width 300 -height 200 +wm geom .t +0+0 +update +test wm-13.1 {Tk_WmCmd procedure, "minsize" option} { + list [catch {wm minsize} msg] $msg +} {1 {wrong # args: should be "wm option window ?arg ...?"}} +test wm-13.2 {Tk_WmCmd procedure, "minsize" option} { + list [catch {wm minsize . a} msg] $msg +} {1 {wrong # arguments: must be "wm minsize window ?width height?"}} +test wm-13.3 {Tk_WmCmd procedure, "minsize" option} { + list [catch {wm minsize . a b c} msg] $msg +} {1 {wrong # arguments: must be "wm minsize window ?width height?"}} +test wm-13.4 {Tk_WmCmd procedure, "minsize" option} { + wm minsize .t +} {1 1} +test wm-13.5 {Tk_WmCmd procedure, "minsize" option} { + list [catch {wm minsize . x 100} msg] $msg +} {1 {expected integer but got "x"}} +test wm-13.6 {Tk_WmCmd procedure, "minsize" option} { + list [catch {wm minsize . 100 bogus} msg] $msg +} {1 {expected integer but got "bogus"}} +test wm-13.7 {Tk_WmCmd procedure, "minsize" option} { + wm minsize .t 200 150 + wm minsize .t +} {200 150} +test wm-13.8 {Tk_WmCmd procedure, "minsize" option} {nonPortable} { + # Not portable, because some window managers let applications override + # minsize and maxsize. + + wm minsize .t 150 100 + wm geom .t 50x50 + update + list [winfo width .t] [winfo height .t] +} {150 100} +test wm-13.9 {Tk_WmCmd procedure, "resizable" option} { + list [catch {wm resizable . a} msg] $msg +} {1 {wrong # arguments: must be "wm resizable window ?width height?"}} +test wm-13.10 {Tk_WmCmd procedure, "resizable" option} { + list [catch {wm resizable . a b c} msg] $msg +} {1 {wrong # arguments: must be "wm resizable window ?width height?"}} +test wm-13.11 {Tk_WmCmd procedure, "resizable" option} { + list [catch {wm resizable .foo a b c} msg] $msg +} {1 {bad window path name ".foo"}} +test wm-13.12 {Tk_WmCmd procedure, "resizable" option} { + list [catch {wm resizable . x 1} msg] $msg +} {1 {expected boolean value but got "x"}} +test wm-13.13 {Tk_WmCmd procedure, "resizable" option} { + list [catch {wm resizable . 0 gorp} msg] $msg +} {1 {expected boolean value but got "gorp"}} +test wm-13.14 {Tk_WmCmd procedure, "resizable" option} { + catch {destroy .t2} + toplevel .t2 -width 200 -height 100 + wm geom .t2 +0+0 + set result "" + lappend result [wm resizable .t2] + wm resizable .t2 1 0 + lappend result [wm resizable .t2] + wm resizable .t2 no off + lappend result [wm resizable .t2] + wm resizable .t2 false true + lappend result [wm resizable .t2] +} {{1 1} {1 0} {0 0} {0 1}} +destroy .t2 + +test wm-14.1 {TopLevelReqProc procedure, resize causes window to move} \ + {nonPortable} { + catch {destroy .t} + toplevel .t -width 200 -height 200 + wm geom .t +0+0 + update + wm geom .t -0-0 + update + set x [winfo x .t] + set y [winfo y .t] + .t configure -width 300 -height 150 + update + list [expr [winfo x .t] - $x] [expr [winfo y .t] - $y] \ + [winfo width .t] [winfo height .t] +} {-100 50 300 150} + +test wm-15.1 {Tk_SetGrid procedure, set grid dimensions before turning on grid} {nonPortable} { + catch {destroy .t} + toplevel .t + wm geometry .t 30x10+0+0 + listbox .t.l -height 20 -width 20 -setgrid 1 + pack .t.l -fill both -expand 1 + update + wm geometry .t +} {30x10+0+0} +test wm-15.2 {Tk_SetGrid procedure, turning on grid when dimensions already set} { + catch {destroy .t} + toplevel .t + wm geometry .t 200x100+0+0 + listbox .t.l -height 20 -width 20 + pack .t.l -fill both -expand 1 + update + .t.l configure -setgrid 1 + update + wm geometry .t +} {20x20+0+0} + +test wm-16.1 {WaitForEvent procedure, use of modal timeout} { + catch {destroy .t} + toplevel .t -width 200 -height 200 + wm geom .t +0+0 + update + wm iconify .t + set x no + after 0 {set x yes} + wm deiconify .t + set result $x + update + list $result $x +} {no yes} + +test wm-17.1 {ParseGeometry procedure, resize causes window to move} { + catch {destroy .t} + toplevel .t -width 200 -height 200 + wm geom .t +0+0 + update + wm geom .t -0-0 + update + set x [winfo x .t] + set y [winfo y .t] + wm geometry .t 150x300 + update + list [expr [winfo x .t] - $x] [expr [winfo y .t] - $y] \ + [winfo width .t] [winfo height .t] +} {50 -100 150 300} + +test wm-18.1 {TkWmAddToColormapWindows procedure} { + catch {destroy .t} + toplevel .t -width 200 -height 200 -colormap new -relief raised -bd 2 + wm geom .t +0+0 + update + wm colormap .t +} {} +test wm-18.2 {TkWmAddToColormapWindows procedure} { + catch {destroy .t} + toplevel .t -colormap new -relief raised -bd 2 + wm geom .t +0+0 + frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f + update + wm colormap .t +} {.t.f .t} +test wm-18.3 {TkWmAddToColormapWindows procedure} { + catch {destroy .t} + toplevel .t -colormap new + wm geom .t +0+0 + frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f + frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f2 + update + wm colormap .t +} {.t.f .t.f2 .t} +test wm-18.4 {TkWmAddToColormapWindows procedure} { + catch {destroy .t} + toplevel .t -colormap new + wm geom .t +0+0 + frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f + update + wm colormapwindows .t .t.f + frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f2 + update + wm colormapwindows .t +} {.t.f} + +test wm-19.1 {TkWmRemoveFromColormapWindows procedure} { + catch {destroy .t} + toplevel .t -colormap new + wm geom .t +0+0 + frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f + frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f2 + update + destroy .t.f2 + wm colormap .t +} {.t.f .t} +test wm-19.2 {TkWmRemoveFromColormapWindows procedure} { + catch {destroy .t} + toplevel .t -colormap new + wm geom .t +0+0 + frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f + frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2 + pack .t.f2 + update + wm colormapwindows .t .t.f2 + destroy .t.f2 + wm colormap .t +} {} + +catch {destroy .t} +concat {} diff --git a/tk/tests/xmfbox.test b/tk/tests/xmfbox.test new file mode 100644 index 00000000000..fd20939c959 --- /dev/null +++ b/tk/tests/xmfbox.test @@ -0,0 +1,156 @@ +# xmfbox.test -- +# +# This file is a Tcl script to test the file dialog that's used +# when the tk_strictMotif flag is set. Because the file dialog +# 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. +# All rights reserved. +# +# RCS: @(#) $Id$ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +set testPWD [pwd] +eval destroy [winfo children .] +catch {unset foo} + +catch {unset data foo} + +proc cleanup {} { + global testPWD + + set err0 [catch { + cd $testPWD + } msg0] + + set err1 [catch { + if [file exists ./~nosuchuser1] { + file delete ./~nosuchuser1 + } + } msg1] + + set err2 [catch { + if [file exists ./~nosuchuser2] { + file delete ./~nosuchuser2 + } + } msg2] + + set err3 [catch { + if [file exists ./~nosuchuser3] { + file delete ./~nosuchuser3 + } + } msg3] + + set err4 [catch { + if [file exists ./~nosuchuser4] { + file delete ./~nosuchuser4 + } + } msg4] + + if {$err0 || $err1 || $err2 || $err3 || $err4} { + error [list $msg0 $msg1 $msg2 $msg3 $msg4] + } + catch {unset foo} + catch {destroy .foo} +} + +test xmfbox-1.1 {tkMotifFDialog_Create, -parent switch} {unixOnly} { + catch {unset foo} + set x [tkMotifFDialog_Create foo open {-parent .}] + catch {destroy $x} + set x +} .foo + +test xmfbox-1.2 {tkMotifFDialog_Create, -parent switch} {unixOnly} { + catch {unset foo} + toplevel .bar + wm geometry .bar +0+0 + set x [tkMotifFDialog_Create foo open {-parent .bar}] + catch {destroy $x} + catch {destroy .bar} + set x +} .bar.foo + +test xmfbox-2.1 {tkMotifFDialog_InterpFilter, ~ in dir names} {unixOnly} { + cleanup + file mkdir ./~nosuchuser1 + set x [tkMotifFDialog_Create foo open {}] + $::tk::dialog::file::foo(fEnt) delete 0 end + $::tk::dialog::file::foo(fEnt) insert 0 [pwd]/~nosuchuser1 + set kk [tkMotifFDialog_InterpFilter $x] +} [list $testPWD/~nosuchuser1 *] + +test xmfbox-2.2 {tkMotifFDialog_InterpFilter, ~ in file names} {unixOnly} { + cleanup + close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] + set x [tkMotifFDialog_Create foo open {}] + $::tk::dialog::file::foo(fEnt) delete 0 end + $::tk::dialog::file::foo(fEnt) insert 0 [pwd]/~nosuchuser1 + set kk [tkMotifFDialog_InterpFilter $x] +} [list $testPWD ./~nosuchuser1] + +test xmfbox-2.3 {tkMotifFDialog_Update, ~ in file names} {unixOnly} { + cleanup + close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] + set x [tkMotifFDialog_Create foo open {}] + $::tk::dialog::file::foo(fEnt) delete 0 end + $::tk::dialog::file::foo(fEnt) insert 0 [pwd]/~nosuchuser1 + tkMotifFDialog_InterpFilter $x + tkMotifFDialog_Update $x + $::tk::dialog::file::foo(fList) get end +} ~nosuchuser1 + +test xmfbox-2.4 {tkMotifFDialog_LoadFile, ~ in file names} {unixOnly} { + cleanup + close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] + set x [tkMotifFDialog_Create foo open {}] + set i [lsearch [$::tk::dialog::file::foo(fList) get 0 end] ~nosuchuser1] + expr {$i >= 0} +} 1 + +test xmfbox-2.5 {tkMotifFDialog_BrowseFList, ~ in file names} {unixOnly} { + cleanup + close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] + set x [tkMotifFDialog_Create foo open {}] + set i [lsearch [$::tk::dialog::file::foo(fList) get 0 end] ~nosuchuser1] + $::tk::dialog::file::foo(fList) selection clear 0 end + $::tk::dialog::file::foo(fList) selection set $i + tkMotifFDialog_BrowseFList $x + $::tk::dialog::file::foo(sEnt) get +} $testPWD/~nosuchuser1 + +test xmfbox-2.5 {tkMotifFDialog_ActivateFList, ~ in file names} {unixOnly} { + cleanup + close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] + set x [tkMotifFDialog_Create foo open {}] + set i [lsearch [$::tk::dialog::file::foo(fList) get 0 end] ~nosuchuser1] + $::tk::dialog::file::foo(fList) selection clear 0 end + $::tk::dialog::file::foo(fList) selection set $i + tkMotifFDialog_BrowseFList $x + tkMotifFDialog_ActivateFList $x + list $::tk::dialog::file::foo(selectPath) \ + $::tk::dialog::file::foo(selectFile) $tkPriv(selectFilePath) +} [list $testPWD ~nosuchuser1 $testPWD/~nosuchuser1] + +# cleanup +cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + |