diff options
Diffstat (limited to 'tests')
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 + + + + + + + + + + + + |