summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 01:51:06 (GMT)
committerstanton <stanton>1999-04-16 01:51:06 (GMT)
commit03656f44f81469f459031fa3a4a7b09c8bc77712 (patch)
tree31378e81bd58f8c726fc552d6b30cbf3ca07497b /tests
parent404fc236f34304df53b7e44bc7971d786b87d453 (diff)
downloadtk-03656f44f81469f459031fa3a4a7b09c8bc77712.zip
tk-03656f44f81469f459031fa3a4a7b09c8bc77712.tar.gz
tk-03656f44f81469f459031fa3a4a7b09c8bc77712.tar.bz2
* Merged 8.1 branch into the main trunk
Diffstat (limited to 'tests')
-rw-r--r--tests/README33
-rw-r--r--tests/all84
-rw-r--r--tests/all.tcl78
-rw-r--r--tests/arc.tcl15
-rw-r--r--tests/bell.test32
-rw-r--r--tests/bevel.tcl15
-rw-r--r--tests/bgerror.test28
-rw-r--r--tests/bind.test123
-rw-r--r--tests/bitmap.test116
-rw-r--r--tests/border.test195
-rw-r--r--tests/bugs.tcl15
-rw-r--r--tests/butGeom.tcl15
-rw-r--r--tests/butGeom2.tcl15
-rw-r--r--tests/button.test400
-rw-r--r--tests/canvImg.test33
-rw-r--r--tests/canvPs.test30
-rw-r--r--tests/canvPsArc.tcl15
-rw-r--r--tests/canvPsBmap.tcl15
-rw-r--r--tests/canvPsGrph.tcl15
-rw-r--r--tests/canvPsText.tcl15
-rw-r--r--tests/canvRect.test30
-rw-r--r--tests/canvText.test31
-rw-r--r--tests/canvWind.test29
-rw-r--r--tests/canvas.test42
-rw-r--r--tests/clipboard.test28
-rw-r--r--tests/clrpick.test107
-rw-r--r--tests/cmap.tcl15
-rw-r--r--tests/cmds.test28
-rw-r--r--tests/color.test162
-rw-r--r--tests/config.test839
-rw-r--r--tests/cursor.test116
-rw-r--r--tests/defs372
-rw-r--r--tests/defs.tcl990
-rw-r--r--tests/entry.test329
-rw-r--r--tests/event.test28
-rw-r--r--tests/filebox.test77
-rw-r--r--tests/focus.test217
-rw-r--r--tests/focusTcl.test28
-rw-r--r--tests/font.test873
-rw-r--r--tests/frame.test28
-rw-r--r--tests/geometry.test30
-rw-r--r--tests/get.test97
-rw-r--r--tests/grid.test67
-rw-r--r--tests/id.test29
-rw-r--r--tests/image.test33
-rw-r--r--tests/imgBmap.test28
-rw-r--r--tests/imgPPM.test28
-rw-r--r--tests/imgPhoto.test40
-rw-r--r--tests/listbox.test28
-rw-r--r--tests/macEmbed.test75
-rw-r--r--tests/macFont.test212
-rw-r--r--tests/macMenu.test33
-rw-r--r--tests/macWinMenu.test92
-rw-r--r--tests/macscrollbar.test37
-rw-r--r--tests/main.test32
-rw-r--r--tests/menu.test500
-rw-r--r--tests/menuDraw.test50
-rw-r--r--tests/menubut.test48
-rw-r--r--tests/msgbox.test74
-rw-r--r--tests/obj.test52
-rw-r--r--tests/oldpack.test30
-rw-r--r--tests/option.test42
-rw-r--r--tests/pack.test29
-rw-r--r--tests/place.test29
-rw-r--r--tests/raise.test29
-rw-r--r--tests/safe.test59
-rw-r--r--tests/scale.test50
-rw-r--r--tests/scrollbar.test37
-rw-r--r--tests/select.test47
-rw-r--r--tests/send.test53
-rw-r--r--tests/text.test52
-rw-r--r--tests/textBTree.test30
-rw-r--r--tests/textDisp.test34
-rw-r--r--tests/textImage.test37
-rw-r--r--tests/textIndex.test527
-rw-r--r--tests/textMark.test31
-rw-r--r--tests/textTag.test40
-rw-r--r--tests/textWind.test29
-rw-r--r--tests/tk.test30
-rw-r--r--tests/unixButton.test35
-rw-r--r--tests/unixEmbed.test39
-rw-r--r--tests/unixFont.test55
-rw-r--r--tests/unixMenu.test42
-rw-r--r--tests/unixSend.test679
-rw-r--r--tests/unixWm.test93
-rw-r--r--tests/util.test29
-rw-r--r--tests/visual81
-rw-r--r--tests/visual.test28
-rw-r--r--tests/visual_bb.test109
-rw-r--r--tests/winButton.test50
-rw-r--r--tests/winClipboard.test39
-rw-r--r--tests/winDialog.test335
-rw-r--r--tests/winFont.test91
-rw-r--r--tests/winMenu.test356
-rw-r--r--tests/winSend.test428
-rw-r--r--tests/winWm.test55
-rw-r--r--tests/window.test48
-rw-r--r--tests/winfo.test102
-rw-r--r--tests/xmfbox.test153
99 files changed, 8632 insertions, 2671 deletions
diff --git a/tests/README b/tests/README
index 23fc4a5..facea75 100644
--- a/tests/README
+++ b/tests/README
@@ -1,30 +1,7 @@
-Tk Test Suite
---------------
+README -- Tk test suite design document.
-RCS: @(#) $Id: README,v 1.2 1998/09/14 18:23:41 stanton Exp $
+RCS: @(#) $Id: README,v 1.3 1999/04/16 01:51:33 stanton Exp $
-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.
-
-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.
+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.
diff --git a/tests/all b/tests/all
deleted file mode 100644
index 9a473ef..0000000
--- a/tests/all
+++ /dev/null
@@ -1,84 +0,0 @@
-# This file contains a top-level script to run all of the Tcl
-# tests. Execute it by invoking "source all" when running tclTest
-# in this directory.
-#
-# RCS: @(#) $Id: all,v 1.6 1999/04/16 01:25:55 stanton Exp $
-
-set TESTS_DIR [file join [pwd] [file dirname [info script]]]
-source [file join $TESTS_DIR defs]
-set currentDir [pwd]
-
-catch {array set flag $argv}
-set requiredSourceFiles [list arc.tcl bugs.tcl butGeom2.tcl \
- canvPsBmap.tcl canvPsText.tcl bevel.tcl butGeom.tcl \
- canvPsArc.tcl canvPsGrph.tcl cmap.tcl filebox.test \
- option.file1 option.file2 visual README defs]
-
-#
-# Set the TMP_DIR to pwd or the arg of -tmpdir, if given.
-#
-
-if {[info exists flag(-tmpdir)]} {
- set TMP_DIR $flag(-tmpdir)
- if {![file exists $TMP_DIR]} {
- if {[catch {file mkdir $TMP_DIR} msg]} {
- error "bad argument \"$flag(-tmpdir)\" to -tmpdir:\n$msg"
- }
- file mkdir $TMP_DIR
- } elseif {![file isdir $TMP_DIR]} {
- error "bad argument \"$flag(-tmpdir)\" to -tmpdir:\n$TMP_DIR is not a directory"
- }
- if {[string compare [file pathtype $TMP_DIR] absolute] != 0} {
- set TMP_DIR [file join [pwd] $TMP_DIR]
- }
- cd $TMP_DIR
-}
-
-#
-# copy each required source file to the current dir (if it's not already there).
-#
-
-if {[string compare $TESTS_DIR [pwd]] != 0} {
-
- foreach file $requiredSourceFiles {
- if {![file exists $file]} {
- catch {file copy [file join $TESTS_DIR $file] .}
- }
- }
-}
-
-if {$tcl_platform(os) == "Win32s"} {
- set globPattern [file join $TESTS_DIR *.tes]
-} else {
- set globPattern [file join $TESTS_DIR *.test]
-}
-
-foreach file [lsort [glob $globPattern]] {
- 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
- }
-}
-
-# remove the required source files from the current dir.
-if {[info exists TMP_DIR]} {
- foreach file $requiredSourceFiles {
- catch {file delete -force $file}
- }
- cd $currentDir
-}
-
-# exit if Tk is running in non-interactive mode.
-# Don't exit at the end of all the tests on the Mac, since
-# this destroys the window that contains the test results...
-
-if {([info exists tk_version] && !$tcl_interactive) \
- || [string compare $tcl_platform(platform) macintosh]} {
- catch {destroy .}
- exit
-}
diff --git a/tests/all.tcl b/tests/all.tcl
new file mode 100644
index 0000000..fc2b89d
--- /dev/null
+++ b/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: all.tcl,v 1.2 1999/04/16 01:51:33 stanton Exp $
+
+if {[lsearch ::tcltest [namespace children]] == -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/tests/arc.tcl b/tests/arc.tcl
index 33056f5..4315361 100644
--- a/tests/arc.tcl
+++ b/tests/arc.tcl
@@ -1,7 +1,7 @@
# This file creates a visual test for arcs. It is part of the Tk
# visual test suite, which is invoked via the "visual" script.
#
-# RCS: @(#) $Id: arc.tcl,v 1.2 1998/09/14 18:23:42 stanton Exp $
+# RCS: @(#) $Id: arc.tcl,v 1.3 1999/04/16 01:51:33 stanton Exp $
catch {destroy .t}
toplevel .t
@@ -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/tests/bell.test b/tests/bell.test
index 0c88769..e8c2040 100644
--- a/tests/bell.test
+++ b/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.
+# 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.
-#
-# RCS: @(#) $Id: bell.test,v 1.3 1998/09/30 19:01:22 rjohnson Exp $
+# RCS: @(#) $Id: bell.test,v 1.4 1999/04/16 01:51:33 stanton Exp $
-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/tests/bevel.tcl b/tests/bevel.tcl
index 815590a..ae6039a 100644
--- a/tests/bevel.tcl
+++ b/tests/bevel.tcl
@@ -2,7 +2,7 @@
# widgets. It is part of the Tk visual test suite, which is invoked
# via the "visual" script.
#
-# RCS: @(#) $Id: bevel.tcl,v 1.2 1998/09/14 18:23:42 stanton Exp $
+# RCS: @(#) $Id: bevel.tcl,v 1.3 1999/04/16 01:51:33 stanton Exp $
catch {destroy .t}
toplevel .t
@@ -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/tests/bgerror.test b/tests/bgerror.test
index b718483..cf6489b 100644
--- a/tests/bgerror.test
+++ b/tests/bgerror.test
@@ -2,17 +2,15 @@
# 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.
-#
-# RCS: @(#) $Id: bgerror.test,v 1.2 1998/09/14 18:23:42 stanton Exp $
+# RCS: @(#) $Id: bgerror.test,v 1.3 1999/04/16 01:51:33 stanton Exp $
-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/tests/bind.test b/tests/bind.test
index e3e5f51..a62b7a1 100644
--- a/tests/bind.test
+++ b/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.
+# 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.
-#
-# RCS: @(#) $Id: bind.test,v 1.4 1998/10/10 00:30:37 rjohnson Exp $
+# RCS: @(#) $Id: bind.test,v 1.5 1999/04/16 01:51:34 stanton Exp $
-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}
@@ -254,7 +252,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
@@ -1470,8 +1468,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"}
@@ -1539,10 +1540,10 @@ test bind-16.43 {ExpandPercents procedure} {
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 +1612,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
@@ -1971,73 +1971,73 @@ test bind-22.16 {HandleEventGenerate} {
} {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"}}}}
+ {<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]}}
{<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]}}
@@ -2045,7 +2045,7 @@ foreach check {
{<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]}}
@@ -2053,7 +2053,7 @@ foreach check {
{<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}
@@ -2069,19 +2069,19 @@ foreach check {
{<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]}}
{<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}
@@ -2090,16 +2090,16 @@ foreach check {
{<<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,7 +2107,7 @@ 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]}}
@@ -2119,7 +2119,7 @@ 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]}}
@@ -2131,9 +2131,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, -width, -window, -x, or -y}}}}
} {
set event [lindex $check 0]
test bind-22.$i "HandleEventGenerate: options $event [lindex $check 2]" {
@@ -2244,7 +2244,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
@@ -2557,3 +2567,20 @@ test bind-31.2 {MouseWheel events} {
destroy .b
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/bitmap.test b/tests/bitmap.test
new file mode 100644
index 0000000..2049840
--- /dev/null
+++ b/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: bitmap.test,v 1.2 1999/04/16 01:51:34 stanton Exp $
+
+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/tests/border.test b/tests/border.test
new file mode 100644
index 0000000..e59b405
--- /dev/null
+++ b/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: border.test,v 1.2 1999/04/16 01:51:34 stanton Exp $
+
+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/tests/bugs.tcl b/tests/bugs.tcl
index 880e216..e1492b4 100644
--- a/tests/bugs.tcl
+++ b/tests/bugs.tcl
@@ -8,7 +8,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: bugs.tcl,v 1.2 1998/09/14 18:23:43 stanton Exp $
+# RCS: @(#) $Id: bugs.tcl,v 1.3 1999/04/16 01:51:34 stanton Exp $
if {[info procs test] != "test"} {
source defs
@@ -28,3 +28,16 @@ test crash-1.1 {color} {
. configure -bg rgb:345
set foo ""
} {}
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/butGeom.tcl b/tests/butGeom.tcl
index 7f124df..da91d08 100644
--- a/tests/butGeom.tcl
+++ b/tests/butGeom.tcl
@@ -1,7 +1,7 @@
# This file creates a visual test for button layout. It is part of
# the Tk visual test suite, which is invoked via the "visual" script.
#
-# RCS: @(#) $Id: butGeom.tcl,v 1.2 1998/09/14 18:23:43 stanton Exp $
+# RCS: @(#) $Id: butGeom.tcl,v 1.3 1999/04/16 01:51:34 stanton Exp $
catch {destroy .t}
toplevel .t
@@ -113,3 +113,16 @@ proc config {option value} {
$w configure $option $value
}
}
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/butGeom2.tcl b/tests/butGeom2.tcl
index 36122ea..9dc223e 100644
--- a/tests/butGeom2.tcl
+++ b/tests/butGeom2.tcl
@@ -1,7 +1,7 @@
# This file creates a visual test for button layout. It is part of
# the Tk visual test suite, which is invoked via the "visual" script.
#
-# RCS: @(#) $Id: butGeom2.tcl,v 1.2 1998/09/14 18:23:43 stanton Exp $
+# RCS: @(#) $Id: butGeom2.tcl,v 1.3 1999/04/16 01:51:34 stanton Exp $
catch {destroy .t}
toplevel .t
@@ -111,3 +111,16 @@ proc config-but {option value} {
$w configure $option $value
}
}
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/button.test b/tests/button.test
index 1e36dd2..309c795 100644
--- a/tests/button.test
+++ b/tests/button.test
@@ -4,23 +4,23 @@
#
# Copyright (c) 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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: button.test,v 1.2 1998/09/14 18:23:43 stanton Exp $
+# RCS: @(#) $Id: button.test,v 1.3 1999/04/16 01:51:34 stanton Exp $
+
+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,217 @@ update
set i 1
foreach test {
{-activebackground #012345 #012345 non-existent
- {unknown color name "non-existent"}}
+ {unknown color name "non-existent"} {0 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"} {0 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"}
+ {0 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} {0 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} {
+test button-4.7 {ButtonWidgetCmd procedure, "cget" option} {
list [catch {.l cget -disabledforeground} msg] $msg
} {1 {unknown option "-disabledforeground"}}
-test button-4.7 {ButtonWidgetCmd procedure, "cget" option} {
+test button-4.8 {ButtonWidgetCmd procedure, "cget" option} {
catch {.b cget -disabledforeground}
} {0}
-test button-4.8 {ButtonWidgetCmd procedure, "cget" option} {
+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 +270,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 +279,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 +320,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 +357,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 +379,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 +389,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 +399,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 +421,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 +437,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 +448,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 +458,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 +472,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 +492,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 +517,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 +525,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 +533,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 +541,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 +551,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 +559,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 +780,19 @@ eval destroy [winfo children .]
option clear
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/canvImg.test b/tests/canvImg.test
index 05af9df..a79c15e 100644
--- a/tests/canvImg.test
+++ b/tests/canvImg.test
@@ -4,23 +4,23 @@
#
# Copyright (c) 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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: canvImg.test,v 1.2 1998/09/14 18:23:43 stanton Exp $
+# RCS: @(#) $Id: canvImg.test,v 1.3 1999/04/16 01:51:34 stanton Exp $
+
+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
}
@@ -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/tests/canvPs.test b/tests/canvPs.test
index 6fc4bd0..08d72cf 100644
--- a/tests/canvPs.test
+++ b/tests/canvPs.test
@@ -3,14 +3,13 @@
# TkCanvPostscriptCmd in generic/tkCanvPs.c
#
# Copyright (c) 1995 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.
-#
-# RCS: @(#) $Id: canvPs.test,v 1.2 1998/09/14 18:23:43 stanton Exp $
+# RCS: @(#) $Id: canvPs.test,v 1.3 1999/04/16 01:51:34 stanton Exp $
-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/tests/canvPsArc.tcl b/tests/canvPsArc.tcl
index 8b77091..4acdbbe 100644
--- a/tests/canvPsArc.tcl
+++ b/tests/canvPsArc.tcl
@@ -2,7 +2,7 @@
# for bitmaps in canvases. It is part of the Tk visual test suite,
# which is invoked via the "visual" script.
#
-# RCS: @(#) $Id: canvPsArc.tcl,v 1.2 1998/09/14 18:23:44 stanton Exp $
+# RCS: @(#) $Id: canvPsArc.tcl,v 1.3 1999/04/16 01:51:35 stanton Exp $
catch {destroy .t}
toplevel .t
@@ -43,3 +43,16 @@ $c create arc .5i 4.5i 2i 6i -style arc -start 135 -extent 315 -width 3m \
-outline black -outlinestipple gray25
$c create arc 3.5i 4.5i 5.5i 5.5i -style arc -start 45 -extent -90 -width 1m \
-outline black
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/canvPsBmap.tcl b/tests/canvPsBmap.tcl
index 15f41a4..dbc9c83 100644
--- a/tests/canvPsBmap.tcl
+++ b/tests/canvPsBmap.tcl
@@ -2,7 +2,7 @@
# for bitmaps in canvases. It is part of the Tk visual test suite,
# which is invoked via the "visual" script.
#
-# RCS: @(#) $Id: canvPsBmap.tcl,v 1.2 1998/09/14 18:23:44 stanton Exp $
+# RCS: @(#) $Id: canvPsBmap.tcl,v 1.3 1999/04/16 01:51:35 stanton Exp $
catch {destroy .t}
toplevel .t
@@ -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/tests/canvPsGrph.tcl b/tests/canvPsGrph.tcl
index 8458727..1b27898 100644
--- a/tests/canvPsGrph.tcl
+++ b/tests/canvPsGrph.tcl
@@ -2,7 +2,7 @@
# for some of the graphical objects in canvases. It is part of the Tk
# visual test suite, which is invoked via the "visual" script.
#
-# RCS: @(#) $Id: canvPsGrph.tcl,v 1.2 1998/09/14 18:23:44 stanton Exp $
+# RCS: @(#) $Id: canvPsGrph.tcl,v 1.3 1999/04/16 01:51:35 stanton Exp $
catch {destroy .t}
toplevel .t
@@ -85,3 +85,16 @@ proc mkObjs c {
}
mkObjs $c
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/canvPsText.tcl b/tests/canvPsText.tcl
index 61df240..145dcc7 100644
--- a/tests/canvPsText.tcl
+++ b/tests/canvPsText.tcl
@@ -2,7 +2,7 @@
# for text in canvases. It is part of the Tk visual test suite,
# which is invoked via the "visual" script.
#
-# RCS: @(#) $Id: canvPsText.tcl,v 1.2 1998/09/14 18:23:44 stanton Exp $
+# RCS: @(#) $Id: canvPsText.tcl,v 1.3 1999/04/16 01:51:35 stanton Exp $
catch {destroy .t}
toplevel .t
@@ -81,3 +81,16 @@ proc setStipple c {
global stipple
$c itemconfigure text -stipple $stipple
}
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/canvRect.test b/tests/canvRect.test
index c582990..9ba8c8d 100644
--- a/tests/canvRect.test
+++ b/tests/canvRect.test
@@ -3,14 +3,13 @@
# in the standard fashion for Tcl tests.
#
# Copyright (c) 1994-1996 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.
-#
-# RCS: @(#) $Id: canvRect.test,v 1.2 1998/09/14 18:23:44 stanton Exp $
+# RCS: @(#) $Id: canvRect.test,v 1.3 1999/04/16 01:51:35 stanton Exp $
-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 .] {
@@ -294,7 +293,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 +326,20 @@ restore showpage
end
%%EOF
}
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/canvText.test b/tests/canvText.test
index 9263e87..f0d9b85 100644
--- a/tests/canvText.test
+++ b/tests/canvText.test
@@ -3,14 +3,13 @@
# fashion for Tcl tests.
#
# Copyright (c) 1996-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.
-#
-# RCS: @(#) $Id: canvText.test,v 1.3 1998/10/16 00:46:19 rjohnson Exp $
+# RCS: @(#) $Id: canvText.test,v 1.4 1999/04/16 01:51:35 stanton Exp $
-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 .] {
@@ -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 {}
@@ -491,3 +490,19 @@ restore showpage
end
%%EOF
"
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/canvWind.test b/tests/canvWind.test
index 2ae6ac8..76db55c 100644
--- a/tests/canvWind.test
+++ b/tests/canvWind.test
@@ -3,14 +3,13 @@
# 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.
-#
-# RCS: @(#) $Id: canvWind.test,v 1.2 1998/09/14 18:23:44 stanton Exp $
+# RCS: @(#) $Id: canvWind.test,v 1.3 1999/04/16 01:51:35 stanton Exp $
-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/tests/canvas.test b/tests/canvas.test
index c37a36a..ee612ef 100644
--- a/tests/canvas.test
+++ b/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.
+# 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.
-#
-# RCS: @(#) $Id: canvas.test,v 1.4 1998/10/13 18:13:07 rjohnson Exp $
+# RCS: @(#) $Id: canvas.test,v 1.5 1999/04/16 01:51:35 stanton Exp $
-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 +73,16 @@ 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 +91,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 +243,20 @@ test canvas-9.1 {canvas id creation and deletion} {
set x ""
} {}
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/clipboard.test b/tests/clipboard.test
index 1c1b43b..7e482e9 100644
--- a/tests/clipboard.test
+++ b/tests/clipboard.test
@@ -3,19 +3,18 @@
# fashion for Tcl tests.
#
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: clipboard.test,v 1.2 1998/09/14 18:23:45 stanton Exp $
+# RCS: @(#) $Id: clipboard.test,v 1.3 1999/04/16 01:51:35 stanton Exp $
#
# Note: Multiple display clipboard handling will only be tested if the
# 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/tests/clrpick.test b/tests/clrpick.test
index a56b6b3..db101b8 100644
--- a/tests/clrpick.test
+++ b/tests/clrpick.test
@@ -2,22 +2,27 @@
# 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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: clrpick.test,v 1.2 1998/09/14 18:23:45 stanton Exp $
+# RCS: @(#) $Id: clrpick.test,v 1.3 1999/04/16 01:51:35 stanton Exp $
#
-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,62 @@ 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 #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} {
- 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"
+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} {
- 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.3 {tk_chooseColor command} \
+ {nonUnixUserInteraction colorsLeftover} {
+ ToPressButton $parent ok
+ tk_chooseColor -parent $parent -title "Press OK"
+} "$color"
-test clrpick-2.4 {tk_chooseColor command} {
+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} {
+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"
} ""
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/cmap.tcl b/tests/cmap.tcl
index fb92643..dca7f71 100644
--- a/tests/cmap.tcl
+++ b/tests/cmap.tcl
@@ -2,7 +2,7 @@
# property. It is part of the Tk visual test suite, which is invoked
# via the "visual" script.
#
-# RCS: @(#) $Id: cmap.tcl,v 1.2 1998/09/14 18:23:45 stanton Exp $
+# RCS: @(#) $Id: cmap.tcl,v 1.3 1999/04/16 01:51:35 stanton Exp $
catch {destroy .t}
toplevel .t -colormap new
@@ -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/tests/cmds.test b/tests/cmds.test
index 6524f3c..c6301d9 100644
--- a/tests/cmds.test
+++ b/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.
+# 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.
-#
-# RCS: @(#) $Id: cmds.test,v 1.2 1998/09/14 18:23:45 stanton Exp $
+# RCS: @(#) $Id: cmds.test,v 1.3 1999/04/16 01:51:35 stanton Exp $
-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/tests/color.test b/tests/color.test
index 7c68ec3..3b86efc 100644
--- a/tests/color.test
+++ b/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.
+# Copyright (c) 1995-1998 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.
-#
-# RCS: @(#) $Id: color.test,v 1.2 1998/09/14 18:23:45 stanton Exp $
+# RCS: @(#) $Id: color.test,v 1.3 1999/04/16 01:51:36 stanton Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
-if {[info procs test] != "test"} {
- source defs
+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,75 @@ 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.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 +204,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 +214,86 @@ 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/tests/config.test b/tests/config.test
new file mode 100644
index 0000000..8fdbbd7
--- /dev/null
+++ b/tests/config.test
@@ -0,0 +1,839 @@
+# 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: config.test,v 1.2 1999/04/16 01:51:36 stanton Exp $
+
+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]
+} {{} {} {} {} {} {} {} {}}
+
+# cleanup
+eval destroy [winfo children .]
+killTables
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/cursor.test b/tests/cursor.test
new file mode 100644
index 0000000..bb01561
--- /dev/null
+++ b/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: cursor.test,v 1.2 1999/04/16 01:51:36 stanton Exp $
+
+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/tests/defs b/tests/defs
deleted file mode 100644
index a7037ee..0000000
--- a/tests/defs
+++ /dev/null
@@ -1,372 +0,0 @@
-# This file contains support code for the Tcl test suite. 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) 1994-1997 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.
-#
-# RCS: @(#) $Id: defs,v 1.4 1999/04/16 01:25:55 stanton Exp $
-
-if {![info exists VERBOSE]} {
- set VERBOSE 0
-}
-if {![info exists TESTS]} {
- set TESTS {}
-}
-
-tk appname tktest
-wm title . tktest
-
-# Check configuration information that will determine which tests
-# to run. To do this, create an array testConfig. Each element
-# has a 0 or 1 value, and the following elements are defined:
-# unixOnly - 1 means this is a UNIX platform, so it's OK
-# to run tests that only work under UNIX.
-# macOnly - 1 means this is a Mac platform, so it's OK
-# to run tests that only work on Macs.
-# pcOnly - 1 means this is a PC platform, so it's OK to
-# run tests that only work on PCs.
-# unixOrPc - 1 means this is a UNIX or PC platform.
-# macOrPc - 1 means this is a Mac or PC platform.
-# macOrUnix - 1 means this is a Mac or UNIX platform.
-# nonPortable - 1 means this the tests are being running in
-# the master Tcl/Tk development environment;
-# Some tests are inherently non-portable because
-# they depend on things like word length, file system
-# configuration, window manager, etc. These tests
-# are only run in the main Tcl development directory
-# where the configuration is well known. The presence
-# of the file "doAllTests" in this directory indicates
-# that it is safe to run non-portable tests.
-# fonts - 1 means that this platform uses fonts with
-# well-know geometries, so it is safe to run
-# tests that depend on particular font sizes.
-
-catch {unset testConfig}
-
-set testConfig(unixOnly) [expr {$tcl_platform(platform) == "unix"}]
-set testConfig(macOnly) [expr {$tcl_platform(platform) == "macintosh"}]
-set testConfig(pcOnly) [expr {$tcl_platform(platform) == "windows"}]
-
-set testConfig(unix) $testConfig(unixOnly)
-set testConfig(mac) $testConfig(macOnly)
-set testConfig(pc) $testConfig(pcOnly)
-
-set testConfig(unixOrPc) [expr {$testConfig(unixOnly) || $testConfig(pcOnly)}]
-set testConfig(macOrPc) [expr {$testConfig(macOnly) || $testConfig(pcOnly)}]
-set testConfig(macOrUnix) [expr {$testConfig(macOnly) || $testConfig(unixOnly)}]
-
-set testConfig(nonPortable) [expr {[file exists doAllTests] || [file exists DOALLT~1]}]
-
-set testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}]
-set testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}]
-set testConfig(win32s) [expr {$tcl_platform(os) == "Win32s"}]
-
-# The following config switches are used to mark tests that should work,
-# but have been temporarily disabled on certain platforms because they don't.
-
-set testConfig(tempNotPc) [expr {!$testConfig(pc)}]
-set testConfig(tempNotMac) [expr {!$testConfig(mac)}]
-set testConfig(tempNotUnix) [expr {!$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 testConfig(pcCrash) [expr {!$testConfig(pc)}]
-set testConfig(win32sCrash) [expr {!$testConfig(win32s)}]
-set testConfig(macCrash) [expr {!$testConfig(mac)}]
-set testConfig(unixCrash) [expr {!$testConfig(unix)}]
-
-set 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 testConfig(fonts) 0
-}
-destroy .e .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 testConfig(fonts) 0
-}
-
-if {$testConfig(nonPortable) == 0} {
- puts stdout "(will skip non-portable tests)"
-}
-if {$testConfig(fonts) == 0} {
- puts stdout "(will skip font-sensitive tests: this system has unexpected font geometries)"
-}
-
-trace variable testConfig r safeFetch
-
-proc safeFetch {n1 n2 op} {
- global testConfig
-
- if {($n2 != {}) && ([info exists testConfig($n2)] == 0)} {
- set testConfig($n2) 0
- }
-}
-
-# 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 {}
-}
-
-proc print_verbose {name description script code answer} {
- puts stdout "\n"
- puts stdout "==== $name $description"
- puts stdout "==== Contents of test case:"
- puts stdout "$script"
- if {$code != 0} {
- if {$code == 1} {
- puts stdout "==== Test generated error:"
- puts stdout $answer
- } elseif {$code == 2} {
- puts stdout "==== Test generated return exception; result was:"
- puts stdout $answer
- } 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 $answer
- }
- } else {
- puts stdout "==== Result was:"
- puts stdout "$answer"
- }
-}
-
-# test --
-# This procedure runs a test and prints an error message if the
-# test fails. If 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 TESTS variable, 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 "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.
-
-proc test {name description script answer args} {
- global VERBOSE TESTS testConfig
- if {[string compare $TESTS ""] != 0} {
- set ok 0
- foreach test $TESTS {
- if {[string match $test $name]} {
- set ok 1
- break
- }
- }
- if {!$ok} {
- return
- }
- }
- set i [llength $args]
- if {$i == 0} {
- # Empty body
- } elseif {$i == 1} {
- # "constraints" argument exists; shuffle arguments down, then
- # make sure that the constraints are satisfied.
-
- set constraints $script
- set script $answer
- set answer [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
- # $testConfig(a) || $testConfig(b).
-
- regsub -all {[.a-zA-Z0-9]+} $constraints {$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 testConfig($constraint)]
- || !$testConfig($constraint)} {
- set doTest 0
- break
- }
- }
- }
- if {$doTest == 0} {
- if {$VERBOSE} {
- puts stdout "++++ $name SKIPPED: $constraints"
- }
- return
- }
- } else {
- error "wrong # args: must be \"test name description ?constraints? script answer\""
- }
- memory tag $name
- set code [catch {uplevel $script} result]
- if {$code != 0} {
- print_verbose $name $description $script $code $result
- } elseif {[string compare $result $answer] == 0} {
- if {$VERBOSE} {
- if {$VERBOSE > 0} {
- print_verbose $name $description $script $code $result
- }
- if {$VERBOSE != -2} {
- puts stdout "++++ $name PASSED"
- }
- }
- } else {
- print_verbose $name $description $script $code $result
- puts stdout "---- Result should have been:"
- puts stdout "$answer"
- puts stdout "---- $name FAILED"
- }
- if {[string compare $::tcl_platform(platform) macintosh] == 0} {
- # Force the text to be drawn even if the tests are not updating.
- update idletasks
- }
-}
-
-proc dotests {file args} {
- global TESTS
- set savedTests $TESTS
- set TESTS $args
- source $file
- set TESTS $savedTests
-}
-
-# 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 tktest executable
-
-set tktest [info nameofexecutable]
-if {$tktest == "{}"} {
- set tktest {}
- puts stdout "Unable to find tktest executable, skipping multiple process tests."
-}
-
-# Create background process
-
-proc setupbg args {
- global tktest fd bgData
- if {$tktest == ""} {
- error "you're not running tktest so setupbg should not have been called"
- }
- if {[info exists fd] && ($fd != "")} {
- cleanupbg
- }
- set fd [open "|[list $tktest -geometry +0+0 -name tktest] $args" r+]
- puts $fd "puts foo; flush stdout"
- flush $fd
- if {[gets $fd data] < 0} {
- error "unexpected EOF from \"$tktest\""
- }
- if {[string compare $data foo]} {
- error "unexpected output from background process \"$data\""
- }
- fileevent $fd readable bgReady
-}
-
-# Send a command to the background process, catching errors and
-# flushing I/O channels
-proc dobg {command} {
- global fd bgData bgDone
- puts $fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout"
- flush $fd
- set bgDone 0
- set bgData {}
- tkwait variable bgDone
- set 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 bgReady {} {
- global fd bgData bgDone
- set x [gets $fd]
- if {[eof $fd]} {
- fileevent $fd readable {}
- set bgDone 1
- } elseif {$x == "**DONE**"} {
- set bgDone 1
- } else {
- append bgData $x
- }
-}
-
-# Exit the background process, and close the pipes
-proc cleanupbg {} {
- global fd
- catch {
- puts $fd "exit"
- close $fd
- }
- set 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 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
-}
-
-proc 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
-}
-
-proc removeFile {name} {
- file delete -- $name
-}
diff --git a/tests/defs.tcl b/tests/defs.tcl
new file mode 100644
index 0000000..40e147d
--- /dev/null
+++ b/tests/defs.tcl
@@ -0,0 +1,990 @@
+# 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: defs.tcl,v 1.2 1999/04/16 01:51:36 stanton Exp $
+
+# 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]
+ if {[info exists tk_version]} {
+ lappend procList setupbg dobg bgReady cleanupbg fixfocus
+ }
+ foreach proc $procList {
+ namespace export $proc
+ }
+
+ # ::tcltest::verbose defaults to "b"
+ variable verbose "b"
+
+ # match defaults to the empty list
+ variable match {}
+
+ # skip defaults to the empty list
+ variable skip {}
+
+ # 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 {}
+}
+
+# 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
+ }
+ }
+
+ # 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 in Tk8.1b2
+ # This bug is logged as a pipe bug (bugID 1495).
+
+ global tcl_platform
+ if {$tcl_platform(platform) != "windows"} {
+ 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
+ }
+}
+
+# Need to catch the import because it fails if defs.tcl is sourced
+# more than once.
+catch {namespace import ::tcltest::*}
+return
diff --git a/tests/entry.test b/tests/entry.test
index 551404c..107df62 100644
--- a/tests/entry.test
+++ b/tests/entry.test
@@ -3,23 +3,23 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-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.
-#
-# RCS: @(#) $Id: entry.test,v 1.2 1998/09/14 18:23:45 stanton Exp $
+# RCS: @(#) $Id: entry.test,v 1.3 1999/04/16 01:51:37 stanton Exp $
+
+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 normal 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 "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 "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 "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} {
+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, 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} {
+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,78 +433,92 @@ 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.319149} {0.117021 0.351064} {0.117021 0.351064}
+
+ set x {}
+ .e xview moveto .1
+ lappend x [.e xview]
+ .e xview moveto .11
+ lappend x [.e xview]
+ .e xview moveto .12
+ lappend x [.e xview]
+} {{0.0957447 0.308511} {0.106383 0.319149} {0.117021 0.329787}}
+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}}
@@ -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}
@@ -1265,5 +1358,21 @@ test entry-18.1 {Entry widget vs hiding} {
# XXX Still need to write tests for EntryBlinkProc, EntryFocusProc,
# and EntryTextVarProc.
-
option clear
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/event.test b/tests/event.test
index 0812f71..b5bfe6a 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -3,14 +3,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 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.
-#
-# RCS: @(#) $Id: event.test,v 1.2 1998/09/14 18:23:46 stanton Exp $
+# RCS: @(#) $Id: event.test,v 1.3 1999/04/16 01:51:37 stanton Exp $
-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 .] {
@@ -39,3 +38,20 @@ test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} {
destroy .b
set x
} {destroy}
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/filebox.test b/tests/filebox.test
index 02e9295..e4bc512 100644
--- a/tests/filebox.test
+++ b/tests/filebox.test
@@ -3,15 +3,24 @@
# for Tcl tests.
#
# Copyright (c) 1996 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.
-#
-# RCS: @(#) $Id: filebox.test,v 1.5 1998/12/07 23:29:00 hershey Exp $
+# RCS: @(#) $Id: filebox.test,v 1.6 1999/04/16 01:51:37 stanton Exp $
#
+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
@@ -90,17 +99,18 @@ 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 {unknown option "-foo", must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent or -title}}
+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 {
@@ -118,11 +128,11 @@ foreach mode $modes {
#
foreach command "tk_getOpenFile tk_getSaveFile" {
-
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
@@ -156,10 +166,6 @@ foreach mode $modes {
set isNative 0
}
- if {$isNative && ![info exists INTERACTIVE]} {
- continue
- }
-
set parent .
set verylongstring longstring:
@@ -174,52 +180,48 @@ 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]
-
- # this file should be in the current working dir
+ set fileName $tmpFile
set fileDir [pwd]
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
ToPressButton .t1 ok
set choice {}
@@ -264,7 +266,7 @@ 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]
@@ -288,10 +290,19 @@ 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/tests/focus.test b/tests/focus.test
index a8c3f3b..e8f850a 100644
--- a/tests/focus.test
+++ b/tests/focus.test
@@ -3,18 +3,13 @@
# standard fashion for Tcl tests.
#
# Copyright (c) 1994-1996 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.
-#
-# RCS: @(#) $Id: focus.test,v 1.4 1998/12/08 04:05:34 hershey Exp $
-
-if {$tcl_platform(platform) != "unix"} {
- return
-}
+# RCS: @(#) $Id: focus.test,v 1.5 1999/04/16 01:51:37 stanton Exp $
-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 .]
@@ -47,7 +42,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 +60,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 +76,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,91 +123,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."
- cleanupbg
- return
-}
+# Some tests require the testwrapper command
-test focus-2.1 {TkFocusFilterEvent procedure} {nonPortable} {
+set ::tcltest::testConfig(testwrapper) \
+ [expr {[info commands testwrapper] != {}}]
+
+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
@@ -224,7 +214,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
@@ -237,7 +227,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
@@ -267,7 +258,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
@@ -277,7 +269,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
@@ -287,7 +280,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
@@ -299,17 +293,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
@@ -323,14 +320,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 {}
@@ -338,7 +337,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
@@ -348,7 +348,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
@@ -359,7 +359,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
@@ -373,7 +374,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
@@ -385,7 +387,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
@@ -399,7 +402,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
@@ -411,7 +415,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
@@ -421,12 +426,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
@@ -439,7 +446,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 {}
@@ -449,7 +457,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
@@ -462,7 +471,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
@@ -473,7 +483,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
@@ -481,7 +491,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
@@ -495,7 +505,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
@@ -504,7 +514,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
@@ -515,7 +525,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
@@ -525,7 +549,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> {}
@@ -534,7 +558,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
@@ -583,7 +608,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
@@ -635,3 +661,20 @@ 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/tests/focusTcl.test b/tests/focusTcl.test
index 14c1d3d..0d223cf 100644
--- a/tests/focusTcl.test
+++ b/tests/focusTcl.test
@@ -4,14 +4,13 @@
# standard fashion for Tcl tests.
#
# Copyright (c) 1995 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.
-#
-# RCS: @(#) $Id: focusTcl.test,v 1.2 1998/09/14 18:23:47 stanton Exp $
+# RCS: @(#) $Id: focusTcl.test,v 1.3 1999/04/16 01:51:37 stanton Exp $
-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/tests/font.test b/tests/font.test
index 909085b..264dee5 100644
--- a/tests/font.test
+++ b/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.
+# Copyright (c) 1996-1998 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.
-#
-# RCS: @(#) $Id: font.test,v 1.3 1998/09/14 18:23:47 stanton Exp $
+# RCS: @(#) $Id: font.test,v 1.4 1999/04/16 01:51:37 stanton Exp $
+
+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 {[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} {
+ # (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} {
+ # (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} {
+ # (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} {
+ # (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} {
+ # (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
@@ -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,153 @@ 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} {
+ list [catch {font actual "\{xyz"} msg] $msg
+} [list 1 "font \"{xyz\" doesn't exist"]
+test font-38.8 {ParseFontNameObj procedure: arguments} {
+ 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 {TkFontGetPixels: size >= 0} {
+ font actual {times 12} -size
+} {12}
+
+test font-45.1 {TkFontGetPoints: size >= 0} {
+ font actual {times 12} -size
+} {12}
+test font-45.2 {TkFontGetPoints: size < 0} {
+ font actual {times -12} -size
+} {24}
+
+tk scaling $oldscale
+
+test font-46.1 {TkFontGetAliasList: no match} {
+ font actual {snarky 10} -family
+} [font actual {-size 10} -family]
+test font-46.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-46.3 {TkFontGetAliasList: match} {pcOnly} {
+ font actual {times 10} -family
+} {Times New Roman}
+test font-46.4 {TkFontGetAliasList: match} {unixOnly} {
+ font actual {{times new roman} 10} -family
+} [font actual {times 10} -family]
+
+setup
destroy .b
+
+# cleanup
+::tcltest::cleanupTests
return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/frame.test b/tests/frame.test
index 7e3d8da..370f674 100644
--- a/tests/frame.test
+++ b/tests/frame.test
@@ -4,14 +4,13 @@
#
# Copyright (c) 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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: frame.test,v 1.2 1998/09/14 18:23:47 stanton Exp $
+# RCS: @(#) $Id: frame.test,v 1.3 1999/04/16 01:51:37 stanton Exp $
-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 .] {
@@ -615,3 +614,20 @@ test frame-11.2 {TkInstallFrameMenu - frame renamed} {
catch {destroy .f}
rename eatColors {}
rename colorsFree {}
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/geometry.test b/tests/geometry.test
index 0785ab1..615ccc7 100644
--- a/tests/geometry.test
+++ b/tests/geometry.test
@@ -4,14 +4,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: geometry.test,v 1.2 1998/09/14 18:23:47 stanton Exp $
+# RCS: @(#) $Id: geometry.test,v 1.3 1999/04/16 01:51:37 stanton Exp $
-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/tests/get.test b/tests/get.test
new file mode 100644
index 0000000..bf6dc44
--- /dev/null
+++ b/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: get.test,v 1.2 1999/04/16 01:51:38 stanton Exp $
+
+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/tests/grid.test b/tests/grid.test
index 85464d7..ed0a455 100644
--- a/tests/grid.test
+++ b/tests/grid.test
@@ -3,14 +3,13 @@
#
# Copyright (c) 1996 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.
-#
-# RCS: @(#) $Id: grid.test,v 1.3 1999/01/06 21:10:46 stanton Exp $
+# RCS: @(#) $Id: grid.test,v 1.4 1999/04/16 01:51:38 stanton Exp $
-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]
+}
# helper routine to return "." to a sane state after a test
# The variable GRID_VERBOSE can be used to "look" at the result
@@ -319,7 +318,7 @@ test grid-6.8 {location (weights)} {
} {{-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
@@ -989,23 +988,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} {
@@ -1212,3 +1214,20 @@ test grid-17.1 {forget and pending idle handlers} {
destroy .t
set result ok
} ok
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/id.test b/tests/id.test
index b1c2ea9..8c12a50 100644
--- a/tests/id.test
+++ b/tests/id.test
@@ -3,19 +3,19 @@
# the standard fashion for Tcl tests.
#
# Copyright (c) 1995 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.
-#
-# RCS: @(#) $Id: id.test,v 1.3 1998/09/14 18:23:47 stanton Exp $
+# RCS: @(#) $Id: id.test,v 1.4 1999/04/16 01:51:38 stanton Exp $
-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/tests/image.test b/tests/image.test
index 468865d..e3f7841 100644
--- a/tests/image.test
+++ b/tests/image.test
@@ -4,23 +4,23 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: image.test,v 1.2 1998/09/14 18:23:47 stanton Exp $
+# RCS: @(#) $Id: image.test,v 1.3 1999/04/16 01:51:38 stanton Exp $
+
+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/tests/imgBmap.test b/tests/imgBmap.test
index 337a136..ffdafeb 100644
--- a/tests/imgBmap.test
+++ b/tests/imgBmap.test
@@ -4,14 +4,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 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.
-#
-# RCS: @(#) $Id: imgBmap.test,v 1.2 1998/09/14 18:23:47 stanton Exp $
+# RCS: @(#) $Id: imgBmap.test,v 1.3 1999/04/16 01:51:38 stanton Exp $
-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/tests/imgPPM.test b/tests/imgPPM.test
index f9ffc9e..00abf33 100644
--- a/tests/imgPPM.test
+++ b/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.
+# 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.
-#
-# RCS: @(#) $Id: imgPPM.test,v 1.2 1998/09/14 18:23:47 stanton Exp $
+# RCS: @(#) $Id: imgPPM.test,v 1.3 1999/04/16 01:51:38 stanton Exp $
-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 .] {
@@ -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/tests/imgPhoto.test b/tests/imgPhoto.test
index d3a9dcc..0ee4489 100644
--- a/tests/imgPhoto.test
+++ b/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: imgPhoto.test,v 1.3 1998/12/07 23:29:00 hershey Exp $
+# RCS: @(#) $Id: imgPhoto.test,v 1.4 1999/04/16 01:51:38 stanton Exp $
-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,13 +27,20 @@ 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 [file dirname [info script]]]
+ set newLib [file dirname $::tcltest::testsDir]
set teapotPhotoFile \
[file join $newLib library demos images teapot.ppm]
if {![file exists $teapotPhotoFile]} {
@@ -432,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/tests/listbox.test b/tests/listbox.test
index c2b1447..3c124df 100644
--- a/tests/listbox.test
+++ b/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.
+# 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.
-#
-# RCS: @(#) $Id: listbox.test,v 1.2 1998/09/14 18:23:48 stanton Exp $
+# RCS: @(#) $Id: listbox.test,v 1.3 1999/04/16 01:51:38 stanton Exp $
-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
@@ -1656,3 +1656,19 @@ catch {destroy .e}
catch {destroy .partial}
option clear
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/macEmbed.test b/tests/macEmbed.test
index 90b7161..67a77a0 100644
--- a/tests/macEmbed.test
+++ b/tests/macEmbed.test
@@ -3,18 +3,13 @@
# 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.
-#
-# RCS: @(#) $Id: macEmbed.test,v 1.3 1998/09/14 18:23:48 stanton Exp $
+# RCS: @(#) $Id: macEmbed.test,v 1.4 1999/04/16 01:51:38 stanton Exp $
-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/tests/macFont.test b/tests/macFont.test
index 8c6d0ae..7bec629 100644
--- a/tests/macFont.test
+++ b/tests/macFont.test
@@ -7,28 +7,30 @@
# but there are no results that can be checked.
#
# Copyright (c) 1996 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.
-#
-# RCS: @(#) $Id: macFont.test,v 1.2 1998/09/14 18:23:48 stanton Exp $
+# RCS: @(#) $Id: macFont.test,v 1.3 1999/04/16 01:51:38 stanton Exp $
-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/tests/macMenu.test b/tests/macMenu.test
index 3882b0d..b76b7e6 100644
--- a/tests/macMenu.test
+++ b/tests/macMenu.test
@@ -4,13 +4,18 @@
# system.
#
# Copyright (c) 1995-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.
-#
-# RCS: @(#) $Id: macMenu.test,v 1.2 1998/09/14 18:23:48 stanton Exp $
+# RCS: @(#) $Id: macMenu.test,v 1.3 1999/04/16 01:51:39 stanton Exp $
+
+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/tests/macWinMenu.test b/tests/macWinMenu.test
index e19fdff..2aad508 100644
--- a/tests/macWinMenu.test
+++ b/tests/macWinMenu.test
@@ -3,26 +3,27 @@
# the common implementation of Macintosh and Windows menus.
#
# Copyright (c) 1995-1996 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.
-#
-# RCS: @(#) $Id: macWinMenu.test,v 1.2 1998/09/14 18:23:48 stanton Exp $
+# RCS: @(#) $Id: macWinMenu.test,v 1.3 1999/04/16 01:51:39 stanton Exp $
-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/tests/macscrollbar.test b/tests/macscrollbar.test
index c13198a..4abf137 100644
--- a/tests/macscrollbar.test
+++ b/tests/macscrollbar.test
@@ -4,17 +4,20 @@
# Tcl tests.
#
# Copyright (c) 1996 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.
-#
-# RCS: @(#) $Id: macscrollbar.test,v 1.2 1998/09/14 18:23:48 stanton Exp $
+# RCS: @(#) $Id: macscrollbar.test,v 1.3 1999/04/16 01:51:39 stanton Exp $
-# 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/tests/main.test b/tests/main.test
index 5db6ed5..0422223 100644
--- a/tests/main.test
+++ b/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.
+# 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.
-#
-# RCS: @(#) $Id: main.test,v 1.4 1999/02/04 21:03:28 stanton Exp $
+# RCS: @(#) $Id: main.test,v 1.5 1999/04/16 01:51:39 stanton Exp $
-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,7 +21,7 @@ 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
@@ -31,7 +30,20 @@ test main-1.1 {StdinProc} {unixOnly} {
list $error $msg
} {0 {}}
-#
-# Clean up.
-#
+# cleanup
catch {removeFile script}
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/menu.test b/tests/menu.test
index a4399b5..7b8ba02 100644
--- a/tests/menu.test
+++ b/tests/menu.test
@@ -2,32 +2,27 @@
# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995-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.
-#
-# RCS: @(#) $Id: menu.test,v 1.2 1998/09/14 18:23:48 stanton Exp $
+# RCS: @(#) $Id: menu.test,v 1.3 1999/04/16 01:51:39 stanton Exp $
+
+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,20 @@ test menu-32.1 {menu vs command hiding} {
# menu-34 MenuInit only called at boot time
+# cleanup
deleteWindows
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/menuDraw.test b/tests/menuDraw.test
index b142f98..fdb051b 100644
--- a/tests/menuDraw.test
+++ b/tests/menuDraw.test
@@ -2,23 +2,23 @@
# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1996-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.
-#
-# RCS: @(#) $Id: menuDraw.test,v 1.2 1998/09/14 18:23:48 stanton Exp $
+# RCS: @(#) $Id: menuDraw.test,v 1.3 1999/04/16 01:51:39 stanton Exp $
+
+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/tests/menubut.test b/tests/menubut.test
index 9bdf04c..89d46d8 100644
--- a/tests/menubut.test
+++ b/tests/menubut.test
@@ -3,27 +3,27 @@
#
# Copyright (c) 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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: menubut.test,v 1.2 1998/09/14 18:23:49 stanton Exp $
+# RCS: @(#) $Id: menubut.test,v 1.3 1999/04/16 01:51:39 stanton Exp $
# XXX This test file is woefully incomplete right now. If any part
# 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"}}
@@ -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
@@ -314,7 +314,7 @@ test menubutton-7.13 {ComputeMenuButtonGeometry procedure} {fonts} {
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/tests/msgbox.test b/tests/msgbox.test
index 0511c87..e9a16d4 100644
--- a/tests/msgbox.test
+++ b/tests/msgbox.test
@@ -2,23 +2,27 @@
# 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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: msgbox.test,v 1.2 1998/09/14 18:23:49 stanton Exp $
+# RCS: @(#) $Id: msgbox.test,v 1.3 1999/04/16 01:51:39 stanton Exp $
#
-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, -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, -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,52 @@ 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
}
}
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/obj.test b/tests/obj.test
new file mode 100644
index 0000000..f24ff68
--- /dev/null
+++ b/tests/obj.test
@@ -0,0 +1,52 @@
+# This file is a Tcl script to test new object types in Tk.
+# It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+#
+# RCS: @(#) $Id: obj.test,v 1.2 1999/04/16 01:51:39 stanton Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
+foreach i [winfo children .] {
+ destroy $i
+}
+wm geometry . {}
+raise .
+
+test obj-1.1 {TkGetPixelsFromObj} {
+} {}
+
+test obj-2.1 {FreePixelInternalRep} {
+} {}
+
+test obj-3.1 {DupPixelInternalRep} {
+} {}
+
+test obj-4.1 {SetPixelFromAny} {
+} {}
+
+
+
+eval destroy [winfo children .]
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/oldpack.test b/tests/oldpack.test
index 984e4fe..a793304 100644
--- a/tests/oldpack.test
+++ b/tests/oldpack.test
@@ -4,14 +4,14 @@
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: oldpack.test,v 1.2 1998/09/14 18:23:49 stanton Exp $
+# RCS: @(#) $Id: oldpack.test,v 1.3 1999/04/16 01:51:40 stanton Exp $
-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/tests/option.test b/tests/option.test
index 3acc8f8..339d723 100644
--- a/tests/option.test
+++ b/tests/option.test
@@ -3,14 +3,14 @@
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: option.test,v 1.2 1998/09/14 18:23:49 stanton Exp $
+# RCS: @(#) $Id: option.test,v 1.3 1999/04/16 01:51:40 stanton Exp $
-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/tests/pack.test b/tests/pack.test
index 0084de4..6f6adbd 100644
--- a/tests/pack.test
+++ b/tests/pack.test
@@ -3,14 +3,14 @@
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: pack.test,v 1.2 1998/09/14 18:23:49 stanton Exp $
+# RCS: @(#) $Id: pack.test,v 1.3 1999/04/16 01:51:40 stanton Exp $
-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:
@@ -967,3 +967,20 @@ destroy .pack
foreach i {pack1 pack2 pack3 pack4} {
rename $i {}
}
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/place.test b/tests/place.test
index aaa2537..ea4014b 100644
--- a/tests/place.test
+++ b/tests/place.test
@@ -2,14 +2,13 @@
# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995 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.
-#
-# RCS: @(#) $Id: place.test,v 1.2 1998/09/14 18:23:49 stanton Exp $
+# RCS: @(#) $Id: place.test,v 1.3 1999/04/16 01:51:40 stanton Exp $
-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/tests/raise.test b/tests/raise.test
index 5c40341..14323c5 100644
--- a/tests/raise.test
+++ b/tests/raise.test
@@ -5,11 +5,10 @@
#
# Copyright (c) 1993-1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: raise.test,v 1.2 1998/09/14 18:23:49 stanton Exp $
+# RCS: @(#) $Id: raise.test,v 1.3 1999/04/16 01:51:40 stanton Exp $
if {[info commands testmakeexist] == {}} {
puts "This application hasn't been compiled with the \"testmakeexist\""
@@ -18,8 +17,9 @@ if {[info commands testmakeexist] == {}} {
return
}
-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]
+}
# Procedure to create a bunch of overlapping windows, which should
# make it easy to detect differences in order.
@@ -297,3 +297,20 @@ test raise-7.8 {errors in raise/lower commands} {
foreach i [winfo child .] {
destroy $i
}
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/safe.test b/tests/safe.test
index 1a1970b..b134268 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -3,31 +3,28 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 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.
-#
-# RCS: @(#) $Id: safe.test,v 1.4 1999/04/16 01:25:55 stanton Exp $
+# RCS: @(#) $Id: safe.test,v 1.5 1999/04/16 01:51:40 stanton Exp $
-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 .] {
- puts "*** Destroying $i ***"; update idletasks
destroy $i
}
# 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_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}
}
-puts "About to do 1"
test safe-1.1 {Safe Tk loading into an interpreter} {
catch {safe::interpDelete a}
@@ -51,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}
@@ -99,19 +96,14 @@ test safe-3.2 {Unsafe commands are available hidden} {
set status
} ok
-# This test gets a panic on the Mac in Tk8.0.5. It did not in 8.0.4,
-# and it also does not if you update before deleting. This is just
-# revealing the weakness in the link between the container list and the
-# ports for the windows. The same comment applies to safe-5.2
-
-test safe-4.1 {testing loadTk} {unixOrPc} {
+test safe-4.1 {testing loadTk} {
# no error shall occur, the user will
# 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
} {}
@@ -133,7 +125,7 @@ test safe-5.1 {loading Tk in safe interps without master's clearance} {
set msg
} {not allowed to start Tk by master's safe::TkInit}
-test safe-5.2 {multi-level Tk loading with clearance} {unixOrPc} {
+test safe-5.2 {multi-level Tk loading with clearance} {
# No error shall occur in that test and no window
# shall remain at the end.
set i [safe::interpCreate]
@@ -173,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/tests/scale.test b/tests/scale.test
index adc50e9..01b1609 100644
--- a/tests/scale.test
+++ b/tests/scale.test
@@ -3,14 +3,13 @@
#
# Copyright (c) 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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: scale.test,v 1.3 1998/11/03 02:06:43 stanton Exp $
+# RCS: @(#) $Id: scale.test,v 1.4 1999/04/16 01:51:40 stanton Exp $
-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,18 +55,18 @@ 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}}
+ {-sliderrelief raised raised badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
{-state disabled disabled badValue
- {bad state value "badValue": must be normal, active, or disabled}}
+ {bad state "badValue": must be active, disabled, or normal}}
{-state normal normal {} {}}
{-takefocus "any string" "any string" {} {}}
{-tickinterval 4.3 4.0 badValue
@@ -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
@@ -799,3 +798,20 @@ test scale-16.1 {scale widget vs hidden commands} {
catch {destroy .s}
option clear
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/scrollbar.test b/tests/scrollbar.test
index 7790b05..0328043 100644
--- a/tests/scrollbar.test
+++ b/tests/scrollbar.test
@@ -4,14 +4,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-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.
-#
-# RCS: @(#) $Id: scrollbar.test,v 1.2 1998/09/14 18:23:50 stanton Exp $
+# RCS: @(#) $Id: scrollbar.test,v 1.3 1999/04/16 01:51:40 stanton Exp $
-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 .] {
@@ -170,16 +169,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
@@ -662,4 +661,20 @@ test scrollbar-9.1 {scrollbar widget vs hidden commands} {
catch {destroy .s}
catch {destroy .t}
-concat {}
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/select.test b/tests/select.test
index d449f7c..9f1e6a6 100644
--- a/tests/select.test
+++ b/tests/select.test
@@ -3,19 +3,18 @@
# fashion for Tcl tests.
#
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: select.test,v 1.2 1998/09/14 18:23:50 stanton Exp $
+# RCS: @(#) $Id: select.test,v 1.3 1999/04/16 01:51:40 stanton Exp $
#
# Note: Multiple display selection handling will only be tested if the
# 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
@@ -984,4 +983,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/tests/send.test b/tests/send.test
index 2f6e7d1..816151e 100644
--- a/tests/send.test
+++ b/tests/send.test
@@ -4,28 +4,31 @@
#
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1994-1996 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.
-#
-# RCS: @(#) $Id: send.test,v 1.2 1998/09/14 18:23:50 stanton Exp $
+# RCS: @(#) $Id: send.test,v 1.3 1999/04/16 01:51:40 stanton Exp $
+
+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/tests/text.test b/tests/text.test
index 62d5839..fd953d0 100644
--- a/tests/text.test
+++ b/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.
+# 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.
-#
-# RCS: @(#) $Id: text.test,v 1.2 1998/09/14 18:23:50 stanton Exp $
+# RCS: @(#) $Id: text.test,v 1.3 1999/04/16 01:51:40 stanton Exp $
-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 .]
@@ -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}
@@ -1082,6 +1082,27 @@ 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}
+
eval destroy [winfo child .]
text .t2 -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
@@ -1260,3 +1281,20 @@ test text-23.1 {text widget vs hidden commands} {
eval destroy [winfo child .]
option clear
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/textBTree.test b/tests/textBTree.test
index d59a9b8..855a8f3 100644
--- a/tests/textBTree.test
+++ b/tests/textBTree.test
@@ -5,14 +5,14 @@
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: textBTree.test,v 1.2 1998/09/14 18:23:50 stanton Exp $
+# RCS: @(#) $Id: textBTree.test,v 1.3 1999/04/16 01:51:41 stanton Exp $
-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/tests/textDisp.test b/tests/textDisp.test
index 9741fdc..7ae7f25 100644
--- a/tests/textDisp.test
+++ b/tests/textDisp.test
@@ -3,17 +3,16 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-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.
-#
-# RCS: @(#) $Id: textDisp.test,v 1.2 1998/09/14 18:23:50 stanton Exp $
+# RCS: @(#) $Id: textDisp.test,v 1.3 1999/04/16 01:51:41 stanton Exp $
-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;
@@ -2866,3 +2865,20 @@ foreach i [winfo children .] {
catch {destroy $i}
}
option clear
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/textImage.test b/tests/textImage.test
index e639097..9b17358 100644
--- a/tests/textImage.test
+++ b/tests/textImage.test
@@ -1,7 +1,17 @@
-# RCS: @(#) $Id: textImage.test,v 1.2 1998/09/14 18:23:51 stanton Exp $
-
-if {[string compare test [info procs test]] == 1} then \
- {source ../tests/defs}
+# 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: textImage.test,v 1.3 1999/04/16 01:51:41 stanton Exp $
+
+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/tests/textIndex.test b/tests/textIndex.test
index 1744834..2bfdbc1 100644
--- a/tests/textIndex.test
+++ b/tests/textIndex.test
@@ -3,21 +3,22 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: textIndex.test,v 1.2 1998/09/14 18:23:51 stanton Exp $
+# RCS: @(#) $Id: textIndex.test,v 1.3 1999/04/16 01:51:41 stanton Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
+# Some tests require the testtext command
-if {[string compare test [info procs test]] == 1} then \
- {source defs}
+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
@@ -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/tests/textMark.test b/tests/textMark.test
index 6bc2589..775c252 100644
--- a/tests/textMark.test
+++ b/tests/textMark.test
@@ -3,19 +3,20 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: textMark.test,v 1.2 1998/09/14 18:23:51 stanton Exp $
+# RCS: @(#) $Id: textMark.test,v 1.3 1999/04/16 01:51:41 stanton Exp $
-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/tests/textTag.test b/tests/textTag.test
index 79901cf..0cfc840 100644
--- a/tests/textTag.test
+++ b/tests/textTag.test
@@ -3,19 +3,20 @@
#
# Copyright (c) 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.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: textTag.test,v 1.2 1998/09/14 18:23:52 stanton Exp $
+# RCS: @(#) $Id: textTag.test,v 1.3 1999/04/16 01:51:41 stanton Exp $
-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
@@ -753,4 +761,20 @@ test textTag-16.7 {TkTextPickCurrent procedure} {
} {3.1}
catch {destroy .t}
-concat {}
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/textWind.test b/tests/textWind.test
index a62663d..4e11955 100644
--- a/tests/textWind.test
+++ b/tests/textWind.test
@@ -3,14 +3,14 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 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.
-#
-# RCS: @(#) $Id: textWind.test,v 1.2 1998/09/14 18:23:52 stanton Exp $
+# RCS: @(#) $Id: textWind.test,v 1.3 1999/04/16 01:51:41 stanton Exp $
-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/tests/tk.test b/tests/tk.test
index 89a853b..c62832c 100644
--- a/tests/tk.test
+++ b/tests/tk.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.
-#
-# RCS: @(#) $Id: tk.test,v 1.2 1998/09/14 18:23:52 stanton Exp $
+# RCS: @(#) $Id: tk.test,v 1.3 1999/04/16 01:51:41 stanton Exp $
-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 or scaling}}
set appname [tk appname]
test tk-2.1 {tk command: appname} {
@@ -78,3 +77,20 @@ 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
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/unixButton.test b/tests/unixButton.test
index 6788655..6604e36 100644
--- a/tests/unixButton.test
+++ b/tests/unixButton.test
@@ -5,13 +5,18 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-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.
-#
-# RCS: @(#) $Id: unixButton.test,v 1.2 1998/09/14 18:23:52 stanton Exp $
+# RCS: @(#) $Id: unixButton.test,v 1.3 1999/04/16 01:51:41 stanton Exp $
+
+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/tests/unixEmbed.test b/tests/unixEmbed.test
index 39a3cf5..2f2970d 100644
--- a/tests/unixEmbed.test
+++ b/tests/unixEmbed.test
@@ -3,18 +3,19 @@
# tests.
#
# Copyright (c) 1996-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.
-#
-# RCS: @(#) $Id: unixEmbed.test,v 1.4 1998/12/08 04:05:34 hershey Exp $
+# RCS: @(#) $Id: unixEmbed.test,v 1.5 1999/04/16 01:51:41 stanton Exp $
-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}
@@ -101,6 +102,7 @@ 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
}
@@ -621,8 +623,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/tests/unixFont.test b/tests/unixFont.test
index 9dcd672..896eda9 100644
--- a/tests/unixFont.test
+++ b/tests/unixFont.test
@@ -9,18 +9,19 @@
# at all sites.
#
# Copyright (c) 1996 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.
-#
-# RCS: @(#) $Id: unixFont.test,v 1.2 1998/09/14 18:23:52 stanton Exp $
+# RCS: @(#) $Id: unixFont.test,v 1.3 1999/04/16 01:51:42 stanton Exp $
-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}
@@ -222,23 +223,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 +284,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 +294,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/tests/unixMenu.test b/tests/unixMenu.test
index cd1e87b..ebc833b 100644
--- a/tests/unixMenu.test
+++ b/tests/unixMenu.test
@@ -4,13 +4,18 @@
# system.
#
# Copyright (c) 1995-1996 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.
-#
-# RCS: @(#) $Id: unixMenu.test,v 1.2 1998/09/14 18:23:52 stanton Exp $
+# RCS: @(#) $Id: unixMenu.test,v 1.3 1999/04/16 01:51:42 stanton Exp $
+
+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,20 @@ test unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} {
test unixMenu-26.1 {TkpMenuInit - nothing to do} {} {}
+# cleanup
deleteWindows
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/unixSend.test b/tests/unixSend.test
new file mode 100644
index 0000000..5914dd7
--- /dev/null
+++ b/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: unixSend.test,v 1.2 1999/04/16 01:51:42 stanton Exp $
+
+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/tests/unixWm.test b/tests/unixWm.test
index f70c589..11528d6 100644
--- a/tests/unixWm.test
+++ b/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.
+# 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.
-#
-# RCS: @(#) $Id: unixWm.test,v 1.4 1999/02/04 21:03:28 stanton Exp $
+# RCS: @(#) $Id: unixWm.test,v 1.5 1999/04/16 01:51:42 stanton Exp $
-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!),"
@@ -355,6 +356,7 @@ test unixWm-8.9 {icon windows} {nonPortable} {
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
}
@@ -1309,7 +1311,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 +1475,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
@@ -2291,6 +2297,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 +2338,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 +2357,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 +2382,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,7 +2390,21 @@ test unixWm-58.3 {exit processing} {
list $error $msg
} {0 {}}
-
+# cleanup
catch {destroy .t}
catch {removeFile script}
-concat {}
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/util.test b/tests/util.test
index 9793144..d3d5c91 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -3,14 +3,14 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 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.
-#
-# RCS: @(#) $Id: util.test,v 1.2 1998/09/14 18:23:53 stanton Exp $
+# RCS: @(#) $Id: util.test,v 1.3 1999/04/16 01:51:42 stanton Exp $
-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/tests/visual b/tests/visual
deleted file mode 100644
index d227503..0000000
--- a/tests/visual
+++ /dev/null
@@ -1,81 +0,0 @@
-#!/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: visual,v 1.2 1998/09/14 18:23:53 stanton Exp $
-
-set auto_path ". $auto_path"
-wm title . "Visual Tests for Tk"
-
-#-------------------------------------------------------
-# 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 exit
-
-menubutton .menu.group1 -text "Group 1" -menu .menu.group1.m
-menu .menu.group1.m
-.menu.group1.m add command -label "Canvas arcs" -command {source arc.tcl}
-.menu.group1.m add command -label "Beveled borders in text widgets" \
- -command {source bevel.tcl}
-.menu.group1.m add command -label "Colormap management" \
- -command {source cmap.tcl}
-.menu.group1.m add command -label "Label/button geometry" \
- -command {source butGeom.tcl}
-.menu.group1.m add command -label "Label/button colors" \
- -command {source 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 {source canvPsGrph.tcl}
-.menu.ps.m add command -label "Text" \
- -command {source canvPsText.tcl}
-.menu.ps.m add command -label "Bitmaps" \
- -command {source canvPsBmap.tcl}
-.menu.ps.m add command -label "Arcs" \
- -command {source 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
-
-# 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
-}
-
-# 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]}
diff --git a/tests/visual.test b/tests/visual.test
index 402bd5c..8614c2d 100644
--- a/tests/visual.test
+++ b/tests/visual.test
@@ -4,14 +4,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 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.
-#
-# RCS: @(#) $Id: visual.test,v 1.2 1998/09/14 18:23:53 stanton Exp $
+# RCS: @(#) $Id: visual.test,v 1.3 1999/04/16 01:51:43 stanton Exp $
-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/tests/visual_bb.test b/tests/visual_bb.test
new file mode 100644
index 0000000..efafc09
--- /dev/null
+++ b/tests/visual_bb.test
@@ -0,0 +1,109 @@
+#!/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: visual_bb.test,v 1.2 1999/04/16 01:51:43 stanton Exp $
+
+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 "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/tests/winButton.test b/tests/winButton.test
index 4202a6a..48a60d5 100644
--- a/tests/winButton.test
+++ b/tests/winButton.test
@@ -5,27 +5,23 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-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.
-#
-# RCS: @(#) $Id: winButton.test,v 1.3 1998/09/14 18:23:53 stanton Exp $
+# RCS: @(#) $Id: winButton.test,v 1.4 1999/04/16 01:51:43 stanton Exp $
-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/tests/winClipboard.test b/tests/winClipboard.test
index 6727a27..446dbd1 100644
--- a/tests/winClipboard.test
+++ b/tests/winClipboard.test
@@ -7,41 +7,52 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: winClipboard.test,v 1.3 1998/11/03 02:06:44 stanton Exp $
-
-if {$tcl_platform(platform)!="windows"} {
- return
-}
+# RCS: @(#) $Id: winClipboard.test,v 1.4 1999/04/16 01:51:43 stanton Exp $
-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} {
+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
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"]
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/winDialog.test b/tests/winDialog.test
new file mode 100644
index 0000000..64ed21b
--- /dev/null
+++ b/tests/winDialog.test
@@ -0,0 +1,335 @@
+# 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: winDialog.test,v 1.2 1999/04/16 01:51:43 stanton Exp $
+
+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
+
+ after 1 "$arg"
+}
+
+proc then {cmd} {
+ set ::command $cmd
+ set ::dialogresult {}
+
+ afterbody
+ vwait ::dialogresult
+ return $::dialogresult
+}
+
+proc afterbody {} {
+ if {$::tk_dialog == 0} {
+ 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} {knownBug 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.22 {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.22 {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-8.1 {OFNHookProc} {nt} {
+} {}
+
+test winDialog-6.1 {MakeFilter} {nt} {
+} {}
+
+test winDialog-5.1 {Tk_ChooseDirectoryObjCmd: no arguments} {nt} {
+ start {tk_chooseDirectory}
+ then {
+ Click cancel
+ }
+} {0}
+test winDialog-5.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-5.4 {Tk_ChooseDirectoryObjCmd: many arguments} {nt} {
+ start {tk_chooseDirectory -initialdir c:/ -mustexist 1 -parent . -title test}
+ then {
+ Click cancel
+ }
+} {0}
+test winDialog-5.5 {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-5.6 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() == TCL_OK} \
+ {nt} {
+ start {tk_chooseDirectory -title bar}
+ then {
+ Click cancel
+ }
+} {0}
+test winDialog-5.7 {Tk_ChooseDirectoryObjCmd: valid option, but missing value} \
+ {nt} {
+ list [catch {tk_chooseDirectory -initialdir bar -title} msg] $msg
+} {1 {value for "-title" missing}}
+test winDialog-5.12 {Tk_ChooseDirectoryObjCmd: initial directory} {nt} {
+# case DIR_INITIAL:
+
+ start {set x [tk_chooseDirectory -initialdir c:/ -title Foo]}
+ then {
+ Click 1
+ }
+ string tolower [set x]
+} {c:/}
+test winDialog-5.13 \
+ {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}}
+
+test winDialog-7.1 {Tk_MessageBoxObjCmd} {emptyTest nt} {} {}
+
+testwinevent debug 0
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/winFont.test b/tests/winFont.test
index a02b461..2c2798e 100644
--- a/tests/winFont.test
+++ b/tests/winFont.test
@@ -7,18 +7,13 @@
# but there are no results that can be checked.
#
# Copyright (c) 1996-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.
-#
-# RCS: @(#) $Id: winFont.test,v 1.3 1998/09/14 18:23:53 stanton Exp $
-
-if {$tcl_platform(platform)!="windows"} {
- return
-}
+# RCS: @(#) $Id: winFont.test,v 1.4 1999/04/16 01:51:43 stanton Exp $
-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}
@@ -45,10 +40,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 +53,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 +154,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 +168,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/tests/winMenu.test b/tests/winMenu.test
index 96fdd21..576646f 100644
--- a/tests/winMenu.test
+++ b/tests/winMenu.test
@@ -4,37 +4,23 @@
# system.
#
# Copyright (c) 1995-1996 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.
-#
-# RCS: @(#) $Id: winMenu.test,v 1.2 1998/09/14 18:23:53 stanton Exp $
-
-if {$tcl_platform(platform) != "windows"} {
- return
-}
+# RCS: @(#) $Id: winMenu.test,v 1.3 1999/04/16 01:51:43 stanton Exp $
-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/tests/winSend.test b/tests/winSend.test
new file mode 100644
index 0000000..34819b5
--- /dev/null
+++ b/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: winSend.test,v 1.2 1999/04/16 01:51:44 stanton Exp $
+
+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/tests/winWm.test b/tests/winWm.test
index c48fc3b..e4275fe 100644
--- a/tests/winWm.test
+++ b/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.
+# 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.
-#
-# RCS: @(#) $Id: winWm.test,v 1.2 1998/09/14 18:23:53 stanton Exp $
-
-if {$tcl_platform(platform) != "windows"} {
- return
-}
+# RCS: @(#) $Id: winWm.test,v 1.3 1999/04/16 01:51:44 stanton Exp $
-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,7 @@ test winWm-2.2 {TkpWmSetState} {
destroy .t
set result
} {normal withdrawn iconic normal}
-test winWm-2.3 {TkpWmSetState} {
+test winWm-2.3 {TkpWmSetState} {pcOnly} {
set result {}
toplevel .t
wm geometry .t 150x50+10+10
@@ -142,7 +137,7 @@ test winWm-2.3 {TkpWmSetState} {
} {{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 +156,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 +173,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 +192,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 +212,19 @@ test winWm-5.2 {UpdateGeometryInfo: menu resizing} {
destroy .t
set result
} {50 50 0}
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/window.test b/tests/window.test
index 3a1df2b..2de63a0 100644
--- a/tests/window.test
+++ b/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.
+# 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.
-#
-# RCS: @(#) $Id: window.test,v 1.3 1998/09/14 18:23:53 stanton Exp $
+# RCS: @(#) $Id: window.test,v 1.4 1999/04/16 01:51:44 stanton Exp $
-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/tests/winfo.test b/tests/winfo.test
index 826d1e2..82bc261 100644
--- a/tests/winfo.test
+++ b/tests/winfo.test
@@ -3,14 +3,13 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-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.
-#
-# RCS: @(#) $Id: winfo.test,v 1.3 1998/09/14 18:23:54 stanton Exp $
+# RCS: @(#) $Id: winfo.test,v 1.4 1999/04/16 01:51:44 stanton Exp $
-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,19 @@ test winfo-13.4 {[winfo containing] with embedded windows} {macOrUnix} {
foreach i [winfo children .] {
catch {destroy $i}
}
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/xmfbox.test b/tests/xmfbox.test
new file mode 100644
index 0000000..c5b6736
--- /dev/null
+++ b/tests/xmfbox.test
@@ -0,0 +1,153 @@
+# 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: xmfbox.test,v 1.2 1999/04/16 01:51:44 stanton Exp $
+
+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
+ 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 {}]
+ $foo(fEnt) delete 0 end
+ $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 {}]
+ $foo(fEnt) delete 0 end
+ $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 {}]
+ $foo(fEnt) delete 0 end
+ $foo(fEnt) insert 0 [pwd]/~nosuchuser1
+ tkMotifFDialog_InterpFilter $x
+ tkMotifFDialog_Update $x
+ $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 [$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 [$foo(fList) get 0 end] ~nosuchuser1]
+ $foo(fList) selection clear 0 end
+ $foo(fList) selection set $i
+ tkMotifFDialog_BrowseFList $x
+ $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 [$foo(fList) get 0 end] ~nosuchuser1]
+ $foo(fList) selection clear 0 end
+ $foo(fList) selection set $i
+ tkMotifFDialog_BrowseFList $x
+ tkMotifFDialog_ActivateFList $x
+ list $foo(selectPath) $foo(selectFile) $tkPriv(selectFilePath)
+} [list $testPWD ~nosuchuser1 $testPWD/~nosuchuser1]
+
+# cleanup
+cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+