diff options
Diffstat (limited to 'contrib/tcl/tests')
93 files changed, 20314 insertions, 3933 deletions
diff --git a/contrib/tcl/tests/append.test b/contrib/tcl/tests/append.test index 2be7194a2648b..6733454ee100d 100644 --- a/contrib/tcl/tests/append.test +++ b/contrib/tcl/tests/append.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) append.test 1.14 96/04/05 15:28:42 +# SCCS: @(#) append.test 1.16 97/04/09 11:29:33 if {[string compare test [info procs test]] == 1} then {source defs} @@ -86,43 +86,47 @@ test append-4.6 {lappend command} { test append-4.7 {lappend command} { set x "a\{" lappend x abc -} "a{ abc" +} "a\\\{ abc" test append-4.8 {lappend command} { set x "\\\{" lappend x abc } "\\{ abc" test append-4.9 {lappend command} { set x " \{" - lappend x abc -} " {abc" + list [catch {lappend x abc} msg] $msg +} {1 {unmatched open brace in list}} test append-4.10 {lappend command} { set x " \{" - lappend x abc -} " {abc" + list [catch {lappend x abc} msg] $msg +} {1 {unmatched open brace in list}} test append-4.11 {lappend command} { set x "\{\{\{" - lappend x abc -} "{{{abc" + list [catch {lappend x abc} msg] $msg +} {1 {unmatched open brace in list}} test append-4.12 {lappend command} { set x "x \{\{\{" - lappend x abc -} "x {{{abc" + list [catch {lappend x abc} msg] $msg +} {1 {unmatched open brace in list}} test append-4.13 {lappend command} { set x "x\{\{\{" lappend x abc -} "x{{{ abc" +} "x\\\{\\\{\\\{ abc" test append-4.14 {lappend command} { set x " " lappend x abc -} " abc" +} "abc" test append-4.15 {lappend command} { set x "\\ " lappend x abc -} "\\ abc" +} "{ } abc" test append-4.16 {lappend command} { set x "x " lappend x abc } "x abc" +test append-4.17 {lappend command} { + catch {unset x} + lappend x +} {} proc check {var size} { set l [llength $var] @@ -152,7 +156,3 @@ test append-6.2 {lappend errors} { set x "" list [catch {lappend x(0) 44} msg] $msg } {1 {can't set "x(0)": variable isn't array}} -test append-6.3 {lappend errors} { - catch {unset x} - list [catch {lappend x} msg] $msg -} {1 {can't read "x": no such variable}} diff --git a/contrib/tcl/tests/basic.test b/contrib/tcl/tests/basic.test new file mode 100644 index 0000000000000..d2f370124417e --- /dev/null +++ b/contrib/tcl/tests/basic.test @@ -0,0 +1,381 @@ +# This file contains tests for the tclBasic.c source file. Tests appear in +# the same order as the C code that they test. The set of tests is +# currently incomplete since it currently includes only new tests for +# code changed for the addition of Tcl namespaces. Other variable- +# related tests appear in several other test files including +# assocd.test, cmdInfo.test, eval.test, expr.test, interp.test, +# and trace.test. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) basic.test 1.6 97/06/20 14:51:18 +# + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {namespace delete test_ns_basic} +catch {interp delete test_interp} +catch {rename p ""} +catch {rename q ""} +catch {rename cmd ""} +catch {unset x} + +test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} { + catch {interp delete test_interp} + interp create test_interp + interp eval test_interp { + namespace eval test_ns_basic { + proc p {} { + return [namespace current] + } + } + } + list [interp eval test_interp {test_ns_basic::p}] \ + [interp delete test_interp] +} {::test_ns_basic {}} + +test basic-2.1 {DeleteInterpProc, destroys interp's global namespace} { + catch {interp delete test_interp} + interp create test_interp + interp eval test_interp { + namespace eval test_ns_basic { + namespace export p + proc p {} { + return [namespace current] + } + } + namespace eval test_ns_2 { + namespace import ::test_ns_basic::p + variable v 27 + proc q {} { + variable v + return "[p] $v" + } + } + } + list [interp eval test_interp {test_ns_2::q}] \ + [interp eval test_interp {namespace delete ::}] \ + [catch {interp eval test_interp {set a 123}} msg] $msg \ + [interp delete test_interp] +} {{::test_ns_basic 27} {} 1 {invalid command name "set"} {}} + +test basic-3.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} { + catch {interp delete test_interp} + interp create test_interp + interp eval test_interp { + proc p {} { + return 27 + } + } + interp alias {} localP test_interp p + list [interp eval test_interp {p}] \ + [localP] \ + [test_interp hide p] \ + [catch {localP} msg] $msg \ + [interp delete test_interp] \ + [catch {localP} msg] $msg +} {27 27 {} 1 {invalid command name "p"} {} 1 {invalid command name "localP"}} + +test basic-4.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} { + catch {interp delete test_interp} + interp create test_interp + interp eval test_interp { + namespace eval test_ns_basic { + proc p {} { + return [namespace current] + } + } + } + list [catch {test_interp hide test_ns_basic::p} msg] $msg \ + [interp delete test_interp] +} {1 {hidden command names can't have namespace qualifiers} {}} +test basic-4.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} { + catch {namespace delete test_ns_basic} + catch {rename cmd ""} + proc cmd {} { ;# note that this is global + return [namespace current] + } + namespace eval test_ns_basic { + proc hideCmd {} { + interp hide {} cmd + } + proc exposeCmd {} { + interp expose {} cmd + } + proc callCmd {} { + cmd + } + } + list [test_ns_basic::callCmd] \ + [test_ns_basic::hideCmd] \ + [catch {cmd} msg] $msg \ + [test_ns_basic::exposeCmd] \ + [test_ns_basic::callCmd] \ + [namespace delete test_ns_basic] +} {:: {} 1 {invalid command name "cmd"} {} :: {}} + +test basic-5.1 {Tcl_ExposeCommand, an exposed cmd goes back to its containing namespace unless cmd name has namespace qualifiers} { + catch {namespace delete test_ns_basic} + catch {rename cmd ""} + proc cmd {} { ;# note that this is global + return [namespace current] + } + namespace eval test_ns_basic { + proc hideCmd {} { + interp hide {} cmd + } + proc exposeCmd {} { + interp expose {} cmd ::test_ns_basic::newCmd + } + proc callCmd {} { + cmd + } + } + list [test_ns_basic::callCmd] \ + [test_ns_basic::hideCmd] \ + [test_ns_basic::exposeCmd] \ + [test_ns_basic::newCmd] \ + [namespace delete test_ns_basic] +} {:: {} {} :: {}} +test basic-5.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} { + catch {rename p ""} + catch {rename cmd ""} + proc p {} { + cmd + } + proc cmd {} { + return 42 + } + list [p] \ + [interp hide {} cmd] \ + [proc cmd {} {return Hello}] \ + [cmd] \ + [rename cmd ""] \ + [interp expose {} cmd] \ + [p] +} {42 {} {} Hello {} {} 42} + +if {[info commands testcreatecommand] != {}} { + test basic-6.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [testcreatecommand create] \ + [test_ns_basic::createdcommand] \ + [testcreatecommand delete] + } {{} {CreatedCommandProc in ::test_ns_basic} {}} + test basic-6.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename value:at: ""} + list [testcreatecommand create2] \ + [value:at:] \ + [testcreatecommand delete2] + } {{} {CreatedCommandProc2 in ::} {}} +} +test basic-6.3 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_basic {} + proc test_ns_basic::cmd {} { ;# proc requires that ns already exist + return [namespace current] + } + list [test_ns_basic::cmd] \ + [namespace delete test_ns_basic] +} {::test_ns_basic {}} + +test basic-7.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename cmd ""} + namespace eval test_ns_basic { + proc p {} { + return "p in [namespace current]" + } + } + list [test_ns_basic::p] \ + [rename test_ns_basic::p test_ns_basic::q] \ + [test_ns_basic::q] +} {{p in ::test_ns_basic} {} {p in ::test_ns_basic}} +test basic-7.2 {TclRenameCommand, existing cmd must be found} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg +} {1 {can't rename "test_ns_basic::p": command doesn't exist}} +test basic-7.3 {TclRenameCommand, delete cmd if new name is empty} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_basic { + proc p {} { + return "p in [namespace current]" + } + } + list [info commands test_ns_basic::*] \ + [rename test_ns_basic::p ""] \ + [info commands test_ns_basic::*] +} {::test_ns_basic::p {} {}} +test basic-7.4 {TclRenameCommand, bad new name} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_basic { + proc p {} { + return "p in [namespace current]" + } + } + rename test_ns_basic::p :::george::martha +} {} +test basic-7.5 {TclRenameCommand, new name must not already exist} { + namespace eval test_ns_basic { + proc q {} { + return 42 + } + } + list [catch {rename test_ns_basic::q :::george::martha} msg] $msg +} {1 {can't rename to ":::george::martha": command already exists}} +test basic-7.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename p ""} + catch {rename q ""} + proc p {} { + return "p in [namespace current]" + } + proc q {} { + return "q in [namespace current]" + } + namespace eval test_ns_basic { + proc callP {} { + p + } + } + list [test_ns_basic::callP] \ + [rename q test_ns_basic::p] \ + [test_ns_basic::callP] +} {{p in ::} {} {q in ::}} + +test basic-8.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename p ""} + catch {rename q ""} + catch {unset x} + set x [namespace eval test_ns_basic::test_ns_basic2 { + # the following creates a cmd in the global namespace + testcmdtoken create p + }] + list [testcmdtoken name $x] \ + [rename ::p q] \ + [testcmdtoken name $x] +} {{p ::p} {} {q ::q}} +test basic-8.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} { + catch {rename q ""} + set x [testcmdtoken create test_ns_basic::test_ns_basic2::p] + list [testcmdtoken name $x] \ + [rename test_ns_basic::test_ns_basic2::p q] \ + [testcmdtoken name $x] +} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}} + +test namespace-9.1 {Tcl_GetCommandFullName} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_basic1 { + namespace export cmd* + proc cmd1 {} {} + proc cmd2 {} {} + } + namespace eval test_ns_basic2 { + namespace export * + namespace import ::test_ns_basic1::* + proc p {} {} + } + namespace eval test_ns_basic3 { + namespace import ::test_ns_basic2::* + proc q {} {} + list [namespace which -command foreach] \ + [namespace which -command q] \ + [namespace which -command p] \ + [namespace which -command cmd1] \ + [namespace which -command ::test_ns_basic2::cmd2] + } +} {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2} + +test basic-10.1 {Tcl_DeleteCommand2, invalidate all compiled code if cmd has compile proc} { + catch {interp delete test_interp} + catch {unset x} + interp create test_interp + interp eval test_interp { + proc useSet {} { + return [set a 123] + } + } + set x [interp eval test_interp {useSet}] + interp eval test_interp { + rename set "" + proc set {args} { + return "set called with $args" + } + } + list $x \ + [interp eval test_interp {useSet}] \ + [interp delete test_interp] +} {123 {set called with a 123} {}} +test basic-10.2 {Tcl_DeleteCommand2, deleting commands changes command epoch} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename p ""} + proc p {} { + return "global p" + } + namespace eval test_ns_basic { + proc p {} { + return "namespace p" + } + proc callP {} { + p + } + } + list [test_ns_basic::callP] \ + [rename test_ns_basic::p ""] \ + [test_ns_basic::callP] +} {{namespace p} {} {global p}} +test basic-10.3 {Tcl_DeleteCommand2, delete imported cmds that refer to a deleted cmd} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename p ""} + namespace eval test_ns_basic { + namespace export p + proc p {} {return 42} + } + namespace eval test_ns_basic2 { + namespace import ::test_ns_basic::* + proc callP {} { + p + } + } + list [test_ns_basic2::callP] \ + [info commands test_ns_basic2::*] \ + [rename test_ns_basic::p ""] \ + [catch {test_ns_basic2::callP} msg] $msg \ + [info commands test_ns_basic2::*] +} {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP} + +test basic-11.1 {TclObjInvoke, lookup of "unknown" command} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {interp delete test_interp} + interp create test_interp + interp eval test_interp { + proc unknown {args} { + return "global unknown" + } + namespace eval test_ns_basic { + proc unknown {args} { + return "namespace unknown" + } + } + } + list [interp alias test_interp newAlias test_interp doesntExist] \ + [catch {interp eval test_interp {newAlias}} msg] $msg \ + [interp delete test_interp] +} {newAlias 0 {global unknown} {}} + +catch {eval namespace delete [namespace children :: test_ns_*]} +catch {namespace delete george} +catch {interp delete test_interp} +catch {rename p ""} +catch {rename q ""} +catch {rename cmd ""} +catch {rename value:at: ""} +catch {unset x} diff --git a/contrib/tcl/tests/binary.test b/contrib/tcl/tests/binary.test new file mode 100644 index 0000000000000..13e1f8a949f3e --- /dev/null +++ b/contrib/tcl/tests/binary.test @@ -0,0 +1,1374 @@ +# This file tests the tclBinary.c file and the "binary" Tcl command. +# +# 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) 1997 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) binary.test 1.6 97/05/13 15:56:39 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test binary-1.1 {Tcl_BinaryObjCmd: bad args} { + list [catch {binary} msg] $msg +} {1 {wrong # args: should be "binary option ?arg arg ...?"}} +test binary-1.2 {Tcl_BinaryObjCmd: bad args} { + list [catch {binary foo} msg] $msg +} {1 {bad option "foo": must be format, or scan}} + +test binary-1.3 {Tcl_BinaryObjCmd: format error} { + list [catch {binary f} msg] $msg +} {1 {wrong # args: should be "binary f formatString ?arg arg ...?"}} +test binary-1.4 {Tcl_BinaryObjCmd: format} { + binary format "" +} {} + + + +test binary-2.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format a } msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-2.2 {Tcl_BinaryObjCmd: format} { + binary format a0 foo +} {} +test binary-2.3 {Tcl_BinaryObjCmd: format} { + binary format a f +} {f} +test binary-2.4 {Tcl_BinaryObjCmd: format} { + binary format a foo +} {f} +test binary-2.5 {Tcl_BinaryObjCmd: format} { + binary format a3 foo +} {foo} +test binary-2.6 {Tcl_BinaryObjCmd: format} { + binary format a5 foo +} foo\x00\x00 +test binary-2.7 {Tcl_BinaryObjCmd: format} { + binary format a*a3 foobarbaz blat +} foobarbazbla +test binary-2.8 {Tcl_BinaryObjCmd: format} { + binary format a*X3a2 foobar x +} foox\x00r + +test binary-3.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format A} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-3.2 {Tcl_BinaryObjCmd: format} { + binary format A0 f +} {} +test binary-3.3 {Tcl_BinaryObjCmd: format} { + binary format A f +} {f} +test binary-3.4 {Tcl_BinaryObjCmd: format} { + binary format A foo +} {f} +test binary-3.5 {Tcl_BinaryObjCmd: format} { + binary format A3 foo +} {foo} +test binary-3.6 {Tcl_BinaryObjCmd: format} { + binary format A5 foo +} {foo } +test binary-3.7 {Tcl_BinaryObjCmd: format} { + binary format A*A3 foobarbaz blat +} foobarbazbla +test binary-3.8 {Tcl_BinaryObjCmd: format} { + binary format A*X3A2 foobar x +} {foox r} + +test binary-4.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format B} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-4.2 {Tcl_BinaryObjCmd: format} { + binary format B0 1 +} {} +test binary-4.3 {Tcl_BinaryObjCmd: format} { + binary format B 1 +} \x80 +test binary-4.4 {Tcl_BinaryObjCmd: format} { + binary format B* 010011 +} \x4c +test binary-4.5 {Tcl_BinaryObjCmd: format} { + binary format B8 01001101 +} \x4d +test binary-4.6 {Tcl_BinaryObjCmd: format} { + binary format A2X2B9 oo 01001101 +} \x4d\x00 +test binary-4.7 {Tcl_BinaryObjCmd: format} { + binary format B9 010011011010 +} \x4d\x80 +test binary-4.8 {Tcl_BinaryObjCmd: format} { + binary format B2B3 10 010 +} \x80\x40 +test binary-4.9 {Tcl_BinaryObjCmd: format} { + list [catch {binary format B1B5 1 foo} msg] $msg +} {1 {expected binary string but got "foo" instead}} + +test binary-5.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format b} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-5.2 {Tcl_BinaryObjCmd: format} { + binary format b0 1 +} {} +test binary-5.3 {Tcl_BinaryObjCmd: format} { + binary format b 1 +} \x01 +test binary-5.4 {Tcl_BinaryObjCmd: format} { + binary format b* 010011 +} 2 +test binary-5.5 {Tcl_BinaryObjCmd: format} { + binary format b8 01001101 +} \xb2 +test binary-5.6 {Tcl_BinaryObjCmd: format} { + binary format A2X2b9 oo 01001101 +} \xb2\x00 +test binary-5.7 {Tcl_BinaryObjCmd: format} { + binary format b9 010011011010 +} \xb2\x01 +test binary-5.8 {Tcl_BinaryObjCmd: format} { + binary format b17 1 +} \x01\00\00 +test binary-5.9 {Tcl_BinaryObjCmd: format} { + binary format b2b3 10 010 +} \x01\x02 +test binary-5.10 {Tcl_BinaryObjCmd: format} { + list [catch {binary format b1b5 1 foo} msg] $msg +} {1 {expected binary string but got "foo" instead}} + +test binary-6.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format h} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-6.2 {Tcl_BinaryObjCmd: format} { + binary format h0 1 +} {} +test binary-6.3 {Tcl_BinaryObjCmd: format} { + binary format h 1 +} \x01 +test binary-6.4 {Tcl_BinaryObjCmd: format} { + binary format h c +} \x0c +test binary-6.5 {Tcl_BinaryObjCmd: format} { + binary format h* baadf00d +} \xab\xda\x0f\xd0 +test binary-6.6 {Tcl_BinaryObjCmd: format} { + binary format h4 c410 +} \x4c\x01 +test binary-6.7 {Tcl_BinaryObjCmd: format} { + binary format h6 c4102 +} \x4c\x01\x02 +test binary-6.8 {Tcl_BinaryObjCmd: format} { + binary format h5 c41020304 +} \x4c\x01\x02 +test binary-6.9 {Tcl_BinaryObjCmd: format} { + binary format a3X3h5 foo 2 +} \x02\x00\x00 +test binary-6.10 {Tcl_BinaryObjCmd: format} { + binary format h2h3 23 456 +} \x32\x54\x06 +test binary-6.11 {Tcl_BinaryObjCmd: format} { + list [catch {binary format h2 foo} msg] $msg +} {1 {expected hexadecimal string but got "foo" instead}} + +test binary-7.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format H} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-7.2 {Tcl_BinaryObjCmd: format} { + binary format H0 1 +} {} +test binary-7.3 {Tcl_BinaryObjCmd: format} { + binary format H 1 +} \x10 +test binary-7.4 {Tcl_BinaryObjCmd: format} { + binary format H c +} \xc0 +test binary-7.5 {Tcl_BinaryObjCmd: format} { + binary format H* baadf00d +} \xba\xad\xf0\x0d +test binary-7.6 {Tcl_BinaryObjCmd: format} { + binary format H4 c410 +} \xc4\x10 +test binary-7.7 {Tcl_BinaryObjCmd: format} { + binary format H6 c4102 +} \xc4\x10\x20 +test binary-7.8 {Tcl_BinaryObjCmd: format} { + binary format H5 c41023304 +} \xc4\x10\x20 +test binary-7.9 {Tcl_BinaryObjCmd: format} { + binary format a3X3H5 foo 2 +} \x20\x00\x00 +test binary-7.10 {Tcl_BinaryObjCmd: format} { + binary format H2H3 23 456 +} \x23\x45\x60 +test binary-7.11 {Tcl_BinaryObjCmd: format} { + list [catch {binary format H2 foo} msg] $msg +} {1 {expected hexadecimal string but got "foo" instead}} + +test binary-8.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format c} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-8.2 {Tcl_BinaryObjCmd: format} { + list [catch {binary format c blat} msg] $msg +} {1 {expected integer but got "blat"}} +test binary-8.3 {Tcl_BinaryObjCmd: format} { + binary format c0 0x50 +} {} +test binary-8.4 {Tcl_BinaryObjCmd: format} { + binary format c 0x50 +} P +test binary-8.5 {Tcl_BinaryObjCmd: format} { + binary format c 0x5052 +} R +test binary-8.6 {Tcl_BinaryObjCmd: format} { + binary format c2 {0x50 0x52} +} PR +test binary-8.7 {Tcl_BinaryObjCmd: format} { + binary format c2 {0x50 0x52 0x53} +} PR +test binary-8.8 {Tcl_BinaryObjCmd: format} { + binary format c* {0x50 0x52} +} PR +test binary-8.9 {Tcl_BinaryObjCmd: format} { + list [catch {binary format c2 {0x50}} msg] $msg +} {1 {number of elements in list does not match count}} +test binary-8.10 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + list [catch {binary format c $a} msg] $msg +} [list 1 "expected integer but got \"0x50 0x51\""] +test binary-8.11 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + binary format c1 $a +} P + +test binary-9.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format s} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-9.2 {Tcl_BinaryObjCmd: format} { + list [catch {binary format s blat} msg] $msg +} {1 {expected integer but got "blat"}} +test binary-9.3 {Tcl_BinaryObjCmd: format} { + binary format s0 0x50 +} {} +test binary-9.4 {Tcl_BinaryObjCmd: format} { + binary format s 0x50 +} P\x00 +test binary-9.5 {Tcl_BinaryObjCmd: format} { + binary format s 0x5052 +} RP +test binary-9.6 {Tcl_BinaryObjCmd: format} { + binary format s 0x505251 0x53 +} QR +test binary-9.7 {Tcl_BinaryObjCmd: format} { + binary format s2 {0x50 0x52} +} P\x00R\x00 +test binary-9.8 {Tcl_BinaryObjCmd: format} { + binary format s* {0x5051 0x52} +} QPR\x00 +test binary-9.9 {Tcl_BinaryObjCmd: format} { + binary format s2 {0x50 0x52 0x53} 0x54 +} P\x00R\x00 +test binary-9.10 {Tcl_BinaryObjCmd: format} { + list [catch {binary format s2 {0x50}} msg] $msg +} {1 {number of elements in list does not match count}} +test binary-9.11 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + list [catch {binary format s $a} msg] $msg +} [list 1 "expected integer but got \"0x50 0x51\""] +test binary-9.12 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + binary format s1 $a +} P\x00 + +test binary-10.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format S} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-10.2 {Tcl_BinaryObjCmd: format} { + list [catch {binary format S blat} msg] $msg +} {1 {expected integer but got "blat"}} +test binary-10.3 {Tcl_BinaryObjCmd: format} { + binary format S0 0x50 +} {} +test binary-10.4 {Tcl_BinaryObjCmd: format} { + binary format S 0x50 +} \x00P +test binary-10.5 {Tcl_BinaryObjCmd: format} { + binary format S 0x5052 +} PR +test binary-10.6 {Tcl_BinaryObjCmd: format} { + binary format S 0x505251 0x53 +} RQ +test binary-10.7 {Tcl_BinaryObjCmd: format} { + binary format S2 {0x50 0x52} +} \x00P\x00R +test binary-10.8 {Tcl_BinaryObjCmd: format} { + binary format S* {0x5051 0x52} +} PQ\x00R +test binary-10.9 {Tcl_BinaryObjCmd: format} { + binary format S2 {0x50 0x52 0x53} 0x54 +} \x00P\x00R +test binary-10.10 {Tcl_BinaryObjCmd: format} { + list [catch {binary format S2 {0x50}} msg] $msg +} {1 {number of elements in list does not match count}} +test binary-10.11 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + list [catch {binary format S $a} msg] $msg +} [list 1 "expected integer but got \"0x50 0x51\""] +test binary-10.12 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + binary format S1 $a +} \x00P + +test binary-11.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format i} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-11.2 {Tcl_BinaryObjCmd: format} { + list [catch {binary format i blat} msg] $msg +} {1 {expected integer but got "blat"}} +test binary-11.3 {Tcl_BinaryObjCmd: format} { + binary format i0 0x50 +} {} +test binary-11.4 {Tcl_BinaryObjCmd: format} { + binary format i 0x50 +} P\x00\x00\x00 +test binary-11.5 {Tcl_BinaryObjCmd: format} { + binary format i 0x5052 +} RP\x00\x00 +test binary-11.6 {Tcl_BinaryObjCmd: format} { + binary format i 0x505251 0x53 +} QRP\x00 +test binary-11.7 {Tcl_BinaryObjCmd: format} { + binary format i1 {0x505251 0x53} +} QRP\x00 +test binary-11.8 {Tcl_BinaryObjCmd: format} { + binary format i 0x53525150 +} PQRS +test binary-11.9 {Tcl_BinaryObjCmd: format} { + binary format i2 {0x50 0x52} +} P\x00\x00\x00R\x00\x00\x00 +test binary-11.10 {Tcl_BinaryObjCmd: format} { + binary format i* {0x50515253 0x52} +} SRQPR\x00\x00\x00 +test binary-11.11 {Tcl_BinaryObjCmd: format} { + list [catch {binary format i2 {0x50}} msg] $msg +} {1 {number of elements in list does not match count}} +test binary-11.12 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + list [catch {binary format i $a} msg] $msg +} [list 1 "expected integer but got \"0x50 0x51\""] +test binary-11.13 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + binary format i1 $a +} P\x00\x00\x00 + +test binary-12.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format I} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-12.2 {Tcl_BinaryObjCmd: format} { + list [catch {binary format I blat} msg] $msg +} {1 {expected integer but got "blat"}} +test binary-12.3 {Tcl_BinaryObjCmd: format} { + binary format I0 0x50 +} {} +test binary-12.4 {Tcl_BinaryObjCmd: format} { + binary format I 0x50 +} \x00\x00\x00P +test binary-12.5 {Tcl_BinaryObjCmd: format} { + binary format I 0x5052 +} \x00\x00PR +test binary-12.6 {Tcl_BinaryObjCmd: format} { + binary format I 0x505251 0x53 +} \x00PRQ +test binary-12.7 {Tcl_BinaryObjCmd: format} { + binary format I1 {0x505251 0x53} +} \x00PRQ +test binary-12.8 {Tcl_BinaryObjCmd: format} { + binary format I 0x53525150 +} SRQP +test binary-12.9 {Tcl_BinaryObjCmd: format} { + binary format I2 {0x50 0x52} +} \x00\x00\x00P\x00\x00\x00R +test binary-12.10 {Tcl_BinaryObjCmd: format} { + binary format I* {0x50515253 0x52} +} PQRS\x00\x00\x00R +test binary-12.11 {Tcl_BinaryObjCmd: format} { + list [catch {binary format i2 {0x50}} msg] $msg +} {1 {number of elements in list does not match count}} +test binary-12.12 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + list [catch {binary format I $a} msg] $msg +} [list 1 "expected integer but got \"0x50 0x51\""] +test binary-12.13 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + binary format I1 $a +} \x00\x00\x00P + +test binary-13.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format f} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-13.2 {Tcl_BinaryObjCmd: format} { + list [catch {binary format f blat} msg] $msg +} {1 {expected floating-point number but got "blat"}} +test binary-13.3 {Tcl_BinaryObjCmd: format} { + binary format f0 1.6 +} {} +test binary-13.4 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format f 1.6 +} \x3f\xcc\xcc\xcd +test binary-13.5 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format f 1.6 +} \xcd\xcc\xcc\x3f +test binary-13.6 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format f* {1.6 3.4} +} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +test binary-13.7 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format f* {1.6 3.4} +} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +test binary-13.8 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format f2 {1.6 3.4} +} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +test binary-13.9 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format f2 {1.6 3.4} +} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +test binary-13.10 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format f2 {1.6 3.4 5.6} +} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +test binary-13.11 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format f2 {1.6 3.4 5.6} +} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +test binary-13.12 {Tcl_BinaryObjCmd: float overflow} {nonPortable macOrUnix} { + binary format f -3.402825e+38 +} \x00\x80\x00\x00 +test binary-13.13 {Tcl_BinaryObjCmd: float overflow} {nonPortable pcOnly} { + binary format f -3.402825e+38 +} \x00\x00\x80\x00 +test binary-13.14 {Tcl_BinaryObjCmd: format} { + list [catch {binary format f2 {1.6}} msg] $msg +} {1 {number of elements in list does not match count}} +test binary-13.15 {Tcl_BinaryObjCmd: format} { + set a {1.6 3.4} + list [catch {binary format f $a} msg] $msg +} [list 1 "expected floating-point number but got \"1.6 3.4\""] +test binary-13.16 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + set a {1.6 3.4} + binary format f1 $a +} \x3f\xcc\xcc\xcd +test binary-13.17 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + set a {1.6 3.4} + binary format f1 $a +} \xcd\xcc\xcc\x3f + +test binary-14.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format d} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-14.2 {Tcl_BinaryObjCmd: format} { + list [catch {binary format d blat} msg] $msg +} {1 {expected floating-point number but got "blat"}} +test binary-14.3 {Tcl_BinaryObjCmd: format} { + binary format d0 1.6 +} {} +test binary-14.4 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format d 1.6 +} \x3f\xf9\x99\x99\x99\x99\x99\x9a +test binary-14.5 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format d 1.6 +} \x9a\x99\x99\x99\x99\x99\xf9\x3f +test binary-14.6 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format d* {1.6 3.4} +} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +test binary-14.7 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format d* {1.6 3.4} +} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +test binary-14.8 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format d2 {1.6 3.4} +} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +test binary-14.9 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format d2 {1.6 3.4} +} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +test binary-14.10 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format d2 {1.6 3.4 5.6} +} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +test binary-14.11 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format d2 {1.6 3.4 5.6} +} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +test binary-14.12 {Tcl_BinaryObjCmd: float overflow} {nonPortable unixOnly} { + binary format d NaN +} \x7f\xff\xff\xff\xff\xff\xff\xff +test binary-14.13 {Tcl_BinaryObjCmd: float overflow} {nonPortable macOnly} { + binary format d NaN +} \x7f\xf8\x02\xa0\x00\x00\x00\x00 +test binary-14.14 {Tcl_BinaryObjCmd: format} { + list [catch {binary format d2 {1.6}} msg] $msg +} {1 {number of elements in list does not match count}} +test binary-14.15 {Tcl_BinaryObjCmd: format} { + set a {1.6 3.4} + list [catch {binary format d $a} msg] $msg +} [list 1 "expected floating-point number but got \"1.6 3.4\""] +test binary-14.16 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + set a {1.6 3.4} + binary format d1 $a +} \x3f\xf9\x99\x99\x99\x99\x99\x9a +test binary-14.17 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + set a {1.6 3.4} + binary format d1 $a +} \x9a\x99\x99\x99\x99\x99\xf9\x3f + +test binary-15.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format ax*a "y" "z"} msg] $msg +} {1 {cannot use "*" in format string with "x"}} +test binary-15.2 {Tcl_BinaryObjCmd: format} { + binary format axa "y" "z" +} y\x00z +test binary-15.3 {Tcl_BinaryObjCmd: format} { + binary format ax3a "y" "z" +} y\x00\x00\x00z +test binary-15.4 {Tcl_BinaryObjCmd: format} { + binary format a*X3x3a* "foo" "z" +} \x00\x00\x00z + +test binary-16.1 {Tcl_BinaryObjCmd: format} { + binary format a*X*a "foo" "z" +} zoo +test binary-16.2 {Tcl_BinaryObjCmd: format} { + binary format aX3a "y" "z" +} z +test binary-16.3 {Tcl_BinaryObjCmd: format} { + binary format a*Xa* "foo" "zy" +} fozy +test binary-16.4 {Tcl_BinaryObjCmd: format} { + binary format a*X3a "foobar" "z" +} foozar +test binary-16.5 {Tcl_BinaryObjCmd: format} { + binary format a*X3aX2a "foobar" "z" "b" +} fobzar + +test binary-17.1 {Tcl_BinaryObjCmd: format} { + binary format @1 +} \x00 +test binary-17.2 {Tcl_BinaryObjCmd: format} { + binary format @5a2 "ab" +} \x00\x00\x00\x00\x00\x61\x62 +test binary-17.3 {Tcl_BinaryObjCmd: format} { + binary format {a* @0 a2 @* a*} "foobar" "ab" "blat" +} abobarblat + +test binary-18.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format u0a3 abc abd} msg] $msg +} {1 {bad field specifier "u"}} + + +test binary-19.1 {Tcl_BinaryObjCmd: errors} { + list [catch {binary s} msg] $msg +} {1 {wrong # args: should be "binary s value formatString ?varName varName ...?"}} +test binary-19.2 {Tcl_BinaryObjCmd: errors} { + list [catch {binary scan foo} msg] $msg +} {1 {wrong # args: should be "binary scan value formatString ?varName varName ...?"}} +test binary-19.3 {Tcl_BinaryObjCmd: scan} { + binary scan {} {} +} 0 + +test binary-20.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc a} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-20.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan abc a arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-20.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 abc + list [binary scan abc a0 arg1] $arg1 +} {1 {}} +test binary-20.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc a* arg1] $arg1 +} {1 abc} +test binary-20.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc a5 arg1] [info exist arg1] +} {0 0} +test binary-20.6 {Tcl_BinaryObjCmd: scan} { + set arg1 foo + list [binary scan abc a2 arg1] $arg1 +} {1 ab} +test binary-20.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + list [binary scan abcdef a2a2 arg1 arg2] $arg1 $arg2 +} {2 ab cd} +test binary-20.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc a2 arg1(a)] $arg1(a) +} {1 ab} +test binary-20.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc a arg1(a)] $arg1(a) +} {1 a} + +test binary-21.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc A} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-21.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan abc A arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-21.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 abc + list [binary scan abc A0 arg1] $arg1 +} {1 {}} +test binary-21.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc A* arg1] $arg1 +} {1 abc} +test binary-21.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc A5 arg1] [info exist arg1] +} {0 0} +test binary-21.6 {Tcl_BinaryObjCmd: scan} { + set arg1 foo + list [binary scan abc A2 arg1] $arg1 +} {1 ab} +test binary-21.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + list [binary scan abcdef A2A2 arg1 arg2] $arg1 $arg2 +} {2 ab cd} +test binary-21.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc A2 arg1(a)] $arg1(a) +} {1 ab} +test binary-21.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc A2 arg1(a)] $arg1(a) +} {1 ab} +test binary-21.10 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc A arg1(a)] $arg1(a) +} {1 a} +test binary-21.11 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan "abc def \x00 " A* arg1] $arg1 +} {1 {abc def}} +test binary-21.12 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan "abc def \x00ghi " A* arg1] $arg1 +} [list 1 "abc def \x00ghi"] + +test binary-22.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc b} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-22.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 b* arg1] $arg1 +} {1 0100101011001010} +test binary-22.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x82\x53 b arg1] $arg1 +} {1 0} +test binary-22.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x82\x53 b1 arg1] $arg1 +} {1 0} +test binary-22.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x82\x53 b0 arg1] $arg1 +} {1 {}} +test binary-22.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 b5 arg1] $arg1 +} {1 01001} +test binary-22.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 b8 arg1] $arg1 +} {1 01001010} +test binary-22.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 b14 arg1] $arg1 +} {1 01001010110010} +test binary-22.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 b14 arg1] $arg1 +} {0 foo} +test binary-22.10 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53 b1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-22.11 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x07\x87\x05 b5b* arg1 arg2] $arg1 $arg2 +} {2 11100 1110000110100000} + + +test binary-23.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc B} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-23.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 B* arg1] $arg1 +} {1 0101001001010011} +test binary-23.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x82\x53 B arg1] $arg1 +} {1 1} +test binary-23.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x82\x53 B1 arg1] $arg1 +} {1 1} +test binary-23.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 B0 arg1] $arg1 +} {1 {}} +test binary-23.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 B5 arg1] $arg1 +} {1 01010} +test binary-23.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 B8 arg1] $arg1 +} {1 01010010} +test binary-23.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 B14 arg1] $arg1 +} {1 01010010010100} +test binary-23.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 B14 arg1] $arg1 +} {0 foo} +test binary-23.10 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53 B1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-23.11 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x70\x87\x05 B5B* arg1 arg2] $arg1 $arg2 +} {2 01110 1000011100000101} + +test binary-24.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc h} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-24.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 h* arg1] $arg1 +} {1 253a} +test binary-24.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \xc2\xa3 h arg1] $arg1 +} {1 2} +test binary-24.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x82\x53 h1 arg1] $arg1 +} {1 2} +test binary-24.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 h0 arg1] $arg1 +} {1 {}} +test binary-24.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \xf2\x53 h2 arg1] $arg1 +} {1 2f} +test binary-24.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 h3 arg1] $arg1 +} {1 253} +test binary-24.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 h3 arg1] $arg1 +} {0 foo} +test binary-24.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53 h1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-24.10 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x70\x87\x05 h2h* arg1 arg2] $arg1 $arg2 +} {2 07 7850} + +test binary-25.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc H} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-25.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 H* arg1] $arg1 +} {1 52a3} +test binary-25.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \xc2\xa3 H arg1] $arg1 +} {1 c} +test binary-25.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x82\x53 H1 arg1] $arg1 +} {1 8} +test binary-25.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 H0 arg1] $arg1 +} {1 {}} +test binary-25.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \xf2\x53 H2 arg1] $arg1 +} {1 f2} +test binary-25.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 H3 arg1] $arg1 +} {1 525} +test binary-25.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 H3 arg1] $arg1 +} {0 foo} +test binary-25.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53 H1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-25.10 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x70\x87\x05 H2H* arg1 arg2] $arg1 $arg2 +} {2 70 8705} + +test binary-26.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc c} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-26.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 c* arg1] $arg1 +} {1 {82 -93}} +test binary-26.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 c arg1] $arg1 +} {1 82} +test binary-26.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 c1 arg1] $arg1 +} {1 82} +test binary-26.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 c0 arg1] $arg1 +} {1 {}} +test binary-26.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 c2 arg1] $arg1 +} {1 {82 -93}} +test binary-26.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \xff c arg1] $arg1 +} {1 -1} +test binary-26.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 c3 arg1] $arg1 +} {0 foo} +test binary-26.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53 c1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-26.10 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x70\x87\x05 c2c* arg1 arg2] $arg1 $arg2 +} {2 {112 -121} 5} + +test binary-27.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc s} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-27.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 s* arg1] $arg1 +} {1 {-23726 21587}} +test binary-27.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 s arg1] $arg1 +} {1 -23726} +test binary-27.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 s1 arg1] $arg1 +} {1 -23726} +test binary-27.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 s0 arg1] $arg1 +} {1 {}} +test binary-27.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 s2 arg1] $arg1 +} {1 {-23726 21587}} +test binary-27.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 s1 arg1] $arg1 +} {0 foo} +test binary-27.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53 s1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-27.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x52\xa3\x53\x54\x05 s2c* arg1 arg2] $arg1 $arg2 +} {2 {-23726 21587} 5} + +test binary-28.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc S} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-28.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 S* arg1] $arg1 +} {1 {21155 21332}} +test binary-28.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 S arg1] $arg1 +} {1 21155} +test binary-28.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 S1 arg1] $arg1 +} {1 21155} +test binary-28.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 S0 arg1] $arg1 +} {1 {}} +test binary-28.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 S2 arg1] $arg1 +} {1 {21155 21332}} +test binary-28.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 S1 arg1] $arg1 +} {0 foo} +test binary-28.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53 S1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-28.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x52\xa3\x53\x54\x05 S2c* arg1 arg2] $arg1 $arg2 +} {2 {21155 21332} 5} + +test binary-29.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc i} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-29.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i* arg1] $arg1 +} {1 {1414767442 67305985}} +test binary-29.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i arg1] $arg1 +} {1 1414767442} +test binary-29.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 i1 arg1] $arg1 +} {1 1414767442} +test binary-29.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53 i0 arg1] $arg1 +} {1 {}} +test binary-29.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i2 arg1] $arg1 +} {1 {1414767442 67305985}} +test binary-29.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 i1 arg1] $arg1 +} {0 foo} +test binary-29.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53\x53\x54 i1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-29.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 i2c* arg1 arg2] $arg1 $arg2 +} {2 {1414767442 67305985} 5} + +test binary-30.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc I} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-30.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I* arg1] $arg1 +} {1 {1386435412 16909060}} +test binary-30.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I arg1] $arg1 +} {1 1386435412} +test binary-30.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 I1 arg1] $arg1 +} {1 1386435412} +test binary-30.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53 I0 arg1] $arg1 +} {1 {}} +test binary-30.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I2 arg1] $arg1 +} {1 {1386435412 16909060}} +test binary-30.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 I1 arg1] $arg1 +} {0 foo} +test binary-30.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53\x53\x54 I1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-30.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 I2c* arg1 arg2] $arg1 $arg2 +} {2 {1386435412 16909060} 5} + +test binary-31.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc f} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-31.2 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1 +} {1 {1.6000000238418579 3.4000000953674316}} +test binary-31.3 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f* arg1] $arg1 +} {1 {1.6000000238418579 3.4000000953674316}} +test binary-31.4 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f arg1] $arg1 +} {1 1.6000000238418579} +test binary-31.5 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f arg1] $arg1 +} {1 1.6000000238418579} +test binary-31.6 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xcc\xcc\xcd f1 arg1] $arg1 +} {1 1.6000000238418579} +test binary-31.7 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \xcd\xcc\xcc\x3f f1 arg1] $arg1 +} {1 1.6000000238418579} +test binary-31.8 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xcc\xcc\xcd f0 arg1] $arg1 +} {1 {}} +test binary-31.9 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \xcd\xcc\xcc\x3f f0 arg1] $arg1 +} {1 {}} +test binary-31.10 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f2 arg1] $arg1 +} {1 {1.6000000238418579 3.4000000953674316}} +test binary-31.11 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f2 arg1] $arg1 +} {1 {1.6000000238418579 3.4000000953674316}} +test binary-31.12 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 f1 arg1] $arg1 +} {0 foo} +test binary-31.13 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x3f\xcc\xcc\xcd f1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-31.14 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 f2c* arg1 arg2] $arg1 $arg2 +} {2 {1.6000000238418579 3.4000000953674316} 5} +test binary-31.15 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2 +} {2 {1.6000000238418579 3.4000000953674316} 5} + +test binary-32.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc d} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-32.2 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d* arg1] $arg1 +} {1 {1.6000000000000001 3.3999999999999999}} +test binary-32.3 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d* arg1] $arg1 +} {1 {1.6000000000000001 3.3999999999999999}} +test binary-32.4 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d arg1] $arg1 +} {1 1.6000000000000001} +test binary-32.5 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d arg1] $arg1 +} {1 1.6000000000000001} +test binary-32.6 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1] $arg1 +} {1 1.6000000000000001} +test binary-32.7 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d1 arg1] $arg1 +} {1 1.6000000000000001} +test binary-32.8 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d0 arg1] $arg1 +} {1 {}} +test binary-32.9 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d0 arg1] $arg1 +} {1 {}} +test binary-32.10 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d2 arg1] $arg1 +} {1 {1.6000000000000001 3.3999999999999999}} +test binary-32.11 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d2 arg1] $arg1 +} {1 {1.6000000000000001 3.3999999999999999}} +test binary-32.12 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 d1 arg1] $arg1 +} {0 foo} +test binary-32.13 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-32.14 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33\x05 d2c* arg1 arg2] $arg1 $arg2 +} {2 {1.6000000000000001 3.3999999999999999} 5} +test binary-32.15 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40\x05 d2c* arg1 arg2] $arg1 $arg2 +} {2 {1.6000000000000001 3.3999999999999999} 5} + +test binary-33.1 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + list [binary scan abcdefg a2xa3 arg1 arg2] $arg1 $arg2 +} {2 ab def} +test binary-33.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + set arg2 foo + list [binary scan abcdefg a3x*a3 arg1 arg2] $arg1 $arg2 +} {1 abc foo} +test binary-33.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + set arg2 foo + list [binary scan abcdefg a3x20a3 arg1 arg2] $arg1 $arg2 +} {1 abc foo} +test binary-33.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + set arg2 foo + list [binary scan abc a3x20a3 arg1 arg2] $arg1 $arg2 +} {1 abc foo} +test binary-33.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x1a1 arg1] $arg1 +} {1 b} +test binary-33.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x5a1 arg1] $arg1 +} {1 f} +test binary-33.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x0a1 arg1] $arg1 +} {1 a} + +test binary-34.1 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + list [binary scan abcdefg a2Xa3 arg1 arg2] $arg1 $arg2 +} {2 ab bcd} +test binary-34.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + set arg2 foo + list [binary scan abcdefg a3X*a3 arg1 arg2] $arg1 $arg2 +} {2 abc abc} +test binary-34.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + set arg2 foo + list [binary scan abcdefg a3X20a3 arg1 arg2] $arg1 $arg2 +} {2 abc abc} +test binary-34.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc X20a3 arg1] $arg1 +} {1 abc} +test binary-34.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x*X1a1 arg1] $arg1 +} {1 f} +test binary-34.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x*X5a1 arg1] $arg1 +} {1 b} +test binary-34.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x3X0a1 arg1] $arg1 +} {1 d} + +test binary-35.1 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + list [catch {binary scan abcdefg a2@a3 arg1 arg2} msg] $msg +} {1 {missing count for "@" field specifier}} +test binary-35.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + set arg2 foo + list [binary scan abcdefg a3@*a3 arg1 arg2] $arg1 $arg2 +} {1 abc foo} +test binary-35.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + set arg2 foo + list [binary scan abcdefg a3@20a3 arg1 arg2] $arg1 $arg2 +} {1 abc foo} +test binary-35.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef @2a3 arg1] $arg1 +} {1 cde} +test binary-35.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x*@1a1 arg1] $arg1 +} {1 b} +test binary-35.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x*@0a1 arg1] $arg1 +} {1 a} + +test binary-36.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abcdef u0a3} msg] $msg +} {1 {bad field specifier "u"}} + +# GetFormatSpec is pretty thoroughly tested above, but there are a few +# cases we should text explicitly + +test binary-37.1 {GetFormatSpec: whitespace} { + binary format "a3 a5 a3" foo barblat baz +} foobarblbaz +test binary-37.2 {GetFormatSpec: whitespace} { + binary format " " foo +} {} +test binary-37.3 {GetFormatSpec: whitespace} { + binary format " a3" foo +} foo +test binary-37.4 {GetFormatSpec: whitespace} { + binary format "" foo +} {} +test binary-37.5 {GetFormatSpec: whitespace} { + binary format "" foo +} {} +test binary-37.6 {GetFormatSpec: whitespace} { + binary format " a3 " foo +} foo +test binary-37.7 {GetFormatSpec: numbers} { + list [catch {binary scan abcdef "x-1" foo} msg] $msg +} {1 {bad field specifier "-"}} +test binary-37.8 {GetFormatSpec: numbers} { + catch {unset arg1} + set arg1 foo + list [binary scan abcdef "a0x3" arg1] $arg1 +} {1 {}} + +# FormatNumber is thoroughly tested above, so we don't have any explicit tests + +test binary-38.1 {ScanNumber: sign extension} { + catch {unset arg1} + list [binary scan \x52\xa3 c2 arg1] $arg1 +} {1 {82 -93}} +test binary-38.2 {ScanNumber: sign extension} { + catch {unset arg1} + list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 s4 arg1] $arg1 +} {1 {513 -32511 386 -32127}} +test binary-38.3 {ScanNumber: sign extension} { + catch {unset arg1} + list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 S4 arg1] $arg1 +} {1 {258 385 -32255 -32382}} +test binary-38.4 {ScanNumber: sign extension} { + catch {unset arg1} + list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 i5 arg1] $arg1 +} {1 {33620225 16843137 16876033 25297153 -2130640639}} +test binary-38.5 {ScanNumber: sign extension} { + catch {unset arg1} + list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 I5 arg1] $arg1 +} {1 {16843010 -2130640639 25297153 16876033 16843137}} + +test binary-39.1 {ScanNumber: floating point overflow} {nonPortable unixOnly} { + catch {unset arg1} + list [binary scan \xff\xff\xff\xff f1 arg1] $arg1 +} {1 -NaN} +test binary-39.2 {ScanNumber: floating point overflow} {nonPortable macOnly} { + catch {unset arg1} + list [binary scan \xff\xff\xff\xff f1 arg1] $arg1 +} {1 -NAN(255)} +test binary-39.3 {ScanNumber: floating point overflow} {nonPortable pcOnly} { + catch {unset arg1} + set result [binary scan \xff\xff\xff\xff f1 arg1] + if {([string compare $arg1 -1.\#QNAN] == 0) + || ([string compare $arg1 -NAN] == 0)} { + lappend result success + } else { + lappend result failure + } +} {1 success} +test binary-39.4 {ScanNumber: floating point overflow} {nonPortable unixOnly} { + catch {unset arg1} + list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1] $arg1 +} {1 -NaN} +test binary-39.5 {ScanNumber: floating point overflow} {nonPortable macOnly} { + catch {unset arg1} + list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1] $arg1 +} {1 -NAN(255)} +test binary-39.6 {ScanNumber: floating point overflow} {nonPortable pcOnly} { + catch {unset arg1} + set result [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1] + if {([string compare $arg1 -1.\#QNAN] == 0) + || ([string compare $arg1 -NAN] == 0)} { + lappend result success + } else { + lappend result failure + } +} {1 success} diff --git a/contrib/tcl/tests/clock.test b/contrib/tcl/tests/clock.test index cf8d94bfae6d8..b75ee32f4b247 100644 --- a/contrib/tcl/tests/clock.test +++ b/contrib/tcl/tests/clock.test @@ -4,12 +4,12 @@ # 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) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1995-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) clock.test 1.6 96/07/23 16:16:43 +# SCCS: @(#) clock.test 1.14 97/06/02 10:18:12 if {[string compare test [info procs test]] == 1} then {source defs} @@ -18,7 +18,7 @@ test clock-1.1 {clock tests} { } {1 {wrong # args: should be "clock option ?arg ...?"}} test clock-1.2 {clock tests} { list [catch {clock foo} msg] $msg -} {1 {unknown option "foo": must be clicks, format, scan, or seconds}} +} {1 {bad option "foo": must be clicks, format, scan, or seconds}} # clock clicks test clock-2.1 {clock clicks tests} { @@ -27,7 +27,7 @@ test clock-2.1 {clock clicks tests} { } {} test clock-2.2 {clock clicks tests} { list [catch {clock clicks foo} msg] $msg -} {1 {wrong # arguments: must be "clock clicks"}} +} {1 {wrong # args: should be "clock clicks"}} test clock-2.3 {clock clicks tests} { set start [clock clicks] after 10 @@ -42,26 +42,35 @@ test clock-3.1 {clock format tests} {unixOnly} { } {Sun Nov 04 03:02:46 AM 1990} test clock-3.2 {clock format tests} { list [catch {clock format} msg] $msg -} {1 {wrong # args: clock format clockval ?-format string? ?-gmt boolean?}} +} {1 {wrong # args: should be "clock format clockval ?-format string? ?-gmt boolean?"}} test clock-3.3 {clock format tests} { list [catch {clock format foo} msg] $msg -} {1 {expected unsigned time but got "foo"}} +} {1 {expected integer but got "foo"}} test clock-3.4 {clock format tests} {unixOrPc} { set clockval 657687766 clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true } "Sun Nov 04 03:02:46 AM 1990" test clock-3.5 {clock format tests} { list [catch {clock format a b c d e g} msg] $msg -} {1 {wrong # args: clock format clockval ?-format string? ?-gmt boolean?}} -test clock-3.6 {clock format tests} {unixOrPc} { +} {1 {wrong # args: should be "clock format clockval ?-format string? ?-gmt boolean?"}} +test clock-3.6 {clock format tests} {unixOrPc nonPortable} { set clockval -1 clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true } "Wed Dec 31 11:59:59 PM 1969" +test clock-3.7 {clock format tests} { + list [catch {clock format 123 -bad arg} msg] $msg +} {1 {bad switch "-bad": must be -format, or -gmt}} +test clock-3.8 {clock format tests} { + clock format 123 -format "x" +} x +test clock-3.9 {clock format tests} { + clock format 123 -format "" +} "" # clock scan test clock-4.1 {clock scan tests} { list [catch {clock scan} msg] $msg -} {1 {wrong # args: clock scan dateString ?-base clockValue? ?-gmt boolean?}} +} {1 {wrong # args: should be "clock scan dateString ?-base clockValue? ?-gmt boolean?"}} test clock-4.2 {clock scan tests} { list [catch {clock scan "bad-string"} msg] $msg } {1 {unable to convert date-time string "bad-string"}} @@ -90,6 +99,18 @@ test clock-4.8 {clock scan tests} { set time [clock scan "Oct 23,1992 15:00" -gmt true] clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true } {Oct 23,1992 15:00 GMT} +test clock-4.9 {clock scan tests} { + list [catch {clock scan "Jan 12" -bad arg} msg] $msg +} {1 {bad switch "-bad": must be -base, or -gmt}} +# The following two two tests test the two year date policy +test clock-4.10 {clock scan tests} { + set time [clock scan "1/1/71" -gmt true] + clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true +} {Jan 01,1971 00:00 GMT} +test clock-4.11 {clock scan tests} { + set time [clock scan "1/1/37" -gmt true] + clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true +} {Jan 01,2037 00:00 GMT} # clock seconds test clock-5.1 {clock seconds tests} { @@ -98,7 +119,7 @@ test clock-5.1 {clock seconds tests} { } {} test clock-5.2 {clock seconds tests} { list [catch {clock seconds foo} msg] $msg -} {1 {wrong # arguments: must be "clock seconds"}} +} {1 {wrong # args: should be "clock seconds"}} test clock-5.3 {clock seconds tests} { set start [clock seconds] after 2000 @@ -106,3 +127,21 @@ test clock-5.3 {clock seconds tests} { expr "$end > $start" } {1} +# The following dates check certain roll over dates +set day [expr 24 * 60 * 60] +test clock-6.1 {clock roll over dates} { + set time [clock scan "12/31/1998" -gmt true] + clock format [expr $time + $day] -format {%b %d,%Y %H:%M GMT} -gmt true +} {Jan 01,1999 00:00 GMT} +test clock-6.2 {clock roll over dates} { + set time [clock scan "12/31/1999" -gmt true] + clock format [expr $time + $day] -format {%b %d,%Y %H:%M GMT} -gmt true +} {Jan 01,2000 00:00 GMT} +test clock-6.3 {clock roll over dates} { + set time [clock scan "2/28/2000" -gmt true] + clock format [expr $time + $day] -format {%b %d,%Y %H:%M GMT} -gmt true +} {Feb 29,2000 00:00 GMT} +test clock-6.4 {clock roll over dates} { + set time [clock scan "2/29/2000" -gmt true] + clock format [expr $time + $day] -format {%b %d,%Y %H:%M GMT} -gmt true +} {Mar 01,2000 00:00 GMT} diff --git a/contrib/tcl/tests/cmdAH.test b/contrib/tcl/tests/cmdAH.test index 97c5bddf7c1ba..cbf3ae739e9db 100644 --- a/contrib/tcl/tests/cmdAH.test +++ b/contrib/tcl/tests/cmdAH.test @@ -4,196 +4,230 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996 by Sun Microsystems, Inc. +# Copyright (c) 1996-1997 by Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) cmdAH.test 1.9 96/07/01 14:38:19 +# SCCS: @(#) cmdAH.test 1.30 97/06/23 18:17:47 if {[string compare test [info procs test]] == 1} then {source defs} global env set platform [testgetplatform] -test cmdah-1.1 {Tcl_FileCmd} { +test cmdAH-1.1 {Tcl_FileObjCmd} { list [catch file msg] $msg -} {1 {wrong # args: should be "file option name ?arg ...?"}} -test cmdah-1.2 {Tcl_FileCmd} { +} {1 {wrong # args: should be "file option ?arg ...?"}} +test cmdAH-1.2 {Tcl_FileObjCmd} { list [catch {file x} msg] $msg -} {1 {wrong # args: should be "file option name ?arg ...?"}} +} {1 {bad option "x": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +test cmdAH-1.3 {Tcl_FileObjCmd} { + list [catch {file atime} msg] $msg +} {1 {wrong # args: should be "file atime name ?arg ...?"}} + + +#volume + +test cmdAH-2.1 {Tcl_FileObjCmd: volumes} { + list [catch {file volumes x} msg] $msg +} {1 {wrong # args: should be "file volumes"}} +test cmdAH-2.2 {Tcl_FileObjCmd: volumes} { + set volumeList [file volumes] + if { [llength $volumeList] == 0 } { + set result 0 + } else { + set result 1 + } +} {1} +test cmdAH-2.3 {Tcl_FileObjCmd: volumes} {macOrUnix} { + set volumeList [file volumes] + catch [list glob -nocomplain [lindex $volumeList 0]*] +} {0} +test cmdAH-2.4 {Tcl_FileObjCmd: volumes} {pcOnly} { + set volumeList [file volumes] + list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}] +} {0 1 0} + +# attributes + +test cmdAH-3.1 {Tcl_FileObjCmd - file attrs} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file}] [file delete -force foo.file] +} {0 {}} # dirname -test cmdah-2.1 {Tcl_FileCmd: dirname} { +test cmdAH-4.1 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname a b} msg] $msg } {1 {wrong # args: should be "file dirname name"}} -test cmdah-2.2 {Tcl_FileCmd: dirname} { +test cmdAH-4.2 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname /a/b } /a -test cmdah-2.3 {Tcl_FileCmd: dirname} { +test cmdAH-4.3 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname {} } . -test cmdah-2.4 {Tcl_FileCmd: dirname} { +test cmdAH-4.4 {Tcl_FileObjCmd: dirname} { testsetplatform mac file dirname {} } : -test cmdah-2.5 {Tcl_FileCmd: dirname} { +test cmdAH-4.5 {Tcl_FileObjCmd: dirname} { testsetplatform win file dirname {} } . -test cmdah-2.6 {Tcl_FileCmd: dirname} { +test cmdAH-4.6 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname .def } . -test cmdah-2.7 {Tcl_FileCmd: dirname} { +test cmdAH-4.7 {Tcl_FileObjCmd: dirname} { testsetplatform mac file dirname a } : -test cmdah-2.8 {Tcl_FileCmd: dirname} { +test cmdAH-4.8 {Tcl_FileObjCmd: dirname} { testsetplatform win file dirname a } . -test cmdah-2.9 {Tcl_FileCmd: dirname} { +test cmdAH-4.9 {Tcl_FileObjCmd: dirname} { testsetplatform unix - file d a/b/c.d + file dirname a/b/c.d } a/b -test cmdah-2.10 {Tcl_FileCmd: dirname} { +test cmdAH-4.10 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname a/b.c/d } a/b.c -test cmdah-2.11 {Tcl_FileCmd: dirname} { +test cmdAH-4.11 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname /. } / -test cmdah-2.12 {Tcl_FileCmd: dirname} { +test cmdAH-4.12 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname /} msg] $msg } {0 /} -test cmdah-2.13 {Tcl_FileCmd: dirname} { +test cmdAH-4.13 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname /foo} msg] $msg } {0 /} -test cmdah-2.14 {Tcl_FileCmd: dirname} { +test cmdAH-4.14 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname //foo} msg] $msg } {0 /} -test cmdah-2.15 {Tcl_FileCmd: dirname} { +test cmdAH-4.15 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname //foo/bar} msg] $msg } {0 /foo} -test cmdah-2.16 {Tcl_FileCmd: dirname} { +test cmdAH-4.16 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname {//foo\/bar/baz}} msg] $msg } {0 {/foo\/bar}} -test cmdah-2.17 {Tcl_FileCmd: dirname} { +test cmdAH-4.17 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname {//foo\/bar/baz/blat}} msg] $msg } {0 {/foo\/bar/baz}} -test cmdah-2.18 {Tcl_FileCmd: dirname} { +test cmdAH-4.18 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname /foo//} msg] $msg } {0 /} -test cmdah-2.19 {Tcl_FileCmd: dirname} { +test cmdAH-4.19 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname ./a} msg] $msg } {0 .} -test cmdah-2.20 {Tcl_FileCmd: dirname} { +test cmdAH-4.20 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname a/.a} msg] $msg } {0 a} -test cmdah-2.21 {Tcl_FileCmd: dirname} { +test cmdAH-4.21 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname c:foo} msg] $msg } {0 c:} -test cmdah-2.22 {Tcl_FileCmd: dirname} { +test cmdAH-4.22 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname c:} msg] $msg } {0 c:} -test cmdah-2.23 {Tcl_FileCmd: dirname} { +test cmdAH-4.23 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname c:/} msg] $msg } {0 c:/} -test cmdah-2.24 {Tcl_FileCmd: dirname} { +test cmdAH-4.24 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname {c:\foo}} msg] $msg } {0 c:/} -test cmdah-2.25 {Tcl_FileCmd: dirname} { +test cmdAH-4.25 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname {//foo/bar/baz}} msg] $msg } {0 //foo/bar} -test cmdah-2.26 {Tcl_FileCmd: dirname} { +test cmdAH-4.26 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname {//foo/bar}} msg] $msg } {0 //foo/bar} -test cmdah-2.27 {Tcl_FileCmd: dirname} { +test cmdAH-4.27 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :} msg] $msg } {0 :} -test cmdah-2.28 {Tcl_FileCmd: dirname} { +test cmdAH-4.28 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :Foo} msg] $msg } {0 :} -test cmdah-2.29 {Tcl_FileCmd: dirname} { +test cmdAH-4.29 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname Foo:} msg] $msg } {0 Foo:} -test cmdah-2.30 {Tcl_FileCmd: dirname} { +test cmdAH-4.30 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname Foo:bar} msg] $msg } {0 Foo:} -test cmdah-2.31 {Tcl_FileCmd: dirname} { +test cmdAH-4.31 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :Foo:bar} msg] $msg } {0 :Foo} -test cmdah-2.32 {Tcl_FileCmd: dirname} { +test cmdAH-4.32 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ::} msg] $msg } {0 :} -test cmdah-2.33 {Tcl_FileCmd: dirname} { +test cmdAH-4.33 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :::} msg] $msg } {0 ::} -test cmdah-2.34 {Tcl_FileCmd: dirname} { +test cmdAH-4.34 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname /foo/bar/} msg] $msg } {0 foo:} -test cmdah-2.35 {Tcl_FileCmd: dirname} { +test cmdAH-4.35 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname /foo/bar} msg] $msg } {0 foo:} -test cmdah-2.36 {Tcl_FileCmd: dirname} { +test cmdAH-4.36 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname /foo} msg] $msg } {0 foo:} -test cmdah-2.37 {Tcl_FileCmd: dirname} { +test cmdAH-4.37 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname foo} msg] $msg } {0 :} -test cmdah-2.38 {Tcl_FileCmd: dirname} { +test cmdAH-4.38 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname ~/foo} msg] $msg } {0 ~} -test cmdah-2.39 {Tcl_FileCmd: dirname} { +test cmdAH-4.39 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname ~bar/foo} msg] $msg } {0 ~bar} -test cmdah-2.40 {Tcl_FileCmd: dirname} { +test cmdAH-4.40 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ~bar/foo} msg] $msg } {0 ~bar:} -test cmdah-2.41 {Tcl_FileCmd: dirname} { +test cmdAH-4.41 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ~/foo} msg] $msg } {0 ~:} -test cmdah-2.42 {Tcl_FileCmd: dirname} { +test cmdAH-4.42 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ~:baz} msg] $msg } {0 ~:} -test cmdah-2.43 {Tcl_FileCmd: dirname} { +test cmdAH-4.43 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -202,7 +236,7 @@ test cmdah-2.43 {Tcl_FileCmd: dirname} { set env(HOME) $temp set result } {0 /home} -test cmdah-2.44 {Tcl_FileCmd: dirname} { +test cmdAH-4.44 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "~" @@ -211,7 +245,7 @@ test cmdah-2.44 {Tcl_FileCmd: dirname} { set env(HOME) $temp set result } {0 ~} -test cmdah-2.45 {Tcl_FileCmd: dirname} { +test cmdAH-4.45 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -220,7 +254,7 @@ test cmdah-2.45 {Tcl_FileCmd: dirname} { set env(HOME) $temp set result } {0 /home} -test cmdah-2.46 {Tcl_FileCmd: dirname} { +test cmdAH-4.46 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -232,171 +266,171 @@ test cmdah-2.46 {Tcl_FileCmd: dirname} { # tail -test cmdah-3.1 {Tcl_FileCmd: tail} { +test cmdAH-5.1 {Tcl_FileObjCmd: tail} { testsetplatform unix list [catch {file tail a b} msg] $msg } {1 {wrong # args: should be "file tail name"}} -test cmdah-3.2 {Tcl_FileCmd: tail} { +test cmdAH-5.2 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /a/b } b -test cmdah-3.3 {Tcl_FileCmd: tail} { +test cmdAH-5.3 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {} } {} -test cmdah-3.4 {Tcl_FileCmd: tail} { +test cmdAH-5.4 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail {} } {} -test cmdah-3.5 {Tcl_FileCmd: tail} { +test cmdAH-5.5 {Tcl_FileObjCmd: tail} { testsetplatform win file tail {} } {} -test cmdah-3.6 {Tcl_FileCmd: tail} { +test cmdAH-5.6 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail .def } .def -test cmdah-3.7 {Tcl_FileCmd: tail} { +test cmdAH-5.7 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail a } a -test cmdah-3.8 {Tcl_FileCmd: tail} { +test cmdAH-5.8 {Tcl_FileObjCmd: tail} { testsetplatform win file tail a } a -test cmdah-3.9 {Tcl_FileCmd: tail} { +test cmdAH-5.9 {Tcl_FileObjCmd: tail} { testsetplatform unix file ta a/b/c.d } c.d -test cmdah-3.10 {Tcl_FileCmd: tail} { +test cmdAH-5.10 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail a/b.c/d } d -test cmdah-3.11 {Tcl_FileCmd: tail} { +test cmdAH-5.11 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /. } . -test cmdah-3.12 {Tcl_FileCmd: tail} { +test cmdAH-5.12 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail / } {} -test cmdah-3.13 {Tcl_FileCmd: tail} { +test cmdAH-5.13 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /foo } foo -test cmdah-3.14 {Tcl_FileCmd: tail} { +test cmdAH-5.14 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail //foo } foo -test cmdah-3.15 {Tcl_FileCmd: tail} { +test cmdAH-5.15 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail //foo/bar } bar -test cmdah-3.16 {Tcl_FileCmd: tail} { +test cmdAH-5.16 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {//foo\/bar/baz} } baz -test cmdah-3.17 {Tcl_FileCmd: tail} { +test cmdAH-5.17 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {//foo\/bar/baz/blat} } blat -test cmdah-3.18 {Tcl_FileCmd: tail} { +test cmdAH-5.18 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /foo// } foo -test cmdah-3.19 {Tcl_FileCmd: tail} { +test cmdAH-5.19 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail ./a } a -test cmdah-3.20 {Tcl_FileCmd: tail} { +test cmdAH-5.20 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail a/.a } .a -test cmdah-3.21 {Tcl_FileCmd: tail} { +test cmdAH-5.21 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:foo } foo -test cmdah-3.22 {Tcl_FileCmd: tail} { +test cmdAH-5.22 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c: } {} -test cmdah-3.23 {Tcl_FileCmd: tail} { +test cmdAH-5.23 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:/ } {} -test cmdah-3.24 {Tcl_FileCmd: tail} { +test cmdAH-5.24 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {c:\foo} } foo -test cmdah-3.25 {Tcl_FileCmd: tail} { +test cmdAH-5.25 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {//foo/bar/baz} } baz -test cmdah-3.26 {Tcl_FileCmd: tail} { +test cmdAH-5.26 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {//foo/bar} } {} -test cmdah-3.27 {Tcl_FileCmd: tail} { +test cmdAH-5.27 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail : } : -test cmdah-3.28 {Tcl_FileCmd: tail} { +test cmdAH-5.28 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail :Foo } Foo -test cmdah-3.29 {Tcl_FileCmd: tail} { +test cmdAH-5.29 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail Foo: } {} -test cmdah-3.30 {Tcl_FileCmd: tail} { +test cmdAH-5.30 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail Foo:bar } bar -test cmdah-3.31 {Tcl_FileCmd: tail} { +test cmdAH-5.31 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail :Foo:bar } bar -test cmdah-3.32 {Tcl_FileCmd: tail} { +test cmdAH-5.32 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail :: } :: -test cmdah-3.33 {Tcl_FileCmd: tail} { +test cmdAH-5.33 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ::: } :: -test cmdah-3.34 {Tcl_FileCmd: tail} { +test cmdAH-5.34 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail /foo/bar/ } bar -test cmdah-3.35 {Tcl_FileCmd: tail} { +test cmdAH-5.35 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail /foo/bar } bar -test cmdah-3.36 {Tcl_FileCmd: tail} { +test cmdAH-5.36 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail /foo } {} -test cmdah-3.37 {Tcl_FileCmd: tail} { +test cmdAH-5.37 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail foo } foo -test cmdah-3.38 {Tcl_FileCmd: tail} { +test cmdAH-5.38 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~:foo } foo -test cmdah-3.39 {Tcl_FileCmd: tail} { +test cmdAH-5.39 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~bar:foo } foo -test cmdah-3.40 {Tcl_FileCmd: tail} { +test cmdAH-5.40 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~bar/foo } foo -test cmdah-3.41 {Tcl_FileCmd: tail} { +test cmdAH-5.41 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~/foo } foo -test cmdah-3.42 {Tcl_FileCmd: tail} { +test cmdAH-5.42 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -405,7 +439,7 @@ test cmdah-3.42 {Tcl_FileCmd: tail} { set env(HOME) $temp set result } test -test cmdah-3.43 {Tcl_FileCmd: tail} { +test cmdAH-5.43 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "~" @@ -414,7 +448,7 @@ test cmdah-3.43 {Tcl_FileCmd: tail} { set env(HOME) $temp set result } {} -test cmdah-3.44 {Tcl_FileCmd: tail} { +test cmdAH-5.44 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -423,7 +457,7 @@ test cmdah-3.44 {Tcl_FileCmd: tail} { set env(HOME) $temp set result } test -test cmdah-3.45 {Tcl_FileCmd: tail} { +test cmdAH-5.45 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -432,166 +466,166 @@ test cmdah-3.45 {Tcl_FileCmd: tail} { set env(HOME) $temp set result } test -test cmdah-3.46 {Tcl_FileCmd: tail} { +test cmdAH-5.46 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {f.oo\bar/baz.bat} } baz.bat -test cmdah-3.47 {Tcl_FileCmd: tail} { +test cmdAH-5.47 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:foo } foo -test cmdah-3.48 {Tcl_FileCmd: tail} { +test cmdAH-5.48 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c: } {} -test cmdah-3.49 {Tcl_FileCmd: tail} { +test cmdAH-5.49 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:/foo } foo -test cmdah-3.50 {Tcl_FileCmd: tail} { +test cmdAH-5.50 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {c:/foo\bar} } bar -test cmdah-3.51 {Tcl_FileCmd: tail} { +test cmdAH-5.51 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {foo\bar} } bar # rootname -test cmdah-4.1 {Tcl_FileCmd: rootname} { +test cmdAH-6.1 {Tcl_FileObjCmd: rootname} { testsetplatform unix list [catch {file rootname a b} msg] $msg } {1 {wrong # args: should be "file rootname name"}} -test cmdah-4.2 {Tcl_FileCmd: rootname} { +test cmdAH-6.2 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname {} } {} -test cmdah-4.3 {Tcl_FileCmd: rootname} { +test cmdAH-6.3 {Tcl_FileObjCmd: rootname} { testsetplatform unix file ro foo } foo -test cmdah-4.4 {Tcl_FileCmd: rootname} { +test cmdAH-6.4 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname foo. } foo -test cmdah-4.5 {Tcl_FileCmd: rootname} { +test cmdAH-6.5 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname .foo } {} -test cmdah-4.6 {Tcl_FileCmd: rootname} { +test cmdAH-6.6 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname abc.def } abc -test cmdah-4.7 {Tcl_FileCmd: rootname} { +test cmdAH-6.7 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname abc.def.ghi } abc.def -test cmdah-4.8 {Tcl_FileCmd: rootname} { +test cmdAH-6.8 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname a/b/c.d } a/b/c -test cmdah-4.9 {Tcl_FileCmd: rootname} { +test cmdAH-6.9 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname a/b.c/d } a/b.c/d -test cmdah-4.10 {Tcl_FileCmd: rootname} { +test cmdAH-6.10 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname a/b.c/ } a/b.c/ -test cmdah-4.11 {Tcl_FileCmd: rootname} { +test cmdAH-6.11 {Tcl_FileObjCmd: rootname} { testsetplatform mac file ro foo } foo -test cmdah-4.12 {Tcl_FileCmd: rootname} { +test cmdAH-6.12 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname {} } {} -test cmdah-4.13 {Tcl_FileCmd: rootname} { +test cmdAH-6.13 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname foo. } foo -test cmdah-4.14 {Tcl_FileCmd: rootname} { +test cmdAH-6.14 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname .foo } {} -test cmdah-4.15 {Tcl_FileCmd: rootname} { +test cmdAH-6.15 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname abc.def } abc -test cmdah-4.16 {Tcl_FileCmd: rootname} { +test cmdAH-6.16 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname abc.def.ghi } abc.def -test cmdah-4.17 {Tcl_FileCmd: rootname} { +test cmdAH-6.17 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a:b:c.d } a:b:c -test cmdah-4.18 {Tcl_FileCmd: rootname} { +test cmdAH-6.18 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a:b.c:d } a:b.c:d -test cmdah-4.19 {Tcl_FileCmd: rootname} { +test cmdAH-6.19 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a/b/c.d } a/b/c -test cmdah-4.20 {Tcl_FileCmd: rootname} { +test cmdAH-6.20 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a/b.c/d } a/b.c/d -test cmdah-4.21 {Tcl_FileCmd: rootname} { +test cmdAH-6.21 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname /a.b } /a -test cmdah-4.22 {Tcl_FileCmd: rootname} { +test cmdAH-6.22 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname foo.c: } foo.c: -test cmdah-4.23 {Tcl_FileCmd: rootname} { +test cmdAH-6.23 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname {} } {} -test cmdah-4.24 {Tcl_FileCmd: rootname} { +test cmdAH-6.24 {Tcl_FileObjCmd: rootname} { testsetplatform windows file ro foo } foo -test cmdah-4.25 {Tcl_FileCmd: rootname} { +test cmdAH-6.25 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname foo. } foo -test cmdah-4.26 {Tcl_FileCmd: rootname} { +test cmdAH-6.26 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname .foo } {} -test cmdah-4.27 {Tcl_FileCmd: rootname} { +test cmdAH-6.27 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname abc.def } abc -test cmdah-4.28 {Tcl_FileCmd: rootname} { +test cmdAH-6.28 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname abc.def.ghi } abc.def -test cmdah-4.29 {Tcl_FileCmd: rootname} { +test cmdAH-6.29 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a/b/c.d } a/b/c -test cmdah-4.30 {Tcl_FileCmd: rootname} { +test cmdAH-6.30 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a/b.c/d } a/b.c/d -test cmdah-4.31 {Tcl_FileCmd: rootname} { +test cmdAH-6.31 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b.c\\ } a\\b.c\\ -test cmdah-4.32 {Tcl_FileCmd: rootname} { +test cmdAH-6.32 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b\\c.d } a\\b\\c -test cmdah-4.33 {Tcl_FileCmd: rootname} { +test cmdAH-6.33 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b.c\\d } a\\b.c\\d -test cmdah-4.34 {Tcl_FileCmd: rootname} { +test cmdAH-6.34 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b.c\\ } a\\b.c\\ @@ -599,7 +633,7 @@ set num 35 foreach outer { {} a .a a. a.a } { foreach inner { {} a .a a. a.a } { set thing [format %s/%s $outer $inner] - test cmdah-4.$num {Tcl_FileCmd: rootname and extension options} { +; test cmdAH-6.$num {Tcl_FileObjCmd: rootname and extension options} { testsetplatform unix format %s%s [file rootname $thing] [file ext $thing] } $thing @@ -609,199 +643,210 @@ foreach outer { {} a .a a. a.a } { # extension -test cmdah-5.1 {Tcl_FileCmd: extension} { +test cmdAH-7.1 {Tcl_FileObjCmd: extension} { testsetplatform unix list [catch {file extension a b} msg] $msg } {1 {wrong # args: should be "file extension name"}} -test cmdah-5.2 {Tcl_FileCmd: extension} { +test cmdAH-7.2 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension {} } {} -test cmdah-5.3 {Tcl_FileCmd: extension} { +test cmdAH-7.3 {Tcl_FileObjCmd: extension} { testsetplatform unix file ext foo } {} -test cmdah-5.4 {Tcl_FileCmd: extension} { +test cmdAH-7.4 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension foo. } . -test cmdah-5.5 {Tcl_FileCmd: extension} { +test cmdAH-7.5 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension .foo } .foo -test cmdah-5.6 {Tcl_FileCmd: extension} { +test cmdAH-7.6 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension abc.def } .def -test cmdah-5.7 {Tcl_FileCmd: extension} { +test cmdAH-7.7 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension abc.def.ghi } .ghi -test cmdah-5.8 {Tcl_FileCmd: extension} { +test cmdAH-7.8 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension a/b/c.d } .d -test cmdah-5.9 {Tcl_FileCmd: extension} { +test cmdAH-7.9 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension a/b.c/d } {} -test cmdah-5.10 {Tcl_FileCmd: extension} { +test cmdAH-7.10 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension a/b.c/ } {} -test cmdah-5.11 {Tcl_FileCmd: extension} { +test cmdAH-7.11 {Tcl_FileObjCmd: extension} { testsetplatform mac file ext foo } {} -test cmdah-5.12 {Tcl_FileCmd: extension} { +test cmdAH-7.12 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension {} } {} -test cmdah-5.13 {Tcl_FileCmd: extension} { +test cmdAH-7.13 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension foo. } . -test cmdah-5.14 {Tcl_FileCmd: extension} { +test cmdAH-7.14 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension .foo } .foo -test cmdah-5.15 {Tcl_FileCmd: extension} { +test cmdAH-7.15 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension abc.def } .def -test cmdah-5.16 {Tcl_FileCmd: extension} { +test cmdAH-7.16 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension abc.def.ghi } .ghi -test cmdah-5.17 {Tcl_FileCmd: extension} { +test cmdAH-7.17 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a:b:c.d } .d -test cmdah-5.18 {Tcl_FileCmd: extension} { +test cmdAH-7.18 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a:b.c:d } {} -test cmdah-5.19 {Tcl_FileCmd: extension} { +test cmdAH-7.19 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a/b/c.d } .d -test cmdah-5.20 {Tcl_FileCmd: extension} { +test cmdAH-7.20 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a/b.c/d } {} -test cmdah-5.21 {Tcl_FileCmd: extension} { +test cmdAH-7.21 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension /a.b } .b -test cmdah-5.22 {Tcl_FileCmd: extension} { +test cmdAH-7.22 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension foo.c: } {} -test cmdah-5.23 {Tcl_FileCmd: extension} { +test cmdAH-7.23 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension {} } {} -test cmdah-5.24 {Tcl_FileCmd: extension} { +test cmdAH-7.24 {Tcl_FileObjCmd: extension} { testsetplatform windows file ext foo } {} -test cmdah-5.25 {Tcl_FileCmd: extension} { +test cmdAH-7.25 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension foo. } . -test cmdah-5.26 {Tcl_FileCmd: extension} { +test cmdAH-7.26 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension .foo } .foo -test cmdah-5.27 {Tcl_FileCmd: extension} { +test cmdAH-7.27 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension abc.def } .def -test cmdah-5.28 {Tcl_FileCmd: extension} { +test cmdAH-7.28 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension abc.def.ghi } .ghi -test cmdah-5.29 {Tcl_FileCmd: extension} { +test cmdAH-7.29 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a/b/c.d } .d -test cmdah-5.30 {Tcl_FileCmd: extension} { +test cmdAH-7.30 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a/b.c/d } {} -test cmdah-5.31 {Tcl_FileCmd: extension} { +test cmdAH-7.31 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b.c\\ } {} -test cmdah-5.32 {Tcl_FileCmd: extension} { +test cmdAH-7.32 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b\\c.d } .d -test cmdah-5.33 {Tcl_FileCmd: extension} { +test cmdAH-7.33 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b.c\\d } {} -test cmdah-5.34 {Tcl_FileCmd: extension} { +test cmdAH-7.34 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b.c\\ } {} +set num 35 +foreach value {a..b a...b a.c..b ..b} result {..b ...b ..b ..b} { + foreach p {unix mac windows} { +; test cmdAH-7.$num {Tcl_FileObjCmd: extension} " + testsetplatform $p + file extension $value + " $result + incr num + } +} # pathtype -test cmdah-6.1 {Tcl_FileCmd: pathtype} { +test cmdAH-8.1 {Tcl_FileObjCmd: pathtype} { testsetplatform unix list [catch {file pathtype a b} msg] $msg } {1 {wrong # args: should be "file pathtype name"}} -test cmdah-6.2 {Tcl_FileCmd: pathtype} { +test cmdAH-8.2 {Tcl_FileObjCmd: pathtype} { testsetplatform unix file pathtype /a } absolute -test cmdah-6.3 {Tcl_FileCmd: pathtype} { +test cmdAH-8.3 {Tcl_FileObjCmd: pathtype} { testsetplatform unix file p a } relative -test cmdah-6.4 {Tcl_FileCmd: pathtype} { +test cmdAH-8.4 {Tcl_FileObjCmd: pathtype} { testsetplatform windows file pathtype c:a } volumerelative # split -test cmdah-7.1 {Tcl_FileCmd: split} { +test cmdAH-9.1 {Tcl_FileObjCmd: split} { testsetplatform unix list [catch {file split a b} msg] $msg } {1 {wrong # args: should be "file split name"}} -test cmdah-7.2 {Tcl_FileCmd: split} { +test cmdAH-9.2 {Tcl_FileObjCmd: split} { testsetplatform unix file split a } a -test cmdah-7.3 {Tcl_FileCmd: split} { +test cmdAH-9.3 {Tcl_FileObjCmd: split} { testsetplatform unix file split a/b } {a b} # join -test cmdah-8.1 {Tcl_FileCmd: join} { +test cmdAH-10.1 {Tcl_FileObjCmd: join} { testsetplatform unix file join a } a -test cmdah-8.2 {Tcl_FileCmd: join} { +test cmdAH-10.2 {Tcl_FileObjCmd: join} { testsetplatform unix file join a b } a/b -test cmdah-8.3 {Tcl_FileCmd: join} { +test cmdAH-10.3 {Tcl_FileObjCmd: join} { testsetplatform unix file join a b c d } a/b/c/d # error handling of Tcl_TranslateFileName -test cmdah-9.1 {Tcl_FileCmd} { +test cmdAH-11.1 {Tcl_FileObjCmd} { testsetplatform unix - list [catch {file readable ~_bad_user} msg] $msg + list [catch {file atime ~_bad_user} msg] $msg } {1 {user "_bad_user" doesn't exist}} +testsetplatform $platform makeFile abcde gorp.file makeDirectory dir.file @@ -809,14 +854,14 @@ makeDirectory dir.file # Can't run on macintosh - requires chmod if {$tcl_platform(platform) != "macintosh"} { -test cmdah-10.1 {Tcl_FileCmd: readable} { +test cmdAH-12.1 {Tcl_FileObjCmd: readable} { list [catch {file readable a b} msg] $msg } {1 {wrong # args: should be "file readable name"}} catch {exec chmod 444 gorp.file} -test cmdah-10.2 {Tcl_FileCmd: readable} {unixExecs} {file readable gorp.file} 1 +test cmdAH-12.2 {Tcl_FileObjCmd: readable} {unixExecs} {file readable gorp.file} 1 catch {exec chmod 333 gorp.file} if {$user != "root"} { - test cmdah-10.3 {Tcl_FileCmd: readable} {unixOnly} { + test cmdAH-12.3 {Tcl_FileObjCmd: readable} {unixOnly} { file reada gorp.file } 0 } @@ -826,48 +871,47 @@ if {$user != "root"} { # Can't run on macintosh - requires chmod if {$tcl_platform(platform) != "macintosh"} { -test cmdah-11.1 {Tcl_FileCmd: writable} { +test cmdAH-13.1 {Tcl_FileObjCmd: writable} { list [catch {file writable a b} msg] $msg } {1 {wrong # args: should be "file writable name"}} catch {exec chmod 555 gorp.file} if {$user != "root"} { - test cmdah-11.2 {Tcl_FileCmd: writable} {unixExecs} { + test cmdAH-13.2 {Tcl_FileObjCmd: writable} {unixExecs} { file writable gorp.file } 0 } catch {exec chmod 222 gorp.file} -test cmdah-11.3 {Tcl_FileCmd: writable} {unixExecs} {file w gorp.file} 1 +test cmdAH-13.3 {Tcl_FileObjCmd: writable} {unixExecs} {file w gorp.file} 1 } # executable # Can't run on macintosh - requires chmod if {$tcl_platform(platform) != "macintosh"} { -test cmdah-12.1 {Tcl_FileCmd: executable} {unixExecs} { +test cmdAH-14.1 {Tcl_FileObjCmd: executable} {unixExecs} { list [catch {file executable a b} msg] $msg } {1 {wrong # args: should be "file executable name"}} catch {exec chmod 000 dir.file} if {$user != "root"} { - test cmdah-12.2 {Tcl_FileCmd: executable} {unixOnly} { + test cmdAH-14.2 {Tcl_FileObjCmd: executable} {unixOnly} { file executable gorp.file } 0 } catch {exec chmod 775 gorp.file} -test cmdah-12.3 {Tcl_FileCmd: executable} {unixExecs} {file exe gorp.file} 1 +test cmdAH-14.3 {Tcl_FileObjCmd: executable} {unixExecs} {file exe gorp.file} 1 } # exists -test cmdah-13.1 {Tcl_FileCmd: exists} { +test cmdAH-15.1 {Tcl_FileObjCmd: exists} { list [catch {file exists a b} msg] $msg } {1 {wrong # args: should be "file exists name"}} catch {exec chmod 777 dir.file} -removeFile [file join dir.file gorp.file] -removeFile gorp.file -removeDirectory dir.file -removeFile link.file -test cmdah-13.2 {Tcl_FileCmd: exists} {file exists gorp.file} 0 -test cmdah-13.3 {Tcl_FileCmd: exists} { +file delete -force dir.file +file delete gorp.file +file delete link.file +test cmdAH-15.2 {Tcl_FileObjCmd: exists} {file exists gorp.file} 0 +test cmdAH-15.3 {Tcl_FileObjCmd: exists} { file exists [file join dir.file gorp.file] } 0 catch { @@ -875,94 +919,109 @@ catch { makeDirectory dir.file makeFile 12345 [file join dir.file gorp.file] } -test cmdah-13.4 {Tcl_FileCmd: exists} {unixExecs} {file exists gorp.file} 1 -test cmdah-13.5 {Tcl_FileCmd: exists} {unixExecs} { - file exi [file join dir.file gorp.file] +test cmdAH-15.4 {Tcl_FileObjCmd: exists} {unixExecs} {file exists gorp.file} 1 +test cmdAH-15.5 {Tcl_FileObjCmd: exists} {unixExecs} { + file exists [file join dir.file gorp.file] } 1 +# nativename +test cmdAH-15.6 {Tcl_FileObjCmd: nativename} { + testsetplatform unix + list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] +} {0 a/b {}} +test cmdAH-15.7 {Tcl_FileObjCmd: nativename} { + testsetplatform windows + list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] +} {0 {a\b} {}} +test cmdAH-15.8 {Tcl_FileObjCmd: nativename} { + testsetplatform mac + list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] +} {0 :a:b {}} + # The test below has to be done in /tmp rather than the current # directory in order to guarantee (?) a local file system: some # NFS file systems won't do the stuff below correctly. if {$tcl_platform(platform) == "unix"} { - removeFile /tmp/tcl.foo.dir/file + file delete /tmp/tcl.foo.dir/file removeDirectory /tmp/tcl.foo.dir makeDirectory /tmp/tcl.foo.dir makeFile 12345 /tmp/tcl.foo.dir/file exec chmod 000 /tmp/tcl.foo.dir if {$user != "root"} { - test cmdah-13.3 {Tcl_FileCmd: exists} { + test cmdAH-15.9 {Tcl_FileObjCmd: exists} { file exists /tmp/tcl.foo.dir/file } 0 } exec chmod 775 /tmp/tcl.foo.dir - removeFile /tmp/tcl.foo.dir/file + file delete /tmp/tcl.foo.dir/file removeDirectory /tmp/tcl.foo.dir } # Stat related commands -removeFile gorp.file +testsetplatform $platform +file delete gorp.file makeFile "Test string" gorp.file catch {exec chmod 765 gorp.file} # atime -test cmdah-14.1 {Tcl_FileCmd: atime} { +test cmdAH-16.1 {Tcl_FileObjCmd: atime} { list [catch {file atime a b} msg] $msg } {1 {wrong # args: should be "file atime name"}} -test cmdah-14.2 {Tcl_FileCmd: atime} { +test cmdAH-16.2 {Tcl_FileObjCmd: atime} { catch {unset stat} file stat gorp.file stat list [expr {[file mtime gorp.file] == $stat(mtime)}] \ [expr {[file atime gorp.file] == $stat(atime)}] } {1 1} -test cmdah-12.1 {Tcl_FileCmd: atime} { +test cmdAH-16.3 {Tcl_FileObjCmd: atime} { string tolower [list [catch {file atime _bogus_} msg] \ $msg $errorCode] } {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} # isdirectory -test cmdah-15.1 {Tcl_FileCmd: isdirectory} { +test cmdAH-17.1 {Tcl_FileObjCmd: isdirectory} { list [catch {file isdirectory a b} msg] $msg } {1 {wrong # args: should be "file isdirectory name"}} -test cmdah-15.2 {Tcl_FileCmd: isdirectory} {file isdirectory gorp.file} 0 -test cmdah-15.3 {Tcl_FileCmd: isdirectory} {unixExecs} {file isd dir.file} 1 +test cmdAH-17.2 {Tcl_FileObjCmd: isdirectory} {file isdirectory gorp.file} 0 +test cmdAH-17.3 {Tcl_FileObjCmd: isdirectory} {unixExecs} {file isd dir.file} 1 # isfile -test cmdah-15.4 {Tcl_FileCmd: isfile} { +test cmdAH-18.1 {Tcl_FileObjCmd: isfile} { list [catch {file isfile a b} msg] $msg } {1 {wrong # args: should be "file isfile name"}} -test cmdah-15.5 {Tcl_FileCmd: isfile} {file isfile gorp.file} 1 -test cmdah-15.6 {Tcl_FileCmd: isfile} {file isfile dir.file} 0 +test cmdAH-18.2 {Tcl_FileObjCmd: isfile} {file isfile gorp.file} 1 +test cmdAH-18.3 {Tcl_FileObjCmd: isfile} {file isfile dir.file} 0 # lstat and readlink: don't run these tests everywhere, since not all # sites will have symbolic links catch {exec ln -s gorp.file link.file} -test cmdah-16.1 {Tcl_FileCmd: lstat} {unixExecs} { +test cmdAH-19.1 {Tcl_FileObjCmd: lstat} {unixExecs} { list [catch {file lstat a} msg] $msg } {1 {wrong # args: should be "file lstat name varName"}} -test cmdah-16.2 {Tcl_FileCmd: lstat} {unixExecs} { +test cmdAH-19.2 {Tcl_FileObjCmd: lstat} {unixExecs} { list [catch {file lstat a b c} msg] $msg } {1 {wrong # args: should be "file lstat name varName"}} -test cmdah-16.3 {Tcl_FileCmd: lstat} {unixOnly nonPortable} { +test cmdAH-19.3 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} { catch {unset stat} file lstat link.file stat lsort [array names stat] } {atime ctime dev gid ino mode mtime nlink size type uid} -test cmdah-16.4 {Tcl_FileCmd: lstat} {unixOnly nonPortable} { +test cmdAH-19.4 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} { catch {unset stat} file lstat link.file stat list $stat(nlink) [expr $stat(mode)&0777] $stat(type) } {1 511 link} -test cmdah-16.5 {Tcl_FileCmd: lstat errors} {nonPortable} { +test cmdAH-19.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} { string tolower [list [catch {file lstat _bogus_ stat} msg] \ $msg $errorCode] } {1 {couldn't lstat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} -test cmdah-16.6 {Tcl_FileCmd: lstat errors} {unixExecs nonPortable} { +test cmdAH-19.6 {Tcl_FileObjCmd: lstat errors} {unixExecs nonPortable} { catch {unset x} set x 44 list [catch {file lstat gorp.file x} msg] $msg $errorCode @@ -971,10 +1030,10 @@ catch {unset stat} # mtime -test cmdah-17.1 {Tcl_FileCmd: mtime} { +test cmdAH-20.1 {Tcl_FileObjCmd: mtime} { list [catch {file mtime a b} msg] $msg } {1 {wrong # args: should be "file mtime name"}} -test cmdah-17.2 {Tcl_FileCmd: mtime} {unixExecs} { +test cmdAH-20.2 {Tcl_FileObjCmd: mtime} {unixExecs} { set old [file mtime gorp.file] after 2000 set f [open gorp.file w] @@ -983,54 +1042,75 @@ test cmdah-17.2 {Tcl_FileCmd: mtime} {unixExecs} { set new [file mtime gorp.file] expr {($new > $old) && ($new <= ($old+5))} } {1} -test cmdah-17.3 {Tcl_FileCmd: mtime} {unixExecs} { +test cmdAH-20.3 {Tcl_FileObjCmd: mtime} {unixExecs} { catch {unset stat} file stat gorp.file stat list [expr {[file mtime gorp.file] == $stat(mtime)}] \ [expr {[file atime gorp.file] == $stat(atime)}] } {1 1} -test cmdah-17.4 {Tcl_FileCmd: mtime} {unixExecs} { +test cmdAH-20.4 {Tcl_FileObjCmd: mtime} {unixExecs} { string tolower [list [catch {file mtime _bogus_} msg] $msg \ $errorCode] } {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdAH-20.5 {Tcl_FileObjCmd: mtime} { + # Under Unix, use a file in /tmp to avoid clock skew due to NFS. + # On other platforms, just use a file in the local directory. + + if {$tcl_platform(platform) == "unix"} { + set name /tmp/tcl.test + } else { + set name tf + } + + # Borland file times were off by timezone. Make sure that a new file's + # time is correct. 10 seconds variance is allowed used due to slow + # networks or clock skew on a network drive. + + file delete -force $name + close [open $name w] + set a [expr abs([clock seconds]-[file mtime $name])<10] + file delete $name + set a +} {1} + # owned -test cmdah-18.1 {Tcl_FileCmd: owned} { +test cmdAH-21.1 {Tcl_FileObjCmd: owned} { list [catch {file owned a b} msg] $msg } {1 {wrong # args: should be "file owned name"}} -test cmdah-18.2 {Tcl_FileCmd: owned} {unixExecs} {file owned gorp.file} 1 +test cmdAH-21.2 {Tcl_FileObjCmd: owned} {unixExecs} {file owned gorp.file} 1 if {$user != "root"} { - test cmdah-18.3 {Tcl_FileCmd: owned} {unixOnly} {file owned /} 0 + test cmdAH-21.3 {Tcl_FileObjCmd: owned} {unixOnly} {file owned /} 0 } # readlink -test cmdah-19.1 {Tcl_FileCmd: readlink} { +test cmdAH-22.1 {Tcl_FileObjCmd: readlink} { list [catch {file readlink a b} msg] $msg } {1 {wrong # args: should be "file readlink name"}} -test cmdah-19.2 {Tcl_FileCmd: readlink} {unixOnly nonPortable} { +test cmdAH-22.2 {Tcl_FileObjCmd: readlink} {unixOnly nonPortable} { file readlink link.file } gorp.file -test cmdah-19.3 {Tcl_FileCmd: readlink errors} {unixOnly nonPortable} { +test cmdAH-22.3 {Tcl_FileObjCmd: readlink errors} {unixOnly nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] } {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} -test cmdah-19.4 {Tcl_FileCmd: readlink errors} {macOnly nonPortable} { +test cmdAH-22.4 {Tcl_FileObjCmd: readlink errors} {macOnly nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] } {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} -test cmdah-19.5 {Tcl_FileCmd: readlink errors} {pcOnly nonPortable} { +test cmdAH-22.5 {Tcl_FileObjCmd: readlink errors} {pcOnly nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] } {1 {couldn't readlink "_bogus_": invalid argument} {posix einval {invalid argument}}} # size -test cmdah-20.1 {Tcl_FileCmd: size} { +test cmdAH-23.1 {Tcl_FileObjCmd: size} { list [catch {file size a b} msg] $msg } {1 {wrong # args: should be "file size name"}} -test cmdah-20.2 {Tcl_FileCmd: size} { +test cmdAH-23.2 {Tcl_FileObjCmd: size} { set oldsize [file size gorp.file] set f [open gorp.file a] fconfigure $f -translation lf -eofchar {} @@ -1038,37 +1118,38 @@ test cmdah-20.2 {Tcl_FileCmd: size} { close $f expr {[file size gorp.file] - $oldsize} } {10} -test cmdah-20.3 {Tcl_FileCmd: size} { +test cmdAH-23.3 {Tcl_FileObjCmd: size} { string tolower [list [catch {file size _bogus_} msg] $msg \ $errorCode] } {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} # stat +testsetplatform $platform makeFile "Test string" gorp.file catch {exec chmod 765 gorp.file} -test cmdah-21.1 {Tcl_FileCmd: stat} { +test cmdAH-24.1 {Tcl_FileObjCmd: stat} { list [catch {file stat _bogus_} msg] $msg $errorCode } {1 {wrong # args: should be "file stat name varName"} NONE} -test cmdah-21.2 {Tcl_FileCmd: stat} { +test cmdAH-24.2 {Tcl_FileObjCmd: stat} { list [catch {file stat _bogus_ a b} msg] $msg $errorCode } {1 {wrong # args: should be "file stat name varName"} NONE} -test cmdah-21.3 {Tcl_FileCmd: stat} { +test cmdAH-24.3 {Tcl_FileObjCmd: stat} { catch {unset stat} file stat gorp.file stat lsort [array names stat] } {atime ctime dev gid ino mode mtime nlink size type uid} -test cmdah-21.4 {Tcl_FileCmd: stat} {unixOnly} { +test cmdAH-24.4 {Tcl_FileObjCmd: stat} {unixOnly} { catch {unset stat} file stat gorp.file stat list $stat(nlink) $stat(size) [expr $stat(mode)&0777] $stat(type) } {1 12 501 file} -test cmdah-21.5 {Tcl_FileCmd: stat} { +test cmdAH-24.5 {Tcl_FileObjCmd: stat} { string tolower [list [catch {file stat _bogus_ stat} msg] \ $msg $errorCode] } {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} -test cmdah-21.6 {Tcl_FileCmd: stat} { +test cmdAH-24.6 {Tcl_FileObjCmd: stat} { catch {unset x} set x 44 list [catch {file stat gorp.file x} msg] $msg $errorCode @@ -1077,60 +1158,60 @@ catch {unset stat} # type -removeFile link.file +file delete link.file -test cmdah-22.1 {Tcl_FileCmd: type} { +test cmdAH-25.1 {Tcl_FileObjCmd: type} { list [catch {file size a b} msg] $msg } {1 {wrong # args: should be "file size name"}} -test cmdah-22.2 {Tcl_FileCmd: type} {unixExecs} { +test cmdAH-25.2 {Tcl_FileObjCmd: type} {unixExecs} { file type dir.file } directory -test cmdah-22.3 {Tcl_FileCmd: type} { +test cmdAH-25.3 {Tcl_FileObjCmd: type} { file type gorp.file } file -test cmdah-22.4 {Tcl_FileCmd: type} {unixOnly nonPortable} { +test cmdAH-25.4 {Tcl_FileObjCmd: type} {unixOnly nonPortable} { exec ln -s a/b/c link.file set result [file type link.file] - removeFile link.file + file delete link.file set result } link -test cmdah-22.5 {Tcl_FileCmd: type} { +test cmdAH-25.5 {Tcl_FileObjCmd: type} { string tolower [list [catch {file type _bogus_} msg] $msg $errorCode] } {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} # Error conditions -test cmdah-23.1 {error conditions} { +test cmdAH-26.1 {error conditions} { list [catch {file gorp x} msg] $msg -} {1 {bad option "gorp": should be atime, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, owned, pathtype, readable, readlink, root, size, split, stat, tail, type, or writable}} -test cmdah-23.2 {error conditions} { +} {1 {bad option "gorp": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +test cmdAH-26.2 {error conditions} { list [catch {file ex x} msg] $msg -} {1 {bad option "ex": should be atime, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, owned, pathtype, readable, readlink, root, size, split, stat, tail, type, or writable}} -test cmdah-23.3 {error conditions} { +} {1 {ambiguous option "ex": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +test cmdAH-26.3 {error conditions} { list [catch {file is x} msg] $msg -} {1 {bad option "is": should be atime, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, owned, pathtype, readable, readlink, root, size, split, stat, tail, type, or writable}} -test cmdah-23.4 {error conditions} { - list [catch {file n x} msg] $msg -} {1 {bad option "n": should be atime, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, owned, pathtype, readable, readlink, root, size, split, stat, tail, type, or writable}} -test cmdah-23.5 {error conditions} { +} {1 {ambiguous option "is": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +test cmdAH-26.4 {error conditions} { + list [catch {file z x} msg] $msg +} {1 {bad option "z": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +test cmdAH-26.5 {error conditions} { list [catch {file read x} msg] $msg -} {1 {bad option "read": should be atime, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, owned, pathtype, readable, readlink, root, size, split, stat, tail, type, or writable}} -test cmdah-23.6 {error conditions} { +} {1 {ambiguous option "read": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +test cmdAH-26.6 {error conditions} { list [catch {file s x} msg] $msg -} {1 {bad option "s": should be atime, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, owned, pathtype, readable, readlink, root, size, split, stat, tail, type, or writable}} -test cmdah-23.7 {error conditions} { +} {1 {ambiguous option "s": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +test cmdAH-26.7 {error conditions} { list [catch {file t x} msg] $msg -} {1 {bad option "t": should be atime, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, owned, pathtype, readable, readlink, root, size, split, stat, tail, type, or writable}} -test cmdah-23.8 {error conditions} { +} {1 {ambiguous option "t": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +test cmdAH-26.8 {error conditions} { list [catch {file dirname ~woohgy} msg] $msg } {1 {user "woohgy" doesn't exist}} -catch {exec chmod 777 dir.file} -removeFile dir.file/gorp.file -removeFile gorp.file -removeDirectory dir.file -removeFile link.file - testsetplatform $platform catch {unset platform} + +catch {exec chmod 777 dir.file} +file delete -force dir.file +file delete gorp.file +file delete link.file + concat "" diff --git a/contrib/tcl/tests/cmdIL.test b/contrib/tcl/tests/cmdIL.test new file mode 100644 index 0000000000000..55210a1b9e455 --- /dev/null +++ b/contrib/tcl/tests/cmdIL.test @@ -0,0 +1,250 @@ +# This file contains a collection of tests for the procedures in the +# file tclCmdIL.c. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) cmdIL.test 1.15 97/05/22 16:38:11 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test cmdIL-1.1 {Tcl_LsortObjCmd procedure} { + list [catch {lsort} msg] $msg +} {1 {wrong # args: should be "lsort ?options? list"}} +test cmdIL-1.2 {Tcl_LsortObjCmd procedure} { + list [catch {lsort -foo {1 3 2 5}} msg] $msg +} {1 {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -integer, or -real}} +test cmdIL-1.3 {Tcl_LsortObjCmd procedure, default options} { + lsort {d e c b a \{ d35 d300} +} {a b c d d300 d35 e \{} +test cmdIL-1.4 {Tcl_LsortObjCmd procedure, -ascii option} { + lsort -integer -ascii {d e c b a d35 d300} +} {a b c d d300 d35 e} +test cmdIL-1.5 {Tcl_LsortObjCmd procedure, -command option} { + list [catch {lsort -command {1 3 2 5}} msg] $msg +} {1 {"-command" option must be followed by comparison command}} +test cmdIL-1.6 {Tcl_LsortObjCmd procedure, -command option} { + proc cmp {a b} { + expr {[string match x* $b] - [string match x* $a]} + } + lsort -command cmp {x1 abc x2 def x3 x4} +} {x1 x2 x3 x4 abc def} +test cmdIL-1.7 {Tcl_LsortObjCmd procedure, -decreasing option} { + lsort -decreasing {d e c b a d35 d300} +} {e d35 d300 d c b a} +test cmdIL-1.8 {Tcl_LsortObjCmd procedure, -dictionary option} { + lsort -dictionary {d e c b a d35 d300} +} {a b c d d35 d300 e} +test cmdIL-1.9 {Tcl_LsortObjCmd procedure, -increasing option} { + lsort -decreasing -increasing {d e c b a d35 d300} +} {a b c d d300 d35 e} +test cmdIL-1.10 {Tcl_LsortObjCmd procedure, -index option} { + list [catch {lsort -index {1 3 2 5}} msg] $msg +} {1 {"-index" option must be followed by list index}} +test cmdIL-1.11 {Tcl_LsortObjCmd procedure, -index option} { + list [catch {lsort -index foo {1 3 2 5}} msg] $msg +} {1 {expected integer but got "foo"}} +test cmdIL-1.12 {Tcl_LsortObjCmd procedure, -index option} { + lsort -index end -integer {{2 25} {10 20 50 100} {3 16 42} 1} +} {1 {2 25} {3 16 42} {10 20 50 100}} +test cmdIL-1.13 {Tcl_LsortObjCmd procedure, -index option} { + lsort -index 1 -integer {{1 25 100} {3 16 42} {10 20 50}} +} {{3 16 42} {10 20 50} {1 25 100}} +test cmdIL-1.14 {Tcl_LsortObjCmd procedure, -integer option} { + lsort -integer {24 6 300 18} +} {6 18 24 300} +test cmdIL-1.15 {Tcl_LsortObjCmd procedure, -integer option} { + list [catch {lsort -integer {1 3 2.4}} msg] $msg +} {1 {expected integer but got "2.4"}} +test cmdIL-1.16 {Tcl_LsortObjCmd procedure, -real option} { + lsort -real {24.2 6e3 150e-1} +} {150e-1 24.2 6e3} +test cmdIL-1.17 {Tcl_LsortObjCmd procedure, bogus list} { + list [catch {lsort "1 2 3 \{ 4"} msg] $msg +} {1 {unmatched open brace in list}} +test cmdIL-1.18 {Tcl_LsortObjCmd procedure, empty list} { + lsort {} +} {} + +# Can't think of any good tests for the MergeSort and MergeLists +# procedures, except a bunch of random lists to sort. + +test cmdIL-2.1 {MergeSort and MergeLists procedures} { + set result {} + set r 1435753299 + proc rand {} { + global r + set r [expr (16807 * $r) % (0x7fffffff)] + } + for {set i 0} {$i < 150} {incr i} { + set x {} + for {set j 0} {$j < $i} {incr j} { + lappend x [expr [rand] & 0xfff] + } + set y [lsort -integer $x] + set old -1 + foreach el $y { + if {$el < $old} { + append result "list {$x} sorted to {$y}, element $el out of order\n" + break + } + set old $el + } + } + set result +} {} + +test cmdIL-3.1 {SortCompare procedure, skip comparisons after error} { + set x 0 + proc cmp {a b} { + global x + incr x + error "error #$x" + } + list [catch {lsort -integer -command cmp {48 6 28 190 16 2 3 6 1}} msg] \ + $msg $x +} {1 {error #1} 1} +test cmdIL-3.2 {SortCompare procedure, -index option} { + list [catch {lsort -integer -index 2 "\\\{ {30 40 50}"} msg] $msg +} {1 {unmatched open brace in list}} +test cmdIL-3.3 {SortCompare procedure, -index option} { + list [catch {lsort -integer -index 2 {{20 10} {15 30 40}}} msg] $msg +} {1 {element 2 missing from sublist "20 10"}} +test cmdIL-3.4 {SortCompare procedure, -index option} { + list [catch {lsort -integer -index 2 "{a b c} \\\{"} msg] $msg +} {1 {unmatched open brace in list}} +test cmdIL-3.5 {SortCompare procedure, -index option} { + list [catch {lsort -integer -index 2 {{20 10 13} {15}}} msg] $msg +} {1 {element 2 missing from sublist "15"}} +test cmdIL-3.6 {SortCompare procedure, -index option} { + lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}} +} {{3 25 20} {2 5 25} {1 15 30}} +test cmdIL-3.7 {SortCompare procedure, -ascii option} { + lsort -ascii {d e c b a d35 d300 100 20} +} {100 20 a b c d d300 d35 e} +test cmdIL-3.8 {SortCompare procedure, -dictionary option} { + lsort -dictionary {d e c b a d35 d300 100 20} +} {20 100 a b c d d35 d300 e} +test cmdIL-3.9 {SortCompare procedure, -integer option} { + list [catch {lsort -integer {x 3}} msg] $msg +} {1 {expected integer but got "x"}} +test cmdIL-3.10 {SortCompare procedure, -integer option} { + list [catch {lsort -integer {3 q}} msg] $msg +} {1 {expected integer but got "q"}} +test cmdIL-3.11 {SortCompare procedure, -integer option} { + lsort -integer {35 21 0x20 30 023 100 8} +} {8 023 21 30 0x20 35 100} +test cmdIL-3.12 {SortCompare procedure, -real option} { + list [catch {lsort -real {6...4 3}} msg] $msg +} {1 {expected floating-point number but got "6...4"}} +test cmdIL-3.13 {SortCompare procedure, -real option} { + list [catch {lsort -real {3 1x7}} msg] $msg +} {1 {expected floating-point number but got "1x7"}} +test cmdIL-3.14 {SortCompare procedure, -real option} { + lsort -real {24 2.5e01 16.7 85e-1 10.004} +} {85e-1 10.004 16.7 24 2.5e01} +test cmdIL-3.15 {SortCompare procedure, -command option} { + proc cmp {a b} { + error "comparison error" + } + list [catch {lsort -command cmp {48 6}} msg] $msg $errorInfo +} {1 {comparison error} {comparison error + while executing +"error "comparison error"" + (procedure "cmp" line 1) + invoked from within +"cmp 48 6" + (-compare command) + invoked from within +"lsort -command cmp {48 6}"}} +test cmdIL-3.16 {SortCompare procedure, -command option, long command} { + proc cmp {dummy a b} { + string compare $a $b + } + lsort -command {cmp {this argument is very very long in order to make the dstring overflow its statically allocated space}} {{this first element is also long in order to help expand the dstring} {the second element, last but not least, is quite long also, in order to make absolutely sure that space is allocated dynamically for the dstring}} +} {{the second element, last but not least, is quite long also, in order to make absolutely sure that space is allocated dynamically for the dstring} {this first element is also long in order to help expand the dstring}} +test cmdIL-3.17 {SortCompare procedure, -command option, non-integer result} { + proc cmp {a b} { + return foow + } + list [catch {lsort -command cmp {48 6}} msg] $msg +} {1 {-compare command returned non-numeric result}} +test cmdIL-3.18 {SortCompare procedure, -command option} { + proc cmp {a b} { + expr $b - $a + } + lsort -command cmp {48 6 18 22 21 35 36} +} {48 36 35 22 21 18 6} +test cmdIL-3.19 {SortCompare procedure, -decreasing option} { + lsort -decreasing -integer {35 21 0x20 30 023 100 8} +} {100 35 0x20 30 21 023 8} + +test cmdIL-4.1 {DictionaryCompare procedure, numerics, leading zeros} { + lsort -dictionary {a003b a03b} +} {a03b a003b} +test cmdIL-4.2 {DictionaryCompare procedure, numerics, leading zeros} { + lsort -dictionary {a3b a03b} +} {a3b a03b} +test cmdIL-4.3 {DictionaryCompare procedure, numerics, leading zeros} { + lsort -dictionary {a3b A03b} +} {A03b a3b} +test cmdIL-4.4 {DictionaryCompare procedure, numerics, leading zeros} { + lsort -dictionary {a3b a03B} +} {a3b a03B} +test cmdIL-4.5 {DictionaryCompare procedure, numerics, different lengths} { + lsort -dictionary {a321b a03210b} +} {a321b a03210b} +test cmdIL-4.6 {DictionaryCompare procedure, numerics, different lengths} { + lsort -dictionary {a03210b a321b} +} {a321b a03210b} +test cmdIL-4.7 {DictionaryCompare procedure, numerics} { + lsort -dictionary {48 6a 18b 22a 21aa 35 36} +} {6a 18b 21aa 22a 35 36 48} +test cmdIL-4.8 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a123x a123b} +} {a123b a123x} +test cmdIL-4.9 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a123b a123x} +} {a123b a123x} +test cmdIL-4.10 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a1b aab} +} {a1b aab} +test cmdIL-4.11 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a1b a!b} +} {a!b a1b} +test cmdIL-4.12 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a1b2c a1b1c} +} {a1b1c a1b2c} +test cmdIL-4.13 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a1b2c a1b3c} +} {a1b2c a1b3c} +test cmdIL-4.14 {DictionaryCompare procedure, long numbers} { + lsort -dictionary {a7654884321988762b a7654884321988761b} +} {a7654884321988761b a7654884321988762b} +test cmdIL-4.15 {DictionaryCompare procedure, long numbers} { + lsort -dictionary {a8765488432198876b a7654884321988761b} +} {a7654884321988761b a8765488432198876b} +test cmdIL-4.16 {DictionaryCompare procedure, case} { + lsort -dictionary {aBCd abcc} +} {abcc aBCd} +test cmdIL-4.17 {DictionaryCompare procedure, case} { + lsort -dictionary {aBCd abce} +} {aBCd abce} +test cmdIL-4.18 {DictionaryCompare procedure, case} { + lsort -dictionary {abcd ABcc} +} {ABcc abcd} +test cmdIL-4.19 {DictionaryCompare procedure, case} { + lsort -dictionary {abcd ABce} +} {abcd ABce} +test cmdIL-4.20 {DictionaryCompare procedure, case} { + lsort -dictionary {abCD ABcd} +} {ABcd abCD} +test cmdIL-4.21 {DictionaryCompare procedure, case} { + lsort -dictionary {ABcd aBCd} +} {ABcd aBCd} +test cmdIL-4.22 {DictionaryCompare procedure, case} { + lsort -dictionary {ABcd AbCd} +} {ABcd AbCd} diff --git a/contrib/tcl/tests/cmdInfo.test b/contrib/tcl/tests/cmdInfo.test index 303492902cc23..14267acf6dd90 100644 --- a/contrib/tcl/tests/cmdInfo.test +++ b/contrib/tcl/tests/cmdInfo.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) cmdinfo.test 1.5 96/04/05 15:28:12 +# SCCS: @(#) cmdInfo.test 1.10 97/06/20 14:51:12 if {[info commands testcmdinfo] == {}} { puts "This application hasn't been compiled with the \"testcmdinfo\"" @@ -25,7 +25,7 @@ if {[string compare test [info procs test]] == 1} then {source defs} test cmdinfo-1.1 {command procedure and clientData} { testcmdinfo create x1 testcmdinfo get x1 -} {CmdProc1 original CmdDelProc1 original} +} {CmdProc1 original CmdDelProc1 original :: stringProc} test cmdinfo-1.2 {command procedure and clientData} { testcmdinfo create x1 x1 @@ -34,7 +34,7 @@ test cmdinfo-1.3 {command procedure and clientData} { testcmdinfo create x1 testcmdinfo modify x1 testcmdinfo get x1 -} {CmdProc2 new_command_data CmdDelProc2 new_delete_data} +} {CmdProc2 new_command_data CmdDelProc2 new_delete_data :: stringProc} test cmdinfo-1.4 {command procedure and clientData} { testcmdinfo create x1 testcmdinfo modify x1 @@ -62,13 +62,37 @@ test cmdinfo-3.3 {Tcl_Get/SetCommandInfo return values} { testcmdinfo modify non_existent } 0 -test cmdinfo-4.1 {Tcl_GetCommandName procedure} { +test cmdinfo-4.1 {Tcl_GetCommandName/Tcl_GetCommandFullName procedures} { set x [testcmdtoken create x1] rename x1 newName set y [testcmdtoken name $x] rename newName x1 - lappend y [testcmdtoken name $x] -} {newName x1} + eval lappend y [testcmdtoken name $x] +} {newName ::newName x1 ::x1} +catch {rename newTestCmd {}} +catch {rename newTestCmd2 {}} + +test cmdinfo-5.1 {Names for commands created when inside namespaces} { + # create namespace cmdInfoNs1 + namespace eval cmdInfoNs1 {} ;# creates namespace cmdInfoNs1 + # create namespace cmdInfoNs1::cmdInfoNs2 and execute a script in it + set x [namespace eval cmdInfoNs1::cmdInfoNs2 { + # the following creates a cmd in the global namespace + testcmdtoken create testCmd + }] + set y [testcmdtoken name $x] + rename ::testCmd newTestCmd + eval lappend y [testcmdtoken name $x] +} {testCmd ::testCmd newTestCmd ::newTestCmd} + +test cmdinfo-6.1 {Names for commands created when outside namespaces} { + set x [testcmdtoken create cmdInfoNs1::cmdInfoNs2::testCmd] + set y [testcmdtoken name $x] + rename cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 + eval lappend y [testcmdtoken name $x] +} {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2} + +catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1} catch {rename x1 ""} concat {} diff --git a/contrib/tcl/tests/compile.test b/contrib/tcl/tests/compile.test new file mode 100644 index 0000000000000..6d8e0328f9253 --- /dev/null +++ b/contrib/tcl/tests/compile.test @@ -0,0 +1,108 @@ +# This file contains tests for the file tclCompile.c. +# +# 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) 1997 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) compile.test 1.5 97/06/25 11:43:49 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# The following tests are very incomplete, although the rest of the +# test suite covers this file fairly well. + +catch {rename p ""} +catch {namespace delete test_ns_compile} +catch {unset x} +catch {unset y} +catch {unset a} + +test compile-1.1 {TclCompileDollarVar: global scalar name with ::s} { + catch {unset x} + set x 123 + list $::x [expr {[lsearch -exact [info globals] x] != 0}] +} {123 1} +test compile-1.2 {TclCompileDollarVar: global scalar name with ::s} { + catch {unset y} + proc p {} { + set ::y 789 + return $::y + } + list [p] $::y [expr {[lsearch -exact [info globals] y] != 0}] +} {789 789 1} +test compile-1.3 {TclCompileDollarVar: global array name with ::s} { + catch {unset a} + set ::a(1) 2 + list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {[lsearch -exact [info globals] a] != 0}] +} {2 3 3 1} +test compile-1.4 {TclCompileDollarVar: global scalar name with ::s} { + catch {unset a} + proc p {} { + set ::a(1) 1 + return $::a($::a(1)) + } + list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] +} {1 1 1} + +test compile-2.1 {TclCompileSetCmd: global scalar names with ::s} { + catch {unset x} + catch {unset y} + set x 123 + proc p {} { + set ::y 789 + return $::y + } + list $::x [expr {[lsearch -exact [info globals] x] != 0}] \ + [p] $::y [expr {[lsearch -exact [info globals] y] != 0}] +} {123 1 789 789 1} +test compile-2.2 {TclCompileSetCmd: global array names with ::s} { + catch {unset a} + set ::a(1) 2 + proc p {} { + set ::a(1) 1 + return $::a($::a(1)) + } + list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] +} {2 1 3 3 1} +test compile-2.3 {TclCompileSetCmd: namespace var names with ::s} { + catch {namespace delete test_ns_compile} + catch {unset x} + namespace eval test_ns_compile { + variable v hello + variable arr + set ::x $::test_ns_compile::v + set ::test_ns_compile::arr(1) 123 + } + list $::x $::test_ns_compile::arr(1) +} {hello 123} + +test compile-3.1 {CollectArgInfo: binary data} { + list [catch "string length \000foo" msg] $msg +} {0 4} +test compile-3.2 {CollectArgInfo: binary data} { + list [catch "string length foo\000" msg] $msg +} {0 4} +test compile-3.3 {CollectArgInfo: handle "]" at end of command properly} { + set x ] +} {]} + +test compile-4.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} { + proc p {} { + set x {} + eval $x + append x { } + eval $x + } + p +} {} + +catch {rename p ""} +catch {namespace delete test_ns_compile} +catch {unset x} +catch {unset y} +catch {unset a} diff --git a/contrib/tcl/tests/concat.test b/contrib/tcl/tests/concat.test index b86aeed4000f0..d0222e945f9b6 100644 --- a/contrib/tcl/tests/concat.test +++ b/contrib/tcl/tests/concat.test @@ -5,12 +5,12 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) concat.test 1.8 96/02/16 08:55:43 +# SCCS: @(#) concat.test 1.10 96/12/20 18:53:31 if {[string compare test [info procs test]] == 1} then {source defs} @@ -27,13 +27,20 @@ test concat-1.4 {special characters} { concat a\{ {b \{c d} \{d } "a{ b \\{c d {d" -test concat-2.1 {error: no arguments} { +test concat-2.1 {error: one empty argument} { + concat {} +} {} + +test concat-3.1 {error: no arguments} { list [catch concat msg] $msg } {0 {}} -test concat-3.1 {pruning off extra white space} { +test concat-4.1 {pruning off extra white space} { concat {} {a b c} } {a b c} -test concat-3.2 {pruning off extra white space} { +test concat-4.2 {pruning off extra white space} { concat x y " a b c \n\t " " " " def " } {x y a b c def} +test concat-4.3 {pruning off extra white space sets length correctly} { + llength [concat { {{a}} }] +} 1 diff --git a/contrib/tcl/tests/defs b/contrib/tcl/tests/defs index 62f1e4c6c6464..ead6aebb25c62 100644 --- a/contrib/tcl/tests/defs +++ b/contrib/tcl/tests/defs @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) defs 1.38 96/07/24 17:18:20 +# SCCS: @(#) defs 1.52 97/06/24 11:13:36 if ![info exists VERBOSE] { set VERBOSE 0 @@ -22,10 +22,16 @@ if ![info exists TESTS] { # variable to prevent some tests from running at all. set user {} -catch {set user [exec whoami]} -if {$user == "root"} { - puts stdout "Warning: you're executing as root. I'll have to" - puts stdout "skip some of the tests, since they'll fail as root." +if {$tcl_platform(platform) == "unix"} { + catch {set user [exec whoami]} + if {$user == ""} { + catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} + } + if {$user == ""} {set user root} + if {$user == "root"} { + puts stdout "Warning: you're executing as root. I'll have to" + puts stdout "skip some of the tests, since they'll fail as root." + } } # Some of the tests don't work on some system configurations due to @@ -35,8 +41,6 @@ if {$user == "root"} { # "doAllTests" in this directory is used to indicate that the non-portable # tests should be run. -set doNonPortableTests [file exists doAllTests] - # If there is no "memory" command (because memory debugging isn't # enabled), generate a dummy command that does nothing. @@ -67,17 +71,28 @@ if {[info commands memory] == ""} { # that it is safe to run non-portable tests. # tempNotPc - The inverse of pcOnly. This flag is used to # temporarily disable a test. +# tempNotMac - The inverse of macOnly. This flag is used to +# temporarily disable a test. # nonBlockFiles - 1 means this platform supports setting files into # nonblocking mode. # asyncPipeClose- 1 means this platform supports async flush and # async close on a pipe. # unixExecs - 1 means this machine has commands such as 'cat', # 'echo' etc available. +# notIfCompiled - 1 means this that it is safe to run tests that +# might fail if the bytecode compiler is used. This +# element is set 1 if the file "doAllTests" exists in +# this directory. Normally, this element is 0 so that +# tests that fail with the bytecode compiler are +# skipped. As of 11/2/96 these are the history tests +# since they depend on accurate source location +# information. catch {unset testConfig} if {$tcl_platform(platform) == "unix"} { set testConfig(unixOnly) 1 set testConfig(tempNotPc) 1 + set testConfig(tempNotMac) 1 } else { set testConfig(unixOnly) 0 } @@ -88,6 +103,7 @@ if {$tcl_platform(platform) == "macintosh"} { set testConfig(macOnly) 0 } if {$tcl_platform(platform) == "windows"} { + set testConfig(tempNotMac) 1 set testConfig(pcOnly) 1 } else { set testConfig(pcOnly) 0 @@ -95,15 +111,45 @@ if {$tcl_platform(platform) == "windows"} { 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) [file exists doAllTests] +set testConfig(nonPortable) [file exists doAllTests] +set testConfig(notIfCompiled) [file exists doAllCompilerTests] + +set testConfig(unix) $testConfig(unixOnly) +set testConfig(mac) $testConfig(macOnly) +set testConfig(pc) $testConfig(pcOnly) + +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 crash on +# certain platforms, so that they can be reactivated again when the +# underlying problem is fixed. + +set testConfig(winCrash) $testConfig(macOrUnix) +set testConfig(macCrash) $testConfig(unixOrPc) +set testConfig(unixCrash) $testConfig(macOrPc) -set f [open defs r] -if {[expr [catch {fconfigure $f -blocking off}]] == 0} { +if {[catch {set f [open defs r]}]} { set testConfig(nonBlockFiles) 1 } else { - set testConfig(nonBlockFiles) 0 + if {[expr [catch {fconfigure $f -blocking off}]] == 0} { + set testConfig(nonBlockFiles) 1 + } else { + set testConfig(nonBlockFiles) 0 + } + close $f +} + +trace variable testConfig r safeFetch + +proc safeFetch {n1 n2 op} { + global testConfig + + if {($n2 != {}) && ([info exists testConfig($n2)] == 0)} { + set testConfig($n2) 0 + } } -close $f # Test for SCO Unix - cannot run async flushing tests because a potential # problem with select is apparently interfering. (Mark Diekhans). @@ -169,6 +215,10 @@ if {($testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} { } else { catch {exec rm -r removeMe} } + if {$testConfig(unixExecs) == 0} { + puts stdout "Warning: Unix-style executables are not available, so" + puts stdout "some tests will be skipped." + } } proc print_verbose {name description script code answer} { @@ -240,12 +290,35 @@ proc test {name description script answer args} { set constraints $script set script $answer set answer [lindex $args 0] - foreach constraint $constraints { - if {![info exists testConfig($constraint)] - || !$testConfig($constraint)} { - return + 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 then { + puts stdout "++++ $name SKIPPED: $constraints" + } + return + } } else { error "wrong # args: must be \"test name description ?constraints? script answer\"" } @@ -298,30 +371,15 @@ proc makeFile {contents name} { } proc removeFile {name} { - global tcl_platform testConfig - if {$tcl_platform(platform) == "macintosh"} { - catch {rm -f $name} - } else { - catch {exec rm -f $name} - } + file delete $name } proc makeDirectory {name} { - global tcl_platform testConfig - if {$tcl_platform(platform) == "macintosh"} { - catch {mkdir $name} - } else { - catch {exec mkdir $name} - } + file mkdir $name } proc removeDirectory {name} { - global tcl_platform testConfig - if {$tcl_platform(platform) == "macintosh"} { - catch {rmdir $name} - } else { - catch {exec rm -rf $name} - } + file delete -force $name } proc viewFile {name} { @@ -345,4 +403,4 @@ if {$tcltest == "{}"} { puts "Unable to find tcltest executable, multiple process tests will fail." } - + diff --git a/contrib/tcl/tests/dstring.test b/contrib/tcl/tests/dstring.test index 2ae157acbac4f..93a84d4c9acdd 100644 --- a/contrib/tcl/tests/dstring.test +++ b/contrib/tcl/tests/dstring.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) dstring.test 1.8 96/02/16 08:55:46 +# SCCS: @(#) dstring.test 1.10 96/10/08 17:40:02 if {[info commands testdstring] == {}} { puts "This application hasn't been compiled with the \"testdstring\"" @@ -153,7 +153,7 @@ test dstring-3.4 {nested sublists} { testdstring element last testdstring get } {before {during more} last} -test dstring-3.4 {nested sublists} { +test dstring-3.5 {nested sublists} { testdstring free testdstring element "\{" testdstring start @@ -183,6 +183,7 @@ test dstring-5.1 {copying to result} { } xyz test dstring-5.2 {copying to result} { testdstring free + catch {unset a} foreach l {a b c d e f g h i j k l m n o p} { testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 } diff --git a/contrib/tcl/tests/error.test b/contrib/tcl/tests/error.test index 9adbe057afece..3421edc32f86b 100644 --- a/contrib/tcl/tests/error.test +++ b/contrib/tcl/tests/error.test @@ -5,12 +5,12 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) error.test 1.14 96/02/16 08:55:48 +# SCCS: @(#) error.test 1.18 96/11/07 18:36:09 if {[string compare test [info procs test]] == 1} then {source defs} @@ -42,9 +42,7 @@ test error-1.3 {simple errors from commands} { set errorInfo } {wrong # args: should be "string compare string1 string2" while executing -"string compare" - invoked from within -"format [string compare]..."} +"format [string compare]"} test error-1.4 {simple errors from commands} { catch {error glorp} b @@ -64,10 +62,6 @@ test error-1.7 {simple errors from commands} { set b } {wrong # args: should be "catch command ?varName?"} -test error-2.1 {simple errors from commands} { - catch catch -} 1 - # Check errors nested in procedures. Also check the optional argument # to "error" to generate a new error trace. @@ -86,7 +80,7 @@ test error-2.3 {errors in nested procedures} { } {Human-generated while executing "error {Human-generated}" - (procedure "foo" line 4) + (procedure "foo" line 1) invoked from within "foo"} @@ -104,9 +98,7 @@ test error-2.6 {errors in nested procedures} { set errorInfo } {glorp2 while executing -"error glorp2" - invoked from within -"format [error glorp2]..." +"format [error glorp2]" (procedure "foo2" line 1) invoked from within "foo2"} diff --git a/contrib/tcl/tests/eval.test b/contrib/tcl/tests/eval.test index dcd2ea85766f1..48ee9ce6e798c 100644 --- a/contrib/tcl/tests/eval.test +++ b/contrib/tcl/tests/eval.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) eval.test 1.7 96/02/16 08:55:49 +# SCCS: @(#) eval.test 1.9 96/09/10 13:50:39 if {[string compare test [info procs test]] == 1} then {source defs} @@ -47,7 +47,7 @@ test eval-2.5 {error in eval'ed command: setting errorInfo} { } "test error while executing \"error \"test error\"\" - (\"eval\" body line 3) + (\"eval\" body line 1) invoked from within \"eval { set a 1 diff --git a/contrib/tcl/tests/event.test b/contrib/tcl/tests/event.test index b48ee221d0585..67418364379da 100644 --- a/contrib/tcl/tests/event.test +++ b/contrib/tcl/tests/event.test @@ -1,14 +1,14 @@ # This file contains a collection of tests for the procedures in the file -# tclEvent.c, which includes the "after", "update", and "vwait" Tcl +# tclEvent.c, which includes the "update", and "vwait" Tcl # commands. Sourcing this file into Tcl runs the tests and generates # output for errors. No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1995-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# "@(#) event.test 1.20 96/04/09 15:54:05" +# "@(#) event.test 1.27 97/06/23 18:21:18" if {[string compare test [info procs test]] == 1} then {source defs} @@ -110,6 +110,7 @@ if {[catch {testfilehandler create 0 off off}] == 0 } { } {0 0} test event-4.1 {FileHandlerEventProc, race between event and disabling } { + update testfilehandler close testfilehandler create 2 disabled disabled testfilehandler create 1 readable writable @@ -128,6 +129,7 @@ if {[catch {testfilehandler create 0 off off}] == 0 } { set result } {{0 1} {1 1} {1 2} {0 0}} test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off } { + update testfilehandler close testfilehandler create 1 readable writable testfilehandler create 2 readable writable @@ -145,147 +147,7 @@ if {[catch {testfilehandler create 0 off off}] == 0 } { update } -test event-5.1 {Tcl_CreateTimerHandler procedure} { - foreach i [after info] { - after cancel $i - } - set x "" - foreach i {100 200 1000 50 150} { - after $i lappend x $i - } - after 200 - update - set x -} {50 100 150 200} - -test event-6.1 {Tcl_DeleteTimerHandler procedure} { - foreach i [after info] { - after cancel $i - } - set x "" - foreach i {100 200 300 50 150} { - after $i lappend x $i - } - after cancel lappend x 150 - after cancel lappend x 50 - after 200 - update - set x -} {100 200} - -if {[info commands testmodal] != ""} { - test event-7.1 {Tcl_CreateModalTimeout and Tcl_DeleteModalTimeout procedures} { - update - set x {} - set result {} - testmodal create 50 first - testmodal create 200 second - after 100 - testmodal eventnotimers - lappend result $x - after 150 - testmodal eventnotimers - lappend result $x - testmodal delete - testmodal eventnotimers - lappend result $x - testmodal eventnotimers - lappend result $x - testmodal delete - testmodal eventnotimers - lappend result $x - } {{} second {second first} {second first first} {second first first}} - - test event-8.1 {TimerHandlerSetupProc procedure, choosing correct timer} { - update - set x {} - after 100 {lappend x normal} - testmodal create 200 modal - vwait x - testmodal delete - set x - } {normal} - test event-8.2 {TimerHandlerSetupProc procedure, choosing correct timer} { - update - set x {} - after 200 {lappend x normal} - testmodal create 100 modal - vwait x - testmodal delete - set x - } {modal} -} - -# No tests for TimerHandlerCheckProc: it's already tested by other tests -# above and below. - -test event-9.1 {TimerHandlerEventProc procedure} { - foreach i [after info] { - after cancel $i - } - foreach i {100 200 300} { - after $i lappend x $i - } - after 100 - set result "" - set x "" - update - lappend result $x - after 100 - update - lappend result $x - after 100 - update - lappend result $x -} {100 {100 200} {100 200 300}} - -# No tests for Tcl_DoWhenIdle: it's already tested by other tests -# below. - -test event-10.1 {Tk_CancelIdleCall procedure} { - foreach i [after info] { - after cancel $i - } - set x before - set y before - set z before - after idle set x after1 - after idle set y after2 - after idle set z after3 - after cancel set y after2 - update idletasks - concat $x $y $z -} {after1 before after3} -test event-10.2 {Tk_CancelIdleCall procedure} { - foreach i [after info] { - after cancel $i - } - set x before - set y before - set z before - after idle set x after1 - after idle set y after2 - after idle set z after3 - after cancel set x after1 - update idletasks - concat $x $y $z -} {before after2 after3} - -test event-11.1 {Tcl_ServiceIdle, self-rescheduling handlers} { - foreach i [after info] { - after cancel $i - } - set x 1 - set y 23 - after idle {incr x; after idle {incr x; after idle {incr x}}} - after idle {incr y} - vwait x - set result "$x $y" - update idletasks - lappend result $x -} {2 24 4} - -test event-12.1 {Tcl_BackgroundError, HandleBgErrors procedures} { +test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} { catch {rename bgerror {}} proc bgerror msg { global errorInfo errorCode x @@ -305,7 +167,7 @@ test event-12.1 {Tcl_BackgroundError, HandleBgErrors procedures} { while executing "open non_existent" ("after" script)} {POSIX ENOENT {no such file or directory}}}} -test event-12.2 {Tcl_BackgroundError, HandleBgErrors procedures} { +test event-5.2 {Tcl_BackgroundError, HandleBgErrors procedures} { catch {rename bgerror {}} proc bgerror msg { global x @@ -320,7 +182,7 @@ test event-12.2 {Tcl_BackgroundError, HandleBgErrors procedures} { set x } {{a simple error}} -test event-13.1 {BgErrorDeleteProc procedure} { +test event-6.1 {BgErrorDeleteProc procedure} { catch {interp delete foo} interp create foo foo eval { @@ -346,20 +208,20 @@ test event-13.1 {BgErrorDeleteProc procedure} { } {Unmodified } -test event-14.1 {tkerror/bgerror backwards compabitility} { +test event-7.1 {tkerror/bgerror backwards compabitility} { catch {rename bgerror {}} proc tkerror {x y} { return [expr $x + $y] } list [tkerror 4 7] [bgerror 8 -3] } {11 5} -test event-14.2 {tkerror/bgerror backwards compabitility} { +test event-7.2 {tkerror/bgerror backwards compabitility} { proc bgerror {x y} { return [expr 1 + $x + $y] } list [tkerror 6 -2] [bgerror 7 2] } {5 10} -test event-14.3 {tkerror/bgerror backwards compabitility} { +test event-7.3 {tkerror/bgerror backwards compabitility} { proc bgerror {x y} { return [expr 1 + $x + $y] } @@ -367,7 +229,7 @@ test event-14.3 {tkerror/bgerror backwards compabitility} { rename tkerror {} lappend result [info commands bgerror] [info commands tkerror] } {bgerror tkerror {} {}} -test event-14.4 {tkerror/bgerror backwards compabitility} { +test event-7.4 {tkerror/bgerror backwards compabitility} { proc tkerror {x y} { return [expr 1 + $x + $y] } @@ -375,14 +237,14 @@ test event-14.4 {tkerror/bgerror backwards compabitility} { rename bgerror {} lappend result [info commands bgerror] [info commands tkerror] } {bgerror tkerror {} {}} -test event-14.5 {tkerror/bgerror backwards compabitility} { +test event-7.5 {tkerror/bgerror backwards compabitility} { proc tkerror {x y} { return [expr 1 + $x + $y] } rename tkerror foo list [info commands bgerror] [info commands tkerror] [foo 4 3] } {{} {} 8} -test event-14.6 {tkerror/bgerror backwards compabitility} { +test event-7.6 {tkerror/bgerror backwards compabitility} { proc bgerror {x y} { return [expr 1 + $x + $y] } @@ -390,26 +252,26 @@ test event-14.6 {tkerror/bgerror backwards compabitility} { rename bgerror foo list [info commands bgerror] [info commands tkerror] [foo 4 3] } {{} {} 8} -test event-14.7 {tkerror/bgerror backwards compabitility} { +test event-7.7 {tkerror/bgerror backwards compabitility} { proc foo args {return $args} catch {rename tkerror {}} rename foo tkerror list [info commands bgerror] [info commands tkerror] [info commands foo] [tkerror a b c d] } {bgerror tkerror {} {a b c d}} -test event-14.8 {tkerror/bgerror backwards compabitility} { +test event-7.8 {tkerror/bgerror backwards compabitility} { proc foo args {return $args} catch {rename bgerror {}} rename foo bgerror list [info commands bgerror] [info commands tkerror] [info commands foo] [tkerror a b c d] } {bgerror tkerror {} {a b c d}} -test event-14.9 {tkerror/bgerror backwards compabitility} { +test event-7.9 {tkerror/bgerror backwards compabitility} { proc bgerror args {return $args} list [catch {rename bgerror tkerror} msg] $msg } {1 {can't rename to "tkerror": command already exists}} -rename bgerror {} +catch {rename bgerror {}} if {[info commands testexithandler] != ""} { - test event-15.1 {Tcl_CreateExitHandler procedure} {unixOrPc} { + test event-8.1 {Tcl_CreateExitHandler procedure} {unixOrPc} { set child [open |[list [info nameofexecutable]] r+] puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; exit" @@ -422,7 +284,7 @@ even 4 odd 41 } - test event-16.1 {Tcl_DeleteExitHandler procedure} {unixOrPc} { + test event-9.1 {Tcl_DeleteExitHandler procedure} {unixOrPc} { set child [open |[list [info nameofexecutable]] r+] puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; testexithandler delete 41" @@ -435,7 +297,7 @@ odd 41 even 6 even 4 } - test event-16.2 {Tcl_DeleteExitHandler procedure} {unixOrPc} { + test event-9.2 {Tcl_DeleteExitHandler procedure} {unixOrPc} { set child [open |[list [info nameofexecutable]] r+] puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; testexithandler delete 4" @@ -448,7 +310,7 @@ even 4 even 6 odd 41 } - test event-16.3 {Tcl_DeleteExitHandler procedure} {unixOrPc} { + test event-9.3 {Tcl_DeleteExitHandler procedure} {unixOrPc} { set child [open |[list [info nameofexecutable]] r+] puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; testexithandler delete 6" @@ -461,7 +323,7 @@ odd 41 even 4 odd 41 } - test event-16.4 {Tcl_DeleteExitHandler procedure} {unixOrPc} { + test event-9.4 {Tcl_DeleteExitHandler procedure} {unixOrPc} { set child [open |[list [info nameofexecutable]] r+] puts $child "testexithandler create 41; testexithandler delete 41" puts $child "testexithandler create 16; exit" @@ -473,301 +335,25 @@ odd 41 } } -test event-17.1 {Tcl_Exit procedure} {unixOrPc} { +test event-10.1 {Tcl_Exit procedure} {unixOrPc} { set child [open |[list [info nameofexecutable]] r+] puts $child "exit 3" list [catch {close $child} msg] $msg [lindex $errorCode 0] \ [lindex $errorCode 2] } {1 {child process exited abnormally} CHILDSTATUS 3} -test event-18.1 {Tcl_AfterCmd procedure, basics} { - list [catch {after} msg] $msg -} {1 {wrong # args: should be "after option ?arg arg ...?"}} -test event-18.2 {Tcl_AfterCmd procedure, basics} { - list [catch {after 2x} msg] $msg -} {1 {expected integer but got "2x"}} -test event-18.3 {Tcl_AfterCmd procedure, basics} { - list [catch {after gorp} msg] $msg -} {1 {bad argument "gorp": must be cancel, idle, info, or a number}} -test event-18.4 {Tcl_AfterCmd procedure, ms argument} { - set x before - after 400 {set x after} - after 200 - update - set y $x - after 400 - update - list $y $x -} {before after} -test event-18.5 {Tcl_AfterCmd procedure, ms argument} { - set x before - after 300 set x after - after 200 - update - set y $x - after 200 - update - list $y $x -} {before after} -test event-18.6 {Tcl_AfterCmd procedure, cancel option} { - list [catch {after cancel} msg] $msg -} {1 {wrong # args: should be "after cancel id|command"}} -test event-18.7 {Tcl_AfterCmd procedure, cancel option} { - after cancel after#1 -} {} -test event-18.8 {Tcl_AfterCmd procedure, cancel option} { - after cancel {foo bar} -} {} -test event-18.9 {Tcl_AfterCmd procedure, cancel option} { - foreach i [after info] { - after cancel $i - } - set x before - set y [after 100 set x after] - after cancel $y - after 200 - update - set x -} {before} -test event-18.10 {Tcl_AfterCmd procedure, cancel option} { - foreach i [after info] { - after cancel $i - } - set x before - after 100 set x after - after cancel {set x after} - after 200 - update - set x -} {before} -test event-18.11 {Tcl_AfterCmd procedure, cancel option} { - foreach i [after info] { - after cancel $i - } - set x before - after 100 set x after - set id [after 300 set x after] - after cancel $id - after 200 - update - set y $x - set x cleared - after 200 - update - list $y $x -} {after cleared} -test event-18.12 {Tcl_AfterCmd procedure, cancel option} { - foreach i [after info] { - after cancel $i - } - set x first - after idle lappend x second - after idle lappend x third - set i [after idle lappend x fourth] - after cancel {lappend x second} - after cancel $i - update idletasks - set x -} {first third} -test event-18.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} { - foreach i [after info] { - after cancel $i - } - set x first - after idle lappend x second - after idle lappend x third - set i [after idle lappend x fourth] - after cancel lappend x second - after cancel $i - update idletasks - set x -} {first third} -test event-18.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} { - foreach i [after info] { - after cancel $i - } - set id [ - after 100 { - set x done - after cancel $id - } - ] - vwait x -} {} -test event-18.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} { - foreach i [after info] { - after cancel $i - } - interp create x - x eval {set a before; set b before; after idle {set a a-after}; - after idle {set b b-after}} - set result [llength [x eval after info]] - lappend result [llength [after info]] - after cancel {set b b-after} - set a aaa - set b bbb - x eval {after cancel set a a-after} - update idletasks - lappend result $a $b [x eval {list $a $b}] - interp delete x - set result -} {2 0 aaa bbb {before b-after}} -test event-18.16 {Tcl_AfterCmd procedure, idle option} { - list [catch {after idle} msg] $msg -} {1 {wrong # args: should be "after idle script script ..."}} -test event-18.17 {Tcl_AfterCmd procedure, idle option} { - set x before - after idle {set x after} - set y $x - update idletasks - list $y $x -} {before after} -test event-18.18 {Tcl_AfterCmd procedure, idle option} { - set x before - after idle set x after - set y $x - update idletasks - list $y $x -} {before after} -set event1 [after idle event 1] -set event2 [after 1000 event 2] -interp create x -set childEvent [x eval {after idle event in child}] -test event-18.19 {Tcl_AfterCmd, info option} { - lsort [after info] -} "$event1 $event2" -test event-18.20 {Tcl_AfterCmd, info option} { - list [catch {after info a b} msg] $msg -} {1 {wrong # args: should be "after info ?id?"}} -test event-18.21 {Tcl_AfterCmd, info option} { - list [catch {after info $childEvent} msg] $msg -} "1 {event \"$childEvent\" doesn't exist}" -test event-18.22 {Tcl_AfterCmd, info option} { - list [after info $event1] [after info $event2] -} {{{event 1} idle} {{event 2} timer}} -after cancel $event1 -after cancel $event2 -interp delete x - -set event [after idle foo bar] -scan $event after#%d id -test event-19.1 {GetAfterEvent procedure} { - list [catch {after info xfter#$id} msg] $msg -} "1 {event \"xfter#$id\" doesn't exist}" -test event-19.2 {GetAfterEvent procedure} { - list [catch {after info afterx$id} msg] $msg -} "1 {event \"afterx$id\" doesn't exist}" -test event-19.3 {GetAfterEvent procedure} { - list [catch {after info after#ab} msg] $msg -} {1 {event "after#ab" doesn't exist}} -test event-19.4 {GetAfterEvent procedure} { - list [catch {after info after#} msg] $msg -} {1 {event "after#" doesn't exist}} -test event-19.5 {GetAfterEvent procedure} { - list [catch {after info after#${id}x} msg] $msg -} "1 {event \"after#${id}x\" doesn't exist}" -test event-19.6 {GetAfterEvent procedure} { - list [catch {after info afterx[expr $id+1]} msg] $msg -} "1 {event \"afterx[expr $id+1]\" doesn't exist}" -after cancel $event - -test event-20.1 {AfterProc procedure} { - set x before - proc foo {} { - set x untouched - after 100 {set x after} - after 200 - update - return $x - } - list [foo] $x -} {untouched after} -test event-20.2 {AfterProc procedure} { - catch {rename bgerror {}} - proc bgerror msg { - global x errorInfo - set x [list $msg $errorInfo] - } - set x empty - after 100 {error "After error"} - after 200 - set y $x - update - catch {rename bgerror {}} - list $y $x -} {empty {{After error} {After error - while executing -"error "After error"" - ("after" script)}}} -test event-20.3 {AfterProc procedure, deleting handler from itself} { - foreach i [after info] { - after cancel $i - } - proc foo {} { - global x - set x {} - foreach i [after info] { - lappend x [after info $i] - } - after cancel foo - } - after idle foo - after 1000 {error "I shouldn't ever have executed"} - update idletasks - set x -} {{{error "I shouldn't ever have executed"} timer}} -test event-20.4 {AfterProc procedure, deleting handler from itself} { - foreach i [after info] { - after cancel $i - } - proc foo {} { - global x - set x {} - foreach i [after info] { - lappend x [after info $i] - } - after cancel foo - } - after 1000 {error "I shouldn't ever have executed"} - after idle foo - update idletasks - set x -} {{{error "I shouldn't ever have executed"} timer}} - foreach i [after info] { - after cancel $i - } - -test event-21.1 {AfterCleanupProc procedure} { - catch {interp delete x} - interp create x - x eval {after 200 { - lappend x after - puts "part 1: this message should not appear" - }} - after 200 {lappend x after2} - x eval {after 200 { - lappend x after3 - puts "part 2: this message should not appear" - }} - after 200 {lappend x after4} - x eval {after 200 { - lappend x after5 - puts "part 3: this message should not appear" - }} - interp delete x - set x before - after 300 - update - set x -} {before after2 after4} - -test event-22.1 {Tcl_VwaitCmd procedure} { +test event-11.1 {Tcl_VwaitCmd procedure} { list [catch {vwait} msg] $msg } {1 {wrong # args: should be "vwait name"}} -test event-22.2 {Tcl_VwaitCmd procedure} { +test event-11.2 {Tcl_VwaitCmd procedure} { list [catch {vwait a b} msg] $msg } {1 {wrong # args: should be "vwait name"}} -test event-22.3 {Tcl_VwaitCmd procedure} { +test event-11.3 {Tcl_VwaitCmd procedure} { + catch {unset x} + set x 1 + list [catch {vwait x(1)} msg] $msg +} {1 {can't trace "x(1)": variable isn't array}} +test event-11.4 {Tcl_VwaitCmd procedure} { foreach i [after info] { after cancel $i } @@ -782,13 +368,57 @@ test event-22.3 {Tcl_VwaitCmd procedure} { list [vwait y] $x $y $z $q } {{} x-done y-done before q-done} -test event-23.1 {Tcl_UpdateCmd procedure} { +foreach i [after info] { + after cancel $i +} + +test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} { + set f1 [open test1 w] + proc accept {s args} { + puts $s foobar + close $s + } + set s1 [socket -server accept 5000] + set s2 [socket 127.0.0.1 5000] + close $s1 + set x 0 + set y 0 + set z 0 + fileevent $s2 readable { incr z } + vwait z + fileevent $f1 writable { incr x; if { $y == 3 } { set z done } } + fileevent $s2 readable { incr y; if { $x == 3 } { set z done } } + vwait z + close $f1 + close $s2 + file delete test1 test2 + list $x $y $z +} {3 3 done} +test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} { + file delete test1 test2 + set f1 [open test1 w] + set f2 [open test2 w] + set x 0 + set y 0 + set z 0 + update + fileevent $f1 writable { incr x; if { $y == 3 } { set z done } } + fileevent $f2 writable { incr y; if { $x == 3 } { set z done } } + vwait z + close $f1 + close $f2 + file delete test1 test2 + list $x $y $z +} {3 3 done} + + +test event-12.1 {Tcl_UpdateCmd procedure} { list [catch {update a b} msg] $msg } {1 {wrong # args: should be "update ?idletasks?"}} -test event-23.2 {Tcl_UpdateCmd procedure} { +test event-12.2 {Tcl_UpdateCmd procedure} { list [catch {update bogus} msg] $msg } {1 {bad option "bogus": must be idletasks}} -test event-23.3 {Tcl_UpdateCmd procedure} { +test event-12.3 {Tcl_UpdateCmd procedure} { foreach i [after info] { after cancel $i } @@ -801,7 +431,7 @@ test event-23.3 {Tcl_UpdateCmd procedure} { update idletasks list $x $y $z } {before after {after, y = after}} -test event-23.4 {Tcl_UpdateCmd procedure} { +test event-12.4 {Tcl_UpdateCmd procedure} { foreach i [after info] { after cancel $i } @@ -817,7 +447,7 @@ test event-23.4 {Tcl_UpdateCmd procedure} { } {x-done before z-done} if {[info commands testfilehandler] != ""} { - test event-24.1 {Tcl_WaitForFile procedure, readable} unixOnly { + test event-13.1 {Tcl_WaitForFile procedure, readable} unixOnly { foreach i [after info] { after cancel $i } @@ -830,7 +460,7 @@ if {[info commands testfilehandler] != ""} { testfilehandler close list $result $x } {{} {no timeout}} - test event-24.2 {Tcl_WaitForFile procedure, readable} unixOnly { + test event-13.2 {Tcl_WaitForFile procedure, readable} unixOnly { foreach i [after info] { after cancel $i } @@ -843,7 +473,7 @@ if {[info commands testfilehandler] != ""} { testfilehandler close list $result $x } {{} timeout} - test event-24.3 {Tcl_WaitForFile procedure, readable} unixOnly { + test event-13.3 {Tcl_WaitForFile procedure, readable} unixOnly { foreach i [after info] { after cancel $i } @@ -857,7 +487,7 @@ if {[info commands testfilehandler] != ""} { testfilehandler close list $result $x } {readable {no timeout}} - test event-24.4 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} { + test event-13.4 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} { foreach i [after info] { after cancel $i } @@ -871,7 +501,7 @@ if {[info commands testfilehandler] != ""} { testfilehandler close list $result $x } {{} {no timeout}} - test event-24.5 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} { + test event-13.5 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} { foreach i [after info] { after cancel $i } @@ -885,7 +515,7 @@ if {[info commands testfilehandler] != ""} { testfilehandler close list $result $x } {{} timeout} - test event-24.6 {Tcl_WaitForFile procedure, writable} unixOnly { + test event-13.6 {Tcl_WaitForFile procedure, writable} unixOnly { foreach i [after info] { after cancel $i } @@ -898,7 +528,7 @@ if {[info commands testfilehandler] != ""} { testfilehandler close list $result $x } {writable {no timeout}} - test event-24.7 {Tcl_WaitForFile procedure, don't call other event handlers} unixOnly { + test event-13.7 {Tcl_WaitForFile procedure, don't call other event handlers} unixOnly { foreach i [after info] { after cancel $i } @@ -912,7 +542,10 @@ if {[info commands testfilehandler] != ""} { testfilehandler close lappend result $x } {{} {} {timeout idle}} - test event-24.8 {Tcl_WaitForFile procedure, waiting indefinitely} unixOnly { +} + +if {[info commands testfilewait] != ""} { + test event-13.8 {Tcl_WaitForFile procedure, waiting indefinitely} unixOnly { set f [open "|sleep 2" r] set result "" lappend result [testfilewait $f readable 100] diff --git a/contrib/tcl/tests/exec.test b/contrib/tcl/tests/exec.test index 75dd359608fc9..4b00c4449c468 100644 --- a/contrib/tcl/tests/exec.test +++ b/contrib/tcl/tests/exec.test @@ -5,12 +5,12 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# 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. # -# SCCS: @(#) exec.test 1.53 96/04/12 16:33:37 +# SCCS: @(#) exec.test 1.56 97/06/20 13:27:37 if {[string compare test [info procs test]] == 1} then {source defs} @@ -21,16 +21,11 @@ if {[info commands exec] == ""} { return } -# This procedure generates a shell command to be passed to exec -# to mask the differences between Unix and PC shells. - -proc shellCmd {string} { - global tcl_platform - if {$tcl_platform(platform) == "unix"} { - return "sh -c \"$string\"" - } else { - return "sh -c {\"$string\"}" - } +proc cat {name} { + set f [open $name r] + set x [read -nonewline $f] + close $f + set x } # Basic operations. @@ -118,12 +113,12 @@ test exec-4.1 {redirecting output and stderr to file} {unixExecs} { exec cat gorp.file } "test output" test exec-4.2 {redirecting output and stderr to file} {unixExecs} { - list [eval exec [shellCmd "echo foo bar 1>&2"] >&gorp.file] \ + list [exec sh -c "echo foo bar 1>&2" >&gorp.file] \ [exec cat gorp.file] } {{} {foo bar}} test exec-4.3 {redirecting output and stderr to file} {unixExecs} { exec echo "first line" > gorp.file - list [eval exec [shellCmd "echo foo bar 1>&2"] >>&gorp.file] \ + list [exec sh -c "echo foo bar 1>&2" >>&gorp.file] \ [exec cat gorp.file] } "{} {first line\nfoo bar}" test exec-4.4 {redirecting output and stderr to file} {unixExecs} { @@ -140,8 +135,8 @@ test exec-4.5 {redirecting output and stderr to file} {unixExecs} { set f [open gorp.file w] puts $f "Line 1" flush $f - eval exec >&@ $f [shellCmd "echo foo bar 1>&2"] - eval exec >&@$f [shellCmd "echo xyzzy 1>&2"] + exec >&@ $f sh -c "echo foo bar 1>&2" + exec >&@$f sh -c "echo xyzzy 1>&2" puts $f "Line 3" close $f exec cat gorp.file @@ -181,14 +176,14 @@ test exec-5.7 {redirecting input from file} {unixExecs} { # I/O redirection: standard error through a pipeline. test exec-6.1 {redirecting stderr through a pipeline} {unixExecs} { - eval exec [shellCmd "echo foo bar"] |& cat + exec sh -c "echo foo bar" |& cat } "foo bar" test exec-6.2 {redirecting stderr through a pipeline} {unixExecs} { - eval exec [shellCmd "echo foo bar 1>&2"] |& cat + exec sh -c "echo foo bar 1>&2" |& cat } "foo bar" test exec-6.3 {redirecting stderr through a pipeline} {unixExecs} { - eval exec [shellCmd "echo foo bar 1>&2"] \ - |& [shellCmd "echo second msg 1>&2; cat"] |& cat + exec sh -c "echo foo bar 1>&2" \ + |& sh -c "echo second msg 1>&2; cat" |& cat } "second msg\nfoo bar" # I/O redirection: combinations. @@ -223,21 +218,21 @@ test exec-9.2 {commands returning errors} {unixExecs} { string tolower [list [catch {exec echo foo | foo123} msg] $msg $errorCode] } {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}} test exec-9.3 {commands returning errors} {unixExecs} { - list [catch {eval exec sleep 1 | [shellCmd "exit 43"] | sleep 1} msg] $msg + list [catch {exec sleep 1 | sh -c "exit 43" | sleep 1} msg] $msg } {1 {child process exited abnormally}} test exec-9.4 {commands returning errors} {unixExecs} { - list [catch {eval exec [shellCmd "exit 43"] | echo "foo bar"} msg] $msg + list [catch {exec sh -c "exit 43" | echo "foo bar"} msg] $msg } {1 {foo bar child process exited abnormally}} test exec-9.5 {commands returning errors} {unixExecs} { list [catch {exec gorp456 | echo a b c} msg] [string tolower $msg] } {1 {couldn't execute "gorp456": no such file or directory}} test exec-9.6 {commands returning errors} {unixExecs} { - list [catch {eval exec [shellCmd "echo error msg 1>&2"]} msg] $msg + list [catch {exec sh -c "echo error msg 1>&2"} msg] $msg } {1 {error msg}} test exec-9.7 {commands returning errors} {unixExecs} { - list [catch {eval exec [shellCmd "echo error msg 1>&2"] \ - | [shellCmd "echo error msg 1>&2"]} msg] $msg + list [catch {exec sh -c "echo error msg 1>&2" \ + | sh -c "echo error msg 1>&2"} msg] $msg } {1 {error msg error msg}} @@ -408,16 +403,16 @@ test exec-14.4 {-- switch} { test exec-15.1 {standard error redirection} {unixExecs} { exec echo "First line" > gorp.file - list [eval exec [shellCmd "echo foo bar 1>&2"] 2> gorp.file] \ + list [exec sh -c "echo foo bar 1>&2" 2> gorp.file] \ [exec cat gorp.file] } {{} {foo bar}} test exec-15.2 {standard error redirection} {unixExecs} { - list [eval exec [shellCmd "echo foo bar 1>&2"] | echo biz baz >gorp.file \ + list [exec sh -c "echo foo bar 1>&2" | echo biz baz >gorp.file \ 2> gorp.file2] [exec cat gorp.file] \ [exec cat gorp.file2] } {{} {biz baz} {foo bar}} test exec-15.3 {standard error redirection} {unixExecs} { - list [eval exec [shellCmd "echo foo bar 1>&2"] | echo biz baz 2>gorp.file \ + list [exec sh -c "echo foo bar 1>&2" | echo biz baz 2>gorp.file \ > gorp.file2] [exec cat gorp.file] \ [exec cat gorp.file2] } {{} {foo bar} {biz baz}} @@ -425,7 +420,7 @@ test exec-15.4 {standard error redirection} {unixExecs} { set f [open gorp.file w] puts $f "Line 1" flush $f - eval exec [shellCmd "echo foo bar 1>&2"] 2>@ $f + exec sh -c "echo foo bar 1>&2" 2>@ $f puts $f "Line 3" close $f exec cat gorp.file @@ -434,12 +429,12 @@ foo bar Line 3} test exec-15.5 {standard error redirection} {unixExecs} { exec echo "First line" > gorp.file - eval exec [shellCmd "echo foo bar 1>&2"] 2>> gorp.file + exec sh -c "echo foo bar 1>&2" 2>> gorp.file exec cat gorp.file } {First line foo bar} test exec-15.6 {standard error redirection} {unixExecs} { - eval exec [shellCmd "echo foo bar 1>&2"] > gorp.file2 2> gorp.file \ + exec sh -c "echo foo bar 1>&2" > gorp.file2 2> gorp.file \ >& gorp.file 2> gorp.file2 | echo biz baz list [exec cat gorp.file] [exec cat gorp.file2] } {{biz baz} {foo bar}} @@ -454,13 +449,13 @@ test exec-16.1 {flush output before exec} {unixExecs} { } {First line Second line Third line} -test exec-16.2 {flush output before exec} {unixExecs} { +test exec-16.2 {flush output before exec} {} { set f [open gorp.file w] puts $f "First line" - eval exec [shellCmd "echo Second line 1>&2"] >&@ $f > gorp.file2 + exec [lindex $tcltest 0] << {puts stderr {Second line}} >&@ $f > gorp.file2 puts $f "Third line" close $f - exec cat gorp.file + cat gorp.file } {First line Second line Third line} diff --git a/contrib/tcl/tests/execute.test b/contrib/tcl/tests/execute.test new file mode 100644 index 0000000000000..6c63750d9b3d6 --- /dev/null +++ b/contrib/tcl/tests/execute.test @@ -0,0 +1,113 @@ +# This file contains tests for the tclExecute.c source file. Tests appear +# in the same order as the C code that they test. The set of tests is +# currently incomplete since it currently includes only new tests for +# code changed for the addition of Tcl namespaces. Other execution- +# related tests appear in several other test files including +# namespace.test, basic.test, eval.test, for.test, etc. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) execute.test 1.3 97/06/20 14:51:19 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {eval namespace delete [namespace children :: test_ns_*]} +catch {rename foo ""} +catch {unset x} +catch {unset y} +catch {unset msg} + +test execute-1.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {unset x} + catch {unset y} + namespace eval test_ns_1 { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_1::test_ns_2 { + namespace import ::test_ns_1::* + } + set x "test_ns_1::" + set y "test_ns_2::" + list [namespace which -command ${x}${y}cmd1] \ + [catch {namespace which -command ${x}${y}cmd2} msg] $msg \ + [catch {namespace which -command ${x}${y}:cmd2} msg] $msg +} {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}} +test execute-1.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename foo ""} + catch {unset l} + proc foo {} { + return "global foo" + } + namespace eval test_ns_1 { + proc whichFoo {} { + return [namespace which -command foo] + } + } + set l "" + lappend l [test_ns_1::whichFoo] + namespace eval test_ns_1 { + proc foo {} { + return "namespace foo" + } + } + lappend l [test_ns_1::whichFoo] + set l +} {::foo ::test_ns_1::foo} +test execute-1.3 {Tcl_GetCommandFromObj, command never found} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename foo ""} + namespace eval test_ns_1 { + proc foo {} { + return "namespace foo" + } + } + namespace eval test_ns_1 { + proc foo {} { + return "namespace foo" + } + } + list [namespace eval test_ns_1 {namespace which -command foo}] \ + [rename test_ns_1::foo ""] \ + [catch {namespace eval test_ns_1 {namespace which -command foo}} msg] $msg +} {::test_ns_1::foo {} 0 {}} + +test execute-2.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {unset l} + proc {} {} {return {}} + {} + set l {} + lindex {} 0 + {} +} {} + +test execute-3.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} { + proc {} {} {} + proc { } {} {} + proc p {} { + set x {} + $x + append x { } + $x + } + p +} {} + +catch {eval namespace delete [namespace children :: test_ns_*]} +catch {rename foo ""} +catch {rename p ""} +catch {rename {} ""} +catch {rename { } ""} +catch {unset x} +catch {unset y} +catch {unset msg} diff --git a/contrib/tcl/tests/expr-old.test b/contrib/tcl/tests/expr-old.test new file mode 100644 index 0000000000000..e25a1eb2d3821 --- /dev/null +++ b/contrib/tcl/tests/expr-old.test @@ -0,0 +1,904 @@ +# Commands covered: expr +# +# This file contains the original set of tests for Tcl's expr command. +# Since the expr command is now compiled, a new set of tests covering +# the new implementation is in the file "expr.test". Sourcing this file +# into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1991-1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) expr-old.test 1.59 97/06/26 14:33:32 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { + set gotT1 0 + puts "This application hasn't been compiled with the \"T1\" and" + puts "\"T2\" math functions, so I'll skip some of the expr tests." +} else { + set gotT1 1 +} + +# First, test all of the integer operators individually. + +test expr-old-1.1 {integer operators} {expr -4} -4 +test expr-old-1.2 {integer operators} {expr -(1+4)} -5 +test expr-old-1.3 {integer operators} {expr ~3} -4 +test expr-old-1.4 {integer operators} {expr !2} 0 +test expr-old-1.5 {integer operators} {expr !0} 1 +test expr-old-1.6 {integer operators} {expr 4*6} 24 +test expr-old-1.7 {integer operators} {expr 36/12} 3 +test expr-old-1.8 {integer operators} {expr 27/4} 6 +test expr-old-1.9 {integer operators} {expr 27%4} 3 +test expr-old-1.10 {integer operators} {expr 2+2} 4 +test expr-old-1.11 {integer operators} {expr 2-6} -4 +test expr-old-1.12 {integer operators} {expr 1<<3} 8 +test expr-old-1.13 {integer operators} {expr 0xff>>2} 63 +test expr-old-1.14 {integer operators} {expr -1>>2} -1 +test expr-old-1.15 {integer operators} {expr 3>2} 1 +test expr-old-1.16 {integer operators} {expr 2>2} 0 +test expr-old-1.17 {integer operators} {expr 1>2} 0 +test expr-old-1.18 {integer operators} {expr 3<2} 0 +test expr-old-1.19 {integer operators} {expr 2<2} 0 +test expr-old-1.20 {integer operators} {expr 1<2} 1 +test expr-old-1.21 {integer operators} {expr 3>=2} 1 +test expr-old-1.22 {integer operators} {expr 2>=2} 1 +test expr-old-1.23 {integer operators} {expr 1>=2} 0 +test expr-old-1.24 {integer operators} {expr 3<=2} 0 +test expr-old-1.25 {integer operators} {expr 2<=2} 1 +test expr-old-1.26 {integer operators} {expr 1<=2} 1 +test expr-old-1.27 {integer operators} {expr 3==2} 0 +test expr-old-1.28 {integer operators} {expr 2==2} 1 +test expr-old-1.29 {integer operators} {expr 3!=2} 1 +test expr-old-1.30 {integer operators} {expr 2!=2} 0 +test expr-old-1.31 {integer operators} {expr 7&0x13} 3 +test expr-old-1.32 {integer operators} {expr 7^0x13} 20 +test expr-old-1.33 {integer operators} {expr 7|0x13} 23 +test expr-old-1.34 {integer operators} {expr 0&&1} 0 +test expr-old-1.35 {integer operators} {expr 0&&0} 0 +test expr-old-1.36 {integer operators} {expr 1&&3} 1 +test expr-old-1.37 {integer operators} {expr 0||1} 1 +test expr-old-1.38 {integer operators} {expr 3||0} 1 +test expr-old-1.39 {integer operators} {expr 0||0} 0 +test expr-old-1.40 {integer operators} {expr 3>2?44:66} 44 +test expr-old-1.41 {integer operators} {expr 2>3?44:66} 66 +test expr-old-1.42 {integer operators} {expr 36/5} 7 +test expr-old-1.43 {integer operators} {expr 36%5} 1 +test expr-old-1.44 {integer operators} {expr -36/5} -8 +test expr-old-1.45 {integer operators} {expr -36%5} 4 +test expr-old-1.46 {integer operators} {expr 36/-5} -8 +test expr-old-1.47 {integer operators} {expr 36%-5} -4 +test expr-old-1.48 {integer operators} {expr -36/-5} 7 +test expr-old-1.49 {integer operators} {expr -36%-5} -1 +test expr-old-1.50 {integer operators} {expr +36} 36 +test expr-old-1.51 {integer operators} {expr +--++36} 36 +test expr-old-1.52 {integer operators} {expr +36%+5} 1 + +# Check the floating-point operators individually, along with +# automatic conversion to integers where needed. + +test expr-old-2.1 {floating-point operators} {format %.6g [expr -4.2]} -4.2 +test expr-old-2.2 {floating-point operators} { + format %.6g [expr -(1.1+4.2)] +} -5.3 +test expr-old-2.3 {floating-point operators} {expr +5.7} 5.7 +test expr-old-2.4 {floating-point operators} {expr +--+-62.0} -62.0 +test expr-old-2.5 {floating-point operators} {expr !2.1} 0 +test expr-old-2.6 {floating-point operators} {expr !0.0} 1 +test expr-old-2.7 {floating-point operators} {format %.6g [expr 4.2*6.3]} 26.46 +test expr-old-2.8 {floating-point operators} {expr 36.0/12.0} 3.0 +test expr-old-2.9 {floating-point operators} {expr 27/4.0} 6.75 +test expr-old-2.10 {floating-point operators} {format %.6g [expr 2.3+2.1]} 4.4 +test expr-old-2.11 {floating-point operators} {format %.6g [expr 2.3-6.5]} -4.2 +test expr-old-2.12 {floating-point operators} {expr 3.1>2.1} 1 +test expr-old-2.13 {floating-point operators} {expr {2.1 > 2.1}} 0 +test expr-old-2.14 {floating-point operators} {expr 1.23>2.34e+1} 0 +test expr-old-2.15 {floating-point operators} {expr 3.45<2.34} 0 +test expr-old-2.16 {floating-point operators} {expr 0.002e3<--200e-2} 0 +test expr-old-2.17 {floating-point operators} {expr 1.1<2.1} 1 +test expr-old-2.18 {floating-point operators} {expr 3.1>=2.2} 1 +test expr-old-2.19 {floating-point operators} {expr 2.345>=2.345} 1 +test expr-old-2.20 {floating-point operators} {expr 1.1>=2.2} 0 +test expr-old-2.21 {floating-point operators} {expr 3.0<=2.0} 0 +test expr-old-2.22 {floating-point operators} {expr 2.2<=2.2} 1 +test expr-old-2.23 {floating-point operators} {expr 2.2<=2.2001} 1 +test expr-old-2.24 {floating-point operators} {expr 3.2==2.2} 0 +test expr-old-2.25 {floating-point operators} {expr 2.2==2.2} 1 +test expr-old-2.26 {floating-point operators} {expr 3.2!=2.2} 1 +test expr-old-2.27 {floating-point operators} {expr 2.2!=2.2} 0 +test expr-old-2.28 {floating-point operators} {expr 0.0&&0.0} 0 +test expr-old-2.29 {floating-point operators} {expr 0.0&&1.3} 0 +test expr-old-2.30 {floating-point operators} {expr 1.3&&0.0} 0 +test expr-old-2.31 {floating-point operators} {expr 1.3&&3.3} 1 +test expr-old-2.32 {floating-point operators} {expr 0.0||0.0} 0 +test expr-old-2.33 {floating-point operators} {expr 0.0||1.3} 1 +test expr-old-2.34 {floating-point operators} {expr 1.3||0.0} 1 +test expr-old-2.35 {floating-point operators} {expr 3.3||0.0} 1 +test expr-old-2.36 {floating-point operators} { + format %.6g [expr 3.3>2.3?44.3:66.3]} 44.3 +test expr-old-2.37 {floating-point operators} { + format %.6g [expr 2.3>3.3?44.3:66.3]} 66.3 +test expr-old-2.38 {floating-point operators} { + list [catch {format %.6g [expr 028.1 + 09.2]} msg] $msg +} {0 37.3} + +# Operators that aren't legal on floating-point numbers + +test expr-old-3.1 {illegal floating-point operations} { + list [catch {expr ~4.0} msg] $msg +} {1 {can't use floating-point value as operand of "~"}} +test expr-old-3.2 {illegal floating-point operations} { + list [catch {expr 27%4.0} msg] $msg +} {1 {can't use floating-point value as operand of "%"}} +test expr-old-3.3 {illegal floating-point operations} { + list [catch {expr 27.0%4} msg] $msg +} {1 {can't use floating-point value as operand of "%"}} +test expr-old-3.4 {illegal floating-point operations} { + list [catch {expr 1.0<<3} msg] $msg +} {1 {can't use floating-point value as operand of "<<"}} +test expr-old-3.5 {illegal floating-point operations} { + list [catch {expr 3<<1.0} msg] $msg +} {1 {can't use floating-point value as operand of "<<"}} +test expr-old-3.6 {illegal floating-point operations} { + list [catch {expr 24.0>>3} msg] $msg +} {1 {can't use floating-point value as operand of ">>"}} +test expr-old-3.7 {illegal floating-point operations} { + list [catch {expr 24>>3.0} msg] $msg +} {1 {can't use floating-point value as operand of ">>"}} +test expr-old-3.8 {illegal floating-point operations} { + list [catch {expr 24&3.0} msg] $msg +} {1 {can't use floating-point value as operand of "&"}} +test expr-old-3.9 {illegal floating-point operations} { + list [catch {expr 24.0|3} msg] $msg +} {1 {can't use floating-point value as operand of "|"}} +test expr-old-3.10 {illegal floating-point operations} { + list [catch {expr 24.0^3} msg] $msg +} {1 {can't use floating-point value as operand of "^"}} + +# Check the string operators individually. + +test expr-old-4.1 {string operators} {expr {"abc" > "def"}} 0 +test expr-old-4.2 {string operators} {expr {"def" > "def"}} 0 +test expr-old-4.3 {string operators} {expr {"g" > "def"}} 1 +test expr-old-4.4 {string operators} {expr {"abc" < "abd"}} 1 +test expr-old-4.5 {string operators} {expr {"abd" < "abd"}} 0 +test expr-old-4.6 {string operators} {expr {"abe" < "abd"}} 0 +test expr-old-4.7 {string operators} {expr {"abc" >= "def"}} 0 +test expr-old-4.8 {string operators} {expr {"def" >= "def"}} 1 +test expr-old-4.9 {string operators} {expr {"g" >= "def"}} 1 +test expr-old-4.10 {string operators} {expr {"abc" <= "abd"}} 1 +test expr-old-4.11 {string operators} {expr {"abd" <= "abd"}} 1 +test expr-old-4.12 {string operators} {expr {"abe" <= "abd"}} 0 +test expr-old-4.13 {string operators} {expr {"abc" == "abd"}} 0 +test expr-old-4.14 {string operators} {expr {"abd" == "abd"}} 1 +test expr-old-4.15 {string operators} {expr {"abc" != "abd"}} 1 +test expr-old-4.16 {string operators} {expr {"abd" != "abd"}} 0 +test expr-old-4.17 {string operators} {expr {"0y" < "0x12"}} 0 +test expr-old-4.18 {string operators} {expr {"." < " "}} 0 + +# The following tests are non-portable because on some systems "+" +# and "-" can be parsed as numbers. + +test expr-old-4.19 {string operators} {nonPortable} {expr {"0" == "+"}} 0 +test expr-old-4.20 {string operators} {nonPortable} {expr {"0" == "-"}} 0 +test expr-old-4.21 {string operators} {expr {1?"foo":"bar"}} foo +test expr-old-4.22 {string operators} {expr {0?"foo":"bar"}} bar + +# Operators that aren't legal on string operands. + +test expr-old-5.1 {illegal string operations} { + list [catch {expr {-"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "-"}} +test expr-old-5.2 {illegal string operations} { + list [catch {expr {+"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-old-5.3 {illegal string operations} { + list [catch {expr {~"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "~"}} +test expr-old-5.4 {illegal string operations} { + list [catch {expr {!"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "!"}} +test expr-old-5.5 {illegal string operations} { + list [catch {expr {"a"*"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "*"}} +test expr-old-5.6 {illegal string operations} { + list [catch {expr {"a"/"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "/"}} +test expr-old-5.7 {illegal string operations} { + list [catch {expr {"a"%"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "%"}} +test expr-old-5.8 {illegal string operations} { + list [catch {expr {"a"+"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-old-5.9 {illegal string operations} { + list [catch {expr {"a"-"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "-"}} +test expr-old-5.10 {illegal string operations} { + list [catch {expr {"a"<<"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "<<"}} +test expr-old-5.11 {illegal string operations} { + list [catch {expr {"a">>"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of ">>"}} +test expr-old-5.12 {illegal string operations} { + list [catch {expr {"a"&"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "&"}} +test expr-old-5.13 {illegal string operations} { + list [catch {expr {"a"^"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "^"}} +test expr-old-5.14 {illegal string operations} { + list [catch {expr {"a"|"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "|"}} +test expr-old-5.15 {illegal string operations} { + list [catch {expr {"a"&&"b"}} msg] $msg +} {1 {expected boolean value but got "a"}} +test expr-old-5.16 {illegal string operations} { + list [catch {expr {"a"||"b"}} msg] $msg +} {1 {expected boolean value but got "a"}} +test expr-old-5.17 {illegal string operations} { + list [catch {expr {"a"?4:2}} msg] $msg +} {1 {expected boolean value but got "a"}} + +# Check precedence pairwise. + +test expr-old-6.1 {precedence checks} {expr -~3} 4 +test expr-old-6.2 {precedence checks} {expr -!3} 0 +test expr-old-6.3 {precedence checks} {expr -~0} 1 + +test expr-old-7.1 {precedence checks} {expr 2*4/6} 1 +test expr-old-7.2 {precedence checks} {expr 24/6*3} 12 +test expr-old-7.3 {precedence checks} {expr 24/6/2} 2 + +test expr-old-8.1 {precedence checks} {expr -2+4} 2 +test expr-old-8.2 {precedence checks} {expr -2-4} -6 +test expr-old-8.3 {precedence checks} {expr +2-4} -2 + +test expr-old-9.1 {precedence checks} {expr 2*3+4} 10 +test expr-old-9.2 {precedence checks} {expr 8/2+4} 8 +test expr-old-9.3 {precedence checks} {expr 8%3+4} 6 +test expr-old-9.4 {precedence checks} {expr 2*3-1} 5 +test expr-old-9.5 {precedence checks} {expr 8/2-1} 3 +test expr-old-9.6 {precedence checks} {expr 8%3-1} 1 + +test expr-old-10.1 {precedence checks} {expr 6-3-2} 1 + +test expr-old-11.1 {precedence checks} {expr 7+1>>2} 2 +test expr-old-11.2 {precedence checks} {expr 7+1<<2} 32 +test expr-old-11.3 {precedence checks} {expr 7>>3-2} 3 +test expr-old-11.4 {precedence checks} {expr 7<<3-2} 14 + +test expr-old-12.1 {precedence checks} {expr 6>>1>4} 0 +test expr-old-12.2 {precedence checks} {expr 6>>1<2} 0 +test expr-old-12.3 {precedence checks} {expr 6>>1>=3} 1 +test expr-old-12.4 {precedence checks} {expr 6>>1<=2} 0 +test expr-old-12.5 {precedence checks} {expr 6<<1>5} 1 +test expr-old-12.6 {precedence checks} {expr 6<<1<5} 0 +test expr-old-12.7 {precedence checks} {expr 5<=6<<1} 1 +test expr-old-12.8 {precedence checks} {expr 5>=6<<1} 0 + +test expr-old-13.1 {precedence checks} {expr 2<3<4} 1 +test expr-old-13.2 {precedence checks} {expr 0<4>2} 0 +test expr-old-13.3 {precedence checks} {expr 4>2<1} 0 +test expr-old-13.4 {precedence checks} {expr 4>3>2} 0 +test expr-old-13.5 {precedence checks} {expr 4>3>=2} 0 +test expr-old-13.6 {precedence checks} {expr 4>=3>2} 0 +test expr-old-13.7 {precedence checks} {expr 4>=3>=2} 0 +test expr-old-13.8 {precedence checks} {expr 0<=4>=2} 0 +test expr-old-13.9 {precedence checks} {expr 4>=2<=0} 0 +test expr-old-13.10 {precedence checks} {expr 2<=3<=4} 1 + +test expr-old-14.1 {precedence checks} {expr 1==4>3} 1 +test expr-old-14.2 {precedence checks} {expr 0!=4>3} 1 +test expr-old-14.3 {precedence checks} {expr 1==3<4} 1 +test expr-old-14.4 {precedence checks} {expr 0!=3<4} 1 +test expr-old-14.5 {precedence checks} {expr 1==4>=3} 1 +test expr-old-14.6 {precedence checks} {expr 0!=4>=3} 1 +test expr-old-14.7 {precedence checks} {expr 1==3<=4} 1 +test expr-old-14.8 {precedence checks} {expr 0!=3<=4} 1 + +test expr-old-15.1 {precedence checks} {expr 1==3==3} 0 +test expr-old-15.2 {precedence checks} {expr 3==3!=2} 1 +test expr-old-15.3 {precedence checks} {expr 2!=3==3} 0 +test expr-old-15.4 {precedence checks} {expr 2!=1!=1} 0 + +test expr-old-16.1 {precedence checks} {expr 2&3==2} 0 +test expr-old-16.2 {precedence checks} {expr 1&3!=3} 0 + +test expr-old-17.1 {precedence checks} {expr 7&3^0x10} 19 +test expr-old-17.2 {precedence checks} {expr 7^0x10&3} 7 + +test expr-old-18.1 {precedence checks} {expr 7^0x10|3} 23 +test expr-old-18.2 {precedence checks} {expr 7|0x10^3} 23 + +test expr-old-19.1 {precedence checks} {expr 7|3&&1} 1 +test expr-old-19.2 {precedence checks} {expr 1&&3|7} 1 +test expr-old-19.3 {precedence checks} {expr 0&&1||1} 1 +test expr-old-19.4 {precedence checks} {expr 1||1&&0} 1 + +test expr-old-20.1 {precedence checks} {expr 1||0?3:4} 3 +test expr-old-20.2 {precedence checks} {expr 1?0:4||1} 0 +test expr-old-20.3 {precedence checks} {expr 1?2:0?3:4} 2 +test expr-old-20.4 {precedence checks} {expr 0?2:0?3:4} 4 +test expr-old-20.5 {precedence checks} {expr 1?2?3:4:0} 3 +test expr-old-20.6 {precedence checks} {expr 0?2?3:4:0} 0 + +# Parentheses. + +test expr-old-21.1 {parenthesization} {expr (2+4)*6} 36 +test expr-old-21.2 {parenthesization} {expr (1?0:4)||1} 1 +test expr-old-21.3 {parenthesization} {expr +(3-4)} -1 + +# Embedded commands and variable names. + +set a 16 +test expr-old-22.1 {embedded variables} {expr {2*$a}} 32 +test expr-old-22.2 {embedded variables} { + set x -5 + set y 10 + expr {$x + $y} +} {5} +test expr-old-22.3 {embedded variables} { + set x " -5" + set y " +10" + expr {$x + $y} +} {5} +test expr-old-22.4 {embedded commands and variables} {expr {[set a] - 14}} 2 +test expr-old-22.5 {embedded commands and variables} { + list [catch {expr {12 - [bad_command_name]}} msg] $msg +} {1 {invalid command name "bad_command_name"}} + +# Double-quotes and things inside them. + +test expr-old-23.1 {double quotes} {expr {"abc"}} abc +test expr-old-23.2 {double quotes} { + set a 189 + expr {"$a.bc"} +} 189.bc +test expr-old-23.3 {double quotes} { + set b2 xyx + expr {"$b2$b2$b2.[set b2].[set b2]"} +} xyxxyxxyx.xyx.xyx +test expr-old-23.4 {double quotes} {expr {"11\}\}22"}} 11}}22 +test expr-old-23.5 {double quotes} {expr {"\*bc"}} {*bc} +test expr-old-23.6 {double quotes} { + catch {unset bogus__} + list [catch {expr {"$bogus__"}} msg] $msg +} {1 {can't read "bogus__": no such variable}} +test expr-old-23.7 {double quotes} { + list [catch {expr {"a[error Testing]bc"}} msg] $msg +} {1 Testing} +test expr-old-23.8 {double quotes} { + list [catch {expr {"12398712938788234-1298379" != ""}} msg] $msg +} {0 1} + +# Numbers in various bases. + +test expr-old-24.1 {numbers in different bases} {expr 0x20} 32 +test expr-old-24.2 {numbers in different bases} {expr 015} 13 + +# Conversions between various data types. + +test expr-old-25.1 {type conversions} {expr 2+2.5} 4.5 +test expr-old-25.2 {type conversions} {expr 2.5+2} 4.5 +test expr-old-25.3 {type conversions} {expr 2-2.5} -0.5 +test expr-old-25.4 {type conversions} {format %.6g [expr 2/2.5]} 0.8 +test expr-old-25.5 {type conversions} {expr 2>2.5} 0 +test expr-old-25.6 {type conversions} {expr 2.5>2} 1 +test expr-old-25.7 {type conversions} {expr 2<2.5} 1 +test expr-old-25.8 {type conversions} {expr 2>=2.5} 0 +test expr-old-25.9 {type conversions} {expr 2<=2.5} 1 +test expr-old-25.10 {type conversions} {expr 2==2.5} 0 +test expr-old-25.11 {type conversions} {expr 2!=2.5} 1 +test expr-old-25.12 {type conversions} {expr 2>"ab"} 0 +test expr-old-25.13 {type conversions} {expr {2>" "}} 1 +test expr-old-25.14 {type conversions} {expr {"24.1a" > 24.1}} 1 +test expr-old-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0 +test expr-old-25.16 {type conversions} {expr 2+2.5} 4.5 +test expr-old-25.17 {type conversions} {expr 2+2.5} 4.5 +test expr-old-25.18 {type conversions} {expr 2.0e2} 200.0 +test expr-old-25.19 {type conversions} {format %.6g [expr 2.0e15]} 2e+15 +test expr-old-25.20 {type conversions} {expr 10.0} 10.0 + +# Various error conditions. + +test expr-old-26.1 {error conditions} { + list [catch {expr 2+"a"} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-old-26.2 {error conditions} { + list [catch {expr 2+4*} msg] $msg +} {1 {syntax error in expression "2+4*"}} +test expr-old-26.3 {error conditions} { + list [catch {expr 2+4*(} msg] $msg +} {1 {syntax error in expression "2+4*("}} +catch {unset _non_existent_} +test expr-old-26.4 {error conditions} { + list [catch {expr 2+$_non_existent_} msg] $msg +} {1 {can't read "_non_existent_": no such variable}} +set a xx +test expr-old-26.5 {error conditions} { + list [catch {expr {2+$a}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-old-26.6 {error conditions} { + list [catch {expr {2+[set a]}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-old-26.7 {error conditions} { + list [catch {expr {2+(4}} msg] $msg +} {1 {syntax error in expression "2+(4"}} +test expr-old-26.8 {error conditions} { + list [catch {expr 2/0} msg] $msg $errorCode +} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} +test expr-old-26.9 {error conditions} { + list [catch {expr 2%0} msg] $msg $errorCode +} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} +test expr-old-26.10 {error conditions} { + list [catch {expr 2.0/0.0} msg] $msg $errorCode +} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} +test expr-old-26.11 {error conditions} { + list [catch {expr 2#} msg] $msg +} {1 {syntax error in expression "2#"}} +test expr-old-26.12 {error conditions} { + list [catch {expr a.b} msg] $msg +} {1 {syntax error in expression "a.b"}} +test expr-old-26.13 {error conditions} { + list [catch {expr {"a"/"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "/"}} +test expr-old-26.14 {error conditions} { + list [catch {expr 2:3} msg] $msg +} {1 {syntax error in expression "2:3"}} +test expr-old-26.15 {error conditions} { + list [catch {expr a@b} msg] $msg +} {1 {syntax error in expression "a@b"}} +test expr-old-26.16 {error conditions} { + list [catch {expr a[b} msg] $msg +} {1 {missing close-bracket or close-brace}} +test expr-old-26.17 {error conditions} { + list [catch {expr a`b} msg] $msg +} {1 {syntax error in expression "a`b"}} +test expr-old-26.18 {error conditions} { + list [catch {expr \"a\"\{b} msg] $msg +} {1 {missing close-brace}} +test expr-old-26.19 {error conditions} { + list [catch {expr a} msg] $msg +} {1 {syntax error in expression "a"}} +test expr-old-26.20 {error conditions} { + list [catch expr msg] $msg +} {1 {wrong # args: should be "expr arg ?arg ...?"}} + +# Cancelled evaluation. + +test expr-old-27.1 {cancelled evaluation} { + set a 1 + expr {0&&[set a 2]} + set a +} 1 +test expr-old-27.2 {cancelled evaluation} { + set a 1 + expr {1||[set a 2]} + set a +} 1 +test expr-old-27.3 {cancelled evaluation} { + set a 1 + expr {0?[set a 2]:1} + set a +} 1 +test expr-old-27.4 {cancelled evaluation} { + set a 1 + expr {1?2:[set a 2]} + set a +} 1 +catch {unset x} +test expr-old-27.5 {cancelled evaluation} { + list [catch {expr {[info exists x] && $x}} msg] $msg +} {0 0} +test expr-old-27.6 {cancelled evaluation} { + list [catch {expr {0 && [concat $x]}} msg] $msg +} {0 0} +test expr-old-27.7 {cancelled evaluation} { + set one 1 + list [catch {expr {1 || 1/$one}} msg] $msg +} {0 1} +test expr-old-27.8 {cancelled evaluation} { + list [catch {expr {1 || -"string"}} msg] $msg +} {0 1} +test expr-old-27.9 {cancelled evaluation} { + list [catch {expr {1 || ("string" * ("x" && "y"))}} msg] $msg +} {0 1} +test expr-old-27.10 {cancelled evaluation} { + set x -1.0 + list [catch {expr {($x > 0) ? round(log($x)) : 0}} msg] $msg +} {0 0} +test expr-old-27.11 {cancelled evaluation} { + list [catch {expr {0 && foo}} msg] $msg +} {1 {syntax error in expression "0 && foo"}} +test expr-old-27.12 {cancelled evaluation} { + list [catch {expr {0 ? 1 : foo}} msg] $msg +} {1 {syntax error in expression "0 ? 1 : foo"}} + +# Tcl_ExprBool as used in "if" statements + +test expr-old-28.1 {Tcl_ExprBoolean usage} { + set a 1 + if {2} {set a 2} + set a +} 2 +test expr-old-28.2 {Tcl_ExprBoolean usage} { + set a 1 + if {0} {set a 2} + set a +} 1 +test expr-old-28.3 {Tcl_ExprBoolean usage} { + set a 1 + if {1.2} {set a 2} + set a +} 2 +test expr-old-28.4 {Tcl_ExprBoolean usage} { + set a 1 + if {-1.1} {set a 2} + set a +} 2 +test expr-old-28.5 {Tcl_ExprBoolean usage} { + set a 1 + if {0.0} {set a 2} + set a +} 1 +test expr-old-28.6 {Tcl_ExprBoolean usage} { + set a 1 + if {"YES"} {set a 2} + set a +} 2 +test expr-old-28.7 {Tcl_ExprBoolean usage} { + set a 1 + if {"no"} {set a 2} + set a +} 1 +test expr-old-28.8 {Tcl_ExprBoolean usage} { + set a 1 + if {"true"} {set a 2} + set a +} 2 +test expr-old-28.9 {Tcl_ExprBoolean usage} { + set a 1 + if {"fAlse"} {set a 2} + set a +} 1 +test expr-old-28.10 {Tcl_ExprBoolean usage} { + set a 1 + if {"on"} {set a 2} + set a +} 2 +test expr-old-28.11 {Tcl_ExprBoolean usage} { + set a 1 + if {"Off"} {set a 2} + set a +} 1 +test expr-old-28.12 {Tcl_ExprBool usage} { + list [catch {if {"abc"} {}} msg] $msg +} {1 {expected boolean value but got "abc"}} +test expr-old-28.13 {Tcl_ExprBool usage} { + list [catch {if {"ogle"} {}} msg] $msg +} {1 {expected boolean value but got "ogle"}} +test expr-old-28.14 {Tcl_ExprBool usage} { + list [catch {if {"o"} {}} msg] $msg +} {1 {expected boolean value but got "o"}} + +# Operands enclosed in braces + +test expr-old-29.1 {braces} {expr {{abc}}} abc +test expr-old-29.2 {braces} {expr {{00010}}} 8 +test expr-old-29.3 {braces} {format %.6g [expr {{3.1200000}}]} 3.12 +test expr-old-29.4 {braces} {expr {{a{b}{1 {2 3}}c}}} "a{b}{1 {2 3}}c" +test expr-old-29.5 {braces} { + list [catch {expr "\{abc"} msg] $msg +} {1 {missing close-brace}} + +# Very long values + +test expr-old-30.1 {long values} { + set a "0000 1111 2222 3333 4444" + set a "$a | $a | $a | $a | $a" + set a "$a || $a || $a || $a || $a" + expr {$a} +} {0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444} +test expr-old-30.2 {long values} { + set a "000000000000000000000000000000" + set a "$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a${a}5" + expr $a +} 5 + +# Expressions spanning multiple arguments + +test expr-old-31.1 {multiple arguments to expr command} { + expr 4 + ( 6 *12) -3 +} 73 +test expr-old-31.2 {multiple arguments to expr command} { + list [catch {expr 2 + (3 + 4} msg] $msg +} {1 {syntax error in expression "2 + (3 + 4"}} +test expr-old-31.3 {multiple arguments to expr command} { + list [catch {expr 2 + 3 +} msg] $msg +} {1 {syntax error in expression "2 + 3 +"}} +test expr-old-31.4 {multiple arguments to expr command} { + list [catch {expr 2 + 3 )} msg] $msg +} {1 {syntax error in expression "2 + 3 )"}} + +# Math functions + +test expr-old-32.1 {math functions in expressions} { + format %.6g [expr acos(0.5)] +} {1.0472} +test expr-old-32.2 {math functions in expressions} { + format %.6g [expr asin(0.5)] +} {0.523599} +test expr-old-32.3 {math functions in expressions} { + format %.6g [expr atan(1.0)] +} {0.785398} +test expr-old-32.4 {math functions in expressions} { + format %.6g [expr atan2(2.0, 2.0)] +} {0.785398} +test expr-old-32.5 {math functions in expressions} { + format %.6g [expr ceil(1.999)] +} {2} +test expr-old-32.6 {math functions in expressions} { + format %.6g [expr cos(.1)] +} {0.995004} +test expr-old-32.7 {math functions in expressions} { + format %.6g [expr cosh(.1)] +} {1.005} +test expr-old-32.8 {math functions in expressions} { + format %.6g [expr exp(1.0)] +} {2.71828} +test expr-old-32.9 {math functions in expressions} { + format %.6g [expr floor(2.000)] +} {2} +test expr-old-32.10 {math functions in expressions} { + format %.6g [expr floor(2.001)] +} {2} +test expr-old-32.11 {math functions in expressions} { + format %.6g [expr fmod(7.3, 3.2)] +} {0.9} +test expr-old-32.12 {math functions in expressions} { + format %.6g [expr hypot(3.0, 4.0)] +} {5} +test expr-old-32.13 {math functions in expressions} { + format %.6g [expr log(2.8)] +} {1.02962} +test expr-old-32.14 {math functions in expressions} { + format %.6g [expr log10(2.8)] +} {0.447158} +test expr-old-32.15 {math functions in expressions} { + format %.6g [expr pow(2.1, 3.1)] +} {9.97424} +test expr-old-32.16 {math functions in expressions} { + format %.6g [expr sin(.1)] +} {0.0998334} +test expr-old-32.17 {math functions in expressions} { + format %.6g [expr sinh(.1)] +} {0.100167} +test expr-old-32.18 {math functions in expressions} { + format %.6g [expr sqrt(2.0)] +} {1.41421} +test expr-old-32.19 {math functions in expressions} { + format %.6g [expr tan(0.8)] +} {1.02964} +test expr-old-32.20 {math functions in expressions} { + format %.6g [expr tanh(0.8)] +} {0.664037} +test expr-old-32.21 {math functions in expressions} { + format %.6g [expr abs(-1.8)] +} {1.8} +test expr-old-32.22 {math functions in expressions} { + expr abs(10.0) +} {10.0} +test expr-old-32.23 {math functions in expressions} { + format %.6g [expr abs(-4)] +} {4} +test expr-old-32.24 {math functions in expressions} { + format %.6g [expr abs(66)] +} {66} +test expr-old-32.25 {math functions in expressions} {nonPortable} { + list [catch {expr abs(0x80000000)} msg] $msg +} {1 {integer value too large to represent}} +test expr-old-32.26 {math functions in expressions} { + expr double(1) +} {1.0} +test expr-old-32.27 {math functions in expressions} { + format %.6g [expr double(1.1)] +} {1.1} +test expr-old-32.28 {math functions in expressions} { + expr int(1) +} {1} +test expr-old-32.29 {math functions in expressions} { + expr int(1.4) +} {1} +test expr-old-32.30 {math functions in expressions} { + expr int(1.6) +} {1} +test expr-old-32.31 {math functions in expressions} { + expr int(-1.4) +} {-1} +test expr-old-32.32 {math functions in expressions} { + expr int(-1.6) +} {-1} +test expr-old-32.33 {math functions in expressions} { + list [catch {expr int(1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-old-32.34 {math functions in expressions} { + list [catch {expr int(-1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-old-32.35 {math functions in expressions} { + expr round(1.49) +} {1} +test expr-old-32.36 {math functions in expressions} { + expr round(1.51) +} {2} +test expr-old-32.37 {math functions in expressions} { + expr round(-1.49) +} {-1} +test expr-old-32.38 {math functions in expressions} { + expr round(-1.51) +} {-2} +test expr-old-32.39 {math functions in expressions} { + list [catch {expr round(1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-old-32.40 {math functions in expressions} { + list [catch {expr round(-1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-old-32.41 {math functions in expressions} { + list [catch {expr pow(1.0 + 3.0 - 2, .8 * 5)} msg] $msg +} {0 16.0} +test expr-old-32.42 {math functions in expressions} { + list [catch {expr hypot(5*.8,3)} msg] $msg +} {0 5.0} +if $gotT1 { + test expr-old-32.43 {math functions in expressions} { + expr 2*T1() + } 246 + test expr-old-32.44 {math functions in expressions} { + expr T2()*3 + } 1035 +} +test expr-old-32.45 {math functions in expressions} { + expr (0 <= rand()) && (rand() < 1) +} {1} +test expr-old-32.46 {math functions in expressions} { + list [catch {expr rand(24)} msg] $msg +} {1 {syntax error in expression "rand(24)"}} +test expr-old-32.47 {math functions in expressions} { + list [catch {expr srand()} msg] $msg +} {1 {syntax error in expression "srand()"}} +test expr-old-32.48 {math functions in expressions} { + list [catch {expr srand(3.79)} msg] $msg +} {1 {can't use floating-point value as argument to srand}} +test expr-old-32.49 {math functions in expressions} { + list [catch {expr srand("")} msg] $msg +} {1 {can't use non-numeric string as argument to srand}} +test expr-old-32.50 {math functions in expressions} { + set result [expr round(srand(12345) * 1000)] + for {set i 0} {$i < 10} {incr i} { + lappend result [expr round(rand() * 1000)] + } + set result +} {97 834 948 36 12 51 766 585 914 784 333} +test expr-old-32.51 {math functions in expressions} { + list [catch {expr {srand([lindex "6ty" 0])}} msg] $msg +} {1 {can't use non-numeric string as argument to srand}} + +test expr-old-33.1 {conversions and fancy args to math functions} { + expr hypot ( 3 , 4 ) +} 5.0 +test expr-old-33.2 {conversions and fancy args to math functions} { + expr hypot ( (2.0+1.0) , 4 ) +} 5.0 +test expr-old-33.3 {conversions and fancy args to math functions} { + expr hypot ( 3 , (3.0 + 1.0) ) +} 5.0 +test expr-old-33.4 {conversions and fancy args to math functions} { + format %.6g [expr cos(acos(0.1))] +} 0.1 + +test expr-old-34.1 {errors in math functions} { + list [catch {expr func_2(1.0)} msg] $msg +} {1 {unknown math function "func_2"}} +test expr-old-34.2 {errors in math functions} { + list [catch {expr func|(1.0)} msg] $msg +} {1 {syntax error in expression "func|(1.0)"}} +test expr-old-34.3 {errors in math functions} { + list [catch {expr {hypot("a b", 2.0)}} msg] $msg +} {1 {argument to math function didn't have numeric value}} +test expr-old-34.4 {errors in math functions} { + list [catch {expr hypot(1.0 2.0)} msg] $msg +} {1 {syntax error in expression "hypot(1.0 2.0)"}} +test expr-old-34.5 {errors in math functions} { + list [catch {expr hypot(1.0, 2.0} msg] $msg +} {1 {syntax error in expression "hypot(1.0, 2.0"}} +test expr-old-34.6 {errors in math functions} { + list [catch {expr hypot(1.0 ,} msg] $msg +} {1 {syntax error in expression "hypot(1.0 ,"}} +test expr-old-34.7 {errors in math functions} { + list [catch {expr hypot(1.0)} msg] $msg +} {1 {too few arguments for math function}} +test expr-old-34.8 {errors in math functions} { + list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg +} {1 {too many arguments for math function}} +test expr-old-34.9 {errors in math functions} { + list [catch {expr acos(-2.0)} msg] $msg $errorCode +} {1 {domain error: argument not in valid range} {ARITH DOMAIN {domain error: argument not in valid range}}} +test expr-old-34.10 {errors in math functions} {nonPortable} { + list [catch {expr pow(-3, 1000001)} msg] $msg $errorCode +} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} +test expr-old-34.11 {errors in math functions} { + list [catch {expr pow(3, 1000001)} msg] $msg $errorCode +} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} +test expr-old-34.12 {errors in math functions} { + list [catch {expr -14.0*exp(100000)} msg] $msg $errorCode +} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} +test expr-old-34.13 {errors in math functions} { + list [catch {expr int(1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test expr-old-34.14 {errors in math functions} { + list [catch {expr int(-1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test expr-old-34.15 {errors in math functions} { + list [catch {expr round(1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test expr-old-34.16 {errors in math functions} { + list [catch {expr round(-1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +if $gotT1 { + test expr-old-34.17 {errors in math functions} { + list [catch {expr T1(4)} msg] $msg + } {1 {syntax error in expression "T1(4)"}} +} + +test expr-old-36.1 {ExprLooksLikeInt procedure} { + list [catch {expr 0289} msg] $msg +} {1 {syntax error in expression "0289"}} +test expr-old-36.2 {ExprLooksLikeInt procedure} { + set x 0289 + list [catch {expr {$x+1}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-old-36.3 {ExprLooksLikeInt procedure} { + list [catch {format %.6g [expr 0289.1]} msg] $msg +} {0 289.1} +test expr-old-36.4 {ExprLooksLikeInt procedure} { + set x 0289.1 + list [catch {format %.6g [expr {$x+1}]} msg] $msg +} {0 290.1} +test expr-old-36.5 {ExprLooksLikeInt procedure} { + set x { +22} + list [catch {expr {$x+1}} msg] $msg +} {0 23} +test expr-old-36.6 {ExprLooksLikeInt procedure} { + set x { -22} + list [catch {expr {$x+1}} msg] $msg +} {0 -21} +test expr-old-36.7 {ExprLooksLikeInt procedure} {nonPortable unixOnly} { + list [catch {expr nan} msg] $msg +} {1 {domain error: argument not in valid range}} +test expr-old-36.8 {ExprLooksLikeInt procedure} { + list [catch {expr 78e1} msg] $msg +} {0 780.0} +test expr-old-36.9 {ExprLooksLikeInt procedure} { + list [catch {expr 24E1} msg] $msg +} {0 240.0} +test expr-old-36.10 {ExprLooksLikeInt procedure} {nonPortable unixOnly} { + list [catch {expr 78e} msg] $msg +} {1 {syntax error in expression "78e"}} + +test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if no error} { + testexprlong +} {This is a result: 5} + + + +# Special test for Pentium arithmetic bug of 1994: + +if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} { + puts "Warning: this machine contains a defective Pentium processor" + puts "that performs arithmetic incorrectly. I recommend that you" + puts "call Intel customer service immediately at 1-800-628-8686" + puts "to request a replacement processor." +} diff --git a/contrib/tcl/tests/expr.test b/contrib/tcl/tests/expr.test index d5dbab58b4790..481e3abd02005 100644 --- a/contrib/tcl/tests/expr.test +++ b/contrib/tcl/tests/expr.test @@ -1,16 +1,15 @@ -# Commands covered: expr +# Commands covered: expr # # 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 +# 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) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1996-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) expr.test 1.48 96/02/16 08:55:51 +# SCCS: @(#) expr.test 1.29 97/06/23 18:46:25 if {[string compare test [info procs test]] == 1} then {source defs} @@ -22,869 +21,616 @@ if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { set gotT1 1 } -# First, test all of the integer operators individually. +# procedures used below -test expr-1.1 {integer operators} {expr -4} -4 -test expr-1.2 {integer operators} {expr -(1+4)} -5 -test expr-1.3 {integer operators} {expr ~3} -4 -test expr-1.4 {integer operators} {expr !2} 0 -test expr-1.5 {integer operators} {expr !0} 1 -test expr-1.6 {integer operators} {expr 4*6} 24 -test expr-1.7 {integer operators} {expr 36/12} 3 -test expr-1.8 {integer operators} {expr 27/4} 6 -test expr-1.9 {integer operators} {expr 27%4} 3 -test expr-1.10 {integer operators} {expr 2+2} 4 -test expr-1.11 {integer operators} {expr 2-6} -4 -test expr-1.12 {integer operators} {expr 1<<3} 8 -test expr-1.13 {integer operators} {expr 0xff>>2} 63 -test expr-1.14 {integer operators} {expr -1>>2} -1 -test expr-1.15 {integer operators} {expr 3>2} 1 -test expr-1.16 {integer operators} {expr 2>2} 0 -test expr-1.17 {integer operators} {expr 1>2} 0 -test expr-1.18 {integer operators} {expr 3<2} 0 -test expr-1.19 {integer operators} {expr 2<2} 0 -test expr-1.20 {integer operators} {expr 1<2} 1 -test expr-1.21 {integer operators} {expr 3>=2} 1 -test expr-1.22 {integer operators} {expr 2>=2} 1 -test expr-1.23 {integer operators} {expr 1>=2} 0 -test expr-1.24 {integer operators} {expr 3<=2} 0 -test expr-1.25 {integer operators} {expr 2<=2} 1 -test expr-1.26 {integer operators} {expr 1<=2} 1 -test expr-1.27 {integer operators} {expr 3==2} 0 -test expr-1.28 {integer operators} {expr 2==2} 1 -test expr-1.29 {integer operators} {expr 3!=2} 1 -test expr-1.30 {integer operators} {expr 2!=2} 0 -test expr-1.31 {integer operators} {expr 7&0x13} 3 -test expr-1.32 {integer operators} {expr 7^0x13} 20 -test expr-1.33 {integer operators} {expr 7|0x13} 23 -test expr-1.34 {integer operators} {expr 0&&1} 0 -test expr-1.35 {integer operators} {expr 0&&0} 0 -test expr-1.36 {integer operators} {expr 1&&3} 1 -test expr-1.37 {integer operators} {expr 0||1} 1 -test expr-1.38 {integer operators} {expr 3||0} 1 -test expr-1.39 {integer operators} {expr 0||0} 0 -test expr-1.40 {integer operators} {expr 3>2?44:66} 44 -test expr-1.41 {integer operators} {expr 2>3?44:66} 66 -test expr-1.42 {integer operators} {expr 36/5} 7 -test expr-1.43 {integer operators} {expr 36%5} 1 -test expr-1.44 {integer operators} {expr -36/5} -8 -test expr-1.45 {integer operators} {expr -36%5} 4 -test expr-1.46 {integer operators} {expr 36/-5} -8 -test expr-1.47 {integer operators} {expr 36%-5} -4 -test expr-1.48 {integer operators} {expr -36/-5} 7 -test expr-1.49 {integer operators} {expr -36%-5} -1 -test expr-1.50 {integer operators} {expr +36} 36 -test expr-1.51 {integer operators} {expr +--++36} 36 -test expr-1.52 {integer operators} {expr +36%+5} 1 - -# Check the floating-point operators individually, along with -# automatic conversion to integers where needed. - -test expr-2.1 {floating-point operators} {expr -4.2} -4.2 -test expr-2.2 {floating-point operators} {expr -(1.1+4.2)} -5.3 -test expr-2.3 {floating-point operators} {expr +5.7} 5.7 -test expr-2.4 {floating-point operators} {expr +--+-62.0} -62.0 -test expr-2.5 {floating-point operators} {expr !2.1} 0 -test expr-2.6 {floating-point operators} {expr !0.0} 1 -test expr-2.7 {floating-point operators} {expr 4.2*6.3} 26.46 -test expr-2.8 {floating-point operators} {expr 36.0/12.0} 3.0 -test expr-2.9 {floating-point operators} {expr 27/4.0} 6.75 -test expr-2.10 {floating-point operators} {expr 2.3+2.1} 4.4 -test expr-2.11 {floating-point operators} {expr 2.3-6.5} -4.2 -test expr-2.12 {floating-point operators} {expr 3.1>2.1} 1 -test expr-2.13 {floating-point operators} {expr {2.1 > 2.1}} 0 -test expr-2.14 {floating-point operators} {expr 1.23>2.34e+1} 0 -test expr-2.15 {floating-point operators} {expr 3.45<2.34} 0 -test expr-2.16 {floating-point operators} {expr 0.002e3<--200e-2} 0 -test expr-2.17 {floating-point operators} {expr 1.1<2.1} 1 -test expr-2.18 {floating-point operators} {expr 3.1>=2.2} 1 -test expr-2.19 {floating-point operators} {expr 2.345>=2.345} 1 -test expr-2.20 {floating-point operators} {expr 1.1>=2.2} 0 -test expr-2.21 {floating-point operators} {expr 3.0<=2.0} 0 -test expr-2.22 {floating-point operators} {expr 2.2<=2.2} 1 -test expr-2.23 {floating-point operators} {expr 2.2<=2.2001} 1 -test expr-2.24 {floating-point operators} {expr 3.2==2.2} 0 -test expr-2.25 {floating-point operators} {expr 2.2==2.2} 1 -test expr-2.26 {floating-point operators} {expr 3.2!=2.2} 1 -test expr-2.27 {floating-point operators} {expr 2.2!=2.2} 0 -test expr-2.28 {floating-point operators} {expr 0.0&&0.0} 0 -test expr-2.29 {floating-point operators} {expr 0.0&&1.3} 0 -test expr-2.30 {floating-point operators} {expr 1.3&&0.0} 0 -test expr-2.31 {floating-point operators} {expr 1.3&&3.3} 1 -test expr-2.32 {floating-point operators} {expr 0.0||0.0} 0 -test expr-2.33 {floating-point operators} {expr 0.0||1.3} 1 -test expr-2.34 {floating-point operators} {expr 1.3||0.0} 1 -test expr-2.35 {floating-point operators} {expr 3.3||0.0} 1 -test expr-2.36 {floating-point operators} {expr 3.3>2.3?44.3:66.3} 44.3 -test expr-2.37 {floating-point operators} {expr 2.3>3.3?44.3:66.3} 66.3 -test expr-2.38 {floating-point operators} { - list [catch {expr 028.1 + 09.2} msg] $msg -} {0 37.3} - -# Operators that aren't legal on floating-point numbers +proc put_hello_char {c} { + global a + append a [format %c $c] + return $c +} +proc hello_world {} { + global a + set a "" + set L1 [set l0 [set h_1 [set q 0]]] + for {put_hello_char [expr [put_hello_char [expr [set h 7]*10+2]]+29]} {$l0?[put_hello_char $l0] + :!$h_1} {put_hello_char $ll;expr {$L1==2?[set ll [expr 32+0-0+[set bar 0]]]:0}} {expr {[incr L1]==[expr 1+([string length "abc"]-[string length "abc"])] + ?[set ll [set l0 [expr 54<<1]]]:$ll==108&&$L1<3? + [incr ll [expr 1|1<<1]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]; set l0; set l0 $l0; set l0; set l0]:$L1==4&&$ll==32?[set ll [expr 19+$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+[set foo [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]]]] + :[set q [expr $q-$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]};expr {$L1==5?[incr ll -8; set ll $ll; set ll]:$q&&$h1&&1};expr {$L1==4+2 + ?[incr ll 3]:[expr ([string length "abc"]-[string length "abc"])+1]};expr {$ll==($h<<4)+2+0&&$L1!=6?[incr ll -6]:[set h1 [expr 100+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]} + expr {$L1!=1<<3?[incr q [expr ([string length "abc"]-[string length "abc"])-1]]:[set h_1 [set ll $h1]]} + } + set a +} -test expr-3.1 {illegal floating-point operations} { - list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value as operand of "~"}} -test expr-3.2 {illegal floating-point operations} { - list [catch {expr 27%4.0} msg] $msg -} {1 {can't use floating-point value as operand of "%"}} -test expr-3.3 {illegal floating-point operations} { - list [catch {expr 27.0%4} msg] $msg -} {1 {can't use floating-point value as operand of "%"}} -test expr-3.4 {illegal floating-point operations} { - list [catch {expr 1.0<<3} msg] $msg -} {1 {can't use floating-point value as operand of "<<"}} -test expr-3.5 {illegal floating-point operations} { - list [catch {expr 3<<1.0} msg] $msg -} {1 {can't use floating-point value as operand of "<<"}} -test expr-3.6 {illegal floating-point operations} { - list [catch {expr 24.0>>3} msg] $msg -} {1 {can't use floating-point value as operand of ">>"}} -test expr-3.7 {illegal floating-point operations} { - list [catch {expr 24>>3.0} msg] $msg -} {1 {can't use floating-point value as operand of ">>"}} -test expr-3.8 {illegal floating-point operations} { - list [catch {expr 24&3.0} msg] $msg -} {1 {can't use floating-point value as operand of "&"}} -test expr-3.9 {illegal floating-point operations} { - list [catch {expr 24.0|3} msg] $msg -} {1 {can't use floating-point value as operand of "|"}} -test expr-3.10 {illegal floating-point operations} { - list [catch {expr 24.0^3} msg] $msg -} {1 {can't use floating-point value as operand of "^"}} +proc 12days {a b c} { + global xxx + expr {1<$a?[expr {$a<3?[12days -79 -13 [string range $c [12days -87 \ + [expr 1-$b] [string range $c [12days -86 0 [string range $c 1 end]] \ + end]] end]]:1};expr {$a<$b?[12days [expr $a+1] $b $c]:3};expr {[12days \ + -94 [expr $a-27] $c]&&$a==2?$b<13?[12days 2 [expr $b+1] "%s %d %d\n"]:9 + :16}]:$a<0?$a<-72?[12days $b $a "@n'+,#'/*\{\}w+/w#cdnr/+,\{\}r/*de\}+,/*\{*+,/w\{%+,/w#q#n+,/#\{l+,/n\{n+,/+#n+,/#;#q#n+,/+k#;*+,/'r :'d*'3,\}\{w+K w'K:'+\}e#';dq#'l q#'+d'K#!/+k#;q#'r\}eKK#\}w'r\}eKK\{nl\]'/#;#q#n')\{)#\}w')\{)\{nl\]'/+#n';d\}rw' i;# )\{nl\]!/n\{n#'; r\{#w'r nc\{nl\]'/#\{l,+'K \{rw' iK\{;\[\{nl\]'/w#q#n'wk nw' iwk\{KK\{nl\]!/w\{%'l##w#' i; :\{nl\]'/*\{q#'ld;r'\}\{nlwb!/*de\}'c ;;\{nl'-\{\}rw\]'/+,\}##'*\}#nc,',#nw\]'/+kd'+e\}+;#'rdq#w! nr'/ ') \}+\}\{rl#'\{n' ')# \}'+\}##(!!/"] + :$a<-50?[string compare [format %c $b] [string index $c 0]]==0?[append \ + xxx [string index $c 31];scan [string index $c 31] %c x;set x] + :[12days -65 $b [string range $c 1 end]]:[12days [expr ([string compare \ + [string index $c 0] "/"]==0)+$a] $b [string range $c 1 end]]:0<$a + ?[12days 2 2 "%s"]:[string compare [string index $c 0] "/"]==0|| + [12days 0 [12days -61 [scan [string index $c 0] %c x; set x] \ + "!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \ + [string range $c 1 end]]} +} +proc do_twelve_days {} { + global xxx + set xxx "" + 12days 1 1 1 + string length $xxx +} -# Check the string operators individually. +# start of tests -test expr-4.1 {string operators} {expr {"abc" > "def"}} 0 -test expr-4.2 {string operators} {expr {"def" > "def"}} 0 -test expr-4.3 {string operators} {expr {"g" > "def"}} 1 -test expr-4.4 {string operators} {expr {"abc" < "abd"}} 1 -test expr-4.5 {string operators} {expr {"abd" < "abd"}} 0 -test expr-4.6 {string operators} {expr {"abe" < "abd"}} 0 -test expr-4.7 {string operators} {expr {"abc" >= "def"}} 0 -test expr-4.8 {string operators} {expr {"def" >= "def"}} 1 -test expr-4.9 {string operators} {expr {"g" >= "def"}} 1 -test expr-4.10 {string operators} {expr {"abc" <= "abd"}} 1 -test expr-4.11 {string operators} {expr {"abd" <= "abd"}} 1 -test expr-4.12 {string operators} {expr {"abe" <= "abd"}} 0 -test expr-4.13 {string operators} {expr {"abc" == "abd"}} 0 -test expr-4.14 {string operators} {expr {"abd" == "abd"}} 1 -test expr-4.15 {string operators} {expr {"abc" != "abd"}} 1 -test expr-4.16 {string operators} {expr {"abd" != "abd"}} 0 -test expr-4.17 {string operators} {expr {"0y" < "0x12"}} 1 -test expr-4.18 {string operators} {expr {"." < " "}} 0 +catch {unset a b i x} -# The following tests are non-portable because on some systems "+" -# and "-" can be parsed as numbers. +test expr-1.1 {TclCompileExprCmd: no expression} { + list [catch {expr } msg] $msg +} {1 {wrong # args: should be "expr arg ?arg ...?"}} +test expr-1.2 {TclCompileExprCmd: one expression word} { + expr -25 +} -25 +test expr-1.3 {TclCompileExprCmd: two expression words} { + format %.6g [expr -8.2 -6] +} -14.2 +test expr-1.4 {TclCompileExprCmd: five expression words} { + expr 20 - 5 +10 -7 +} 18 +test expr-1.5 {TclCompileExprCmd: quoted expression word} { + expr "0005" +} 5 +test expr-1.6 {TclCompileExprCmd: quoted expression word} { + catch {expr "0005"zxy} msg + set msg +} {quoted string doesn't terminate properly} +test expr-1.7 {TclCompileExprCmd: expression word in braces} { + expr {-0005} +} -5 +test expr-1.8 {TclCompileExprCmd: expression word in braces} { + expr {{-0x1234}} +} -4660 +test expr-1.9 {TclCompileExprCmd: expression word in braces} { + catch {expr {-0005}foo} msg + set msg +} {argument word in braces doesn't terminate properly} +test expr-1.10 {TclCompileExprCmd: other expression word in braces} { + expr 4*[llength "6 2"] +} 8 +test expr-1.11 {TclCompileExprCmd: expression word terminated by ;} { + expr 4*[llength "6 2"]; +} 8 +test expr-1.12 {TclCompileExprCmd: inlined expr (in "catch") inside other catch} { + set a xxx + catch { + # Might not be a number + set a [expr 10*$a] + } +} 1 +test expr-1.13 {TclCompileExprCmd: second level of substitutions in expr not in braces with single var reference} { + set a xxx + set x 27; set bool {$x}; if $bool {set a foo} + set a +} foo + +test expr-2.1 {TclCompileExpr: are builtin functions registered?} { + expr double(5*[llength "6 2"]) +} 10.0 +test expr-2.2 {TclCompileExpr: error in expr} { + catch {expr 2**3} msg + set msg +} {syntax error in expression "2**3"} +test expr-2.3 {TclCompileExpr: junk after legal expr} { + catch {expr 7*[llength "a b"]foo} msg + set msg +} {syntax error in expression "7*2foo"} +test expr-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} { + expr {0001} +} 1 -test expr-4.19 {string operators} {nonPortable} {expr {"0" == "+"}} 0 -test expr-4.20 {string operators} {nonPortable} {expr {"0" == "-"}} 0 -test expr-4.21 {string operators} {expr {1?"foo":"bar"}} foo -test expr-4.22 {string operators} {expr {0?"foo":"bar"}} bar +test expr-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1 +test expr-3.2 {CompileCondExpr: error in lor expr} { + catch {expr x||3} msg + set msg +} {syntax error in expression "x||3"} +test expr-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44 +test expr-3.4 {CompileCondExpr: error compiling true arm} { + catch {expr 3>2?2**3:66} msg + set msg +} {syntax error in expression "3>2?2**3:66"} +test expr-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66 +test expr-3.6 {CompileCondExpr: error compiling false arm} { + catch {expr 2>3?44:2**3} msg + set msg +} {syntax error in expression "2>3?44:2**3"} +test expr-3.7 {CompileCondExpr: long arms & nested cond exprs} {unixOnly nonPortable} { + puts "Note: doing test expr-3.7 which can take several minutes to run" + hello_world +} {Hello world} +catch {unset xxx} +test expr-3.8 {CompileCondExpr: long arms & nested cond exprs} {unixOnly nonPortable} { + puts "Note: doing test expr-3.8 which can take several minutes to run" + do_twelve_days +} 2358 +catch {unset xxx} + +test expr-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1 +test expr-4.2 {CompileLorExpr: error in land expr} { + catch {expr x&&3} msg + set msg +} {syntax error in expression "x&&3"} +test expr-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1 +test expr-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1 +test expr-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1 +test expr-4.6 {CompileLorExpr: error compiling lor arm} { + catch {expr 2**3||4.0} msg + set msg +} {syntax error in expression "2**3||4.0"} +test expr-4.7 {CompileLorExpr: error compiling lor arm} { + catch {expr 1.3||2**3} msg + set msg +} {syntax error in expression "1.3||2**3"} +test expr-4.8 {CompileLorExpr: error compiling lor arms} { + list [catch {expr {"a"||"b"}} msg] $msg +} {1 {expected boolean value but got "a"}} +test expr-4.9 {CompileLorExpr: long lor arm} { + set a "abcdefghijkl" + set i 7 + expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} +} 1 -# Operators that aren't legal on string operands. +test expr-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23 +test expr-5.2 {CompileLandExpr: error in bitor expr} { + catch {expr x|3} msg + set msg +} {syntax error in expression "x|3"} +test expr-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0 +test expr-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0 +test expr-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1 +test expr-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1 +test expr-5.7 {CompileLandExpr: error compiling land arm} { + catch {expr 2**3&&4.0} msg + set msg +} {syntax error in expression "2**3&&4.0"} +test expr-5.8 {CompileLandExpr: error compiling land arm} { + catch {expr 1.3&&2**3} msg + set msg +} {syntax error in expression "1.3&&2**3"} +test expr-5.9 {CompileLandExpr: error compiling land arm} { + list [catch {expr {"a"&&"b"}} msg] $msg +} {1 {expected boolean value but got "a"}} +test expr-5.10 {CompileLandExpr: long land arms} { + set a "abcdefghijkl" + set i 7 + expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]} +} 1 -test expr-5.1 {illegal string operations} { - list [catch {expr {-"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} -test expr-5.2 {illegal string operations} { - list [catch {expr {+"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} -test expr-5.3 {illegal string operations} { - list [catch {expr {~"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "~"}} -test expr-5.4 {illegal string operations} { - list [catch {expr {!"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "!"}} -test expr-5.5 {illegal string operations} { - list [catch {expr {"a"*"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} -test expr-5.6 {illegal string operations} { - list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} -test expr-5.7 {illegal string operations} { - list [catch {expr {"a"%"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "%"}} -test expr-5.8 {illegal string operations} { - list [catch {expr {"a"+"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} -test expr-5.9 {illegal string operations} { - list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} -test expr-5.10 {illegal string operations} { - list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "<<"}} -test expr-5.11 {illegal string operations} { - list [catch {expr {"a">>"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of ">>"}} -test expr-5.12 {illegal string operations} { - list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "&"}} -test expr-5.13 {illegal string operations} { +test expr-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3 +test expr-6.2 {CompileBitXorExpr: error in bitand expr} { + catch {expr x|3} msg + set msg +} {syntax error in expression "x|3"} +test expr-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20 +test expr-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19 +test expr-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7 +test expr-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8 +test expr-6.7 {CompileBitXorExpr: error compiling bitxor arm} { + catch {expr 2**3|6} msg + set msg +} {syntax error in expression "2**3|6"} +test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} { + catch {expr 2^x} msg + set msg +} {syntax error in expression "2^x"} +test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { + list [catch {expr {24.0^3}} msg] $msg +} {1 {can't use floating-point value as operand of "^"}} +test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {"a"^"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "^"}} -test expr-5.14 {illegal string operations} { - list [catch {expr {"a"|"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "|"}} -test expr-5.15 {illegal string operations} { - list [catch {expr {"a"&&"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "&&"}} -test expr-5.16 {illegal string operations} { - list [catch {expr {"a"||"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "||"}} -test expr-5.17 {illegal string operations} { - list [catch {expr {"a"?4:2}} msg] $msg -} {1 {can't use non-numeric string as operand of "?"}} - -# Check precedence pairwise. - -test expr-6.1 {precedence checks} {expr -~3} 4 -test expr-6.2 {precedence checks} {expr -!3} 0 -test expr-6.3 {precedence checks} {expr -~0} 1 - -test expr-7.1 {precedence checks} {expr 2*4/6} 1 -test expr-7.2 {precedence checks} {expr 24/6*3} 12 -test expr-7.3 {precedence checks} {expr 24/6/2} 2 - -test expr-8.1 {precedence checks} {expr -2+4} 2 -test expr-8.2 {precedence checks} {expr -2-4} -6 -test expr-8.3 {precedence checks} {expr +2-4} -2 - -test expr-9.1 {precedence checks} {expr 2*3+4} 10 -test expr-9.2 {precedence checks} {expr 8/2+4} 8 -test expr-9.3 {precedence checks} {expr 8%3+4} 6 -test expr-9.4 {precedence checks} {expr 2*3-1} 5 -test expr-9.5 {precedence checks} {expr 8/2-1} 3 -test expr-9.6 {precedence checks} {expr 8%3-1} 1 - -test expr-10.1 {precedence checks} {expr 6-3-2} 1 - -test expr-11.1 {precedence checks} {expr 7+1>>2} 2 -test expr-11.2 {precedence checks} {expr 7+1<<2} 32 -test expr-11.3 {precedence checks} {expr 7>>3-2} 3 -test expr-11.4 {precedence checks} {expr 7<<3-2} 14 - -test expr-12.1 {precedence checks} {expr 6>>1>4} 0 -test expr-12.2 {precedence checks} {expr 6>>1<2} 0 -test expr-12.3 {precedence checks} {expr 6>>1>=3} 1 -test expr-12.4 {precedence checks} {expr 6>>1<=2} 0 -test expr-12.5 {precedence checks} {expr 6<<1>5} 1 -test expr-12.6 {precedence checks} {expr 6<<1<5} 0 -test expr-12.7 {precedence checks} {expr 5<=6<<1} 1 -test expr-12.8 {precedence checks} {expr 5>=6<<1} 0 - -test expr-13.1 {precedence checks} {expr 2<3<4} 1 -test expr-13.2 {precedence checks} {expr 0<4>2} 0 -test expr-13.3 {precedence checks} {expr 4>2<1} 0 -test expr-13.4 {precedence checks} {expr 4>3>2} 0 -test expr-13.5 {precedence checks} {expr 4>3>=2} 0 -test expr-13.6 {precedence checks} {expr 4>=3>2} 0 -test expr-13.7 {precedence checks} {expr 4>=3>=2} 0 -test expr-13.8 {precedence checks} {expr 0<=4>=2} 0 -test expr-13.9 {precedence checks} {expr 4>=2<=0} 0 -test expr-13.10 {precedence checks} {expr 2<=3<=4} 1 - -test expr-14.1 {precedence checks} {expr 1==4>3} 1 -test expr-14.2 {precedence checks} {expr 0!=4>3} 1 -test expr-14.3 {precedence checks} {expr 1==3<4} 1 -test expr-14.4 {precedence checks} {expr 0!=3<4} 1 -test expr-14.5 {precedence checks} {expr 1==4>=3} 1 -test expr-14.6 {precedence checks} {expr 0!=4>=3} 1 -test expr-14.7 {precedence checks} {expr 1==3<=4} 1 -test expr-14.8 {precedence checks} {expr 0!=3<=4} 1 - -test expr-15.1 {precedence checks} {expr 1==3==3} 0 -test expr-15.2 {precedence checks} {expr 3==3!=2} 1 -test expr-15.3 {precedence checks} {expr 2!=3==3} 0 -test expr-15.4 {precedence checks} {expr 2!=1!=1} 0 - -test expr-16.1 {precedence checks} {expr 2&3==2} 0 -test expr-16.2 {precedence checks} {expr 1&3!=3} 0 - -test expr-17.1 {precedence checks} {expr 7&3^0x10} 19 -test expr-17.2 {precedence checks} {expr 7^0x10&3} 7 - -test expr-18.1 {precedence checks} {expr 7^0x10|3} 23 -test expr-18.2 {precedence checks} {expr 7|0x10^3} 23 - -test expr-19.1 {precedence checks} {expr 7|3&&1} 1 -test expr-19.2 {precedence checks} {expr 1&&3|7} 1 -test expr-19.3 {precedence checks} {expr 0&&1||1} 1 -test expr-19.4 {precedence checks} {expr 1||1&&0} 1 - -test expr-20.1 {precedence checks} {expr 1||0?3:4} 3 -test expr-20.2 {precedence checks} {expr 1?0:4||1} 0 -test expr-20.3 {precedence checks} {expr 1?2:0?3:4} 2 -test expr-20.4 {precedence checks} {expr 0?2:0?3:4} 4 -test expr-20.5 {precedence checks} {expr 1?2?3:4:0} 3 -test expr-20.6 {precedence checks} {expr 0?2?3:4:0} 0 - -# Parentheses. - -test expr-21.1 {parenthesization} {expr (2+4)*6} 36 -test expr-21.2 {parenthesization} {expr (1?0:4)||1} 1 -test expr-21.3 {parenthesization} {expr +(3-4)} -1 - -# Embedded commands and variable names. - -set a 16 -test expr-22.1 {embedded variables} {expr {2*$a}} 32 -test expr-22.2 {embedded variables} { - set x -5 - set y 10 - expr {$x + $y} -} {5} -test expr-22.3 {embedded variables} { - set x " -5" - set y " +10" - expr {$x + $y} -} {5} -test expr-22.4 {embedded commands and variables} {expr {[set a] - 14}} 2 -test expr-22.5 {embedded commands and variables} { - list [catch {expr {12 - [bad_command_name]}} msg] $msg -} {1 {invalid command name "bad_command_name"}} - -# Double-quotes and things inside them. - -test expr-23.1 {double quotes} {expr {"abc"}} abc -test expr-23.2 {double quotes} { - set a 189 - expr {"$a.bc"} -} 189.bc -test expr-23.3 {double quotes} { - set b2 xyx - expr {"$b2$b2$b2.[set b2].[set b2]"} -} xyxxyxxyx.xyx.xyx -test expr-23.4 {double quotes} {expr {"11\}\}22"}} 11}}22 -test expr-23.5 {double quotes} {expr {"\*bc"}} {*bc} -test expr-23.6 {double quotes} { - catch {unset bogus__} - list [catch {expr {"$bogus__"}} msg] $msg -} {1 {can't read "bogus__": no such variable}} -test expr-23.7 {double quotes} { - list [catch {expr {"a[error Testing]bc"}} msg] $msg -} {1 Testing} -test expr-23.8 {double quotes} { - list [catch {expr {"12398712938788234-1298379" != ""}} msg] $msg -} {0 1} - -# Numbers in various bases. -test expr-24.1 {numbers in different bases} {expr 0x20} 32 -test expr-24.2 {numbers in different bases} {expr 015} 13 - -# Conversions between various data types. - -test expr-25.1 {type conversions} {expr 2+2.5} 4.5 -test expr-25.2 {type conversions} {expr 2.5+2} 4.5 -test expr-25.3 {type conversions} {expr 2-2.5} -0.5 -test expr-25.4 {type conversions} {expr 2/2.5} 0.8 -test expr-25.5 {type conversions} {expr 2>2.5} 0 -test expr-25.6 {type conversions} {expr 2.5>2} 1 -test expr-25.7 {type conversions} {expr 2<2.5} 1 -test expr-25.8 {type conversions} {expr 2>=2.5} 0 -test expr-25.9 {type conversions} {expr 2<=2.5} 1 -test expr-25.10 {type conversions} {expr 2==2.5} 0 -test expr-25.11 {type conversions} {expr 2!=2.5} 1 -test expr-25.12 {type conversions} {expr 2>"ab"} 0 -test expr-25.13 {type conversions} {expr {2>" "}} 1 -test expr-25.14 {type conversions} {expr {"24.1a" > 24.1}} 1 -test expr-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0 -test expr-25.16 {type conversions} {expr 2+2.5} 4.5 -test expr-25.17 {type conversions} {expr 2+2.5} 4.5 -test expr-25.18 {type conversions} {expr 2.0e2} 200.0 -test expr-25.19 {type conversions} {expr 2.0e15} 2e+15 -test expr-25.20 {type conversions} {expr 10.0} 10.0 +test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 +test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 +test expr-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1 +test expr-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0 +test expr-7.5 {CompileBitAndExpr: error in equality expr} { + catch {expr x==3} msg + set msg +} {syntax error in expression "x==3"} +test expr-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3 +test expr-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82 +test expr-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2 +test expr-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7 +test expr-7.10 {CompileBitAndExpr: error compiling bitand arm} { + catch {expr 2**3&6} msg + set msg +} {syntax error in expression "2**3&6"} +test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} { + catch {expr 2&x} msg + set msg +} {syntax error in expression "2&x"} +test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} { + list [catch {expr {24.0&3}} msg] $msg +} {1 {can't use floating-point value as operand of "&"}} +test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} { + list [catch {expr {"a"&"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "&"}} -# Various error conditions. +test expr-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1 +test expr-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1 +test expr-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1 +test expr-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0 +test expr-8.5 {CompileEqualityExpr: error in relational expr} { + catch {expr x>3} msg + set msg +} {syntax error in expression "x>3"} +test expr-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0 +test expr-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1 +test expr-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1 +test expr-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1 +test expr-8.10 {CompileEqualityExpr: error compiling equality arm} { + catch {expr 2**3==6} msg + set msg +} {syntax error in expression "2**3==6"} +test expr-8.11 {CompileEqualityExpr: error compiling equality arm} { + catch {expr 2!=x} msg + set msg +} {syntax error in expression "2!=x"} + + +test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 +test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 +test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 +test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 +test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} { + expr {1<<31} +} -2147483648 +test expr-9.6 {CompileRelationalExpr: error in shift expr} { + catch {expr x>>3} msg + set msg +} {syntax error in expression "x>>3"} +test expr-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1 +test expr-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1 +test expr-9.9 {CompileRelationalExpr: error compiling relational arm} { + catch {expr 2**3>6} msg + set msg +} {syntax error in expression "2**3>6"} +test expr-9.10 {CompileRelationalExpr: error compiling relational arm} { + catch {expr 2<x} msg + set msg +} {syntax error in expression "2<x"} + +test expr-10.1 {CompileShiftExpr: just add expr} {expr 4+-2} 2 +test expr-10.2 {CompileShiftExpr: just add expr} {expr 0xff-2} 253 +test expr-10.3 {CompileShiftExpr: just add expr} {expr -1--2} 1 +test expr-10.4 {CompileShiftExpr: just add expr} {expr 1-0123} -82 +test expr-10.5 {CompileShiftExpr: error in add expr} { + catch {expr x+3} msg + set msg +} {syntax error in expression "x+3"} +test expr-10.6 {CompileShiftExpr: simple shift exprs} {expr 0xff>>0x3} 31 +test expr-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936 +test expr-10.8 {CompileShiftExpr: error compiling shift arm} { + catch {expr 2**3>>6} msg + set msg +} {syntax error in expression "2**3>>6"} +test expr-10.9 {CompileShiftExpr: error compiling shift arm} { + catch {expr 2<<x} msg + set msg +} {syntax error in expression "2<<x"} +test expr-10.10 {CompileShiftExpr: runtime error} { + list [catch {expr {24.0>>43}} msg] $msg +} {1 {can't use floating-point value as operand of ">>"}} +test expr-10.11 {CompileShiftExpr: runtime error} { + list [catch {expr {"a"<<"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "<<"}} -test expr-26.1 {error conditions} { - list [catch {expr 2+"a"} msg] $msg +test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 +test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 +test expr-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1 +test expr-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 6 +test expr-11.5 {CompileAddExpr: error in multiply expr} { + catch {expr x*3} msg + set msg +} {syntax error in expression "x*3"} +test expr-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258 +test expr-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239 +test expr-11.8 {CompileAddExpr: error compiling add arm} { + catch {expr 2**3+6} msg + set msg +} {syntax error in expression "2**3+6"} +test expr-11.9 {CompileAddExpr: error compiling add arm} { + catch {expr 2-x} msg + set msg +} {syntax error in expression "2-x"} +test expr-11.10 {CompileAddExpr: runtime error} { + list [catch {expr {24.0+"xx"}} msg] $msg } {1 {can't use non-numeric string as operand of "+"}} -test expr-26.2 {error conditions} { - list [catch {expr 2+4*} msg] $msg -} {1 {syntax error in expression "2+4*"}} -test expr-26.3 {error conditions} { - list [catch {expr 2+4*(} msg] $msg -} {1 {syntax error in expression "2+4*("}} -catch {unset _non_existent_} -test expr-26.4 {error conditions} { - list [catch {expr 2+$_non_existent_} msg] $msg -} {1 {can't read "_non_existent_": no such variable}} -set a xx -test expr-26.5 {error conditions} { - list [catch {expr {2+$a}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} -test expr-26.6 {error conditions} { - list [catch {expr {2+[set a]}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} -test expr-26.7 {error conditions} { - list [catch {expr {2+(4}} msg] $msg -} {1 {unmatched parentheses in expression "2+(4"}} -test expr-26.8 {error conditions} { - list [catch {expr 2/0} msg] $msg $errorCode -} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} -test expr-26.9 {error conditions} { - list [catch {expr 2%0} msg] $msg $errorCode -} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} -test expr-26.10 {error conditions} { - list [catch {expr 2.0/0.0} msg] $msg $errorCode -} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} -test expr-26.11 {error conditions} { - list [catch {expr 2#} msg] $msg -} {1 {syntax error in expression "2#"}} -test expr-26.12 {error conditions} { - list [catch {expr a.b} msg] $msg -} {1 {syntax error in expression "a.b"}} -test expr-26.13 {error conditions} { +test expr-11.11 {CompileAddExpr: runtime error} { + list [catch {expr {"a"-"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "-"}} +test expr-11.12 {CompileAddExpr: runtime error} { + list [catch {expr {3/0}} msg] $msg +} {1 {divide by zero}} +test expr-11.13 {CompileAddExpr: runtime error} { + list [catch {expr {2.3/0.0}} msg] $msg +} {1 {divide by zero}} + +test expr-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5 +test expr-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5 +test expr-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0 +test expr-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936 +test expr-12.5 {CompileMultiplyExpr: error in unary expr} { + catch {expr ~x} msg + set msg +} {syntax error in expression "~x"} +test expr-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765 +test expr-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2 +test expr-12.8 {CompileMultiplyExpr: error compiling multiply arm} { + catch {expr 2*3%%6} msg + set msg +} {syntax error in expression "2*3%%6"} +test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} { + catch {expr 2*x} msg + set msg +} {syntax error in expression "2*x"} +test expr-12.10 {CompileMultiplyExpr: runtime error} { + list [catch {expr {24.0*"xx"}} msg] $msg +} {1 {can't use non-numeric string as operand of "*"}} +test expr-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "/"}} -test expr-26.14 {error conditions} { - list [catch {expr 2:3} msg] $msg -} {1 {can't have : operator without ? first}} -test expr-26.15 {error conditions} { - list [catch {expr a@b} msg] $msg -} {1 {syntax error in expression "a@b"}} -test expr-26.16 {error conditions} { - list [catch {expr a[b} msg] $msg -} {1 {missing close-bracket}} -test expr-26.17 {error conditions} { - list [catch {expr a`b} msg] $msg -} {1 {syntax error in expression "a`b"}} -test expr-26.18 {error conditions} { - list [catch {expr \"a\"\{b} msg] $msg -} {1 {missing close-brace}} -test expr-26.19 {error conditions} { - list [catch {expr a} msg] $msg -} {1 {syntax error in expression "a"}} -test expr-26.20 {error conditions} { - list [catch expr msg] $msg -} {1 {wrong # args: should be "expr arg ?arg ...?"}} - -# Cancelled evaluation. - -test expr-27.1 {cancelled evaluation} { - set a 1 - expr {0&&[set a 2]} - set a -} 1 -test expr-27.2 {cancelled evaluation} { - set a 1 - expr {1||[set a 2]} - set a -} 1 -test expr-27.3 {cancelled evaluation} { - set a 1 - expr {0?[set a 2]:1} - set a -} 1 -test expr-27.4 {cancelled evaluation} { - set a 1 - expr {1?2:[set a 2]} - set a -} 1 -catch {unset x} -test expr-27.5 {cancelled evaluation} { - list [catch {expr {[info exists x] && $x}} msg] $msg -} {0 0} -test expr-27.6 {cancelled evaluation} { - list [catch {expr {0 && [concat $x]}} msg] $msg -} {0 0} -test expr-27.7 {cancelled evaluation} { - set one 1 - list [catch {expr {1 || 1/$one}} msg] $msg -} {0 1} -test expr-27.8 {cancelled evaluation} { - list [catch {expr {1 || -"string"}} msg] $msg -} {0 1} -test expr-27.9 {cancelled evaluation} { - list [catch {expr {1 || ("string" * ("x" && "y"))}} msg] $msg -} {0 1} -test expr-27.10 {cancelled evaluation} { - set x -1.0 - list [catch {expr {($x > 0) ? round(log($x)) : 0}} msg] $msg -} {0 0} - -# Tcl_ExprBool as used in "if" statements - -test expr-28.1 {Tcl_ExprBoolean usage} { - set a 1 - if {2} {set a 2} - set a -} 2 -test expr-28.2 {Tcl_ExprBoolean usage} { - set a 1 - if {0} {set a 2} - set a -} 1 -test expr-28.3 {Tcl_ExprBoolean usage} { - set a 1 - if {1.2} {set a 2} - set a -} 2 -test expr-28.4 {Tcl_ExprBoolean usage} { - set a 1 - if {-1.1} {set a 2} - set a -} 2 -test expr-28.5 {Tcl_ExprBoolean usage} { - set a 1 - if {0.0} {set a 2} - set a -} 1 -test expr-28.6 {Tcl_ExprBoolean usage} { - set a 1 - if {"YES"} {set a 2} - set a -} 2 -test expr-28.7 {Tcl_ExprBoolean usage} { - set a 1 - if {"no"} {set a 2} - set a -} 1 -test expr-28.8 {Tcl_ExprBoolean usage} { - set a 1 - if {"true"} {set a 2} - set a -} 2 -test expr-28.9 {Tcl_ExprBoolean usage} { - set a 1 - if {"fAlse"} {set a 2} - set a -} 1 -test expr-28.10 {Tcl_ExprBoolean usage} { - set a 1 - if {"on"} {set a 2} - set a -} 2 -test expr-28.11 {Tcl_ExprBoolean usage} { - set a 1 - if {"Off"} {set a 2} - set a -} 1 -test expr-28.12 {Tcl_ExprBool usage} { - list [catch {if {"abc"} {}} msg] $msg -} {1 {expected boolean value but got "abc"}} -test expr-28.13 {Tcl_ExprBool usage} { - list [catch {if {"ogle"} {}} msg] $msg -} {1 {expected boolean value but got "ogle"}} -test expr-28.14 {Tcl_ExprBool usage} { - list [catch {if {"o"} {}} msg] $msg -} {1 {expected boolean value but got "o"}} - -# Operands enclosed in braces -test expr-29.1 {braces} {expr {{abc}}} abc -test expr-29.2 {braces} {expr {{00010}}} 8 -test expr-29.3 {braces} {expr {{3.1200000}}} 3.12 -test expr-29.4 {braces} {expr {{a{b}{1 {2 3}}c}}} "a{b}{1 {2 3}}c" -test expr-29.5 {braces} { - list [catch {expr "\{abc"} msg] $msg -} {1 {missing close-brace}} - -# Very long values - -test expr-30.1 {long values} { - set a "0000 1111 2222 3333 4444" - set a "$a | $a | $a | $a | $a" - set a "$a || $a || $a || $a || $a" - expr {$a} -} {0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444} -test expr-30.2 {long values} { - set a "000000000000000000000000000000" - set a "$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a${a}5" +test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 +test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +000123} 83 +test expr-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36 +test expr-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0 +test expr-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0 +test expr-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1 +test expr-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0 +test expr-13.8 {CompileUnaryExpr: error compiling unary expr} { + catch {expr ~x} msg + set msg +} {syntax error in expression "~x"} +test expr-13.9 {CompileUnaryExpr: error compiling unary expr} { + catch {expr !1.x} msg + set msg +} {syntax error in expression "!1.x"} +test expr-13.10 {CompileUnaryExpr: runtime error} { + list [catch {expr {~"xx"}} msg] $msg +} {1 {can't use non-numeric string as operand of "~"}} +test expr-13.11 {CompileUnaryExpr: runtime error} { + list [catch {expr ~4.0} msg] $msg +} {1 {can't use floating-point value as operand of "~"}} +test expr-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291 +test expr-13.13 {CompileUnaryExpr: just primary expr} { + set a 27 expr $a -} 5 - -# Expressions spanning multiple arguments - -test expr-31.1 {multiple arguments to expr command} { - expr 4 + ( 6 *12) -3 -} 73 -test expr-31.2 {multiple arguments to expr command} { - list [catch {expr 2 + (3 + 4} msg] $msg -} {1 {unmatched parentheses in expression "2 + (3 + 4"}} -test expr-31.3 {multiple arguments to expr command} { - list [catch {expr 2 + 3 +} msg] $msg -} {1 {syntax error in expression "2 + 3 +"}} -test expr-31.4 {multiple arguments to expr command} { - list [catch {expr 2 + 3 )} msg] $msg -} {1 {syntax error in expression "2 + 3 )"}} - -# Math functions - -test expr-32.1 {math functions in expressions} { - expr acos(0.5) -} {1.0472} -test expr-32.2 {math functions in expressions} { - expr asin(0.5) -} {0.523599} -test expr-32.3 {math functions in expressions} { - expr atan(1.0) -} {0.785398} -test expr-32.4 {math functions in expressions} { - expr atan2(2.0, 2.0) -} {0.785398} -test expr-32.5 {math functions in expressions} { - expr ceil(1.999) -} {2.0} -test expr-32.6 {math functions in expressions} { - expr cos(.1) -} {0.995004} -test expr-32.7 {math functions in expressions} { - expr cosh(.1) -} {1.005} -test expr-32.8 {math functions in expressions} { - expr exp(1.0) -} {2.71828} -test expr-32.9 {math functions in expressions} { - expr floor(2.000) -} {2.0} -test expr-32.10 {math functions in expressions} { - expr floor(2.001) -} {2.0} -test expr-32.11 {math functions in expressions} { - expr fmod(7.3, 3.2) -} {0.9} -test expr-32.12 {math functions in expressions} { - expr hypot(3.0, 4.0) -} {5.0} -test expr-32.13 {math functions in expressions} { - expr log(2.8) -} {1.02962} -test expr-32.14 {math functions in expressions} { - expr log10(2.8) -} {0.447158} -test expr-32.15 {math functions in expressions} { - expr pow(2.1, 3.1) -} {9.97424} -test expr-32.16 {math functions in expressions} { - expr sin(.1) -} {0.0998334} -test expr-32.17 {math functions in expressions} { - expr sinh(.1) -} {0.100167} -test expr-32.18 {math functions in expressions} { - expr sqrt(2.0) -} {1.41421} -test expr-32.19 {math functions in expressions} { - expr tan(0.8) -} {1.02964} -test expr-32.20 {math functions in expressions} { - expr tanh(0.8) -} {0.664037} -test expr-32.21 {math functions in expressions} { - expr abs(-1.8) -} {1.8} -test expr-32.22 {math functions in expressions} { - expr abs(10.0) -} {10.0} -test expr-32.23 {math functions in expressions} { - expr abs(-4) -} {4} -test expr-32.24 {math functions in expressions} { - expr abs(66) -} {66} -test expr-32.25 {math functions in expressions} {nonPortable} { - list [catch {expr abs(0x80000000)} msg] $msg -} {1 {integer value too large to represent}} -test expr-32.26 {math functions in expressions} { - expr double(1) -} {1.0} -test expr-32.27 {math functions in expressions} { - expr double(1.1) -} {1.1} -test expr-32.28 {math functions in expressions} { - expr int(1) -} {1} -test expr-32.29 {math functions in expressions} { - expr int(1.4) -} {1} -test expr-32.30 {math functions in expressions} { - expr int(1.6) -} {1} -test expr-32.31 {math functions in expressions} { - expr int(-1.4) -} {-1} -test expr-32.32 {math functions in expressions} { - expr int(-1.6) -} {-1} -test expr-32.33 {math functions in expressions} { - list [catch {expr int(1e60)} msg] $msg -} {1 {integer value too large to represent}} -test expr-32.34 {math functions in expressions} { - list [catch {expr int(-1e60)} msg] $msg -} {1 {integer value too large to represent}} -test expr-32.35 {math functions in expressions} { - expr round(1.49) -} {1} -test expr-32.36 {math functions in expressions} { - expr round(1.51) -} {2} -test expr-32.37 {math functions in expressions} { - expr round(-1.49) -} {-1} -test expr-32.38 {math functions in expressions} { - expr round(-1.51) -} {-2} -test expr-32.39 {math functions in expressions} { - list [catch {expr round(1e60)} msg] $msg -} {1 {integer value too large to represent}} -test expr-32.40 {math functions in expressions} { - list [catch {expr round(-1e60)} msg] $msg -} {1 {integer value too large to represent}} -test expr-32.41 {math functions in expressions} { - list [catch {expr pow(1.0 + 3.0 - 2, .8 * 5)} msg] $msg -} {0 16.0} -test expr-32.42 {math functions in expressions} { - list [catch {expr hypot(5*.8,3)} msg] $msg -} {0 5.0} +} 27 +test expr-13.14 {CompileUnaryExpr: just primary expr} { + expr double(27) +} 27.0 +test expr-13.15 {CompileUnaryExpr: just primary expr} {expr "123"} 123 +test expr-13.16 {CompileUnaryExpr: error in primary expr} { + catch {expr [set]} msg + set msg +} {wrong # args: should be "set varName ?newValue?"} +test expr-14.1 {CompilePrimaryExpr: literal primary} {expr 1} 1 +test expr-14.2 {CompilePrimaryExpr: literal primary} {expr 123} 123 +test expr-14.3 {CompilePrimaryExpr: literal primary} {expr 0xff} 255 +test expr-14.4 {CompilePrimaryExpr: literal primary} {expr 00010} 8 +test expr-14.5 {CompilePrimaryExpr: literal primary} {expr 62.0} 62.0 +test expr-14.6 {CompilePrimaryExpr: literal primary} { + format %.6g [expr 3.1400000] +} 3.14 +test expr-14.7 {CompilePrimaryExpr: literal primary} {expr {{abcde}<{abcdef}}} 1 +test expr-14.8 {CompilePrimaryExpr: literal primary} {expr {{abc\ +def} < {abcdef}}} 1 +test expr-14.9 {CompilePrimaryExpr: literal primary} {expr {{abc\tde} > {abc\tdef}}} 0 +test expr-14.10 {CompilePrimaryExpr: literal primary} {expr {{123}}} 123 +test expr-14.11 {CompilePrimaryExpr: var reference primary} { + set i 789 + list [expr {$i}] [expr $i] +} {789 789} +test expr-14.12 {CompilePrimaryExpr: var reference primary} { + set i {789} ;# test expr's aggressive conversion to numeric semantics + list [expr {$i}] [expr $i] +} {789 789} +test expr-14.13 {CompilePrimaryExpr: var reference primary} { + catch {unset a} + set a(foo) foo + set a(bar) bar + set a(123) 123 + set result "" + lappend result [expr $a(123)] [expr {$a(bar)<$a(foo)}] + catch {unset a} + set result +} {123 1} +test expr-14.14 {CompilePrimaryExpr: var reference primary} { + set i 123 ;# test "$var.0" floating point conversion hack + list [expr $i] [expr $i.0] [expr $i.0/12.0] +} {123 123.0 10.25} +test expr-14.15 {CompilePrimaryExpr: var reference primary} { + set i 123 + catch {expr $i.2} msg + set msg +} 123.2 +test expr-14.16 {CompilePrimaryExpr: error compiling var reference primary} { + catch {expr {$a(foo}} msg + set errorInfo +} {missing ) + (parsing index for array "a") + while compiling +"expr"} +test expr-14.17 {CompilePrimaryExpr: string primary that looks like var ref} { + expr $ +} $ +test expr-14.18 {CompilePrimaryExpr: quoted string primary} { + expr "21" +} 21 +test expr-14.19 {CompilePrimaryExpr: quoted string primary} { + set i 123 + set x 456 + format %.6g [expr "$i+$x"] +} 579 +test expr-14.20 {CompilePrimaryExpr: quoted string primary} { + set i 3 + set x 6 + format %.6g [expr 2+"$i.$x"] +} 5.6 +test expr-14.21 {CompilePrimaryExpr: error in quoted string primary} { + catch {expr "[set]"} msg + set msg +} {wrong # args: should be "set varName ?newValue?"} +test expr-14.22 {CompilePrimaryExpr: subcommand primary} { + expr {[set i 123; set i]} +} 123 +test expr-14.23 {CompilePrimaryExpr: error in subcommand primary} { + catch {expr {[set]}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + while compiling +"expr"} +test expr-14.24 {CompilePrimaryExpr: error in subcommand primary} { + catch {expr {[set i}} msg + set errorInfo +} {missing close-bracket or close-brace + while compiling +"set" + while compiling +"expr"} +test expr-14.25 {CompilePrimaryExpr: math function primary} { + format %.6g [expr exp(1.0)] +} 2.71828 +test expr-14.26 {CompilePrimaryExpr: math function primary} { + format %.6g [expr pow(2.0+0.1,3.0+0.1)] +} 9.97424 +test expr-14.27 {CompilePrimaryExpr: error in math function primary} { + catch {expr sinh::(2.0)} msg + set errorInfo +} {syntax error in expression "sinh::(2.0)" + while executing +"expr sinh::(2.0)"} +test expr-14.28 {CompilePrimaryExpr: subexpression primary} { + expr 2+(3*4) +} 14 +test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} { + catch {expr 2+(3*[set])} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + while compiling +"expr"} +test expr-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} { + catch {expr 2+(3*(4+5)} msg + set errorInfo +} {syntax error in expression "2+(3*(4+5)" + while executing +"expr 2+(3*(4+5)"} +test expr-14.31 {CompilePrimaryExpr: unexpected token} { + catch {expr @} msg + set errorInfo +} {syntax error in expression "@" + while executing +"expr @"} + +test expr-15.1 {CompileMathFuncCall: missing parenthesis} { + catch {expr sinh2.0)} msg + set errorInfo +} {syntax error in expression "sinh2.0)" + while executing +"expr sinh2.0)"} +test expr-15.2 {CompileMathFuncCall: unknown math function} { + catch {expr whazzathuh(1)} msg + set errorInfo +} {unknown math function "whazzathuh" + while executing +"expr whazzathuh(1)"} +test expr-15.3 {CompileMathFuncCall: too many arguments} { + catch {expr sin(1,2,3)} msg + set errorInfo +} {too many arguments for math function + while executing +"expr sin(1,2,3)"} +test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} { + catch {expr sin()} msg + set errorInfo +} {syntax error in expression "sin()" + while executing +"expr sin()"} +test expr-15.5 {CompileMathFuncCall: too few arguments} { + catch {expr pow(1)} msg + set errorInfo +} {too few arguments for math function + while executing +"expr pow(1)"} +test expr-15.6 {CompileMathFuncCall: missing ')'} { + catch {expr sin(1} msg + set errorInfo +} {syntax error in expression "sin(1" + while executing +"expr sin(1"} if $gotT1 { - test expr-32.43 {math functions in expressions} { + test expr-15.7 {CompileMathFuncCall: call registered math function} { expr 2*T1() } 246 - test expr-32.44 {math functions in expressions} { + test expr-15.8 {CompileMathFuncCall: call registered math function} { expr T2()*3 } 1035 -} - -test expr-33.1 {conversions and fancy args to math functions} { - expr hypot ( 3 , 4 ) -} 5.0 -test expr-33.2 {conversions and fancy args to math functions} { - expr hypot ( (2.0+1.0) , 4 ) -} 5.0 -test expr-33.3 {conversions and fancy args to math functions} { - expr hypot ( 3 , (3.0 + 1.0) ) -} 5.0 -test expr-33.4 {conversions and fancy args to math functions} { - expr cos(acos(0.1)) -} 0.1 -test expr-34.1 {errors in math functions} { - list [catch {expr func_2(1.0)} msg] $msg -} {1 {unknown math function "func_2"}} -test expr-34.2 {errors in math functions} { - list [catch {expr func|(1.0)} msg] $msg -} {1 {syntax error in expression "func|(1.0)"}} -test expr-34.3 {errors in math functions} { - list [catch {expr {hypot("a b", 2.0)}} msg] $msg -} {1 {argument to math function didn't have numeric value}} -test expr-34.4 {errors in math functions} { - list [catch {expr hypot(1.0 2.0)} msg] $msg -} {1 {syntax error in expression "hypot(1.0 2.0)"}} -test expr-34.5 {errors in math functions} { - list [catch {expr hypot(1.0, 2.0} msg] $msg -} {1 {syntax error in expression "hypot(1.0, 2.0"}} -test expr-34.6 {errors in math functions} { - list [catch {expr hypot(1.0 ,} msg] $msg -} {1 {syntax error in expression "hypot(1.0 ,"}} -test expr-34.7 {errors in math functions} { - list [catch {expr hypot(1.0)} msg] $msg -} {1 {too few arguments for math function}} -test expr-34.8 {errors in math functions} { - list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg -} {1 {too many arguments for math function}} -test expr-34.9 {errors in math functions} { - list [catch {expr acos(-2.0)} msg] $msg $errorCode -} {1 {domain error: argument not in valid range} {ARITH DOMAIN {domain error: argument not in valid range}}} -test expr-34.10 {errors in math functions} {nonPortable} { - list [catch {expr pow(-3, 1000001)} msg] $msg $errorCode -} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} -test expr-34.11 {errors in math functions} { - list [catch {expr pow(3, 1000001)} msg] $msg $errorCode -} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} -test expr-34.12 {errors in math functions} { - list [catch {expr -14.0*exp(100000)} msg] $msg $errorCode -} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} -test expr-34.13 {errors in math functions} { - list [catch {expr int(1.0e30)} msg] $msg $errorCode -} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} -test expr-34.14 {errors in math functions} { - list [catch {expr int(-1.0e30)} msg] $msg $errorCode -} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} -test expr-34.15 {errors in math functions} { - list [catch {expr round(1.0e30)} msg] $msg $errorCode -} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} -test expr-34.16 {errors in math functions} { - list [catch {expr round(-1.0e30)} msg] $msg $errorCode -} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} -if $gotT1 { - test expr-34.17 {errors in math functions} { - list [catch {expr T1(4)} msg] $msg - } {1 {syntax error in expression "T1(4)"}} + test expr-15.9 {CompileMathFuncCall: call registered math function} { + expr T3(21, 37) + } 37 + test expr-15.10 {CompileMathFuncCall: call registered math function} { + expr T3(21.2, 37) + } 37.0 + test expr-15.11 {CompileMathFuncCall: call registered math function} { + expr T3(-21.2, -17.5) + } -17.5 } -catch {unset tcl_precision} -test expr-35.1 {tcl_precision variable} { - expr 2.0/3 -} 0.666667 -set tcl_precision 1 -test expr-35.2 {tcl_precision variable} { - expr 2.0/3 -} 0.7 -test expr-35.3 {tcl_precision variable} { - expr 2.0/3 -} 0.7 -test expr-35.4 {tcl_precision variable} { - list [catch {set tcl_precision 0} msg] $msg [expr 2.0/3] -} {1 {can't set "tcl_precision": improper value for precision} 0.7} -test expr-35.5 {tcl_precision variable} { - list [catch {set tcl_precision 101} msg] $msg [expr 2.0/3] -} {1 {can't set "tcl_precision": improper value for precision} 0.7} -test expr-35.6 {tcl_precision variable} { - list [catch {set tcl_precision {}} msg] $msg [expr 2.0/3] -} {1 {can't set "tcl_precision": improper value for precision} 0.7} -test expr-35.7 {tcl_precision variable} { - list [catch {set tcl_precision {1 2 3}} msg] $msg [expr 2.0/3] -} {1 {can't set "tcl_precision": improper value for precision} 0.7} -catch {unset tcl_precision} -test expr-35.8 {tcl_precision variable} { - expr 2.0/3 -} 0.666667 - -test expr-36.1 {ExprLooksLikeInt procedure} { - list [catch {expr 0289} msg] $msg -} {1 {syntax error in expression "0289"}} -test expr-36.2 {ExprLooksLikeInt procedure} { - set x 0289 - list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} -test expr-36.3 {ExprLooksLikeInt procedure} { - list [catch {expr 0289.1} msg] $msg -} {0 289.1} -test expr-36.4 {ExprLooksLikeInt procedure} { - set x 0289.1 - list [catch {expr {$x+1}} msg] $msg -} {0 290.1} -test expr-36.5 {ExprLooksLikeInt procedure} { - set x { +22} - list [catch {expr {$x+1}} msg] $msg -} {0 23} -test expr-36.6 {ExprLooksLikeInt procedure} { - set x { -22} - list [catch {expr {$x+1}} msg] $msg -} {0 -21} -test expr-36.7 {ExprLooksLikeInt procedure} {nonPortable unixOnly} { - list [catch {expr nan} msg] $msg -} {1 {domain error: argument not in valid range}} -test expr-36.8 {ExprLooksLikeInt procedure} { - list [catch {expr 78e1} msg] $msg -} {0 780.0} -test expr-36.9 {ExprLooksLikeInt procedure} { - list [catch {expr 24E1} msg] $msg -} {0 240.0} -test expr-36.10 {ExprLooksLikeInt procedure} {nonPortable unixOnly} { - list [catch {expr 78e} msg] $msg -} {1 {syntax error in expression "78e"}} - - -# Special test for Pentium arithmetic bug of 1994: - -if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} { - puts "Warning: this machine contains a defective Pentium processor" - puts "that performs arithmetic incorrectly. I recommend that you" - puts "call Intel customer service immediately at 1-800-628-8686" - puts "to request a replacement processor." -} +# Check "expr" and computed command names. + +test expr-16.1 {expr and computed command names} { + set i 0 + set z expr + $z 1+2 +} 3 + +# Check correct conversion of operands to numbers: If the string looks like +# an integer, convert to integer. Otherwise, if the string looks like a +# double, convert to double. + +test expr-17.1 {expr and conversion of operands to numbers} { + set x [lindex 11 0] + catch {expr int($x)} + expr {$x} +} 11 + +# Check "expr" and interpreter result object resetting before appending +# an error msg during evaluation of exprs not in {}s + +test expr-18.1 {expr and interpreter result object resetting} { + proc p {} { + set t 10.0 + set x 2.0 + set dx 0.2 + set f {$dx-$x/10} + set g {-$x/5} + set center 1.0 + set x [expr $x-$center] + set dx [expr $dx+$g] + set x [expr $x+$f+$center] + set x [expr $x+$f+$center] + set y [expr round($x)] + } + p +} 3 diff --git a/contrib/tcl/tests/fCmd.test b/contrib/tcl/tests/fCmd.test new file mode 100644 index 0000000000000..f53da0c3e33a4 --- /dev/null +++ b/contrib/tcl/tests/fCmd.test @@ -0,0 +1,2083 @@ +# This file tests the tclFCmd.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) fCmd.test 1.30 97/06/23 17:29:36 +# + +if {[string compare test [info procs test]] == 1} then {source defs} + +set platform [testgetplatform] + +if {$user == "root"} { + puts "Skipping fCmd tests. They depend on not being able to write to" + puts "certain directories. It would be too dangerous to run them as root." + return +} + +if {"[info commands testchmod]" != "testchmod"} { + puts "Skipping fCmd tests. This application does not seem to have the" + puts "testchmod command that is needed to run these tests." + return +} + +proc createfile {file {string a}} { + set f [open $file w] + puts -nonewline $f $string + close $f + return $string +} + +# +# checkcontent -- +# +# Ensures that file "file" contains only the string "matchString" +# returns 0 if the file does not exist, or has a different content +# +proc checkcontent {file matchString} { + if {[catch { + set f [open $file] + set fileString [read $f] + close $f + }]} { + return 0 + } + return [string match $matchString $fileString] +} + +proc openup {path} { + testchmod 777 $path + if {[file isdirectory $path]} { + catch { + foreach p [glob [file join $path *]] { + openup $p + } + } + } +} + +proc cleanup {args} { + foreach p ". $args" { + set x "" + catch { + set x [glob [file join $p tf*] [file join $p td*]] + } + foreach file $x { + if {[catch {file delete -force -- $file}]} { + openup $file + file delete -force -- $file + } + } + } +} + +proc contents {file} { + set f [open $file r] + set r [read $f] + close $f + set r +} + +set testConfig(NT) 0 +set testConfig(95) 0 + +switch $tcl_platform(os) { + "Windows NT" {set testConfig(NT) 1} + "Windows 95" {set testConfig(95) 1} +} + +set testConfig(fileSharing) 0 +set testConfig(notFileSharing) 1 + +if {$tcl_platform(platform) == "macintosh"} { + catch {file delete -force foo.dir} + file mkdir foo.dir + if {[catch {file attributes foo.dir -readonly 1}] == 0} { + set testConfig(fileSharing) 1 + set testConfig(notFileSharing) 0 + } + file delete -force foo.dir +} + +set testConfig(xdev) 0 + +if {$tcl_platform(platform) == "unix"} { + if {[catch {set m1 [exec df .]; set m2 [exec df /tmp]}] == 0} { + set m1 [string range $m1 0 [expr [string first " " $m1]-1]] + set m2 [string range $m2 0 [expr [string first " " $m2]-1]] + if {$m1 != "" && $m2 != "" && $m1 != $m2 && [file exists $m1] && [file exists $m2]} { + set testConfig(xdev) 1 + } + } +} + +set root [lindex [file split [pwd]] 0] + +# A really long file name +# length of long is 1216 chars, which should be greater than any static +# buffer or allowable filename. + +set long "abcdefghihjllmnopqrstuvwxyz01234567890" +append long $long +append long $long +append long $long +append long $long +append long $long + +test fCmd-1.1 {TclFileRenameCmd} { + cleanup + createfile tf1 + file rename tf1 tf2 + glob tf* +} {tf2} + +test fCmd-2.1 {TclFileCopyCmd} { + cleanup + createfile tf1 + file copy tf1 tf2 + lsort [glob tf*] +} {tf1 tf2} + +test fCmd-3.1 {FileCopyRename: FileForceOption fails} { + list [catch {file rename -xyz} msg] $msg +} {1 {bad option "-xyz": should be -force or --}} +test fCmd-3.2 {FileCopyRename: not enough args} { + list [catch {file rename xyz} msg] $msg +} {1 {wrong # args: should be "file rename ?options? source ?source ...? target"}} +test fCmd-3.3 {FileCopyRename: Tcl_TranslateFileName fails} { + list [catch {file rename xyz ~nonexistantuser} msg] $msg +} {1 {user "nonexistantuser" doesn't exist}} +test fCmd-3.4 {FileCopyRename: Tcl_TranslateFileName passes} { + cleanup + list [catch {file copy tf1 ~} msg] $msg +} {1 {error copying "tf1": no such file or directory}} +test fCmd-3.5 {FileCopyRename: target doesn't exist: stat(target) != 0} { + cleanup + list [catch {file rename tf1 tf2 tf3} msg] $msg +} {1 {error renaming: target "tf3" is not a directory}} +test fCmd-3.6 {FileCopyRename: target tf3 is not a directory: !S_ISDIR(target)} { + cleanup + createfile tf3 + list [catch {file rename tf1 tf2 tf3} msg] $msg +} {1 {error renaming: target "tf3" is not a directory}} +test fCmd-3.7 {FileCopyRename: target exists & is directory} { + cleanup + file mkdir td1 + createfile tf1 tf1 + file rename tf1 td1 + contents [file join td1 tf1] +} {tf1} +test fCmd-3.8 {FileCopyRename: too many arguments: argc - i > 2} { + cleanup + list [catch {file rename tf1 tf2 tf3} msg] $msg +} {1 {error renaming: target "tf3" is not a directory}} +test fCmd-3.9 {FileCopyRename: too many arguments: argc - i > 2} { + cleanup + list [catch {file copy -force -- tf1 tf2 tf3} msg] $msg +} {1 {error copying: target "tf3" is not a directory}} +test fCmd-3.10 {FileCopyRename: just 2 arguments} { + cleanup + createfile tf1 tf1 + file rename tf1 tf2 + contents tf2 +} {tf1} +test fCmd-3.11 {FileCopyRename: just 2 arguments} { + cleanup + createfile tf1 tf1 + file rename -force -force -- tf1 tf2 + contents tf2 +} {tf1} +test fCmd-3.12 {FileCopyRename: move each source: 1 source} { + cleanup + createfile tf1 tf1 + file mkdir td1 + file rename tf1 td1 + contents [file join td1 tf1] +} {tf1} +test fCmd-3.13 {FileCopyRename: move each source: multiple sources} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + createfile tf3 tf3 + createfile tf4 tf4 + file mkdir td1 + file rename tf1 tf2 tf3 tf4 td1 + list [contents [file join td1 tf1]] [contents [file join td1 tf2]] \ + [contents [file join td1 tf3]] [contents [file join td1 tf4]] +} {tf1 tf2 tf3 tf4} +test fCmd-3.14 {FileCopyRename: FileBasename fails} { + cleanup + file mkdir td1 + list [catch {file rename ~nonexistantuser td1} msg] $msg +} {1 {user "nonexistantuser" doesn't exist}} +test fCmd-3.15 {FileCopyRename: source[0] == '\0'} {unixOrPc} { + cleanup + file mkdir td1 + list [catch {file rename / td1} msg] $msg +} {1 {error renaming "/" to "td1": file already exists}} +test fCmd-3.16 {FileCopyRename: break on first error} { + cleanup + createfile tf1 + createfile tf2 + createfile tf3 + createfile tf4 + file mkdir td1 + createfile [file join td1 tf3] + list [catch {file rename tf1 tf2 tf3 tf4 td1} msg] $msg +} [subst {1 {error renaming "tf3" to "[file join td1 tf3]": file already exists}}] + +test fCmd-4.1 {TclFileMakeDirsCmd: make each dir: 1 dir} { + cleanup + file mkdir td1 + glob td* +} {td1} +test fCmd-4.2 {TclFileMakeDirsCmd: make each dir: multiple dirs} { + cleanup + file mkdir td1 td2 td3 + lsort [glob td*] +} {td1 td2 td3} +test fCmd-4.3 {TclFileMakeDirsCmd: stops on first error} { + cleanup + createfile tf1 + catch {file mkdir td1 td2 tf1 td3 td4} + glob td1 td2 tf1 td3 td4 +} {td1 td2 tf1} +test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName fails} { + cleanup + list [catch {file mkdir ~nonexistantuser} msg] $msg +} {1 {user "nonexistantuser" doesn't exist}} +test fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\0'} { + cleanup + list [catch {file mkdir ""} msg] $msg +} {1 {can't create directory "": no such file or directory}} +test fCmd-4.6 {TclFileMakeDirsCmd: one level deep} { + cleanup + file mkdir td1 + glob td1 +} {td1} +test fCmd-4.7 {TclFileMakeDirsCmd: multi levels deep} { + cleanup + file mkdir [file join td1 td2 td3 td4] + glob td1 [file join td1 td2] +} "td1 [file join td1 td2]" +test fCmd-4.8 {TclFileMakeDirsCmd: already exist: lstat(target) == 0} { + cleanup + file mkdir td1 + set x [file exist td1] + file mkdir td1 + list $x [file exist td1] +} {1 1} +test fCmd-4.9 {TclFileMakeDirsCmd: exists, not dir} { + cleanup + createfile tf1 + list [catch {file mkdir tf1} msg] $msg +} [subst {1 {can't create directory "[file join tf1]": file already exists}}] +test fCmd-4.10 {TclFileMakeDirsCmd: exists, is dir} { + cleanup + file mkdir td1 + set x [file exist td1] + file mkdir td1 + list $x [file exist td1] +} {1 1} +test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {unixOnly} { + cleanup + file mkdir td1/td2/td3 + testchmod 000 td1/td2 + set msg [list [catch {file mkdir td1/td2/td3/td4} msg] $msg] + testchmod 755 td1/td2 + set msg +} {1 {can't create directory "td1/td2/td3": permission denied}} +test fCmd-4.12 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {macOnly} { + cleanup + list [catch {file mkdir nonexistantvolume:} msg] $msg +} {1 {can't create directory "nonexistantvolume:": invalid argument}} +test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} { + cleanup + set x [file exist td1] + file mkdir td1 + list $x [file exist td1] +} {0 1} +test fCmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {unixOnly nonPortable} { + cleanup + list [catch {file mkdir /tf1} msg] $msg +} {1 {can't create directory "/tf1": permission denied}} +test fCmd-4.15 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {macOnly} { + list [catch {file mkdir ${root}:} msg] $msg +} [subst {1 {can't create directory "${root}:": no such file or directory}}] +test fCmd-4.16 {TclFileMakeDirsCmd: TclpCreateDirectory succeeds} { + cleanup + file mkdir tf1 + file exists tf1 +} {1} + +test fCmd-5.1 {TclFileDeleteCmd: FileForceOption fails} { + list [catch {file delete -xyz} msg] $msg +} {1 {bad option "-xyz": should be -force or --}} +test fCmd-5.2 {TclFileDeleteCmd: not enough args} { + list [catch {file delete -force -force} msg] $msg +} {1 {wrong # args: should be "file delete ?options? file ?file ...?"}} +test fCmd-5.3 {TclFileDeleteCmd: 1 file} { + cleanup + createfile tf1 + createfile tf2 + file mkdir td1 + file delete tf2 + glob tf* td* +} {tf1 td1} +test fCmd-5.4 {TclFileDeleteCmd: multiple files} { + cleanup + createfile tf1 + createfile tf2 + file mkdir td1 + set x [list [file exist tf1] [file exist tf2] [file exist td1]] + file delete tf1 td1 tf2 + lappend x [file exist tf1] [file exist tf2] [file exist tf3] +} {1 1 1 0 0 0} +test fCmd-5.5 {TclFileDeleteCmd: stop at first error} {unixOrPc} { + cleanup + createfile tf1 + createfile tf2 + file mkdir td1 + catch {file delete tf1 td1 $root tf2} + list [file exist tf1] [file exist tf2] [file exist td1] +} {0 1 0} +test fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} { + list [catch {file delete ~nonexistantuser} msg] $msg +} {1 {user "nonexistantuser" doesn't exist}} +test fCmd-5.7 {TclFileDeleteCmd: Tcl_TranslateFileName succeeds} { + catch {file delete ~/tf1} + createfile ~/tf1 + file delete ~/tf1 +} {} +test fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} { + cleanup + set x [file exist tf1] + file delete tf1 + list $x [file exist tf1] +} {0 0} +test fCmd-5.9 {TclFileDeleteCmd: is directory} { + cleanup + file mkdir td1 + file delete td1 + file exist td1 +} {0} +test fCmd-5.10 {TclFileDeleteCmd: TclpRemoveDirectory fails} { + cleanup + file mkdir td1/td2 + list [catch {file delete td1} msg] $msg +} {1 {error deleting "td1": directory not empty}} + +test fCmd-6.1 {CopyRenameOneFile: bad source} { + # can't test this, because it's caught by FileCopyRename +} {} +test fCmd-6.2 {CopyRenameOneFile: bad target} { + # can't test this, because it's caught by FileCopyRename +} {} +test fCmd-6.3 {CopyRenameOneFile: lstat(source) != 0} { + cleanup + list [catch {file rename tf1 tf2} msg] $msg +} {1 {error renaming "tf1": no such file or directory}} +test fCmd-6.4 {CopyRenameOneFile: lstat(source) == 0} { + cleanup + createfile tf1 + file rename tf1 tf2 + glob tf* +} {tf2} +test fCmd-6.5 {CopyRenameOneFile: lstat(target) != 0} { + cleanup + createfile tf1 + file rename tf1 tf2 + glob tf* +} {tf2} +test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly} { + cleanup + file mkdir td1 + testchmod 000 td1 + createfile tf1 + set msg [list [catch {file rename tf1 td1} msg] $msg] + testchmod 755 td1 + set msg +} {1 {error renaming "tf1" to "td1/tf1": permission denied}} +test fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} {95} { + cleanup + createfile tf1 + list [catch {file rename tf1 $long} msg] $msg +} [subst {1 {error renaming "tf1" to "$long": file name too long}}] +test fCmd-6.8 {CopyRenameOneFile: errno != ENOENT} {macOnly} { + cleanup + createfile tf1 + list [catch {file rename tf1 $long} msg] $msg +} [subst {1 {error renaming "tf1" to "$long": file name too long}}] +test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} {unixOnly} { + cleanup + createfile tf1 + file rename tf1 tf2 + glob tf* +} {tf2} +test fCmd-6.10 {CopyRenameOneFile: lstat(target) == 0} { + cleanup + createfile tf1 + createfile tf2 + list [catch {file rename tf1 tf2} msg] $msg +} {1 {error renaming "tf1" to "tf2": file already exists}} +test fCmd-6.11 {CopyRenameOneFile: force == 0} { + cleanup + createfile tf1 + createfile tf2 + list [catch {file rename tf1 tf2} msg] $msg +} {1 {error renaming "tf1" to "tf2": file already exists}} +test fCmd-6.12 {CopyRenameOneFile: force != 0} { + cleanup + createfile tf1 + createfile tf2 + file rename -force tf1 tf2 + glob tf* +} {tf2} +test fCmd-6.13 {CopyRenameOneFile: source is dir, target is file} { + cleanup + file mkdir td1 + file mkdir td2 + createfile [file join td2 td1] + list [catch {file rename -force td1 td2} msg] $msg +} [subst {1 {can't overwrite file "[file join td2 td1]" with directory "td1"}}] +test fCmd-6.14 {CopyRenameOneFile: source is file, target is dir} { + cleanup + createfile tf1 + file mkdir [file join td1 tf1] + list [catch {file rename -force tf1 td1} msg] $msg +} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}] +test fCmd-6.15 {CopyRenameOneFile: TclpRenameFile succeeds} { + cleanup + file mkdir [file join td1 td2] + file mkdir td2 + createfile [file join td2 tf1] + file rename -force td2 td1 + file exists [file join td1 td2 tf1] +} {1} +test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} { + cleanup + file mkdir [file join td1 td2] + createfile [file join td1 td2 tf1] + file mkdir td2 + list [catch {file rename -force td2 td1} msg] $msg +} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}] +test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} { + cleanup + list [catch {file rename -force $root tf1} msg] $msg +} [subst {1 {error renaming "$root" to "tf1": trying to rename a volume or move a directory into itself}}] +test fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} { + cleanup + file mkdir [file join td1 td2] + createfile [file join td1 td2 tf1] + file mkdir td2 + list [catch {file rename -force td2 td1} msg] $msg +} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}] +test fCmd-6.19 {CopyRenameOneFile: errno == EXDEV} {unixOnly} { + cleanup /tmp + createfile tf1 + file rename tf1 /tmp + glob tf* /tmp/tf1 +} {/tmp/tf1} +test fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} {pcOnly} { + catch {file delete -force c:/tcl8975@ d:/tcl8975@} + file mkdir c:/tcl8975@ + if [catch {file rename c:/tcl8975@ d:/}] { + list d:/tcl8975@ + } else { + set msg [glob c:/tcl8975@ d:/tcl8975@] + file delete -force d:/tcl8975@ + set msg + } +} {d:/tcl8975@} +test fCmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} {unixOnly} { + cleanup /tmp + file mkdir td1 + file rename td1 /tmp + glob td* /tmp/td* +} {/tmp/td1} +test fCmd-6.22 {CopyRenameOneFile: copy/rename: !S_ISDIR(source)} {unixOnly} { + cleanup /tmp + createfile tf1 + file rename tf1 /tmp + glob tf* /tmp/tf* +} {/tmp/tf1} +test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly xdev} { + cleanup /tmp + file mkdir td1/td2/td3 + exec chmod 000 td1 + set msg [list [catch {file rename td1 /tmp} msg] $msg] + exec chmod 755 td1 + set msg +} {1 {error renaming "td1": permission denied}} +test fCmd-6.24 {CopyRenameOneFile: error uses original name} {unixOnly} { + cleanup + file mkdir ~/td1/td2 + exec chmod 000 [file join [file dirname ~] [file tail ~] td1] + set msg [list [catch {file copy ~/td1 td1} msg] $msg] + exec chmod 755 [file join [file dirname ~] [file tail ~] td1] + file delete -force ~/td1 + set msg +} {1 {error copying "~/td1": permission denied}} +test fCmd-6.25 {CopyRenameOneFile: error uses original name} {unixOnly} { + cleanup + file mkdir td2 + file mkdir ~/td1 + exec chmod 000 [file join [file dirname ~] [file tail ~] td1] + set msg [list [catch {file copy td2 ~/td1} msg] $msg] + exec chmod 755 [file join [file dirname ~] [file tail ~] td1] + file delete -force ~/td1 + set msg +} {1 {error copying "td2" to "~/td1/td2": permission denied}} +test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} {unixOnly} { + cleanup + file mkdir ~/td1/td2 + exec chmod 000 [file join [file dirname ~] [file tail ~] td1 td2] + set msg [list [catch {file copy ~/td1 td1} msg] $msg] + exec chmod 755 [file join [file dirname ~] [file tail ~] td1 td2] + file delete -force ~/td1 + set msg +} "1 {error copying \"~/td1\" to \"td1\": \"[file join [file dirname ~] [file tail ~] td1 td2]\": permission denied}" +test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly xdev} { + cleanup /tmp + file mkdir td1/td2/td3 + file mkdir /tmp/td1 + createfile /tmp/td1/tf1 + list [catch {file rename -force td1 /tmp} msg] $msg +} {1 {error renaming "td1" to "/tmp/td1": file already exists}} +test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly xdev} { + cleanup /tmp + file mkdir td1/td2/td3 + exec chmod 000 td1/td2/td3 + set msg [list [catch {file rename td1 /tmp} msg] $msg] + exec chmod 755 td1/td2/td3 + set msg +} {1 {error renaming "td1" to "/tmp/td1": "td1/td2/td3": permission denied}} +test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} {unixOnly xdev} { + cleanup /tmp + file mkdir td1/td2/td3 + file rename td1 /tmp + glob td* /tmp/td1/t* +} {/tmp/td1/td2} +test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} {unixOnly nonPortable} { + cleanup + if [file exists /kernel] { + set msg [list [catch {file rename /kernel td1} msg] $msg] + set a1 {1 {can't unlink "/kernel": permission denied}} + expr {$msg == $a1} + } else { + list 1 + } +} {1} +test fCmd-6.31 {CopyRenameOneFile: TclpDeleteFile passed} {unixOnly xdev} { + catch {cleanup /tmp} + file mkdir /tmp/td1 + createfile /tmp/td1/tf1 + file rename /tmp/td1/tf1 tf1 + list [file exists /tmp/td1/tf1] [file exists tf1] +} {0 1} +test fCmd-6.32 {CopyRenameOneFile: copy} { + cleanup + list [catch {file copy tf1 tf2} msg] $msg +} {1 {error copying "tf1": no such file or directory}} +catch {cleanup /tmp} + +test fCmd-7.1 {FileForceOption: none} { + cleanup + file mkdir [file join tf1 tf2] + list [catch {file delete tf1} msg] $msg +} {1 {error deleting "tf1": directory not empty}} +test fCmd-7.2 {FileForceOption: -force} { + cleanup + file mkdir [file join tf1 tf2] + file delete -force tf1 +} {} +test fCmd-7.3 {FileForceOption: --} { + createfile -tf1 + file delete -- -tf1 +} {} +test fCmd-7.4 {FileForceOption: bad option} { + createfile -tf1 + set msg [list [catch {file delete -tf1} msg] $msg] + file delete -- -tf1 + set msg +} {1 {bad option "-tf1": should be -force or --}} +test fCmd-7.5 {FileForceOption: multiple times through loop} { + createfile -- + createfile -force + file delete -force -force -- -- -force + list [catch {glob -- -- -force} msg] $msg +} {1 {no files matched glob patterns "-- -force"}} + +test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} {unixOnly nonPortable} { + list [catch {file rename ~$user /} msg] $msg +} "1 {error renaming \"~$user\" to \"/[file tail ~$user]\": permission denied}" + +test fCmd-9.1 {file rename: comprehensive: EACCES} {unixOnly} { + cleanup + file mkdir td1 + list [catch {file rename td1 /} msg] $msg +} {1 {error renaming "td1" to "/td1": permission denied}} +test fCmd-9.2 {file rename: comprehensive: source doesn't exist} { + cleanup + list [catch {file rename tf1 tf2} msg] $msg +} {1 {error renaming "tf1": no such file or directory}} +test fCmd-9.3 {file rename: comprehensive: file to new name} { + cleanup + createfile tf1 + createfile tf2 + testchmod 444 tf2 + file rename tf1 tf3 + file rename tf2 tf4 + list [lsort [glob tf*]] [file writable tf3] [file writable tf4] +} {{tf3 tf4} 1 0} +test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc} { + cleanup + file mkdir td1 td2 + testchmod 555 td2 + file rename td1 td3 + file rename td2 td4 + list [lsort [glob td*]] [file writable td3] [file writable td4] +} {{td3 td4} 1 0} +test fCmd-9.5 {file rename: comprehensive: file to self} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + testchmod 444 tf2 + file rename -force tf1 tf1 + file rename -force tf2 tf2 + list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2] +} {tf1 tf2 1 0} +test fCmd-9.6 {file rename: comprehensive: dir to self} {unixOrPc} { + cleanup + file mkdir td1 + file mkdir td2 + testchmod 555 td2 + file rename -force td1 . + file rename -force td2 . + list [lsort [glob td*]] [file writable td1] [file writable td2] +} {{td1 td2} 1 0} +test fCmd-9.7 {file rename: comprehensive: file to existing file} { + cleanup + createfile tf1 + createfile tf2 + createfile tfs1 + createfile tfs2 + createfile tfs3 + createfile tfs4 + createfile tfd1 + createfile tfd2 + createfile tfd3 + createfile tfd4 + testchmod 444 tfs3 + testchmod 444 tfs4 + testchmod 444 tfd2 + testchmod 444 tfd4 + set msg [list [catch {file rename tf1 tf2} msg] $msg] + file rename -force tfs1 tfd1 + file rename -force tfs2 tfd2 + file rename -force tfs3 tfd3 + file rename -force tfs4 tfd4 + list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] +} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0} +test fCmd-9.8 {file rename: comprehensive: dir to empty dir} { + # Under unix, you can rename a read-only directory, but you can't + # move it into another directory. + + cleanup + file mkdir td1 + file mkdir [file join td2 td1] + file mkdir tds1 + file mkdir tds2 + file mkdir tds3 + file mkdir tds4 + file mkdir [file join tdd1 tds1] + file mkdir [file join tdd2 tds2] + file mkdir [file join tdd3 tds3] + file mkdir [file join tdd4 tds4] + if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { + testchmod 555 tds3 + testchmod 555 tds4 + } + if {$tcl_platform(platform) != "macintosh"} { + testchmod 555 [file join tdd2 tds2] + testchmod 555 [file join tdd4 tds4] + } + set msg [list [catch {file rename td1 td2} msg] $msg] + file rename -force tds1 tdd1 + file rename -force tds2 tdd2 + file rename -force tds3 tdd3 + file rename -force tds4 tdd4 + if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { + set w3 [file writable [file join tdd3 tds3]] + set w4 [file writable [file join tdd4 tds4]] + } else { + set w3 0 + set w4 0 + } + list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \ + [file writable [file join tdd2 tds2]] $w3 $w4 +} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}] +test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} { + cleanup + file mkdir tds1 + file mkdir tds2 + file mkdir [file join tdd1 tds1 xxx] + file mkdir [file join tdd2 tds2 xxx] + if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { + testchmod 555 tds2 + } + set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg] + set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg] + if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { + set w2 [file writable tds2] + } else { + set w2 0 + } + list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2 +} [subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}] +test fCmd-9.10 {file rename: comprehensive: file to new name and dir} { + cleanup + createfile tf1 + createfile tf2 + file mkdir td1 + testchmod 444 tf2 + file rename tf1 [file join td1 tf3] + file rename tf2 [file join td1 tf4] + list [catch {glob tf*}] [lsort [glob [file join td1 t*]]] \ + [file writable [file join td1 tf3]] [file writable [file join td1 tf4]] +} [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}] +test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} { + cleanup + file mkdir td1 + file mkdir td2 + file mkdir td3 + if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { + testchmod 555 td2 + } + file rename td1 [file join td3 td3] + file rename td2 [file join td3 td4] + if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { + set w4 [file writable [file join td3 td4]] + } else { + set w4 0 + } + list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \ + [file writable [file join td3 td3]] $w4 +} [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}] +test fCmd-9.12 {file rename: comprehensive: target exists} { + cleanup + file mkdir [file join td1 td2] [file join td2 td1] + if {$tcl_platform(platform) != "macintosh"} { + testchmod 555 [file join td2 td1] + } + file mkdir [file join td3 td4] [file join td4 td3] + file rename -force td3 td4 + set msg [list [file exists td3] [file exists [file join td4 td3 td4]] \ + [catch {file rename td1 td2} msg] $msg] + if {$tcl_platform(platform) != "macintosh"} { + testchmod 755 [file join td2 td1] + } + set msg +} [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}] +test fCmd-9.13 {file rename: comprehensive: can't overwrite target} { + cleanup + file mkdir [file join td1 td2] [file join td2 td1 td4] + list [catch {file rename -force td1 td2} msg] $msg +} [subst {1 {error renaming "td1" to "[file join td2 td1]": file already exists}}] +test fCmd-9.14 {file rename: comprehensive: dir into self} { + cleanup + file mkdir td1 + list [glob td*] [list [catch {file rename td1 td1} msg] $msg] +} [subst {td1 {1 {error renaming "td1" to "[file join td1 td1]": trying to rename a volume or move a directory into itself}}}] +test fCmd-9.15 {file rename: comprehensive: source and target incompatible} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {file rename -force td1 tf1} msg] $msg +} {1 {can't overwrite file "tf1" with directory "td1"}} +test fCmd-9.16 {file rename: comprehensive: source and target incompatible} { + cleanup + file mkdir td1/tf1 + createfile tf1 + list [catch {file rename -force tf1 td1} msg] $msg +} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}] + +test fCmd-10.1 {file copy: comprehensive: source doesn't exist} { + cleanup + list [catch {file copy tf1 tf2} msg] $msg +} {1 {error copying "tf1": no such file or directory}} +test fCmd-10.2 {file copy: comprehensive: file to new name} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + testchmod 444 tf2 + file copy tf1 tf3 + file copy tf2 tf4 + list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4] +} {{tf1 tf2 tf3 tf4} tf1 tf2 1 0} +test fCmd-10.3 {file copy: comprehensive: dir to new name} {unixOrPc} { + cleanup + file mkdir [file join td1 tdx] + file mkdir [file join td2 tdy] + testchmod 555 td2 + file copy td1 td3 + file copy td2 td4 + set msg [list [lsort [glob td*]] [glob [file join td3 t*]] \ + [glob [file join td4 t*]] [file writable td3] [file writable td4]] + if {$tcl_platform(platform) != "macintosh"} { + testchmod 755 td2 + testchmod 755 td4 + } + set msg +} [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0}] +test fCmd-10.4 {file copy: comprehensive: file to existing file} { + cleanup + createfile tf1 + createfile tf2 + createfile tfs1 + createfile tfs2 + createfile tfs3 + createfile tfs4 + createfile tfd1 + createfile tfd2 + createfile tfd3 + createfile tfd4 + testchmod 444 tfs3 + testchmod 444 tfs4 + testchmod 444 tfd2 + testchmod 444 tfd4 + set msg [list [catch {file copy tf1 tf2} msg] $msg] + file copy -force tfs1 tfd1 + file copy -force tfs2 tfd2 + file copy -force tfs3 tfd3 + file copy -force tfs4 tfd4 + list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] +} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0} +test fCmd-10.5 {file copy: comprehensive: dir to empty dir} { + cleanup + file mkdir td1 + file mkdir [file join td2 td1] + file mkdir tds1 + file mkdir tds2 + file mkdir tds3 + file mkdir tds4 + file mkdir [file join tdd1 tds1] + file mkdir [file join tdd2 tds2] + file mkdir [file join tdd3 tds3] + file mkdir [file join tdd4 tds4] + if {$tcl_platform(platform) != "macintosh"} { + testchmod 555 tds3 + testchmod 555 tds4 + testchmod 555 [file join tdd2 tds2] + testchmod 555 [file join tdd4 tds4] + } + set a1 [list [catch {file copy td1 td2} msg] $msg] + set a2 [list [catch {file copy -force tds1 tdd1} msg] $msg] + set a3 [catch {file copy -force tds2 tdd2}] + set a4 [catch {file copy -force tds3 tdd3}] + set a5 [catch {file copy -force tds4 tdd4}] + list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 +} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}] +test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} {unixOrPc} { + cleanup + file mkdir tds1 + file mkdir tds2 + file mkdir [file join tdd1 tds1 xxx] + file mkdir [file join tdd2 tds2 xxx] + testchmod 555 tds2 + set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg] + set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg] + list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2] +} [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}] +test fCmd-10.7 {file rename: comprehensive: file to new name and dir} { + cleanup + createfile tf1 + createfile tf2 + file mkdir td1 + testchmod 444 tf2 + file copy tf1 [file join td1 tf3] + file copy tf2 [file join td1 tf4] + list [lsort [glob tf*]] [lsort [glob [file join td1 t*]]] \ + [file writable [file join td1 tf3]] [file writable [file join td1 tf4]] +} [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}] +test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} {unixOrPc} { + cleanup + file mkdir td1 + file mkdir td2 + file mkdir td3 + testchmod 555 td2 + file copy td1 [file join td3 td3] + file copy td2 [file join td3 td4] + list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \ + [file writable [file join td3 td3]] [file writable [file join td3 td4]] +} [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}] +test fCmd-10.9 {file copy: comprehensive: source and target incompatible} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {file copy -force td1 tf1} msg] $msg +} {1 {can't overwrite file "tf1" with directory "td1"}} +test fCmd-10.10 {file copy: comprehensive: source and target incompatible} { + cleanup + file mkdir [file join td1 tf1] + createfile tf1 + list [catch {file copy -force tf1 td1} msg] $msg +} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}] +cleanup + +# old tests + +test fCmd-11.1 {TclFileRenameCmd: -- option } { + catch {file delete -force -- -tfa1} + set s [createfile -tfa1] + file rename -- -tfa1 tfa2 + set result [expr [checkcontent tfa2 $s] && ![file exists -tfa1]] + file delete tfa2 + set result +} {1} + +test fCmd-11.2 {TclFileRenameCmd: bad option } { + catch {file delete -force -- tfa1} + set s [createfile tfa1] + set r1 [catch {file rename -x tfa1 tfa2}] + set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]] + file delete tfa1 + set result +} {1} + +test fCmd-11.3 {TclFileRenameCmd: bad \# args} { + catch {file rename -- } +} {1} + +test fCmd-11.4 {TclFileRenameCmd: target filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file rename tfa ~/foobar }] + set env(HOME) $temp + set result + } {1} + +test fCmd-11.5 {TclFileRenameCmd: more than one source and target is not a directory} { + catch {file delete -force -- tfa1 tfa2 tfa3} + createfile tfa1 + createfile tfa2 + createfile tfa3 + set result [catch {file rename tfa1 tfa2 tfa3}] + file delete tfa1 tfa2 tfa3 + set result +} {1} + +test fCmd-11.6 {TclFileRenameCmd: : single file into directory } { + catch {file delete -force -- tfa1 tfad} + set s [createfile tfa1] + file mkdir tfad + file rename tfa1 tfad + set result [expr [checkcontent tfad/tfa1 $s] && ![file exists tfa1]] + file delete -force tfad + set result +} {1} + +test fCmd-11.7 {TclFileRenameCmd: : multiple files into directory } { + catch {file delete -force -- tfa1 tfa2 tfad} + set s1 [createfile tfa1 ] + set s2 [createfile tfa2 ] + file mkdir tfad + file rename tfa1 tfa2 tfad + set r1 [checkcontent tfad/tfa1 $s1] + set r2 [checkcontent tfad/tfa2 $s2] + + set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfa2]] + + file delete -force tfad + set result +} {1} + +test fCmd-11.8 {TclFileRenameCmd: error renaming file to directory } { + catch {file delete -force -- tfa tfad} + set s [createfile tfa ] + file mkdir tfad + file mkdir tfad/tfa + set r1 [catch {file rename tfa tfad}] + set r2 [checkcontent tfa $s] + set r3 [file isdir tfad] + set result [expr $r1 && $r2 && $r3 ] + file delete -force tfa tfad + set result +} {1} + +# +# Coverage tests for renamefile() ; +# +test fCmd-12.1 {renamefile: source filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file rename ~/tfa1 tfa2}] + set env(HOME) $temp + set result +} {1} + +test fCmd-12.2 {renamefile: src filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set s [createfile tfa1] + file mkdir tfad + set result [catch {file rename tfa1 ~/tfa2 tfad}] + set env(HOME) $temp + file delete -force tfad + set result +} {1} + +test fCmd-12.3 {renamefile: stat failing on source} { + catch {file delete -force -- tfa1 tfa2} + set r1 [catch {file rename tfa1 tfa2}] + expr {$r1 && ![file exists tfa1] && ![file exists tfa2]} +} {1} + +test fCmd-12.4 {renamefile: error renaming file to directory } { + catch {file delete -force -- tfa tfad} + set s1 [createfile tfa ] + file mkdir tfad + file mkdir tfad/tfa + set r1 [catch {file rename tfa tfad}] + set r2 [checkcontent tfa $s1] + set r3 [file isdir tfad/tfa] + set result [expr $r1 && $r2 && $r3] + file delete -force tfa tfad + set result +} {1} + +test fCmd-12.5 {renamefile: error renaming directory to file } { + catch {file delete -force -- tfa tfad} + file mkdir tfa + file mkdir tfad + set s [createfile tfad/tfa] + set r1 [catch {file rename tfa tfad}] + set r2 [checkcontent tfad/tfa $s] + set r3 [file isdir tfad] + set r4 [file isdir tfa] + set result [expr $r1 && $r2 && $r3 && $r4 ] + file delete -force tfa tfad + set result +} {1} + +test fCmd-12.6 {renamefile: TclRenameFile succeeding } { + catch {file delete -force -- tfa1 tfa2} + set s [createfile tfa1] + file rename tfa1 tfa2 + set result [expr [checkcontent tfa2 $s] && ![file exists tfa1]] + file delete tfa2 + set result +} {1} + +test fCmd-12.7 {renamefile: renaming directory into offspring} { + catch {file delete -force -- tfad} + file mkdir tfad + file mkdir tfad/dir + set result [catch {file rename tfad tfad/dir}] + file delete -force tfad + set result +} {1} + +test fCmd-12.8 {renamefile: generic error } {unixOnly} { + catch {file delete -force -- tfa} + file mkdir tfa + file mkdir tfa/dir + exec chmod 555 tfa + set result [catch {file rename tfa/dir tfa2}] + exec chmod 777 tfa + file delete -force tfa + set result +} {1} + + +test fCmd-12.9 {renamefile: moving a file across volumes } {unixOnly} { + catch {file delete -force -- tfa /tmp/tfa} + set s [createfile tfa ] + file rename tfa /tmp + set result [expr [checkcontent /tmp/tfa $s] && ![file exists tfa]] + file delete /tmp/tfa + set result +} {1} + +test fCmd-12.10 {renamefile: moving a directory across volumes } {unixOnly} { + catch {file delete -force -- tfad /tmp/tfad} + file mkdir tfad + set s [createfile tfad/a ] + file rename tfad /tmp + set restul [expr [checkcontent /tmp/tfad/a $s] && ![file exists tfad]] + file delete -force /tmp/tfad + set result +} {1} + +# +# Coverage tests for TclCopyFilesCmd() +# +test fCmd-13.1 {TclCopyFilesCmd: -force option } { + catch {file delete -force -- tfa1} + set s [createfile tfa1] + file copy -force tfa1 tfa2 + set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]] + file delete tfa1 tfa2 + set result +} {1} + +test fCmd-13.2 {TclCopyFilesCmd: -- option } { + catch {file delete -force -- tfa1} + set s [createfile -tfa1] + file copy -- -tfa1 tfa2 + set result [expr [checkcontent tfa2 $s] && [checkcontent -tfa1 $s]] + file delete -- -tfa1 tfa2 + set result +} {1} + +test fCmd-13.3 {TclCopyFilesCmd: bad option } { + catch {file delete -force -- tfa1} + set s [createfile tfa1] + set r1 [catch {file copy -x tfa1 tfa2}] + set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]] + file delete tfa1 + set result +} {1} + +test fCmd-13.4 {TclCopyFilesCmd: bad \# args} { + catch {file copy -- } +} {1} + +test fCmd-13.5 {TclCopyFilesCmd: target filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file copy tfa ~/foobar }] + set env(HOME) $temp + set result + } {1} + +test fCmd-13.6 {TclCopyFilesCmd: more than one source and target is not a directory} { + catch {file delete -force -- tfa1 tfa2 tfa3} + createfile tfa1 + createfile tfa2 + createfile tfa3 + set result [catch {file copy tfa1 tfa2 tfa3}] + file delete tfa1 tfa2 tfa3 + set result +} {1} + +test fCmd-13.7 {TclCopyFilesCmd: : single file into directory } { + catch {file delete -force -- tfa1 tfad} + set s [createfile tfa1] + file mkdir tfad + file copy tfa1 tfad + set result [expr [checkcontent tfad/tfa1 $s] && [checkcontent tfa1 $s]] + file delete -force tfad tfa1 + set result +} {1} + +test fCmd-13.8 {TclCopyFilesCmd: : multiple files into directory } { + catch {file delete -force -- tfa1 tfa2 tfad} + set s1 [createfile tfa1 ] + set s2 [createfile tfa2 ] + file mkdir tfad + file copy tfa1 tfa2 tfad + set r1 [checkcontent tfad/tfa1 $s1] + set r2 [checkcontent tfad/tfa2 $s2] + set r3 [checkcontent tfa1 $s1] + set r4 [checkcontent tfa2 $s2] + set result [expr $r1 && $r2 && $r3 && $r4 ] + + file delete -force tfad tfa1 tfa2 + set result +} {1} + +test fCmd-13.9 {TclCopyFilesCmd: error copying file to directory } { + catch {file delete -force -- tfa tfad} + set s [createfile tfa ] + file mkdir tfad + file mkdir tfad/tfa + set r1 [catch {file copy tfa tfad}] + set r2 [expr [checkcontent tfa $s] && [file isdir tfad/tfa]] + set r3 [file isdir tfad] + set result [expr $r1 && $r2 && $r3 ] + file delete -force tfa tfad + set result +} {1} + +# +# Coverage tests for copyfile() +# +test fCmd-14.1 {copyfile: source filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file copy ~/tfa1 tfa2}] + set env(HOME) $temp + set result +} {1} + +test fCmd-14.2 {copyfile: dst filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set s [createfile tfa1] + file mkdir tfad + set r1 [catch {file copy tfa1 ~/tfa2 tfad}] + set result [expr $r1 && [checkcontent tfad/tfa1 $s]] + set env(HOME) $temp + file delete -force tfa1 tfad + set result +} {1} + +test fCmd-14.3 {copyfile: stat failing on source} { + catch {file delete -force -- tfa1 tfa2} + set r1 [catch {file copy tfa1 tfa2}] + expr $r1 && ![file exists tfa1] && ![file exists tfa2] +} {1} + +test fCmd-14.4 {copyfile: error copying file to directory } { + catch {file delete -force -- tfa tfad} + set s1 [createfile tfa ] + file mkdir tfad + file mkdir tfad/tfa + set r1 [catch {file copy tfa tfad}] + set r2 [checkcontent tfa $s1] + set r3 [file isdir tfad] + set r4 [file isdir tfad/tfa] + set result [expr $r1 && $r2 && $r3 && $r4 ] + file delete -force tfa tfad + set result +} {1} + + test fCmd-14.5 {copyfile: error copying directory to file } { + catch {file delete -force -- tfa tfad} + file mkdir tfa + file mkdir tfad + set s [createfile tfad/tfa] + set r1 [catch {file copy tfa tfad}] + set r2 [checkcontent tfad/tfa $s] + set r3 [file isdir tfad] + set r4 [file isdir tfa] + set result [expr $r1 && $r2 && $r3 && $r4 ] + file delete -force tfa tfad + set result +} {1} + +test fCmd-14.6 {copyfile: copy file succeeding } { + catch {file delete -force -- tfa tfa2} + set s [createfile tfa] + file copy tfa tfa2 + set result [expr [checkcontent tfa $s] && [checkcontent tfa2 $s]] + file delete tfa tfa2 + set result +} {1} + +test fCmd-14.7 {copyfile: copy directory succeeding } { + catch {file delete -force -- tfa tfa2} + file mkdir tfa + set s [createfile tfa/file] + file copy tfa tfa2 + set result [expr [checkcontent tfa/file $s] && [checkcontent tfa2/file $s]] + file delete -force tfa tfa2 + set result +} {1} + +test fCmd-14.8 {copyfile: copy directory failing } {unixOnly} { + catch {file delete -force -- tfa} + file mkdir tfa/dir/a/b/c + exec chmod 000 tfa/dir + set r1 [catch {file copy tfa tfa2}] + exec chmod 777 tfa/dir + set result $r1 + file delete -force tfa tfa2 + set result +} {1} + +# +# Coverage tests for TclMkdirCmd() +# +test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file mkdir ~/tfa}] + set env(HOME) $temp + set result +} {1} +# +# Can Tcl_SplitPath return argc == 0? If so them we need a +# test for that code. +# +test fCmd-15.2 {TclMakeDirsCmd - one directory } { + catch {file delete -force -- tfa} + file mkdir tfa + set result [file isdirectory tfa] + file delete tfa + set result +} {1} + +test fCmd-15.3 {TclMakeDirsCmd: - two directories } { + catch {file delete -force -- tfa1 tfa2} + file mkdir tfa1 tfa2 + set result [expr [file isdirectory tfa1] && [file isdirectory tfa2]] + file delete tfa1 tfa2 + set result +} {1} + +test fCmd-15.4 {TclMakeDirsCmd - stat failing } {unixOnly} { + catch {file delete -force -- tfa} + file mkdir tfa + createfile tfa/file + exec chmod 000 tfa + set result [catch {file mkdir tfa/file}] + exec chmod 777 tfa + file delete -force tfa + set result +} {1} + +test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep } { + catch {file delete -force -- tfa} + file mkdir tfa/a/b/c + set result [file isdir tfa/a/b/c] + file delete -force tfa + set result +} {1} + + +test fCmd-15.6 {TclMakeDirsCmd: - trying to overwrite a file } { + catch {file delete -force -- tfa} + set s [createfile tfa] + set r1 [catch {file mkdir tfa}] + set r2 [file isdir tfa] + set r3 [file exists tfa] + set result [expr $r1 && !$r2 && $r3 && [checkcontent tfa $s]] + file delete tfa + set result +} {1} + +test fCmd-15.7 {TclMakeDirsCmd - making several directories } { + catch {file delete -force -- tfa1 tfa2} + file mkdir tfa1 tfa2/a/b/c + set result [expr [file isdir tfa1] && [file isdir tfa2/a/b/c]] + file delete -force tfa1 tfa2 + set result +} {1} + +test fCmd-15.8 {TclFileMakeDirsCmd: trying to create an existing dir} { + file mkdir tfa + file mkdir tfa + set result [file isdir tfa] + file delete tfa + set result +} {1} + + +# Coverage tests for TclDeleteFilesCommand() +test fCmd-16.1 { test the -- argument } { + catch {file delete -force -- tfa} + createfile tfa + file delete -- tfa + file exists tfa +} {0} + +test fCmd-16.2 { test the -force and -- arguments } { + catch {file delete -force -- tfa} + createfile tfa + file delete -force -- tfa + file exists tfa +} {0} + +test fCmd-16.3 { test bad option } { + catch {file delete -force -- tfa} + createfile tfa + set result [catch {file delete -dog tfa}] + file delete tfa + set result +} {1} + +test fCmd-16.4 { test not enough args } { + catch {file delete} +} {1} + +test fCmd-16.5 { test not enough args with options } { + catch {file delete --} +} {1} + +test fCmd-16.6 {delete: source filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file delete ~/tfa}] + set env(HOME) $temp + set result +} {1} + +test fCmd-16.7 {remove a non-empty directory without -force } { + catch {file delete -force -- tfa} + file mkdir tfa + createfile tfa/a + set result [catch {file delete tfa }] + file delete -force tfa + set result +} {1} + +test fCmd-16.8 {remove a normal file } { + catch {file delete -force -- tfa} + file mkdir tfa + createfile tfa/a + set result [catch {file delete tfa }] + file delete -force tfa + set result +} {1} + +test fCmd-16.9 {error while deleting file } {unixOnly} { + catch {file delete -force -- tfa} + file mkdir tfa + createfile tfa/a + exec chmod 555 tfa + set result [catch {file delete tfa/a }] + ####### + ####### If any directory in a tree that is being removed does not + ####### have write permission, the process will fail! + ####### This is also the case with "rm -rf" + ####### + exec chmod 777 tfa + file delete -force tfa + set result +} {1} + +test fCmd-16.10 {deleting multiple files } { + catch {file delete -force -- tfa1 tfa2} + createfile tfa1 + createfile tfa2 + file delete tfa1 tfa2 + expr ![file exists tfa1] && ![file exists tfa2] +} {1} + +test fCmd-16.11 { TclFileDeleteCmd: removing a nonexistant file} { + catch {file delete -force -- tfa} + file delete tfa + set result 1 +} {1} + +# More coverage tests for mkpath() + test fCmd-17.1 {mkdir stat failing on target but not ENOENT } {unixOnly} { + catch {file delete -force -- tfa1} + file mkdir tfa1 + exec chmod 555 tfa1 + set result [catch {file mkdir tfa1/tfa2}] + exec chmod 777 tfa1 + file delete -force tfa1 + set result +} {1} + +test fCmd-17.2 {mkdir several levels deep - relative } { + catch {file delete -force -- tfa} + file mkdir tfa/a/b + set result [file isdir tfa/a/b ] + file delete tfa/a/b tfa/a tfa + set result +} {1} + +test fCmd-17.3 {mkdir several levels deep - absolute } { + catch {file delete -force -- tfa} + set f [file join [pwd] tfa a ] + file mkdir $f + set result [file isdir $f ] + file delete $f [file join [pwd] tfa] + set result +} {1} + +# +# Functionality tests for TclFileRenameCmd() +# + +test fCmd-18.1 {TclFileRenameCmd: rename (first form) in the same directory} { + catch {file delete -force -- tfad} + file mkdir tfad/dir + cd tfad/dir + set s [createfile foo ] + file rename foo bar + file rename bar ./foo + file rename ./foo bar + file rename ./bar ./foo + file rename foo ../dir/bar + file rename ../dir/bar ./foo + file rename ../../tfad/dir/foo ../../tfad/dir/bar + file rename [file join [pwd] bar] foo + file rename foo [file join [pwd] bar] + set result [expr [checkcontent bar $s] && ![file exists foo]] + cd ../.. + file delete -force tfad + set result +} {1} + +test fCmd-18.2 {TclFileRenameCmd: single dir to nonexistant } { + catch {file delete -force -- tfa1 tfa2} + file mkdir tfa1 + file rename tfa1 tfa2 + set result [expr [file exists tfa2] && ![file exists tfa1]] + file delete tfa2 + set result +} {1} + +test fCmd-18.3 {TclFileRenameCmd: mixed dirs and files into directory } { + catch {file delete -force -- tfa1 tfad1 tfad2} + set s [createfile tfa1 ] + file mkdir tfad1 tfad2 + file rename tfa1 tfad1 tfad2 + set r1 [checkcontent tfad2/tfa1 $s] + set r2 [file isdir tfad2/tfad1] + set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfad1]] + file delete tfad2/tfa1 + file delete -force tfad2 + set result +} {1} + +test fCmd-18.4 {TclFileRenameCmd: attempt to replace non-dir with dir } { + catch {file delete -force -- tfa tfad} + set s [createfile tfa ] + file mkdir tfad + set r1 [catch {file rename tfad tfa}] + set r2 [checkcontent tfa $s] + set r3 [file isdir tfad] + set result [expr $r1 && $r2 && $r3 ] + file delete tfa tfad + set result +} {1} + +test fCmd-18.5 {TclFileRenameCmd: attempt to replace dir with non-dir } { + catch {file delete -force -- tfa tfad} + set s [createfile tfa ] + file mkdir tfad/tfa + set r1 [catch {file rename tfa tfad}] + set r2 [checkcontent tfa $s] + set r3 [file isdir tfad/tfa] + set result [expr $r1 && $r2 && $r3 ] + file delete -force tfa tfad + set result +} {1} + +# +# On Windows there is no easy way to determine if two files are the same +# +test fCmd-18.6 {TclFileRenameCmd: rename a file to itself} {macOrUnix} { + catch {file delete -force -- tfa} + set s [createfile tfa] + set r1 [catch {file rename tfa tfa}] + set result [expr $r1 && [checkcontent tfa $s]] + file delete tfa + set result +} {1} + +test fCmd-18.7 {TclFileRenameCmd: rename dir on top of another empty dir w/o -force} { + catch {file delete -force -- tfa tfad} + file mkdir tfa tfad/tfa + set r1 [catch {file rename tfa tfad}] + set result [expr $r1 && [file isdir tfa]] + file delete -force tfa tfad + set result +} {1} + +test fCmd-18.8 {TclFileRenameCmd: rename dir on top of another empty dir w/ -force} { + catch {file delete -force -- tfa tfad} + file mkdir tfa tfad/tfa + file rename -force tfa tfad + set result [expr ![file isdir tfa]] + file delete -force tfad + set result +} {1} + +test fCmd-18.9 {TclFileRenameCmd: rename dir on top of a non-empty dir w/o -force} { + catch {file delete -force -- tfa tfad} + file mkdir tfa tfad/tfa/file + set r1 [catch {file rename tfa tfad}] + set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]] + file delete -force tfa tfad + set result +} {1} + +test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} { + catch {file delete -force -- tfa tfad} + file mkdir tfa tfad/tfa/file + set r1 [catch {file rename -force tfa tfad}] + set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]] + file delete -force tfa tfad + set result +} {1} + +test fCmd-18.11 {TclFileRenameCmd: rename a non-existant file} { + catch {file delete -force -- tfa1} + set r1 [catch {file rename tfa1 tfa2}] + set result [expr $r1 && ![file exists tfa1] && ![file exists tfa2]] +} {1} + +test fCmd-18.12 {TclFileRenameCmd : rename a symbolic link to file} {unixOnly} { + catch {file delete -force -- tfa1 tfa2 tfa3} + + set s [createfile tfa1] + exec ln -s tfa1 tfa2 + file rename tfa2 tfa3 + set t [file type tfa3] + set result [expr { $t == "link" }] + file delete tfa1 tfa3 + set result +} {1} + +test fCmd-18.13 {TclFileRenameCmd : rename a symbolic link to dir} {unixOnly} { + catch {file delete -force -- tfa1 tfa2 tfa3} + + file mkdir tfa1 + exec ln -s tfa1 tfa2 + file rename tfa2 tfa3 + set t [file type tfa3] + set result [expr { $t == "link" }] + file delete tfa1 tfa3 + set result +} {1} + +test fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} {unixOnly} { + catch {file delete -force -- tfa1 tfa2 tfa3} + + file mkdir tfa1/a/b/c/d + file mkdir tfa2 + set f [file join [pwd] tfa1/a/b] + set f2 [file join [pwd] {tfa2/b alias}] + exec ln -s $f $f2 + file rename {tfa2/b alias/c} tfa3 + set r1 [file isdir tfa3] + set r2 [file exists tfa1/a/b/c] + set result [expr $r1 && !$r2] + file delete -force tfa1 tfa2 tfa3 + set result +} {1} + +test fCmd-18.15 {TclFileRenameCmd : rename a file to a symlink dir} {unixOnly} { + catch {file delete -force -- tfa1 tfa2 tfalink} + + file mkdir tfa1 + set s [createfile tfa2] + exec ln -s tfa1 tfalink + + file rename tfa2 tfalink + set result [checkcontent tfa1/tfa2 $s ] + file delete -force tfa1 tfalink + set result +} {1} + +test fCmd-18.16 {TclFileRenameCmd : rename a dangling symlink} {unixOnly} { + catch {file delete -force -- tfa1 tfalink} + + file mkdir tfa1 + exec ln -s tfa1 tfalink + file delete tfa1 + file rename tfalink tfa2 + set result [expr [string compare [file type tfa2] "link"] == 0] + file delete tfa2 + set result +} {1} + + +# +# Coverage tests for TclUnixRmdir +# +test fCmd-19.1 { remove empty directory } { + catch {file delete -force -- tfa} + file mkdir tfa + file delete tfa + file exists tfa +} {0} + +test fCmd-19.2 { rmdir error besides EEXIST} {unixOnly} { + catch {file delete -force -- tfa} + file mkdir tfa + file mkdir tfa/a + exec chmod 555 tfa + set result [catch {file delete tfa/a}] + exec chmod 777 tfa + file delete -force tfa + set result +} {1} + +test fCmd-19.3 { recursive remove } { + catch {file delete -force -- tfa} + file mkdir tfa + file mkdir tfa/a + file delete -force tfa + file exists tfa +} {0} + +# +# TclUnixDeleteFile and TraversalDelete are covered by tests from the +# TclDeleteFilesCmd suite +# +# + +# +# Coverage tests for TraverseUnixTree(), called from TclDeleteFilesCmd +# + +test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } {unixOnly} { + catch {file delete -force -- tfa} + file mkdir tfa + file mkdir tfa/a + exec chmod 000 tfa/a + set result [catch {file delete -force tfa}] + exec chmod 777 tfa/a + file delete -force tfa + set result +} {1} + + +# +# Feature testing for TclCopyFilesCmd +# +test fCmd-21.1 {copy : single file to nonexistant } { + catch {file delete -force -- tfa1 tfa2} + set s [createfile tfa1] + file copy tfa1 tfa2 + set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]] + file delete tfa1 tfa2 + set result +} {1} + +test fCmd-21.2 {copy : single dir to nonexistant } { + catch {file delete -force -- tfa1 tfa2} + file mkdir tfa1 + file copy tfa1 tfa2 + set result [expr [file isdir tfa2] && [file isdir tfa1]] + file delete tfa1 tfa2 + set result +} {1} + +test fCmd-21.3 {copy : single file into directory } { + catch {file delete -force -- tfa1 tfad} + set s [createfile tfa1] + file mkdir tfad + file copy tfa1 tfad + set result [expr [checkcontent tfad/tfa1 $s] && [checkcontent tfa1 $s]] + file delete -force tfa1 tfad + set result +} {1} + +test fCmd-21.4 {copy : more than one source and target is not a directory} { + catch {file delete -force -- tfa1 tfa2 tfa3} + createfile tfa1 + createfile tfa2 + createfile tfa3 + set result [catch {file copy tfa1 tfa2 tfa3}] + file delete tfa1 tfa2 tfa3 + set result +} {1} + +test fCmd-21.5 {copy : multiple files into directory } { + catch {file delete -force -- tfa1 tfa2 tfad} + set s1 [createfile tfa1 ] + set s2 [createfile tfa2 ] + file mkdir tfad + file copy tfa1 tfa2 tfad + set r1 [checkcontent tfad/tfa1 $s1] + set r2 [checkcontent tfad/tfa2 $s2] + set r3 [checkcontent tfa1 $s1] + set r4 [checkcontent tfa2 $s2] + set result [expr $r1 && $r2 && $r3 && $r4] + file delete -force tfa1 tfa2 tfad + set result +} {1} + +test fCmd-21.6 {copy : mixed dirs and files into directory } {notFileSharing} { + catch {file delete -force -- tfa1 tfad1 tfad2} + set s [createfile tfa1 ] + file mkdir tfad1 tfad2 + file copy tfa1 tfad1 tfad2 + set r1 [checkcontent [file join tfad2 tfa1] $s] + set r2 [file isdir [file join tfad2 tfad1]] + set r3 [checkcontent tfa1 $s] + set result [expr $r1 && $r2 && $r3 && [file isdir tfad1]] + file delete -force tfa1 tfad1 tfad2 + set result +} {1} + +test fCmd-21.7 {TclCopyFilesCmd : copy a dangling link } {unixOnly} { + file mkdir tfad1 + exec ln -s tfad1 tfalink + file delete tfad1 + file copy tfalink tfalink2 + set result [string match [file type tfalink2] link] + file delete tfalink tfalink2 + set result +} {1} + +test fCmd-21.8 {TclCopyFilesCmd : copy a link } {unixOnly} { + file mkdir tfad1 + exec ln -s tfad1 tfalink + file copy tfalink tfalink2 + set r1 [file type tfalink] + set r2 [file type tfalink2] + set r3 [file isdir tfad1] + set result [expr {("$r1" == "link" ) && ("$r2" == "link" ) && $r3}] + file delete tfad1 tfalink tfalink2 + set result +} {1} + +test fCmd-21.9 {TclCopyFilesCmd : copy dir with a link in it } {unixOnly} { + file mkdir tfad1 + exec ln -s "[pwd]/tfad1" tfad1/tfalink + file copy tfad1 tfad2 + set result [string match [file type tfad2/tfalink] link] + file delete -force tfad1 tfad2 + set result +} {1} + +test fCmd-21.10 {TclFileCopyCmd: copy dir on top of another empty dir w/o -force} { + catch {file delete -force -- tfa tfad} + file mkdir tfa [file join tfad tfa] + set r1 [catch {file copy tfa tfad}] + set result [expr $r1 && [file isdir tfa]] + file delete -force tfa tfad + set result +} {1} + +test fCmd-21.11 {TclFileCopyCmd: copy dir on top of a dir w/o -force} { + catch {file delete -force -- tfa tfad} + file mkdir tfa [file join tfad tfa file] + set r1 [catch {file copy tfa tfad}] + set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]] + file delete -force tfa tfad + set result +} {1} + +test fCmd-21.12 {TclFileCopyCmd: copy dir on top of a non-empty dir w/ -force} { + catch {file delete -force -- tfa tfad} + file mkdir tfa [file join tfad tfa file] + set r1 [catch {file copy -force tfa tfad}] + set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]] + file delete -force tfa tfad + set result +} {1} + +# +# Coverage testing for TclpRenameFile +# +test fCmd-22.1 { TclpRenameFile : rename and overwrite in a single dir } { + catch {file delete -force -- tfa1 tfa2} + set s [createfile tfa1] + set s2 [createfile tfa2 q] + + set r1 [catch {rename tfa1 tfa2}] + file rename -force tfa1 tfa2 + set result [expr $r1 && [checkcontent tfa2 $s]] + file delete [glob tfa1 tfa2] + set result +} {1} + +test fCmd-22.2 { TclpRenameFile : attempt to overwrite itself } {macOrUnix} { + catch {file delete -force -- tfa1} + set s [createfile tfa1] + file rename -force tfa1 tfa1 + set result [checkcontent tfa1 $s] + file delete tfa1 + set result +} {1} + +test fCmd-22.3 { TclpRenameFile : rename dir to existing dir } { + catch {file delete -force -- d1 tfad} + file mkdir d1 [file join tfad d1] + set r1 [catch {file rename d1 tfad}] + set result [expr $r1 && [file isdir d1] && [file isdir [file join tfad d1]]] + file delete -force d1 tfad + set result +} {1} + +test fCmd-22.4 { TclpRenameFile : rename dir to dir several levels deep } { + catch {file delete -force -- d1 tfad} + file mkdir d1 [file join tfad a b c] + file rename d1 [file join tfad a b c d1] + set result [expr ![file isdir d1] && [file isdir [file join tfad a b c d1]]] + file delete -force [glob d1 tfad] + set result +} {1} + + +# +# TclMacCopyFile needs to be redone. +# +test fCmd-22.5 { TclMacCopyFile : copy and overwrite in a single dir } { + catch {file delete -force -- tfa1 tfa2} + set s [createfile tfa1] + set s2 [createfile tfa2 q] + + set r1 [catch {file copy tfa1 tfa2}] + file copy -force tfa1 tfa2 + set result [expr $r1 && [checkcontent tfa2 $s] && [checkcontent tfa1 $s]] + file delete tfa1 tfa2 + set result +} {1} + +# +# TclMacMkdir - basic cases are covered elsewhere. +# Error cases are not covered. +# + +# +# TclMacRmdir +# Error cases are not covered. +# + +test fCmd-23.1 { TclMacRmdir : trying to remove a nonempty directory } { + catch {file delete -force -- tfad} + + file mkdir [file join tfad dir] + + set result [catch {file delete tfad}] + file delete -force tfad + set result +} {1} + +# +# TclMacDeleteFile +# Error cases are not covered. +# +test fCmd-24.1 { TclMacDeleteFile : deleting a normal file } { + catch {file delete -force -- tfa1} + + createfile tfa1 + file delete tfa1 + file exists tfa1 +} {0} + +# +# TclMacCopyDirectory +# Error cases are not covered. +# +test fCmd-25.1 { TclMacCopyDirectory : copying a normal directory} {notFileSharing} { + catch {file delete -force -- tfad1 tfad2} + + file mkdir [file join tfad1 a b c] + file copy tfad1 tfad2 + set result [expr [file isdir [file join tfad1 a b c]] && [file isdir [file join tfad2 a b c]]] + file delete -force tfad1 tfad2 + set result +} {1} + +test fCmd-25.2 { TclMacCopyDirectory : copying a short path normal directory} {notFileSharing} { + catch {file delete -force -- tfad1 tfad2} + + file mkdir tfad1 + file copy tfad1 tfad2 + set result [expr [file isdir tfad1] && [file isdir tfad2]] + file delete tfad1 tfad2 + set result +} {1} + +test fCmd-25.3 { TclMacCopyDirectory : copying dirs between different dirs} {notFileSharing} { + catch {file delete -force -- tfad1 tfad2} + + file mkdir [file join tfad1 x y z] + file mkdir [file join tfad2 dir] + file copy tfad1 [file join tfad2 dir] + set result [expr [file isdir [file join tfad1 x y z]] && [file isdir [file join tfad2 dir tfad1 x y z]]] + file delete -force tfad1 tfad2 + set result +} {1} + +# +# Functionality tests for TclDeleteFilesCmd +# + +test fCmd-26.1 { TclDeleteFilesCmd : delete symlink} {unixOnly} { + catch {file delete -force -- tfad1 tfad2} + + file mkdir tfad1 + exec ln -s tfad1 tfalink + file delete tfalink + + set r1 [file isdir tfad1] + set r2 [file exists tfalink] + + set result [expr $r1 && !$r2] + file delete tfad1 + set result +} {1} + +test fCmd-26.2 { TclDeleteFilesCmd : delete dir with symlink} {unixOnly} { + catch {file delete -force -- tfad1 tfad2} + + file mkdir tfad1 + file mkdir tfad2 + exec ln -s tfad1 [file join tfad2 link] + file delete -force tfad2 + + set r1 [file isdir tfad1] + set r2 [file exists tfad2] + + set result [expr $r1 && !$r2] + file delete tfad1 + set result +} {1} + +test fCmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly} { + catch {file delete -force -- tfad1 tfad2} + + file mkdir tfad1 + exec ln -s tfad1 tfad2 + file delete tfad1 + file delete tfad2 + + set r1 [file exists tfad1] + set r2 [file exists tfad2] + + set result [expr !$r1 && !$r2] + set result +} {1} + +test fCmd-27.1 {TclFileAttrsCmd - wrong # args} { + list [catch {file attributes a b c d} msg] $msg +} {1 {wrong # args: must be "file attributes name ?option? ?value? ?option value? ..."}} +test fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} { + testsetplatform unix + list [catch {file attributes ~_bad_user} msg] $msg [testsetplatform $platform] +} {1 {user "_bad_user" doesn't exist} {}} +test fCmd-27.3 {TclFileAttrsCmd - all attributes} { + catch {file delete -force -- foo.tmp} + createfile foo.tmp + list [catch {file attributes foo.tmp} msg] [expr {[llength $msg] > 0}] [file delete -force -- foo.tmp] +} {0 1 {}} +test fCmd-27.4 {TclFileAttrsCmd - getting one option} { + catch {file delete -force -- foo.tmp} + createfile foo.tmp + set attrs [file attributes foo.tmp] + list [catch {eval file attributes foo.tmp [lindex $attrs 0]}] [file delete -force -- foo.tmp] +} {0 {}} + +set testConfig(tclGroup) 0 +if {($tcl_platform(platform) == "macintosh") \ + || ($tcl_platform(platform) == "windows")} { + set testConfig(tclGroup) 1 +} elseif {[catch {exec {groups}} groupList] == 0} { + if {[lsearch $groupList tcl] != -1} { + set testConfig(tclGroup) 1 + } +} + +test fCmd-27.5 {TclFileAttrsCmd - setting one option} {tclGroup} { + catch {file delete -force -- foo.tmp} + createfile foo.tmp + set attrs [file attributes foo.tmp] + list [catch {eval file attributes foo.tmp [lrange $attrs 0 1]} msg] $msg [file delete -force -- foo.tmp] +} {0 {} {}} +test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {tclGroup} { + catch {file delete -force -- foo.tmp} + createfile foo.tmp + set attrs [file attributes foo.tmp] + list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp] +} {0 {} {}} + +cleanup diff --git a/contrib/tcl/tests/fileName.test b/contrib/tcl/tests/fileName.test index abb3eb857d20a..f7f45946aa35f 100644 --- a/contrib/tcl/tests/fileName.test +++ b/contrib/tcl/tests/fileName.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) fileName.test 1.23 96/07/31 11:46:11 +# SCCS: @(#) fileName.test 1.28 97/06/23 17:30:15 if {[string compare test [info procs test]] == 1} then {source defs} @@ -1095,14 +1095,11 @@ test filename-11.13 {Tcl_GlobCmd} { catch { set oldhome $env(HOME) set env(HOME) [pwd] - removeDirectory globTest - makeDirectory globTest - makeDirectory globTest/a1 - makeDirectory globTest/a2 - makeDirectory globTest/a3 - makeDirectory globTest/a1/b1 - makeDirectory globTest/a1/b2 - makeDirectory globTest/a2/b3 + file delete -force globTest + file mkdir globTest/a1/b1 + file mkdir globTest/a1/b2 + file mkdir globTest/a2/b3 + file mkdir globTest/a3 close [open globTest/x1.c w] close [open globTest/y1.c w] close [open globTest/z1.c w] @@ -1140,7 +1137,7 @@ if {$tcl_platform(platform) == "macintosh"} { } set x1 x1.c set y1 y1.c -test filename-12.4 {simple globbing} {unixOrPC} { +test filename-12.4 {simple globbing} {unixOrPc} { lsort [glob globTest/x1.c globTest/y1.c globTest/foo] } "$globPreResult$x1 $globPreResult$y1" test filename-12.5 {simple globbing} {unixExecs} { @@ -1183,89 +1180,89 @@ test filename-13.10 {globbing with brace substitution} {unixExecs} { test filename-13.11 {globbing with brace substitution} {unixOrPc unixExecs} { list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg } {0 {globTest/x1.c globTest/x,z1.c globTest/z1.c}} -test filename-13.11 {globbing with brace substitution} {macOnly} { +test filename-13.12 {globbing with brace substitution} {macOnly} { list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg } {0 {:globTest:x1.c :globTest:x,z1.c :globTest:z1.c}} -test filename-13.12 {globbing with brace substitution} {unixExecs} { +test filename-13.13 {globbing with brace substitution} {unixExecs} { lsort [glob globTest/{a,b,x,y}1.c] } [list $globPreResult$x1 $globPreResult$y1] -test filename-13.13 {globbing with brace substitution} {unixOrPc unixExecs} { +test filename-13.14 {globbing with brace substitution} {unixOrPc unixExecs} { lsort [glob {globTest/{x1,y2,weird name}.c}] } {{globTest/weird name.c} globTest/x1.c} -test filename-13.13 {globbing with brace substitution} {macOnly} { +test filename-13.15 {globbing with brace substitution} {macOnly} { lsort [glob {globTest/{x1,y2,weird name}.c}] } {{:globTest:weird name.c} :globTest:x1.c} -test filename-13.14 {globbing with brace substitution} {unixOrPc unixExecs} { +test filename-13.16 {globbing with brace substitution} {unixOrPc unixExecs} { lsort [glob globTest/{x1.c,a1/*}] } {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} -test filename-13.14 {globbing with brace substitution} {macOnly} { +test filename-13.17 {globbing with brace substitution} {macOnly} { lsort [glob globTest/{x1.c,a1/*}] } {:globTest:a1:b1 :globTest:a1:b2 :globTest:x1.c} -test filename-13.15 {globbing with brace substitution} {unixOrPc unixExecs} { +test filename-13.18 {globbing with brace substitution} {unixOrPc unixExecs} { lsort [glob globTest/{x1.c,{a},a1/*}] } {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} -test filename-13.15 {globbing with brace substitution} {macOnly} { +test filename-13.19 {globbing with brace substitution} {macOnly} { lsort [glob globTest/{x1.c,{a},a1/*}] } {:globTest:a1:b1 :globTest:a1:b2 :globTest:x1.c} -test filename-13.16 {globbing with brace substitution} {unixOrPc unixExecs} { +test filename-13.20 {globbing with brace substitution} {unixOrPc unixExecs} { lsort [glob globTest/{a,x}1/*/{x,y}*] } {globTest/a1/b1/x2.c globTest/a1/b2/y2.c} -test filename-13.16 {globbing with brace substitution} {macOnly} { +test filename-13.21 {globbing with brace substitution} {macOnly} { lsort [glob globTest/{a,x}1/*/{x,y}*] } {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c} -test filename-13.17 {globbing with brace substitution} {unixExecs} { +test filename-13.22 {globbing with brace substitution} {unixExecs} { list [catch {glob globTest/\{a,x\}1/*/\{} msg] $msg } {1 {unmatched open-brace in file name}} test filename-14.1 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { lsort [glob g*/*.c] } {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} -test filename-14.1 {asterisks, question marks, and brackets} {macOnly} { +test filename-14.2 {asterisks, question marks, and brackets} {macOnly} { lsort [glob g*/*.c] } {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c} -test filename-14.2 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { +test filename-14.3 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { lsort [glob globTest/?1.c] } {globTest/x1.c globTest/y1.c globTest/z1.c} -test filename-14.2 {asterisks, question marks, and brackets} {macOnly} { +test filename-14.4 {asterisks, question marks, and brackets} {macOnly} { lsort [glob globTest/?1.c] } {:globTest:x1.c :globTest:y1.c :globTest:z1.c} -test filename-14.3 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { +test filename-14.5 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { lsort [glob */*/*/*.c] } {globTest/a1/b1/x2.c globTest/a1/b2/y2.c} -test filename-14.3 {asterisks, question marks, and brackets} {macOnly} { +test filename-14.6 {asterisks, question marks, and brackets} {macOnly} { lsort [glob */*/*/*.c] } {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c} -test filename-14.4 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { +test filename-14.7 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { lsort [glob globTest/*] } {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} -test filename-14.4 {asterisks, question marks, and brackets} {macOnly} { +test filename-14.8 {asterisks, question marks, and brackets} {macOnly} { lsort [glob globTest/*] } {:globTest:.1 :globTest:a1 :globTest:a2 :globTest:a3 {:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c} -test filename-14.5 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { +test filename-14.9 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { lsort [glob globTest/.*] } {globTest/. globTest/.. globTest/.1} -test filename-14.5 {asterisks, question marks, and brackets} {macOnly} { +test filename-14.10 {asterisks, question marks, and brackets} {macOnly} { lsort [glob globTest/.*] } {:globTest:.1} -test filename-14.6 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { +test filename-14.11 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { lsort [glob globTest/*/*] } {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3} -test filename-14.6 {asterisks, question marks, and brackets} {macOnly} { +test filename-14.12 {asterisks, question marks, and brackets} {macOnly} { lsort [glob globTest/*/*] } {:globTest:a1:b1 :globTest:a1:b2 :globTest:a2:b3} -test filename-14.7 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { +test filename-14.13 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { lsort [glob {globTest/[xyab]1.*}] } {globTest/x1.c globTest/y1.c} -test filename-14.7 {asterisks, question marks, and brackets} {macOnly} { +test filename-14.14 {asterisks, question marks, and brackets} {macOnly} { lsort [glob {globTest/[xyab]1.*}] } {:globTest:x1.c :globTest:y1.c} -test filename-14.8 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { +test filename-14.15 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { lsort [glob globTest/*/] } {globTest/a1/ globTest/a2/ globTest/a3/} -test filename-14.8 {asterisks, question marks, and brackets} {macOnly} { +test filename-14.16 {asterisks, question marks, and brackets} {macOnly} { lsort [glob globTest/*/] } {:globTest:a1: :globTest:a2: :globTest:a3:} -test filename-14.9 {asterisks, question marks, and brackets} {unixExecs} { +test filename-14.17 {asterisks, question marks, and brackets} {unixExecs} { global env set temp $env(HOME) set env(HOME) [file join $env(HOME) globTest] @@ -1273,25 +1270,25 @@ test filename-14.9 {asterisks, question marks, and brackets} {unixExecs} { set env(HOME) $temp set result } [list 0 [list [file join $env(HOME) globTest z1.c]]] -test filename-14.10 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { +test filename-14.18 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg } {0 {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}} -test filename-14.10 {asterisks, question marks, and brackets} {macOnly} { +test filename-14.19 {asterisks, question marks, and brackets} {macOnly} { list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg } {0 {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}} -test filename-14.11 {asterisks, question marks, and brackets} { +test filename-14.20 {asterisks, question marks, and brackets} { list [catch {glob -nocomplain goo/*} msg] $msg } {0 {}} -test filename-14.12 {asterisks, question marks, and brackets} { +test filename-14.21 {asterisks, question marks, and brackets} { list [catch {glob globTest/*/gorp} msg] $msg } {1 {no files matched glob pattern "globTest/*/gorp"}} -test filename-14.13 {asterisks, question marks, and brackets} { +test filename-14.22 {asterisks, question marks, and brackets} { list [catch {glob goo/* x*z foo?q} msg] $msg } {1 {no files matched glob patterns "goo/* x*z foo?q"}} -test filename-14.14 {slash globbing} {unixOrPc} { +test filename-14.23 {slash globbing} {unixOrPc} { glob / } / -test filename-14.15 {slash globbing} {pcOnly} { +test filename-14.24 {slash globbing} {pcOnly} { glob {\\} } / @@ -1327,9 +1324,9 @@ if {$tcl_platform(platform) == "unix"} { if {$tcl_platform(platform) == "windows"} { set temp [pwd] cd c:/ - exec rm -rf globTest catch { - exec mkdir globTest + removeDirectory globTest + makeDirectory globTest close [open globTest/x1.BAT w] close [open globTest/y1.Bat w] close [open globTest/z1.bat w] @@ -1369,12 +1366,12 @@ if {$tcl_platform(platform) == "windows"} { lsort [glob c:\\\\globTest\\\\*.bat] } {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat} - exec rm -rf globTest + removeDirectory globTest if $testConfig(nonPortable) { cd //gaspode/d - exec rm -rf globTest - exec mkdir globTest + removeDirectory globTest + makeDirectory globTest close [open globTest/x1.BAT w] close [open globTest/y1.Bat w] @@ -1387,7 +1384,7 @@ if {$tcl_platform(platform) == "windows"} { glob {\\\\gaspode\\d\\*Test} } //gaspode/d/globTest - exec rm -rf globTest + removeDirectory globTest } cd $temp diff --git a/contrib/tcl/tests/for-old.test b/contrib/tcl/tests/for-old.test new file mode 100644 index 0000000000000..354f3d68baae6 --- /dev/null +++ b/contrib/tcl/tests/for-old.test @@ -0,0 +1,66 @@ +# Commands covered: for, continue, break +# +# This file contains the original set of tests for Tcl's for command. +# Since the for command is now compiled, a new set of tests covering +# the new implementation is in the file "for.test". Sourcing this file +# into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) for-old.test 1.14 97/01/13 13:42:18 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Check "for" and its use of continue and break. + +catch {unset a i} +test for-old-1.1 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + set a [concat $a $i] + } + set a +} {1 2 3 4 5} +test for-old-1.2 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 continue + set a [concat $a $i] + } + set a +} {1 2 3 5} +test for-old-1.3 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 break + set a [concat $a $i] + } + set a +} {1 2 3} +test for-old-1.4 {for tests} {catch {for 1 2 3} msg} 1 +test for-old-1.5 {for tests} { + catch {for 1 2 3} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-old-1.6 {for tests} {catch {for 1 2 3 4 5} msg} 1 +test for-old-1.7 {for tests} { + catch {for 1 2 3 4 5} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-old-1.8 {for tests} { + set a {xyz} + for {set i 1} {$i<6} {set i [expr $i+1]} {} + set a +} xyz +test for-old-1.9 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} { + set a [concat $a $i] + } + set a +} {1 2 3} diff --git a/contrib/tcl/tests/for.test b/contrib/tcl/tests/for.test index 16d8c9c029ab1..7b518febf0488 100644 --- a/contrib/tcl/tests/for.test +++ b/contrib/tcl/tests/for.test @@ -1,211 +1,592 @@ -# Commands covered: foreach, for, continue, break +# Commands covered: for, continue, break # # 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) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) for.test 1.11 96/02/16 08:55:55 +# SCCS: @(#) for.test 1.9 97/06/23 18:40:35 if {[string compare test [info procs test]] == 1} then {source defs} -# Basic "foreach" operation. +# Basic "for" operation. -test for-1.1 {basic foreach tests} { +test for-1.1 {TclCompileForCmd: missing initial command} { + list [catch {for} msg] $msg +} {1 {wrong # args: should be "for start test next command"}} +test for-1.2 {TclCompileForCmd: error in initial command} { + list [catch {for {set}} msg] $msg $errorInfo +} {1 {wrong # args: should be "for start test next command"} {wrong # args: should be "for start test next command" + while compiling +"for"}} +catch {unset i} +test for-1.3 {TclCompileForCmd: missing test expression} { + catch {for {set i 0}} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-1.4 {TclCompileForCmd: error in test expression} { + catch {for {set i 0} {$i<}} msg + set errorInfo +} {wrong # args: should be "for start test next command" + while compiling +"for"} +test for-1.5 {TclCompileForCmd: test expression is enclosed in quotes} { + set i 0 + for {} "$i > 5" {incr i} {} +} {} +test for-1.6 {TclCompileForCmd: missing "next" command} { + catch {for {set i 0} {$i < 5}} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-1.7 {TclCompileForCmd: missing command body} { + catch {for {set i 0} {$i < 5} {incr i}} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-1.8 {TclCompileForCmd: error compiling command body} { + catch {for {set i 0} {$i < 5} {incr i} {set}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("for" body line 1) + while compiling +"for"} +catch {unset a} +test for-1.9 {TclCompileForCmd: simple command body} { set a {} - foreach i {a b c d} { + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 break set a [concat $a $i] } set a -} {a b c d} -test for-1.2 {basic foreach tests} { +} {1 2 3} +test for-1.10 {TclCompileForCmd: command body in quotes} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} "append a x" + set a +} {xxxxx} +test for-1.11 {TclCompileForCmd: computed command body} { + catch {unset x1} + catch {unset bb} + catch {unset x2} + set x1 {append a x1; } + set bb {break} + set x2 {; append a x2} set a {} - foreach i {a b {{c d} e} {123 {{x}}}} { - set a [concat $a $i] - } + for {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2 set a -} {a b {c d} e 123 {{x}}} -test for-1.3 {basic foreach tests} {catch {foreach} msg} 1 -test for-1.4 {basic foreach tests} { - catch {foreach} msg - set msg -} {wrong # args: should be "foreach varList list ?varList list ...? command"} -test for-1.5 {basic foreach tests} {catch {foreach i} msg} 1 -test for-1.6 {basic foreach tests} { - catch {foreach i} msg - set msg -} {wrong # args: should be "foreach varList list ?varList list ...? command"} -test for-1.7 {basic foreach tests} {catch {foreach i j} msg} 1 -test for-1.8 {basic foreach tests} { - catch {foreach i j} msg - set msg -} {wrong # args: should be "foreach varList list ?varList list ...? command"} -test for-1.9 {basic foreach tests} {catch {foreach i j k l} msg} 1 -test for-1.10 {basic foreach tests} { - catch {foreach i j k l} msg - set msg -} {wrong # args: should be "foreach varList list ?varList list ...? command"} -test for-1.11 {basic foreach tests} { +} {x1} +test for-1.12 {TclCompileForCmd: error in "next" command} { + catch {for {set i 0} {$i < 5} {set} {puts $i}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("for" loop-end command) + while compiling +"for"} +test for-1.13 {TclCompileForCmd: long command body} { set a {} - foreach i {} { + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } set a [concat $a $i] } set a +} {1 2 3} +test for-1.14 {TclCompileForCmd: for command result} { + set a [for {set i 0} {$i < 5} {incr i} {}] + set a +} {} +test for-1.15 {TclCompileForCmd: for command result} { + set a [for {set i 0} {$i < 5} {incr i} {if $i==3 break}] + set a } {} -test for-1.11 {foreach errors} { - list [catch {foreach {{a}{b}} {1 2 3} {}} msg] $msg -} {1 {list element in braces followed by "{b}" instead of space}} -test for-1.12 {foreach errors} { - list [catch {foreach a {{1 2}3} {}} msg] $msg -} {1 {list element in braces followed by "3" instead of space}} -catch {unset a} -test for-1.13 {foreach errors} { - catch {unset a} - set a(0) 44 - list [catch {foreach a {1 2 3} {}} msg] $msg -} {1 {couldn't set loop variable: "a"}} -catch {unset a} -test for-1.14 {parallel foreach tests} { - set x {} - foreach {a b} {1 2 3 4} { - append x $b $a - } - set x -} {2143} -test for-1.15 {parallel foreach tests} { - set x {} - foreach {a b} {1 2 3 4 5} { - append x $b $a - } - set x -} {21435} -test for-1.16 {parallel foreach tests} { - set x {} - foreach a {1 2 3} b {4 5 6} { - append x $b $a - } - set x -} {415263} -test for-1.17 {parallel foreach tests} { - set x {} - foreach a {1 2 3} b {4 5 6 7 8} { - append x $b $a - } - set x -} {41526378} -test for-1.18 {parallel foreach tests} { - set x {} - foreach {a b} {a b A B aa bb} c {c C cc CC} { - append x $a $b $c - } - set x -} {abcABCaabbccCC} -test for-1.19 {parallel foreach tests} { - set x {} - foreach a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { - append x $a $b $c $d $e - } - set x -} {111112222233333} -test for-1.20 {parallel foreach tests} { - set x {} - foreach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { - append x $a $b $c $d $e - } - set x -} {1111 2222334} -# Check "continue". +# Check "for" and "continue". -test for-2.1 {continue tests} {catch continue} 4 -test for-2.2 {continue tests} { +test for-2.1 {TclCompileContinueCmd: arguments after "continue"} { + catch {continue foo} msg + set msg +} {wrong # args: should be "continue"} +test for-2.2 {TclCompileContinueCmd: continue result} { + catch continue +} 4 +test for-2.3 {continue tests} { set a {} - foreach i {a b c d} { - if {[string compare $i "b"] == 0} continue + for {set i 1} {$i <= 4} {set i [expr $i+1]} { + if {$i == 2} continue set a [concat $a $i] } set a -} {a c d} -test for-2.3 {continue tests} { +} {1 3 4} +test for-2.4 {continue tests} { set a {} - foreach i {a b c d} { - if {[string compare $i "b"] != 0} continue + for {set i 1} {$i <= 4} {set i [expr $i+1]} { + if {$i != 2} continue set a [concat $a $i] } set a -} {b} -test for-2.4 {continue tests} {catch {continue foo} msg} 1 -test for-2.5 {continue tests} { - catch {continue foo} msg +} {2} +test for-2.5 {continue tests, nested loops} { + set msg {} + for {set i 1} {$i <= 4} {incr i} { + for {set a 1} {$a <= 2} {incr a} { + if {$i>=2 && $a>=2} continue + set msg [concat $msg "$i.$a"] + } + } set msg -} {wrong # args: should be "continue"} - -# Check "break". - -test for-3.1 {break tests} {catch break} 3 -test for-3.2 {break tests} { +} {1.1 1.2 2.1 3.1 4.1} +test for-2.6 {continue tests, long command body} { set a {} - foreach i {a b c d} { - if {[string compare $i "c"] == 0} break + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==2 continue + if $i==4 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } set a [concat $a $i] } set a -} {a b} -test for-3.3 {break tests} {catch {break foo} msg} 1 -test for-3.4 {break tests} { +} {1 3} + +# Check "for" and "break". + +test for-3.1 {TclCompileBreakCmd: arguments after "break"} { catch {break foo} msg set msg } {wrong # args: should be "break"} - -# Check "for" and its use of continue and break. - -test for-4.1 {for tests} { +test for-3.2 {TclCompileBreakCmd: break result} { + catch break +} 3 +test for-3.3 {break tests} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { + for {set i 1} {$i <= 4} {incr i} { + if {$i == 3} break set a [concat $a $i] } set a -} {1 2 3 4 5} -test for-4.2 {for tests} { - set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 continue - set a [concat $a $i] +} {1 2} +test for-3.4 {break tests, nested loops} { + set msg {} + for {set i 1} {$i <= 4} {incr i} { + for {set a 1} {$a <= 2} {incr a} { + if {$i>=2 && $a>=2} break + set msg [concat $msg "$i.$a"] + } } - set a -} {1 2 3 5} -test for-4.3 {for tests} { + set msg +} {1.1 1.2 2.1 3.1 4.1} +test for-3.5 {break tests, long command body} { set a {} for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==2 continue + if $i==5 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } if $i==4 break + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } set a [concat $a $i] } set a -} {1 2 3} -test for-4.4 {for tests} {catch {for 1 2 3} msg} 1 -test for-4.5 {for tests} { - catch {for 1 2 3} msg - set msg -} {wrong # args: should be "for start test next command"} -test for-4.6 {for tests} {catch {for 1 2 3 4 5} msg} 1 -test for-4.7 {for tests} { - catch {for 1 2 3 4 5} msg - set msg -} {wrong # args: should be "for start test next command"} -test for-4.8 {for tests} { - set a {xyz} - for {set i 1} {$i<6} {set i [expr $i+1]} {} - set a -} xyz -test for-4.9 {for tests} { - set a {} - for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} { - set a [concat $a $i] +} {1 3} +# A simplified version of exmh's mail formatting routine to stress "for", +# "break", "while", and "if". +proc formatMail {} { + array set lines { + 0 {Return-path: george@tcl} \ + 1 {Return-path: <george@tcl>} \ + 2 {Received: from tcl by tcl.Somewhere.COM (SMI-8.6/SMI-SVR4)} \ + 3 { id LAA10027; Wed, 11 Sep 1996 11:14:53 -0700} \ + 4 {Message-id: <199609111814.LAA10027@tcl.Somewhere.COM>} \ + 5 {X-mailer: exmh version 1.6.9 8/22/96} \ + 6 {Mime-version: 1.0} \ + 7 {Content-type: text/plain; charset=iso-8859-1} \ + 8 {Content-transfer-encoding: quoted-printable} \ + 9 {Content-length: 2162} \ + 10 {To: fred} \ + 11 {Subject: tcl7.6} \ + 12 {Date: Wed, 11 Sep 1996 11:14:53 -0700} \ + 13 {From: George <george@tcl>} \ + 14 {The Tcl 7.6 and Tk 4.2 releases} \ + 15 {} \ + 16 {This page contains information about Tcl 7.6 and Tk4.2, which are the most recent} \ + 17 {releases of the Tcl scripting language and the Tk toolkit. The first beta versions of these} \ + 18 {releases were released on August 30, 1996. These releases contain only minor changes,} \ + 19 {so we hope to have only a single beta release and to go final in early October, 1996. } \ + 20 {} \ + 21 {} \ + 22 {What's new } \ + 23 {} \ + 24 {The most important changes in the releases are summarized below. See the README} \ + 25 {and changes files in the distributions for more complete information on what has} \ + 26 {changed, including both feature changes and bug fixes. } \ + 27 {} \ + 28 { There are new options to the file command for copying files (file copy),} \ + 29 { deleting files and directories (file delete), creating directories (file} \ + 30 { mkdir), and renaming files (file rename). } \ + 31 { The implementation of exec has been improved greatly for Windows 95 and} \ + 32 { Windows NT. } \ + 33 { There is a new memory allocator for the Macintosh version, which should be} \ + 34 { more efficient than the old one. } \ + 35 { Tk's grid geometry manager has been completely rewritten. The layout} \ + 36 { algorithm produces much better layouts than before, especially where rows or} \ + 37 { columns were stretchable. } \ + 38 { There are new commands for creating common dialog boxes:} \ + 39 { tk_chooseColor, tk_getOpenFile, tk_getSaveFile and} \ + 40 { tk_messageBox. These use native dialog boxes if they are available. } \ + 41 { There is a new virtual event mechanism for handling events in a more portable} \ + 42 { way. See the new command event. It also allows events (both physical and} \ + 43 { virtual) to be generated dynamically. } \ + 44 {} \ + 45 {Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl 7.5 and Tk 4.1 except for} \ + 46 {changes in the C APIs for custom channel drivers. Scripts written for earlier releases} \ + 47 {should work on these new releases as well. } \ + 48 {} \ + 49 {Obtaining The Releases} \ + 50 {} \ + 51 {Binary Releases} \ + 52 {} \ + 53 {Pre-compiled releases are available for the following platforms: } \ + 54 {} \ + 55 { Windows 3.1, Windows 95, and Windows NT: Fetch} \ + 56 { ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then execute it. The file is a} \ + 57 { self-extracting executable. It will install the Tcl and Tk libraries, the wish and} \ + 58 { tclsh programs, and documentation. } \ + 59 { Macintosh (both 68K and PowerPC): Fetch} \ + 60 { ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. The file is in binhex format,} \ + 61 { which is understood by Fetch, StuffIt, and many other Mac utilities. The} \ + 62 { unpacked file is a self-installing executable: double-click on it and it will create a} \ + 63 { folder containing all that you need to run Tcl and Tk. } \ + 64 { UNIX (Solaris 2.* and SunOS, other systems soon to follow). Easy to install} \ + 65 { binary packages are now for sale at the Sun Labs Tcl/Tk Shop. Check it out!} \ } - set a -} {1 2 3} + + set result "" + set NL " +" + set tag {level= type=text/plain part=0 sel Charset} + set ix [lsearch -regexp $tag text/enriched] + if {$ix < 0} { + set ranges {} + set quote 0 + } + set breakrange {6.42 78.0} + set F1 [lindex $breakrange 0] + set F2 [lindex $breakrange 1] + set breakrange [lrange $breakrange 2 end] + if {[string length $F1] == 0} { + set F1 -1 + set break 0 + } else { + set break 1 + } + + set xmailer 0 + set inheaders 1 + set last [array size lines] + set plen 2 + for {set L 1} {$L < $last} {incr L} { + set line $lines($L) + if {$inheaders} { + # Blank or empty line terminates headers + # Leading --- terminates headers + if {[regexp {^[ ]*$} $line] || [regexp {^--+} $line]} { + set inheaders 0 + } + if {[regexp -nocase {^x-mailer:} $line]} { + continue + } + } + if $inheaders { + set limit 55 + } else { + set limit 55 + + # Decide whether or not to break the body line + + if {$plen > 0} { + if {[string first {> } $line] == 0} { + # This is quoted text from previous message, don't reformat + append result $line $NL + if {$quote && !$inheaders} { + # Fix from <sarr@umich.edu> to handle text/enriched + if {$L > $L1 && $L < $L2 && $line != {}} { + # enriched requires two newlines for each one. + append result $NL + } elseif {$L > $L2} { + set L1 [lindex $ranges 0] + set L2 [lindex $ranges 1] + set ranges [lrange $ranges 2 end] + set quote [llength $L1] + } + } + continue + } + } + if {$F1 < 0} { + # Nothing left to format + append result $line $NL + continue + } elseif {$L < $F1} { + # Not yet to formatted block + append result $line $NL + continue + } elseif {$L > $F2} { + # Past formatted block + set F1 [lindex $breakrange 0] + set F2 [lindex $breakrange 1] + set breakrange [lrange $breakrange 2 end] + append result $line $NL + if {[string length $F1] == 0} { + set F1 -1 + } + continue + } + } + set climit [expr $limit-1] + set cutoff 50 + set continuation 0 + + while {[string length $line] > $limit} { + for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} { + set char [string index $line $c] + if {$char == " " || $char == "\t"} { + break + } + if {$char == ">"} { ;# Hack for enriched formatting + break + } + } + if {$c < $cutoff} { + if {! $inheaders} { + set c [expr $limit-1] + } else { + set c [string length $line] + } + } + set newline [string range $line 0 $c] + if {! $continuation} { + append result $newline $NL + } else { + append result \ $newline $NL + } + incr c + set line [string trimright [string range $line $c end]] + if {$inheaders} { + set continuation 1 + set limit $climit + } + } + if {$continuation} { + if {[string length $line] != 0} { + append result \ $line $NL + } + } else { + append result $line $NL + if {$quote && !$inheaders} { + if {$L > $L1 && $L < $L2 && $line != {}} { + # enriched requires two newlines for each one. + append result "" $NL + } elseif {$L > $L2} { + set L1 [lindex $ranges 0] + set L2 [lindex $ranges 1] + set ranges [lrange $ranges 2 end] + set quote [llength $L1] + } + } + } + } + return $result +} +test for-3.6 {break tests} { + formatMail +} {Return-path: <george@tcl> +Received: from tcl by tcl.Somewhere.COM (SMI-8.6/SMI-SVR4) + id LAA10027; Wed, 11 Sep 1996 11:14:53 -0700 +Message-id: <199609111814.LAA10027@tcl.Somewhere.COM> +Mime-version: 1.0 +Content-type: text/plain; charset=iso-8859-1 +Content-transfer-encoding: quoted-printable +Content-length: 2162 +To: fred +Subject: tcl7.6 +Date: Wed, 11 Sep 1996 11:14:53 -0700 +From: George <george@tcl> +The Tcl 7.6 and Tk 4.2 releases + +This page contains information about Tcl 7.6 and Tk4.2, + which are the most recent +releases of the Tcl scripting language and the Tk toolk +it. The first beta versions of these +releases were released on August 30, 1996. These releas +es contain only minor changes, +so we hope to have only a single beta release and to +go final in early October, 1996. + + +What's new + +The most important changes in the releases are summariz +ed below. See the README +and changes files in the distributions for more complet +e information on what has +changed, including both feature changes and bug fixes. + + There are new options to the file command for +copying files (file copy), + deleting files and directories (file delete), +creating directories (file + mkdir), and renaming files (file rename). + The implementation of exec has been improved great +ly for Windows 95 and + Windows NT. + There is a new memory allocator for the Macintosh +version, which should be + more efficient than the old one. + Tk's grid geometry manager has been completely +rewritten. The layout + algorithm produces much better layouts than before +, especially where rows or + columns were stretchable. + There are new commands for creating common dialog +boxes: + tk_chooseColor, tk_getOpenFile, tk_getSaveFile and + tk_messageBox. These use native dialog boxes if +they are available. + There is a new virtual event mechanism for handlin +g events in a more portable + way. See the new command event. It also allows +events (both physical and + virtual) to be generated dynamically. + +Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl +7.5 and Tk 4.1 except for +changes in the C APIs for custom channel drivers. Scrip +ts written for earlier releases +should work on these new releases as well. + +Obtaining The Releases + +Binary Releases + +Pre-compiled releases are available for the following +platforms: + + Windows 3.1, Windows 95, and Windows NT: Fetch + ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then +execute it. The file is a + self-extracting executable. It will install the +Tcl and Tk libraries, the wish and + tclsh programs, and documentation. + Macintosh (both 68K and PowerPC): Fetch + ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. +The file is in binhex format, + which is understood by Fetch, StuffIt, and many +other Mac utilities. The + unpacked file is a self-installing executable: +double-click on it and it will create a + folder containing all that you need to run Tcl +and Tk. + UNIX (Solaris 2.* and SunOS, other systems +soon to follow). Easy to install + binary packages are now for sale at the Sun Labs +Tcl/Tk Shop. Check it out! +} + +# Check that "break" resets the interpreter's result + +test for-4.1 {break must reset the interp result} { + catch { + set z GLOBTESTDIR/dir2/file2.c + if [string match GLOBTESTDIR/dir2/* $z] { + break + } + } j + set j +} {} + +# Check "for" and computed command names. + +test for-5.1 {for and computed command names} { + set j 0 + set z for + $z {set i 0} {$i<10} {incr i} {set j $i} + set j +} 9 diff --git a/contrib/tcl/tests/foreach.test b/contrib/tcl/tests/foreach.test new file mode 100644 index 0000000000000..64fffc5d5dbbe --- /dev/null +++ b/contrib/tcl/tests/foreach.test @@ -0,0 +1,203 @@ +# Commands covered: foreach, continue, break +# +# 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) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) foreach.test 1.7 97/06/23 18:23:42 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset a} +catch {unset x} + +# Basic "foreach" operation. + +test foreach-1.1 {basic foreach tests} { + set a {} + foreach i {a b c d} { + set a [concat $a $i] + } + set a +} {a b c d} +test foreach-1.2 {basic foreach tests} { + set a {} + foreach i {a b {{c d} e} {123 {{x}}}} { + set a [concat $a $i] + } + set a +} {a b {c d} e 123 {{x}}} +test foreach-1.3 {basic foreach tests} {catch {foreach} msg} 1 +test foreach-1.4 {basic foreach tests} { + catch {foreach} msg + set msg +} {wrong # args: should be "foreach varList list ?varList list ...? command"} +test foreach-1.5 {basic foreach tests} {catch {foreach i} msg} 1 +test foreach-1.6 {basic foreach tests} { + catch {foreach i} msg + set msg +} {wrong # args: should be "foreach varList list ?varList list ...? command"} +test foreach-1.7 {basic foreach tests} {catch {foreach i j} msg} 1 +test foreach-1.8 {basic foreach tests} { + catch {foreach i j} msg + set msg +} {wrong # args: should be "foreach varList list ?varList list ...? command"} +test foreach-1.9 {basic foreach tests} {catch {foreach i j k l} msg} 1 +test foreach-1.10 {basic foreach tests} { + catch {foreach i j k l} msg + set msg +} {wrong # args: should be "foreach varList list ?varList list ...? command"} +test foreach-1.11 {basic foreach tests} { + set a {} + foreach i {} { + set a [concat $a $i] + } + set a +} {} +test foreach-1.12 {foreach errors} { + list [catch {foreach {{a}{b}} {1 2 3} {}} msg] $msg +} {1 {list element in braces followed by "{b}" instead of space}} +test foreach-1.13 {foreach errors} { + list [catch {foreach a {{1 2}3} {}} msg] $msg +} {1 {list element in braces followed by "3" instead of space}} +catch {unset a} +test foreach-1.14 {foreach errors} { + catch {unset a} + set a(0) 44 + list [catch {foreach a {1 2 3} {}} msg] $msg +} {1 {couldn't set loop variable: "a"}} +test foreach-1.15 {foreach errors} { + list [catch {foreach {} {} {}} msg] $msg +} {1 {foreach varlist is empty}} +catch {unset a} + +test foreach-2.1 {parallel foreach tests} { + set x {} + foreach {a b} {1 2 3 4} { + append x $b $a + } + set x +} {2143} +test foreach-2.2 {parallel foreach tests} { + set x {} + foreach {a b} {1 2 3 4 5} { + append x $b $a + } + set x +} {21435} +test foreach-2.3 {parallel foreach tests} { + set x {} + foreach a {1 2 3} b {4 5 6} { + append x $b $a + } + set x +} {415263} +test foreach-2.4 {parallel foreach tests} { + set x {} + foreach a {1 2 3} b {4 5 6 7 8} { + append x $b $a + } + set x +} {41526378} +test foreach-2.5 {parallel foreach tests} { + set x {} + foreach {a b} {a b A B aa bb} c {c C cc CC} { + append x $a $b $c + } + set x +} {abcABCaabbccCC} +test foreach-2.6 {parallel foreach tests} { + set x {} + foreach a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + append x $a $b $c $d $e + } + set x +} {111112222233333} +test foreach-2.7 {parallel foreach tests} { + set x {} + foreach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + append x $a $b $c $d $e + } + set x +} {1111 2222334} +test foreach-2.8 {foreach only sets vars if repeating loop} { + proc foo {} { + set rgb {65535 0 0} + foreach {r g b} [set rgb] {} + return "r=$r, g=$g, b=$b" + } + foo +} {r=65535, g=0, b=0} +test foreach-2.9 {foreach only supports local scalar variables} { + proc foo {} { + set x {} + foreach {a(3)} {1 2 3 4} {lappend x [set {a(3)}]} + set x + } + foo +} {1 2 3 4} + +test foreach-3.1 {compiled foreach backward jump works correctly} { + catch {unset x} + proc foo {arrayName} { + upvar 1 $arrayName a + set l {} + foreach member [array names a] { + lappend l [list $member [set a($member)]] + } + return $l + } + array set x {0 zero 1 one 2 two 3 three} + foo x +} {{0 zero} {1 one} {2 two} {3 three}} + +# Check "continue". + +test foreach-4.1 {continue tests} {catch continue} 4 +test foreach-4.2 {continue tests} { + set a {} + foreach i {a b c d} { + if {[string compare $i "b"] == 0} continue + set a [concat $a $i] + } + set a +} {a c d} +test foreach-4.3 {continue tests} { + set a {} + foreach i {a b c d} { + if {[string compare $i "b"] != 0} continue + set a [concat $a $i] + } + set a +} {b} +test foreach-4.4 {continue tests} {catch {continue foo} msg} 1 +test foreach-4.5 {continue tests} { + catch {continue foo} msg + set msg +} {wrong # args: should be "continue"} + +# Check "break". + +test foreach-5.1 {break tests} {catch break} 3 +test foreach-5.2 {break tests} { + set a {} + foreach i {a b c d} { + if {[string compare $i "c"] == 0} break + set a [concat $a $i] + } + set a +} {a b} +test foreach-5.3 {break tests} {catch {break foo} msg} 1 +test foreach-5.4 {break tests} { + catch {break foo} msg + set msg +} {wrong # args: should be "break"} + +catch {unset a} +catch {unset x} diff --git a/contrib/tcl/tests/format.test b/contrib/tcl/tests/format.test index e6764f3df4ac5..219327b43189f 100644 --- a/contrib/tcl/tests/format.test +++ b/contrib/tcl/tests/format.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) format.test 1.23 96/07/31 16:54:50 +# SCCS: @(#) format.test 1.24 96/10/08 17:40:55 if {[string compare test [info procs test]] == 1} then {source defs} @@ -181,13 +181,13 @@ test format-4.16 {g-format} { test format-4.17 {g-format} { format "%.3g" .001 } {0.001} -test format-4.19 {g-format} { +test format-4.18 {g-format} { format "%.3g" .00001 } {1e-05} -test format-4.20 {g-format} { +test format-4.19 {g-format} { format "%#.3g" 1234.0 } {1.23e+03} -test format-4.21 {g-format} { +test format-4.20 {g-format} { format "%#.3G" 9999.5 } {1.00E+04} diff --git a/contrib/tcl/tests/get.test b/contrib/tcl/tests/get.test index 07138615902b9..50e68bb03112f 100644 --- a/contrib/tcl/tests/get.test +++ b/contrib/tcl/tests/get.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) get.test 1.5 96/04/09 15:54:33 +# SCCS: @(#) get.test 1.6 96/10/08 17:39:21 if {[string compare test [info procs test]] == 1} then {source defs} @@ -49,11 +49,11 @@ test get-1.8 {Tcl_GetInt procedure} {nonPortable} { set x 0 list [catch {incr x 4294967294} msg] $msg } {0 -2} -test get-1.8 {Tcl_GetInt procedure} {nonPortable} { +test get-1.9 {Tcl_GetInt procedure} {nonPortable} { set x 0 list [catch {incr x +4294967294} msg] $msg } {0 -2} -test get-1.9 {Tcl_GetInt procedure} {nonPortable} { +test get-1.10 {Tcl_GetInt procedure} {nonPortable} { set x 0 list [catch {incr x -4294967294} msg] $msg } {0 2} diff --git a/contrib/tcl/tests/history.test b/contrib/tcl/tests/history.test index d5921b6e4dfc7..1d30955be9917 100644 --- a/contrib/tcl/tests/history.test +++ b/contrib/tcl/tests/history.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) history.test 1.11 96/02/16 08:55:57 +# SCCS: @(#) history.test 1.12 96/03/11 18:06:04 if {[info commands history] == ""} { puts stdout "This version of Tcl was built without the history command;\n" @@ -282,14 +282,14 @@ test history-10.1 {history revision} { history a {set a [history e]} exec set a } {set a 12345} -test history-10.2 {history revision} { +test history-10.2 {history revision} {notIfCompiled} { set a 0 history a {set a 12345} history a {set a [history e]} exec history a foo history ev -1 } {set a {set a 12345}} -test history-10.3 {history revision} { +test history-10.3 {history revision} {notIfCompiled} { set a 0 history a {set a 12345} history a {set a [history e]} exec @@ -298,7 +298,7 @@ test history-10.3 {history revision} { history a {set a 12345} history ev -1 } {set a {set a 12345}} -test history-10.4 {history revision} { +test history-10.4 {history revision} {notIfCompiled} { history a {set a 12345} history a {history s 123 999} exec history a foo @@ -309,13 +309,13 @@ test history-10.5 {history revision} { history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec set a } {word0 {a b}} -test history-10.6 {history revision} { +test history-10.6 {history revision} {notIfCompiled} { history add {word0 word1 word2 a b c word6} history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec history add foo history ev } {set a [list word0 {a b}]} -test history-10.7 {history revision} { +test history-10.7 {history revision} {notIfCompiled} { history add {word0 word1 word2 a b c word6} history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec history add {format b} @@ -325,7 +325,7 @@ test history-10.7 {history revision} { history add foo history ev } {set [format a] [list abc [format b] {word1 word2 a}]} -test history-10.8 {history revision} { +test history-10.8 {history revision} {notIfCompiled} { history add {set a 12345} concat a b c history add {history redo; set b 44} exec @@ -348,7 +348,7 @@ test history-10.11 {history revision} { history add {set a [history w 4-[history word 2]]} exec set a } {b c word6} -test history-10.12 {history revision} { +test history-10.12 {history revision} {notIfCompiled} { history add {word0 word1 $ a b c word6} history add {set a [history w 4-[history word 2]]} exec history add foo @@ -364,14 +364,14 @@ test history-10.14 {history revision} { history add foo history e } {set a [history word 0; format c]} -test history-10.15 {history revision even when nested} { +test history-10.15 {history revision even when nested} {notIfCompiled} { proc x {a b} {history word $a $b} history add {word1 word2 word3 word4} history add {set a [x 1-3 -1]} exec history add foo history e } {set a {word2 word3 word4}} -test history-10.16 {disable history revision in nested history evals} { +test history-10.16 {disable history revision in nested history evals} {notIfCompiled} { history add {word1 word2 word3 word4} history add {set a [history words 0]; history add foo; set a [history words 0]} exec history e diff --git a/contrib/tcl/tests/http.test b/contrib/tcl/tests/http.test new file mode 100644 index 0000000000000..3c47c27d531ef --- /dev/null +++ b/contrib/tcl/tests/http.test @@ -0,0 +1,367 @@ +# Commands covered: http_config, http_get, http_wait, http_reset +# +# This file contains a collection of tests for the http script library. +# Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) http.test 1.9 97/06/24 17:32:56 + +if {[string compare test [info procs test]] == 1} then {source defs} + + +if [catch {package require http 1.0}] { + catch {puts stderr "Cannot find http package"} + return +} + +############### The httpd_ procedures implement a stub http server. ######## +proc httpd_init {{port 8015}} { + socket -server httpdAccept $port +} +proc httpd_log {args} { + global httpLog + if {[info exists httpLog] && $httpLog} { + puts stderr "httpd: [join $args { }]" + } +} +array set httpdErrors { + 204 {No Content} + 400 {Bad Request} + 404 {Not Found} + 503 {Service Unavailable} + 504 {Service Temporarily Unavailable} + } + +proc httpdError {sock code args} { + global httpdErrors + puts $sock "$code $httpdErrors($code)" + httpd_log "error: [join $args { }]" +} +proc httpdAccept {newsock ipaddr port} { + global httpd + upvar #0 httpd$newsock data + + fconfigure $newsock -blocking 0 -translation {auto crlf} + httpd_log $newsock Connect $ipaddr $port + set data(ipaddr) $ipaddr + fileevent $newsock readable [list httpdRead $newsock] +} + +# read data from a client request + +proc httpdRead { sock } { + upvar #0 httpd$sock data + + set readCount [gets $sock line] + if {![info exists data(state)]} { + if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \ + $line x data(proto) data(url) data(query)] { + set data(state) mime + httpd_log $sock Query $line + } else { + httpdError $sock 400 + httpd_log $sock Error "bad first line:$line" + httpdSockDone $sock + } + return + } + + # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1 + + set state [string compare $readCount 0],$data(state),$data(proto) + httpd_log $sock $state + switch -- $state { + -1,mime,HEAD - + -1,mime,GET - + -1,mime,POST { + # gets would block + return + } + 0,mime,HEAD - + 0,mime,GET - + 0,query,POST { httpdRespond $sock } + 0,mime,POST { set data(state) query } + 1,mime,HEAD - + 1,mime,POST - + 1,mime,GET { + if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] { + set data(mime,[string tolower $key]) $value + } + } + 1,query,POST { + append data(query) $line + httpdRespond $sock + } + default { + if [eof $sock] { + httpd_log $sock Error "unexpected eof on <$data(url)> request" + } else { + httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>" + } + httpdError $sock 404 + httpdSockDone $sock + } + } +} +proc httpdSockDone { sock } { +upvar #0 httpd$sock data + unset data + close $sock +} + +# Respond to the query. + +proc httpdRespond { sock } { + global httpd + upvar #0 httpd$sock data + + set html "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>$data(proto) $data(url)</h2> +" + if {[info exists data(query)] && [string length $data(query)]} { + append html "<h2>Query</h2>\n<dl>\n" + foreach {key value} [split $data(query) &=] { + append html "<dt>$key<dd>$value\n" + } + append html </dl>\n + } + append html </body></html> + + if {$data(proto) == "HEAD"} { + puts $sock "HTTP/1.0 200 OK" + } else { + puts $sock "HTTP/1.0 200 Data follows" + } + puts $sock "Date: [clock format [clock clicks]]" + puts $sock "Content-Type: text/html" + puts $sock "Content-Length: [string length $html]" + puts $sock "" + if {$data(proto) != "HEAD"} { + fconfigure $sock -translation binary + puts -nonewline $sock $html + } + httpd_log $sock Done "" + httpdSockDone $sock +} +##################### end server ###########################33 + +set port 8010 +if [catch {httpd_init $port} listen] { + puts stderr "Cannot start http server, http test skipped" + unset port + return +} + +test http-1.1 {http_config} { + http_config +} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}} + +test http-1.2 {http_config} { + http_config -proxyfilter +} httpProxyRequired + +test http-1.3 {http_config} { + catch {http_config -junk} +} 1 + +test http-1.4 {http_config} { + http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite" + set x [http_config] + http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired + set x +} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}} + +test http-1.5 {http_config} { + catch {http_config -proxyhost {} -junk 8080} +} 1 + +test http-2.1 {http_reset} { + catch {http_reset http#1} +} 0 + +test http-3.1 {http_get} { + catch {http_get -bogus flag} +} 1 +test http-3.2 {http_get} { + catch {http_get junk} err + set err +} {Unsupported URL: junk} + +set tail /a/b/c +set url [info hostname]:$port/a/b/c +test http-3.3 {http_get} { + set token [http_get $url] + http_data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET $tail</h2> +</body></html>" + +proc selfproxy {host} { + global port + return [list [info hostname] $port] +} +test http-3.4 {http_get} { + http_config -proxyfilter selfproxy + set token [http_get $url] + http_config -proxyfilter httpProxyRequired + http_data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET http://$url</h2> +</body></html>" + +test http-3.5 {http_get} { + http_config -proxyfilter bogus + set token [http_get $url] + http_config -proxyfilter httpProxyRequired + http_data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET $tail</h2> +</body></html>" + +test http-3.6 {http_get} { + set token [http_get $url -headers {Pragma no-cache}] + http_data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET $tail</h2> +</body></html>" + +test http-3.7 {http_get} { + set token [http_get $url -query Name=Value&Foo=Bar] + http_data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>POST $tail</h2> +<h2>Query</h2> +<dl> +<dt>Name<dd>Value +<dt>Foo<dd>Bar +</dl> +</body></html>" + +test http-3.8 {http_get} { + set token [http_get $url -validate 1] + http_code $token +} "HTTP/1.0 200 OK" + +test http-4.1 {httpEvent} { + set token [http_get $url] + upvar #0 $token data + array set meta $data(meta) + expr ($data(totalsize) == $meta(Content-Length)) +} 1 + +test http-4.2 {httpEvent} { + set token [http_get $url] + upvar #0 $token data + array set meta $data(meta) + string compare $data(type) [string trim $meta(Content-Type)] +} 0 + +test http-4.3 {httpEvent} { + set token [http_get $url] + http_code $token +} {HTTP/1.0 200 Data follows} + +test http-4.4 {httpEvent} { + set out [open testfile w] + set token [http_get $url -channel $out] + close $out + set in [open testfile] + set x [read $in] + close $in + file delete testfile + set x +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET $tail</h2> +</body></html>" + +test http-4.5 {httpEvent} { + set out [open testfile w] + set token [http_get $url -channel $out] + close $out + upvar #0 $token data + file delete testfile + expr $data(currentsize) == $data(totalsize) +} 1 + +proc myProgress {token total current} { + global progress httpLog + if {[info exists httpLog] && $httpLog} { + puts "progress $total $current" + } + set progress [list $total $current] +} +if 0 { + # This test hangs on Windows95 because the client never gets EOF + set httpLog 1 + test http-4.6 {httpEvent} { + set token [http_get $url -blocksize 50 -progress myProgress] + set progress + } {111 111} +} +test http-4.7 {httpEvent} { + set token [http_get $url -progress myProgress] + set progress +} {111 111} +test http-4.8 {httpEvent} { + set token [http_get $url] + http_status $token +} {ok} +test http-4.9 {httpEvent} { + set token [http_get $url -progress myProgress] + http_code $token +} {HTTP/1.0 200 Data follows} +test http-4.10 {httpEvent} { + set token [http_get $url -progress myProgress] + http_size $token +} {111} +test http-4.11 {httpEvent} { + set token [http_get $url -timeout 1 -command {#}] + http_reset $token + http_status $token +} {reset} +test http-4.12 {httpEvent} { + set token [http_get $url -timeout 1 -command {#}] + update + http_status $token +} {timeout} + +test http-5.1 {http_formatQuery} { + http_formatQuery name1 value1 name2 "value two" +} {name1=value1&name2=value+two} + +test http-5.2 {http_formatQuery} { + http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 +} {name1=%7ebwelch&name2=%a1%a2%a2} + +test http-5.3 {http_formatQuery} { + http_formatQuery lines "line1\nline2\nline3" +} {lines=line1%0d%0aline2%0d%0aline3} + +test http-6.1 {httpProxyRequired} { + http_config -proxyhost [info hostname] -proxyport $port + set token [http_get $url] + http_wait $token + http_config -proxyhost {} -proxyport {} + upvar #0 $token data + set data(body) +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET http://$url</h2> +</body></html>" + +unset url +unset port +close $listen diff --git a/contrib/tcl/tests/if-old.test b/contrib/tcl/tests/if-old.test new file mode 100644 index 0000000000000..abade28a8a1d0 --- /dev/null +++ b/contrib/tcl/tests/if-old.test @@ -0,0 +1,156 @@ +# Commands covered: if +# +# This file contains the original set of tests for Tcl's if command. +# Since the if command is now compiled, a new set of tests covering +# the new implementation is in the file "if.test". Sourcing this file +# into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) if-old.test 1.10 96/10/22 11:33:06 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test if-old-1.1 {taking proper branch} { + set a {} + if 0 {set a 1} else {set a 2} + set a +} 2 +test if-old-1.2 {taking proper branch} { + set a {} + if 1 {set a 1} else {set a 2} + set a +} 1 +test if-old-1.3 {taking proper branch} { + set a {} + if 1<2 {set a 1} + set a +} 1 +test if-old-1.4 {taking proper branch} { + set a {} + if 1>2 {set a 1} + set a +} {} +test if-old-1.5 {taking proper branch} { + set a {} + if 0 {set a 1} else {} + set a +} {} +test if-old-1.5 {taking proper branch} { + set a {} + if 0 {set a 1} elseif 1 {set a 2} elseif 1 {set a 3} else {set a 4} + set a +} {2} +test if-old-1.6 {taking proper branch} { + set a {} + if 0 {set a 1} elseif 0 {set a 2} elseif 1 {set a 3} else {set a 4} + set a +} {3} +test if-old-1.7 {taking proper branch} { + set a {} + if 0 {set a 1} elseif 0 {set a 2} elseif 0 {set a 3} else {set a 4} + set a +} {4} +test if-old-1.8 {taking proper branch, multiline test expr} { + set a {} + if {($tcl_platform(platform) != "foobar1") && \ + ($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4} + set a +} {3} + + +test if-old-2.1 {optional then-else args} { + set a 44 + if 0 then {set a 1} elseif 0 then {set a 3} else {set a 2} + set a +} 2 +test if-old-2.2 {optional then-else args} { + set a 44 + if 1 then {set a 1} else {set a 2} + set a +} 1 +test if-old-2.3 {optional then-else args} { + set a 44 + if 0 {set a 1} else {set a 2} + set a +} 2 +test if-old-2.4 {optional then-else args} { + set a 44 + if 1 {set a 1} else {set a 2} + set a +} 1 +test if-old-2.5 {optional then-else args} { + set a 44 + if 0 then {set a 1} {set a 2} + set a +} 2 +test if-old-2.6 {optional then-else args} { + set a 44 + if 1 then {set a 1} {set a 2} + set a +} 1 +test if-old-2.7 {optional then-else args} { + set a 44 + if 0 then {set a 1} else {set a 2} + set a +} 2 +test if-old-2.8 {optional then-else args} { + set a 44 + if 0 then {set a 1} elseif 0 {set a 2} elseif 0 {set a 3} {set a 4} + set a +} 4 + +test if-old-3.1 {return value} { + if 1 then {set a 22; concat abc} +} abc +test if-old-3.2 {return value} { + if 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi} +} def +test if-old-3.3 {return value} { + if 0 then {set a 22; concat abc} else {concat def} +} def +test if-old-3.4 {return value} { + if 0 then {set a 22; concat abc} +} {} +test if-old-3.5 {return value} { + if 0 then {set a 22; concat abc} elseif 0 {concat def} +} {} + +test if-old-4.1 {error conditions} { + list [catch {if} msg] $msg +} {1 {wrong # args: no expression after "if" argument}} +test if-old-4.2 {error conditions} { + list [catch {if {[error "error in condition"]} foo} msg] $msg +} {1 {error in condition}} +test if-old-4.3 {error conditions} { + list [catch {if 2} msg] $msg +} {1 {wrong # args: no script following "2" argument}} +test if-old-4.4 {error conditions} { + list [catch {if 2 then} msg] $msg +} {1 {wrong # args: no script following "then" argument}} +test if-old-4.5 {error conditions} { + list [catch {if 2 the} msg] $msg +} {1 {invalid command name "the"}} +test if-old-4.6 {error conditions} { + list [catch {if 2 then {[error "error in then clause"]}} msg] $msg +} {1 {error in then clause}} +test if-old-4.7 {error conditions} { + list [catch {if 0 then foo elseif} msg] $msg +} {1 {wrong # args: no expression after "elseif" argument}} +test if-old-4.8 {error conditions} { + list [catch {if 0 then foo elsei} msg] $msg +} {1 {invalid command name "elsei"}} +test if-old-4.9 {error conditions} { + list [catch {if 0 then foo elseif 0 bar else} msg] $msg +} {1 {wrong # args: no script following "else" argument}} +test if-old-4.10 {error conditions} { + list [catch {if 0 then foo elseif 0 bar els} msg] $msg +} {1 {invalid command name "els"}} +test if-old-4.11 {error conditions} { + list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg +} {1 {error in else clause}} diff --git a/contrib/tcl/tests/if.test b/contrib/tcl/tests/if.test index e5b9ed236efcc..8bc288fb079e7 100644 --- a/contrib/tcl/tests/if.test +++ b/contrib/tcl/tests/if.test @@ -4,145 +4,502 @@ # 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) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) if.test 1.8 96/02/16 08:55:59 +# SCCS: @(#) if.test 1.8 97/06/23 18:18:30 if {[string compare test [info procs test]] == 1} then {source defs} -test if-1.1 {taking proper branch} { +# Basic "if" operation. + +catch {unset a} +test if-1.1 {TclCompileIfCmd: missing if/elseif test} { + list [catch {if} msg] $msg +} {1 {wrong # args: no expression after "if" argument}} +test if-1.2 {TclCompileIfCmd: error in if/elseif test} { + list [catch {if {[error "error in condition"]} foo} msg] $msg +} {1 {error in condition}} +test if-1.3 {TclCompileIfCmd: error in if/elseif test} { + list [catch {if {1+}} msg] $msg $errorInfo +} {1 {syntax error in expression "1+"} {syntax error in expression "1+" + ("if" test expression) + while compiling +"if"}} +test if-1.4 {TclCompileIfCmd: if/elseif test in braces} { set a {} - if 0 {set a 1} else {set a 2} + if {1<2} {set a 1} set a -} 2 -test if-1.2 {taking proper branch} { +} {1} +test if-1.5 {TclCompileIfCmd: if/elseif test not in braces} { set a {} - if 1 {set a 1} else {set a 2} + if 1<2 {set a 1} set a -} 1 -test if-1.3 {taking proper branch} { +} {1} +test if-1.6 {TclCompileIfCmd: multiline test expr} { + set a {} + if {($tcl_platform(platform) != "foobar1") && \ + ($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4} + set a +} 3 +test if-1.7 {TclCompileIfCmd: "then" after if/elseif test} { + set a {} + if 4>3 then {set a 1} + set a +} {1} +test if-1.8 {TclCompileIfCmd: keyword other than "then" after if/elseif test} { + set a {} + catch {if 1<2 therefore {set a 1}} msg + set msg +} {invalid command name "therefore"} +test if-1.9 {TclCompileIfCmd: missing "then" body} { + set a {} + catch {if 1<2 then} msg + set msg +} {wrong # args: no script following "then" argument} +test if-1.10 {TclCompileIfCmd: error in "then" body} { + set a {} + list [catch {if {$a!="xxx"} then {set}} msg] $msg $errorInfo +} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("if" body script) + while compiling +"if"}} +test if-1.11 {TclCompileIfCmd: error in "then" body} { + list [catch {if 2 then {[error "error in then clause"]}} msg] $msg +} {1 {error in then clause}} +test if-1.12 {TclCompileIfCmd: "then" body in quotes} { + set a {} + if 27>17 "append a x" + set a +} {x} +test if-1.13 {TclCompileIfCmd: computed "then" body} { + catch {unset x1} + catch {unset x2} + set a {} + set x1 {append a x1} + set x2 {; append a x2} + set a {} + if 1 $x1$x2 + set a +} {x1x2} +test if-1.14 {TclCompileIfCmd: taking proper branch} { set a {} if 1<2 {set a 1} set a } 1 -test if-1.4 {taking proper branch} { +test if-1.15 {TclCompileIfCmd: taking proper branch} { set a {} if 1>2 {set a 1} set a } {} -test if-1.5 {taking proper branch} { +test if-1.16 {TclCompileIfCmd: test jumpFalse instruction replacement after long "then" body} { + catch {unset i} set a {} - if 0 {set a 1} else {} + if 1<2 { + set a 1 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 2 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 3 + } set a -} {} -test if-1.5 {taking proper branch} { +} 3 +test if-1.17 {TclCompileIfCmd: if/elseif test in quotes} { set a {} - if 0 {set a 1} elseif 1 {set a 2} elseif 1 {set a 3} else {set a 4} + list [catch {if {"0 < 3"} {set a 1}} msg] $msg +} {1 {expected boolean value but got "0 < 3"}} + + +test if-2.1 {TclCompileIfCmd: "elseif" after if/elseif test} { + set a {} + if 3>4 {set a 1} elseif 1 {set a 2} set a } {2} -test if-1.6 {taking proper branch} { +# Since "else" is optional, the "elwood" below is treated as a command. +# But then there shouldn't be any additional argument words for the "if". +test if-2.2 {TclCompileIfCmd: keyword other than "elseif"} { set a {} - if 0 {set a 1} elseif 0 {set a 2} elseif 1 {set a 3} else {set a 4} - set a -} {3} -test if-1.7 {taking proper branch} { + catch {if 1<2 {set a 1} elwood {set a 2}} msg + set msg +} {wrong # args: extra words after "else" clause in "if" command} +test if-2.3 {TclCompileIfCmd: missing expression after "elseif"} { + set a {} + catch {if 1<2 {set a 1} elseif} msg + set msg +} {wrong # args: no expression after "elseif" argument} +test if-2.4 {TclCompileIfCmd: error in expression after "elseif"} { set a {} - if 0 {set a 1} elseif 0 {set a 2} elseif 0 {set a 3} else {set a 4} + list [catch {if 3>4 {set a 1} elseif {1>}} msg] $msg $errorInfo +} {1 {syntax error in expression "1>"} {syntax error in expression "1>" + ("if" test expression) + while compiling +"if"}} +test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long "elseif" body} { + catch {unset i} + set a {} + if 1>2 { + set a 1 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 2 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 3 + } elseif 1<2 then { #; this if arm should be taken + set a 4 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 5 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 6 + } set a -} {4} - +} 6 -test if-2.1 {optional then-else args} { - set a 44 - if 0 then {set a 1} elseif 0 then {set a 3} else {set a 2} - set a -} 2 -test if-2.2 {optional then-else args} { - set a 44 - if 1 then {set a 1} else {set a 2} - set a -} 1 -test if-2.3 {optional then-else args} { - set a 44 - if 0 {set a 1} else {set a 2} +test if-3.1 {TclCompileIfCmd: "else" clause} { + set a {} + if 3>4 {set a 1} elseif {$a == "foo"} {set a 2} else {set a 3} set a -} 2 -test if-2.4 {optional then-else args} { - set a 44 - if 1 {set a 1} else {set a 2} +} 3 +# Since "else" is optional, the "elsex" below is treated as a command. +# But then there shouldn't be any additional argument words for the "if". +test if-3.2 {TclCompileIfCmd: keyword other than "else"} { + set a {} + catch {if 1<2 then {set a 1} elsex {set a 2}} msg + set msg +} {wrong # args: extra words after "else" clause in "if" command} +test if-3.3 {TclCompileIfCmd: missing body after "else"} { + set a {} + catch {if 2<1 {set a 1} else} msg + set msg +} {wrong # args: no script following "else" argument} +test if-3.4 {TclCompileIfCmd: error compiling body after "else"} { + set a {} + catch {if 2<1 {set a 1} else {set}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("if" else script) + while compiling +"if"} +test if-3.5 {TclCompileIfCmd: extra arguments after "else" argument} { + set a {} + catch {if 2<1 {set a 1} else {set a 2} or something} msg + set msg +} {wrong # args: extra words after "else" clause in "if" command} +# The following test also checks whether contained loops and other +# commands are properly relocated because a short jump must be replaced +# by a "long distance" one. +test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long "else" clause} { + catch {unset i} + set a {} + if 1>2 { + set a 1 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 2 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 3 + } elseif 1==2 then { #; this if arm should be taken + set a 4 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 5 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 6 + } else { + set a 7 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 8 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 9 + } set a -} 1 -test if-2.5 {optional then-else args} { - set a 44 - if 0 then {set a 1} {set a 2} +} 9 + +test if-4.1 {TclCompileIfCmd: "if" command result} { + set a {} + set a [if 3<4 {set i 27}] set a -} 2 -test if-2.6 {optional then-else args} { - set a 44 - if 1 then {set a 1} {set a 2} +} 27 +test if-4.2 {TclCompileIfCmd: "if" command result} { + set a {} + set a [if 3>4 {set i 27}] set a -} 1 -test if-2.7 {optional then-else args} { - set a 44 - if 0 then {set a 1} else {set a 2} +} {} +test if-4.3 {TclCompileIfCmd: "if" command result} { + set a {} + set a [if 0 {set i 1} elseif 1 {set i 2}] set a } 2 -test if-2.8 {optional then-else args} { - set a 44 - if 0 then {set a 1} elseif 0 {set a 2} elseif 0 {set a 3} {set a 4} +test if-4.4 {TclCompileIfCmd: "if" command result} { + set a {} + set a [if 0 {set i 1} elseif 0 {set i 2} elseif 2>5 {set i 3} else {set i 4}] set a } 4 - -test if-3.1 {return value} { - if 1 then {set a 22; concat abc} -} abc -test if-3.2 {return value} { +test if-4.5 {TclCompileIfCmd: return value} { if 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi} } def -test if-3.3 {return value} { - if 0 then {set a 22; concat abc} else {concat def} -} def -test if-3.4 {return value} { - if 0 then {set a 22; concat abc} -} {} -test if-3.5 {return value} { - if 0 then {set a 22; concat abc} elseif 0 {concat def} -} {} -test if-4.1 {error conditions} { - list [catch {if} msg] $msg -} {1 {wrong # args: no expression after "if" argument}} -test if-4.2 {error conditions} { - list [catch {if {[error "error in condition"]}} msg] $msg -} {1 {error in condition}} -test if-4.3 {error conditions} { - list [catch {if 2} msg] $msg -} {1 {wrong # args: no script following "2" argument}} -test if-4.4 {error conditions} { - list [catch {if 2 then} msg] $msg -} {1 {wrong # args: no script following "then" argument}} -test if-4.5 {error conditions} { - list [catch {if 2 the} msg] $msg -} {1 {invalid command name "the"}} -test if-4.6 {error conditions} { - list [catch {if 2 then {[error "error in then clause"]}} msg] $msg -} {1 {error in then clause}} -test if-4.7 {error conditions} { - list [catch {if 0 then foo elseif} msg] $msg -} {1 {wrong # args: no expression after "elseif" argument}} -test if-4.8 {error conditions} { - list [catch {if 0 then foo elsei} msg] $msg -} {1 {invalid command name "elsei"}} -test if-4.9 {error conditions} { - list [catch {if 0 then foo elseif 0 bar else} msg] $msg -} {1 {wrong # args: no script following "else" argument}} -test if-4.10 {error conditions} { - list [catch {if 0 then foo elseif 0 bar els} msg] $msg -} {1 {invalid command name "els"}} -test if-4.11 {error conditions} { - list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg -} {1 {error in else clause}} +# Check "if" and computed command names. + +test if-5.1 {if and computed command names} { + set i 0 + set z if + $z 1 { + set i 1 + } + set i +} 1 diff --git a/contrib/tcl/tests/incr-old.test b/contrib/tcl/tests/incr-old.test new file mode 100644 index 0000000000000..8fbd89f474ad2 --- /dev/null +++ b/contrib/tcl/tests/incr-old.test @@ -0,0 +1,89 @@ +# Commands covered: incr +# +# This file contains the original set of tests for Tcl's incr command. +# Since the incr command is now compiled, a new set of tests covering +# the new implementation is in the file "incr.test". Sourcing this file +# into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) incr-old.test 1.11 96/11/19 16:56:23 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset x} + +test incr-old-1.1 {basic incr operation} { + set x 23 + list [incr x] $x +} {24 24} +test incr-old-1.2 {basic incr operation} { + set x 106 + list [incr x -5] $x +} {101 101} +test incr-old-1.3 {basic incr operation} { + set x " -106" + list [incr x 1] $x +} {-105 -105} +test incr-old-1.3 {basic incr operation} { + set x " +106" + list [incr x 1] $x +} {107 107} + +test incr-old-2.1 {incr errors} { + list [catch incr msg] $msg +} {1 {wrong # args: should be "incr varName ?increment?"}} +test incr-old-2.2 {incr errors} { + list [catch {incr a b c} msg] $msg +} {1 {wrong # args: should be "incr varName ?increment?"}} +test incr-old-2.3 {incr errors} { + catch {unset x} + list [catch {incr x} msg] $msg $errorInfo +} {1 {can't read "x": no such variable} {can't read "x": no such variable + (reading value of variable to increment) + invoked from within +"incr x"}} +test incr-old-2.4 {incr errors} { + set x abc + list [catch {incr x} msg] $msg $errorInfo +} {1 {expected integer but got "abc"} {expected integer but got "abc" + while executing +"incr x"}} +test incr-old-2.5 {incr errors} { + set x 123 + list [catch {incr x 1a} msg] $msg $errorInfo +} {1 {expected integer but got "1a"} {expected integer but got "1a" + while executing +"incr x 1a"}} +test incr-old-2.6 {incr errors} { + proc readonly args {error "variable is read-only"} + set x 123 + trace var x w readonly + list [catch {incr x 1} msg] $msg $errorInfo +} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only + while executing +"incr x 1"}} +catch {unset x} +test incr-old-2.7 {incr errors} { + set x - + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got "-"}} +test incr-old-2.8 {incr errors} { + set x { - } + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got " - "}} +test incr-old-2.9 {incr errors} { + set x + + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got "+"}} +test incr-old-2.10 {incr errors} { + set x {20 x} + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got "20 x"}} + +concat {} diff --git a/contrib/tcl/tests/incr.test b/contrib/tcl/tests/incr.test index b9b7fbaf77322..30db386f38bc2 100644 --- a/contrib/tcl/tests/incr.test +++ b/contrib/tcl/tests/incr.test @@ -1,65 +1,228 @@ -# Commands covered: lreplace +# Commands covered: incr # # 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) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) incr.test 1.8 96/02/16 08:56:00 +# SCCS: @(#) incr.test 1.8 97/06/20 16:53:28 if {[string compare test [info procs test]] == 1} then {source defs} -catch {unset x} +# Basic "incr" operation. -test incr-1.1 {basic incr operation} { - set x 23 - list [incr x] $x -} {24 24} -test incr-1.2 {basic incr operation} { - set x 106 - list [incr x -5] $x -} {101 101} -test incr-1.3 {basic incr operation} { - set x " -106" - list [incr x 1] $x -} {-105 -105} -test incr-1.3 {basic incr operation} { - set x " +106" - list [incr x 1] $x -} {107 107} +catch {unset x} +catch {unset i} -test incr-2.1 {incr errors} { - list [catch incr msg] $msg -} {1 {wrong # args: should be "incr varName ?increment?"}} -test incr-2.2 {incr errors} { - list [catch {incr a b c} msg] $msg +test incr-1.1 {TclCompileIncrCmd: missing variable name} { + list [catch {incr} msg] $msg } {1 {wrong # args: should be "incr varName ?increment?"}} -test incr-2.3 {incr errors} { - catch {unset x} - list [catch {incr x} msg] $msg $errorInfo -} {1 {can't read "x": no such variable} {can't read "x": no such variable - while executing -"incr x"}} -test incr-2.4 {incr errors} { - set x abc - list [catch {incr x} msg] $msg $errorInfo -} {1 {expected integer but got "abc"} {expected integer but got "abc" - (reading value of variable to increment) - invoked from within -"incr x"}} -test incr-2.5 {incr errors} { - set x 123 - list [catch {incr x 1a} msg] $msg $errorInfo -} {1 {expected integer but got "1a"} {expected integer but got "1a" +test incr-1.2 {TclCompileIncrCmd: simple variable name} { + set i 10 + list [incr i] $i +} {11 11} +test incr-1.3 {TclCompileIncrCmd: error compiling variable name} { + set i 10 + catch {incr "i"xxx} msg + set msg +} {extra characters after close-quote} +test incr-1.4 {TclCompileIncrCmd: simple variable name in quotes} { + set i 17 + list [incr "i"] $i +} {18 18} +test incr-1.5 {TclCompileIncrCmd: simple variable name in braces} { + catch {unset {a simple var}} + set {a simple var} 27 + list [incr {a simple var}] ${a simple var} +} {28 28} +test incr-1.6 {TclCompileIncrCmd: simple array variable name} { + catch {unset a} + set a(foo) 37 + list [incr a(foo)] $a(foo) +} {38 38} +test incr-1.7 {TclCompileIncrCmd: non-simple (computed) variable name} { + set x "i" + set i 77 + list [incr $x 2] $i +} {79 79} +test incr-1.8 {TclCompileIncrCmd: non-simple (computed) variable name} { + set x "i" + set i 77 + list [incr [set x] +2] $i +} {79 79} + +test incr-1.9 {TclCompileIncrCmd: increment given} { + set i 10 + list [incr i +07] $i +} {17 17} +test incr-1.10 {TclCompileIncrCmd: no increment given} { + set i 10 + list [incr i] $i +} {11 11} + +test incr-1.11 {TclCompileIncrCmd: simple global name} { + proc p {} { + global i + set i 54 + incr i + } + p +} {55} +test incr-1.12 {TclCompileIncrCmd: simple local name} { + proc p {} { + set foo 100 + incr foo + } + p +} {101} +test incr-1.13 {TclCompileIncrCmd: simple but new (unknown) local name} { + proc p {} { + incr bar + } + catch {p} msg + set msg +} {can't read "bar": no such variable} +test incr-1.14 {TclCompileIncrCmd: simple local name, >255 locals} { + proc 260locals {} { + # create 260 locals + set a0 0; set a1 0; set a2 0; set a3 0; set a4 0 + set a5 0; set a6 0; set a7 0; set a8 0; set a9 0 + set b0 0; set b1 0; set b2 0; set b3 0; set b4 0 + set b5 0; set b6 0; set b7 0; set b8 0; set b9 0 + set c0 0; set c1 0; set c2 0; set c3 0; set c4 0 + set c5 0; set c6 0; set c7 0; set c8 0; set c9 0 + set d0 0; set d1 0; set d2 0; set d3 0; set d4 0 + set d5 0; set d6 0; set d7 0; set d8 0; set d9 0 + set e0 0; set e1 0; set e2 0; set e3 0; set e4 0 + set e5 0; set e6 0; set e7 0; set e8 0; set e9 0 + set f0 0; set f1 0; set f2 0; set f3 0; set f4 0 + set f5 0; set f6 0; set f7 0; set f8 0; set f9 0 + set g0 0; set g1 0; set g2 0; set g3 0; set g4 0 + set g5 0; set g6 0; set g7 0; set g8 0; set g9 0 + set h0 0; set h1 0; set h2 0; set h3 0; set h4 0 + set h5 0; set h6 0; set h7 0; set h8 0; set h9 0 + set i0 0; set i1 0; set i2 0; set i3 0; set i4 0 + set i5 0; set i6 0; set i7 0; set i8 0; set i9 0 + set j0 0; set j1 0; set j2 0; set j3 0; set j4 0 + set j5 0; set j6 0; set j7 0; set j8 0; set j9 0 + set k0 0; set k1 0; set k2 0; set k3 0; set k4 0 + set k5 0; set k6 0; set k7 0; set k8 0; set k9 0 + set l0 0; set l1 0; set l2 0; set l3 0; set l4 0 + set l5 0; set l6 0; set l7 0; set l8 0; set l9 0 + set m0 0; set m1 0; set m2 0; set m3 0; set m4 0 + set m5 0; set m6 0; set m7 0; set m8 0; set m9 0 + set n0 0; set n1 0; set n2 0; set n3 0; set n4 0 + set n5 0; set n6 0; set n7 0; set n8 0; set n9 0 + set o0 0; set o1 0; set o2 0; set o3 0; set o4 0 + set o5 0; set o6 0; set o7 0; set o8 0; set o9 0 + set p0 0; set p1 0; set p2 0; set p3 0; set p4 0 + set p5 0; set p6 0; set p7 0; set p8 0; set p9 0 + set q0 0; set q1 0; set q2 0; set q3 0; set q4 0 + set q5 0; set q6 0; set q7 0; set q8 0; set q9 0 + set r0 0; set r1 0; set r2 0; set r3 0; set r4 0 + set r5 0; set r6 0; set r7 0; set r8 0; set r9 0 + set s0 0; set s1 0; set s2 0; set s3 0; set s4 0 + set s5 0; set s6 0; set s7 0; set s8 0; set s9 0 + set t0 0; set t1 0; set t2 0; set t3 0; set t4 0 + set t5 0; set t6 0; set t7 0; set t8 0; set t9 0 + set u0 0; set u1 0; set u2 0; set u3 0; set u4 0 + set u5 0; set u6 0; set u7 0; set u8 0; set u9 0 + set v0 0; set v1 0; set v2 0; set v3 0; set v4 0 + set v5 0; set v6 0; set v7 0; set v8 0; set v9 0 + set w0 0; set w1 0; set w2 0; set w3 0; set w4 0 + set w5 0; set w6 0; set w7 0; set w8 0; set w9 0 + set x0 0; set x1 0; set x2 0; set x3 0; set x4 0 + set x5 0; set x6 0; set x7 0; set x8 0; set x9 0 + set y0 0; set y1 0; set y2 0; set y3 0; set y4 0 + set y5 0; set y6 0; set y7 0; set y8 0; set y9 0 + set z0 0; set z1 0; set z2 0; set z3 0; set z4 0 + set z5 0; set z6 0; set z7 0; set z8 0; set z9 0 + # now increment the last one (local var index > 255) + incr z9 + } + 260locals +} {1} +test incr-1.15 {TclCompileIncrCmd: variable is array} { + catch {unset a} + set a(foo) 27 + set x [incr a(foo) 11] + catch {unset a} + set x +} 38 +test incr-1.16 {TclCompileIncrCmd: variable is array, elem substitutions} { + catch {unset a} + set i 5 + set a(foo5) 27 + set x [incr a(foo$i) 11] + catch {unset a} + set x +} 38 + +test incr-1.17 {TclCompileIncrCmd: increment given, simple int} { + set i 5 + incr i 123 +} 128 +test incr-1.18 {TclCompileIncrCmd: increment given, simple int} { + set i 5 + incr i -100 +} -95 +test incr-1.19 {TclCompileIncrCmd: increment given, but erroneous} { + set i 5 + catch {incr i [set]} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" (reading increment) + while compiling +"incr"} +test incr-1.20 {TclCompileIncrCmd: increment given, in quotes} { + set i 25 + incr i "-100" +} -75 +test incr-1.21 {TclCompileIncrCmd: increment given, in braces} { + set i 24 + incr i {126} +} 150 +test incr-1.22 {TclCompileIncrCmd: increment given, large int} { + set i 5 + incr i 200000 +} 200005 +test incr-1.23 {TclCompileIncrCmd: increment given, formatted int != int} { + set i 25 + incr i 000012345 ;# an octal literal +} 5374 +test incr-1.24 {TclCompileIncrCmd: increment given, formatted int != int} { + set i 25 + catch {incr i 1a} msg + set msg +} {expected integer but got "1a"} + +test incr-1.25 {TclCompileIncrCmd: too many arguments} { + set i 10 + catch {incr i 10 20} msg + set msg +} {wrong # args: should be "incr varName ?increment?"} + + +test incr-1.26 {TclCompileIncrCmd: runtime error, bad variable name} { + list [catch {incr {"foo}} msg] $msg $errorInfo +} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable + (reading value of variable to increment) invoked from within -"incr x 1a"}} -test incr-2.6 {incr errors} { +"incr {"foo}"}} +test incr-1.27 {TclCompileIncrCmd: runtime error, bad variable name} { + list [catch {incr [set]} msg] $msg $errorInfo +} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + while compiling +"incr"}} +test incr-1.28 {TclCompileIncrCmd: runtime error, readonly variable} { proc readonly args {error "variable is read-only"} set x 123 trace var x w readonly @@ -68,21 +231,16 @@ test incr-2.6 {incr errors} { while executing "incr x 1"}} catch {unset x} -test incr-2.7 {incr errors} { - set x - - list [catch {incr x 1} msg] $msg -} {1 {expected integer but got "-"}} -test incr-2.8 {incr errors} { - set x { - } +test incr-1.29 {TclCompileIncrCmd: runtime error, bad variable value} { + set x " - " list [catch {incr x 1} msg] $msg } {1 {expected integer but got " - "}} -test incr-2.9 {incr errors} { - set x + - list [catch {incr x 1} msg] $msg -} {1 {expected integer but got "+"}} -test incr-2.10 {incr errors} { - set x {20 x} - list [catch {incr x 1} msg] $msg -} {1 {expected integer but got "20 x"}} + +# Check "incr" and computed command names. -concat {} +test incr-2.1 {incr and computed command names} { + set i 5 + set z incr + $z i -1 + set i +} 4 diff --git a/contrib/tcl/tests/indexObj.test b/contrib/tcl/tests/indexObj.test new file mode 100644 index 0000000000000..9f30ee02d5253 --- /dev/null +++ b/contrib/tcl/tests/indexObj.test @@ -0,0 +1,68 @@ +# This file is a Tcl script to test out the the procedures in file +# tkIndexObj.c, which implement indexed table lookups. The tests here +# are organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# @(#) indexObj.test 1.3 97/06/23 18:23:09 + +if {[info procs test] != "test"} { + source defs +} + +if {[info commands testindexobj] == {}} { + puts "This application hasn't been compiled with the \"testindexobj\"" + puts "command, so I can't test Tcl_GetIndexFromObj etc." + return +} + +test indexObj-1.1 {exact match} { + testindexobj 1 1 xyz abc def xyz alm +} {2} +test indexObj-1.2 {exact match} { + testindexobj 1 1 abc abc def xyz alm +} {0} +test indexObj-1.3 {exact match} { + testindexobj 1 1 alm abc def xyz alm +} {3} +test indexObj-1.4 {unique abbreviation} { + testindexobj 1 1 xy abc def xalb xyz alm +} {3} +test indexObj-1.5 {multiple abbreviations and exact match} { + testindexobj 1 1 x abc def xalb xyz alm x +} {5} +test indexObj-1.6 {forced exact match} { + testindexobj 1 0 xy abc def xalb xy alm +} {3} +test indexObj-1.7 {forced exact match} { + testindexobj 1 0 x abc def xalb xyz alm x +} {5} + +test indexObj-2.1 {no match} { + list [catch {testindexobj 1 1 dddd abc def xalb xyz alm x} msg] $msg +} {1 {bad token "dddd": must be abc, def, xalb, xyz, alm, or x}} +test indexObj-2.2 {no match} { + list [catch {testindexobj 1 1 dddd abc} msg] $msg +} {1 {bad token "dddd": must be abc}} +test indexObj-2.3 {no match: no abbreviations} { + list [catch {testindexobj 1 0 xy abc def xalb xyz alm} msg] $msg +} {1 {bad token "xy": must be abc, def, xalb, xyz, or alm}} +test indexObj-2.4 {ambiguous value} { + list [catch {testindexobj 1 1 d dumb daughter a c} msg] $msg +} {1 {ambiguous token "d": must be dumb, daughter, a, or c}} +test indexObj-2.5 {omit error message} { + list [catch {testindexobj 0 1 d x} msg] $msg +} {1 {}} + +test indexObj-3.1 {cache result to skip next lookup} { + testindexobj check 42 +} {42} + +test indexObj-4.1 {free old internal representation} { + set x {a b} + lindex $x 1 + testindexobj 1 1 $x abc def {a b} zzz +} {2} diff --git a/contrib/tcl/tests/info.test b/contrib/tcl/tests/info.test index 9e8f012287c68..7e7a22645ddb3 100644 --- a/contrib/tcl/tests/info.test +++ b/contrib/tcl/tests/info.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) info.test 1.33 96/03/22 12:12:48 +# SCCS: @(#) info.test 1.38 97/05/20 16:35:54 if {[string compare test [info procs test]] == 1} then {source defs} @@ -33,6 +33,11 @@ test info-1.4 {info args option} { test info-1.5 {info args option} { list [catch {info args set} msg] $msg } {1 {"set" isn't a procedure}} +test info-1.6 {info args option} { + proc t1 {a b} {set c 123; set d $c} + t1 1 2 + info args t1 +} {a b} test info-2.1 {info body option} { proc t1 {} {body of t1} @@ -45,12 +50,15 @@ test info-2.3 {info body option} { list [catch {info args set 1} msg] $msg } {1 {wrong # args: should be "info args procname"}} +# "info cmdcount" is no longer accurate for compiled commands! The expected +# result for info-3.1 used to be "3" and is now "1" since the "set"s have +# been compiled away. test info-3.1 {info cmdcount option} { set x [info cmdcount] set y 12345 set z [info cm] expr $z-$x -} 3 +} 1 test info-3.2 {info body option} { list [catch {info cmdcount 1} msg] $msg } {1 {wrong # args: should be "info cmdcount"}} @@ -367,7 +375,7 @@ test info-9.4 {info level option} { } {1 t1} test info-9.5 {info level option} { list [catch {info level 1 2} msg] $msg -} {1 {wrong # args: should be "info level [number]"}} +} {1 {wrong # args: should be "info level ?number?"}} test info-9.6 {info level option} { list [catch {info level 123a} msg] $msg } {1 {expected integer but got "123a"}} @@ -383,7 +391,7 @@ test info-9.9 {info level option} { list [catch {t1 -3} msg] $msg } {1 {bad level "-3"}} -set savedLibrary tcl_library +set savedLibrary $tcl_library test info-10.1 {info library option} { list [catch {info library x} msg] $msg } {1 {wrong # args: should be "info library"}} @@ -433,6 +441,14 @@ test info-12.5 {info locals option} { proc t1 {} {return [info locals]} t1 } {} +test info-12.6 {info locals vs unset compiled locals} { + proc t1 {lst} { + foreach $lst $lst {} + unset lst + return [info locals] + } + lsort [t1 {a b c c d e f}] +} {a b c d e f} test info-13.1 {info nameofexecutable option} { list [catch {info nameofexecutable foo} msg] $msg @@ -543,13 +559,13 @@ test info-20.1 {miscellaneous error conditions} { } {1 {wrong # args: should be "info option ?arg arg ...?"}} test info-20.2 {miscellaneous error conditions} { list [catch {info gorp} msg] $msg -} {1 {bad option "gorp": should be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} test info-20.3 {miscellaneous error conditions} { list [catch {info c} msg] $msg -} {1 {bad option "c": should be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} test info-20.4 {miscellaneous error conditions} { list [catch {info l} msg] $msg -} {1 {bad option "l": should be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} test info-20.5 {miscellaneous error conditions} { list [catch {info s} msg] $msg -} {1 {bad option "s": should be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} diff --git a/contrib/tcl/tests/interp.test b/contrib/tcl/tests/interp.test index c82b901a1f758..85aee328e222d 100644 --- a/contrib/tcl/tests/interp.test +++ b/contrib/tcl/tests/interp.test @@ -9,10 +9,18 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) interp.test 1.24 96/03/27 10:23:29 +# SCCS: @(#) interp.test 1.52 97/06/23 17:29:50 if {[string compare test [info procs test]] == 1} then {source defs} +# The set of hidden commands is platform dependent: + +if {"$tcl_platform(platform)" == "macintosh"} { + set hidden_cmds {beep cd echo exit fconfigure file glob load ls open pwd socket source vwait} +} else { + set hidden_cmds {cd exec exit fconfigure file glob load open pwd socket source vwait} +} + foreach i [interp slaves] { interp delete $i } @@ -25,7 +33,7 @@ test interp-1.1 {options for interp command} { } {1 {wrong # args: should be "interp cmd ?arg ...?"}} test interp-1.2 {options for interp command} { list [catch {interp frobox} msg] $msg -} {1 {bad option "frobox": should be alias, aliases, create, delete, exists, eval, issafe, share, slaves, target or transfer}} +} {1 {bad option "frobox": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}} test interp-1.3 {options for interp command} { interp delete } "" @@ -43,13 +51,13 @@ test interp-1.6 {options for interp command} { } {1 {wrong # args: should be "interp slaves ?path?"}} test interp-1.7 {options for interp command} { list [catch {interp hello} msg] $msg -} {1 {bad option "hello": should be alias, aliases, create, delete, exists, eval, issafe, share, slaves, target or transfer}} +} {1 {bad option "hello": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}} test interp-1.8 {options for interp command} { list [catch {interp -froboz} msg] $msg -} {1 {bad option "-froboz": should be alias, aliases, create, delete, exists, eval, issafe, share, slaves, target or transfer}} +} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}} test interp-1.9 {options for interp command} { list [catch {interp -froboz -safe} msg] $msg -} {1 {bad option "-froboz": should be alias, aliases, create, delete, exists, eval, issafe, share, slaves, target or transfer}} +} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}} test interp-1.10 {options for interp command} { list [catch {interp target} msg] $msg } {1 {wrong # args: should be "interp target path alias"}} @@ -131,6 +139,7 @@ test interp-3.11 {testing interp delete} { interp delete } "" test interp-4.1 {testing interp delete} { + catch {interp create a} interp delete a } "" test interp-4.2 {testing interp delete} { @@ -228,18 +237,25 @@ test interp-7.5 {testing basic alias creation} { # Part 7: testing basic alias invocation test interp-8.1 {testing basic alias invocation} { + catch {interp create a} + a alias foo in_master a eval foo s1 s2 s3 } {seen in master: {s1 s2 s3}} test interp-8.2 {testing basic alias invocation} { + catch {interp create a} + a alias bar in_master a1 a2 a3 a eval bar s1 s2 s3 } {seen in master: {a1 a2 a3 s1 s2 s3}} # Part 8: Testing aliases for non-existent targets test interp-9.1 {testing aliases for non-existent targets} { + catch {interp create a} a alias zop nonexistent-command-in-master list [catch {a eval zop} msg] $msg -} {1 {aliased target "nonexistent-command-in-master" for "zop" not found}} +} {1 {invalid command name "nonexistent-command-in-master"}} test interp-9.2 {testing aliases for non-existent targets} { + catch {interp create a} + a alias zop nonexistent-command-in-master proc nonexistent-command-in-master {} {return i_exist!} a eval zop } i_exist! @@ -248,42 +264,59 @@ if {[info command nonexistent-command-in-master] != ""} { rename nonexistent-command-in-master {} } -# Recreate interpreter b.. -if {![interp exists b]} { - interp create b -} - # Part 9: Aliasing between interpreters test interp-10.1 {testing aliasing between interpreters} { + catch {interp delete a} + catch {interp delete b} + interp create a + interp create b interp alias a a_alias b b_alias 1 2 3 } a_alias test interp-10.2 {testing aliasing between interpreters} { + catch {interp delete a} + catch {interp delete b} + interp create a + interp create b b eval {proc b_alias {args} {return [list got $args]}} + interp alias a a_alias b b_alias 1 2 3 a eval a_alias a b c } {got {1 2 3 a b c}} test interp-10.3 {testing aliasing between interpreters} { - b eval {rename b_alias {}} + catch {interp delete a} + catch {interp delete b} + interp create a + interp create b + interp alias a a_alias b b_alias 1 2 3 list [catch {a eval a_alias a b c} msg] $msg -} {1 {aliased target "b_alias" for "a_alias" not found}} +} {1 {invalid command name "b_alias"}} test interp-10.4 {testing aliasing between interpreters} { + catch {interp delete a} + interp create a + a alias a_alias puts a aliases -} {foo zop bar a_alias} +} a_alias test interp-10.5 {testing aliasing between interpreters} { + catch {interp delete a} + catch {interp delete b} + interp create a + interp create b + a alias a_alias puts + interp alias a a_del b b_del interp delete b a aliases -} {foo zop bar} - -# Recreate interpreter b.. -if {![interp exists b]} { - interp create b -} - +} a_alias test interp-10.6 {testing aliasing between interpreters} { + catch {interp delete a} + catch {interp delete b} + interp create a + interp create b interp alias a a_command b b_command a1 a2 a3 b alias b_command in_master b1 b2 b3 a eval a_command m1 m2 m3 } {seen in master: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} test interp-10.7 {testing aliases between interpreters} { + catch {interp delete a} + interp create a interp alias "" foo a zoppo a eval {proc zoppo {x} {list $x $x $x}} set x [foo 33] @@ -300,13 +333,17 @@ test interp-11.2 {testing interp target} { list [catch {interp target nosuchinterpreter foo} msg] $msg } {1 {could not find interpreter "nosuchinterpreter"}} test interp-11.3 {testing interp target} { + catch {interp delete a} + interp create a a alias boo no_command interp target a boo } "" test interp-11.4 {testing interp target} { + catch {interp delete x1} interp create x1 x1 eval interp create x2 x1 eval x2 eval interp create x3 + catch {interp delete y1} interp create y1 y1 eval interp create y2 y1 eval y2 eval interp create y3 @@ -314,6 +351,15 @@ test interp-11.4 {testing interp target} { interp target {x1 x2 x3} xcommand } {y1 y2 y3} test interp-11.5 {testing interp target} { + catch {interp delete x1} + interp create x1 + interp create {x1 x2} + interp create {x1 x2 x3} + catch {interp delete y1} + interp create y1 + interp create {y1 y2} + interp create {y1 y2 y3} + interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand list [catch {x1 eval {interp target {x2 x3} xcommand}} msg] $msg } {1 {target interpreter for alias "xcommand" in path "x2 x3" is not my descendant}} @@ -322,90 +368,139 @@ test interp-12.1 {testing interp issafe} { interp issafe } 0 test interp-12.2 {testing interp issafe} { + catch {interp delete a} + interp create a interp issafe a } 0 test interp-12.3 {testing interp issafe} { + catch {interp delete a} + interp create a interp create {a x3} -safe interp issafe {a x3} } 1 test interp-12.4 {testing interp issafe} { + catch {interp delete a} + interp create a + interp create {a x3} -safe interp create {a x3 foo} interp issafe {a x3 foo} } 1 # Part 12: testing interpreter object command "issafe" sub-command test interp-13.1 {testing foo issafe} { + catch {interp delete a} + interp create a a issafe } 0 test interp-13.2 {testing foo issafe} { + catch {interp delete a} + interp create a + interp create {a x3} -safe a eval x3 issafe } 1 test interp-13.3 {testing foo issafe} { + catch {interp delete a} + interp create a + interp create {a x3} -safe + interp create {a x3 foo} a eval x3 eval foo issafe } 1 -# part 13: testing interp aliases +# part 14: testing interp aliases test interp-14.1 {testing interp aliases} { interp aliases } "" test interp-14.2 {testing interp aliases} { - interp aliases a -} {boo foo zop bar a_command} + catch {interp delete a} + interp create a + a alias a1 puts + a alias a2 puts + a alias a3 puts + lsort [interp aliases a] +} {a1 a2 a3} test interp-14.3 {testing interp aliases} { + catch {interp delete a} + interp create a + interp create {a x3} interp alias {a x3} froboz "" puts interp aliases {a x3} } froboz +# part 15: testing file sharing test interp-15.1 {testing file sharing} { + catch {interp delete z} interp create z z eval close stdout list [catch {z eval puts hello} msg] $msg } {1 {can not find channel named "stdout"}} +catch {removeFile file-15.2} test interp-15.2 {testing file sharing} { - set f [open foo w] + catch {interp delete z} + interp create z + set f [open file-15.2 w] interp share "" $f z z eval puts $f hello z eval close $f close $f } "" +catch {removeFile file-15.2} test interp-15.3 {testing file sharing} { + catch {interp delete xsafe} interp create xsafe -safe list [catch {xsafe eval puts hello} msg] $msg } {1 {can not find channel named "stdout"}} +catch {removeFile file-15.4} test interp-15.4 {testing file sharing} { - set f [open foo w] + catch {interp delete xsafe} + interp create xsafe -safe + set f [open file-15.4 w] interp share "" $f xsafe xsafe eval puts $f hello xsafe eval close $f close $f } "" +catch {removeFile file-15.4} test interp-15.5 {testing file sharing} { + catch {interp delete xsafe} + interp create xsafe -safe interp share "" stdout xsafe list [catch {xsafe eval gets stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} +catch {removeFile file-15.6} test interp-15.6 {testing file sharing} { - set f [open foo w] + catch {interp delete xsafe} + interp create xsafe -safe + set f [open file-15.6 w] interp share "" $f xsafe set x [list [catch [list xsafe eval gets $f] msg] $msg] + xsafe eval close $f close $f string compare [string tolower $x] \ [list 1 [format "channel \"%s\" wasn't opened for reading" $f]] } 0 +catch {removeFile file-15.6} +catch {removeFile file-15.7} test interp-15.7 {testing file transferring} { - set f [open foo w] + catch {interp delete xsafe} + interp create xsafe -safe + set f [open file-15.7 w] interp transfer "" $f xsafe xsafe eval puts $f hello xsafe eval close $f } "" +catch {removeFile file-15.7} +catch {removeFile file-15.8} test interp-15.8 {testing file transferring} { - set f [open foo w] + catch {interp delete xsafe} + interp create xsafe -safe + set f [open file-15.8 w] interp transfer "" $f xsafe xsafe eval close $f set x [list [catch {close $f} msg] $msg] string compare [string tolower $x] \ [list 1 [format "can not find channel named \"%s\"" $f]] } 0 -removeFile foo +catch {removeFile file-15.8} # # Torture tests for interpreter deletion order @@ -413,23 +508,27 @@ removeFile foo proc kill {} {interp delete xxx} test interp-15.9 {testing deletion order} { + catch {interp delete xxx} interp create xxx xxx alias kill kill list [catch {xxx eval kill} msg] $msg } {0 {}} test interp-16.1 {testing deletion order} { + catch {interp delete xxx} interp create xxx interp create {xxx yyy} interp alias {xxx yyy} kill "" kill list [catch {interp eval {xxx yyy} kill} msg] $msg } {0 {}} test interp-16.2 {testing deletion order} { + catch {interp delete xxx} interp create xxx interp create {xxx yyy} interp alias {xxx yyy} kill "" kill list [catch {xxx eval yyy eval kill} msg] $msg } {0 {}} test interp-16.3 {testing deletion order} { + catch {interp delete xxx} interp create xxx interp create ddd xxx alias kill kill @@ -439,6 +538,7 @@ test interp-16.3 {testing deletion order} { set x } "" test interp-16.4 {testing deletion order} { + catch {interp delete xxx} interp create xxx interp create {xxx yyy} interp alias {xxx yyy} kill "" kill @@ -448,33 +548,45 @@ test interp-16.4 {testing deletion order} { interp delete ddd set x } "" +test interp-16.5 {testing deletion order, bgerror} { + catch {interp delete xxx} + interp create xxx + xxx eval {proc bgerror {args} {exit}} + xxx alias exit kill xxx + proc kill {i} {interp delete $i} + xxx eval after 100 expr a + b + set x waiting + after 200 {set x done} + vwait x + interp exists xxx +} 0 # # Alias loop prevention testing. # -test interp-16.5 {alias loop prevention} { +test interp-17.1 {alias loop prevention} { list [catch {interp alias {} a {} a} msg] $msg } {1 {cannot define or rename alias "a": would create a loop}} -test interp-17.1 {alias loop prevention} { +test interp-17.2 {alias loop prevention} { catch {interp delete x} interp create x x alias a loop list [catch {interp alias {} loop x a} msg] $msg } {1 {cannot define or rename alias "loop": would create a loop}} -test interp-17.2 {alias loop prevention} { +test interp-17.3 {alias loop prevention} { catch {interp delete x} interp create x interp alias x a x b list [catch {interp alias x b x a} msg] $msg } {1 {cannot define or rename alias "b": would create a loop}} -test interp-17.3 {alias loop prevention} { +test interp-17.4 {alias loop prevention} { catch {interp delete x} interp create x interp alias x b x a list [catch {x eval rename b a} msg] $msg } {1 {cannot define or rename alias "b": would create a loop}} -test interp-17.4 {alias loop prevention} { +test interp-17.5 {alias loop prevention} { catch {interp delete x} interp create x x alias z l1 @@ -489,27 +601,27 @@ test interp-17.4 {alias loop prevention} { # if {[info commands testinterpdelete] != ""} { - test interp-17.5 {testing Tcl_DeleteInterp vs slaves} { + test interp-18.1 {testing Tcl_DeleteInterp vs slaves} { list [catch {testinterpdelete} msg] $msg } {1 {wrong # args: should be "testinterpdelete path"}} - test interp-18.1 {testing Tcl_DeleteInterp vs slaves} { + test interp-18.2 {testing Tcl_DeleteInterp vs slaves} { catch {interp delete a} interp create a testinterpdelete a } "" - test interp-18.2 {testing Tcl_DeleteInterp vs slaves} { + test interp-18.3 {testing Tcl_DeleteInterp vs slaves} { catch {interp delete a} interp create a interp create {a b} testinterpdelete {a b} } "" - test interp-18.3 {testing Tcl_DeleteInterp vs slaves} { + test interp-18.4 {testing Tcl_DeleteInterp vs slaves} { catch {interp delete a} interp create a interp create {a b} testinterpdelete a } "" - test interp-18.4 {testing Tcl_DeleteInterp vs slaves} { + test interp-18.5 {testing Tcl_DeleteInterp vs slaves} { catch {interp delete a} interp create a interp create {a b} @@ -517,7 +629,7 @@ if {[info commands testinterpdelete] != ""} { proc dodel {x} {testinterpdelete $x} list [catch {interp eval {a b} {dodel {a b}}} msg] $msg } {0 {}} - test interp-18.5 {testing Tcl_DeleteInterp vs slaves} { + test interp-18.6 {testing Tcl_DeleteInterp vs slaves} { catch {interp delete a} interp create a interp create {a b} @@ -525,7 +637,7 @@ if {[info commands testinterpdelete] != ""} { proc dodel {x} {testinterpdelete $x} list [catch {interp eval {a b} {dodel a}} msg] $msg } {0 {}} - test interp-18.6 {eval in deleted interp} { + test interp-18.7 {eval in deleted interp} { catch {interp delete a} interp create a a eval { @@ -541,7 +653,7 @@ if {[info commands testinterpdelete] != ""} { proc dela {} {interp delete a} list [catch {a eval dodel} msg] $msg } {1 {attempt to call eval in deleted interpreter}} - test interp-18.7 {eval in deleted interp} { + test interp-18.8 {eval in deleted interp} { catch {interp delete a} interp create a a eval { @@ -565,6 +677,1184 @@ if {[info commands testinterpdelete] != ""} { } {1 {attempt to call eval in deleted interpreter}} } +# Test alias deletion + +test interp-19.1 {alias deletion} { + catch {interp delete a} + interp create a + interp alias a foo a bar + set s [interp alias a foo {}] + interp delete a + set s +} {} +test interp-19.2 {alias deletion} { + catch {interp delete a} + interp create a + catch {interp alias a foo {}} msg + interp delete a + set msg +} {alias "foo" not found} +test interp-19.3 {alias deletion} { + catch {interp delete a} + interp create a + interp alias a foo a bar + interp eval a {rename foo zop} + interp alias a foo a zop + catch {interp eval a foo} msg + interp delete a + set msg +} {invalid command name "zop"} +test interp-19.4 {alias deletion} { + catch {interp delete a} + interp create a + interp alias a foo a bar + interp eval a {rename foo zop} + catch {interp eval a foo} msg + interp delete a + set msg +} {invalid command name "foo"} +test interp-19.5 {alias deletion} { + catch {interp delete a} + interp create a + interp eval a {proc bar {} {return 1}} + interp alias a foo a bar + interp eval a {rename foo zop} + catch {interp eval a zop} msg + interp delete a + set msg +} 1 +test interp-19.6 {alias deletion} { + catch {interp delete a} + interp create a + interp alias a foo a bar + interp eval a {rename foo zop} + interp alias a foo a zop + set s [interp aliases a] + interp delete a + set s +} foo +test interp-19.7 {alias deletion, renaming} { + catch {interp delete a} + interp create a + interp alias a foo a bar + interp eval a rename foo blotz + interp alias a foo {} + set s [interp aliases a] + interp delete a + set s +} {} +test interp-19.8 {alias deletion, renaming} { + catch {interp delete a} + interp create a + interp alias a foo a bar + interp eval a rename foo blotz + set l "" + lappend l [interp aliases a] + interp alias a foo {} + lappend l [interp aliases a] + interp delete a + set l +} {foo {}} +test interp-19.9 {alias deletion, renaming} { + catch {interp delete a} + interp create a + interp alias a foo a bar + interp eval a rename foo blotz + interp eval a {proc foo {} {expr 34 * 34}} + interp alias a foo {} + set l [interp eval a foo] + interp delete a + set l +} 1156 + +test interp-20.1 {interp hide, interp expose and interp invokehidden} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + a eval {proc foo {} {}} + a hide foo + catch {a eval foo something} msg + interp delete a + set msg +} {invalid command name "foo"} +test interp-20.2 {interp hide, interp expose and interp invokehidden} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + a hide list + set l "" + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + a expose list + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {1 2 3}} +test interp-20.3 {interp hide, interp expose and interp invokehidden} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + a hide list + set l "" + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + lappend l [catch {a invokehidden list 1 2 3} msg] + lappend l $msg + a expose list + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}} +test interp-20.4 {interp hide, interp expose and interp invokehidden -- passing {}} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + a hide list + set l "" + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + lappend l [catch {a invokehidden list {"" 1 2 3}} msg] + lappend l $msg + a expose list + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}} +test interp-20.5 {interp hide, interp expose and interp invokehidden -- passing {}} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + a hide list + set l "" + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + lappend l [catch {a invokehidden list {{} 1 2 3}} msg] + lappend l $msg + a expose list + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}} +test interp-20.6 {interp invokehidden -- eval args} { + catch {interp delete a} + interp create a + a hide list + set l "" + set z 45 + lappend l [catch {a invokehidden list $z 1 2 3} msg] + lappend l $msg + a expose list + lappend l [catch {a eval list $z 1 2 3} msg] + lappend l $msg + interp delete a + set l +} {0 {45 1 2 3} 0 {45 1 2 3}} +test interp-20.7 {interp invokehidden vs variable eval} { + catch {interp delete a} + interp create a + a hide list + set z 45 + set l "" + lappend l [catch {a invokehidden list {$z a b c}} msg] + lappend l $msg + interp delete a + set l +} {0 {{$z a b c}}} +test interp-20.8 {interp invokehidden vs variable eval} { + catch {interp delete a} + interp create a + a hide list + a eval set z 89 + set z 45 + set l "" + lappend l [catch {a invokehidden list {$z a b c}} msg] + lappend l $msg + interp delete a + set l +} {0 {{$z a b c}}} +test interp-20.9 {interp invokehidden vs variable eval} { + catch {interp delete a} + interp create a + a hide list + a eval set z 89 + set z 45 + set l "" + lappend l [catch {a invokehidden list $z {$z a b c}} msg] + lappend l $msg + interp delete a + set l +} {0 {45 {$z a b c}}} +test interp-20.10 {interp hide, interp expose and interp invokehidden} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + a eval {proc foo {} {}} + interp hide a foo + catch {interp eval a foo something} msg + interp delete a + set msg +} {invalid command name "foo"} +test interp-20.11 {interp hide, interp expose and interp invokehidden} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + interp hide a list + set l "" + lappend l [catch {interp eval a {list 1 2 3}} msg] + lappend l $msg + interp expose a list + lappend l [catch {interp eval a {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {1 2 3}} +test interp-20.12 {interp hide, interp expose and interp invokehidden} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + interp hide a list + set l "" + lappend l [catch {interp eval a {list 1 2 3}} msg] + lappend l $msg + lappend l [catch {interp invokehidden a list 1 2 3} msg] + lappend l $msg + interp expose a list + lappend l [catch {interp eval a {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}} +test interp-20.13 {interp hide, interp expose, interp invokehidden -- passing {}} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + interp hide a list + set l "" + lappend l [catch {interp eval a {list 1 2 3}} msg] + lappend l $msg + lappend l [catch {interp invokehidden a list {"" 1 2 3}} msg] + lappend l $msg + interp expose a list + lappend l [catch {interp eval a {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}} +test interp-20.14 {interp hide, interp expose, interp invokehidden -- passing {}} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + interp hide a list + set l "" + lappend l [catch {interp eval a {list 1 2 3}} msg] + lappend l $msg + lappend l [catch {interp invokehidden a list {{} 1 2 3}} msg] + lappend l $msg + interp expose a list + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}} +test interp-20.15 {interp invokehidden -- eval args} { + catch {interp delete a} + interp create a + interp hide a list + set l "" + set z 45 + lappend l [catch {interp invokehidden a list $z 1 2 3} msg] + lappend l $msg + a expose list + lappend l [catch {interp eval a list $z 1 2 3} msg] + lappend l $msg + interp delete a + set l +} {0 {45 1 2 3} 0 {45 1 2 3}} +test interp-20.16 {interp invokehidden vs variable eval} { + catch {interp delete a} + interp create a + interp hide a list + set z 45 + set l "" + lappend l [catch {interp invokehidden a list {$z a b c}} msg] + lappend l $msg + interp delete a + set l +} {0 {{$z a b c}}} +test interp-20.17 {interp invokehidden vs variable eval} { + catch {interp delete a} + interp create a + interp hide a list + a eval set z 89 + set z 45 + set l "" + lappend l [catch {interp invokehidden a list {$z a b c}} msg] + lappend l $msg + interp delete a + set l +} {0 {{$z a b c}}} +test interp-20.18 {interp invokehidden vs variable eval} { + catch {interp delete a} + interp create a + interp hide a list + a eval set z 89 + set z 45 + set l "" + lappend l [catch {interp invokehidden a list $z {$z a b c}} msg] + lappend l $msg + interp delete a + set l +} {0 {45 {$z a b c}}} +test interp-20.19 {interp invokehidden vs nested commands} { + catch {interp delete a} + interp create a + a hide list + set l [a invokehidden list {[list x y z] f g h} z] + interp delete a + set l +} {{[list x y z] f g h} z} +test interp-20.20 {interp invokehidden vs nested commands} { + catch {interp delete a} + interp create a + a hide list + set l [interp invokehidden a list {[list x y z] f g h} z] + interp delete a + set l +} {{[list x y z] f g h} z} +test interp-20.21 {interp hide vs safety} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [catch {a hide list} msg] + lappend l $msg + interp delete a + set l +} {0 {}} +test interp-20.22 {interp hide vs safety} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [catch {interp hide a list} msg] + lappend l $msg + interp delete a + set l +} {0 {}} +test interp-20.23 {interp hide vs safety} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [catch {a eval {interp hide {} list}} msg] + lappend l $msg + interp delete a + set l +} {1 {permission denied: safe interpreter cannot hide commands}} +test interp-20.24 {interp hide vs safety} { + catch {interp delete a} + interp create a -safe + interp create {a b} + set l "" + lappend l [catch {a eval {interp hide b list}} msg] + lappend l $msg + interp delete a + set l +} {1 {permission denied: safe interpreter cannot hide commands}} +test interp-20.25 {interp hide vs safety} { + catch {interp delete a} + interp create a -safe + interp create {a b} + set l "" + lappend l [catch {interp hide {a b} list} msg] + lappend l $msg + interp delete a + set l +} {0 {}} +test interp-20.26 {interp expoose vs safety} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [catch {a hide list} msg] + lappend l $msg + lappend l [catch {a expose list} msg] + lappend l $msg + interp delete a + set l +} {0 {} 0 {}} +test interp-20.27 {interp expose vs safety} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [catch {interp hide a list} msg] + lappend l $msg + lappend l [catch {interp expose a list} msg] + lappend l $msg + interp delete a + set l +} {0 {} 0 {}} +test interp-20.28 {interp expose vs safety} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [catch {a hide list} msg] + lappend l $msg + lappend l [catch {a eval {interp expose {} list}} msg] + lappend l $msg + interp delete a + set l +} {0 {} 1 {permission denied: safe interpreter cannot expose commands}} +test interp-20.29 {interp expose vs safety} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [catch {interp hide a list} msg] + lappend l $msg + lappend l [catch {a eval {interp expose {} list}} msg] + lappend l $msg + interp delete a + set l +} {0 {} 1 {permission denied: safe interpreter cannot expose commands}} +test interp-20.30 {interp expose vs safety} { + catch {interp delete a} + interp create a -safe + interp create {a b} + set l "" + lappend l [catch {interp hide {a b} list} msg] + lappend l $msg + lappend l [catch {a eval {interp expose b list}} msg] + lappend l $msg + interp delete a + set l +} {0 {} 1 {permission denied: safe interpreter cannot expose commands}} +test interp-20.31 {interp expose vs safety} { + catch {interp delete a} + interp create a -safe + interp create {a b} + set l "" + lappend l [catch {interp hide {a b} list} msg] + lappend l $msg + lappend l [catch {interp expose {a b} list} msg] + lappend l $msg + interp delete a + set l +} {0 {} 0 {}} +test interp-20.32 {interp invokehidden vs safety} { + catch {interp delete a} + interp create a -safe + interp hide a list + set l "" + lappend l [catch {a eval {interp invokehidden {} list a b c}} msg] + lappend l $msg + interp delete a + set l +} {1 {not allowed to invoke hidden commands from safe interpreter}} +test interp-20.33 {interp invokehidden vs safety} { + catch {interp delete a} + interp create a -safe + interp hide a list + set l "" + lappend l [catch {a eval {interp invokehidden {} list a b c}} msg] + lappend l $msg + lappend l [catch {a invokehidden list a b c} msg] + lappend l $msg + interp delete a + set l +} {1 {not allowed to invoke hidden commands from safe interpreter}\ +0 {a b c}} +test interp-20.34 {interp invokehidden vs safety} { + catch {interp delete a} + interp create a -safe + interp create {a b} + interp hide {a b} list + set l "" + lappend l [catch {a eval {interp invokehidden b list a b c}} msg] + lappend l $msg + lappend l [catch {interp invokehidden {a b} list a b c} msg] + lappend l $msg + interp delete a + set l +} {1 {not allowed to invoke hidden commands from safe interpreter}\ +0 {a b c}} +test interp-20.35 {invokehidden at local level} { + catch {interp delete a} + interp create a + a eval { + proc p1 {} { + set z 90 + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a h1 + } + set r [interp eval a p1] + interp delete a + set r +} 91 +test interp-20.36 {invokehidden at local level} { + catch {interp delete a} + interp create a + a eval { + set z 90 + proc p1 {} { + global z + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a h1 + } + set r [interp eval a p1] + interp delete a + set r +} 91 +test interp-20.37 {invokehidden at local level} { + catch {interp delete a} + interp create a + a eval { + proc p1 {} { + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a h1 + } + set r [interp eval a p1] + interp delete a + set r +} 91 +test interp-20.38 {invokehidden at global level} { + catch {interp delete a} + interp create a + a eval { + proc p1 {} { + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a -global h1 + } + set r [catch {interp eval a p1} msg] + interp delete a + list $r $msg +} {1 {can't read "z": no such variable}} +test interp-20.39 {invokehidden at global level} { + catch {interp delete a} + interp create a + a eval { + proc p1 {} { + global z + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a -global h1 + } + set r [catch {interp eval a p1} msg] + interp delete a + list $r $msg +} {0 91} +test interp-20.40 {safe, invokehidden at local level} { + catch {interp delete a} + interp create a -safe + a eval { + proc p1 {} { + set z 90 + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a h1 + } + set r [interp eval a p1] + interp delete a + set r +} 91 +test interp-20.41 {safe, invokehidden at local level} { + catch {interp delete a} + interp create a -safe + a eval { + set z 90 + proc p1 {} { + global z + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a h1 + } + set r [interp eval a p1] + interp delete a + set r +} 91 +test interp-20.42 {safe, invokehidden at local level} { + catch {interp delete a} + interp create a -safe + a eval { + proc p1 {} { + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a h1 + } + set r [interp eval a p1] + interp delete a + set r +} 91 +test interp-20.43 {invokehidden at global level} { + catch {interp delete a} + interp create a + a eval { + proc p1 {} { + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a -global h1 + } + set r [catch {interp eval a p1} msg] + interp delete a + list $r $msg +} {1 {can't read "z": no such variable}} +test interp-20.44 {invokehidden at global level} { + catch {interp delete a} + interp create a + a eval { + proc p1 {} { + global z + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a -global h1 + } + set r [catch {interp eval a p1} msg] + interp delete a + list $r $msg +} {0 91} + +test interp-21.1 {interp hidden} { + interp hidden {} +} "" +test interp-21.2 {interp hidden} { + interp hidden +} "" +test interp-21.3 {interp hidden vs interp hide, interp expose} { + set l "" + lappend l [interp hidden] + interp hide {} pwd + lappend l [interp hidden] + interp expose {} pwd + lappend l [interp hidden] + set l +} {{} pwd {}} +test interp-21.4 {interp hidden} { + catch {interp delete a} + interp create a + set l [interp hidden a] + interp delete a + set l +} "" +test interp-21.5 {interp hidden} { + catch {interp delete a} + interp create -safe a + set l [lsort [interp hidden a]] + interp delete a + set l +} $hidden_cmds +test interp-21.6 {interp hidden vs interp hide, interp expose} { + catch {interp delete a} + interp create a + set l "" + lappend l [interp hidden a] + interp hide a pwd + lappend l [interp hidden a] + interp expose a pwd + lappend l [interp hidden a] + interp delete a + set l +} {{} pwd {}} +test interp-21.7 {interp hidden} { + catch {interp delete a} + interp create a + set l [a hidden] + interp delete a + set l +} "" +test interp-21.8 {interp hidden} { + catch {interp delete a} + interp create a -safe + set l [lsort [a hidden]] + interp delete a + set l +} $hidden_cmds +test interp-21.9 {interp hidden vs interp hide, interp expose} { + catch {interp delete a} + interp create a + set l "" + lappend l [a hidden] + a hide pwd + lappend l [a hidden] + a expose pwd + lappend l [a hidden] + interp delete a + set l +} {{} pwd {}} + +test interp-22.1 {testing interp marktrusted} { + catch {interp delete a} + interp create a + set l "" + lappend l [a issafe] + lappend l [a marktrusted] + lappend l [a issafe] + interp delete a + set l +} {0 {} 0} +test interp-22.2 {testing interp marktrusted} { + catch {interp delete a} + interp create a + set l "" + lappend l [interp issafe a] + lappend l [interp marktrusted a] + lappend l [interp issafe a] + interp delete a + set l +} {0 {} 0} +test interp-22.3 {testing interp marktrusted} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [a issafe] + lappend l [a marktrusted] + lappend l [a issafe] + interp delete a + set l +} {1 {} 0} +test interp-22.4 {testing interp marktrusted} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [interp issafe a] + lappend l [interp marktrusted a] + lappend l [interp issafe a] + interp delete a + set l +} {1 {} 0} +test interp-22.5 {testing interp marktrusted} { + catch {interp delete a} + interp create a -safe + interp create {a b} + catch {a eval {interp marktrusted b}} msg + interp delete a + set msg +} {"interp marktrusted" can only be invoked from a trusted interpreter} +test interp-22.6 {testing interp marktrusted} { + catch {interp delete a} + interp create a -safe + interp create {a b} + catch {a eval {b marktrusted}} msg + interp delete a + set msg +} {"b marktrusted" can only be invoked from a trusted interpreter} +test interp-22.7 {testing interp marktrusted} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [interp issafe a] + interp marktrusted a + interp create {a b} + lappend l [interp issafe a] + lappend l [interp issafe {a b}] + interp delete a + set l +} {1 0 0} +test interp-22.8 {testing interp marktrusted} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [interp issafe a] + interp create {a b} + lappend l [interp issafe {a b}] + interp marktrusted a + interp create {a c} + lappend l [interp issafe a] + lappend l [interp issafe {a c}] + interp delete a + set l +} {1 1 0 0} +test interp-22.9 {testing interp marktrusted} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [interp issafe a] + interp create {a b} + lappend l [interp issafe {a b}] + interp marktrusted {a b} + lappend l [interp issafe a] + lappend l [interp issafe {a b}] + interp create {a b c} + lappend l [interp issafe {a b c}] + interp delete a + set l +} {1 1 1 0 0} + +test interp-23.1 {testing hiding vs aliases} { + catch {interp delete a} + interp create a + set l "" + lappend l [interp hidden a] + a alias bar bar + lappend l [interp aliases a] + lappend l [interp hidden a] + a hide bar + lappend l [interp aliases a] + lappend l [interp hidden a] + a alias bar {} + lappend l [interp aliases a] + lappend l [interp hidden a] + interp delete a + set l +} {{} bar {} bar bar {} {}} +test interp-23.2 {testing hiding vs aliases} {pc || unix} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [lsort [interp hidden a]] + a alias bar bar + lappend l [interp aliases a] + lappend l [lsort [interp hidden a]] + a hide bar + lappend l [interp aliases a] + lappend l [lsort [interp hidden a]] + a alias bar {} + lappend l [interp aliases a] + lappend l [lsort [interp hidden a]] + interp delete a + set l +} {{cd exec exit fconfigure file glob load open pwd socket source vwait} bar {cd exec exit fconfigure file glob load open pwd socket source vwait} bar {bar cd exec exit fconfigure file glob load open pwd socket source vwait} {} {cd exec exit fconfigure file glob load open pwd socket source vwait}} + +test interp-23.3 {testing hiding vs aliases} {macOnly} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [lsort [interp hidden a]] + a alias bar bar + lappend l [interp aliases a] + lappend l [lsort [interp hidden a]] + a hide bar + lappend l [interp aliases a] + lappend l [lsort [interp hidden a]] + a alias bar {} + lappend l [interp aliases a] + lappend l [lsort [interp hidden a]] + interp delete a + set l +} {{beep cd echo exit fconfigure file glob load ls open pwd socket source vwait} bar {beep cd echo exit fconfigure file glob load ls open pwd socket source vwait} bar {bar beep cd echo exit fconfigure file glob load ls open pwd socket source vwait} {} {beep cd echo exit fconfigure file glob load ls open pwd socket source vwait}} + +test interp-24.1 {result resetting on error} { + catch {interp delete a} + interp create a + proc foo args {error $args} + interp alias a foo {} foo + set l [interp eval a { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.2 {result resetting on error} { + catch {interp delete a} + interp create a -safe + proc foo args {error $args} + interp alias a foo {} foo + set l [interp eval a { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.3 {result resetting on error} { + catch {interp delete a} + interp create a + interp create {a b} + interp eval a { + proc foo args {error $args} + } + interp alias {a b} foo a foo + set l [interp eval {a b} { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.4 {result resetting on error} { + catch {interp delete a} + interp create a -safe + interp create {a b} + interp eval a { + proc foo args {error $args} + } + interp alias {a b} foo a foo + set l [interp eval {a b} { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.5 {result resetting on error} { + catch {interp delete a} + catch {interp delete b} + interp create a + interp create b + interp eval a { + proc foo args {error $args} + } + interp alias b foo a foo + set l [interp eval b { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.6 {result resetting on error} { + catch {interp delete a} + catch {interp delete b} + interp create a -safe + interp create b -safe + interp eval a { + proc foo args {error $args} + } + interp alias b foo a foo + set l [interp eval b { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.7 {result resetting on error} { + catch {interp delete a} + interp create a + interp eval a { + proc foo args {error $args} + } + set l {} + lappend l [catch {interp eval a foo 1 2 3} msg] + lappend l $msg + lappend l [catch {interp eval a foo 3 4 5} msg] + lappend l $msg + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.8 {result resetting on error} { + catch {interp delete a} + interp create a -safe + interp eval a { + proc foo args {error $args} + } + set l {} + lappend l [catch {interp eval a foo 1 2 3} msg] + lappend l $msg + lappend l [catch {interp eval a foo 3 4 5} msg] + lappend l $msg + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.9 {result resetting on error} { + catch {interp delete a} + interp create a + interp create {a b} + interp eval {a b} { + proc foo args {error $args} + } + interp eval a { + proc foo args { + eval interp eval b foo $args + } + } + set l {} + lappend l [catch {interp eval a foo 1 2 3} msg] + lappend l $msg + lappend l [catch {interp eval a foo 3 4 5} msg] + lappend l $msg + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.10 {result resetting on error} { + catch {interp delete a} + interp create a -safe + interp create {a b} + interp eval {a b} { + proc foo args {error $args} + } + interp eval a { + proc foo args { + eval interp eval b foo $args + } + } + set l {} + lappend l [catch {interp eval a foo 1 2 3} msg] + lappend l $msg + lappend l [catch {interp eval a foo 3 4 5} msg] + lappend l $msg + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.11 {result resetting on error} { + catch {interp delete a} + interp create a + interp create {a b} + interp eval {a b} { + proc foo args {error $args} + } + interp eval a { + proc foo args { + set l {} + lappend l [catch {eval interp eval b foo $args} msg] + lappend l $msg + lappend l [catch {eval interp eval b foo $args} msg] + lappend l $msg + set l + } + } + set l [interp eval a foo 1 2 3] + interp delete a + set l +} {1 {1 2 3} 1 {1 2 3}} +test interp-24.12 {result resetting on error} { + catch {interp delete a} + interp create a -safe + interp create {a b} + interp eval {a b} { + proc foo args {error $args} + } + interp eval a { + proc foo args { + set l {} + lappend l [catch {eval interp eval b foo $args} msg] + lappend l $msg + lappend l [catch {eval interp eval b foo $args} msg] + lappend l $msg + set l + } + } + set l [interp eval a foo 1 2 3] + interp delete a + set l +} {1 {1 2 3} 1 {1 2 3}} + +unset hidden_cmds + +test interp-25.1 {testing aliasing of string commands} { + catch {interp delete a} + interp create a + a alias exec foo ;# Relies on exec being a string command! + interp delete a +} "" + foreach i [interp slaves] { interp delete $i } diff --git a/contrib/tcl/tests/io.test b/contrib/tcl/tests/io.test index 2c856246c0896..c83033b4a1a8b 100644 --- a/contrib/tcl/tests/io.test +++ b/contrib/tcl/tests/io.test @@ -11,13 +11,26 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# "@(#) io.test 1.87 96/07/30 11:59:00" +# SCCS: @(#) io.test 1.119 97/06/23 18:47:01 if {[string compare test [info procs test]] == 1} then {source defs} +if {"[info commands testchannel]" != "testchannel"} { + puts "Skipping io tests. This application does not seem to have the" + puts "testchannel command that is needed to run these tests." + return +} + removeFile test1 removeFile pipe +set testConfig(umask2) 1 +catch { + if {"[exec umask]" != "002"} { + set testConfig(umask2) 0 + } +} + # set up a long data file for some of the following tests set f [open longfile w] @@ -209,6 +222,42 @@ test io-1.7 {Tcl_GetChannel: stdio name translation} { interp delete z set result } {{} {} {can not find channel named "stderr"}} +test io-1.8 {reuse of stdio special channels} {unixOnly} { + removeFile script + removeFile test1 + set f [open script w] + puts $f { + close stderr + set f [open test1 w] + puts stderr hello + close $f + set f [open test1 r] + puts [gets $f] + } + close $f + set f [open "|$tcltest script" r] + set c [gets $f] + close $f + set c +} hello +test io-1.9 {reuse of stdio special channels} {unixOnly} { + removeFile script + removeFile test1 + set f [open script w] + puts $f { + set f [open test1 w] + puts $f hello + close $f + close stderr + set f [open "|cat test1" r] + puts [gets $f] + } + close $f + set f [open "|$tcltest script" r] + set c [gets $f] + close $f + set c +} hello # Must add test function for testing Tcl_CreateCloseHandler and # Tcl_DeleteCloseHandler. @@ -216,38 +265,47 @@ test io-1.7 {Tcl_GetChannel: stdio name translation} { # Test channel table management. The functions tested are # GetChannelTable, DeleteChannelTable, Tcl_RegisterChannel, # Tcl_UnregisterChannel, Tcl_GetChannel and Tcl_CreateChannel. +# +# These functions use "eof stdin" to ensure that the standard +# channels are added to the channel table of the interpreter. -test io-3.1 {GetChannelTable, DeleteChannelTable on std handles} { +test io-2.1 {GetChannelTable, DeleteChannelTable on std handles} { + set l1 [testchannel refcount stdin] + eof stdin interp create x set l "" - lappend l [testchannel refcount stdin] + lappend l [expr [testchannel refcount stdin] - $l1] x eval {eof stdin} - lappend l [testchannel refcount stdin] + lappend l [expr [testchannel refcount stdin] - $l1] interp delete x - lappend l [testchannel refcount stdin] + lappend l [expr [testchannel refcount stdin] - $l1] set l -} {2 2 1} -test io-3.2 {GetChannelTable, DeleteChannelTable on std handles} { +} {0 1 0} +test io-2.2 {GetChannelTable, DeleteChannelTable on std handles} { + set l1 [testchannel refcount stdout] + eof stdin interp create x set l "" - lappend l [testchannel refcount stdout] + lappend l [expr [testchannel refcount stdout] - $l1] x eval {eof stdout} - lappend l [testchannel refcount stdout] + lappend l [expr [testchannel refcount stdout] - $l1] interp delete x - lappend l [testchannel refcount stdout] + lappend l [expr [testchannel refcount stdout] - $l1] set l -} {2 2 1} -test io-3.3 {GetChannelTable, DeleteChannelTable on std handles} { +} {0 1 0} +test io-2.3 {GetChannelTable, DeleteChannelTable on std handles} { + set l1 [testchannel refcount stderr] + eof stdin interp create x set l "" - lappend l [testchannel refcount stderr] + lappend l [expr [testchannel refcount stderr] - $l1] x eval {eof stderr} - lappend l [testchannel refcount stderr] + lappend l [expr [testchannel refcount stderr] - $l1] interp delete x - lappend l [testchannel refcount stderr] + lappend l [expr [testchannel refcount stderr] - $l1] set l -} {2 2 1} -test io-3.4 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { +} {0 1 0} +test io-2.4 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { removeFile test1 set l "" set f [open test1 w] @@ -261,7 +319,7 @@ test io-3.4 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { string compare [string tolower $l] \ [list 1 [format "can not find channel named \"%s\"" $f]] } 0 -test io-3.5 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { +test io-2.5 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { removeFile test1 set l "" set f [open test1 w] @@ -282,7 +340,7 @@ test io-3.5 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { string compare [string tolower $l] \ [list 1 2 1 1 [format "can not find channel named \"%s\"" $f]] } 0 -test io-3.6 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { +test io-2.6 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { removeFile test1 set l "" set f [open test1 w] @@ -301,20 +359,20 @@ test io-3.6 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { string compare [string tolower $l] \ [list 1 2 1 [format "can not find channel named \"%s\"" $f]] } 0 -test io-3.7 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} { +test io-2.7 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} { eof stdin } 0 -test io-3.6 {testing Tcl_GetChannel, user opened handle} { +test io-2.8 {testing Tcl_GetChannel, user opened handle} { removeFile test1 set f [open test1 w] set x [eof $f] close $f set x } 0 -test io-3.8 {Tcl_GetChannel, channel not found} { +test io-2.9 {Tcl_GetChannel, channel not found} { list [catch {eof file34} msg] $msg } {1 {can not find channel named "file34"}} -test io-3.9 {Tcl_CreateChannel, insertion into channel table} { +test io-2.10 {Tcl_CreateChannel, insertion into channel table} { removeFile test1 set f [open test1 w] set l "" @@ -335,21 +393,21 @@ test io-3.9 {Tcl_CreateChannel, insertion into channel table} { # Tcl_GetChannelType and Tcl_GetChannelFile. Tcl_GetChannelInstanceData # not tested because files do not use the instance data. -test io-4.1 {Tcl_GetChannelName} { +test io-3.1 {Tcl_GetChannelName} { removeFile test1 set f [open test1 w] set n [testchannel name $f] close $f string compare $n $f } 0 -test io-4.2 {Tcl_GetChannelType} { +test io-3.2 {Tcl_GetChannelType} { removeFile test1 set f [open test1 w] set t [testchannel type $f] close $f string compare $t file } 0 -test io-4.3 {Tcl_GetChannelFile, input} { +test io-3.3 {Tcl_GetChannelFile, input} { set f [open test1 w] fconfigure $f -translation lf -eofchar {} puts $f "1234567890\n098765432" @@ -362,7 +420,7 @@ test io-4.3 {Tcl_GetChannelFile, input} { close $f set l } {10 11} -test io-4.4 {Tcl_GetChannelFile, output} { +test io-3.4 {Tcl_GetChannelFile, output} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -380,7 +438,7 @@ test io-4.4 {Tcl_GetChannelFile, output} { # Test flushing. The functions tested here are FlushChannel. -test io-5.1 {FlushChannel, no output buffered} { +test io-4.1 {FlushChannel, no output buffered} { removeFile test1 set f [open test1 w] flush $f @@ -388,7 +446,7 @@ test io-5.1 {FlushChannel, no output buffered} { close $f set s } 0 -test io-5.2 {FlushChannel, some output buffered} { +test io-4.2 {FlushChannel, some output buffered} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -401,7 +459,7 @@ test io-5.2 {FlushChannel, some output buffered} { lappend l [file size test1] set l } {0 6 6} -test io-5.3 {FlushChannel, implicit flush on close} { +test io-4.3 {FlushChannel, implicit flush on close} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -412,7 +470,7 @@ test io-5.3 {FlushChannel, implicit flush on close} { lappend l [file size test1] set l } {0 6} -test io-5.4 {FlushChannel, implicit flush when buffer fills} { +test io-4.4 {FlushChannel, implicit flush when buffer fills} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -428,7 +486,7 @@ test io-5.4 {FlushChannel, implicit flush when buffer fills} { close $f set l } {0 60 72} -test io-5.5 {FlushChannel, implicit flush when buffer fills and on close} {unixOrPc} { +test io-4.5 {FlushChannel, implicit flush when buffer fills and on close} {unixOrPc} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffersize 60 -eofchar {} @@ -442,7 +500,7 @@ test io-5.5 {FlushChannel, implicit flush when buffer fills and on close} {unixO lappend l [file size test1] set l } {0 60 72} -test io-5.6 {FlushChannel, async flushing, async close} {unixOrPc asyncPipeClose} { +test io-4.6 {FlushChannel, async flushing, async close} {unixOrPc asyncPipeClose} { removeFile pipe removeFile output set f [open pipe w] @@ -481,7 +539,7 @@ test io-5.6 {FlushChannel, async flushing, async close} {unixOrPc asyncPipeClose # Tests closing a channel. The functions tested are CloseChannel and Tcl_Close. -test io-6.1 {CloseChannel called when all references are dropped} { +test io-5.1 {CloseChannel called when all references are dropped} { removeFile test1 set f [open test1 w] interp create x @@ -494,7 +552,7 @@ test io-6.1 {CloseChannel called when all references are dropped} { close $f set l } {2 1} -test io-6.2 {CloseChannel called when all references are dropped} { +test io-5.2 {CloseChannel called when all references are dropped} { removeFile test1 set f [open test1 w] interp create x @@ -509,7 +567,7 @@ test io-6.2 {CloseChannel called when all references are dropped} { close $f set l } abcdef -test io-6.3 {CloseChannel, not called before output queue is empty} {unixOrPc asyncPipeClose tempNotPc nonPortable} { +test io-5.3 {CloseChannel, not called before output queue is empty} {unixOrPc asyncPipeClose tempNotPc nonPortable} { removeFile pipe removeFile output set f [open pipe w] @@ -552,13 +610,8 @@ test io-6.3 {CloseChannel, not called before output queue is empty} {unixOrPc as } else { set result ok } - # - # Wait for the flush to finish - # - catch {vwait x} - set result } ok -test io-6.4 {Tcl_Close} { +test io-5.4 {Tcl_Close} { removeFile test1 set l "" lappend l [lsort [testchannel open]] @@ -571,7 +624,7 @@ test io-6.4 {Tcl_Close} { $consoleFileNames] string compare $l $x } 0 -test io-6.5 {Tcl_Close vs standard handles} {unixOnly} { +test io-5.5 {Tcl_Close vs standard handles} {unixOnly} { removeFile script set f [open script w] puts $f { @@ -588,10 +641,10 @@ test io-6.5 {Tcl_Close vs standard handles} {unixOnly} { # Test output on channels. The functions tested are Tcl_Write # and Tcl_Flush. -test io-7.1 {Tcl_Write, channel not writable} { +test io-6.1 {Tcl_Write, channel not writable} { list [catch {puts stdin hello} msg] $msg } {1 {channel "stdin" wasn't opened for writing}} -test io-7.2 {Tcl_Write, empty string} { +test io-6.2 {Tcl_Write, empty string} { removeFile test1 set f [open test1 w] fconfigure $f -eofchar {} @@ -599,7 +652,7 @@ test io-7.2 {Tcl_Write, empty string} { close $f file size test1 } 0 -test io-7.3 {Tcl_Write, nonempty string} { +test io-6.3 {Tcl_Write, nonempty string} { removeFile test1 set f [open test1 w] fconfigure $f -eofchar {} @@ -607,7 +660,7 @@ test io-7.3 {Tcl_Write, nonempty string} { close $f file size test1 } 5 -test io-7.4 {Tcl_Write, buffering in full buffering mode} { +test io-6.4 {Tcl_Write, buffering in full buffering mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering full -eofchar {} @@ -621,7 +674,7 @@ test io-7.4 {Tcl_Write, buffering in full buffering mode} { close $f set l } {6 0 0 6} -test io-7.5 {Tcl_Write, buffering in line buffering mode} { +test io-6.5 {Tcl_Write, buffering in line buffering mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering line -eofchar {} @@ -635,7 +688,7 @@ test io-7.5 {Tcl_Write, buffering in line buffering mode} { close $f set l } {5 0 0 11} -test io-7.6 {Tcl_Write, buffering in no buffering mode} { +test io-6.6 {Tcl_Write, buffering in no buffering mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering none -eofchar {} @@ -649,7 +702,7 @@ test io-7.6 {Tcl_Write, buffering in no buffering mode} { close $f set l } {0 5 0 11} -test io-7.7 {Tcl_Flush, full buffering} { +test io-6.7 {Tcl_Flush, full buffering} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering full -eofchar {} @@ -666,7 +719,7 @@ test io-7.7 {Tcl_Flush, full buffering} { close $f set l } {5 0 11 0 0 11} -test io-7.8 {Tcl_Flush, full buffering} { +test io-6.8 {Tcl_Flush, full buffering} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering line @@ -686,10 +739,10 @@ test io-7.8 {Tcl_Flush, full buffering} { close $f set l } {5 0 0 5 0 11 0 11} -test io-7.9 {Tcl_Flush, channel not writable} { +test io-6.9 {Tcl_Flush, channel not writable} { list [catch {flush stdin} msg] $msg } {1 {channel "stdin" wasn't opened for writing}} -test io-7.10 {Tcl_Write, looping and buffering} { +test io-6.10 {Tcl_Write, looping and buffering} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -701,7 +754,7 @@ test io-7.10 {Tcl_Write, looping and buffering} { close $f1 file size test1 } 387 -test io-7.11 {Tcl_Write, no newline, implicit flush} { +test io-6.11 {Tcl_Write, no newline, implicit flush} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -eofchar {} @@ -713,7 +766,7 @@ test io-7.11 {Tcl_Write, no newline, implicit flush} { close $f2 file size test1 } 377 -test io-7.12 {Tcl_Write on a pipe} {unixOrPc} { +test io-6.12 {Tcl_Write on a pipe} {unixOrPc} { removeFile test1 removeFile pipe set f1 [open pipe w] @@ -738,7 +791,7 @@ test io-7.12 {Tcl_Write on a pipe} {unixOrPc} { close $f2 set y } ok -test io-7.13 {Tcl_Write to a pipe, line buffered} {unixOrPc} { +test io-6.13 {Tcl_Write to a pipe, line buffered} {unixOrPc} { removeFile test1 removeFile pipe set f1 [open pipe w] @@ -767,7 +820,7 @@ test io-7.13 {Tcl_Write to a pipe, line buffered} {unixOrPc} { close $f2 set y } ok -test io-7.14 {Tcl_Write, buffering and implicit flush at close} { +test io-6.14 {Tcl_Write, buffering and implicit flush at close} { removeFile test3 set f [open test3 w] puts -nonewline $f "Text1" @@ -779,7 +832,7 @@ test io-7.14 {Tcl_Write, buffering and implicit flush at close} { close $f set x } {Text1 Text 2 Text 3} -test io-7.15 {Tcl_Flush, channel not open for writing} { +test io-6.15 {Tcl_Flush, channel not open for writing} { removeFile test1 set fd [open test1 w] close $fd @@ -789,14 +842,14 @@ test io-7.15 {Tcl_Flush, channel not open for writing} { string compare $x \ [list 1 "channel \"$fd\" wasn't opened for writing"] } 0 -test io-7.16 {Tcl_Flush on pipe opened only for reading} {unixOrPc unixExecs} { +test io-6.16 {Tcl_Flush on pipe opened only for reading} {unixOrPc unixExecs} { set fd [open "|cat longfile" r] set x [list [catch {flush $fd} msg] $msg] catch {close $fd} string compare $x \ [list 1 "channel \"$fd\" wasn't opened for writing"] } 0 -test io-7.17 {Tcl_Write buffers, then Tcl_Flush flushes} { +test io-6.17 {Tcl_Write buffers, then Tcl_Flush flushes} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf @@ -808,7 +861,7 @@ test io-7.17 {Tcl_Write buffers, then Tcl_Flush flushes} { close $f1 set x } 18 -test io-7.18 {Tcl_Write and Tcl_Flush intermixed} { +test io-6.18 {Tcl_Write and Tcl_Flush intermixed} { removeFile test1 set x "" set f1 [open test1 w] @@ -827,7 +880,7 @@ test io-7.18 {Tcl_Write and Tcl_Flush intermixed} { close $f1 set x } {18 24 30} -test io-7.19 {Explicit and implicit flushes} { +test io-6.19 {Explicit and implicit flushes} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -845,7 +898,7 @@ test io-7.19 {Explicit and implicit flushes} { lappend x [file size test1] set x } {18 24 30} -test io-7.20 {Implicit flush when buffer is full} { +test io-6.20 {Implicit flush when buffer is full} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -863,7 +916,7 @@ test io-7.20 {Implicit flush when buffer is full} { lappend z [file size test1] set z } {4096 12288 12600} -test io-7.21 {Tcl_Flush to pipe} {unixOrPc} { +test io-6.21 {Tcl_Flush to pipe} {unixOrPc} { removeFile pipe set f1 [open pipe w] puts $f1 {set x [read stdin 6]} @@ -877,7 +930,7 @@ test io-7.21 {Tcl_Flush to pipe} {unixOrPc} { catch {close $f1} set x } "read 6 characters" -test io-7.22 {Tcl_Flush called at other end of pipe} {unixOrPc} { +test io-6.22 {Tcl_Flush called at other end of pipe} {unixOrPc} { removeFile pipe set f1 [open pipe w] puts $f1 { @@ -900,7 +953,7 @@ test io-7.22 {Tcl_Flush called at other end of pipe} {unixOrPc} { close $f1 set x } {hello hello bye} -test io-7.23 {Tcl_Flush and line buffering at end of pipe} {unixOrPc} { +test io-6.23 {Tcl_Flush and line buffering at end of pipe} {unixOrPc} { removeFile pipe set f1 [open pipe w] puts $f1 { @@ -920,7 +973,7 @@ test io-7.23 {Tcl_Flush and line buffering at end of pipe} {unixOrPc} { close $f1 set x } {hello hello bye} -test io-7.24 {Tcl_Write and Tcl_Flush move end of file} { +test io-6.24 {Tcl_Write and Tcl_Flush move end of file} { set f [open test3 w] puts $f "Line 1" puts $f "Line 2" @@ -936,7 +989,7 @@ test io-7.24 {Tcl_Write and Tcl_Flush move end of file} { set x } {{} {Line 1 Line 2}} -test io-7.25 {Implicit flush with Tcl_Flush to command pipelines} {unixOrPc unixExecs} { +test io-6.25 {Implicit flush with Tcl_Flush to command pipelines} {unixOrPc unixExecs} { removeFile test3 set f [open "| cat | cat > test3" w] puts $f "Line 1" @@ -950,7 +1003,7 @@ test io-7.25 {Implicit flush with Tcl_Flush to command pipelines} {unixOrPc unix } {Line 1 Line 2 } -test io-7.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {unixOrPc unixExecs} { +test io-6.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {unixOrPc unixExecs} { set f [open "| cat -u" r+] puts $f "Line1" flush $f @@ -958,7 +1011,7 @@ test io-7.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {unixOrPc unixExe close $f set x } {Line1} -test io-7.27 {Tcl_Flush on closed pipeline} {unixOrPc tempNotPc} { +test io-6.27 {Tcl_Flush on closed pipeline} {unixOrPc tempNotPc} { removeFile pipe set f [open pipe w] puts $f {exit} @@ -986,7 +1039,7 @@ test io-7.27 {Tcl_Flush on closed pipeline} {unixOrPc tempNotPc} { regsub {".*":} $x {"":} x string tolower $x } {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}} -test io-7.28 {Tcl_Write, lf mode} { +test io-6.28 {Tcl_Write, lf mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -996,7 +1049,7 @@ test io-7.28 {Tcl_Write, lf mode} { close $f set s } 21 -test io-7.29 {Tcl_Write, cr mode} { +test io-6.29 {Tcl_Write, cr mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -1004,7 +1057,7 @@ test io-7.29 {Tcl_Write, cr mode} { close $f file size test1 } 21 -test io-7.30 {Tcl_Write, crlf mode} { +test io-6.30 {Tcl_Write, crlf mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -1012,7 +1065,7 @@ test io-7.30 {Tcl_Write, crlf mode} { close $f file size test1 } 25 -test io-7.31 {Tcl_Write, background flush} {unixOrPc} { +test io-6.31 {Tcl_Write, background flush} {unixOrPc} { removeFile pipe removeFile output set f [open pipe w] @@ -1048,7 +1101,7 @@ test io-7.31 {Tcl_Write, background flush} {unixOrPc} { set result ok } } ok -test io-7.32 {Tcl_Write, background flush to slow reader} {unixOrPc asyncPipeClose} { +test io-6.32 {Tcl_Write, background flush to slow reader} {unixOrPc asyncPipeClose} { removeFile pipe removeFile output set f [open pipe w] @@ -1085,7 +1138,7 @@ test io-7.32 {Tcl_Write, background flush to slow reader} {unixOrPc asyncPipeClo set result ok } } ok -test io-7.33 {Tcl_Flush, implicit flush on exit} {unixOrPc} { +test io-6.33 {Tcl_Flush, implicit flush on exit} {unixOrPc} { set f [open script w] puts $f { set f [open test1 w] @@ -1104,7 +1157,8 @@ test io-7.33 {Tcl_Flush, implicit flush on exit} {unixOrPc} { bye strange } -test io-7.34 {Tcl_Close, async flush on close, using sockets} { + +test io-6.34 {Tcl_Close, async flush on close, using sockets} {tempNotMac} { set c 0 set x running set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz @@ -1140,7 +1194,7 @@ test io-7.34 {Tcl_Close, async flush on close, using sockets} { vwait x set c } 2000 -test io-7.35 {Tcl_Close vs fileevent vs multiple interpreters} { +test io-6.35 {Tcl_Close vs fileevent vs multiple interpreters} { catch {interp delete x} catch {interp delete y} interp create x @@ -1181,7 +1235,7 @@ test io-7.35 {Tcl_Close vs fileevent vs multiple interpreters} { # Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read. -test io-8.1 {Tcl_Write lf, Tcl_Read lf} { +test io-7.1 {Tcl_Write lf, Tcl_Read lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1193,7 +1247,7 @@ test io-8.1 {Tcl_Write lf, Tcl_Read lf} { close $f set x } "hello\nthere\nand\nhere\n" -test io-8.2 {Tcl_Write lf, Tcl_Read cr} { +test io-7.2 {Tcl_Write lf, Tcl_Read cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1205,7 +1259,7 @@ test io-8.2 {Tcl_Write lf, Tcl_Read cr} { close $f set x } "hello\nthere\nand\nhere\n" -test io-8.3 {Tcl_Write lf, Tcl_Read crlf} { +test io-7.3 {Tcl_Write lf, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1217,7 +1271,7 @@ test io-8.3 {Tcl_Write lf, Tcl_Read crlf} { close $f set x } "hello\nthere\nand\nhere\n" -test io-8.4 {Tcl_Write cr, Tcl_Read cr} { +test io-7.4 {Tcl_Write cr, Tcl_Read cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1229,7 +1283,7 @@ test io-8.4 {Tcl_Write cr, Tcl_Read cr} { close $f set x } "hello\nthere\nand\nhere\n" -test io-8.5 {Tcl_Write cr, Tcl_Read lf} { +test io-7.5 {Tcl_Write cr, Tcl_Read lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1241,7 +1295,7 @@ test io-8.5 {Tcl_Write cr, Tcl_Read lf} { close $f set x } "hello\rthere\rand\rhere\r" -test io-8.6 {Tcl_Write cr, Tcl_Read crlf} { +test io-7.6 {Tcl_Write cr, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1253,7 +1307,7 @@ test io-8.6 {Tcl_Write cr, Tcl_Read crlf} { close $f set x } "hello\rthere\rand\rhere\r" -test io-8.7 {Tcl_Write crlf, Tcl_Read crlf} { +test io-7.7 {Tcl_Write crlf, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1265,7 +1319,7 @@ test io-8.7 {Tcl_Write crlf, Tcl_Read crlf} { close $f set x } "hello\nthere\nand\nhere\n" -test io-8.8 {Tcl_Write crlf, Tcl_Read lf} { +test io-7.8 {Tcl_Write crlf, Tcl_Read lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1277,7 +1331,7 @@ test io-8.8 {Tcl_Write crlf, Tcl_Read lf} { close $f set x } "hello\r\nthere\r\nand\r\nhere\r\n" -test io-8.9 {Tcl_Write crlf, Tcl_Read cr} { +test io-7.9 {Tcl_Write crlf, Tcl_Read cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1289,7 +1343,7 @@ test io-8.9 {Tcl_Write crlf, Tcl_Read cr} { close $f set x } "hello\n\nthere\n\nand\n\nhere\n\n" -test io-8.10 {Tcl_Write lf, Tcl_Read auto} { +test io-7.10 {Tcl_Write lf, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1305,7 +1359,7 @@ there and here } auto} -test io-8.11 {Tcl_Write cr, Tcl_Read auto} { +test io-7.11 {Tcl_Write cr, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1321,7 +1375,7 @@ there and here } auto} -test io-8.12 {Tcl_Write crlf, Tcl_Read auto} { +test io-7.12 {Tcl_Write crlf, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1338,7 +1392,7 @@ and here } auto} -test io-8.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { +test io-7.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1355,7 +1409,7 @@ test io-8.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { string length $c } [expr 700*15+1] -test io-8.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { +test io-7.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1372,7 +1426,7 @@ test io-8.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { string length $c } [expr 700*15+1] -test io-8.15 {Tcl_Write mixed, Tcl_Read auto} { +test io-7.15 {Tcl_Write mixed, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1388,7 +1442,7 @@ there and here } -test io-8.16 {Tcl_Write ^Z at end, Tcl_Read auto} { +test io-7.16 {Tcl_Write ^Z at end, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1404,7 +1458,7 @@ there and here } -test io-8.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} { +test io-7.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} { removeFile test1 set f [open test1 w] fconfigure $f -eofchar \x1a -translation lf @@ -1420,7 +1474,7 @@ there and here } -test io-8.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { +test io-7.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1440,7 +1494,7 @@ test io-8.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { close $f set l } {abc def 0 {} 1 {} 1} -test io-8.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { +test io-7.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1460,7 +1514,7 @@ test io-8.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { close $f set l } {abc def 0 {} 1 {} 1} -test io-8.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { +test io-7.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -1482,7 +1536,7 @@ test io-8.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { close $f set l } "abc def 0 \x1aghi 0 qrs 0 {} 1" -test io-8.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { +test io-7.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -1500,7 +1554,7 @@ test io-8.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { close $f set l } {0 1 {} 1} -test io-8.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { +test io-7.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -1518,7 +1572,7 @@ test io-8.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { close $f set l } {0 1 {} 1} -test io-8.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { +test io-7.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1532,7 +1586,7 @@ test io-8.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { close $f list $c $e } {8 1} -test io-8.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { +test io-7.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1546,7 +1600,7 @@ test io-8.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { close $f list $c $e } {8 1} -test io-8.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { +test io-7.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1560,7 +1614,7 @@ test io-8.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { close $f list $c $e } {8 1} -test io-8.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { +test io-7.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1574,7 +1628,7 @@ test io-8.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { close $f list $c $e } {8 1} -test io-8.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { +test io-7.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1588,7 +1642,7 @@ test io-8.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { close $f list $c $e } {8 1} -test io-8.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { +test io-7.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1605,7 +1659,7 @@ test io-8.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { # Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets. -test io-9.1 {Tcl_Write lf, Tcl_Gets auto} { +test io-8.1 {Tcl_Write lf, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1622,7 +1676,7 @@ test io-9.1 {Tcl_Write lf, Tcl_Gets auto} { close $f set l } {hello 6 auto there 12 auto} -test io-9.2 {Tcl_Write cr, Tcl_Gets auto} { +test io-8.2 {Tcl_Write cr, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1639,7 +1693,7 @@ test io-9.2 {Tcl_Write cr, Tcl_Gets auto} { close $f set l } {hello 6 auto there 12 auto} -test io-9.3 {Tcl_Write crlf, Tcl_Gets auto} { +test io-8.3 {Tcl_Write crlf, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1656,7 +1710,7 @@ test io-9.3 {Tcl_Write crlf, Tcl_Gets auto} { close $f set l } {hello 7 auto there 14 auto} -test io-9.4 {Tcl_Write lf, Tcl_Gets lf} { +test io-8.4 {Tcl_Write lf, Tcl_Gets lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1674,7 +1728,7 @@ test io-9.4 {Tcl_Write lf, Tcl_Gets lf} { close $f set l } {hello 6 lf there 12 lf} -test io-9.5 {Tcl_Write lf, Tcl_Gets cr} { +test io-8.5 {Tcl_Write lf, Tcl_Gets cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1694,7 +1748,7 @@ test io-9.5 {Tcl_Write lf, Tcl_Gets cr} { close $f set l } {20 21 cr 1 {} 21 cr 1} -test io-9.6 {Tcl_Write lf, Tcl_Gets crlf} { +test io-8.6 {Tcl_Write lf, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1714,7 +1768,7 @@ test io-9.6 {Tcl_Write lf, Tcl_Gets crlf} { close $f set l } {20 21 crlf 1 {} 21 crlf 1} -test io-9.7 {Tcl_Write cr, Tcl_Gets cr} { +test io-8.7 {Tcl_Write cr, Tcl_Gets cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1734,7 +1788,7 @@ test io-9.7 {Tcl_Write cr, Tcl_Gets cr} { close $f set l } {hello 6 cr 0 there 12 cr 0} -test io-9.8 {Tcl_Write cr, Tcl_Gets lf} { +test io-8.8 {Tcl_Write cr, Tcl_Gets lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1754,7 +1808,7 @@ test io-9.8 {Tcl_Write cr, Tcl_Gets lf} { close $f set l } {21 21 lf 1 {} 21 lf 1} -test io-9.9 {Tcl_Write cr, Tcl_Gets crlf} { +test io-8.9 {Tcl_Write cr, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1774,7 +1828,7 @@ test io-9.9 {Tcl_Write cr, Tcl_Gets crlf} { close $f set l } {21 21 crlf 1 {} 21 crlf 1} -test io-9.10 {Tcl_Write crlf, Tcl_Gets crlf} { +test io-8.10 {Tcl_Write crlf, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1794,7 +1848,7 @@ test io-9.10 {Tcl_Write crlf, Tcl_Gets crlf} { close $f set l } {hello 7 crlf 0 there 14 crlf 0} -test io-9.11 {Tcl_Write crlf, Tcl_Gets cr} { +test io-8.11 {Tcl_Write crlf, Tcl_Gets cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1814,7 +1868,7 @@ test io-9.11 {Tcl_Write crlf, Tcl_Gets cr} { close $f set l } {hello 6 cr 0 6 13 cr 0} -test io-9.12 {Tcl_Write crlf, Tcl_Gets lf} { +test io-8.12 {Tcl_Write crlf, Tcl_Gets lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1834,7 +1888,7 @@ test io-9.12 {Tcl_Write crlf, Tcl_Gets lf} { close $f set l } {6 7 lf 0 6 14 lf 0} -test io-9.13 {binary mode is synonym of lf mode} { +test io-8.13 {binary mode is synonym of lf mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation binary @@ -1846,7 +1900,7 @@ test io-9.13 {binary mode is synonym of lf mode} { # Test io-9.14 has been removed because "auto" output translation mode is # not supoprted. # -test io-9.15 {Tcl_Write mixed, Tcl_Gets auto} { +test io-8.14 {Tcl_Write mixed, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1865,7 +1919,7 @@ test io-9.15 {Tcl_Write mixed, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-9.16 {Tcl_Write mixed, Tcl_Gets auto} { +test io-8.15 {Tcl_Write mixed, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1884,7 +1938,7 @@ test io-9.16 {Tcl_Write mixed, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-9.17 {Tcl_Write mixed, Tcl_Gets auto} { +test io-8.16 {Tcl_Write mixed, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1902,7 +1956,7 @@ test io-9.17 {Tcl_Write mixed, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-9.18 {Tcl_Write mixed, Tcl_Gets auto} { +test io-8.17 {Tcl_Write mixed, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1921,7 +1975,7 @@ test io-9.18 {Tcl_Write mixed, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-9.19 {Tcl_Write ^Z at end, Tcl_Gets auto} { +test io-8.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1941,7 +1995,7 @@ test io-9.19 {Tcl_Write ^Z at end, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-9.20 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { +test io-8.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -eofchar \x1a -translation lf @@ -1960,7 +2014,7 @@ test io-9.20 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-9.21 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { +test io-8.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1979,7 +2033,7 @@ test io-9.21 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { close $f set l } {abc def 0 {} 1} -test io-9.22 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { +test io-8.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1997,7 +2051,7 @@ test io-9.22 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { close $f set l } {abc def 0 {} 1} -test io-9.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { +test io-8.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -2019,7 +2073,7 @@ test io-9.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { close $f set l } "abc def 0 \x1aqrs 0 tuv 0 {} 1" -test io-9.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { +test io-8.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -2041,7 +2095,7 @@ test io-9.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { close $f set l } "abc def 0 \x1aqrs 0 tuv 0 {} 1" -test io-9.25 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { +test io-8.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -2063,7 +2117,7 @@ test io-9.25 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { close $f set l } "abc def 0 \x1aqrs 0 tuv 0 {} 1" -test io-9.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { +test io-8.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -2081,7 +2135,7 @@ test io-9.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { close $f set l } {abc def 0 {} 1} -test io-9.27 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { +test io-8.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -2099,7 +2153,7 @@ test io-9.27 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { close $f set l } {abc def 0 {} 1} -test io-9.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { +test io-8.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -2117,7 +2171,7 @@ test io-9.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { close $f set l } {abc def 0 {} 1} -test io-9.29 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { +test io-8.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -2135,7 +2189,7 @@ test io-9.29 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { close $f set l } {abc def 0 {} 1} -test io-9.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { +test io-8.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -2153,7 +2207,7 @@ test io-9.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { close $f set l } {abc def 0 {} 1} -test io-9.31 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { +test io-8.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -2171,7 +2225,7 @@ test io-9.31 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { close $f set l } {abc def 0 {} 1} -test io-9.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { +test io-8.31 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -2190,7 +2244,7 @@ test io-9.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { close $f string length $c } [expr 700*15+1] -test io-9.33 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { +test io-8.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -2213,19 +2267,19 @@ test io-9.33 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { # Test Tcl_Read and buffering. -test io-10.1 {Tcl_Read, channel not readable} { +test io-9.1 {Tcl_Read, channel not readable} { list [catch {read stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} -test io-10.2 {Tcl_Read, zero byte count} { +test io-9.2 {Tcl_Read, zero byte count} { read stdin 0 } "" -test io-10.3 {Tcl_Read, negative byte count} { +test io-9.3 {Tcl_Read, negative byte count} { set f [open longfile r] set l [list [catch {read $f -1} msg] $msg] close $f set l } {1 {bad argument "-1": should be "nonewline"}} -test io-10.4 {Tcl_Read, positive byte count} { +test io-9.4 {Tcl_Read, positive byte count} { set f [open longfile r] set x [read $f 1024] set s [string length $x] @@ -2233,7 +2287,7 @@ test io-10.4 {Tcl_Read, positive byte count} { close $f set s } 1024 -test io-10.5 {Tcl_Read, multiple buffers} { +test io-9.5 {Tcl_Read, multiple buffers} { set f [open longfile r] fconfigure $f -buffersize 100 set x [read $f 1024] @@ -2242,7 +2296,7 @@ test io-10.5 {Tcl_Read, multiple buffers} { close $f set s } 1024 -test io-10.6 {Tcl_Read, very large read} { +test io-9.6 {Tcl_Read, very large read} { set f1 [open longfile r] set z [read $f1 1000000] close $f1 @@ -2254,7 +2308,7 @@ test io-10.6 {Tcl_Read, very large read} { } set x } ok -test io-10.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { +test io-9.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set f1 [open longfile r] fconfigure $f1 -blocking off set z [read $f1 20] @@ -2266,7 +2320,7 @@ test io-10.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { } set x } ok -test io-10.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { +test io-9.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set f1 [open longfile r] fconfigure $f1 -blocking off set z [read $f1 1000000] @@ -2279,7 +2333,7 @@ test io-10.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { } set x } ok -test io-10.9 {Tcl_Read, read to end of file} { +test io-9.9 {Tcl_Read, read to end of file} { set f1 [open longfile r] set z [read $f1] close $f1 @@ -2291,7 +2345,7 @@ test io-10.9 {Tcl_Read, read to end of file} { } set x } ok -test io-10.10 {Tcl_Read from a pipe} {unixOrPc} { +test io-9.10 {Tcl_Read from a pipe} {unixOrPc} { removeFile pipe set f1 [open pipe w] puts $f1 {puts [gets stdin]} @@ -2303,7 +2357,7 @@ test io-10.10 {Tcl_Read from a pipe} {unixOrPc} { close $f1 set x } "hello\n" -test io-10.11 {Tcl_Read from a pipe} {unixOrPc} { +test io-9.11 {Tcl_Read from a pipe} {unixOrPc} { removeFile pipe set f1 [open pipe w] puts $f1 {puts [gets stdin]} @@ -2322,7 +2376,7 @@ test io-10.11 {Tcl_Read from a pipe} {unixOrPc} { } {{hello } {hello }} -test io-10.12 {Tcl_Read, -nonewline} { +test io-9.12 {Tcl_Read, -nonewline} { removeFile test1 set f1 [open test1 w] puts $f1 hello @@ -2334,7 +2388,7 @@ test io-10.12 {Tcl_Read, -nonewline} { set c } {hello bye} -test io-10.13 {Tcl_Read, -nonewline} { +test io-9.13 {Tcl_Read, -nonewline} { removeFile test1 set f1 [open test1 w] puts $f1 hello @@ -2346,7 +2400,7 @@ test io-10.13 {Tcl_Read, -nonewline} { list [string length $c] $c } {9 {hello bye}} -test io-10.14 {Tcl_Read, reading in small chunks} { +test io-9.14 {Tcl_Read, reading in small chunks} { removeFile test1 set f [open test1 w] puts $f "Two lines: this one" @@ -2359,7 +2413,7 @@ test io-10.14 {Tcl_Read, reading in small chunks} { } {T wo { lines: this one and this one }} -test io-10.15 {Tcl_Read, asking for more input than available} { +test io-9.15 {Tcl_Read, asking for more input than available} { removeFile test1 set f [open test1 w] puts $f "Two lines: this one" @@ -2372,7 +2426,7 @@ test io-10.15 {Tcl_Read, asking for more input than available} { } {Two lines: this one and this one } -test io-10.16 {Tcl_Read, read to end of file with -nonewline} { +test io-9.16 {Tcl_Read, read to end of file with -nonewline} { removeFile test1 set f [open test1 w] puts $f "Two lines: this one" @@ -2387,7 +2441,7 @@ and this one} # Test Tcl_Gets. -test io-11.1 {Tcl_Gets, reading what was written} { +test io-10.1 {Tcl_Gets, reading what was written} { removeFile test1 set f1 [open test1 w] set y "first line" @@ -2402,7 +2456,7 @@ test io-11.1 {Tcl_Gets, reading what was written} { close $f1 set z } ok -test io-11.2 {Tcl_Gets into variable} { +test io-10.2 {Tcl_Gets into variable} { set f1 [open longfile r] set c [gets $f1 x] set l [string length x] @@ -2413,7 +2467,7 @@ test io-11.2 {Tcl_Gets into variable} { close $f1 set z } ok -test io-11.3 {Tcl_Gets from pipe} {unixOrPc} { +test io-10.3 {Tcl_Gets from pipe} {unixOrPc} { removeFile pipe set f1 [open pipe w] puts $f1 {puts [gets stdin]} @@ -2429,7 +2483,7 @@ test io-11.3 {Tcl_Gets from pipe} {unixOrPc} { } set z } ok -test io-11.4 {Tcl_Gets with long line} { +test io-10.4 {Tcl_Gets with long line} { removeFile test3 set f [open test3 w] puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" @@ -2443,13 +2497,13 @@ test io-11.4 {Tcl_Gets with long line} { close $f set x } {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} -test io-11.5 {Tcl_Gets with long line} { +test io-10.5 {Tcl_Gets with long line} { set f [open test3] set x [gets $f y] close $f list $x $y } {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} -test io-11.6 {Tcl_Gets and end of file} { +test io-10.6 {Tcl_Gets and end of file} { removeFile test3 set f [open test3 w] puts -nonewline $f "Test1\nTest2" @@ -2465,7 +2519,7 @@ test io-11.6 {Tcl_Gets and end of file} { close $f set x } {5 Test1 5 Test2 -1 {}} -test io-11.7 {Tcl_Gets and bad variable} { +test io-10.7 {Tcl_Gets and bad variable} { set f [open test3 w] puts $f "Line 1" puts $f "Line 2" @@ -2477,7 +2531,7 @@ test io-11.7 {Tcl_Gets and bad variable} { close $f set result } {1 {can't set "x(0)": variable isn't array}} -test io-11.8 {Tcl_Gets, exercising double buffering} { +test io-10.8 {Tcl_Gets, exercising double buffering} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} set x "" @@ -2490,7 +2544,7 @@ test io-11.8 {Tcl_Gets, exercising double buffering} { close $f set y } 100 -test io-11.9 {Tcl_Gets, exercising double buffering} { +test io-10.9 {Tcl_Gets, exercising double buffering} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} set x "" @@ -2503,7 +2557,7 @@ test io-11.9 {Tcl_Gets, exercising double buffering} { close $f set y } 200 -test io-11.10 {Tcl_Gets, exercising double buffering} { +test io-10.10 {Tcl_Gets, exercising double buffering} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} set x "" @@ -2519,14 +2573,14 @@ test io-11.10 {Tcl_Gets, exercising double buffering} { # Test Tcl_Seek and Tcl_Tell. -test io-12.1 {Tcl_Seek to current position at start of file} { +test io-11.1 {Tcl_Seek to current position at start of file} { set f1 [open longfile r] seek $f1 0 current set c [tell $f1] close $f1 set c } 0 -test io-12.2 {Tcl_Seek to offset from start} { +test io-11.2 {Tcl_Seek to offset from start} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2539,7 +2593,7 @@ test io-12.2 {Tcl_Seek to offset from start} { close $f1 set c } 10 -test io-12.3 {Tcl_Seek to end of file} { +test io-11.3 {Tcl_Seek to end of file} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2552,7 +2606,7 @@ test io-12.3 {Tcl_Seek to end of file} { close $f1 set c } 54 -test io-12.4 {Tcl_Seek to offset from end of file} { +test io-11.4 {Tcl_Seek to offset from end of file} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2565,7 +2619,7 @@ test io-12.4 {Tcl_Seek to offset from end of file} { close $f1 set c } 44 -test io-12.5 {Tcl_Seek to offset from current position} { +test io-11.5 {Tcl_Seek to offset from current position} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2579,7 +2633,7 @@ test io-12.5 {Tcl_Seek to offset from current position} { close $f1 set c } 20 -test io-12.6 {Tcl_Seek to offset from end of file} { +test io-11.6 {Tcl_Seek to offset from end of file} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2594,7 +2648,7 @@ test io-12.6 {Tcl_Seek to offset from end of file} { list $c $r } {44 {rstuvwxyz }} -test io-12.7 {Tcl_Seek to offset from end of file, then to current position} { +test io-11.7 {Tcl_Seek to offset from end of file, then to current position} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2610,14 +2664,14 @@ test io-12.7 {Tcl_Seek to offset from end of file, then to current position} { close $f1 list $c1 $r1 $c2 } {44 rstuv 49} -test io-12.8 {Tcl_Seek on pipes: not supported} {unixOrPc} { +test io-11.8 {Tcl_Seek on pipes: not supported} {unixOrPc} { set f1 [open "|$tcltest" r+] set x [list [catch {seek $f1 0 current} msg] $msg] close $f1 regsub {".*":} $x {"":} x string tolower $x } {1 {error during seek on "": invalid argument}} -test io-12.9 {Tcl_Seek, testing buffered input flushing} { +test io-11.9 {Tcl_Seek, testing buffered input flushing} { removeFile test3 set f [open test3 w] fconfigure $f -eofchar {} @@ -2640,7 +2694,7 @@ test io-12.9 {Tcl_Seek, testing buffered input flushing} { close $f set x } {a d a l Y {} b} -test io-12.10 {Tcl_Seek testing flushing of buffered input} { +test io-11.10 {Tcl_Seek testing flushing of buffered input} { set f [open test3 w] fconfigure $f -translation lf puts $f xyz\n123 @@ -2654,7 +2708,7 @@ test io-12.10 {Tcl_Seek testing flushing of buffered input} { list $x [viewFile test3] } "xyz {xyz 456}" -test io-12.11 {Tcl_Seek testing flushing of buffered output} { +test io-11.11 {Tcl_Seek testing flushing of buffered output} { set f [open test3 w] puts $f xyz\n123 close $f @@ -2665,7 +2719,7 @@ test io-12.11 {Tcl_Seek testing flushing of buffered output} { close $f list $x [viewFile test3] } "zzy xyzzy" -test io-12.12 {Tcl_Seek testing combination of write, seek back and read} { +test io-11.12 {Tcl_Seek testing combination of write, seek back and read} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} puts $f xyz\n123 @@ -2682,14 +2736,14 @@ test io-12.12 {Tcl_Seek testing combination of write, seek back and read} { } {14 {xyz 123 xyzzy} zzy} -test io-12.13 {Tcl_Tell at start of file} { +test io-11.13 {Tcl_Tell at start of file} { removeFile test1 set f1 [open test1 w] set p [tell $f1] close $f1 set p } 0 -test io-12.14 {Tcl_Tell after seek to end of file} { +test io-11.14 {Tcl_Tell after seek to end of file} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2702,7 +2756,7 @@ test io-12.14 {Tcl_Tell after seek to end of file} { close $f1 set c1 } 54 -test io-12.15 {Tcl_Tell combined with seeking} { +test io-11.15 {Tcl_Tell combined with seeking} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2717,13 +2771,13 @@ test io-12.15 {Tcl_Tell combined with seeking} { close $f1 list $c1 $c2 } {10 20} -test io-12.16 {Tcl_tell on pipe: always -1} {unixOrPc} { +test io-11.16 {Tcl_tell on pipe: always -1} {unixOrPc} { set f1 [open "|$tcltest" r+] set c [tell $f1] close $f1 set c } -1 -test io-12.17 {Tcl_Tell on pipe: always -1} {unixOrPc} { +test io-11.17 {Tcl_Tell on pipe: always -1} {unixOrPc} { set f1 [open "|$tcltest" r+] puts $f1 {puts hello} flush $f1 @@ -2732,7 +2786,7 @@ test io-12.17 {Tcl_Tell on pipe: always -1} {unixOrPc} { close $f1 set c } -1 -test io-12.18 {Tcl_Tell combined with seeking and reading} { +test io-11.18 {Tcl_Tell combined with seeking and reading} { removeFile test2 set f [open test2 w] fconfigure $f -translation lf -eofchar {} @@ -2752,7 +2806,7 @@ test io-12.18 {Tcl_Tell combined with seeking and reading} { close $f set x } {0 3 2 12 30} -test io-12.19 {Tcl_Tell combined with opening in append mode} { +test io-11.19 {Tcl_Tell combined with opening in append mode} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} puts $f "abcdefghijklmnopqrstuvwxyz" @@ -2763,7 +2817,7 @@ test io-12.19 {Tcl_Tell combined with opening in append mode} { close $f set c } 54 -test io-12.20 {Tcl_Tell combined with writing} { +test io-11.20 {Tcl_Tell combined with writing} { set f [open test3 w] set l "" seek $f 29 start @@ -2781,7 +2835,7 @@ test io-12.20 {Tcl_Tell combined with writing} { # Test Tcl_Eof -test io-13.1 {Tcl_Eof} { +test io-12.1 {Tcl_Eof} { removeFile test1 set f [open test1 w] puts $f hello @@ -2800,7 +2854,7 @@ test io-13.1 {Tcl_Eof} { close $f set x } {0 0 0 0 1 1} -test io-13.2 {Tcl_Eof with pipe} {unixOrPc} { +test io-12.2 {Tcl_Eof with pipe} {unixOrPc} { removeFile pipe set f1 [open pipe w] puts $f1 {gets stdin} @@ -2818,7 +2872,7 @@ test io-13.2 {Tcl_Eof with pipe} {unixOrPc} { close $f1 set x } {0 0 0 1} -test io-13.3 {Tcl_Eof with pipe} {unixOrPc} { +test io-12.3 {Tcl_Eof with pipe} {unixOrPc} { removeFile pipe set f1 [open pipe w] puts $f1 {gets stdin} @@ -2840,7 +2894,7 @@ test io-13.3 {Tcl_Eof with pipe} {unixOrPc} { close $f1 set x } {0 0 0 1 1 1} -test io-13.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { +test io-12.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { removeFile test1 set f [open test1 w] close $f @@ -2852,7 +2906,7 @@ test io-13.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { close $f set l } {{} 1} -test io-13.5 {Tcl_Eof, eof detection on nonblocking pipe} {unixOrPc} { +test io-12.5 {Tcl_Eof, eof detection on nonblocking pipe} {unixOrPc} { removeFile pipe set f [open pipe w] puts $f { @@ -2866,7 +2920,7 @@ test io-13.5 {Tcl_Eof, eof detection on nonblocking pipe} {unixOrPc} { close $f set l } {{} 1} -test io-13.6 {Tcl_Eof, eof char, lf write, auto read} { +test io-12.6 {Tcl_Eof, eof char, lf write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar \x1a @@ -2880,7 +2934,7 @@ test io-13.6 {Tcl_Eof, eof char, lf write, auto read} { close $f list $s $l $e } {9 8 1} -test io-13.7 {Tcl_Eof, eof char, lf write, lf read} { +test io-12.7 {Tcl_Eof, eof char, lf write, lf read} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar \x1a @@ -2894,7 +2948,7 @@ test io-13.7 {Tcl_Eof, eof char, lf write, lf read} { close $f list $s $l $e } {9 8 1} -test io-13.8 {Tcl_Eof, eof char, cr write, auto read} { +test io-12.8 {Tcl_Eof, eof char, cr write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar \x1a @@ -2908,7 +2962,7 @@ test io-13.8 {Tcl_Eof, eof char, cr write, auto read} { close $f list $s $l $e } {9 8 1} -test io-13.9 {Tcl_Eof, eof char, cr write, cr read} { +test io-12.9 {Tcl_Eof, eof char, cr write, cr read} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar \x1a @@ -2922,7 +2976,7 @@ test io-13.9 {Tcl_Eof, eof char, cr write, cr read} { close $f list $s $l $e } {9 8 1} -test io-13.10 {Tcl_Eof, eof char, crlf write, auto read} { +test io-12.10 {Tcl_Eof, eof char, crlf write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar \x1a @@ -2936,7 +2990,7 @@ test io-13.10 {Tcl_Eof, eof char, crlf write, auto read} { close $f list $s $l $e } {11 8 1} -test io-13.11 {Tcl_Eof, eof char, crlf write, crlf read} { +test io-12.11 {Tcl_Eof, eof char, crlf write, crlf read} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar \x1a @@ -2950,7 +3004,7 @@ test io-13.11 {Tcl_Eof, eof char, crlf write, crlf read} { close $f list $s $l $e } {11 8 1} -test io-13.12 {Tcl_Eof, eof char in middle, lf write, auto read} { +test io-12.12 {Tcl_Eof, eof char in middle, lf write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -2965,7 +3019,7 @@ test io-13.12 {Tcl_Eof, eof char in middle, lf write, auto read} { close $f list $c $l $e } {17 8 1} -test io-13.13 {Tcl_Eof, eof char in middle, lf write, lf read} { +test io-12.13 {Tcl_Eof, eof char in middle, lf write, lf read} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -2980,7 +3034,7 @@ test io-13.13 {Tcl_Eof, eof char in middle, lf write, lf read} { close $f list $c $l $e } {17 8 1} -test io-13.14 {Tcl_Eof, eof char in middle, cr write, auto read} { +test io-12.14 {Tcl_Eof, eof char in middle, cr write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -2995,7 +3049,7 @@ test io-13.14 {Tcl_Eof, eof char in middle, cr write, auto read} { close $f list $c $l $e } {17 8 1} -test io-13.15 {Tcl_Eof, eof char in middle, cr write, cr read} { +test io-12.15 {Tcl_Eof, eof char in middle, cr write, cr read} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -3010,7 +3064,7 @@ test io-13.15 {Tcl_Eof, eof char in middle, cr write, cr read} { close $f list $c $l $e } {17 8 1} -test io-13.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { +test io-12.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -3025,7 +3079,7 @@ test io-13.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { close $f list $c $l $e } {21 8 1} -test io-13.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { +test io-12.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -3043,7 +3097,7 @@ test io-13.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { # Test Tcl_InputBlocked -test io-14.1 {Tcl_InputBlocked on nonblocking pipe} {unixOrPc tempNotPc} { +test io-13.1 {Tcl_InputBlocked on nonblocking pipe} {unixOrPc tempNotPc} { set f1 [open "|$tcltest" r+] puts $f1 {puts hello_from_pipe} flush $f1 @@ -3062,7 +3116,7 @@ test io-14.1 {Tcl_InputBlocked on nonblocking pipe} {unixOrPc tempNotPc} { close $f1 set x } {{} 1 hello 0 {} 1} -test io-14.2 {Tcl_InputBlocked on blocking pipe} {unixOrPc tempNotPc} { +test io-13.2 {Tcl_InputBlocked on blocking pipe} {unixOrPc tempNotPc} { set f1 [open "|$tcltest" r+] fconfigure $f1 -buffering line puts $f1 {puts hello_from_pipe} @@ -3076,7 +3130,7 @@ test io-14.2 {Tcl_InputBlocked on blocking pipe} {unixOrPc tempNotPc} { close $f1 set x } {hello_from_pipe 0 {} 0 1} -test io-14.3 {Tcl_InputBlocked vs files, short read} { +test io-13.3 {Tcl_InputBlocked vs files, short read} { removeFile test1 set f [open test1 w] puts $f abcdefghijklmnop @@ -3092,11 +3146,11 @@ test io-14.3 {Tcl_InputBlocked vs files, short read} { close $f set l } {0 abc 0 defghijklmnop 0 1} -test io-14.4 {Tcl_InputBlocked vs files, event driven read} { +test io-13.4 {Tcl_InputBlocked vs files, event driven read} { proc in {f} { - global l + global l x lappend l [read $f 3] - if {[eof $f]} {lappend l eof; close $f} + if {[eof $f]} {lappend l eof; close $f; set x done} } removeFile test1 set f [open test1 w] @@ -3105,11 +3159,11 @@ test io-14.4 {Tcl_InputBlocked vs files, event driven read} { set f [open test1 r] set l "" fileevent $f readable [list in $f] - update + vwait x set l } {abc def ghi jkl mno {p } eof} -test io-14.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} { +test io-13.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} { removeFile test1 set f [open test1 w] puts $f abcdefghijklmnop @@ -3126,11 +3180,11 @@ test io-14.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles close $f set l } {0 abc 0 defghijklmnop 0 1} -test io-14.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} { +test io-13.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} { proc in {f} { - global l + global l x lappend l [read $f 3] - if {[eof $f]} {lappend l eof; close $f} + if {[eof $f]} {lappend l eof; close $f; set x done} } removeFile test1 set f [open test1 w] @@ -3140,14 +3194,14 @@ test io-14.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} { fconfigure $f -blocking off set l "" fileevent $f readable [list in $f] - update + vwait x set l } {abc def ghi jkl mno {p } eof} # Test Tcl_InputBuffered -test io-15.1 {Tcl_InputBuffered} { +test io-14.1 {Tcl_InputBuffered} { set f [open longfile r] fconfigure $f -buffersize 4096 read $f 3 @@ -3157,7 +3211,7 @@ test io-15.1 {Tcl_InputBuffered} { close $f set l } {4093 3} -test io-15.2 {Tcl_InputBuffered, test input flushing on seek} { +test io-14.2 {Tcl_InputBuffered, test input flushing on seek} { set f [open longfile r] fconfigure $f -buffersize 4096 read $f 3 @@ -3173,13 +3227,13 @@ test io-15.2 {Tcl_InputBuffered, test input flushing on seek} { # Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize -test io-16.1 {Tcl_GetChannelBufferSize, default buffer size} { +test io-15.1 {Tcl_GetChannelBufferSize, default buffer size} { set f [open longfile r] set s [fconfigure $f -buffersize] close $f set s } 4096 -test io-16.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { +test io-15.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { set f [open longfile r] set l "" lappend l [fconfigure $f -buffersize] @@ -3201,7 +3255,7 @@ test io-16.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { # Test Tcl_SetChannelOption, Tcl_GetChannelOption -test io-17.1 {Tcl_GetChannelOption} { +test io-16.1 {Tcl_GetChannelOption} { removeFile test1 set f1 [open test1 w] set x [fconfigure $f1 -blocking] @@ -3211,14 +3265,14 @@ test io-17.1 {Tcl_GetChannelOption} { # # Test 17.2 was removed. # -test io-17.3 {Tcl_GetChannelOption} { +test io-16.2 {Tcl_GetChannelOption} { removeFile test1 set f1 [open test1 w] set x [fconfigure $f1 -buffering] close $f1 set x } full -test io-17.4 {Tcl_GetChannelOption} { +test io-16.3 {Tcl_GetChannelOption} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -buffering line @@ -3226,7 +3280,7 @@ test io-17.4 {Tcl_GetChannelOption} { close $f1 set x } line -test io-17.5 {Tcl_GetChannelOption, Tcl_SetChannelOption} { +test io-16.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} { removeFile test1 set f1 [open test1 w] set l "" @@ -3242,7 +3296,7 @@ test io-17.5 {Tcl_GetChannelOption, Tcl_SetChannelOption} { close $f1 set l } {full line none line full} -test io-17.6 {Tcl_GetChannelOption, invariance} { +test io-16.5 {Tcl_GetChannelOption, invariance} { removeFile test1 set f1 [open test1 w] set l "" @@ -3252,7 +3306,7 @@ test io-17.6 {Tcl_GetChannelOption, invariance} { close $f1 set l } {full {1 {bad value for -buffering: must be one of full, line, or none}} full} -test io-17.7 {Tcl_SetChannelOption, multiple options} { +test io-16.6 {Tcl_SetChannelOption, multiple options} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -buffering line @@ -3262,7 +3316,7 @@ test io-17.7 {Tcl_SetChannelOption, multiple options} { close $f1 set x } 10 -test io-17.8 {Tcl_SetChannelOption, buffering, translation} { +test io-16.7 {Tcl_SetChannelOption, buffering, translation} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf @@ -3276,7 +3330,7 @@ test io-17.8 {Tcl_SetChannelOption, buffering, translation} { close $f1 set x } {0 21} -test io-17.9 {Tcl_SetChannelOption, different buffering options} { +test io-16.8 {Tcl_SetChannelOption, different buffering options} { removeFile test1 set f1 [open test1 w] set l "" @@ -3296,7 +3350,7 @@ test io-17.9 {Tcl_SetChannelOption, different buffering options} { lappend l [file size test1] set l } {5 10 10 10 20 20} -test io-17.10 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { +test io-16.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { removeFile test1 set f1 [open test1 w] close $f1 @@ -3312,7 +3366,7 @@ test io-17.10 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { close $f1 set x } {1 0 {} {} 0 1} -test io-17.11 {Tcl_SetChannelOption, blocking mode} {unixOrPc tempNotPc} { +test io-16.10 {Tcl_SetChannelOption, blocking mode} {unixOrPc tempNotPc} { removeFile pipe set f1 [open pipe w] puts $f1 {gets stdin} @@ -3342,7 +3396,7 @@ test io-17.11 {Tcl_SetChannelOption, blocking mode} {unixOrPc tempNotPc} { close $f1 set x } {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1} -test io-17.12 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { +test io-16.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { removeFile test1 set f [open test1 w] fconfigure $f -buffersize -10 @@ -3350,7 +3404,7 @@ test io-17.12 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { close $f set x } 4096 -test io-17.13 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} { +test io-16.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} { removeFile test1 set f [open test1 w] fconfigure $f -buffersize 10000000 @@ -3358,7 +3412,7 @@ test io-17.13 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} { close $f set x } 4096 -test io-17.14 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { +test io-16.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { removeFile test1 set f [open test1 w] fconfigure $f -buffersize 40000 @@ -3367,7 +3421,7 @@ test io-17.14 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { set x } 40000 -test io-18.1 {POSIX open access modes: RDWR} { +test io-17.1 {POSIX open access modes: RDWR} { removeFile test3 set f [open test3 w] puts $f xyzzy @@ -3382,7 +3436,7 @@ test io-18.1 {POSIX open access modes: RDWR} { close $f set x } {zzy abzzy} -test io-18.2 {POSIX open access modes: CREAT} {unixOnly} { +test io-17.2 {POSIX open access modes: CREAT} {unixOnly} { removeFile test3 set f [open test3 {WRONLY CREAT} 0600] file stat test3 stats @@ -3394,7 +3448,7 @@ test io-18.2 {POSIX open access modes: CREAT} {unixOnly} { close $f set x } {0600 {line 1}} -test io-18.3 {POSIX open access modes: CREAT} {unixOnly nonPortable} { +test io-17.3 {POSIX open access modes: CREAT} {unixOnly nonPortable umask2} { # This test only works if your umask is 2, like ouster's. removeFile test3 set f [open test3 {WRONLY CREAT}] @@ -3402,7 +3456,7 @@ test io-18.3 {POSIX open access modes: CREAT} {unixOnly nonPortable} { file stat test3 stats format "0%o" [expr $stats(mode)&0777] } 0664 -test io-18.4 {POSIX open access modes: CREAT} { +test io-17.4 {POSIX open access modes: CREAT} { removeFile test3 set f [open test3 w] fconfigure $f -eofchar {} @@ -3417,7 +3471,7 @@ test io-18.4 {POSIX open access modes: CREAT} { close $f set x } abzzy -test io-18.5 {POSIX open access modes: APPEND} { +test io-17.5 {POSIX open access modes: APPEND} { removeFile test3 set f [open test3 w] fconfigure $f -translation lf -eofchar {} @@ -3438,7 +3492,7 @@ test io-18.5 {POSIX open access modes: APPEND} { close $f set x } {{new line} abc} -test io-18.6 {POSIX open access modes: EXCL} { +test io-17.6 {POSIX open access modes: EXCL} { removeFile test3 set f [open test3 w] puts $f xyzzy @@ -3447,7 +3501,7 @@ test io-18.6 {POSIX open access modes: EXCL} { regsub " already " $msg " " msg string tolower $msg } {1 {couldn't open "test3": file exists}} -test io-18.7 {POSIX open access modes: EXCL} { +test io-17.7 {POSIX open access modes: EXCL} { removeFile test3 set f [open test3 {WRONLY CREAT EXCL}] fconfigure $f -eofchar {} @@ -3455,7 +3509,7 @@ test io-18.7 {POSIX open access modes: EXCL} { close $f viewFile test3 } {A test line} -test io-18.8 {POSIX open access modes: TRUNC} { +test io-17.8 {POSIX open access modes: TRUNC} { removeFile test3 set f [open test3 w] puts $f xyzzy @@ -3468,7 +3522,7 @@ test io-18.8 {POSIX open access modes: TRUNC} { close $f set x } abc -test io-18.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} { +test io-17.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} { removeFile test3 set f [open test3 {WRONLY NONBLOCK CREAT}] puts $f "NONBLOCK test" @@ -3478,7 +3532,7 @@ test io-18.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} { close $f set x } {NONBLOCK test} -test io-18.10 {POSIX open access modes: RDONLY} { +test io-17.10 {POSIX open access modes: RDONLY} { set f [open test1 w] puts $f "two lines: this one" puts $f "and this" @@ -3490,15 +3544,15 @@ test io-18.10 {POSIX open access modes: RDONLY} { [list {two lines: this one} 1 \ [format "channel \"%s\" wasn't opened for writing" $f]] } 0 -test io-18.11 {POSIX open access modes: RDONLY} { +test io-17.11 {POSIX open access modes: RDONLY} { removeFile test3 string tolower [list [catch {open test3 RDONLY} msg] $msg] } {1 {couldn't open "test3": no such file or directory}} -test io-18.12 {POSIX open access modes: WRONLY} { +test io-17.12 {POSIX open access modes: WRONLY} { removeFile test3 string tolower [list [catch {open test3 WRONLY} msg] $msg] } {1 {couldn't open "test3": no such file or directory}} -test io-18.13 {POSIX open access modes: WRONLY} { +test io-17.13 {POSIX open access modes: WRONLY} { makeFile xyzzy test3 set f [open test3 WRONLY] fconfigure $f -eofchar {} @@ -3510,11 +3564,11 @@ test io-18.13 {POSIX open access modes: WRONLY} { string compare [string tolower $x] \ [list 1 "channel \"$f\" wasn't opened for reading" abzzy] } 0 -test io-18.14 {POSIX open access modes: RDWR} { +test io-17.14 {POSIX open access modes: RDWR} { removeFile test3 string tolower [list [catch {open test3 RDWR} msg] $msg] } {1 {couldn't open "test3": no such file or directory}} -test io-18.15 {POSIX open access modes: RDWR} { +test io-17.15 {POSIX open access modes: RDWR} { makeFile xyzzy test3 set f [open test3 RDWR] puts -nonewline $f "ab" @@ -3524,7 +3578,7 @@ test io-18.15 {POSIX open access modes: RDWR} { lappend x [viewFile test3] } {zzy abzzy} if {![file exists ~/_test_] && [file writable ~]} { - test io-18.16 {tilde substitution in open} { + test io-17.16 {tilde substitution in open} { set f [open ~/_test_ w] puts $f "Some text" close $f @@ -3533,7 +3587,7 @@ if {![file exists ~/_test_] && [file writable ~]} { set x } 1 } -test io-18.17 {tilde substitution in open} { +test io-17.17 {tilde substitution in open} { set home $env(HOME) unset env(HOME) set x [list [catch {open ~/foo} msg] $msg] @@ -3541,19 +3595,19 @@ test io-18.17 {tilde substitution in open} { set x } {1 {couldn't find HOME environment variable to expand path}} -test io-19.1 {Tcl_FileeventCmd: errors} { +test io-18.1 {Tcl_FileeventCmd: errors} { list [catch {fileevent foo} msg] $msg } {1 {wrong # args: must be "fileevent channelId event ?script?}} -test io-19.2 {Tcl_FileeventCmd: errors} { +test io-18.2 {Tcl_FileeventCmd: errors} { list [catch {fileevent foo bar baz q} msg] $msg } {1 {wrong # args: must be "fileevent channelId event ?script?}} -test io-19.3 {Tcl_FileeventCmd: errors} { +test io-18.3 {Tcl_FileeventCmd: errors} { list [catch {fileevent gorp readable} msg] $msg } {1 {can not find channel named "gorp"}} -test io-19.4 {Tcl_FileeventCmd: errors} { +test io-18.4 {Tcl_FileeventCmd: errors} { list [catch {fileevent gorp writable} msg] $msg } {1 {can not find channel named "gorp"}} -test io-19.5 {Tcl_FileeventCmd: errors} { +test io-18.5 {Tcl_FileeventCmd: errors} { list [catch {fileevent gorp who-knows} msg] $msg } {1 {bad event name "who-knows": must be readable or writable}} @@ -3563,10 +3617,10 @@ test io-19.5 {Tcl_FileeventCmd: errors} { set f [open foo w+] -test io-20.1 {Tcl_FileeventCmd: creating, deleting, querying} { +test io-19.1 {Tcl_FileeventCmd: creating, deleting, querying} { list [fileevent $f readable] [fileevent $f writable] } {{} {}} -test io-20.2 {Tcl_FileeventCmd: replacing} { +test io-19.2 {Tcl_FileeventCmd: replacing} { set result {} fileevent $f r "first script" lappend result [fileevent $f readable] @@ -3588,7 +3642,7 @@ if {($tcl_platform(platform) != "macintosh") && \ catch {set f2 [open {|cat -u} r+]} catch {set f3 [open {|cat -u} r+]} -test io-21.1 {Tcl_FileeventCmd: creating, deleting, querying} { +test io-20.1 {Tcl_FileeventCmd: creating, deleting, querying} { set result {} fileevent $f readable "script 1" lappend result [fileevent $f readable] [fileevent $f writable] @@ -3599,7 +3653,7 @@ test io-21.1 {Tcl_FileeventCmd: creating, deleting, querying} { fileevent $f writable {} lappend result [fileevent $f readable] [fileevent $f writable] } {{script 1} {} {script 1} {write script} {} {write script} {} {}} -test io-21.2 {Tcl_FileeventCmd: deleting when many present} { +test io-20.2 {Tcl_FileeventCmd: deleting when many present} { set result {} lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] fileevent $f r "read f" @@ -3614,7 +3668,7 @@ test io-21.2 {Tcl_FileeventCmd: deleting when many present} { lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] } {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}} -test io-22.1 {FileEventProc procedure: normal read event} { +test io-21.1 {FileEventProc procedure: normal read event} { fileevent $f2 readable { set x [gets $f2]; fileevent $f2 readable {} } @@ -3623,7 +3677,7 @@ test io-22.1 {FileEventProc procedure: normal read event} { vwait x set x } {text} -test io-22.2 {FileEventProc procedure: error in read event} { +test io-21.2 {FileEventProc procedure: error in read event} { proc bgerror args { global x set x $args @@ -3635,7 +3689,7 @@ test io-22.2 {FileEventProc procedure: error in read event} { rename bgerror {} list $x [fileevent $f2 readable] } {bogus {}} -test io-22.3 {FileEventProc procedure: normal write event} { +test io-21.3 {FileEventProc procedure: normal write event} { fileevent $f2 writable { lappend x "triggered" incr count -1 @@ -3650,7 +3704,7 @@ test io-22.3 {FileEventProc procedure: normal write event} { vwait x set x } {initial triggered triggered triggered} -test io-22.4 {FileEventProc procedure: eror in write event} { +test io-21.4 {FileEventProc procedure: eror in write event} { proc bgerror args { global x set x $args @@ -3661,7 +3715,7 @@ test io-22.4 {FileEventProc procedure: eror in write event} { rename bgerror {} list $x [fileevent $f2 writable] } {bad-write {}} -test io-22.5 {FileEventProc procedure: end of file} {unixOrPc unixExecs} { +test io-21.5 {FileEventProc procedure: end of file} {unixOrPc unixExecs} { set f4 [open {|cat << foo} r] fileevent $f4 readable { if {[gets $f4 line] < 0} { @@ -3687,7 +3741,7 @@ catch {close $f3} close $f makeFile "foo bar" foo -test io-23.1 {DeleteFileEvent, cleanup on close} { +test io-22.1 {DeleteFileEvent, cleanup on close} { set f [open foo r] fileevent $f readable { lappend x "binding triggered: \"[gets $f]\"" @@ -3695,10 +3749,11 @@ test io-23.1 {DeleteFileEvent, cleanup on close} { } close $f set x initial - update + after 100 { set y done } + vwait y set x } {initial} -test io-23.2 {DeleteFileEvent, cleanup on close} { +test io-22.2 {DeleteFileEvent, cleanup on close} { set f [open foo r] set f2 [open foo r] fileevent $f readable { @@ -3715,7 +3770,7 @@ test io-23.2 {DeleteFileEvent, cleanup on close} { close $f2 set x } {initial {f2 triggered: "foo bar"}} -test io-23.3 {DeleteFileEvent, cleanup on close} { +test io-22.3 {DeleteFileEvent, cleanup on close} { set f [open foo r] set f2 [open foo r] set f3 [open foo r] @@ -3741,7 +3796,7 @@ test io-23.3 {DeleteFileEvent, cleanup on close} { if {[info commands testfevent] == "testfevent"} { -test io-24.1 {Tcl event loop vs multiple interpreters} { +test io-23.1 {Tcl event loop vs multiple interpreters} { testfevent create testfevent cmd { set f [open foo r] @@ -3751,11 +3806,12 @@ test io-24.1 {Tcl event loop vs multiple interpreters} { fileevent $f readable {} } } + after 1 ;# We must delay because Windows takes a little time to notice update testfevent cmd {close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} -test io-24.2 {Tcl event loop vs multiple interpreters} { +test io-23.2 {Tcl event loop vs multiple interpreters} { testfevent create testfevent cmd { set x 0 @@ -3764,7 +3820,7 @@ test io-24.2 {Tcl event loop vs multiple interpreters} { set x } } {triggered} -test io-24.3 {Tcl event loop vs multiple interpreters} { +test io-23.3 {Tcl event loop vs multiple interpreters} { testfevent create testfevent cmd { set x 0 @@ -3778,7 +3834,7 @@ test io-24.3 {Tcl event loop vs multiple interpreters} { } } {0 0 {0 timer}} -test io-25.1 {fileevent vs multiple interpreters} { +test io-24.1 {fileevent vs multiple interpreters} { set f [open foo r] set f2 [open foo r] set f3 [open foo r] @@ -3797,7 +3853,7 @@ test io-25.1 {fileevent vs multiple interpreters} { close $f3 set x } {{} {script 1} {} {sript 3}} -test io-25.2 {deleting fileevent on interpreter delete} { +test io-24.2 {deleting fileevent on interpreter delete} { set f [open foo r] set f2 [open foo r] set f3 [open foo r] @@ -3818,7 +3874,7 @@ test io-25.2 {deleting fileevent on interpreter delete} { close $f4 set x } {{script 1} {} {} {script 4}} -test io-25.3 {deleting fileevent on interpreter delete} { +test io-24.3 {deleting fileevent on interpreter delete} { set f [open foo r] set f2 [open foo r] set f3 [open foo r] @@ -3839,7 +3895,7 @@ test io-25.3 {deleting fileevent on interpreter delete} { close $f4 set x } {{script 1} {script 2} {} {}} -test io-25.4 {file events on shared files and multiple interpreters} { +test io-24.4 {file events on shared files and multiple interpreters} { set f [open foo r] set f2 [open foo r] testfevent create @@ -3855,7 +3911,7 @@ test io-25.4 {file events on shared files and multiple interpreters} { close $f2 set x } {{script 3} {script 1} {script 2}} -test io-25.5 {file events on shared files, deleting file events} { +test io-24.5 {file events on shared files, deleting file events} { set f [open foo r] testfevent create testfevent share $f @@ -3868,7 +3924,7 @@ test io-25.5 {file events on shared files, deleting file events} { close $f set x } {{} {script 2}} -test io-25.6 {file events on shared files, deleting file events} { +test io-24.6 {file events on shared files, deleting file events} { set f [open foo r] testfevent create testfevent share $f @@ -3886,7 +3942,7 @@ test io-25.6 {file events on shared files, deleting file events} { # The above curly closes the test for presence of the "testfevent" command. -test io-26.1 {testing readability conditions} { +test io-25.1 {testing readability conditions} { set f [open bar w] puts $f abcdefg puts $f abcdefg @@ -3911,7 +3967,7 @@ test io-26.1 {testing readability conditions} { vwait x list $x $l } {done {called called called called called called called}} -test io-26.2 {testing readability conditions} {nonBlockFiles} { +test io-25.2 {testing readability conditions} {nonBlockFiles} { set f [open bar w] puts $f abcdefg puts $f abcdefg @@ -3937,7 +3993,7 @@ test io-26.2 {testing readability conditions} {nonBlockFiles} { vwait x list $x $l } {done {called called called called called called called}} -test io-26.3 {testing readability conditions} {unixOnly nonBlockFiles} { +test io-25.3 {testing readability conditions} {unixOnly nonBlockFiles} { set f [open bar w] puts $f abcdefg puts $f abcdefg @@ -3981,7 +4037,7 @@ test io-26.3 {testing readability conditions} {unixOnly nonBlockFiles} { close $f list $x $l } {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} -test io-26.4 {lf write, testing readability, ^Z termination, auto read mode} { +test io-25.4 {lf write, testing readability, ^Z termination, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4006,7 +4062,7 @@ test io-26.4 {lf write, testing readability, ^Z termination, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-26.5 {lf write, testing readability, ^Z in middle, auto read mode} { +test io-25.5 {lf write, testing readability, ^Z in middle, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4031,7 +4087,7 @@ test io-26.5 {lf write, testing readability, ^Z in middle, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-26.6 {cr write, testing readability, ^Z termination, auto read mode} { +test io-25.6 {cr write, testing readability, ^Z termination, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -4056,7 +4112,7 @@ test io-26.6 {cr write, testing readability, ^Z termination, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-26.7 {cr write, testing readability, ^Z in middle, auto read mode} { +test io-25.7 {cr write, testing readability, ^Z in middle, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -4081,7 +4137,7 @@ test io-26.7 {cr write, testing readability, ^Z in middle, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-26.8 {crlf write, testing readability, ^Z termination, auto read mode} { +test io-25.8 {crlf write, testing readability, ^Z termination, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -4106,7 +4162,7 @@ test io-26.8 {crlf write, testing readability, ^Z termination, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-26.9 {crlf write, testing readability, ^Z in middle, auto read mode} { +test io-25.9 {crlf write, testing readability, ^Z in middle, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -4131,7 +4187,7 @@ test io-26.9 {crlf write, testing readability, ^Z in middle, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-26.10 {lf write, testing readability, ^Z in middle, lf read mode} { +test io-25.10 {lf write, testing readability, ^Z in middle, lf read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4156,7 +4212,7 @@ test io-26.10 {lf write, testing readability, ^Z in middle, lf read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-26.11 {lf write, testing readability, ^Z termination, lf read mode} { +test io-25.11 {lf write, testing readability, ^Z termination, lf read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4181,7 +4237,7 @@ test io-26.11 {lf write, testing readability, ^Z termination, lf read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-26.12 {cr write, testing readability, ^Z in middle, cr read mode} { +test io-25.12 {cr write, testing readability, ^Z in middle, cr read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -4206,7 +4262,7 @@ test io-26.12 {cr write, testing readability, ^Z in middle, cr read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-26.13 {cr write, testing readability, ^Z termination, cr read mode} { +test io-25.13 {cr write, testing readability, ^Z termination, cr read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -4231,7 +4287,7 @@ test io-26.13 {cr write, testing readability, ^Z termination, cr read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-26.14 {crlf write, testing readability, ^Z in middle, crlf read mode} { +test io-25.14 {crlf write, testing readability, ^Z in middle, crlf read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -4256,7 +4312,7 @@ test io-26.14 {crlf write, testing readability, ^Z in middle, crlf read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-26.15 {crlf write, testing readability, ^Z termi, crlf read mode} { +test io-25.15 {crlf write, testing readability, ^Z termi, crlf read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -4282,6 +4338,119 @@ test io-26.15 {crlf write, testing readability, ^Z termi, crlf read mode} { list $c $l } {3 {abc def {}}} +test io-26.1 {testing crlf reading, leftover cr disgorgment} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\rb\rc\r\n" + close $f + set f [open test1 r] + set l "" + lappend l [file size test1] + fconfigure $f -translation crlf + lappend l [read $f 1] + lappend l [tell $f] + lappend l [read $f 1] + lappend l [tell $f] + lappend l [read $f 1] + lappend l [tell $f] + lappend l [read $f 1] + lappend l [tell $f] + lappend l [read $f 1] + lappend l [tell $f] + lappend l [read $f 1] + lappend l [tell $f] + lappend l [eof $f] + lappend l [read $f 1] + lappend l [eof $f] + close $f + set l +} "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 { +} 7 0 {} 1" +test io-26.2 {testing crlf reading, leftover cr disgorgment} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\rb\rc\r\n" + close $f + set f [open test1 r] + set l "" + lappend l [file size test1] + fconfigure $f -translation crlf + lappend l [read $f 2] + lappend l [tell $f] + lappend l [read $f 2] + lappend l [tell $f] + lappend l [read $f 2] + lappend l [tell $f] + lappend l [eof $f] + lappend l [read $f 2] + lappend l [tell $f] + lappend l [eof $f] + close $f + set l +} "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1" +test io-26.3 {testing crlf reading, leftover cr disgorgment} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\rb\rc\r\n" + close $f + set f [open test1 r] + set l "" + lappend l [file size test1] + fconfigure $f -translation crlf + lappend l [read $f 3] + lappend l [tell $f] + lappend l [read $f 3] + lappend l [tell $f] + lappend l [eof $f] + lappend l [read $f 3] + lappend l [tell $f] + lappend l [eof $f] + close $f + set l +} "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1" +test io-26.4 {testing crlf reading, leftover cr disgorgment} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\rb\rc\r\n" + close $f + set f [open test1 r] + set l "" + lappend l [file size test1] + fconfigure $f -translation crlf + lappend l [read $f 3] + lappend l [tell $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [eof $f] + close $f + set l +} "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1" +test io-26.5 {testing crlf reading, leftover cr disgorgment} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\rb\rc\r\n" + close $f + set f [open test1 r] + set l "" + lappend l [file size test1] + fconfigure $f -translation crlf + lappend l [set x [gets $f]] + lappend l [tell $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [eof $f] + close $f + set l +} [list 7 a\rb\rc 7 {} 7 1] + test io-27.1 {testing handler deletion} { removeFile test1 set f [open test1 w] @@ -4441,6 +4610,395 @@ test io-27.6 {testing handler deletion vs reentrant calls} { {first after update}] } 0 +test io-28.1 {Test old socket deletion on Macintosh} {tempNotMac} { + set x 0 + set result "" + proc accept {s a p} { + global x wait + fconfigure $s -blocking off + puts $s "sock[incr x]" + close $s + set wait done + } + set ss [socket -server accept 2831] + set wait "" + set cs [socket [info hostname] 2831] + vwait wait + lappend result [gets $cs] + close $cs + + set wait "" + set cs [socket [info hostname] 2831] + vwait wait + lappend result [gets $cs] + close $cs + + set wait "" + set cs [socket [info hostname] 2831] + vwait wait + lappend result [gets $cs] + close $cs + + set wait "" + set cs [socket [info hostname] 2831] + vwait wait + lappend result [gets $cs] + close $cs + close $ss + set result +} {sock1 sock2 sock3 sock4} + +test io-29.1 {TclCopyChannel} { + removeFile test1 + set f1 [open io.test] + set f2 [open test1 w] + fcopy $f1 $f2 -command { # } + catch { fcopy $f1 $f2 } msg + close $f1 + close $f2 + string compare $msg "channel \"$f1\" is busy" +} {0} +test io-29.2 {TclCopyChannel} { + removeFile test1 + set f1 [open io.test] + set f2 [open test1 w] + set f3 [open io.test] + fcopy $f1 $f2 -command { # } + catch { fcopy $f3 $f2 } msg + close $f1 + close $f2 + close $f3 + string compare $msg "channel \"$f2\" is busy" +} {0} +test io-29.3 {TclCopyChannel} { + removeFile test1 + set f1 [open io.test] + set f2 [open test1 w] + fconfigure $f1 -translation lf -blocking 0 + fconfigure $f2 -translation cr -blocking 0 + set s0 [fcopy $f1 $f2] + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + close $f1 + close $f2 + set s1 [file size io.test] + set s2 [file size test1] + if {("$s1" == "$s2") && ($s0 == $s1)} { + lappend result ok + } + set result +} {0 0 ok} +test io-29.4 {TclCopyChannel} { + removeFile test1 + set f1 [open io.test] + set f2 [open test1 w] + fconfigure $f1 -translation lf -blocking 0 + fconfigure $f2 -translation cr -blocking 0 + fcopy $f1 $f2 -size 40 + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + close $f1 + close $f2 + lappend result [file size test1] +} {0 0 40} +test io-29.5 {TclCopyChannel} { + removeFile test1 + set f1 [open io.test] + set f2 [open test1 w] + fconfigure $f1 -translation lf -blocking 0 + fconfigure $f2 -translation lf -blocking 0 + fcopy $f1 $f2 -size -1 + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + close $f1 + close $f2 + set s1 [file size io.test] + set s2 [file size test1] + if {"$s1" == "$s2"} { + lappend result ok + } + set result +} {0 0 ok} +test io-29.6 {TclCopyChannel} { + removeFile test1 + set f1 [open io.test] + set f2 [open test1 w] + fconfigure $f1 -translation lf -blocking 0 + fconfigure $f2 -translation lf -blocking 0 + set s0 [fcopy $f1 $f2 -size [expr [file size io.test] + 5]] + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + close $f1 + close $f2 + set s1 [file size io.test] + set s2 [file size test1] + if {("$s1" == "$s2") && ($s0 == $s1)} { + lappend result ok + } + set result +} {0 0 ok} +test io-29.7 {TclCopyChannel} { + removeFile test1 + set f1 [open io.test] + set f2 [open test1 w] + fconfigure $f1 -translation lf -blocking 0 + fconfigure $f2 -translation lf -blocking 0 + fcopy $f1 $f2 + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + set s1 [file size io.test] + set s2 [file size test1] + close $f1 + close $f2 + if {"$s1" == "$s2"} { + lappend result ok + } + set result +} {0 0 ok} +test io-29.8 {TclCopyChannel} {unixOrPc} { + removeFile test1 + removeFile pipe + set f1 [open pipe w] + puts $f1 { + puts ready + gets stdin + set f1 [open io.test r] + puts [read $f1 100] + close $f1 + } + close $f1 + set f1 [open "|$tcltest pipe" r+] + gets $f1 + puts $f1 ready + flush $f1 + set f2 [open test1 w] + set s0 [fcopy $f1 $f2 -size 40] + catch {close $f1} + close $f2 + list $s0 [file size test1] +} {40 40} + +test io-30.1 {CopyData} { + removeFile test1 + set f1 [open io.test] + set f2 [open test1 w] + fconfigure $f1 -translation lf -blocking 0 + fconfigure $f2 -translation cr -blocking 0 + fcopy $f1 $f2 -size 0 + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + close $f1 + close $f2 + lappend result [file size test1] +} {0 0 0} +test io-30.2 {CopyData} { + removeFile test1 + set f1 [open io.test] + set f2 [open test1 w] + fconfigure $f1 -translation lf -blocking 0 + fconfigure $f2 -translation cr -blocking 0 + fcopy $f1 $f2 -command {set s0} + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + vwait s0 + close $f1 + close $f2 + set s1 [file size io.test] + set s2 [file size test1] + if {("$s1" == "$s2") && ($s0 == $s1)} { + lappend result ok + } + set result +} {0 0 ok} +test io-30.3 {CopyData: background read underflow} {unixOnly} { + removeFile test1 + removeFile pipe + set f1 [open pipe w] + puts $f1 { + puts ready + flush stdout ;# Don't assume line buffered! + fcopy stdin stdout -command { set x } + vwait x + set f [open test1 w] + fconfigure $f -translation lf + puts $f "done" + close $f + } + close $f1 + set f1 [open "|$tcltest pipe" r+] + set result [gets $f1] + puts $f1 line1 + flush $f1 + lappend result [gets $f1] + puts $f1 line2 + flush $f1 + lappend result [gets $f1] + close $f1 + after 500 + set f [open test1] + lappend result [read $f] + close $f + set result +} "ready line1 line2 {done\n}" +test io-30.4 {CopyData: background write overflow} {unixOnly} { + set big aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n + for {set x 0} {$x < 12} {incr x} { + append big $big + } + removeFile test1 + removeFile pipe + set f1 [open pipe w] + puts $f1 { + puts ready + fcopy stdin stdout -command { set x } + vwait x + set f [open test1 w] + fconfigure $f -translation lf + puts $f "done" + close $f + } + close $f1 + set f1 [open "|$tcltest pipe" r+] + set result [gets $f1] + fconfigure $f1 -blocking 0 + puts $f1 $big + flush $f1 + after 500 + set result "" + fileevent $f1 read { + append result [read $f1 1024] + if {[string length $result] >= [string length $big]} { + set x done + } + } + vwait x + close $f1 + set big {} + set x +} done + +proc FcopyTestAccept {sock args} { + after 1000 "close $sock" +} +proc FcopyTestDone {bytes {error {}}} { + global fcopyTestDone + if {[string length $error]} { + set fcopyTestDone 1 + } else { + set fcopyTestDone 0 + } +} +if [catch {socket -server FcopyTestAccept 2828} listen] { + puts stderr "Skipping fcopy error test" +} else { + test io-30.5 {CopyData: error during fcopy} { + set in [open io.test] ;# 126 K + set out [socket localhost 2828] + catch {unset fcopyTestDone} + close $listen ;# This means the socket open never really succeeds + fcopy $in $out -command FcopyTestDone + if ![info exists fcopyTestDone] { + vwait fcopyTestDone + } + close $in + close $out + set fcopyTestDone + } 1 +} + +test io-31.1 {Recursive channel events} { + # This test checks to see if file events are delivered during recursive + # event loops when there is buffered data on the channel. + + proc accept {s a p} { + global as + fconfigure $s -translation lf + puts $s "line 1\nline2\nline3" + flush $s + set as $s + } + proc readit {s next} { + global result x + lappend result $next + if {$next == 1} { + fileevent $s readable [list readit $s 2] + vwait x + } + incr x + } + set ss [socket -server accept 2828] + + # We need to delay on some systems until the creation of the + # server socket completes. + + set done 0 + for {set i 0} {$i < 10} {incr i} { + if {![catch {set cs [socket [info hostname] 2828]}]} { + set done 1 + break + } + after 100 + } + if {$done == 0} { + close $ss + error "failed to connect to server" + } + set result {} + set x 0 + vwait as + fconfigure $cs -translation lf + lappend result [gets $cs] + fconfigure $cs -blocking off + fileevent $cs readable [list readit $cs 1] + set a [after 2000 { set x failure }] + vwait x + after cancel $a + close $as + close $ss + close $cs + list $result $x +} {{{line 1} 1 2} 2} +test io-31.2 {Testing for busy-wait in recursive channel events} { + set s [socket -server accept 3939] + proc accept {s a p} { + global counter + + set counter 0 + fconfigure $s -blocking off -buffering line -translation lf + fileevent $s readable "doit $s" + } + proc doit {s} { + global counter + + incr counter + set l [gets $s] + if {"$l" == ""} { + fileevent $s readable "doit1 $s" + after 1000 newline + } + } + proc doit1 {s} { + global counter + + incr counter + set l [gets $s] + close $s + } + proc producer {} { + global writer + + set writer [socket localhost 3939] + fconfigure $writer -buffering line + puts -nonewline $writer hello + flush $writer + } + proc newline {} { + global writer done + + puts $writer hello + flush $writer + set done 1 + } + producer + vwait done + close $writer + close $s + set counter +} 1 + removeFile longfile removeFile script removeFile output @@ -4449,6 +5007,8 @@ removeFile pipe removeFile my_script removeFile foo removeFile bar +removeFile test2 +removeFile test3 set x "" unset x diff --git a/contrib/tcl/tests/ioCmd.test b/contrib/tcl/tests/ioCmd.test index 18eb5ecc31882..149d6c7445862 100644 --- a/contrib/tcl/tests/ioCmd.test +++ b/contrib/tcl/tests/ioCmd.test @@ -1,5 +1,5 @@ # Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, -# fblocked, fconfigure, open, channel +# fblocked, fconfigure, open, channel, fcopy # # 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 @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# "@(#) iocmd.test 1.37 96/04/12 11:44:23" +# "@(#) ioCmd.test 1.47 97/06/23 18:21:31" if {[string compare test [info procs test]] == 1} then {source defs} @@ -20,92 +20,103 @@ removeFile pipe set executable [list [info nameofexecutable]] -#test iocmd-1.0 {copyfile command} { -# list [catch {copyfile a b c d e f} msg] $msg -#} {1 {wrong # args: should be "copyfile inChanId outChanId ?chunkSize?"}} -#test iocmd-1.1 {copyfile command} { -# list [catch {copyfile f1} msg] $msg -#} {1 {wrong # args: should be "copyfile inChanId outChanId ?chunkSize?"}} -#test iocmd-1.2 {copyfile command} { -# list [catch {copyfile f1 f2} msg] $msg -#} {1 {can not find channel named "f1"}} -#test iocmd-1.3 {copyfile command} { -# list [catch {copyfile stdin f2} msg] $msg -#} {1 {can not find channel named "f2"}} -#test iocmd-1.4 {copyfile command} { -# list [catch {copyfile stdin stdout booboo} msg] $msg -#} {1 {expected integer but got "booboo"}} -#test iocmd-1.5 {copyfile command} { -# list [catch {copyfile stdout stdin} msg] $msg -#} {1 {channel "stdout" wasn't opened for reading}} -#test iocmd-1.6 {copyfile command} { -# list [catch {copyfile stdin stdin} msg] $msg -#} {1 {channel "stdin" wasn't opened for writing}} - -test iocmd-2.1 {puts command} { +test iocmd-1.1 {puts command} { list [catch {puts} msg] $msg } {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}} -test iocmd-2.2 {puts command} { +test iocmd-1.2 {puts command} { list [catch {puts a b c d e f g} msg] $msg } {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}} -test iocmd-2.3 {puts command} { +test iocmd-1.3 {puts command} { list [catch {puts froboz -nonewline kablooie} msg] $msg } {1 {bad argument "kablooie": should be "nonewline"}} -test iocmd-2.4 {puts command} { +test iocmd-1.4 {puts command} { list [catch {puts froboz hello} msg] $msg } {1 {can not find channel named "froboz"}} -test iocmd-2.5 {puts command} { +test iocmd-1.5 {puts command} { list [catch {puts stdin hello} msg] $msg } {1 {channel "stdin" wasn't opened for writing}} +test iocmd-1.6 {puts command} { + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + puts -nonewline $f foobar + close $f + file size test1 +} 6 +test iocmd-1.7 {puts command} { + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + puts $f foobar + close $f + file size test1 +} 7 +test iocmd-1.8 {puts command} { + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + puts -nonewline $f [binary format a4a5 foo bar] + close $f + file size test1 +} 9 + -test iocmd-3.0 {flush command} { +test iocmd-2.1 {flush command} { list [catch {flush} msg] $msg } {1 {wrong # args: should be "flush channelId"}} -test iocmd-3.1 {flush command} { +test iocmd-2.2 {flush command} { list [catch {flush a b c d e} msg] $msg } {1 {wrong # args: should be "flush channelId"}} -test iocmd-3.3 {flush command} { +test iocmd-2.3 {flush command} { list [catch {flush foo} msg] $msg } {1 {can not find channel named "foo"}} -test iocmd-3.4 {flush command} { +test iocmd-2.4 {flush command} { list [catch {flush stdin} msg] $msg } {1 {channel "stdin" wasn't opened for writing}} -test iocmd-4.0 {gets command} { +test iocmd-3.1 {gets command} { list [catch {gets} msg] $msg } {1 {wrong # args: should be "gets channelId ?varName?"}} -test iocmd-4.1 {gets command} { +test iocmd-3.2 {gets command} { list [catch {gets a b c d e f g} msg] $msg } {1 {wrong # args: should be "gets channelId ?varName?"}} -test iocmd-4.2 {gets command} { +test iocmd-3.3 {gets command} { list [catch {gets aaa} msg] $msg } {1 {can not find channel named "aaa"}} -test iocmd-4.2 {gets command} { +test iocmd-3.4 {gets command} { list [catch {gets stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} +test iocmd-3.5 {gets command} { + set f [open test1 w] + puts $f [binary format a4a5 foo bar] + close $f + set f [open test1 r] + set result [gets $f] + close $f + set x foo\x00 + set x "${x}bar\x00\x00" + string compare $x $result +} 0 -test iocmd-5.0 {read command} { +test iocmd-4.1 {read command} { list [catch {read} msg] $msg } {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"}} -test iocmd-5.1 {read command} { +test iocmd-4.2 {read command} { list [catch {read a b c d e f g h} msg] $msg } {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"}} -test iocmd-5.2 {read command} { +test iocmd-4.3 {read command} { list [catch {read aaa} msg] $msg } {1 {can not find channel named "aaa"}} -test iocmd-5.3 {read command} { +test iocmd-4.4 {read command} { list [catch {read -nonewline} msg] $msg } {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"}} -test iocmd-5.4 {read command} { +test iocmd-4.5 {read command} { list [catch {read -nonew file4} msg] $msg $errorCode } {1 {can not find channel named "-nonew"} NONE} -test iocmd-5.5 {read command} { +test iocmd-4.6 {read command} { list [catch {read stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} -test iocmd-5.6 {read command} { +test iocmd-4.7 {read command} { list [catch {read -nonewline stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} -test iocmd-5.23 {read command with incorrect combination of arguments} { +test iocmd-4.8 {read command with incorrect combination of arguments} { removeFile test1 set f [open test1 w] puts $f "Two lines: this one" @@ -116,82 +127,82 @@ test iocmd-5.23 {read command with incorrect combination of arguments} { close $f set x } {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"} NONE} -test iocmd-5.24 {read command} { +test iocmd-4.9 {read command} { list [catch {read stdin foo} msg] $msg $errorCode } {1 {bad argument "foo": should be "nonewline"} NONE} -test iocmd-5.25 {read command} { +test iocmd-4.10 {read command} { list [catch {read file107} msg] $msg $errorCode } {1 {can not find channel named "file107"} NONE} -test iocmd-5.26 {read command} { +test iocmd-4.11 {read command} { set f [open test3 w] set x [list [catch {read $f} msg] $msg $errorCode] close $f string compare [string tolower $x] \ [list 1 [format "channel \"%s\" wasn't opened for reading" $f] none] } 0 -test iocmd-5.27 {read command} { +test iocmd-4.12 {read command} { set f [open test1] set x [list [catch {read $f 12z} msg] $msg $errorCode] close $f set x } {1 {expected integer but got "12z"} NONE} -test iocmd-6.0 {seek command} { +test iocmd-5.1 {seek command} { list [catch {seek} msg] $msg } {1 {wrong # args: should be "seek channelId offset ?origin?"}} -test iocmd-6.1 {seek command} { +test iocmd-5.2 {seek command} { list [catch {seek a b c d e f g} msg] $msg } {1 {wrong # args: should be "seek channelId offset ?origin?"}} -test iocmd-6.2 {seek command} { +test iocmd-5.3 {seek command} { list [catch {seek stdin gugu} msg] $msg } {1 {expected integer but got "gugu"}} -test iocmd-6.3 {seek command} { +test iocmd-5.4 {seek command} { list [catch {seek stdin 100 gugu} msg] $msg } {1 {bad origin "gugu": should be start, current, or end}} -test iocmd-7.0 {tell command} { +test iocmd-6.1 {tell command} { list [catch {tell} msg] $msg } {1 {wrong # args: should be "tell channelId"}} -test iocmd-7.1 {tell command} { +test iocmd-6.2 {tell command} { list [catch {tell a b c d e} msg] $msg } {1 {wrong # args: should be "tell channelId"}} -test iocmd-7.2 {tell command} { +test iocmd-6.3 {tell command} { list [catch {tell aaa} msg] $msg } {1 {can not find channel named "aaa"}} -test iocmd-8.0 {close command} { +test iocmd-7.1 {close command} { list [catch {close} msg] $msg } {1 {wrong # args: should be "close channelId"}} -test iocmd-8.1 {close command} { +test iocmd-7.2 {close command} { list [catch {close a b c d e} msg] $msg } {1 {wrong # args: should be "close channelId"}} -test iocmd-8.2 {close command} { +test iocmd-7.3 {close command} { list [catch {close aaa} msg] $msg } {1 {can not find channel named "aaa"}} -test iocmd-9.0 {fconfigure command} { +test iocmd-8.1 {fconfigure command} { list [catch {fconfigure} msg] $msg } {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}} -test iocmd-9.1 {fconfigure command} { +test iocmd-8.2 {fconfigure command} { list [catch {fconfigure a b c d e f} msg] $msg } {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}} -test iocmd-9.2 {fconfigure command} { +test iocmd-8.3 {fconfigure command} { list [catch {fconfigure a b} msg] $msg } {1 {can not find channel named "a"}} -test iocmd-9.3 {fconfigure command} { +test iocmd-8.4 {fconfigure command} { removeFile test1 set f1 [open test1 w] set x [list [catch {fconfigure $f1 froboz} msg] $msg] close $f1 set x -} {1 {bad option "froboz": must be -blocking, -buffering, -buffersize, -eofchar, -translation, or a channel type specific option}} -test iocmd-9.4 {fconfigure command} { +} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -eofchar, or -translation}} +test iocmd-8.5 {fconfigure command} { list [catch {fconfigure stdin -buffering froboz} msg] $msg } {1 {bad value for -buffering: must be one of full, line, or none}} -test iocmd-9.4 {fconfigure command} { +test iocmd-8.6 {fconfigure command} { list [catch {fconfigure stdin -translation froboz} msg] $msg } {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}} -test iocmd-9.5 {fconfigure command} { +test iocmd-8.7 {fconfigure command} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -199,7 +210,7 @@ test iocmd-9.5 {fconfigure command} { close $f1 set x } {-blocking 1 -buffering full -buffersize 4096 -eofchar {} -translation lf} -test iocmd-9.6 {fconfigure command} { +test iocmd-8.8 {fconfigure command} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ @@ -210,7 +221,7 @@ test iocmd-9.6 {fconfigure command} { close $f1 set x } {line {-blocking 1 -buffering line -buffersize 3030 -eofchar {} -translation lf}} -test iocmd-9.7 {fconfigure command} { +test iocmd-8.9 {fconfigure command} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ @@ -219,60 +230,118 @@ test iocmd-9.7 {fconfigure command} { close $f1 set x } {-blocking 1 -buffering none -buffersize 4040 -eofchar {} -translation lf} -test iocmd-9.8 {fconfigure command} { +test iocmd-8.10 {fconfigure command} { list [catch {fconfigure a b} msg] $msg } {1 {can not find channel named "a"}} -test iocmd-9.9 {fconfigure command} { +test iocmd-8.11 {fconfigure command} { list [catch {fconfigure stdout -froboz blarfo} msg] $msg -} {1 {bad option "-froboz": should be -blocking, -buffering, -buffersize, -eofchar, -translation, or channel type specific option}} -test iocmd-9.10 {fconfigure command} { +} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -eofchar, or -translation}} +test iocmd-8.12 {fconfigure command} { list [catch {fconfigure stdout -b blarfo} msg] $msg -} {1 {bad option "-b": should be -blocking, -buffering, -buffersize, -eofchar, -translation, or channel type specific option}} -test iocmd-9.11 {fconfigure command} { +} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -eofchar, or -translation}} +test iocmd-8.13 {fconfigure command} { list [catch {fconfigure stdout -buffer blarfo} msg] $msg -} {1 {bad option "-buffer": should be -blocking, -buffering, -buffersize, -eofchar, -translation, or channel type specific option}} -test iocmd-9.12 {fconfigure command} { +} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -eofchar, or -translation}} +test iocmd-8.14 {fconfigure command} { fconfigure stdin -buffers } 4096 +proc iocmdSSETUP {} { + uplevel { + set srv [socket -server iocmdSRV 0]; + set port [lindex [fconfigure $srv -sockname] 2]; + proc iocmdSRV {sock ip port} {close $sock} + set cli [socket localhost $port]; + } +} +proc iocmdSSHTDWN {} { + uplevel { + close $cli; + close $srv; + unset cli srv port + rename iocmdSRV {} + } +} + +test iocmd-8.15 {fconfigure command / tcp channel} { + iocmdSSETUP + set r [list [catch {fconfigure $cli -blah} msg] $msg]; + iocmdSSHTDWN + set r; +} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, -peername, or -sockname}} +test iocmd-8.16 {fconfigure command / tcp channel} { + iocmdSSETUP + set r [expr [lindex [fconfigure $cli -peername] 2]==$port]; + iocmdSSHTDWN + set r +} 1 +test iocmd-8.17 {fconfigure command / tcp channel} {nonPortable} { + # It is possible that you don't get the connection reset by peer + # error but rather a valid answer. depends of the tcp implementation + iocmdSSETUP + update; + puts $cli "blah"; flush $cli; # that flush could/should fail too + update; + set r [list [catch {fconfigure $cli -peername} msg] $msg]; + iocmdSSHTDWN + regsub -all {can([^:])+: } $r {} r; + set r +} {1 {connection reset by peer}} +test iocmd-8.18 {fconfigure command / unix tty channel} {nonPortable unixOnly} { + # might fail if /dev/ttya is unavailable + set tty [open /dev/ttya] + set r [list [catch {fconfigure $tty -blah blih} msg] $msg]; + close $tty; + set r; +} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}} +test iocmd-8.19 {fconfigure command / win tty channel} {pcOnly} { + # might fail if com1 is unavailable + set tty [open com1] + set r [list [catch {fconfigure $tty -blah blih} msg] $msg]; + close $tty; + set r; +} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}} -test iocmd-10.1 {eof command} { +test iocmd-9.1 {eof command} { list [catch {eof} msg] $msg $errorCode } {1 {wrong # args: should be "eof channelId"} NONE} -test iocmd-10.2 {eof command} { +test iocmd-9.2 {eof command} { list [catch {eof a b} msg] $msg $errorCode } {1 {wrong # args: should be "eof channelId"} NONE} -test iocmd-10.3 {eof command} { +test iocmd-9.3 {eof command} { catch {close file100} list [catch {eof file100} msg] $msg $errorCode } {1 {can not find channel named "file100"} NONE} -test iocmd-11.0 {fblocked command} { +test iocmd-10.1 {fblocked command} { list [catch {fblocked} msg] $msg } {1 {wrong # args: should be "fblocked channelId"}} -test iocmd-11.1 {fblocked command} { +test iocmd-10.2 {fblocked command} { list [catch {fblocked a b c d e f g} msg] $msg } {1 {wrong # args: should be "fblocked channelId"}} -test iocmd-11.2 {fblocked command} { +test iocmd-10.3 {fblocked command} { list [catch {fblocked file1000} msg] $msg } {1 {can not find channel named "file1000"}} -test iocmd-11.3 {fblocked command} { +test iocmd-10.4 {fblocked command} { list [catch {fblocked stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} -test iocmd-11.4 {fblocked command} { +test iocmd-10.5 {fblocked command} { fblocked stdin } 0 -test iocmd-12.1 {I/O to command pipelines} {unixOrPc unixExecs} { - list [catch {open "| cat < test1 > test3" w} msg] $msg $errorCode +removeFile test5 +test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} { + set f [open test4 w] + close $f + list [catch {open "| cat < test4 > test5" w} msg] $msg $errorCode } {1 {can't write input to command: standard input was redirected} NONE} -test iocmd-12.2 {I/O to command pipelines} {unixOrPc unixExecs} { - list [catch {open "| echo > test3" r} msg] $msg $errorCode +test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} { + list [catch {open "| echo > test5" r} msg] $msg $errorCode } {1 {can't read output from command: standard output was redirected} NONE} -test iocmd-12.3 {I/O to command pipelines} {unixOrPc unixExecs} { - list [catch {open "| echo > test3" r+} msg] $msg $errorCode +test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} { + list [catch {open "| echo > test5" r+} msg] $msg $errorCode } {1 {can't read output from command: standard output was redirected} NONE} -test iocmd-13.1 {POSIX open access modes: RDONLY} { +test iocmd-12.1 {POSIX open access modes: RDONLY} { removeFile test1 set f [open test1 w] puts $f "Two lines: this one" @@ -284,18 +353,18 @@ test iocmd-13.1 {POSIX open access modes: RDONLY} { string compare $x \ "{Two lines: this one} 1 [list [format "channel \"%s\" wasn't opened for writing" $f]]" } 0 -test iocmd-13.2 {POSIX open access modes: RDONLY} { +test iocmd-12.2 {POSIX open access modes: RDONLY} { removeFile test3 string tolower [list [catch {open test3 RDONLY} msg] $msg] } {1 {couldn't open "test3": no such file or directory}} -test iocmd-13.3 {POSIX open access modes: WRONLY} { +test iocmd-12.3 {POSIX open access modes: WRONLY} { removeFile test3 string tolower [list [catch {open test3 WRONLY} msg] $msg] } {1 {couldn't open "test3": no such file or directory}} # # Test 13.4 relies on assigning the same channel name twice. # -test iocmd-13.4 {POSIX open access modes: WRONLY} {unixOnly} { +test iocmd-12.4 {POSIX open access modes: WRONLY} {unixOnly} { removeFile test3 set f [open test3 w] fconfigure $f -eofchar {} @@ -314,80 +383,128 @@ test iocmd-13.4 {POSIX open access modes: WRONLY} {unixOnly} { set y [list 1 [format "channel \"%s\" wasn't opened for reading" $f] abzzy] string compare $x $y } 0 -test iocmd-13.5 {POSIX open access modes: RDWR} { +test iocmd-12.5 {POSIX open access modes: RDWR} { removeFile test3 string tolower [list [catch {open test3 RDWR} msg] $msg] } {1 {couldn't open "test3": no such file or directory}} -test iocmd-13.15 {POSIX open access modes: errors} { +test iocmd-12.6 {POSIX open access modes: errors} { concat [catch {open test3 "FOO \{BAR BAZ"} msg] $msg\n$errorInfo } "1 unmatched open brace in list unmatched open brace in list while processing open access modes \"FOO {BAR BAZ\" invoked from within \"open test3 \"FOO \\{BAR BAZ\"\"" -test iocmd-13.16 {POSIX open access modes: errors} { +test iocmd-12.7 {POSIX open access modes: errors} { list [catch {open test3 {FOO BAR BAZ}} msg] $msg } {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, CREAT EXCL, NOCTTY, NONBLOCK, or TRUNC}} -test iocmd-13.17 {POSIX open access modes: errors} { +test iocmd-12.8 {POSIX open access modes: errors} { list [catch {open test3 {TRUNC CREAT}} msg] $msg } {1 {access mode must include either RDONLY, WRONLY, or RDWR}} -test iocmd-14.1 {errors in open command} { +test iocmd-13.1 {errors in open command} { list [catch {open} msg] $msg } {1 {wrong # args: should be "open fileName ?access? ?permissions?"}} -test iocmd-14.2 {errors in open command} { +test iocmd-13.2 {errors in open command} { list [catch {open a b c d} msg] $msg } {1 {wrong # args: should be "open fileName ?access? ?permissions?"}} -test iocmd-14.3 {errors in open command} { +test iocmd-13.3 {errors in open command} { list [catch {open test1 x} msg] $msg } {1 {illegal access mode "x"}} -test iocmd-14.4 {errors in open command} { +test iocmd-13.4 {errors in open command} { list [catch {open test1 rw} msg] $msg } {1 {illegal access mode "rw"}} -test iocmd-14.5 {errors in open command} { +test iocmd-13.5 {errors in open command} { list [catch {open test1 r+1} msg] $msg } {1 {illegal access mode "r+1"}} -test iocmd-14.6 {errors in open command} { +test iocmd-13.6 {errors in open command} { string tolower [list [catch {open _non_existent_} msg] $msg $errorCode] } {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} -test iocmd-15.1 {file id parsing errors} { +test iocmd-14.1 {file id parsing errors} { list [catch {eof gorp} msg] $msg $errorCode } {1 {can not find channel named "gorp"} NONE} -test iocmd-15.2 {file id parsing errors} { +test iocmd-14.2 {file id parsing errors} { list [catch {eof filex} msg] $msg } {1 {can not find channel named "filex"}} -test iocmd-15.3 {file id parsing errors} { +test iocmd-14.3 {file id parsing errors} { list [catch {eof file12a} msg] $msg } {1 {can not find channel named "file12a"}} -test iocmd-15.4 {file id parsing errors} { +test iocmd-14.4 {file id parsing errors} { list [catch {eof file123} msg] $msg } {1 {can not find channel named "file123"}} -test iocmd-15.5 {file id parsing errors} { +test iocmd-14.5 {file id parsing errors} { list [catch {eof stdout} msg] $msg } {0 0} -test iocmd-15.6 {file id parsing errors} { +test iocmd-14.6 {file id parsing errors} { list [catch {eof stdin} msg] $msg } {0 0} -test iocmd-15.7 {file id parsing errors} { +test iocmd-14.7 {file id parsing errors} { list [catch {eof stdout} msg] $msg } {0 0} -test iocmd-15.8 {file id parsing errors} { +test iocmd-14.8 {file id parsing errors} { list [catch {eof stderr} msg] $msg } {0 0} -test iocmd-15.9 {file id parsing errors} { +test iocmd-14.9 {file id parsing errors} { list [catch {eof stderr1} msg] $msg } {1 {can not find channel named "stderr1"}} -set f [open test1] +set f [open test1 w] close $f set expect "1 {can not find channel named \"$f\"}" -test iocmd-15.10 {file id parsing errors} { +test iocmd-14.10 {file id parsing errors} { list [catch {eof $f} msg] $msg } $expect +test iocmd-15.1 {Tcl_FcopyObjCmd} { + list [catch {fcopy} msg] $msg +} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} +test iocmd-15.2 {Tcl_FcopyObjCmd} { + list [catch {fcopy 1} msg] $msg +} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} +test iocmd-15.3 {Tcl_FcopyObjCmd} { + list [catch {fcopy 1 2 3 4 5 6 7} msg] $msg +} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} +test iocmd-15.4 {Tcl_FcopyObjCmd} { + list [catch {fcopy 1 2 3} msg] $msg +} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} +test iocmd-15.5 {Tcl_FcopyObjCmd} { + list [catch {fcopy 1 2 3 4 5} msg] $msg +} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} +set f [open test1 w] +close $f +set rfile [open test1 r] +set wfile [open test2 w] +test iocmd-15.6 {Tcl_FcopyObjCmd} { + list [catch {fcopy foo $wfile} msg] $msg +} {1 {can not find channel named "foo"}} +test iocmd-15.7 {Tcl_FcopyObjCmd} { + list [catch {fcopy $rfile foo} msg] $msg +} {1 {can not find channel named "foo"}} +test iocmd-15.8 {Tcl_FcopyObjCmd} { + list [catch {fcopy $wfile $wfile} msg] $msg +} "1 {channel \"$wfile\" wasn't opened for reading}" +test iocmd-15.9 {Tcl_FcopyObjCmd} { + list [catch {fcopy $rfile $rfile} msg] $msg +} "1 {channel \"$rfile\" wasn't opened for writing}" +test iocmd-15.10 {Tcl_FcopyObjCmd} { + list [catch {fcopy $rfile $wfile foo bar} msg] $msg +} {1 {bad switch "foo": must be -size, or -command}} +test iocmd-15.11 {Tcl_FcopyObjCmd} { + list [catch {fcopy $rfile $wfile -size foo} msg] $msg +} {1 {expected integer but got "foo"}} +test iocmd-15.12 {Tcl_FcopyObjCmd} { + list [catch {fcopy $rfile $wfile -command bar -size foo} msg] $msg +} {1 {expected integer but got "foo"}} + +close $rfile +close $wfile + removeFile test1 removeFile test2 removeFile test3 +removeFile test4 +# delay long enough for background processes to finish +after 500 +removeFile test5 removeFile pipe removeFile output set x "" diff --git a/contrib/tcl/tests/lindex.test b/contrib/tcl/tests/lindex.test index 66ff3acba7b55..fa2c1c6a80dc1 100644 --- a/contrib/tcl/tests/lindex.test +++ b/contrib/tcl/tests/lindex.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) lindex.test 1.5 96/02/16 08:56:03 +# SCCS: @(#) lindex.test 1.7 97/02/27 16:53:56 if {[string compare test [info procs test]] == 1} then {source defs} @@ -49,7 +49,7 @@ test lindex-2.2 {error conditions} { } {1 {wrong # args: should be "lindex list index"}} test lindex-2.3 {error conditions} { list [catch {lindex 1 2a2} msg] $msg -} {1 {expected integer but got "2a2"}} +} {1 {bad index "2a2": must be integer or "end"}} test lindex-2.4 {error conditions} { list [catch {lindex "a \{" 2} msg] $msg } {1 {unmatched open brace in list}} diff --git a/contrib/tcl/tests/link.test b/contrib/tcl/tests/link.test index 570a6ee1e3ee9..25eefb1bb3158 100644 --- a/contrib/tcl/tests/link.test +++ b/contrib/tcl/tests/link.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) link.test 1.10 96/02/16 08:56:05 +# SCCS: @(#) link.test 1.12 97/01/21 21:16:04 if {[info commands testlink] == {}} { puts "This application hasn't been compiled with the \"testlink\"" @@ -38,14 +38,14 @@ test link-1.2 {reading C variables from Tcl} { test link-2.1 {writing C variables from Tcl} { testlink delete - testlink set 43 1.23 4 - + testlink set 43 1.21 4 - testlink create 1 1 1 1 set int "00721" - set real -8e13 + set real -10.5 set bool true set string abcdef concat [testlink get] $int $real $bool $string -} {465 -8e+13 1 abcdef 00721 -8e13 true abcdef} +} {465 -10.5 1 abcdef 00721 -10.5 true abcdef} test link-2.2 {writing bad values into variables} { testlink delete testlink set 43 1.23 4 - @@ -86,12 +86,12 @@ test link-3.2 {read-only variables} { test link-4.1 {unsetting linked variables} { testlink delete - testlink set -6 -2.1 0 stringValue + testlink set -6 -2.5 0 stringValue testlink create 1 1 1 1 unset int real bool string list [catch {set int} msg] $msg [catch {set real} msg] $msg \ [catch {set bool} msg] $msg [catch {set string} msg] $msg -} {0 -6 0 -2.1 0 0 0 stringValue} +} {0 -6 0 -2.5 0 0 0 stringValue} test link-4.2 {unsetting linked variables} { testlink delete testlink set -6 -2.1 0 stringValue @@ -106,22 +106,22 @@ test link-4.2 {unsetting linked variables} { test link-5.1 {unlinking variables} { testlink delete - testlink set -6 -2.1 0 stringValue + testlink set -6 -2.25 0 stringValue testlink delete set int xx1 set real qrst set bool bogus set string 12345 testlink get -} {-6 -2.1 0 stringValue} +} {-6 -2.25 0 stringValue} test link-5.2 {unlinking variables} { testlink delete - testlink set -6 -2.1 0 stringValue + testlink set -6 -2.25 0 stringValue testlink create 1 1 1 1 testlink delete testlink set 25 14.7 7 - list $int $real $bool $string -} {-6 -2.1 0 stringValue} +} {-6 -2.25 0 stringValue} test link-6.1 {errors in setting up link} { testlink delete @@ -182,9 +182,9 @@ test link-7.5 {access to linked variables via upvar} { } testlink delete testlink create 1 1 1 1 - testlink set -4 16.3 {} {} + testlink set -4 16.75 {} {} list [catch x msg] $msg $real -} {1 {can't set "y": variable must have real value} 16.3} +} {1 {can't set "y": variable must have real value} 16.75} test link-7.6 {access to linked variables via upvar} { proc x {} { upvar bool y @@ -223,6 +223,10 @@ test link-8.2 {Tcl_UpdateLinkedVar procedure} { trace vdelete int w x set x } {} +test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} { + testlink create 0 0 0 0 + list [catch {testlink update 47 {} {} {}} msg] $msg $int +} {0 {} 47} testlink delete foreach i {int real bool string} { diff --git a/contrib/tcl/tests/linsert.test b/contrib/tcl/tests/linsert.test index a77a90716a446..6611394a6182d 100644 --- a/contrib/tcl/tests/linsert.test +++ b/contrib/tcl/tests/linsert.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) linsert.test 1.8 96/02/16 08:56:07 +# SCCS: @(#) linsert.test 1.13 97/02/27 16:53:19 if {[string compare test [info procs test]] == 1} then {source defs} @@ -37,7 +37,7 @@ test linsert-1.7 {linsert command} { } {1 2 one two \{three {$four} 3 4 5} test linsert-1.8 {linsert command} { linsert {\{one \$two \{three \ four \ five} 2 a b c -} {\{one \$two a b c \{three \ four \ five} +} {\{one {$two} a b c \{three { four} { five}} test linsert-1.9 {linsert command} { linsert {{1 2} {3 4} {5 6} {7 8}} 2 {x y} {a b} } {{1 2} {3 4} {x y} {a b} {5 6} {7 8}} @@ -49,10 +49,10 @@ test linsert-1.11 {linsert command} { } {{}} test linsert-1.12 {linsert command} { linsert {a b "c c" d e} 3 1 -} {a b "c c" 1 d e} +} {a b {c c} 1 d e} test linsert-1.13 {linsert command} { linsert { a b c d} 0 1 2 -} {1 2 a b c d} +} {1 2 a b c d} test linsert-1.14 {linsert command} { linsert {a b c {d e f}} 4 1 2 } {a b c {d e f} 1 2} @@ -80,7 +80,15 @@ test linsert-2.2 {linsert errors} { } {1 {wrong # args: should be "linsert list index element ?element ...?"}} test linsert-2.3 {linsert errors} { list [catch {linsert a 12x 2} msg] $msg -} {1 {expected integer but got "12x"}} +} {1 {bad index "12x": must be integer or "end"}} test linsert-2.4 {linsert errors} { list [catch {linsert \{ 12 2} msg] $msg } {1 {unmatched open brace in list}} + +test linsert-3.1 {linsert won't modify shared argument objects} { + proc p {} { + linsert "a b c" 1 "x y" + return "a b c" + } + p +} "a b c" diff --git a/contrib/tcl/tests/list.test b/contrib/tcl/tests/list.test index e90139107a613..6c59f205e22e2 100644 --- a/contrib/tcl/tests/list.test +++ b/contrib/tcl/tests/list.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) list.test 1.20 96/02/16 08:56:09 +# SCCS: @(#) list.test 1.22 97/06/23 18:19:17 if {[string compare test [info procs test]] == 1} then {source defs} @@ -44,15 +44,17 @@ test list-1.24 {basic tests} {list} {} # For the next round of tests create a list and then pick it apart # with "index" to make sure that we get back exactly what went in. +test list-2.1 {placeholder} { +} {} set num 1 proc lcheck {a b c} { global num d set d [list $a $b $c] - test list-2.$num {what goes in must come out} {lindex $d 0} $a +; test list-2.$num {what goes in must come out} {lindex $d 0} $a set num [expr $num+1] - test list-2.$num {what goes in must come out} {lindex $d 1} $b +; test list-2.$num {what goes in must come out} {lindex $d 1} $b set num [expr $num+1] - test list-2.$num {what goes in must come out} {lindex $d 2} $c +; test list-2.$num {what goes in must come out} {lindex $d 2} $c set num [expr $num+1] } lcheck a b c @@ -71,3 +73,35 @@ lcheck xyz \\ 1\\\n2 lcheck "{ab}\\" "{ab}xy" abc concat {} + +# Check that tclListObj.c's SetListFromAny handles possible overlarge +# string rep lengths in the source object. + +proc slowsort list { + set result {} + set last [expr [llength $list] - 1] + while {$last > 0} { + set minIndex [expr [llength $list] - 1] + set min [lindex $list $last] + set i [expr $minIndex-1] + while {$i >= 0} { + if {[string compare [lindex $list $i] $min] < 0} { + set minIndex $i + set min [lindex $list $i] + } + set i [expr $i-1] + } + set result [concat $result [list $min]] + if {$minIndex == 0} { + set list [lrange $list 1 end] + } else { + set list [concat [lrange $list 0 [expr $minIndex-1]] \ + [lrange $list [expr $minIndex+1] end]] + } + set last [expr $last-1] + } + return [concat $result $list] +} +test list-3.1 {SetListFromAny and lrange/concat results} { + slowsort {fred julie alex carol bill annie} +} {alex annie bill carol fred julie} diff --git a/contrib/tcl/tests/listObj.test b/contrib/tcl/tests/listObj.test new file mode 100644 index 0000000000000..00eb7c6435758 --- /dev/null +++ b/contrib/tcl/tests/listObj.test @@ -0,0 +1,176 @@ +# Functionality covered: operation of the procedures in tclListObj.c that +# implement the Tcl type manager for the list object type. +# +# 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) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) listObj.test 1.9 97/06/10 15:28:11 + +if {[info commands testobj] == {}} { + puts "This application hasn't been compiled with the \"testobj\"" + puts "command, so I can't test the Tcl type and object support." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset x} +test listobj-1.1 {Tcl_GetListObjType} { + set t [testobj types] + set first [string first "list" $t] + set result [expr {$first != -1}] +} {1} + +test listobj-2.1 {Tcl_ListObjForObjArray, use in lappend} { + catch {unset x} + list [lappend x 1 abc def] [lappend x 1 ghi jkl] $x +} {{1 abc def} {1 abc def 1 ghi jkl} {1 abc def 1 ghi jkl}} +test listobj-2.2 {Tcl_ListObjForObjArray, use in ObjInterpProc} { + proc return_args {args} { + return $args + } + list [return_args] [return_args x] [return_args x y] +} {{} x {x y}} + +test listobj-3.1 {Tcl_ListObjAppend, list conversion} { + catch {unset x} + list [lappend x 1 2 abc "long string"] $x +} {{1 2 abc {long string}} {1 2 abc {long string}}} +test listobj-3.2 {Tcl_ListObjAppend, list conversion} { + set x "" + list [lappend x first second] [lappend x third fourth] $x +} {{first second} {first second third fourth} {first second third fourth}} +test listobj-3.3 {Tcl_ListObjAppend, list conversion} { + set x "abc def" + list [lappend x first second] $x +} {{abc def first second} {abc def first second}} +test listobj-3.4 {Tcl_ListObjAppend, error in conversion} { + set x " \{" + list [catch {lappend x abc def} msg] $msg +} {1 {unmatched open brace in list}} +test listobj-3.5 {Tcl_ListObjAppend, force internal rep array to grow} { + set x "" + list [lappend x 1 1] [lappend x 2 2] [lappend x 3 3] [lappend x 4 4] \ + [lappend x 5 5] [lappend x 6 6] [lappend x 7 7] [lappend x 8 8] $x +} {{1 1} {1 1 2 2} {1 1 2 2 3 3} {1 1 2 2 3 3 4 4} {1 1 2 2 3 3 4 4 5 5} {1 1 2 2 3 3 4 4 5 5 6 6} {1 1 2 2 3 3 4 4 5 5 6 6 7 7} {1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8} {1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8}} + +test listobj-4.1 {Tcl_ListObjAppendElement, list conversion} { + catch {unset x} + list [lappend x 1] $x +} {1 1} +test listobj-4.2 {Tcl_ListObjAppendElement, list conversion} { + set x "" + list [lappend x first] [lappend x second] $x +} {first {first second} {first second}} +test listobj-4.3 {Tcl_ListObjAppendElement, list conversion} { + set x "abc def" + list [lappend x first] $x +} {{abc def first} {abc def first}} +test listobj-4.4 {Tcl_ListObjAppendElement, error in conversion} { + set x " \{" + list [catch {lappend x abc} msg] $msg +} {1 {unmatched open brace in list}} +test listobj-4.5 {Tcl_ListObjAppendElement, force internal rep array to grow} { + set x "" + list [lappend x 1] [lappend x 2] [lappend x 3] [lappend x 4] \ + [lappend x 5] [lappend x 6] [lappend x 7] [lappend x 8] $x +} {1 {1 2} {1 2 3} {1 2 3 4} {1 2 3 4 5} {1 2 3 4 5 6} {1 2 3 4 5 6 7} {1 2 3 4 5 6 7 8} {1 2 3 4 5 6 7 8}} + +test listobj-5.1 {Tcl_ListObjIndex, basic tests} { + lindex {a b c} 0 +} a +test listobj-5.2 {Tcl_ListObjIndex, basic tests} { + lindex a 0 +} a +test listobj-5.3 {Tcl_ListObjIndex, basic tests} { + lindex {a {b c d} x} 1 +} {b c d} +test listobj-5.4 {Tcl_ListObjIndex, basic tests} { + lindex {a b c} 3 +} {} +test listobj-5.5 {Tcl_ListObjIndex, basic tests} { + lindex {a b c} 100 +} {} +test listobj-5.6 {Tcl_ListObjIndex, basic tests} { + lindex a 100 +} {} +test listobj-5.7 {Tcl_ListObjIndex, basic tests} { + lindex {} -1 +} {} +test listobj-5.8 {Tcl_ListObjIndex, error in conversion} { + set x " \{" + list [catch {lindex $x 0} msg] $msg +} {1 {unmatched open brace in list}} + +test listobj-6.1 {Tcl_ListObjLength} { + llength {a b c d} +} 4 +test listobj-6.2 {Tcl_ListObjLength} { + llength {a b c {a b {c d}} d} +} 5 +test listobj-6.3 {Tcl_ListObjLength} { + llength {} +} 0 +test listobj-6.4 {Tcl_ListObjLength, convert from non-list} { + llength 123 +} 1 +test listobj-6.5 {Tcl_ListObjLength, error converting from non-list} { + list [catch {llength "a b c \{"} msg] $msg +} {1 {unmatched open brace in list}} +test listobj-6.6 {Tcl_ListObjLength, error converting from non-list} { + list [catch {llength "a {b}c"} msg] $msg +} {1 {list element in braces followed by "c" instead of space}} + +test listobj-7.1 {Tcl_ListObjReplace, conversion from non-list} { + lreplace 123 0 0 x +} {x} +test listobj-7.2 {Tcl_ListObjReplace, error converting from non-list} { + list [catch {lreplace "a b c \{" 1 1 x} msg] $msg +} {1 {unmatched open brace in list}} +test listobj-7.3 {Tcl_ListObjReplace, error converting from non-list} { + list [catch {lreplace "a {b}c" 1 2 x} msg] $msg +} {1 {list element in braces followed by "c" instead of space}} +test listobj-7.4 {Tcl_ListObjReplace, negative first element index} { + lreplace {1 2 3 4 5} -1 1 a +} {a 3 4 5} +test listobj-7.5 {Tcl_ListObjReplace, last element index >= num elems} { + lreplace {1 2 3 4 5} 3 7 a b c +} {1 2 3 a b c} +test listobj-7.6 {Tcl_ListObjReplace, first element index > last index} { + lreplace {1 2 3 4 5} 3 1 a b c +} {1 2 3 a b c 4 5} +test listobj-7.7 {Tcl_ListObjReplace, no new elements} { + lreplace {1 2 3 4 5} 1 1 +} {1 3 4 5} +test listobj-7.8 {Tcl_ListObjReplace, shrink array in place} { + lreplace {1 2 3 4 5 6 7} 4 5 +} {1 2 3 4 7} +test listobj-7.9 {Tcl_ListObjReplace, grow array in place} { + lreplace {1 2 3 4 5 6 7} 1 3 a b c d e +} {1 a b c d e 5 6 7} +test listobj-7.10 {Tcl_ListObjReplace, replace tail of array} { + lreplace {1 2 3 4 5 6 7} 3 6 a +} {1 2 3 a} +test listobj-7.11 {Tcl_ListObjReplace, must grow internal array} { + lreplace {1 2 3 4 5} 2 3 a b c d e f g h i j k l +} {1 2 a b c d e f g h i j k l 5} +test listobj-7.12 {Tcl_ListObjReplace, grow array, insert at start} { + lreplace {1 2 3 4 5} -1 -1 a b c d e f g h i j k l +} {a b c d e f g h i j k l 1 2 3 4 5} +test listobj-7.13 {Tcl_ListObjReplace, grow array, insert at end} { + lreplace {1 2 3 4 5} 4 1 a b c d e f g h i j k l +} {1 2 3 4 a b c d e f g h i j k l 5} + +test listobj-8.1 {SetListFromAny} { + lindex {0 foo\x00help 2} 1 +} "foo\x00help" + +test listobj-9.1 {UpdateStringOfList} { + string length [list foo\x00help] +} 8 diff --git a/contrib/tcl/tests/load.test b/contrib/tcl/tests/load.test index 331e3b7a47353..5c33677404ab2 100644 --- a/contrib/tcl/tests/load.test +++ b/contrib/tcl/tests/load.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: %Z% %M% %I% %E% %U% +# SCCS: @(#) load.test 1.19 96/11/30 16:05:18 if {[string compare test [info procs test]] == 1} then {source defs} @@ -27,11 +27,13 @@ if ![file readable [file join $testDir pkga$ext]] { return } -if [string match *pkga* [info loaded]] { +if [string match *pkga* [set alreadyLoaded [info loaded {}]]] { puts "load tests have already been run once: skipping (can't rerun)" return } +set alreadyTotalLoaded [info loaded] + test load-1.1 {basic errors} { list [catch {load} msg] $msg } {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}} @@ -74,8 +76,6 @@ test load-3.1 {error in _Init procedure, same interpreter} { while executing "open non_existent" invoked from within -"if 44 {open non_existent}" - invoked from within "load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} test load-3.2 {error in _Init procedure, slave interpreter} { catch {interp delete x} @@ -90,8 +90,6 @@ test load-3.2 {error in _Init procedure, slave interpreter} { while executing "open non_existent" invoked from within -"if 44 {open non_existent}" - invoked from within "load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}} test load-4.1 {reloading package into same interpreter} { @@ -101,47 +99,62 @@ test load-4.2 {reloading package into same interpreter} { list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg } "1 {file \"[file join $testDir pkga$ext\"] is already loaded for package \"Pkga\"}" +test load-5.1 {file name not specified and no static package: pick default} { + catch {interp delete x} + interp create x + load [file join $testDir pkga$ext] pkga + load {} pkga x + set result [info loaded x] + interp delete x + set result +} "{[file join $testDir pkga$ext] Pkga}" + # On some platforms, like SunOS 4.1.3, these tests can't be run because # they cause the process to exit. -test load-5.1 {errors loading file} {nonPortable} { +test load-6.1 {errors loading file} {nonPortable} { catch {load foo foo} } {1} if {[info command teststaticpkg] != ""} { - test load-6.1 {Tcl_StaticPackage procedure, static packages} { + test load-7.1 {Tcl_StaticPackage procedure} { set x "not loaded" teststaticpkg Test 1 0 load {} Test load {} Test child list [set x] [child eval set x] } {loaded loaded} - test load-6.2 {Tcl_StaticPackage procedure, static packages} { + test load-7.2 {Tcl_StaticPackage procedure} { set x "not loaded" teststaticpkg Another 0 0 load {} Another child eval {set x "not loaded"} list [catch {load {} Another child} msg] $msg [child eval set x] [set x] } {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded} - test load-6.3 {Tcl_StaticPackage procedure, static packages} { + test load-7.3 {Tcl_StaticPackage procedure} { set x "not loaded" teststaticpkg More 0 1 load {} More set x } {not loaded} - - test load-7.1 {TclGetLoadedPackages procedure} { + test load-7.4 {Tcl_StaticPackage procedure, redundant calls} { + teststaticpkg Double 0 1 + teststaticpkg Double 0 1 + info loaded + } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded" + + test load-8.1 {TclGetLoadedPackages procedure} { info loaded - } "{{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} {{} Tcltest}" - test load-7.2 {TclGetLoadedPackages procedure} { + } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded" + test load-8.2 {TclGetLoadedPackages procedure} { list [catch {info loaded gorp} msg] $msg } {1 {couldn't find slave interpreter named "gorp"}} - test load-7.3 {TclGetLoadedPackages procedure} { + test load-8.3 {TclGetLoadedPackages procedure} { list [info loaded {}] [info loaded child] - } "{{{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} {{} Tcltest}} {{{} Test} {[file join $testDir pkgb$ext] Pkgb}}" - test load-7.4 {TclGetLoadedPackages procedure} { + } "{{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyLoaded} {{{} Test} {[file join $testDir pkgb$ext] Pkgb}}" + test load-8.4 {TclGetLoadedPackages procedure} { load [file join $testDir pkgb$ext] pkgb list [info loaded {}] [lsort [info commands pkgb_*]] - } "{{[file join $testDir pkgb$ext] Pkgb} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} {{} Tcltest}} {pkgb_sub pkgb_unsafe}" + } "{{[file join $testDir pkgb$ext] Pkgb} {{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyLoaded} {pkgb_sub pkgb_unsafe}" interp delete child } diff --git a/contrib/tcl/tests/lrange.test b/contrib/tcl/tests/lrange.test index 91f443936bb8a..32fbbaa38898d 100644 --- a/contrib/tcl/tests/lrange.test +++ b/contrib/tcl/tests/lrange.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) lrange.test 1.6 96/07/10 17:16:47 +# SCCS: @(#) lrange.test 1.12 97/06/23 18:19:25 if {[string compare test [info procs test]] == 1} then {source defs} @@ -43,7 +43,7 @@ test lrange-1.9 {range of list elements} { } {a b c d e} test lrange-1.10 {range of list elements} { lrange "a b\{c d" 1 2 -} "b\{c d" +} "b\\{c d" test lrange-1.11 {range of list elements} { lrange "a b c d" end end } d @@ -56,9 +56,12 @@ test lrange-1.13 {range of list elements} { test lrange-1.14 {range of list elements} { lrange "a b c d" end 2 } {} -test lrange-1.14 {range of list elements} { +test lrange-1.15 {range of list elements} { concat \"[lrange {a b \{\ } 0 2]" } {"a b \{\ "} +test lrange-1.16 {list element quoting} { + lrange {[append a .b]} 0 end +} {{[append} a .b\]} test lrange-2.1 {error conditions} { list [catch {lrange a b} msg] $msg @@ -68,10 +71,10 @@ test lrange-2.2 {error conditions} { } {1 {wrong # args: should be "lrange list first last"}} test lrange-2.3 {error conditions} { list [catch {lrange a b 6} msg] $msg -} {1 {expected integer but got "b"}} +} {1 {bad index "b": must be integer or "end"}} test lrange-2.4 {error conditions} { list [catch {lrange a 0 enigma} msg] $msg -} {1 {expected integer or "end" but got "enigma"}} +} {1 {bad index "enigma": must be integer or "end"}} test lrange-2.5 {error conditions} { list [catch {lrange "a \{b c" 3 4} msg] $msg } {1 {unmatched open brace in list}} diff --git a/contrib/tcl/tests/lreplace.test b/contrib/tcl/tests/lreplace.test index 75cddb213418e..197084e7bd211 100644 --- a/contrib/tcl/tests/lreplace.test +++ b/contrib/tcl/tests/lreplace.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) lreplace.test 1.13 96/07/10 17:16:47 +# SCCS: @(#) lreplace.test 1.15 96/12/16 21:43:57 if {[string compare test [info procs test]] == 1} then {source defs} @@ -58,7 +58,7 @@ test lreplace-1.14 {lreplace command} { } {a b c} test lreplace-1.15 {lreplace command} { lreplace {a b "c c" d e f} 3 3 -} {a b "c c" e f} +} {a b {c c} e f} test lreplace-1.16 {lreplace command} { lreplace { 1 2 3 4 5} 0 0 a } {a 2 3 4 5} @@ -112,3 +112,11 @@ test lreplace-2.6 {lreplace errors} { test lreplace-2.7 {lreplace errors} { list [catch {lreplace x 1 1} msg] $msg } {1 {list doesn't contain element 1}} + +test lreplace-3.1 {lreplace won't modify shared argument objects} { + proc p {} { + lreplace "a b c" 1 1 "x y" + return "a b c" + } + p +} "a b c" diff --git a/contrib/tcl/tests/lsearch.test b/contrib/tcl/tests/lsearch.test index 95df87207d242..4eda84ba1b6da 100644 --- a/contrib/tcl/tests/lsearch.test +++ b/contrib/tcl/tests/lsearch.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) lsearch.test 1.5 96/02/16 08:56:15 +# SCCS: @(#) lsearch.test 1.7 97/04/30 13:23:53 if {[string compare test [info procs test]] == 1} then {source defs} @@ -35,18 +35,27 @@ test lsearch-2.2 {search modes} { lsearch -exact {b.x ^bc xy bcx} ^bc } 1 test lsearch-2.3 {search modes} { + lsearch -exact {foo bar cat} ba +} -1 +test lsearch-2.4 {search modes} { + lsearch -exact {foo bar cat} bart +} -1 +test lsearch-2.5 {search modes} { + lsearch -exact {foo bar cat} bar +} 1 +test lsearch-2.6 {search modes} { list [catch {lsearch -regexp {xyz bbcc *bc*} *bc*} msg] $msg } {1 {couldn't compile regular expression pattern: ?+* follows nothing}} -test lsearch-2.4 {search modes} { +test lsearch-2.7 {search modes} { lsearch -regexp {b.x ^bc xy bcx} ^bc } 3 -test lsearch-2.5 {search modes} { +test lsearch-2.8 {search modes} { lsearch -glob {xyz bbcc *bc*} *bc* } 1 -test lsearch-2.6 {search modes} { +test lsearch-2.9 {search modes} { lsearch -glob {b.x ^bc xy bcx} ^bc } 1 -test lsearch-2.7 {search modes} { +test lsearch-2.10 {search modes} { list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg } {1 {bad search mode "-glib": must be -exact, -glob, or -regexp}} @@ -65,3 +74,13 @@ test lsearch-3.4 {lsearch errors} { test lsearch-3.5 {lsearch errors} { list [catch {lsearch "\{" b} msg] $msg } {1 {unmatched open brace in list}} + +test lsearch-4.1 {binary data} { + lsearch -exact [list foo one\000two bar] bar +} 2 +test lsearch-4.2 {binary data} { + set x one + append x \x00 + append x two + lsearch -exact [list foo one\000two bar] $x +} 1 diff --git a/contrib/tcl/tests/macFCmd.test b/contrib/tcl/tests/macFCmd.test new file mode 100644 index 0000000000000..a06004c163606 --- /dev/null +++ b/contrib/tcl/tests/macFCmd.test @@ -0,0 +1,168 @@ +# This file tests the tclfCmd.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 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. +# +# SCCS: @(#) macFCmd.test 1.3 97/06/23 18:24:10 +# + +if {$tcl_platform(platform) != "macintosh"} { + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {file delete -force foo.dir} +file mkdir foo.dir +if {[catch {file attributes foo.dir -readonly 1}]} { + set testConfig(fileSharing) 0 + set testConfig(notFileSharing) 1 +} else { + set testConfig(fileSharing) 1 + set testConfig(notFileSharing) 0 +} +file delete -force foo.dir + +test macFCmd-1.1 {GetFileFinderAttributes - no file} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -creator} msg] $msg +} {1 {couldn't get attributes for file ":foo.file": no such file or directory}} +test macFCmd-1.2 {GetFileFinderAttributes - creator} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + list [catch {file attributes foo.file -creator} msg] $msg [file delete -force foo.file] +} {0 {MPW } {}} +test macFCmd-1.3 {GetFileFinderAttributes - type} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + list [catch {file attributes foo.file -type} msg] $msg [file delete -force foo.file] +} {0 TEXT {}} +test macFCmd-1.4 {GetFileFinderAttributes - not hidden} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + list [catch {file attributes foo.file -hidden} msg] $msg [file delete -force foo.file] +} {0 0 {}} +test macFCmd-1.5 {GetFileFinderAttributes - hidden} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + file attributes foo.file -hidden 1 + list [catch {file attributes foo.file -hidden} msg] $msg [file delete -force foo.file] +} {0 1 {}} +test macFCmd-1.6 {GetFileFinderAttributes - folder creator} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -creator} msg] $msg [file delete -force foo.dir] +} {0 Fldr {}} +test macFCmd-1.7 {GetFileFinderAttributes - folder type} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -type} msg] $msg [file delete -force foo.dir] +} {0 Fldr {}} +test macFCmd-1.8 {GetFileFinderAttributes - folder hidden} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -hidden} msg] $msg [file delete -force foo.dir] +} {0 0 {}} + +test macFCmd-2.1 {GetFileReadOnly - bad file} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -readonly} msg] $msg +} {1 {couldn't get attributes for file ":foo.file": no such file or directory}} +test macFCmd-2.2 {GetFileReadOnly - file not read only} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -readonly} msg] $msg [file delete -force foo.file] +} {0 0 {}} +test macFCmd-2.3 {GetFileReadOnly - file read only} { + catch {file delete -force foo.file} + close [open foo.file w] + file attributes foo.file -readonly 1 + list [catch {file attributes foo.file -readonly} msg] $msg [file delete -force foo.file] +} {0 1 {}} +test macFCmd-2.4 {GetFileReadOnly - directory not read only} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly} msg] $msg [file delete -force foo.dir] +} {0 0 {}} +test macFCmd-2.5 {GetFileReadOnly - directory read only} {fileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + file attributes foo.dir -readonly 1 + list [catch {file attributes foo.dir -readonly} msg] $msg [file delete -force foo.dir] +} {0 1 {}} + +test macFCmd-3.1 {SetFileFinderAttributes - bad file} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -creator FOOO} msg] $msg +} {1 {couldn't set attributes for file ":foo.file": no such file or directory}} +test macFCmd-3.2 {SetFileFinderAttributes - creator} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -creator FOOO} msg] $msg [file attributes foo.file -creator] [file delete -force foo.file] +} {0 {} FOOO {}} +test macFCmd-3.3 {SetFileFinderAttributes - bad creator} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -creator 0} msg] $msg [file delete -force foo.file] +} {1 {expected Macintosh OS type but got "0"} {}} +test macFCmd-3.4 {SetFileFinderAttributes - hidden} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -hidden 1} msg] $msg [file attributes foo.file -hidden] [file delete -force foo.file] +} {0 {} 1 {}} +test macFCmd-3.5 {SetFileFinderAttributes - type} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -type FOOO} msg] $msg [file attributes foo.file -type] [file delete -force foo.file] +} {0 {} FOOO {}} +test macFCmd-3.6 {SetFileFinderAttributes - bad type} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -type 0} msg] $msg [file delete -force foo.file] +} {1 {expected Macintosh OS type but got "0"} {}} +test macFCmd-3.7 {SetFileFinderAttributes - directory} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -creator FOOO} msg] $msg [file delete -force foo.dir] +} {1 {cannot set -creator: ":foo.dir" is a directory} {}} + +test macFCmd-4.1 {SetFileReadOnly - bad file} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -readonly 1} msg] $msg +} {1 {couldn't set attributes for file ":foo.file": no such file or directory}} +test macFCmd-4.2 {SetFileReadOnly - file not readonly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -readonly 0} msg] $msg [file attributes foo.file -readonly] [file delete -force foo.file] +} {0 {} 0 {}} +test macFCmd-4.3 {SetFileReadOnly - file readonly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -readonly 1} msg] $msg [file attributes foo.file -readonly] [file delete -force foo.file] +} {0 {} 1 {}} +test macFCmd-4.4 {SetFileReadOnly - directory not readonly} {fileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 0} msg] $msg [file attributes foo.dir -readonly] [file delete -force foo.dir] +} {0 {} 0 {}} +test macFCmd-4.5 {SetFileReadOnly - directory not readonly} {notFileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 0} msg] $msg [file delete -force foo.dir] +} {1 {cannot set a directory to read-only when File Sharing is turned off} {}} +test macFCmd-4.6 {SetFileReadOnly - directory readonly} {fileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 1} msg] $msg [file attributes foo.dir -readonly] [file delete -force foo.dir] +} {0 {} 1 {}} +test macFCmd-4.7 {SetFileReadOnly - directory readonly} {notFileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 1} msg] $msg [file delete -force foo.dir] +} {1 {cannot set a directory to read-only when File Sharing is turned off} {}} diff --git a/contrib/tcl/tests/misc.test b/contrib/tcl/tests/misc.test index b53759d1cc791..59292064ce713 100644 --- a/contrib/tcl/tests/misc.test +++ b/contrib/tcl/tests/misc.test @@ -6,12 +6,12 @@ # releases. # # Copyright (c) 1992-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) misc.test 1.5 96/02/16 08:56:18 +# SCCS: @(#) misc.test 1.11 97/06/20 16:53:28 if {[string compare test [info procs test]] == 1} then {source defs} @@ -48,23 +48,10 @@ test misc-1.2 {error in variable ref. in command in array reference} { " set msg {} list [catch tstProc msg] $msg $errorInfo -} [list 1 {missing close-brace for variable name} \ -[format {missing close-brace for variable name - while executing -"winfo name $%szz) - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a bogus commen ..." - (parsing index for array "a") - invoked from within -"set tst $a([winfo name $%szz) - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a ..." - (procedure "tstProc" line 4) +} [list 1 {missing close-bracket or close-brace} \ +{missing close-bracket or close-brace + while compiling +"set" + (compiling body of proc "tstProc", line 4) invoked from within -"tstProc"} \{ \{]] +"tstProc"}] diff --git a/contrib/tcl/tests/namespace-old.test b/contrib/tcl/tests/namespace-old.test new file mode 100644 index 0000000000000..f743722198ff7 --- /dev/null +++ b/contrib/tcl/tests/namespace-old.test @@ -0,0 +1,844 @@ +# Functionality covered: this file contains slightly modified versions of +# the original tests written by Mike McLennan of Lucent Technologies for +# the procedures in tclNamesp.c that implement Tcl's basic support for +# namespaces. Other namespace-related tests appear in namespace.test +# and variable.test. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1997 Lucent Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) namespace-old.test 1.5 97/06/20 14:51:17 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Clear out any namespaces called test_ns_* +catch {eval namespace delete [namespace children :: test_ns_*]} + +test namespace-old-1.1 {usage for "namespace" command} { + list [catch {namespace} msg] $msg +} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}} + +test namespace-old-1.2 {global namespace's name is "::" or {}} { + list [namespace current] [namespace eval {} {namespace current}] +} {:: ::} + +test namespace-old-1.3 {usage for "namespace eval"} { + list [catch {namespace eval} msg] $msg +} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}} + +test namespace-old-1.4 {create new namespaces} { + list [lsort [namespace children :: test_ns_simple*]] \ + [namespace eval test_ns_simple {}] \ + [namespace eval test_ns_simple2 {}] \ + [lsort [namespace children :: test_ns_simple*]] +} {{} {} {} {::test_ns_simple ::test_ns_simple2}} + +test namespace-old-1.5 {access a new namespace} { + namespace eval test_ns_simple { namespace current } +} {::test_ns_simple} + +test namespace-old-1.6 {usage for "namespace eval"} { + list [catch {namespace eval} msg] $msg +} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}} + +test namespace-old-1.7 {usage for "namespace eval"} { + list [catch {namespace eval test_ns_xyzzy} msg] $msg +} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}} + +test namespace-old-1.8 {command "namespace eval" concatenates args} { + namespace eval test_ns_simple namespace current +} {::test_ns_simple} + +test namespace-old-1.9 {add elements to a namespace} { + namespace eval test_ns_simple { + variable test_ns_x 0 + proc test {test_ns_x} { + return "test: $test_ns_x" + } + } +} {} + +test namespace-old-1.10 {commands in a namespace} { + namespace eval test_ns_simple { info commands [namespace current]::*} +} {::test_ns_simple::test} + +test namespace-old-1.11 {variables in a namespace} { + namespace eval test_ns_simple { info vars [namespace current]::* } +} {::test_ns_simple::test_ns_x} + +test namespace-old-1.12 {global vars are separate from locals vars} { + list [test_ns_simple::test 123] [set test_ns_simple::test_ns_x] +} {{test: 123} 0} + +test namespace-old-1.13 {add to an existing namespace} { + namespace eval test_ns_simple { + variable test_ns_y 123 + proc _backdoor {cmd} { + eval $cmd + } + } +} "" + +test namespace-old-1.14 {commands in a namespace} { + lsort [namespace eval test_ns_simple {info commands [namespace current]::*}] +} {::test_ns_simple::_backdoor ::test_ns_simple::test} + +test namespace-old-1.15 {variables in a namespace} { + lsort [namespace eval test_ns_simple {info vars [namespace current]::*}] +} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y} +test namespace-old-1.16 {variables in a namespace} { + lsort [info vars test_ns_simple::*] +} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y} + +test namespace-old-1.17 {commands in a namespace are hidden} { + list [catch "_backdoor {return yes!}" msg] $msg +} {1 {invalid command name "_backdoor"}} +test namespace-old-1.18 {using namespace qualifiers} { + list [catch "test_ns_simple::_backdoor {return yes!}" msg] $msg +} {0 yes!} +test namespace-old-1.19 {using absolute namespace qualifiers} { + list [catch "::test_ns_simple::_backdoor {return yes!}" msg] $msg +} {0 yes!} + +test namespace-old-1.20 {variables in a namespace are hidden} { + list [catch "set test_ns_x" msg] $msg [catch "set test_ns_y" msg] $msg +} {1 {can't read "test_ns_x": no such variable} 1 {can't read "test_ns_y": no such variable}} +test namespace-old-1.21 {using namespace qualifiers} { + list [catch "set test_ns_simple::test_ns_x" msg] $msg \ + [catch "set test_ns_simple::test_ns_y" msg] $msg +} {0 0 0 123} +test namespace-old-1.22 {using absolute namespace qualifiers} { + list [catch "set ::test_ns_simple::test_ns_x" msg] $msg \ + [catch "set ::test_ns_simple::test_ns_y" msg] $msg +} {0 0 0 123} +test namespace-old-1.23 {variables can be accessed within a namespace} { + test_ns_simple::_backdoor { + variable test_ns_x + variable test_ns_y + return "$test_ns_x $test_ns_y" + } +} {0 123} + +test namespace-old-1.24 {setting global variables} { + test_ns_simple::_backdoor {variable test_ns_x; set test_ns_x "new val"} + namespace eval test_ns_simple {set test_ns_x} +} {new val} + +test namespace-old-1.25 {qualified variables don't need a global declaration} { + namespace eval test_ns_another { variable test_ns_x 456 } + set cmd {set ::test_ns_another::test_ns_x} + list [catch {test_ns_simple::_backdoor "$cmd some-value"} msg] $msg \ + [eval $cmd] +} {0 some-value some-value} + +test namespace-old-1.26 {namespace qualifiers are okay after $'s} { + namespace eval test_ns_simple { set test_ns_x 12; set test_ns_y 34 } + set cmd {list $::test_ns_simple::test_ns_x $::test_ns_simple::test_ns_y} + list [test_ns_simple::_backdoor $cmd] [eval $cmd] +} {{12 34} {12 34}} + +test namespace-old-1.27 {can create commands with null names} { + proc test_ns_simple:: {args} {return $args} +} {} + +# ----------------------------------------------------------------------- +# TEST: using "info" in namespace contexts +# ----------------------------------------------------------------------- +test namespace-old-2.1 {querying: info commands} { + lsort [test_ns_simple::_backdoor {info commands [namespace current]::*}] +} {::test_ns_simple:: ::test_ns_simple::_backdoor ::test_ns_simple::test} + +test namespace-old-2.2 {querying: info procs} { + lsort [test_ns_simple::_backdoor {info procs}] +} {{} _backdoor test} + +test namespace-old-2.3 {querying: info vars} { + lsort [info vars test_ns_simple::*] +} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y} + +test namespace-old-2.4 {querying: info vars} { + lsort [test_ns_simple::_backdoor {info vars [namespace current]::*}] +} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y} + +test namespace-old-2.5 {querying: info locals} { + lsort [test_ns_simple::_backdoor {info locals}] +} {cmd} + +test namespace-old-2.6 {querying: info exists} { + test_ns_simple::_backdoor {info exists test_ns_x} +} {0} + +test namespace-old-2.7 {querying: info exists} { + test_ns_simple::_backdoor {info exists cmd} +} {1} + +test namespace-old-2.8 {querying: info args} { + info args test_ns_simple::_backdoor +} {cmd} + +test namespace-old-2.9 {querying: info body} { + string trim [info body test_ns_simple::test] +} {return "test: $test_ns_x"} + +# ----------------------------------------------------------------------- +# TEST: namespace qualifiers, namespace tail +# ----------------------------------------------------------------------- +test namespace-old-3.1 {usage for "namespace qualifiers"} { + list [catch "namespace qualifiers" msg] $msg +} {1 {wrong # args: should be "namespace qualifiers string"}} + +test namespace-old-3.2 {querying: namespace qualifiers} { + list [namespace qualifiers ""] \ + [namespace qualifiers ::] \ + [namespace qualifiers x] \ + [namespace qualifiers ::x] \ + [namespace qualifiers foo::x] \ + [namespace qualifiers ::foo::bar::xyz] +} {{} {} {} {} foo ::foo::bar} + +test namespace-old-3.3 {usage for "namespace tail"} { + list [catch "namespace tail" msg] $msg +} {1 {wrong # args: should be "namespace tail string"}} + +test namespace-old-3.4 {querying: namespace tail} { + list [namespace tail ""] \ + [namespace tail ::] \ + [namespace tail x] \ + [namespace tail ::x] \ + [namespace tail foo::x] \ + [namespace tail ::foo::bar::xyz] +} {{} {} x x x xyz} + +# ----------------------------------------------------------------------- +# TEST: delete commands and namespaces +# ----------------------------------------------------------------------- +test namespace-old-4.1 {define test namespaces} { + namespace eval test_ns_delete { + namespace eval ns1 { + variable var1 1 + proc cmd1 {} {return "cmd1"} + } + namespace eval ns2 { + variable var2 2 + proc cmd2 {} {return "cmd2"} + } + namespace eval another {} + lsort [namespace children] + } +} {::test_ns_delete::another ::test_ns_delete::ns1 ::test_ns_delete::ns2} + +test namespace-old-4.2 {it's okay to invoke "namespace delete" with no args} { + list [catch {namespace delete} msg] $msg +} {0 {}} + +test namespace-old-4.3 {command "namespace delete" doesn't support patterns} { + set cmd { + namespace eval test_ns_delete {namespace delete ns*} + } + list [catch $cmd msg] $msg +} {1 {unknown namespace "ns*" in namespace delete command}} + +test namespace-old-4.4 {command "namespace delete" handles multiple args} { + set cmd { + namespace eval test_ns_delete { + eval namespace delete \ + [namespace children [namespace current] ns?] + } + } + list [catch $cmd msg] $msg [namespace children test_ns_delete] +} {0 {} ::test_ns_delete::another} + +# ----------------------------------------------------------------------- +# TEST: namespace hierarchy +# ----------------------------------------------------------------------- +test namespace-old-5.1 {define nested namespaces} { + set test_ns_var_global "var in ::" + proc test_ns_cmd_global {} {return "cmd in ::"} + + namespace eval test_ns_hier1 { + set test_ns_var_hier1 "particular to hier1" + proc test_ns_cmd_hier1 {} {return "particular to hier1"} + + set test_ns_level 1 + proc test_ns_show {} {return "[namespace current]: 1"} + + namespace eval test_ns_hier2 { + set test_ns_var_hier2 "particular to hier2" + proc test_ns_cmd_hier2 {} {return "particular to hier2"} + + set test_ns_level 2 + proc test_ns_show {} {return "[namespace current]: 2"} + + namespace eval test_ns_hier3a {} + namespace eval test_ns_hier3b {} + } + + namespace eval test_ns_hier2a {} + namespace eval test_ns_hier2b {} + } +} {} + +test namespace-old-5.2 {namespaces can be nested} { + list [namespace eval test_ns_hier1 {namespace current}] \ + [namespace eval test_ns_hier1 { + namespace eval test_ns_hier2 {namespace current} + }] +} {::test_ns_hier1 ::test_ns_hier1::test_ns_hier2} + +test namespace-old-5.3 {namespace qualifiers work in namespace command} { + list [namespace eval ::test_ns_hier1 {namespace current}] \ + [namespace eval test_ns_hier1::test_ns_hier2 {namespace current}] \ + [namespace eval ::test_ns_hier1::test_ns_hier2 {namespace current}] +} {::test_ns_hier1 ::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2} + +test namespace-old-5.4 {nested namespaces can access global namespace} { + list [namespace eval test_ns_hier1 {set test_ns_var_global}] \ + [namespace eval test_ns_hier1 {test_ns_cmd_global}] \ + [namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_global}] \ + [namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_global}] +} {{var in ::} {cmd in ::} {var in ::} {cmd in ::}} + +test namespace-old-5.5 {variables in different namespaces don't conflict} { + list [set test_ns_hier1::test_ns_level] \ + [set test_ns_hier1::test_ns_hier2::test_ns_level] +} {1 2} + +test namespace-old-5.6 {commands in different namespaces don't conflict} { + list [test_ns_hier1::test_ns_show] \ + [test_ns_hier1::test_ns_hier2::test_ns_show] +} {{::test_ns_hier1: 1} {::test_ns_hier1::test_ns_hier2: 2}} + +test namespace-old-5.7 {nested namespaces don't see variables in parent} { + set cmd { + namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_hier1} + } + list [catch $cmd msg] $msg +} {1 {can't read "test_ns_var_hier1": no such variable}} + +test namespace-old-5.8 {nested namespaces don't see commands in parent} { + set cmd { + namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_hier1} + } + list [catch $cmd msg] $msg +} {1 {invalid command name "test_ns_cmd_hier1"}} + +test namespace-old-5.9 {usage for "namespace children"} { + list [catch {namespace children test_ns_hier1 y z} msg] $msg +} {1 {wrong # args: should be "namespace children ?name? ?pattern?"}} + +test namespace-old-5.10 {command "namespace children" must get valid namespace} { + list [catch {namespace children xyzzy} msg] $msg +} {1 {unknown namespace "xyzzy" in namespace children command}} + +test namespace-old-5.11 {querying namespace children} { + lsort [namespace children :: test_ns_hier*] +} {::test_ns_hier1} + +test namespace-old-5.12 {querying namespace children} { + lsort [namespace children test_ns_hier1] +} {::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2a ::test_ns_hier1::test_ns_hier2b} + +test namespace-old-5.13 {querying namespace children} { + lsort [namespace eval test_ns_hier1 {namespace children}] +} {::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2a ::test_ns_hier1::test_ns_hier2b} + +test namespace-old-5.14 {querying namespace children} { + lsort [namespace children test_ns_hier1::test_ns_hier2] +} {::test_ns_hier1::test_ns_hier2::test_ns_hier3a ::test_ns_hier1::test_ns_hier2::test_ns_hier3b} + +test namespace-old-5.15 {querying namespace children} { + lsort [namespace eval test_ns_hier1::test_ns_hier2 {namespace children}] +} {::test_ns_hier1::test_ns_hier2::test_ns_hier3a ::test_ns_hier1::test_ns_hier2::test_ns_hier3b} + +test namespace-old-5.16 {querying namespace children with patterns} { + lsort [namespace children test_ns_hier1::test_ns_hier2 test_ns_*] +} {::test_ns_hier1::test_ns_hier2::test_ns_hier3a ::test_ns_hier1::test_ns_hier2::test_ns_hier3b} + +test namespace-old-5.17 {querying namespace children with patterns} { + lsort [namespace children test_ns_hier1::test_ns_hier2 *b] +} {::test_ns_hier1::test_ns_hier2::test_ns_hier3b} + +test namespace-old-5.18 {usage for "namespace parent"} { + list [catch {namespace parent x y} msg] $msg +} {1 {wrong # args: should be "namespace parent ?name?"}} + +test namespace-old-5.19 {command "namespace parent" must get valid namespace} { + list [catch {namespace parent xyzzy} msg] $msg +} {1 {unknown namespace "xyzzy" in namespace parent command}} + +test namespace-old-5.20 {querying namespace parent} { + list [namespace eval :: {namespace parent}] \ + [namespace eval test_ns_hier1 {namespace parent}] \ + [namespace eval test_ns_hier1::test_ns_hier2 {namespace parent}] \ + [namespace eval test_ns_hier1::test_ns_hier2::test_ns_hier3a {namespace parent}] \ +} {{} :: ::test_ns_hier1 ::test_ns_hier1::test_ns_hier2} + +test namespace-old-5.21 {querying namespace parent for explicit namespace} { + list [namespace parent ::] \ + [namespace parent test_ns_hier1] \ + [namespace parent test_ns_hier1::test_ns_hier2] \ + [namespace parent test_ns_hier1::test_ns_hier2::test_ns_hier3a] +} {{} :: ::test_ns_hier1 ::test_ns_hier1::test_ns_hier2} + +# ----------------------------------------------------------------------- +# TEST: name resolution and caching +# ----------------------------------------------------------------------- +test namespace-old-6.1 {relative ns names only looked up in current ns} { + namespace eval test_ns_cache1 {} + namespace eval test_ns_cache2 {} + namespace eval test_ns_cache2::test_ns_cache3 {} + set trigger { + namespace eval test_ns_cache2 {namespace current} + } + set trigger2 { + namespace eval test_ns_cache2::test_ns_cache3 {namespace current} + } + list [namespace eval test_ns_cache1 $trigger] \ + [namespace eval test_ns_cache1 $trigger2] +} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} + +test namespace-old-6.2 {relative ns names only looked up in current ns} { + namespace eval test_ns_cache1::test_ns_cache2 {} + list [namespace eval test_ns_cache1 $trigger] \ + [namespace eval test_ns_cache1 $trigger2] +} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} + +test namespace-old-6.3 {relative ns names only looked up in current ns} { + namespace eval test_ns_cache1::test_ns_cache2::test_ns_cache3 {} + list [namespace eval test_ns_cache1 $trigger] \ + [namespace eval test_ns_cache1 $trigger2] +} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} + +test namespace-old-6.4 {relative ns names only looked up in current ns} { + namespace delete test_ns_cache1::test_ns_cache2 + list [namespace eval test_ns_cache1 $trigger] \ + [namespace eval test_ns_cache1 $trigger2] +} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} + +test namespace-old-6.5 {define test commands} { + proc test_ns_cache_cmd {} { + return "global version" + } + namespace eval test_ns_cache1 { + proc trigger {} { + test_ns_cache_cmd + } + } + test_ns_cache1::trigger +} {global version} + +test namespace-old-6.6 {one-level check for command shadowing} { + proc test_ns_cache1::test_ns_cache_cmd {} { + return "cache1 version" + } + test_ns_cache1::trigger +} {cache1 version} + +test namespace-old-6.7 {renaming commands changes command epoch} { + namespace eval test_ns_cache1 { + rename test_ns_cache_cmd test_ns_new + } + test_ns_cache1::trigger +} {global version} + +test namespace-old-6.8 {renaming back handles shadowing} { + namespace eval test_ns_cache1 { + rename test_ns_new test_ns_cache_cmd + } + test_ns_cache1::trigger +} {cache1 version} + +test namespace-old-6.9 {deleting commands changes command epoch} { + namespace eval test_ns_cache1 { + rename test_ns_cache_cmd "" + } + test_ns_cache1::trigger +} {global version} + +test namespace-old-6.10 {define test namespaces} { + namespace eval test_ns_cache2 { + proc test_ns_cache_cmd {} { + return "global cache2 version" + } + } + namespace eval test_ns_cache1 { + proc trigger {} { + test_ns_cache2::test_ns_cache_cmd + } + } + namespace eval test_ns_cache1::test_ns_cache2 { + proc trigger {} { + test_ns_cache_cmd + } + } + list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger] +} {{global cache2 version} {global version}} + +test namespace-old-6.11 {commands affect all parent namespaces} { + proc test_ns_cache1::test_ns_cache2::test_ns_cache_cmd {} { + return "cache2 version" + } + list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger] +} {{cache2 version} {cache2 version}} + +test namespace-old-6.12 {define test variables} { + variable test_ns_cache_var "global version" + set trigger {set test_ns_cache_var} + namespace eval test_ns_cache1 $trigger +} {global version} + +test namespace-old-6.13 {one-level check for variable shadowing} { + namespace eval test_ns_cache1 { + variable test_ns_cache_var "cache1 version" + } + namespace eval test_ns_cache1 $trigger +} {cache1 version} + +test namespace-old-6.14 {deleting variables changes variable epoch} { + namespace eval test_ns_cache1 { + unset test_ns_cache_var + } + namespace eval test_ns_cache1 $trigger +} {global version} + +test namespace-old-6.15 {define test namespaces} { + namespace eval test_ns_cache2 { + variable test_ns_cache_var "global cache2 version" + } + set trigger2 {set test_ns_cache2::test_ns_cache_var} + list [namespace eval test_ns_cache1 $trigger2] \ + [namespace eval test_ns_cache1::test_ns_cache2 $trigger] +} {{global cache2 version} {global version}} + +test namespace-old-6.16 {public variables affect all parent namespaces} { + variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version" + list [namespace eval test_ns_cache1 $trigger2] \ + [namespace eval test_ns_cache1::test_ns_cache2 $trigger] +} {{cache2 version} {cache2 version}} + +test namespace-old-6.17 {usage for "namespace which"} { + list [catch "namespace which -baz" msg] $msg +} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} +test namespace-old-6.18 {usage for "namespace which"} { + list [catch "namespace which -command" msg] $msg +} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} + +test namespace-old-6.19 {querying: namespace which -command} { + proc test_ns_cache1::test_ns_cache_cmd {} { + return "cache1 version" + } + list [namespace eval :: {namespace which test_ns_cache_cmd}] \ + [namespace eval test_ns_cache1 {namespace which test_ns_cache_cmd}] \ + [namespace eval :: {namespace which -command test_ns_cache_cmd}] \ + [namespace eval test_ns_cache1 {namespace which -command test_ns_cache_cmd}] +} {::test_ns_cache_cmd ::test_ns_cache1::test_ns_cache_cmd ::test_ns_cache_cmd ::test_ns_cache1::test_ns_cache_cmd} + +test namespace-old-6.20 {command "namespace which" may not find commands} { + namespace eval test_ns_cache1 {namespace which -command xyzzy} +} {} + +test namespace-old-6.21 {querying: namespace which -variable} { + namespace eval test_ns_cache1::test_ns_cache2 { + namespace which -variable test_ns_cache_var + } +} {::test_ns_cache1::test_ns_cache2::test_ns_cache_var} + +test namespace-old-6.22 {command "namespace which" may not find variables} { + namespace eval test_ns_cache1 {namespace which -variable xyzzy} +} {} + +# ----------------------------------------------------------------------- +# TEST: uplevel/upvar across namespace boundaries +# ----------------------------------------------------------------------- +test namespace-old-7.1 {define test namespace} { + namespace eval test_ns_uplevel { + variable x 0 + variable y 1 + + proc show_vars {num} { + return [uplevel $num {info vars}] + } + proc test_uplevel {num} { + set a 0 + set b 1 + namespace eval ::test_ns_uplevel " return \[show_vars $num\] " + } + } +} {} +test namespace-old-7.2 {uplevel can access namespace call frame} { + list [expr {[lsearch -exact [test_ns_uplevel::test_uplevel 1] x]>=0}] \ + [expr {[lsearch -exact [test_ns_uplevel::test_uplevel 1] y]>=0}] +} {1 1} +test namespace-old-7.3 {uplevel can go beyond namespace call frame} { + lsort [test_ns_uplevel::test_uplevel 2] +} {a b num} +test namespace-old-7.4 {uplevel can go up to global context} { + expr {[test_ns_uplevel::test_uplevel 3] == [info globals]} +} {1} + +test namespace-old-7.5 {absolute call frame references work too} { + list [expr {[lsearch -exact [test_ns_uplevel::test_uplevel #2] x]>=0}] \ + [expr {[lsearch -exact [test_ns_uplevel::test_uplevel #2] y]>=0}] +} {1 1} +test namespace-old-7.6 {absolute call frame references work too} { + lsort [test_ns_uplevel::test_uplevel #1] +} {a b num} +test namespace-old-7.7 {absolute call frame references work too} { + expr {[test_ns_uplevel::test_uplevel #0] == [info globals]} +} {1} + +test namespace-old-7.8 {namespaces are included in the call stack} { + namespace eval test_ns_upvar { + variable scope "test_ns_upvar" + + proc show_val {var num} { + upvar $num $var x + return $x + } + proc test_upvar {num} { + set scope "test_ns_upvar::test_upvar" + namespace eval ::test_ns_upvar " return \[show_val scope $num\] " + } + } +} {} +test namespace-old-7.9 {upvar can access namespace call frame} { + test_ns_upvar::test_upvar 1 +} {test_ns_upvar} +test namespace-old-7.10 {upvar can go beyond namespace call frame} { + test_ns_upvar::test_upvar 2 +} {test_ns_upvar::test_upvar} +test namespace-old-7.11 {absolute call frame references work too} { + test_ns_upvar::test_upvar #2 +} {test_ns_upvar} +test namespace-old-7.12 {absolute call frame references work too} { + test_ns_upvar::test_upvar #1 +} {test_ns_upvar::test_upvar} + +# ----------------------------------------------------------------------- +# TEST: variable traces across namespace boundaries +# ----------------------------------------------------------------------- +test namespace-old-8.1 {traces work across namespace boundaries} { + namespace eval test_ns_trace { + namespace eval foo { + variable x "" + } + + variable status "" + proc monitor {name1 name2 op} { + variable status + lappend status "$op: $name1" + } + trace variable foo::x rwu [namespace code monitor] + } + set test_ns_trace::foo::x "yes!" + set test_ns_trace::foo::x + unset test_ns_trace::foo::x + + namespace eval test_ns_trace { set status } +} {{w: test_ns_trace::foo::x} {r: test_ns_trace::foo::x} {u: test_ns_trace::foo::x}} + +# ----------------------------------------------------------------------- +# TEST: imported commands +# ----------------------------------------------------------------------- +test namespace-old-9.1 {empty "namespace export" list} { + list [catch "namespace export" msg] $msg +} {0 {}} +test namespace-old-9.2 {usage for "namespace export" command} { + list [catch "namespace export test_ns_trace::zzz" msg] $msg +} {1 {invalid export pattern "test_ns_trace::zzz": pattern can't specify a namespace}} + +test namespace-old-9.3 {define test namespaces for import} { + namespace eval test_ns_export { + namespace export cmd1 cmd2 cmd3 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + proc cmd5 {args} {return "cmd5: $args"} + proc cmd6 {args} {return "cmd6: $args"} + } + lsort [info commands test_ns_export::*] +} {::test_ns_export::cmd1 ::test_ns_export::cmd2 ::test_ns_export::cmd3 ::test_ns_export::cmd4 ::test_ns_export::cmd5 ::test_ns_export::cmd6} + +test namespace-old-9.4 {check export status} { + set x "" + namespace eval test_ns_import { + namespace export cmd1 cmd2 + namespace import ::test_ns_export::* + } + foreach cmd [lsort [info commands test_ns_import::*]] { + lappend x $cmd + } + set x +} {::test_ns_import::cmd1 ::test_ns_import::cmd2 ::test_ns_import::cmd3} + +test namespace-old-9.5 {empty import list in "namespace import" command} { + namespace import +} {} + +test namespace-old-9.6 {empty import list for "namespace import" command} { + namespace import +} {} + +test namespace-old-9.7 {empty forget list for "namespace forget" command} { + namespace forget +} {} + +catch {rename cmd1 {}} +catch {rename cmd2 {}} +catch {rename ncmd {}} +catch {rename ncmd1 {}} +catch {rename ncmd2 {}} +test namespace-old-9.8 {only exported commands are imported} { + namespace import test_ns_import::cmd* + set x [lsort [info commands cmd*]] +} {cmd1 cmd2} + +test namespace-old-9.9 {imported commands work just the same as original} { + list [cmd1 test 1 2 3] [test_ns_import::cmd1 test 4 5 6] +} {{cmd1: test 1 2 3} {cmd1: test 4 5 6}} + +test namespace-old-9.10 {commands can be imported from many namespaces} { + namespace eval test_ns_import2 { + namespace export ncmd ncmd1 ncmd2 + proc ncmd {args} {return "ncmd: $args"} + proc ncmd1 {args} {return "ncmd1: $args"} + proc ncmd2 {args} {return "ncmd2: $args"} + proc ncmd3 {args} {return "ncmd3: $args"} + } + namespace import test_ns_import2::* + lsort [concat [info commands cmd*] [info commands ncmd*]] +} {cmd1 cmd2 ncmd ncmd1 ncmd2} + +test namespace-old-9.11 {imported commands can be removed by deleting them} { + rename cmd1 "" + lsort [concat [info commands cmd*] [info commands ncmd*]] +} {cmd2 ncmd ncmd1 ncmd2} + +test namespace-old-9.12 {command "namespace forget" checks for valid namespaces} { + list [catch {namespace forget xyzzy::*} msg] $msg +} {1 {unknown namespace in namespace forget pattern "xyzzy::*"}} + +test namespace-old-9.13 {command "namespace forget" ignores patterns that don't match} { + list [catch {namespace forget test_ns_import::xy*zzy} msg] $msg \ + [lsort [info commands cmd?]] +} {0 {} cmd2} + +test namespace-old-9.14 {imported commands can be removed} { + namespace forget test_ns_import::cmd? + list [lsort [info commands cmd?]] \ + [catch {cmd1 another test} msg] $msg +} {{} 1 {invalid command name "cmd1"}} + +test namespace-old-9.15 {existing commands can't be overwritten} { + proc cmd1 {x y} { + return [expr $x+$y] + } + list [catch {namespace import test_ns_import::cmd?} msg] $msg \ + [cmd1 3 5] +} {1 {can't import command "cmd1": already exists} 8} + +test namespace-old-9.16 {use "-force" option to override existing commands} { + list [cmd1 3 5] \ + [namespace import -force test_ns_import::cmd?] \ + [cmd1 3 5] +} {8 {} {cmd1: 3 5}} + +test namespace-old-9.17 {commands can be imported into many namespaces} { + namespace eval test_ns_import_use { + namespace import ::test_ns_import::* ::test_ns_import2::ncmd? + lsort [concat [info commands ::test_ns_import_use::cmd*] \ + [info commands ::test_ns_import_use::ncmd*]] + } +} {::test_ns_import_use::cmd1 ::test_ns_import_use::cmd2 ::test_ns_import_use::ncmd1 ::test_ns_import_use::ncmd2} + +test namespace-old-9.18 {when command is deleted, imported commands go away} { + namespace eval test_ns_import { rename cmd1 "" } + list [info commands cmd1] \ + [namespace eval test_ns_import_use {info commands cmd1}] +} {{} {}} + +test namespace-old-9.19 {when namesp is deleted, all imported commands go away} { + namespace delete test_ns_import test_ns_import2 + list [info commands cmd*] \ + [info commands ncmd*] \ + [namespace eval test_ns_import_use {info commands cmd*}] \ + [namespace eval test_ns_import_use {info commands ncmd*}] \ +} {{} {} {} {}} + +# ----------------------------------------------------------------------- +# TEST: scoped values +# ----------------------------------------------------------------------- +test namespace-old-10.1 {define namespace for scope test} { + namespace eval test_ns_inscope { + variable x "x-value" + proc show {args} { + return "show: $args" + } + proc do {args} { + return [eval $args] + } + list [set x] [show test] + } +} {x-value {show: test}} + +test namespace-old-10.2 {command "namespace code" requires one argument} { + list [catch {namespace code} msg] $msg +} {1 {wrong # args: should be "namespace code arg"}} + +test namespace-old-10.3 {command "namespace code" requires one argument} { + list [catch {namespace code first "second arg" third} msg] $msg +} {1 {wrong # args: should be "namespace code arg"}} + +test namespace-old-10.4 {command "namespace code" gets current namesp context} { + namespace eval test_ns_inscope { + namespace code {"1 2 3" "4 5" 6} + } +} {namespace inscope ::test_ns_inscope {"1 2 3" "4 5" 6}} + +test namespace-old-10.5 {with one arg, first "scope" sticks} { + set sval [namespace eval test_ns_inscope {namespace code {one two}}] + namespace code $sval +} {namespace inscope ::test_ns_inscope {one two}} + +test namespace-old-10.6 {with many args, each "scope" adds new args} { + set sval [namespace eval test_ns_inscope {namespace code {one two}}] + namespace code "$sval three" +} {namespace inscope ::test_ns_inscope {one two} three} + +test namespace-old-10.7 {scoped commands work with eval} { + set cref [namespace eval test_ns_inscope {namespace code show}] + list [eval $cref "a" "b c" "d e f"] +} {{show: a b c d e f}} + +test namespace-old-10.8 {scoped commands execute in namespace context} { + set cref [namespace eval test_ns_inscope { + namespace code {set x "some new value"} + }] + list [set test_ns_inscope::x] [eval $cref] [set test_ns_inscope::x] +} {x-value {some new value} {some new value}} + +foreach cmd [info commands test_ns_*] { + rename $cmd "" +} +catch {rename cmd {}} +catch {rename cmd1 {}} +catch {rename cmd2 {}} +catch {rename ncmd {}} +catch {rename ncmd1 {}} +catch {rename ncmd2 {}} +catch {unset cref} +catch {unset trigger} +catch {unset trigger2} +catch {unset sval} +catch {unset msg} +catch {unset x} +catch {unset test_ns_var_global} +catch {unset cmd} +eval namespace delete [namespace children :: test_ns_*] diff --git a/contrib/tcl/tests/namespace.test b/contrib/tcl/tests/namespace.test new file mode 100644 index 0000000000000..c021d21511e5c --- /dev/null +++ b/contrib/tcl/tests/namespace.test @@ -0,0 +1,1064 @@ +# Functionality covered: this file contains a collection of tests for the +# procedures in tclNamesp.c that implement Tcl's basic support for +# namespaces. Other namespace-related tests appear in variable.test. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) namespace.test 1.11 97/06/23 18:24:39 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Clear out any namespaces called test_ns_* +catch {eval namespace delete [namespace children :: test_ns_*]} + +test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} { + namespace children :: +} {} + +catch {unset l} +test namespace-2.1 {Tcl_GetCurrentNamespace} { + list [namespace current] [namespace eval {} {namespace current}] \ + [namespace eval {} {namespace current}] +} {:: :: ::} +test namespace-2.2 {Tcl_GetCurrentNamespace} { + set l {} + lappend l [namespace current] + namespace eval test_ns_1 { + lappend l [namespace current] + namespace eval foo { + lappend l [namespace current] + } + } + lappend l [namespace current] + set l +} {:: ::test_ns_1 ::test_ns_1::foo ::} + +test namespace-3.1 {Tcl_GetGlobalNamespace} { + namespace eval test_ns_1 {namespace eval foo {namespace eval bar {} } } + # namespace children uses Tcl_GetGlobalNamespace + namespace eval test_ns_1 {namespace children foo b*} +} {::test_ns_1::foo::bar} + +test namespace-4.1 {Tcl_PushCallFrame with isProcCallFrame=1} { + namespace eval test_ns_1 { + variable v 123 + proc p {} { + variable v + return $v + } + } + test_ns_1::p ;# does Tcl_PushCallFrame to push p's namespace +} {123} +test namespace-4.2 {Tcl_PushCallFrame with isProcCallFrame=0} { + namespace eval test_ns_1::baz {} ;# does Tcl_PushCallFrame to create baz + proc test_ns_1::baz::p {} { + variable v + set v 789 + set v} + test_ns_1::baz::p +} {789} + +test namespace-5.1 {Tcl_PopCallFrame, no vars} { + namespace eval test_ns_1::blodge {} ;# pushes then pops frame +} {} +test namespace-5.2 {Tcl_PopCallFrame, local vars must be deleted} { + proc test_ns_1::r {} { + set a 123 + } + test_ns_1::r ;# pushes then pop's r's frame +} {123} + +test namespace-6.1 {Tcl_CreateNamespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [lsort [namespace children :: test_ns_*]] \ + [namespace eval test_ns_1 {namespace current}] \ + [namespace eval test_ns_2 {namespace current}] \ + [namespace eval ::test_ns_3 {namespace current}] \ + [namespace eval ::test_ns_4 \ + {namespace eval foo {namespace current}}] \ + [namespace eval ::test_ns_5 \ + {namespace eval ::test_ns_6 {namespace current}}] \ + [lsort [namespace children :: test_ns_*]] +} {{} ::test_ns_1 ::test_ns_2 ::test_ns_3 ::test_ns_4::foo ::test_ns_6 {::test_ns_1 ::test_ns_2 ::test_ns_3 ::test_ns_4 ::test_ns_5 ::test_ns_6}} +test namespace-6.2 {Tcl_CreateNamespace, odd number of :'s in name is okay} { + list [namespace eval :::test_ns_1::::foo {namespace current}] \ + [namespace eval test_ns_2:::::foo {namespace current}] +} {::test_ns_1::foo ::test_ns_2::foo} +test namespace-6.3 {Tcl_CreateNamespace, bad namespace names} { + list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg +} {1 {can't create namespace "": invalid name}} +test namespace-6.4 {Tcl_CreateNamespace, relative ns names now only looked up in current ns} { + set trigger { + namespace eval test_ns_2 {namespace current} + } + set l {} + lappend l [namespace eval test_ns_1 $trigger] + namespace eval test_ns_1::test_ns_2 {} + lappend l [namespace eval test_ns_1 $trigger] +} {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_2} + +test namespace-7.1 {Tcl_DeleteNamespace, active call frames in ns} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc p {} { + namespace delete [namespace current] + return [namespace current] + } + } + list [test_ns_1::p] [catch {test_ns_1::p} msg] $msg +} {::test_ns_1 1 {invalid command name "test_ns_1::p"}} +test namespace-7.2 {Tcl_DeleteNamespace, no active call frames in ns} { + namespace eval test_ns_2 { + proc p {} { + return [namespace current] + } + } + list [test_ns_2::p] [namespace delete test_ns_2] +} {::test_ns_2 {}} + +test namespace-8.1 {TclTeardownNamespace, delete global namespace} { + catch {interp delete test_interp} + interp create test_interp + interp eval test_interp { + namespace eval test_ns_1 { + namespace export p + proc p {} { + return [namespace current] + } + } + namespace eval test_ns_2 { + namespace import ::test_ns_1::p + variable v 27 + proc q {} { + variable v + return "[p] $v" + } + } + set x [test_ns_2::q] + catch {set xxxx} + } + list [interp eval test_interp {test_ns_2::q}] \ + [interp eval test_interp {namespace delete ::}] \ + [catch {interp eval test_interp {set a 123}} msg] $msg \ + [interp delete test_interp] +} {{::test_ns_1 27} {} 1 {invalid command name "set"} {}} +test namespace-8.2 {TclTeardownNamespace, remove deleted ns from parent} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2::test_ns_3a {proc p {} {}} + namespace eval test_ns_1::test_ns_2::test_ns_3b {proc q {} {}} + list [namespace children test_ns_1] \ + [namespace delete test_ns_1::test_ns_2] \ + [namespace children test_ns_1] +} {::test_ns_1::test_ns_2 {} {}} +test namespace-8.3 {TclTeardownNamespace, delete child namespaces} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2::test_ns_3a {proc p {} {}} + namespace eval test_ns_1::test_ns_2::test_ns_3b {proc q {} {}} + list [namespace children test_ns_1] \ + [namespace delete test_ns_1::test_ns_2] \ + [namespace children test_ns_1] \ + [catch {namespace children test_ns_1::test_ns_2} msg] $msg \ + [info commands test_ns_1::test_ns_2::test_ns_3a::*] +} {::test_ns_1::test_ns_2 {} {} 1 {unknown namespace "test_ns_1::test_ns_2" in namespace children command} {}} +test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 cmd2 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_import { + namespace import ::test_ns_export::* + proc p {} {return foo} + } + list [info commands test_ns_import::*] \ + [namespace delete test_ns_export] \ + [info commands test_ns_import::*] +} {{::test_ns_import::p ::test_ns_import::cmd1 ::test_ns_import::cmd2} {} ::test_ns_import::p} + +test namespace-9.1 {Tcl_Import, empty import pattern} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace eval test_ns_import {namespace import {}}} msg] $msg +} {1 {empty import pattern}} +test namespace-9.2 {Tcl_Import, unknown namespace in import pattern} { + list [catch {namespace eval test_ns_import {namespace import fred::x}} msg] $msg +} {1 {unknown namespace in import pattern "fred::x"}} +test namespace-9.3 {Tcl_Import, import ns == export ns} { + list [catch {namespace eval test_ns_import {namespace import ::test_ns_import::puts}} msg] $msg +} {1 {import pattern "::test_ns_import::puts" tries to import from namespace "test_ns_import" into itself}} +test namespace-9.4 {Tcl_Import, simple import} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_import { + namespace import ::test_ns_export::* + proc p {} {return [cmd1 123]} + } + test_ns_import::p +} {cmd1: 123} +test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} { + list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg +} {1 {can't import command "cmd1": already exists}} +test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} { + namespace eval test_ns_import { + namespace import -force ::test_ns_export::* + cmd1 555 + } +} {cmd1: 555} + +test namespace-10.1 {Tcl_ForgetImport, check for valid namespaces} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace forget xyzzy::*} msg] $msg +} {1 {unknown namespace in namespace forget pattern "xyzzy::*"}} +test namespace-10.2 {Tcl_ForgetImport, ignores patterns that don't match} { + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_import { + namespace forget ::test_ns_export::wombat + } +} {} +test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} { + namespace eval test_ns_import { + namespace import ::test_ns_export::* + proc p {} {return [cmd1 123]} + set l {} + lappend l [info commands ::test_ns_import::*] + namespace forget ::test_ns_export::cmd1 + lappend l [info commands ::test_ns_import::*] + lappend l [catch {cmd1 777} msg] $msg + } +} {{::test_ns_import::p ::test_ns_import::cmd1} ::test_ns_import::p 1 {invalid command name "cmd1"}} + +test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + } + list [namespace origin set] [namespace origin test_ns_export::cmd1] +} {::set ::test_ns_export::cmd1} +test namespace-11.2 {TclGetOriginalCommand, directly imported cmd} { + namespace eval test_ns_import1 { + namespace import ::test_ns_export::* + namespace export * + proc p {} {namespace origin cmd1} + } + list [test_ns_import1::p] [namespace origin test_ns_import1::cmd1] +} {::test_ns_export::cmd1 ::test_ns_export::cmd1} +test namespace-11.3 {TclGetOriginalCommand, indirectly imported cmd} { + namespace eval test_ns_import2 { + namespace import ::test_ns_import1::* + proc q {} {return [cmd1 123]} + } + list [test_ns_import2::q] [namespace origin test_ns_import2::cmd1] +} {{cmd1: 123} ::test_ns_export::cmd1} + +test namespace-12.1 {InvokeImportedCmd} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {namespace current} + } + namespace eval test_ns_import { + namespace import ::test_ns_export::* + } + list [test_ns_import::cmd1] +} {::test_ns_export} + +test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} { + namespace eval test_ns_import { + set l {} + lappend l [info commands ::test_ns_import::*] + namespace forget ::test_ns_export::cmd1 + lappend l [info commands ::test_ns_import::*] + } +} {::test_ns_import::cmd1 {}} + +test namespace-14.1 {TclGetNamespaceForQualName, absolute names} { + catch {eval namespace delete [namespace children :: test_ns_*]} + variable v 10 + namespace eval test_ns_1::test_ns_2 { + variable v 20 + } + namespace eval test_ns_2 { + variable v 30 + } + namespace eval test_ns_1 { + list $::v $::test_ns_2::v $::test_ns_1::test_ns_2::v \ + [namespace children ::] + } +} {10 30 20 {::test_ns_1 ::test_ns_2}} +test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} { + namespace eval test_ns_1 { + list [catch {set ::test_ns_777::v} msg] $msg \ + [catch {namespace children test_ns_777} msg] $msg + } +} {1 {can't read "::test_ns_777::v": no such variable} 1 {unknown namespace "test_ns_777" in namespace children command}} +test namespace-14.3 {TclGetNamespaceForQualName, relative names} { + namespace eval test_ns_1 { + list $v $test_ns_2::v + } +} {10 20} +test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { + namespace eval test_ns_1::test_ns_2 { + namespace eval foo {} + } + namespace eval test_ns_1 { + list [namespace children test_ns_2] \ + [catch {namespace children test_ns_1} msg] $msg + } +} {::test_ns_1::test_ns_2::foo 1 {unknown namespace "test_ns_1" in namespace children command}} +test namespace-14.5 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { + namespace eval ::test_ns_2 { + namespace eval bar {} + } + namespace eval test_ns_1 { + set l [list [catch {namespace delete test_ns_2::bar} msg] $msg] + } + set l +} {1 {unknown namespace "test_ns_2::bar" in namespace delete command}} +test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { + namespace eval test_ns_1::test_ns_2 { + namespace eval foo {} + } + namespace eval test_ns_1 { + list [namespace children test_ns_2] \ + [catch {namespace children test_ns_1} msg] $msg + } +} {::test_ns_1::test_ns_2::foo 1 {unknown namespace "test_ns_1" in namespace children command}} +test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} { + namespace children test_ns_1::: +} {::test_ns_1::test_ns_2} +test namespace-14.8 {TclGetNamespaceForQualName, ignore extra :s if ns} { + namespace children :::test_ns_1:::::test_ns_2::: +} {::test_ns_1::test_ns_2::foo} +test namespace-14.9 {TclGetNamespaceForQualName, extra ::s are significant for vars} { + set l {} + lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg + namespace eval test_ns_1::test_ns_2 {variable {} 2525} + lappend l [set test_ns_1::test_ns_2::] +} {1 {can't read "test_ns_1::test_ns_2::": no such variable} 2525} +test namespace-14.10 {TclGetNamespaceForQualName, extra ::s are significant for vars} { + catch {unset test_ns_1::test_ns_2::} + set l {} + lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg + set test_ns_1::test_ns_2:: 314159 + lappend l [set test_ns_1::test_ns_2::] +} {1 {can't read "test_ns_1::test_ns_2::": no such variable} 314159} +test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for commands} { + catch {rename test_ns_1::test_ns_2:: {}} + set l {} + lappend l [catch {test_ns_1::test_ns_2:: hello} msg] $msg + proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"} + lappend l [test_ns_1::test_ns_2:: hello] +} {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} +test namespace-14.12 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace eval test_ns_1 {proc {} {} {}; namespace eval {} {}; {}}} msg] $msg +} {1 {can't create namespace "": invalid name}} + +test namespace-15.1 {Tcl_FindNamespace, absolute name found} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_delete { + namespace eval test_ns_delete2 {} + proc cmd {args} {namespace current} + } + list [namespace delete ::test_ns_delete::test_ns_delete2] \ + [namespace children ::test_ns_delete] +} {{} {}} +test namespace-15.2 {Tcl_FindNamespace, absolute name not found} { + list [catch {namespace delete ::test_ns_delete::test_ns_delete2} msg] $msg +} {1 {unknown namespace "::test_ns_delete::test_ns_delete2" in namespace delete command}} +test namespace-15.3 {Tcl_FindNamespace, relative name found} { + namespace eval test_ns_delete { + namespace eval test_ns_delete2 {} + namespace eval test_ns_delete3 {} + list [namespace delete test_ns_delete2] \ + [namespace children [namespace current]] + } +} {{} ::test_ns_delete::test_ns_delete3} +test namespace-15.4 {Tcl_FindNamespace, relative name not found} { + namespace eval test_ns_delete2 {} + namespace eval test_ns_delete { + list [catch {namespace delete test_ns_delete2} msg] $msg + } +} {1 {unknown namespace "test_ns_delete2" in namespace delete command}} + +test namespace-16.1 {Tcl_FindCommand, absolute name found} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc cmd {args} {return "[namespace current]::cmd: $args"} + variable v "::test_ns_1::cmd" + eval $v one + } +} {::test_ns_1::cmd: one} +test namespace-16.2 {Tcl_FindCommand, absolute name found} { + eval $test_ns_1::v two +} {::test_ns_1::cmd: two} +test namespace-16.3 {Tcl_FindCommand, absolute name not found} { + namespace eval test_ns_1 { + variable v2 "::test_ns_1::ladidah" + list [catch {eval $v2} msg] $msg + } +} {1 {invalid command name "::test_ns_1::ladidah"}} + +# save the "unknown" proc, which is redefined by the following two tests +catch {rename unknown unknown.old} +proc unknown {args} { + return "unknown: $args" +} +test namespace-16.4 {Tcl_FindCommand, absolute name and TCL_GLOBAL_ONLY} { + ::test_ns_1::foobar x y z +} {unknown: ::test_ns_1::foobar x y z} +test namespace-16.5 {Tcl_FindCommand, absolute name and TCL_GLOBAL_ONLY} { + ::foobar 1 2 3 4 5 +} {unknown: ::foobar 1 2 3 4 5} +test namespace-16.6 {Tcl_FindCommand, relative name and TCL_GLOBAL_ONLY} { + test_ns_1::foobar x y z +} {unknown: test_ns_1::foobar x y z} +test namespace-16.7 {Tcl_FindCommand, relative name and TCL_GLOBAL_ONLY} { + foobar 1 2 3 4 5 +} {unknown: foobar 1 2 3 4 5} +# restore the "unknown" proc saved previously +catch {rename unknown {}} +catch {rename unknown.old unknown} + +test namespace-16.8 {Tcl_FindCommand, relative name found} { + namespace eval test_ns_1 { + cmd a b c + } +} {::test_ns_1::cmd: a b c} +test namespace-16.9 {Tcl_FindCommand, relative name found} { + catch {rename cmd2 {}} + proc cmd2 {args} {return "[namespace current]::cmd2: $args"} + namespace eval test_ns_1 { + cmd2 a b c + } +} {::::cmd2: a b c} +test namespace-16.10 {Tcl_FindCommand, relative name found, only look in current then global ns} { + namespace eval test_ns_1 { + proc cmd2 {args} { + return "[namespace current]::cmd2 in test_ns_1: $args" + } + namespace eval test_ns_12 { + cmd2 a b c + } + } +} {::::cmd2: a b c} +test namespace-16.11 {Tcl_FindCommand, relative name not found} { + namespace eval test_ns_1 { + list [catch {cmd3 a b c} msg] $msg + } +} {1 {invalid command name "cmd3"}} + +catch {unset x} +test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} { + catch {eval namespace delete [namespace children :: test_ns_*]} + set x 314159 + namespace eval test_ns_1 { + set ::x + } +} {314159} +test namespace-17.2 {Tcl_FindNamespaceVar, absolute name found} { + namespace eval test_ns_1 { + variable x 777 + set ::test_ns_1::x + } +} {777} +test namespace-17.3 {Tcl_FindNamespaceVar, absolute name found} { + namespace eval test_ns_1 { + namespace eval test_ns_2 { + variable x 1111 + } + set ::test_ns_1::test_ns_2::x + } +} {1111} +test namespace-17.4 {Tcl_FindNamespaceVar, absolute name not found} { + namespace eval test_ns_1 { + namespace eval test_ns_2 { + variable x 1111 + } + list [catch {set ::test_ns_1::test_ns_2::y} msg] $msg + } +} {1 {can't read "::test_ns_1::test_ns_2::y": no such variable}} +test namespace-17.5 {Tcl_FindNamespaceVar, absolute name and TCL_GLOBAL_ONLY} { + namespace eval test_ns_1 { + namespace eval test_ns_3 { + variable ::test_ns_1::test_ns_2::x 2222 + } + } + set ::test_ns_1::test_ns_2::x +} {2222} +test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} { + namespace eval test_ns_1 { + set x + } +} {777} +test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} { + namespace eval test_ns_1 { + unset x + set x ;# must be global x now + } +} {314159} +test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} { + namespace eval test_ns_1 { + list [catch {set wuzzat} msg] $msg + } +} {1 {can't read "wuzzat": no such variable}} +test namespace-17.9 {Tcl_FindNamespaceVar, relative name and TCL_GLOBAL_ONLY} { + namespace eval test_ns_1 { + variable a hello + } + set test_ns_1::a +} {hello} +catch {unset x} + +catch {unset l} +catch {rename foo {}} +test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} { + catch {eval namespace delete [namespace children :: test_ns_*]} + proc foo {} {return "global foo"} + namespace eval test_ns_1 { + proc trigger {} { + return [foo] + } + } + set l "" + lappend l [test_ns_1::trigger] + namespace eval test_ns_1 { + # force invalidation of cached ref to "foo" in proc trigger + proc foo {} {return "foo in test_ns_1"} + } + lappend l [test_ns_1::trigger] + set l +} {{global foo} {foo in test_ns_1}} +test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shadowing} { + namespace eval test_ns_2 { + proc foo {} {return "foo in ::test_ns_2"} + } + namespace eval test_ns_1 { + namespace eval test_ns_2 {} + proc trigger {} { + return [test_ns_2::foo] + } + } + set l "" + lappend l [test_ns_1::trigger] + namespace eval test_ns_1 { + namespace eval test_ns_2 { + # force invalidation of cached ref to "foo" in proc trigger + proc foo {} {return "foo in ::test_ns_1::test_ns_2"} + } + } + lappend l [test_ns_1::trigger] + set l +} {{foo in ::test_ns_2} {foo in ::test_ns_1::test_ns_2}} +catch {unset l} +catch {rename foo {}} + +test namespace-19.1 {GetNamespaceFromObj, global name found} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} + namespace children ::test_ns_1 +} {::test_ns_1::test_ns_2} +test namespace-19.2 {GetNamespaceFromObj, relative name found} { + namespace eval test_ns_1 { + namespace children test_ns_2 + } +} {} +test namespace-19.3 {GetNamespaceFromObj, name not found} { + namespace eval test_ns_1 { + list [catch {namespace children test_ns_99} msg] $msg + } +} {1 {unknown namespace "test_ns_99" in namespace children command}} +test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { + namespace eval test_ns_1 { + proc foo {} { + return [namespace children test_ns_2] + } + list [catch {namespace children test_ns_99} msg] $msg + } + set l {} + lappend l [test_ns_1::foo] + namespace delete test_ns_1::test_ns_2 + namespace eval test_ns_1::test_ns_2::test_ns_3 {} + lappend l [test_ns_1::foo] + set l +} {{} ::test_ns_1::test_ns_2::test_ns_3} + +test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace} msg] $msg +} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}} +test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} { + list [catch {namespace wombat {}} msg] $msg +} {1 {bad namespace subcommand "wombat": should be children, code, current, delete, eval, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}} +test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} { + namespace ch :: +} {} + +test namespace-21.1 {NamespaceChildrenCmd, no args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} + namespace children +} {::test_ns_1} +test namespace-21.2 {NamespaceChildrenCmd, no args} { + namespace eval test_ns_1 { + namespace children + } +} {::test_ns_1::test_ns_2} +test namespace-21.3 {NamespaceChildrenCmd, ns name given} { + namespace children ::test_ns_1 +} {::test_ns_1::test_ns_2} +test namespace-21.4 {NamespaceChildrenCmd, ns name given} { + namespace eval test_ns_1 { + namespace children test_ns_2 + } +} {} +test namespace-21.5 {NamespaceChildrenCmd, too many args} { + namespace eval test_ns_1 { + list [catch {namespace children test_ns_2 xxx yyy} msg] $msg + } +} {1 {wrong # args: should be "namespace children ?name? ?pattern?"}} +test namespace-21.6 {NamespaceChildrenCmd, glob-style pattern given} { + namespace eval test_ns_1::test_ns_foo {} + namespace children test_ns_1 *f* +} {::test_ns_1::test_ns_foo} +test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} { + namespace eval test_ns_1::test_ns_foo {} + namespace children test_ns_1 test* +} {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo} + +test namespace-22.1 {NamespaceCodeCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace code} msg] $msg \ + [catch {namespace code xxx yyy} msg] $msg +} {1 {wrong # args: should be "namespace code arg"} 1 {wrong # args: should be "namespace code arg"}} +test namespace-22.2 {NamespaceCodeCmd, arg is already scoped value} { + namespace eval test_ns_1 { + proc cmd {} {return "test_ns_1::cmd"} + } + namespace code {namespace inscope ::test_ns_1 cmd} +} {namespace inscope ::test_ns_1 cmd} +test namespace-22.3 {NamespaceCodeCmd, arg is already scoped value} { + namespace code {namespace inscope ::test_ns_1 cmd} +} {namespace inscope ::test_ns_1 cmd} +test namespace-22.4 {NamespaceCodeCmd, in :: namespace} { + namespace code unknown +} {namespace inscope :: unknown} +test namespace-22.5 {NamespaceCodeCmd, in other namespace} { + namespace eval test_ns_1 { + namespace code cmd + } +} {namespace inscope ::test_ns_1 cmd} + +test namespace-23.1 {NamespaceCurrentCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace current xxx} msg] $msg \ + [catch {namespace current xxx yyy} msg] $msg +} {1 {wrong # args: should be "namespace current"} 1 {wrong # args: should be "namespace current"}} +test namespace-23.2 {NamespaceCurrentCmd, at global level} { + namespace current +} {::} +test namespace-23.3 {NamespaceCurrentCmd, in nested ns} { + namespace eval test_ns_1::test_ns_2 { + namespace current + } +} {::test_ns_1::test_ns_2} + +test namespace-24.1 {NamespaceDeleteCmd, no args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace delete +} {} +test namespace-24.2 {NamespaceDeleteCmd, one arg} { + namespace eval test_ns_1::test_ns_2 {} + namespace delete ::test_ns_1 +} {} +test namespace-24.3 {NamespaceDeleteCmd, two args} { + namespace eval test_ns_1::test_ns_2 {} + list [namespace delete ::test_ns_1::test_ns_2] [namespace delete ::test_ns_1] +} {{} {}} +test namespace-24.4 {NamespaceDeleteCmd, unknown ns} { + list [catch {namespace delete ::test_ns_foo} msg] $msg +} {1 {unknown namespace "::test_ns_foo" in namespace delete command}} + +test namespace-25.1 {NamespaceEvalCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace eval} msg] $msg +} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}} +test namespace-25.2 {NamespaceEvalCmd, bad args} { + list [catch {namespace test_ns_1} msg] $msg +} {1 {bad namespace subcommand "test_ns_1": should be children, code, current, delete, eval, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}} +catch {unset v} +test namespace-25.3 {NamespaceEvalCmd, new namespace} { + set v 123 + namespace eval test_ns_1 { + variable v 314159 + proc p {} { + variable v + return $v + } + } + test_ns_1::p +} {314159} +test namespace-25.4 {NamespaceEvalCmd, existing namespace} { + namespace eval test_ns_1 { + proc q {} {return [expr {[p]+1}]} + } + test_ns_1::q +} {314160} +test namespace-25.5 {NamespaceEvalCmd, multiple args} { + namespace eval test_ns_1 "set" "v" +} {314159} +test namespace-25.6 {NamespaceEvalCmd, error in eval'd script} { + list [catch {namespace eval test_ns_1 {xxxx}} msg] $msg $errorInfo +} {1 {invalid command name "xxxx"} {invalid command name "xxxx" + while executing +"xxxx" + (in namespace eval "::test_ns_1" script line 1) + invoked from within +"namespace eval test_ns_1 {xxxx}"}} +catch {unset v} + +test namespace-26.1 {NamespaceExportCmd, no args and new ns} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace export +} {} +test namespace-26.2 {NamespaceExportCmd, just -clear arg} { + namespace export -clear +} {} +test namespace-26.3 {NamespaceExportCmd, pattern can't specify a namespace} { + namespace eval test_ns_1 { + list [catch {namespace export ::zzz} msg] $msg + } +} {1 {invalid export pattern "::zzz": pattern can't specify a namespace}} +test namespace-26.4 {NamespaceExportCmd, one pattern} { + namespace eval test_ns_1 { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + } + namespace eval test_ns_2 { + namespace import ::test_ns_1::* + } + list [info commands test_ns_2::*] [test_ns_2::cmd1 hello] +} {::test_ns_2::cmd1 {cmd1: hello}} +test namespace-26.5 {NamespaceExportCmd, sequence of patterns, patterns accumulate} { + namespace eval test_ns_1 { + namespace export cmd1 cmd3 + } + namespace eval test_ns_2 { + namespace import -force ::test_ns_1::* + } + list [info commands test_ns_2::*] [test_ns_2::cmd3 hello] +} {{::test_ns_2::cmd1 ::test_ns_2::cmd3} {cmd3: hello}} +test namespace-26.6 {NamespaceExportCmd, no patterns means return export list} { + namespace eval test_ns_1 { + namespace export + } +} {cmd1 cmd1 cmd3} +test namespace-26.7 {NamespaceExportCmd, -clear resets export list} { + namespace eval test_ns_1 { + namespace export -clear cmd4 + } + namespace eval test_ns_2 { + namespace import ::test_ns_1::* + } + list [info commands test_ns_2::*] [test_ns_2::cmd4 hello] +} {{::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3} {cmd4: hello}} + +test namespace-27.1 {NamespaceForgetCmd, no args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace forget +} {} +test namespace-27.2 {NamespaceForgetCmd, args must be valid namespaces} { + list [catch {namespace forget ::test_ns_1::xxx} msg] $msg +} {1 {unknown namespace in namespace forget pattern "::test_ns_1::xxx"}} +test namespace-27.3 {NamespaceForgetCmd, arg is forgotten} { + namespace eval test_ns_1 { + namespace export cmd* + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace import ::test_ns_1::* + namespace forget ::test_ns_1::cmd1 + } + info commands ::test_ns_2::* +} {::test_ns_2::cmd2} + +test namespace-28.1 {NamespaceImportCmd, no args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace import +} {} +test namespace-28.2 {NamespaceImportCmd, no args and just "-force"} { + namespace import -force +} {} +test namespace-28.3 {NamespaceImportCmd, arg is imported} { + namespace eval test_ns_1 { + namespace export cmd2 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace import ::test_ns_1::* + namespace forget ::test_ns_1::cmd1 + } + info commands test_ns_2::* +} {::test_ns_2::cmd2} + +test namespace-29.1 {NamespaceInscopeCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace inscope} msg] $msg +} {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}} +test namespace-29.2 {NamespaceInscopeCmd, bad args} { + list [catch {namespace inscope ::} msg] $msg +} {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}} +test namespace-29.3 {NamespaceInscopeCmd, specified ns must exist} { + list [catch {namespace inscope test_ns_1 {set v}} msg] $msg +} {1 {unknown namespace "test_ns_1" in inscope namespace command}} +test namespace-29.4 {NamespaceInscopeCmd, simple case} { + namespace eval test_ns_1 { + variable v 747 + proc cmd {args} { + variable v + return "[namespace current]::cmd: v=$v, args=$args" + } + } + namespace inscope test_ns_1 cmd +} {::test_ns_1::cmd: v=747, args=} +test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} { + list [namespace inscope test_ns_1 cmd x y z] \ + [namespace eval test_ns_1 [concat cmd [list x y z]]] +} {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}} + +test namespace-30.1 {NamespaceOriginCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace origin} msg] $msg +} {1 {wrong # args: should be "namespace origin name"}} +test namespace-30.2 {NamespaceOriginCmd, bad args} { + list [catch {namespace origin x y} msg] $msg +} {1 {wrong # args: should be "namespace origin name"}} +test namespace-30.3 {NamespaceOriginCmd, command not found} { + list [catch {namespace origin fred} msg] $msg +} {1 {invalid command name "fred"}} +test namespace-30.4 {NamespaceOriginCmd, command isn't imported} { + namespace origin set +} {::set} +test namespace-30.5 {NamespaceOriginCmd, imported command} { + namespace eval test_ns_1 { + namespace export cmd* + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace export * + namespace import ::test_ns_1::* + proc p {} {} + } + namespace eval test_ns_3 { + namespace import ::test_ns_2::* + list [namespace origin foreach] \ + [namespace origin p] \ + [namespace origin cmd1] \ + [namespace origin ::test_ns_2::cmd2] + } +} {::foreach ::test_ns_2::p ::test_ns_1::cmd1 ::test_ns_1::cmd2} + +test namespace-31.1 {NamespaceParentCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace parent a b} msg] $msg +} {1 {wrong # args: should be "namespace parent ?name?"}} +test namespace-31.2 {NamespaceParentCmd, no args} { + namespace parent +} {} +test namespace-31.3 {NamespaceParentCmd, namespace specified} { + namespace eval test_ns_1 { + namespace eval test_ns_2 { + namespace eval test_ns_3 {} + } + } + list [namespace parent ::] \ + [namespace parent test_ns_1::test_ns_2] \ + [namespace eval test_ns_1::test_ns_2::test_ns_3 {namespace parent ::test_ns_1::test_ns_2}] +} {{} ::test_ns_1 ::test_ns_1} +test namespace-31.4 {NamespaceParentCmd, bad namespace specified} { + list [catch {namespace parent test_ns_1::test_ns_foo} msg] $msg +} {1 {unknown namespace "test_ns_1::test_ns_foo" in namespace parent command}} + +test namespace-32.1 {NamespaceQualifiersCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace qualifiers} msg] $msg +} {1 {wrong # args: should be "namespace qualifiers string"}} +test namespace-32.2 {NamespaceQualifiersCmd, bad args} { + list [catch {namespace qualifiers x y} msg] $msg +} {1 {wrong # args: should be "namespace qualifiers string"}} +test namespace-32.3 {NamespaceQualifiersCmd, simple name} { + namespace qualifiers foo +} {} +test namespace-32.4 {NamespaceQualifiersCmd, leading ::} { + namespace qualifiers ::x::y::z +} {::x::y} +test namespace-32.5 {NamespaceQualifiersCmd, no leading ::} { + namespace qualifiers a::b +} {a} +test namespace-32.6 {NamespaceQualifiersCmd, :: argument} { + namespace qualifiers :: +} {} +test namespace-32.7 {NamespaceQualifiersCmd, odd number of :s} { + namespace qualifiers ::::: +} {} +test namespace-32.8 {NamespaceQualifiersCmd, odd number of :s} { + namespace qualifiers foo::: +} {foo} + +test namespace-33.1 {NamespaceTailCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace tail} msg] $msg +} {1 {wrong # args: should be "namespace tail string"}} +test namespace-33.2 {NamespaceTailCmd, bad args} { + list [catch {namespace tail x y} msg] $msg +} {1 {wrong # args: should be "namespace tail string"}} +test namespace-33.3 {NamespaceTailCmd, simple name} { + namespace tail foo +} {foo} +test namespace-33.4 {NamespaceTailCmd, leading ::} { + namespace tail ::x::y::z +} {z} +test namespace-33.5 {NamespaceTailCmd, no leading ::} { + namespace tail a::b +} {b} +test namespace-33.6 {NamespaceTailCmd, :: argument} { + namespace tail :: +} {} +test namespace-33.7 {NamespaceTailCmd, odd number of :s} { + namespace tail ::::: +} {} +test namespace-33.8 {NamespaceTailCmd, odd number of :s} { + namespace tail foo::: +} {} + +test namespace-34.1 {NamespaceWhichCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace which} msg] $msg +} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} +test namespace-34.2 {NamespaceWhichCmd, bad args} { + list [catch {namespace which -fred} msg] $msg +} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} +test namespace-34.3 {NamespaceWhichCmd, bad args} { + list [catch {namespace which -command} msg] $msg +} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} +test namespace-34.4 {NamespaceWhichCmd, bad args} { + list [catch {namespace which a b} msg] $msg +} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} +test namespace-34.5 {NamespaceWhichCmd, command lookup} { + namespace eval test_ns_1 { + namespace export cmd* + variable v1 111 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace export * + namespace import ::test_ns_1::* + variable v2 222 + proc p {} {} + } + namespace eval test_ns_3 { + namespace import ::test_ns_2::* + variable v3 333 + list [namespace which -command foreach] \ + [namespace which -command p] \ + [namespace which -command cmd1] \ + [namespace which -command ::test_ns_2::cmd2] \ + [catch {namespace which -command ::test_ns_2::noSuchCmd} msg] $msg + } +} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2 0 {}} +test namespace-34.6 {NamespaceWhichCmd, -command is default} { + namespace eval test_ns_3 { + list [namespace which foreach] \ + [namespace which p] \ + [namespace which cmd1] \ + [namespace which ::test_ns_2::cmd2] + } +} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2} +test namespace-34.7 {NamespaceWhichCmd, variable lookup} { + namespace eval test_ns_3 { + list [namespace which -variable env] \ + [namespace which -variable v3] \ + [namespace which -variable ::test_ns_2::v2] \ + [catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg + } +} {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} + +test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc p {} { + namespace delete [namespace current] + return [namespace current] + } + } + test_ns_1::p +} {::test_ns_1} +test namespace-35.2 {FreeNsNameInternalRep, resulting ref count == 0} { + namespace eval test_ns_1 { + proc q {} { + return [namespace current] + } + } + list [test_ns_1::q] \ + [namespace delete test_ns_1] \ + [catch {test_ns_1::q} msg] $msg +} {::test_ns_1 {} 1 {invalid command name "test_ns_1::q"}} + +catch {unset x} +catch {unset y} +test namespace-36.1 {DupNsNameInternalRep} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 {} + set x "::test_ns_1" + list [namespace parent $x] [set y $x] [namespace parent $y] +} {:: ::test_ns_1 ::} +catch {unset x} +catch {unset y} + +test namespace-37.1 {SetNsNameFromAny, ns name found} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} + namespace eval test_ns_1 { + namespace children ::test_ns_1 + } +} {::test_ns_1::test_ns_2} +test namespace-37.2 {SetNsNameFromAny, ns name not found} { + namespace eval test_ns_1 { + list [catch {namespace children ::test_ns_1::test_ns_foo} msg] $msg + } +} {1 {unknown namespace "::test_ns_1::test_ns_foo" in namespace children command}} + +test namespace-38.1 {UpdateStringOfNsName} { + catch {eval namespace delete [namespace children :: test_ns_*]} + ;# Tcl_NamespaceObjCmd calls UpdateStringOfNsName to get subcmd name + list [namespace eval {} {namespace current}] \ + [namespace eval {} {namespace current}] +} {:: ::} + +catch {rename cmd1 {}} +catch {unset l} +catch {unset msg} +catch {unset trigger} +eval namespace delete [namespace children :: test_ns_*] diff --git a/contrib/tcl/tests/obj.test b/contrib/tcl/tests/obj.test new file mode 100644 index 0000000000000..cc8ea3c8893c9 --- /dev/null +++ b/contrib/tcl/tests/obj.test @@ -0,0 +1,496 @@ +# Functionality covered: this file contains a collection of tests for the +# procedures in tclObj.c that implement Tcl's basic type support and the +# type managers for the types boolean, double, and integer. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# @(#) obj.test 1.10 97/05/19 14:38:29 + +if {[info commands testobj] == {}} { + puts "This application hasn't been compiled with the \"testobj\"" + puts "command, so I can't test the Tcl type and object support." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} { + set r 1 + foreach {t} {list boolean cmdName bytecode string int double} { + set first [string first $t [testobj types]] + set r [expr {$r && ($first != -1)}] + } + set result $r +} {1} + +test obj-2.1 {Tcl_GetObjType error} { + list [testintobj set 1 0] [catch {testobj convert 1 foo} msg] $msg +} {0 1 {no type foo found}} +test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} { + set result "" + lappend result [testobj freeallvars] + lappend result [testintobj set 1 12] + lappend result [testobj convert 1 double] + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 12 12 double 3} + +test obj-3.1 {Tcl_ConvertToType error} { + list [testdoubleobj set 1 12.34] [catch {testobj convert 1 int} msg] $msg +} {12.34 1 {expected integer but got "12.34"}} +test obj-3.2 {Tcl_ConvertToType error, "empty string" object} { + list [testobj newobj 1] [catch {testobj convert 1 int} msg] $msg +} {{} 1 {expected integer but got ""}} + +test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} { + set result "" + lappend result [testobj freeallvars] + lappend result [testobj newobj 1] + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} {} string 2} + +test obj-5.1 {Tcl_FreeObj} { + set result "" + lappend result [testintobj set 1 12345] + lappend result [testobj freeallvars] + lappend result [catch {testintobj get 1} msg] + lappend result $msg +} {12345 {} 1 {variable 1 is unset (NULL)}} + +test obj-6.1 {Tcl_DuplicateObj, object has internal rep} { + set result "" + lappend result [testobj freeallvars] + lappend result [testintobj set 1 47] + lappend result [testobj duplicate 1 2] + lappend result [testintobj get 2] + lappend result [testobj refcount 1] + lappend result [testobj refcount 2] +} {{} 47 47 47 2 3} +test obj-6.2 {Tcl_DuplicateObj, "empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testobj newobj 1] + lappend result [testobj duplicate 1 2] + lappend result [testintobj get 2] + lappend result [testobj refcount 1] + lappend result [testobj refcount 2] +} {{} {} {} {} 2 3} + +test obj-7.1 {Tcl_GetStringFromObj, return existing string rep} { + set result "" + lappend result [testintobj set 1 47] + lappend result [testintobj get 1] +} {47 47} +test obj-7.2 {Tcl_GetStringFromObj, "empty string" object} { + set result "" + lappend result [testobj newobj 1] + lappend result [teststringobj append 1 abc -1] + lappend result [teststringobj get 1] +} {{} abc abc} +test obj-7.3 {Tcl_GetStringFromObj, returns string internal rep (DString)} { + set result "" + lappend result [teststringobj set 1 xyz] + lappend result [teststringobj append 1 abc -1] + lappend result [teststringobj get 1] +} {xyz xyzabc xyzabc} +test obj-7.4 {Tcl_GetStringFromObj, recompute string rep from internal rep} { + set result "" + lappend result [testintobj set 1 77] + lappend result [testintobj mult10 1] + lappend result [teststringobj get 1] +} {77 770 770} + +test obj-8.1 {Tcl_NewBooleanObj} { + set result "" + lappend result [testobj freeallvars] + lappend result [testbooleanobj set 1 0] + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 0 boolean 2} + +test obj-9.1 {Tcl_SetBooleanObj, existing "empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testobj newobj 1] + lappend result [testbooleanobj set 1 0] ;# makes existing obj boolean + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} {} 0 boolean 2} +test obj-9.2 {Tcl_SetBooleanObj, existing non-"empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testintobj set 1 98765] + lappend result [testbooleanobj set 1 1] ;# makes existing obj boolean + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 98765 1 boolean 2} + +test obj-10.1 {Tcl_GetBooleanFromObj, existing boolean object} { + set result "" + lappend result [testbooleanobj set 1 1] + lappend result [testbooleanobj not 1] ;# gets existing boolean rep +} {1 0} +test obj-10.2 {Tcl_GetBooleanFromObj, convert to boolean} { + set result "" + lappend result [testintobj set 1 47] + lappend result [testbooleanobj not 1] ;# must convert to bool + lappend result [testobj type 1] +} {47 0 boolean} +test obj-10.3 {Tcl_GetBooleanFromObj, error converting to boolean} { + set result "" + lappend result [teststringobj set 1 abc] + lappend result [catch {testbooleanobj not 1} msg] + lappend result $msg +} {abc 1 {expected boolean value but got "abc"}} +test obj-10.4 {Tcl_GetBooleanFromObj, error converting from "empty string"} { + set result "" + lappend result [testobj newobj 1] + lappend result [catch {testbooleanobj not 1} msg] + lappend result $msg +} {{} 1 {expected boolean value but got ""}} + +test obj-11.1 {DupBooleanInternalRep} { + set result "" + lappend result [testbooleanobj set 1 1] + lappend result [testobj duplicate 1 2] ;# uses DupBooleanInternalRep + lappend result [testbooleanobj get 2] +} {1 1 1} + +test obj-12.1 {SetBooleanFromAny, int to boolean special case} { + set result "" + lappend result [testintobj set 1 1234] + lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny + lappend result [testobj type 1] +} {1234 0 boolean} +test obj-12.2 {SetBooleanFromAny, double to boolean special case} { + set result "" + lappend result [format %.6g [testdoubleobj set 1 3.14159]] + lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny + lappend result [testobj type 1] +} {3.14159 0 boolean} +test obj-12.3 {SetBooleanFromAny, special case strings representing booleans} { + set result "" + foreach s {yes no true false on off} { + teststringobj set 1 $s + lappend result [testbooleanobj not 1] + } + lappend result [testobj type 1] +} {0 1 0 1 0 1 boolean} +test obj-12.4 {SetBooleanFromAny, recompute string rep then parse it} { + set result "" + lappend result [testintobj set 1 456] + lappend result [testintobj div10 1] + lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny + lappend result [testobj type 1] +} {456 45 0 boolean} +test obj-12.5 {SetBooleanFromAny, error parsing string} { + set result "" + lappend result [teststringobj set 1 abc] + lappend result [catch {testbooleanobj not 1} msg] + lappend result $msg +} {abc 1 {expected boolean value but got "abc"}} +test obj-12.6 {SetBooleanFromAny, error parsing string} { + set result "" + lappend result [teststringobj set 1 x1.0] + lappend result [catch {testbooleanobj not 1} msg] + lappend result $msg +} {x1.0 1 {expected boolean value but got "x1.0"}} +test obj-12.7 {SetBooleanFromAny, error converting from "empty string"} { + set result "" + lappend result [testobj newobj 1] + lappend result [catch {testbooleanobj not 1} msg] + lappend result $msg +} {{} 1 {expected boolean value but got ""}} + +test obj-13.1 {UpdateStringOfBoolean} { + set result "" + lappend result [testbooleanobj set 1 0] + lappend result [testbooleanobj not 1] + lappend result [testbooleanobj get 1] ;# must update string rep +} {0 1 1} + +test obj-14.1 {Tcl_NewDoubleObj} { + set result "" + lappend result [testobj freeallvars] + lappend result [format %.6g [testdoubleobj set 1 3.1459]] + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 3.1459 double 1} + +test obj-15.1 {Tcl_SetDoubleObj, existing "empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testobj newobj 1] + lappend result [testdoubleobj set 1 0.123] ;# makes existing obj boolean + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} {} 0.123 double 2} +test obj-15.2 {Tcl_SetDoubleObj, existing non-"empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testintobj set 1 98765] + lappend result [format %.6g [testdoubleobj set 1 27.56]] ;# makes existing obj double + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 98765 27.56 double 1} + +test obj-16.1 {Tcl_GetDoubleFromObj, existing double object} { + set result "" + lappend result [format %.6g [testdoubleobj set 1 16.1]] + lappend result [testdoubleobj mult10 1] ;# gets existing double rep +} {16.1 161.0} +test obj-16.2 {Tcl_GetDoubleFromObj, convert to double} { + set result "" + lappend result [testintobj set 1 477] + lappend result [format %.6g [testdoubleobj div10 1]] ;# must convert to bool + lappend result [testobj type 1] +} {477 47.7 double} +test obj-16.3 {Tcl_GetDoubleFromObj, error converting to double} { + set result "" + lappend result [teststringobj set 1 abc] + lappend result [catch {testdoubleobj mult10 1} msg] + lappend result $msg +} {abc 1 {expected floating-point number but got "abc"}} +test obj-16.4 {Tcl_GetDoubleFromObj, error converting from "empty string"} { + set result "" + lappend result [testobj newobj 1] + lappend result [catch {testdoubleobj div10 1} msg] + lappend result $msg +} {{} 1 {expected floating-point number but got ""}} + +test obj-17.1 {DupDoubleInternalRep} { + set result "" + lappend result [format %.6g [testdoubleobj set 1 17.1]] + lappend result [format %.6g [testobj duplicate 1 2]] ;# uses DupDoubleInternalRep + lappend result [format %.6g [testdoubleobj get 2]] +} {17.1 17.1 17.1} + +test obj-18.1 {SetDoubleFromAny, int to double special case} { + set result "" + lappend result [testintobj set 1 1234] + lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny + lappend result [testobj type 1] +} {1234 12340.0 double} +test obj-18.2 {SetDoubleFromAny, boolean to double special case} { + set result "" + lappend result [testbooleanobj set 1 1] + lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny + lappend result [testobj type 1] +} {1 10.0 double} +test obj-18.3 {SetDoubleFromAny, recompute string rep then parse it} { + set result "" + lappend result [testintobj set 1 456] + lappend result [testintobj div10 1] + lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny + lappend result [testobj type 1] +} {456 45 450.0 double} +test obj-18.4 {SetDoubleFromAny, error parsing string} { + set result "" + lappend result [teststringobj set 1 abc] + lappend result [catch {testdoubleobj mult10 1} msg] + lappend result $msg +} {abc 1 {expected floating-point number but got "abc"}} +test obj-18.5 {SetDoubleFromAny, error parsing string} { + set result "" + lappend result [teststringobj set 1 x1.0] + lappend result [catch {testdoubleobj mult10 1} msg] + lappend result $msg +} {x1.0 1 {expected floating-point number but got "x1.0"}} +test obj-18.6 {SetDoubleFromAny, error converting from "empty string"} { + set result "" + lappend result [testobj newobj 1] + lappend result [catch {testdoubleobj div10 1} msg] + lappend result $msg +} {{} 1 {expected floating-point number but got ""}} + +test obj-19.1 {UpdateStringOfDouble} { + set result "" + lappend result [format %.6g [testdoubleobj set 1 3.14159]] + lappend result [format %.6g [testdoubleobj mult10 1]] + lappend result [format %.6g [testdoubleobj get 1]] ;# must update string rep +} {3.14159 31.4159 31.4159} + +test obj-20.1 {Tcl_NewIntObj} { + set result "" + lappend result [testobj freeallvars] + lappend result [testintobj set 1 55] + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 55 int 2} + +test obj-21.1 {Tcl_SetIntObj, existing "empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testobj newobj 1] + lappend result [testintobj set 1 77] ;# makes existing obj int + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} {} 77 int 2} +test obj-21.2 {Tcl_SetIntObj, existing non-"empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testdoubleobj set 1 12.34] + lappend result [testintobj set 1 77] ;# makes existing obj int + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 12.34 77 int 2} + +test obj-22.1 {Tcl_GetIntFromObj, existing int object} { + set result "" + lappend result [testintobj set 1 22] + lappend result [testintobj mult10 1] ;# gets existing int rep +} {22 220} +test obj-22.2 {Tcl_GetIntFromObj, convert to int} { + set result "" + lappend result [testintobj set 1 477] + lappend result [testintobj div10 1] ;# must convert to bool + lappend result [testobj type 1] +} {477 47 int} +test obj-22.3 {Tcl_GetIntFromObj, error converting to int} { + set result "" + lappend result [teststringobj set 1 abc] + lappend result [catch {testintobj mult10 1} msg] + lappend result $msg +} {abc 1 {expected integer but got "abc"}} +test obj-22.4 {Tcl_GetIntFromObj, error converting from "empty string"} { + set result "" + lappend result [testobj newobj 1] + lappend result [catch {testintobj div10 1} msg] + lappend result $msg +} {{} 1 {expected integer but got ""}} +test obj-22.5 {Tcl_GetIntFromObj, integer too large to represent as non-long error} {nonPortable} { + set result "" + lappend result [testobj newobj 1] + lappend result [testintobj inttoobigtest 1] +} {{} 1} + +test obj-23.1 {DupIntInternalRep} { + set result "" + lappend result [testintobj set 1 23] + lappend result [testobj duplicate 1 2] ;# uses DupIntInternalRep + lappend result [testintobj get 2] +} {23 23 23} + +test obj-24.1 {SetIntFromAny, int to int special case} { + set result "" + lappend result [testintobj set 1 1234] + lappend result [testintobj mult10 1] ;# converts with SetIntFromAny + lappend result [testobj type 1] +} {1234 12340 int} +test obj-24.2 {SetIntFromAny, boolean to int special case} { + set result "" + lappend result [testbooleanobj set 1 1] + lappend result [testintobj mult10 1] ;# converts with SetIntFromAny + lappend result [testobj type 1] +} {1 10 int} +test obj-24.3 {SetIntFromAny, recompute string rep then parse it} { + set result "" + lappend result [testintobj set 1 456] + lappend result [testintobj div10 1] + lappend result [testintobj mult10 1] ;# converts with SetIntFromAny + lappend result [testobj type 1] +} {456 45 450 int} +test obj-24.4 {SetIntFromAny, error parsing string} { + set result "" + lappend result [teststringobj set 1 abc] + lappend result [catch {testintobj mult10 1} msg] + lappend result $msg +} {abc 1 {expected integer but got "abc"}} +test obj-24.5 {SetIntFromAny, error parsing string} { + set result "" + lappend result [teststringobj set 1 x17] + lappend result [catch {testintobj mult10 1} msg] + lappend result $msg +} {x17 1 {expected integer but got "x17"}} +test obj-24.6 {SetIntFromAny, integer too large} {nonPortable} { + set result "" + lappend result [teststringobj set 1 12345678901234567890] + lappend result [catch {testintobj mult10 1} msg] + lappend result $msg +} {12345678901234567890 1 {integer value too large to represent}} +test obj-24.7 {SetIntFromAny, error converting from "empty string"} { + set result "" + lappend result [testobj newobj 1] + lappend result [catch {testintobj div10 1} msg] + lappend result $msg +} {{} 1 {expected integer but got ""}} + +test obj-25.1 {UpdateStringOfInt} { + set result "" + lappend result [testintobj set 1 512] + lappend result [testintobj mult10 1] + lappend result [testintobj get 1] ;# must update string rep +} {512 5120 5120} + +test obj-26.1 {Tcl_NewLongObj} { + set result "" + lappend result [testobj freeallvars] + testintobj setmaxlong 1 + lappend result [testintobj ismaxlong 1] + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 1 int 1} + +test obj-27.1 {Tcl_SetLongObj, existing "empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testobj newobj 1] + lappend result [testintobj setlong 1 77] ;# makes existing obj long int + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} {} 77 int 2} +test obj-27.2 {Tcl_SetLongObj, existing non-"empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testdoubleobj set 1 12.34] + lappend result [testintobj setlong 1 77] ;# makes existing obj long int + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 12.34 77 int 2} + +test obj-28.1 {Tcl_GetLongFromObj, existing long integer object} { + set result "" + lappend result [testintobj setlong 1 22] + lappend result [testintobj mult10 1] ;# gets existing long int rep +} {22 220} +test obj-28.2 {Tcl_GetLongFromObj, convert to long} { + set result "" + lappend result [testintobj setlong 1 477] + lappend result [testintobj div10 1] ;# must convert to bool + lappend result [testobj type 1] +} {477 47 int} +test obj-28.3 {Tcl_GetLongFromObj, error converting to long integer} { + set result "" + lappend result [teststringobj set 1 abc] + lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int + lappend result $msg +} {abc 1 {expected integer but got "abc"}} +test obj-28.4 {Tcl_GetLongFromObj, error converting from "empty string"} { + set result "" + lappend result [testobj newobj 1] + lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int + lappend result $msg +} {{} 1 {expected integer but got ""}} + +test obj-29.1 {Ref counting and object deletion, simple types} { + set result "" + lappend result [testobj freeallvars] + lappend result [testintobj set 1 1024] + lappend result [testobj assign 1 2] ;# vars 1 and 2 share the int obj + lappend result [testobj type 2] + lappend result [testobj refcount 1] + lappend result [testobj refcount 2] + lappend result [testbooleanobj set 2 0] ;# must copy on write, now 2 objs + lappend result [testobj type 2] + lappend result [testobj refcount 1] + lappend result [testobj refcount 2] +} {{} 1024 1024 int 4 4 0 boolean 3 2} + +testobj freeallvars diff --git a/contrib/tcl/tests/osa.test b/contrib/tcl/tests/osa.test new file mode 100644 index 0000000000000..0e94838dbf5b5 --- /dev/null +++ b/contrib/tcl/tests/osa.test @@ -0,0 +1,36 @@ +# Commands covered: AppleScript +# +# 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) 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. +# +# SCCS: @(#) osa.test 1.4 97/06/23 18:24:24 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# This command only runs on the Macintosh, only run the test if we +# can load the command +if {$tcl_platform(platform) != "macintosh"} { + puts "skipping: Mac only tests..." + return +} +if {[info commands AppleScript] == ""} { + puts "couldn't find AppleScript command..." + return +} + +test osa-1.1 {Tcl_OSAComponentCmd} { + list [catch AppleScript msg] $msg +} {1 {wrong # args: should be "AppleScript option ?arg ...?"}} +test osa-1.2 {Tcl_OSAComponentCmd} { + list [catch {AppleScript x} msg] $msg +} {1 {bad option "x": should be compile, decompile, delete, execute, info, load, run or store}} + +test osa-1.3 {TclOSACompileCmd} { + list [catch {AppleScript compile} msg] $msg +} {1 {wrong # args: should be "AppleScript compile ?options? code"}} diff --git a/contrib/tcl/tests/parse.test b/contrib/tcl/tests/parse.test index fa1c6f5c653b9..124126287d352 100644 --- a/contrib/tcl/tests/parse.test +++ b/contrib/tcl/tests/parse.test @@ -6,12 +6,12 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) parse.test 1.34 96/03/02 14:29:03 +# SCCS: @(#) parse.test 1.40 97/06/23 18:19:53 if {[string compare test [info procs test]] == 1} then {source defs} @@ -121,6 +121,11 @@ format %s $b ]b set a } a22b +test parse-4.4 {command substitution} { + set a 7.7 + if [catch {expr int($a)}] {set a foo} + set a +} 7.7 # Variable substitution. @@ -209,7 +214,7 @@ catch {unset a}; catch {unset a1} set errNum 1 proc bsCheck {char num} { global errNum - test parse-6.$errNum {backslash substitution} { +; test parse-6.$errNum {backslash substitution} { scan $char %c value set value } $num @@ -336,22 +341,22 @@ test parse-9.3 {syntax errors} {catch {set a "bcd} msg} 1 test parse-9.4 {syntax errors} { catch {set a "bcd} msg set msg -} {missing "} +} {quoted string doesn't terminate properly} test parse-9.5 {syntax errors} {catch {set a "bcd"xy} msg} 1 test parse-9.6 {syntax errors} { catch {set a "bcd"xy} msg set msg -} {extra characters after close-quote} +} {quoted string doesn't terminate properly} test parse-9.7 {syntax errors} {catch "set a {bcd}xy" msg} 1 test parse-9.8 {syntax errors} { catch "set a {bcd}xy" msg set msg -} {extra characters after close-brace} +} {argument word in braces doesn't terminate properly} test parse-9.9 {syntax errors} {catch {set a [format abc} msg} 1 test parse-9.10 {syntax errors} { catch {set a [format abc} msg set msg -} {missing close-bracket} +} {missing close-bracket or close-brace} test parse-9.11 {syntax errors} {catch gorp-a-lot msg} 1 test parse-9.12 {syntax errors} { catch gorp-a-lot msg @@ -366,11 +371,27 @@ test parse-9.14 {syntax errors} { list [catch {eval \$x[format "%01000d" 0](} msg] $msg $errorInfo } {1 {missing )} {missing ) (parsing index for array "x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000") - invoked from within + while compiling "$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 ..." ("eval" body line 1) invoked from within "eval \$x[format "%01000d" 0]("}} +test parse-9.15 {syntax errors, missplaced braces} { + catch { + proc misplaced_end_brace {} { + set what foo + set when [expr ${what}size - [set off$what]}] + } msg + set msg +} {wrong # args: should be "proc name args body"} +test parse-9.16 {syntax errors, missplaced braces} { + catch { + set a { + set what foo + set when [expr ${what}size - [set off$what]}] + } msg + set msg +} {argument word in braces doesn't terminate properly} # Long values (stressing storage management) @@ -382,30 +403,30 @@ test parse-10.1 {long values} { test parse-10.2 {long values} { llength $a } 43 -test parse-1a1.3 {long values} { +test parse-10.3 {long values} { set b "1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH" set b } $a -test parse-10.3 {long values} { +test parse-10.4 {long values} { set b "$a" set b } $a -test parse-10.4 {long values} { +test parse-10.5 {long values} { set b [set a] set b } $a -test parse-10.5 {long values} { +test parse-10.6 {long values} { set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] string length $b } 214 -test parse-10.6 {long values} { +test parse-10.7 {long values} { set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] llength $b } 43 -test parse-10.7 {long values} { +test parse-10.8 {long values} { set b } $a -test parse-10.8 {long values} { +test parse-10.9 {long values} { set a [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] llength $a } 62 @@ -414,11 +435,11 @@ foreach j [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cc set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i] set test $test$test$test$test set i [expr $i+1] - test parse-10.9 {long values} { + test parse-10.10 {long values} { set j } $test } -test parse-10.10 {test buffer overflow in backslashes in braces} { +test parse-10.11 {test buffer overflow in backslashes in braces} { expr {"a" == {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101}} } 0 @@ -499,6 +520,21 @@ if {[info command testwordend] == "testwordend"} { test parse-13.16 {TclWordEnd procedure} { testwordend "abc" } {c} + test parse-13.17 {TclWordEnd procedure} { + testwordend "a\000bc" + } {c} + test parse-13.18 {TclWordEnd procedure} { + testwordend \[a\000\] + } {]} + test parse-13.19 {TclWordEnd procedure} { + testwordend \"a\000\" + } {"} + test parse-13.20 {TclWordEnd procedure} { + testwordend a{\000}b + } {b} + test parse-13.21 {TclWordEnd procedure} { + testwordend " \000b" + } {b} } test parse-14.1 {TclScriptEnd procedure} { diff --git a/contrib/tcl/tests/pkg.test b/contrib/tcl/tests/pkg.test index 66c165846122e..37a5b9ced9703 100644 --- a/contrib/tcl/tests/pkg.test +++ b/contrib/tcl/tests/pkg.test @@ -4,18 +4,18 @@ # 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) 1995 Sun Microsystems, Inc. +# Copyright (c) 1995-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) pkg.test 1.6 96/03/20 10:50:27 +# SCCS: @(#) pkg.test 1.9 96/11/15 17:56:01 if {[string compare test [info procs test]] == 1} then {source defs} eval package forget [package names] package unknown {} -set oldPath auto_path +set oldPath $auto_path set auto_path "" test pkg-1.1 {Tcl_PkgProvide procedure} { @@ -192,7 +192,7 @@ test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} { } {1 {testing package unknown} {testing package unknown while executing "error "testing package unknown"" - (procedure "pkgUnknown" line 2) + (procedure "pkgUnknown" line 1) invoked from within "pkgUnknown t {}" ("package unknown" script) @@ -545,5 +545,5 @@ test pkg-6.9 {ComparePkgVersions procedure} { package vsatisfies 2 1 } {0} -set auto_path oldPath +set auto_path $oldPath concat diff --git a/contrib/tcl/tests/policies/globalPolicy.tcl b/contrib/tcl/tests/policies/globalPolicy.tcl new file mode 100644 index 0000000000000..11904d4ffa5c3 --- /dev/null +++ b/contrib/tcl/tests/policies/globalPolicy.tcl @@ -0,0 +1,4 @@ +proc globalPolicy_PolicyInit {slave {version {}}} { + interp alias $slave tada {} tada $slave +} +proc tada {slave} {} diff --git a/contrib/tcl/tests/policies/packages/pkgA.tcl b/contrib/tcl/tests/policies/packages/pkgA.tcl new file mode 100644 index 0000000000000..d54d2215c2691 --- /dev/null +++ b/contrib/tcl/tests/policies/packages/pkgA.tcl @@ -0,0 +1,3 @@ +package provide packageA 1.0 + +proc hoohum {} {return bazooka} diff --git a/contrib/tcl/tests/policies/packages/pkgIndex.tcl b/contrib/tcl/tests/policies/packages/pkgIndex.tcl new file mode 100644 index 0000000000000..5d39a66ef355f --- /dev/null +++ b/contrib/tcl/tests/policies/packages/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.0 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded packageA 1.0 [list tclPkgSetup $dir packageA 1.0 {{pkgA.tcl source hoohum}}] diff --git a/contrib/tcl/tests/policies/policyA/policy.tcl b/contrib/tcl/tests/policies/policyA/policy.tcl new file mode 100644 index 0000000000000..cfd558f4160d4 --- /dev/null +++ b/contrib/tcl/tests/policies/policyA/policy.tcl @@ -0,0 +1,5 @@ +proc policyA_PolicyInit {slave {version {}}} { + interp alias $slave tada {} tada $slave +} +proc tada {slave} {} + diff --git a/contrib/tcl/tests/policies/policyA/tclIndex b/contrib/tcl/tests/policies/policyA/tclIndex new file mode 100644 index 0000000000000..5a555373249e5 --- /dev/null +++ b/contrib/tcl/tests/policies/policyA/tclIndex @@ -0,0 +1,9 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(policyA_PolicyInit) [list source [file join $dir policy.tcl]] diff --git a/contrib/tcl/tests/policies/policyB/policy.tcl b/contrib/tcl/tests/policies/policyB/policy.tcl new file mode 100644 index 0000000000000..51ceff7186f50 --- /dev/null +++ b/contrib/tcl/tests/policies/policyB/policy.tcl @@ -0,0 +1,2 @@ +proc policyB_PolicyInit {slave {version 1.0}} { +} diff --git a/contrib/tcl/tests/policies/policyB/tclIndex b/contrib/tcl/tests/policies/policyB/tclIndex new file mode 100644 index 0000000000000..8abf6d11d749f --- /dev/null +++ b/contrib/tcl/tests/policies/policyB/tclIndex @@ -0,0 +1,9 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(policyB_PolicyInit) [list source [file join $dir policy.tcl]] diff --git a/contrib/tcl/tests/policies/policyC/policy.tcl b/contrib/tcl/tests/policies/policyC/policy.tcl new file mode 100644 index 0000000000000..2615b316bbb65 --- /dev/null +++ b/contrib/tcl/tests/policies/policyC/policy.tcl @@ -0,0 +1,7 @@ +proc policyC_PolicyInit {slave {version 1.0}} { +} +proc policyC_PolicyCleanup {slave} { + global l + + lappend l bye +} diff --git a/contrib/tcl/tests/policies/policyC/tclIndex b/contrib/tcl/tests/policies/policyC/tclIndex new file mode 100644 index 0000000000000..d56e723a99697 --- /dev/null +++ b/contrib/tcl/tests/policies/policyC/tclIndex @@ -0,0 +1,10 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(policyC_PolicyInit) [list source [file join $dir policy.tcl]] +set auto_index(policyC_PolicyCleanup) [list source [file join $dir policy.tcl]] diff --git a/contrib/tcl/tests/policies/tclIndex b/contrib/tcl/tests/policies/tclIndex new file mode 100644 index 0000000000000..ce2fa7f02751b --- /dev/null +++ b/contrib/tcl/tests/policies/tclIndex @@ -0,0 +1,10 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(globalPolicy_PolicyInit) [list source [file join $dir globalPolicy.tcl]] +set auto_index(tada) [list source [file join $dir globalPolicy.tcl]] diff --git a/contrib/tcl/tests/proc-old.test b/contrib/tcl/tests/proc-old.test new file mode 100644 index 0000000000000..5da63359e9672 --- /dev/null +++ b/contrib/tcl/tests/proc-old.test @@ -0,0 +1,505 @@ +# Commands covered: proc, return, global +# +# This file, proc-old.test, includes the original set of tests for Tcl's +# proc, return, and global commands. There is now a new file proc.test +# that contains tests for the tclProc.c source file. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-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. +# +# SCCS: @(#) proc-old.test 1.30 97/04/30 14:14:47 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {rename t1 ""} +catch {rename foo ""} + +proc tproc {} {return a; return b} +test proc-old-1.1 {simple procedure call and return} {tproc} a +proc tproc x { + set x [expr $x+1] + return $x +} +test proc-old-1.2 {simple procedure call and return} {tproc 2} 3 +test proc-old-1.3 {simple procedure call and return} { + proc tproc {} {return foo} +} {} +test proc-old-1.4 {simple procedure call and return} { + proc tproc {} {return} + tproc +} {} +proc tproc1 {a} {incr a; return $a} +proc tproc2 {a b} {incr a; return $a} +test proc-old-1.5 {simple procedure call and return (2 procs with same body but different parameters)} { + list [tproc1 123] [tproc2 456 789] +} {124 457} +test proc-old-1.6 {simple procedure call and return (shared proc body string)} { + set x {} + proc tproc {} {} ;# body is shared with x + list [tproc] [append x foo] +} {{} foo} + +test proc-old-2.1 {local and global variables} { + proc tproc x { + set x [expr $x+1] + return $x + } + set x 42 + list [tproc 6] $x +} {7 42} +test proc-old-2.2 {local and global variables} { + proc tproc x { + set y [expr $x+1] + return $y + } + set y 18 + list [tproc 6] $y +} {7 18} +test proc-old-2.3 {local and global variables} { + proc tproc x { + global y + set y [expr $x+1] + return $y + } + set y 189 + list [tproc 6] $y +} {7 7} +test proc-old-2.4 {local and global variables} { + proc tproc x { + global y + return [expr $x+$y] + } + set y 189 + list [tproc 6] $y +} {195 189} +catch {unset _undefined_} +test proc-old-2.5 {local and global variables} { + proc tproc x { + global _undefined_ + return $_undefined_ + } + list [catch {tproc xxx} msg] $msg +} {1 {can't read "_undefined_": no such variable}} +test proc-old-2.6 {local and global variables} { + set a 114 + set b 115 + global a b + list $a $b +} {114 115} + +proc do {cmd} {eval $cmd} +test proc-old-3.1 {local and global arrays} { + catch {unset a} + set a(0) 22 + list [catch {do {global a; set a(0)}} msg] $msg +} {0 22} +test proc-old-3.2 {local and global arrays} { + catch {unset a} + set a(x) 22 + list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x) +} {0 newValue newValue} +test proc-old-3.3 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + list [catch {do {global a; unset a(y)}; array names a} msg] $msg +} {0 x} +test proc-old-3.4 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + list [catch {do {global a; unset a; info exists a}} msg] $msg \ + [info exists a] +} {0 0 0} +test proc-old-3.5 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + list [catch {do {global a; unset a(y); array names a}} msg] $msg +} {0 x} +catch {unset a} +test proc-old-3.6 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + do {global a; do {global a; unset a}; set a(z) 22} + list [catch {array names a} msg] $msg +} {0 z} +test proc-old-3.7 {local and global arrays} { + proc t1 {args} {global info; set info 1} + catch {unset a} + set info {} + do {global a; trace var a(1) w t1} + set a(1) 44 + set info +} 1 +test proc-old-3.8 {local and global arrays} { + proc t1 {args} {global info; set info 1} + catch {unset a} + trace var a(1) w t1 + set info {} + do {global a; trace vdelete a(1) w t1} + set a(1) 44 + set info +} {} +test proc-old-3.9 {local and global arrays} { + proc t1 {args} {global info; set info 1} + catch {unset a} + trace var a(1) w t1 + do {global a; trace vinfo a(1)} +} {{w t1}} +catch {unset a} + +test proc-old-3.1 {arguments and defaults} { + proc tproc {x y z} { + return [list $x $y $z] + } + tproc 11 12 13 +} {11 12 13} +test proc-old-3.2 {arguments and defaults} { + proc tproc {x y z} { + return [list $x $y $z] + } + list [catch {tproc 11 12} msg] $msg +} {1 {no value given for parameter "z" to "tproc"}} +test proc-old-3.3 {arguments and defaults} { + proc tproc {x y z} { + return [list $x $y $z] + } + list [catch {tproc 11 12 13 14} msg] $msg +} {1 {called "tproc" with too many arguments}} +test proc-old-3.4 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + tproc 11 12 13 +} {11 12 13} +test proc-old-3.5 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + tproc 11 12 +} {11 12 z-default} +test proc-old-3.6 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + tproc 11 +} {11 y-default z-default} +test proc-old-3.7 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + list [catch {tproc} msg] $msg +} {1 {no value given for parameter "x" to "tproc"}} +test proc-old-3.8 {arguments and defaults} { + list [catch { + proc tproc {x {y y-default} z} { + return [list $x $y $z] + } + tproc 2 3 + } msg] $msg +} {1 {no value given for parameter "z" to "tproc"}} +test proc-old-3.9 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + tproc 2 3 4 5 +} {2 3 {4 5}} +test proc-old-3.10 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + tproc 2 3 +} {2 3 {}} +test proc-old-3.11 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + tproc 2 +} {2 y-default {}} +test proc-old-3.12 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + list [catch {tproc} msg] $msg +} {1 {no value given for parameter "x" to "tproc"}} + +test proc-old-4.1 {variable numbers of arguments} { + proc tproc args {return $args} + tproc +} {} +test proc-old-4.2 {variable numbers of arguments} { + proc tproc args {return $args} + tproc 1 2 3 4 5 6 7 8 +} {1 2 3 4 5 6 7 8} +test proc-old-4.3 {variable numbers of arguments} { + proc tproc args {return $args} + tproc 1 {2 3} {4 {5 6} {{{7}}}} 8 +} {1 {2 3} {4 {5 6} {{{7}}}} 8} +test proc-old-4.4 {variable numbers of arguments} { + proc tproc {x y args} {return $args} + tproc 1 2 3 4 5 6 7 +} {3 4 5 6 7} +test proc-old-4.5 {variable numbers of arguments} { + proc tproc {x y args} {return $args} + tproc 1 2 +} {} +test proc-old-4.6 {variable numbers of arguments} { + proc tproc {x missing args} {return $args} + list [catch {tproc 1} msg] $msg +} {1 {no value given for parameter "missing" to "tproc"}} + +test proc-old-5.1 {error conditions} { + list [catch {proc} msg] $msg +} {1 {wrong # args: should be "proc name args body"}} +test proc-old-5.2 {error conditions} { + list [catch {proc tproc b} msg] $msg +} {1 {wrong # args: should be "proc name args body"}} +test proc-old-5.3 {error conditions} { + list [catch {proc tproc b c d e} msg] $msg +} {1 {wrong # args: should be "proc name args body"}} +test proc-old-5.4 {error conditions} { + list [catch {proc tproc \{xyz {return foo}} msg] $msg +} {1 {unmatched open brace in list}} +test proc-old-5.5 {error conditions} { + list [catch {proc tproc {{} y} {return foo}} msg] $msg +} {1 {procedure "tproc" has argument with no name}} +test proc-old-5.6 {error conditions} { + list [catch {proc tproc {{} y} {return foo}} msg] $msg +} {1 {procedure "tproc" has argument with no name}} +test proc-old-5.7 {error conditions} { + list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg +} {1 {too many fields in argument specifier "x 1 2"}} +test proc-old-5.8 {error conditions} { + catch {return} +} 2 +test proc-old-5.9 {error conditions} { + list [catch {global} msg] $msg +} {1 {wrong # args: should be "global varName ?varName ...?"}} +proc tproc {} { + set a 22 + global a +} +test proc-old-5.10 {error conditions} { + list [catch {tproc} msg] $msg +} {1 {variable "a" already exists}} +test proc-old-5.11 {error conditions} { + catch {rename tproc {}} + catch { + proc tproc {x {} z} {return foo} + } + list [catch {tproc 1} msg] $msg +} {1 {invalid command name "tproc"}} +test proc-old-5.12 {error conditions} { + proc tproc {} { + set a 22 + error "error in procedure" + return + } + list [catch tproc msg] $msg +} {1 {error in procedure}} +test proc-old-5.13 {error conditions} { + proc tproc {} { + set a 22 + error "error in procedure" + return + } + catch tproc msg + set errorInfo +} {error in procedure + while executing +"error "error in procedure"" + (procedure "tproc" line 1) + invoked from within +"tproc"} +test proc-old-5.14 {error conditions} { + proc tproc {} { + set a 22 + break + return + } + catch tproc msg + set errorInfo +} {invoked "break" outside of a loop + while executing +"tproc"} +test proc-old-5.15 {error conditions} { + proc tproc {} { + set a 22 + continue + return + } + catch tproc msg + set errorInfo +} {invoked "continue" outside of a loop + while executing +"tproc"} +test proc-old-5.16 {error conditions} { + proc foo args { + global fooMsg + set fooMsg "foo was called: $args" + } + proc tproc {} { + set x 44 + trace var x u foo + while {$x < 100} { + error "Nested error" + } + } + set fooMsg "foo not called" + list [catch tproc msg] $msg $errorInfo $fooMsg +} {1 {Nested error} {Nested error + while executing +"error "Nested error"" + (procedure "tproc" line 1) + invoked from within +"tproc"} {foo was called: x {} u}} + +# The tests below will really only be useful when run under Purify or +# some other system that can detect accesses to freed memory... + +test proc-old-6.1 {procedure that redefines itself} { + proc tproc {} { + proc tproc {} { + return 44 + } + return 45 + } + tproc +} 45 +test proc-old-6.2 {procedure that deletes itself} { + proc tproc {} { + rename tproc {} + return 45 + } + tproc +} 45 + +proc tproc code { + return -code $code abc +} +test proc-old-7.1 {return with special completion code} { + list [catch {tproc ok} msg] $msg +} {0 abc} +test proc-old-7.2 {return with special completion code} { + list [catch {tproc error} msg] $msg $errorInfo $errorCode +} {1 abc {abc + while executing +"tproc error"} NONE} +test proc-old-7.3 {return with special completion code} { + list [catch {tproc return} msg] $msg +} {2 abc} +test proc-old-7.4 {return with special completion code} { + list [catch {tproc break} msg] $msg +} {3 abc} +test proc-old-7.5 {return with special completion code} { + list [catch {tproc continue} msg] $msg +} {4 abc} +test proc-old-7.6 {return with special completion code} { + list [catch {tproc -14} msg] $msg +} {-14 abc} +test proc-old-7.7 {return with special completion code} { + list [catch {tproc gorp} msg] $msg +} {1 {bad completion code "gorp": must be ok, error, return, break, continue, or an integer}} +test proc-old-7.8 {return with special completion code} { + list [catch {tproc 10b} msg] $msg +} {1 {bad completion code "10b": must be ok, error, return, break, continue, or an integer}} +test proc-old-7.9 {return with special completion code} { + proc tproc2 {} { + tproc return + } + list [catch tproc2 msg] $msg +} {0 abc} +test proc-old-7.10 {return with special completion code} { + proc tproc2 {} { + return -code error + } + list [catch tproc2 msg] $msg +} {1 {}} +test proc-old-7.11 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error -errorinfo $errorInfo -errorcode $errorCode $msg + } + normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory + while executing +"open _bad_file_name r" + invoked from within +"tproc2"} {posix enoent {no such file or directory}}} +test proc-old-7.12 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error -errorcode $errorCode $msg + } + normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory + while executing +"tproc2"} {posix enoent {no such file or directory}}} +test proc-old-7.13 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error -errorinfo $errorInfo $msg + } + normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory + while executing +"open _bad_file_name r" + invoked from within +"tproc2"} none} +test proc-old-7.14 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error $msg + } + normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory + while executing +"tproc2"} none} +test proc-old-7.14 {return with special completion code} { + list [catch {return -badOption foo message} msg] $msg +} {1 {bad option "-badOption": must be -code, -errorcode, or -errorinfo}} + +test proc-old-8.1 {unset and undefined local arrays} { + proc t1 {} { + foreach v {xxx, yyy} { + catch {unset $v} + } + set yyy(foo) bar + } + t1 +} bar + +test proc-old-9.1 {empty command name} { + catch {rename {} ""} + proc t1 {args} { + return + } + set v [t1] + catch {$v} +} 1 + +test proc-old-10.1 {ByteCode epoch change during recursive proc execution} { + proc t1 x { + set y 20 + rename expr expr.old + rename expr.old expr + if $x then {t1 0} ;# recursive call after foo's code is invalidated + return 20 + } + t1 1 +} 20 + +catch {rename t1 ""} +catch {rename foo ""} diff --git a/contrib/tcl/tests/proc.test b/contrib/tcl/tests/proc.test index 6eef73c858148..96473998fd209 100644 --- a/contrib/tcl/tests/proc.test +++ b/contrib/tcl/tests/proc.test @@ -1,461 +1,159 @@ -# Commands covered: proc, return, global +# This file contains tests for the tclProc.c source file. Tests appear in +# the same order as the C code that they test. The set of tests is +# currently incomplete since it currently includes only new tests for +# code changed for the addition of Tcl namespaces. Other procedure- +# related tests appear in other test files including proc-old.test. # -# 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. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) proc.test 1.21 96/02/16 08:56:21 +# SCCS: @(#) proc.test 1.9 97/06/20 18:55:03 if {[string compare test [info procs test]] == 1} then {source defs} -proc tproc {} {return a; return b} -test proc-1.1 {simple procedure call and return} {tproc} a -proc tproc x { - set x [expr $x+1] - return $x -} -test proc-1.2 {simple procedure call and return} {tproc 2} 3 -test proc-1.3 {simple procedure call and return} { - proc tproc {} {return foo} -} {} -test proc-1.4 {simple procedure call and return} { - proc tproc {} {return} - tproc -} {} +catch {eval namespace delete [namespace children :: test_ns_*]} +catch {rename p ""} +catch {rename {} ""} +catch {unset msg} -test proc-2.1 {local and global variables} { - proc tproc x { - set x [expr $x+1] - return $x - } - set x 42 - list [tproc 6] $x -} {7 42} -test proc-2.2 {local and global variables} { - proc tproc x { - set y [expr $x+1] - return $y - } - set y 18 - list [tproc 6] $y -} {7 18} -test proc-2.3 {local and global variables} { - proc tproc x { - global y - set y [expr $x+1] - return $y - } - set y 189 - list [tproc 6] $y -} {7 7} -test proc-2.4 {local and global variables} { - proc tproc x { - global y - return [expr $x+$y] - } - set y 189 - list [tproc 6] $y -} {195 189} -catch {unset _undefined_} -test proc-2.5 {local and global variables} { - proc tproc x { - global _undefined_ - return $_undefined_ - } - list [catch {tproc xxx} msg] $msg -} {1 {can't read "_undefined_": no such variable}} -test proc-2.6 {local and global variables} { - set a 114 - set b 115 - global a b - list $a $b -} {114 115} +test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 { + namespace eval baz {} + } + proc test_ns_1::baz::p {} { + return "p in [namespace current]" + } + list [test_ns_1::baz::p] \ + [namespace eval test_ns_1 {baz::p}] \ + [info commands test_ns_1::baz::*] +} {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p} +test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {proc test_ns_1::baz::p {} {}} msg] $msg +} {1 {can't create procedure "test_ns_1::baz::p": unknown namespace}} +test proc-1.3 {Tcl_ProcObjCmd, empty proc name} { + catch {eval namespace delete [namespace children :: test_ns_*]} + proc :: {} { + return "empty called" + } + list [::] \ + [info body {}] +} {{empty called} { + return "empty called" + }} +test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 { + namespace eval baz { + proc p {} { + return "p in [namespace current]" + } + } + } + list [test_ns_1::baz::p] \ + [info commands test_ns_1::baz::*] +} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p} +test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::baz {} + namespace eval test_ns_1 { + proc baz::p {} { + return "p in [namespace current]" + } + } + list [test_ns_1::baz::p] \ + [info commands test_ns_1::baz::*] \ + [namespace eval test_ns_1::baz {namespace which p}] +} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p} +test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc q: {} {return "q:"} + proc value:at: {} {return "value:at:"} + } + list [namespace eval test_ns_1 {q:}] \ + [namespace eval test_ns_1 {value:at:}] \ + [test_ns_1::q:] \ + [test_ns_1::value:at:] \ + [lsort [info commands test_ns_1::*]] \ + [namespace eval test_ns_1 {namespace which q:}] \ + [namespace eval test_ns_1 {namespace which value:at:}] +} {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:} +test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} { + catch {rename p ""} + list [catch {proc p {a(1) a(2)} { + set z [expr $a(1)+$a(2)] + puts "$z=z, $a(1)=$a(1)" + }} msg] $msg +} {1 {procedure "p" has formal parameter "a(1)" that is an array element}} -proc do {cmd} {eval $cmd} -test proc-3.1 {local and global arrays} { - catch {unset a} - set a(0) 22 - list [catch {do {global a; set a(0)}} msg] $msg -} {0 22} -test proc-3.2 {local and global arrays} { - catch {unset a} - set a(x) 22 - list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x) -} {0 newValue newValue} -test proc-3.3 {local and global arrays} { - catch {unset a} - set a(x) 22 - set a(y) 33 - list [catch {do {global a; unset a(y)}; array names a} msg] $msg -} {0 x} -test proc-3.4 {local and global arrays} { - catch {unset a} - set a(x) 22 - set a(y) 33 - list [catch {do {global a; unset a; info exists a}} msg] $msg \ - [info exists a] -} {0 0 0} -test proc-3.5 {local and global arrays} { - catch {unset a} - set a(x) 22 - set a(y) 33 - list [catch {do {global a; unset a(y); array names a}} msg] $msg -} {0 x} -catch {unset a} -test proc-3.6 {local and global arrays} { - catch {unset a} - set a(x) 22 - set a(y) 33 - do {global a; do {global a; unset a}; set a(z) 22} - list [catch {array names a} msg] $msg -} {0 z} -test proc-3.7 {local and global arrays} { - proc t1 {args} {global info; set info 1} - catch {unset a} - set info {} - do {global a; trace var a(1) w t1} - set a(1) 44 - set info -} 1 -test proc-3.8 {local and global arrays} { - proc t1 {args} {global info; set info 1} - catch {unset a} - trace var a(1) w t1 - set info {} - do {global a; trace vdelete a(1) w t1} - set a(1) 44 - set info -} {} -test proc-3.9 {local and global arrays} { - proc t1 {args} {global info; set info 1} - catch {unset a} - trace var a(1) w t1 - do {global a; trace vinfo a(1)} -} {{w t1}} -catch {unset a} - -test proc-3.1 {arguments and defaults} { - proc tproc {x y z} { - return [list $x $y $z] - } - tproc 11 12 13 -} {11 12 13} -test proc-3.2 {arguments and defaults} { - proc tproc {x y z} { - return [list $x $y $z] - } - list [catch {tproc 11 12} msg] $msg -} {1 {no value given for parameter "z" to "tproc"}} -test proc-3.3 {arguments and defaults} { - proc tproc {x y z} { - return [list $x $y $z] - } - list [catch {tproc 11 12 13 14} msg] $msg -} {1 {called "tproc" with too many arguments}} -test proc-3.4 {arguments and defaults} { - proc tproc {x {y y-default} {z z-default}} { - return [list $x $y $z] - } - tproc 11 12 13 -} {11 12 13} -test proc-3.5 {arguments and defaults} { - proc tproc {x {y y-default} {z z-default}} { - return [list $x $y $z] - } - tproc 11 12 -} {11 12 z-default} -test proc-3.6 {arguments and defaults} { - proc tproc {x {y y-default} {z z-default}} { - return [list $x $y $z] - } - tproc 11 -} {11 y-default z-default} -test proc-3.7 {arguments and defaults} { - proc tproc {x {y y-default} {z z-default}} { - return [list $x $y $z] - } - list [catch {tproc} msg] $msg -} {1 {no value given for parameter "x" to "tproc"}} -test proc-3.8 {arguments and defaults} { - list [catch { - proc tproc {x {y y-default} z} { - return [list $x $y $z] - } - tproc 2 3 - } msg] $msg -} {1 {no value given for parameter "z" to "tproc"}} -test proc-3.9 {arguments and defaults} { - proc tproc {x {y y-default} args} { - return [list $x $y $args] - } - tproc 2 3 4 5 -} {2 3 {4 5}} -test proc-3.10 {arguments and defaults} { - proc tproc {x {y y-default} args} { - return [list $x $y $args] - } - tproc 2 3 -} {2 3 {}} -test proc-3.11 {arguments and defaults} { - proc tproc {x {y y-default} args} { - return [list $x $y $args] - } - tproc 2 -} {2 y-default {}} -test proc-3.12 {arguments and defaults} { - proc tproc {x {y y-default} args} { - return [list $x $y $args] - } - list [catch {tproc} msg] $msg -} {1 {no value given for parameter "x" to "tproc"}} +test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename p ""} + proc p {} {return "p in [namespace current]"} + info body p +} {return "p in [namespace current]"} +test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 { + namespace eval baz { + proc p {} {return "p in [namespace current]"} + } + } + namespace eval test_ns_1::baz {info body p} +} {return "p in [namespace current]"} +test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::baz {} + namespace eval test_ns_1 { + proc baz::p {} {return "p in [namespace current]"} + } + namespace eval test_ns_1 {info body baz::p} +} {return "p in [namespace current]"} +test proc-2.4 {TclFindProc, global proc and executing in namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename p ""} + proc p {} {return "global p"} + namespace eval test_ns_1::baz {info body p} +} {return "global p"} -test proc-4.1 {variable numbers of arguments} { - proc tproc args {return $args} - tproc -} {} -test proc-4.2 {variable numbers of arguments} { - proc tproc args {return $args} - tproc 1 2 3 4 5 6 7 8 -} {1 2 3 4 5 6 7 8} -test proc-4.3 {variable numbers of arguments} { - proc tproc args {return $args} - tproc 1 {2 3} {4 {5 6} {{{7}}}} 8 -} {1 {2 3} {4 {5 6} {{{7}}}} 8} -test proc-4.4 {variable numbers of arguments} { - proc tproc {x y args} {return $args} - tproc 1 2 3 4 5 6 7 -} {3 4 5 6 7} -test proc-4.5 {variable numbers of arguments} { - proc tproc {x y args} {return $args} - tproc 1 2 -} {} -test proc-4.6 {variable numbers of arguments} { - proc tproc {x missing args} {return $args} - list [catch {tproc 1} msg] $msg -} {1 {no value given for parameter "missing" to "tproc"}} +test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + proc p {} {return "p in [namespace current]"} + p +} {p in ::} +test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::baz { + proc p {} {return "p in [namespace current]"} + p + } +} {p in ::test_ns_1::baz} +test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename p ""} + proc p {} {return "p in [namespace current]"} + namespace eval test_ns_1::baz { + p + } +} {p in ::} +test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename p ""} + namespace eval test_ns_1::baz { + proc p {} {return "p in [namespace current]"} + rename ::test_ns_1::baz::p ::p + list [p] [namespace which p] + } +} {{p in ::test_ns_1::baz} ::p} -test proc-5.1 {error conditions} { - list [catch {proc} msg] $msg -} {1 {wrong # args: should be "proc name args body"}} -test proc-5.2 {error conditions} { - list [catch {proc tproc b} msg] $msg -} {1 {wrong # args: should be "proc name args body"}} -test proc-5.3 {error conditions} { - list [catch {proc tproc b c d e} msg] $msg -} {1 {wrong # args: should be "proc name args body"}} -test proc-5.4 {error conditions} { - list [catch {proc tproc \{xyz {return foo}} msg] $msg -} {1 {unmatched open brace in list}} -test proc-5.5 {error conditions} { - list [catch {proc tproc {{} y} {return foo}} msg] $msg -} {1 {procedure "tproc" has argument with no name}} -test proc-5.6 {error conditions} { - list [catch {proc tproc {{} y} {return foo}} msg] $msg -} {1 {procedure "tproc" has argument with no name}} -test proc-5.7 {error conditions} { - list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg -} {1 {too many fields in argument specifier "x 1 2"}} -test proc-5.8 {error conditions} { - catch {return} -} 2 -test proc-5.9 {error conditions} { - list [catch {global} msg] $msg -} {1 {wrong # args: should be "global varName ?varName ...?"}} -proc tproc {} { - set a 22 - global a -} -test proc-5.10 {error conditions} { - list [catch {tproc} msg] $msg -} {1 {variable "a" already exists}} -test proc-5.11 {error conditions} { - catch {rename tproc {}} - catch { - proc tproc {x {} z} {return foo} - } - list [catch {tproc 1} msg] $msg -} {1 {invalid command name "tproc"}} -test proc-5.12 {error conditions} { - proc tproc {} { - set a 22 - error "error in procedure" - return - } - list [catch tproc msg] $msg -} {1 {error in procedure}} -test proc-5.13 {error conditions} { - proc tproc {} { - set a 22 - error "error in procedure" - return - } - catch tproc msg - set errorInfo -} {error in procedure - while executing -"error "error in procedure"" - (procedure "tproc" line 3) - invoked from within -"tproc"} -test proc-5.14 {error conditions} { - proc tproc {} { - set a 22 - break - return - } - catch tproc msg - set errorInfo -} {invoked "break" outside of a loop - while executing -"tproc"} -test proc-5.15 {error conditions} { - proc tproc {} { - set a 22 - continue - return - } - catch tproc msg - set errorInfo -} {invoked "continue" outside of a loop - while executing -"tproc"} -test proc-5.16 {error conditions} { - proc foo args { - global fooMsg - set fooMsg "foo was called: $args" - } - proc tproc {} { - set x 44 - trace var x u foo - while {$x < 100} { - error "Nested error" - } - } - set fooMsg "foo not called" - list [catch tproc msg] $msg $errorInfo $fooMsg -} {1 {Nested error} {Nested error - while executing -"error "Nested error"" - ("while" body line 2) - invoked from within -"while {$x < 100} { - error "Nested error" - }" - (procedure "tproc" line 4) - invoked from within -"tproc"} {foo was called: x {} u}} - -# The tests below will really only be useful when run under Purify or -# some other system that can detect accesses to freed memory... - -test proc-6.1 {procedure that redefines itself} { - proc tproc {} { - proc tproc {} { - return 44 - } - return 45 - } - tproc -} 45 -test proc-6.2 {procedure that deletes itself} { - proc tproc {} { - rename tproc {} - return 45 - } - tproc -} 45 - -proc tproc code { - return -code $code abc -} -test proc-7.1 {return with special completion code} { - list [catch {tproc ok} msg] $msg -} {0 abc} -test proc-7.2 {return with special completion code} { - list [catch {tproc error} msg] $msg $errorInfo $errorCode -} {1 abc {abc - while executing -"tproc error"} NONE} -test proc-7.3 {return with special completion code} { - list [catch {tproc return} msg] $msg -} {2 abc} -test proc-7.4 {return with special completion code} { - list [catch {tproc break} msg] $msg -} {3 abc} -test proc-7.5 {return with special completion code} { - list [catch {tproc continue} msg] $msg -} {4 abc} -test proc-7.6 {return with special completion code} { - list [catch {tproc -14} msg] $msg -} {-14 abc} -test proc-7.7 {return with special completion code} { - list [catch {tproc gorp} msg] $msg -} {1 {bad completion code "gorp": must be ok, error, return, break, continue, or an integer}} -test proc-7.8 {return with special completion code} { - list [catch {tproc 10b} msg] $msg -} {1 {bad completion code "10b": must be ok, error, return, break, continue, or an integer}} -test proc-7.9 {return with special completion code} { - proc tproc2 {} { - tproc return - } - list [catch tproc2 msg] $msg -} {0 abc} -test proc-7.10 {return with special completion code} { - proc tproc2 {} { - return -code error - } - list [catch tproc2 msg] $msg -} {1 {}} -test proc-7.11 {return with special completion code} { - proc tproc2 {} { - global errorCode errorInfo - catch {open _bad_file_name r} msg - return -code error -errorinfo $errorInfo -errorcode $errorCode $msg - } - normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] -} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory - while executing -"open _bad_file_name r" - invoked from within -"tproc2"} {posix enoent {no such file or directory}}} -test proc-7.12 {return with special completion code} { - proc tproc2 {} { - global errorCode errorInfo - catch {open _bad_file_name r} msg - return -code error -errorcode $errorCode $msg - } - normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] -} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory - while executing -"tproc2"} {posix enoent {no such file or directory}}} -test proc-7.13 {return with special completion code} { - proc tproc2 {} { - global errorCode errorInfo - catch {open _bad_file_name r} msg - return -code error -errorinfo $errorInfo $msg - } - normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] -} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory - while executing -"open _bad_file_name r" - invoked from within -"tproc2"} none} -test proc-7.14 {return with special completion code} { - proc tproc2 {} { - global errorCode errorInfo - catch {open _bad_file_name r} msg - return -code error $msg - } - normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] -} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory - while executing -"tproc2"} none} -test proc-7.14 {return with special completion code} { - list [catch {return -badOption foo message} msg] $msg -} {1 {bad option "-badOption: must be -code, -errorcode, or -errorinfo}} +catch {eval namespace delete [namespace children :: test_ns_*]} +catch {rename p ""} +catch {rename {} ""} +catch {unset msg} diff --git a/contrib/tcl/tests/regexp.test b/contrib/tcl/tests/regexp.test index 1f1aecffc2a48..5fb785be3d32d 100644 --- a/contrib/tcl/tests/regexp.test +++ b/contrib/tcl/tests/regexp.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) regexp.test 1.20 96/04/02 15:03:53 +# SCCS: @(#) regexp.test 1.21 96/12/23 13:59:48 if {[string compare test [info procs test]] == 1} then {source defs} @@ -27,6 +27,9 @@ test regexp-1.3 {basic regexp operation} { test regexp-1.4 {basic regexp operation} { regexp -- -gorp abc-gorpxxx } 1 +test regexp-1.5 {basic regexp operation} { + regexp {^([^ ]*)[ ]*([^ ]*)} "" a +} 1 test regexp-2.1 {getting substrings back from regexp} { set foo {} diff --git a/contrib/tcl/tests/registry.test b/contrib/tcl/tests/registry.test new file mode 100644 index 0000000000000..6a6b99ff958cf --- /dev/null +++ b/contrib/tcl/tests/registry.test @@ -0,0 +1,507 @@ +# registry.test -- +# +# This file contains a collection of tests for the registry command. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# In order for these tests to run, the registry package must be on the +# auto_path or the registry package must have been loaded already. +# +# Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. +# +# SCCS: @(#) registry.test 1.3 97/02/11 16:58:43 + +if {$tcl_platform(platform) != "windows"} { + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +if [catch {package require registry}] { + puts "Unable to find the registry package. Skipping registry tests." + return +} + +switch $tcl_platform(os) { + "Windows NT" {set testConfig(NT) 1} + "Windows 95" {set testConfig(95) 1} +} + +set hostname [info hostname] + +test registry-1.1 {argument parsing for registry command} { + list [catch {registry} msg] $msg +} {1 {wrong # args: should be "registry option ?arg arg ...?"}} +test registry-1.2 {argument parsing for registry command} { + list [catch {registry foo} msg] $msg +} {1 {bad option "foo": must be delete, get, keys, set, type, or values}} + +test registry-1.3 {argument parsing for registry command} { + list [catch {registry d} msg] $msg +} {1 {wrong # args: should be "registry d keyName ?valueName?"}} +test registry-1.4 {argument parsing for registry command} { + list [catch {registry delete} msg] $msg +} {1 {wrong # args: should be "registry delete keyName ?valueName?"}} +test registry-1.5 {argument parsing for registry command} { + list [catch {registry delete foo bar baz} msg] $msg +} {1 {wrong # args: should be "registry delete keyName ?valueName?"}} + +test registry-1.6 {argument parsing for registry command} { + list [catch {registry g} msg] $msg +} {1 {wrong # args: should be "registry g keyName valueName"}} +test registry-1.7 {argument parsing for registry command} { + list [catch {registry get} msg] $msg +} {1 {wrong # args: should be "registry get keyName valueName"}} +test registry-1.8 {argument parsing for registry command} { + list [catch {registry get foo} msg] $msg +} {1 {wrong # args: should be "registry get keyName valueName"}} +test registry-1.9 {argument parsing for registry command} { + list [catch {registry get foo bar baz} msg] $msg +} {1 {wrong # args: should be "registry get keyName valueName"}} + +test registry-1.10 {argument parsing for registry command} { + list [catch {registry k} msg] $msg +} {1 {wrong # args: should be "registry k keyName ?pattern?"}} +test registry-1.11 {argument parsing for registry command} { + list [catch {registry keys} msg] $msg +} {1 {wrong # args: should be "registry keys keyName ?pattern?"}} +test registry-1.12 {argument parsing for registry command} { + list [catch {registry keys foo bar baz} msg] $msg +} {1 {wrong # args: should be "registry keys keyName ?pattern?"}} + +test registry-1.13 {argument parsing for registry command} { + list [catch {registry s} msg] $msg +} {1 {wrong # args: should be "registry s keyName ?valueName data ?type??"}} +test registry-1.14 {argument parsing for registry command} { + list [catch {registry set} msg] $msg +} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}} +test registry-1.15 {argument parsing for registry command} { + list [catch {registry set foo bar} msg] $msg +} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}} +test registry-1.16 {argument parsing for registry command} { + list [catch {registry set foo bar baz blat gorp} msg] $msg +} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}} + +test registry-1.17 {argument parsing for registry command} { + list [catch {registry t} msg] $msg +} {1 {wrong # args: should be "registry t keyName valueName"}} +test registry-1.18 {argument parsing for registry command} { + list [catch {registry type} msg] $msg +} {1 {wrong # args: should be "registry type keyName valueName"}} +test registry-1.19 {argument parsing for registry command} { + list [catch {registry type foo} msg] $msg +} {1 {wrong # args: should be "registry type keyName valueName"}} +test registry-1.20 {argument parsing for registry command} { + list [catch {registry type foo bar baz} msg] $msg +} {1 {wrong # args: should be "registry type keyName valueName"}} + +test registry-1.21 {argument parsing for registry command} { + list [catch {registry v} msg] $msg +} {1 {wrong # args: should be "registry v keyName ?pattern?"}} +test registry-1.22 {argument parsing for registry command} { + list [catch {registry values} msg] $msg +} {1 {wrong # args: should be "registry values keyName ?pattern?"}} +test registry-1.23 {argument parsing for registry command} { + list [catch {registry values foo bar baz} msg] $msg +} {1 {wrong # args: should be "registry values keyName ?pattern?"}} + +test registry-2.1 {DeleteKey: bad key} { + list [catch {registry delete foo} msg] $msg +} {1 {bad root name "foo": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} +test registry-2.2 {DeleteKey: bad key} { + list [catch {registry delete HKEY_CLASSES_ROOT} msg] $msg +} {1 {bad key: cannot delete root keys}} +test registry-2.3 {DeleteKey: bad key} { + list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg +} {1 {bad key: cannot delete root keys}} +test registry-2.4 {DeleteKey: subkey at root level} { + registry set HKEY_CLASSES_ROOT\\TclFoobar + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry keys HKEY_CLASSES_ROOT TclFoobar +} {} +test registry-2.5 {DeleteKey: subkey below root level} { + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test + registry delete HKEY_CLASSES_ROOT\\TclFoobar\\test + set result [registry keys HKEY_CLASSES_ROOT TclFoobar\\test] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {} +test registry-2.6 {DeleteKey: recursive delete} { + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1 + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3 + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result [registry keys HKEY_CLASSES_ROOT TclFoobar] + set result +} {} +test registry-2.7 {DeleteKey: trailing backslashes} { + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz + list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar\\} msg] $msg +} {1 {unable to delete key: The configuration registry key is invalid.}} +test registry-2.8 {DeleteKey: failure} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry delete HKEY_CLASSES_ROOT\\TclFoobar +} {} + + +test registry-3.1 {DeleteValue} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test1 blort + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test2 blat + registry delete HKEY_CLASSES_ROOT\\TclFoobar\\baz test1 + set result [registry values HKEY_CLASSES_ROOT\\TclFoobar\\baz] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} test2 +test registry-3.2 {DeleteValue: bad key} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar test} msg] $msg +} {1 {unable to open key: The system cannot find the file specified.}} +test registry-3.3 {DeleteValue: bad value} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test2 blort + set result [list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar test1} msg] $msg] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {1 {unable to delete value "test1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}} + + +test registry-4.1 {GetKeyNames: bad key} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg +} {1 {unable to open key: The system cannot find the file specified.}} +test registry-4.2 {GetKeyNames} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz + set result [registry keys HKEY_CLASSES_ROOT\\TclFoobar] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {baz} +test registry-4.3 {GetKeyNames: remote key} {nonPortable} { + registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar\\baz + set result [registry keys \\\\gaspode\\HKEY_CLASSES_ROOT\\TclFoobar] + registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar + set result +} {baz} +test registry-4.4 {GetKeyNames: empty key} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar + set result [registry keys HKEY_CLASSES_ROOT\\TclFoobar] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {} +test registry-4.5 {GetKeyNames: patterns} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz + registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat + registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo + set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {baz blat} +test registry-4.6 {GetKeyNames: names with spaces} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz\ bar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat + registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo + set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {{baz bar} blat} + +test registry-5.1 {GetType} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg +} {1 {unable to open key: The system cannot find the file specified.}} +test registry-5.2 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg +} {1 {unable to get type of value "val1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}} +test registry-5.3 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar none + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} none +test registry-5.4 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} sz +test registry-5.5 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar sz + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} sz +test registry-5.6 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar expand_sz + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} expand_sz +test registry-5.7 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 binary + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} binary +test registry-5.8 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 dword + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} dword +test registry-5.9 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 dword_big_endian + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} dword_big_endian +test registry-5.10 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 link + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} link +test registry-5.11 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar multi_sz + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} multi_sz +test registry-5.12 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 resource_list + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} resource_list +test registry-5.13 {GetType: unknown types} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 24 + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} 24 + +test registry-6.1 {GetValue} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry get HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg +} {1 {unable to open key: The system cannot find the file specified.}} +test registry-6.2 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry get HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg +} {1 {unable to get value "val1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}} +test registry-6.3 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar none + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} foobar +test registry-6.4 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} foobar +test registry-6.5 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} foobar +test registry-6.6 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar expand_sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} foobar +test registry-6.7 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 binary + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} 1 +test registry-6.8 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 0x20 dword + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} 32 +test registry-6.9 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 0x20 dword_big_endian + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} 32 +test registry-6.10 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 link + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} 1 +test registry-6.11 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar multi_sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} foobar +test registry-6.12 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {foo\ bar baz} multi_sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {{foo bar} baz} +test registry-6.13 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {} multi_sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {} +test registry-6.14 {GetValue: truncation of multivalues with null elements} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {a {} b} multi_sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} a +test registry-6.15 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 resource_list + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} 1 +test registry-6.16 {GetValue: unknown types} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 24 + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} 1 + +test registry-7.1 {GetValueNames: bad key} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry values HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg +} {1 {unable to open key: The system cannot find the file specified.}} +test registry-7.2 {GetValueNames} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar + set result [registry values HKEY_CLASSES_ROOT\\TclFoobar] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} baz +test registry-7.3 {GetValueNames} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1 + registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2 + registry set HKEY_CLASSES_ROOT\\TclFoobar {} foobar3 + set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar]] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {{} baz blat} +test registry-7.4 {GetValueNames: remote key} {nonPortable} { + registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar baz blat + set result [registry values \\\\gaspode\\HKEY_CLASSES_ROOT\\TclFoobar] + registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar + set result +} baz +test registry-7.5 {GetValueNames: empty key} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar + set result [registry values HKEY_CLASSES_ROOT\\TclFoobar] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {} +test registry-7.6 {GetValueNames: patterns} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1 + registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2 + registry set HKEY_CLASSES_ROOT\\TclFoobar foo foobar3 + set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar b*]] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {baz blat} +test registry-7.7 {GetValueNames: names with spaces} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar baz\ bar foobar1 + registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2 + registry set HKEY_CLASSES_ROOT\\TclFoobar foo foobar3 + set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar b*]] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {{baz bar} blat} + +test registry-8.1 {OpenSubKey} {nonPortable} { + list [catch {registry keys {\\petrouchka\HKEY_LOCAL_MACHINE}} msg] $msg +} {1 {unable to open key: Access is denied.}} +test registry-8.2 {OpenSubKey} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar + set result [registry keys HKEY_CLASSES_ROOT TclFoobar] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} TclFoobar +test registry-8.3 {OpenSubKey} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg +} {1 {unable to open key: The system cannot find the file specified.}} + +test registry-9.1 {ParseKeyName: bad keys} { + list [catch {registry values \\} msg] $msg +} "1 {bad key \"\\\": must start with a valid root}" +test registry-9.2 {ParseKeyName: bad keys} { + list [catch {registry values \\foobar} msg] $msg +} {1 {bad key "\foobar": must start with a valid root}} +test registry-9.3 {ParseKeyName: bad keys} { + list [catch {registry values \\\\} msg] $msg +} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} +test registry-9.4 {ParseKeyName: bad keys} { + list [catch {registry values \\\\\\} msg] $msg +} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} +test registry-9.5 {ParseKeyName: bad keys} { + list [catch {registry values \\\\\\HKEY_CLASSES_ROOT} msg] $msg +} {1 {unable to open key: The network address is invalid.}} +test registry-9.6 {ParseKeyName: bad keys} { + list [catch {registry values \\\\gaspode} msg] $msg +} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} +test registry-9.7 {ParseKeyName: bad keys} { + list [catch {registry values foobar} msg] $msg +} {1 {bad root name "foobar": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} +test registry-9.8 {ParseKeyName: null keys} { + list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg +} {1 {bad key: cannot delete root keys}} +test registry-9.9 {ParseKeyName: null keys} { + list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar\\baz} msg] $msg +} {1 {unable to open key: The system cannot find the file specified.}} + +test registry-10.1 {RecursiveDeleteKey} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1 + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3 + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result [registry keys HKEY_CLASSES_ROOT TclFoobar] + set result +} {} +test registry-10.2 {RecursiveDeleteKey} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1 + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3 + set result [registry delete HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test4] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {} + +test registry-11.1 {SetValue: recursive creation} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat foobar + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar\\baz blat] +} foobar +test registry-11.2 {SetValue: modification} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat foobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat frob + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar\\baz blat] +} frob +test registry-11.3 {SetValue: failure} {nonPortable} { + list [catch {registry set {\\petrouchka\HKEY_CLASSES_ROOT\TclFoobar} bar foobar} msg] $msg +} {1 {unable to open key: Access is denied.}} + + +unset hostname diff --git a/contrib/tcl/tests/rename.test b/contrib/tcl/tests/rename.test index 1613445dbf5c5..05f5938c282ec 100644 --- a/contrib/tcl/tests/rename.test +++ b/contrib/tcl/tests/rename.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) rename.test 1.13 96/03/20 10:49:22 +# SCCS: @(#) rename.test 1.20 97/06/24 17:26:23 if {[string compare test [info procs test]] == 1} then {source defs} @@ -44,7 +44,7 @@ set b [l.new a b c] rename l.new list set c [catch l.new msg2] set d [list 111 222] -test 2.1 {renaming built-in command} { +test rename-2.1 {renaming built-in command} { list $a $msg1 $b $c $msg2 $d } {1 {invalid command name "list"} {a b c} 1 {invalid command name "l.new"} {111 222}} @@ -129,3 +129,44 @@ if {[info command testdel] == "testdel"} { list [catch {interp delete foo} msg] $msg $env(value) } {0 {} deleted} } + +# Save the unknown procedure which is modified by the following test. + +catch {rename unknown unknown.old} + +test rename-5.1 {repeated rename deletion and redefinition of same command} { + set SAVED_UNKNOWN "proc unknown " + append SAVED_UNKNOWN "\{[info args unknown.old]\} " + append SAVED_UNKNOWN "\{[info body unknown.old]\}" + + for {set i 0} {$i < 10} {incr i} { + eval $SAVED_UNKNOWN + tcl_wordBreakBefore "" 0 + rename tcl_wordBreakBefore {} + rename unknown {} + } +} {} + +catch {rename unknown {}} +catch {rename unknown.old unknown} + + +test rename-6.1 {old code invalidated (epoch incremented) when cmd with compile proc is renamed } { + proc x {} { + set a 123 + set b [incr a] + } + x + rename incr incr.old + proc incr {} {puts "new incr called!"} + catch {x} msg + set msg +} {called "incr" with too many arguments} + +catch {rename incr {}} +catch {rename incr.old incr} + +# Make the file return an empty string (cleaner.). + +set x "" + diff --git a/contrib/tcl/tests/resource.test b/contrib/tcl/tests/resource.test new file mode 100644 index 0000000000000..dc60535ef89ed --- /dev/null +++ b/contrib/tcl/tests/resource.test @@ -0,0 +1,78 @@ +# Commands covered: resource +# +# 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) 1996-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) resource.test 1.5 97/05/15 17:51:48 + +# Only run this test on Macintosh systems +if {$tcl_platform(platform) != "macintosh"} { + return +} +if {[string compare test [info procs test]] == 1} then {source defs} + +test resource-1.1 {resource tests} { + list [catch {resource} msg] $msg +} {1 {wrong # args: should be "resource option ?arg ...?"}} +test resource-1.2 {resource tests} { + list [catch {resource _bad_} msg] $msg +} {1 {bad option "_bad_": must be close, list, open, read, types, or write}} + +# resource open & close tests +test resource-2.1 {resource open & close tests} { + list [catch {resource open} msg] $msg +} {1 {wrong # args: should be "resource open fileName ?permissions?"}} +test resource-2.2 {resource open & close tests} { + list [catch {resource open resource.test r extraArg} msg] $msg +} {1 {wrong # args: should be "resource open fileName ?permissions?"}} +test resource-2.3 {resource open & close tests} { + list [catch {resource open resource.test bad_perms} msg] $msg +} {1 {illegal access mode "bad_perms"}} +test resource-2.4 {resource open & close tests} { + list [catch {resource open _bad_file_} msg] $msg +} {1 {path doesn't lead to a file}} +test resource-2.5 {resource open & close tests} { + testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"} + set id [resource open rsrc.file] + resource close $id +} {} +test resource-2.6 {resource open & close tests} { + list [catch {resource close _bad_resource_} msg] $msg +} {1 {invalid resource file reference "_bad_resource_"}} + +# Tests for the Mac version of the source command +catch {file delete rsrc.file} +testWriteTextResource -rsrc fileRsrcName -rsrcid 128 \ + -file rsrc.file {set rsrc_foo 1} +test resource-3.1 {source command} { + catch {unset rsrc_foo} + source -rsrc fileRsrcName rsrc.file + list [catch {set rsrc_foo} msg] $msg +} {0 1} +test resource-3.2 {source command} { + catch {unset rsrc_foo} + list [catch {source -rsrc no_resource rsrc.file} msg] $msg +} {1 {The resource "no_resource" could not be loaded from rsrc.file.}} +test resource-3.3 {source command} { + catch {unset rsrc_foo} + source -rsrcid 128 rsrc.file + list [catch {set rsrc_foo} msg] $msg +} {0 1} +test resource-3.4 {source command} { + catch {unset rsrc_foo} + list [catch {source -rsrcid bad_int rsrc.file} msg] $msg +} {1 {expected integer but got "bad_int"}} +test resource-3.5 {source command} { + catch {unset rsrc_foo} + list [catch {source -rsrcid 100 rsrc.file} msg] $msg +} {1 {The resource "ID=100" could not be loaded from rsrc.file.}} + +# Clean up and return +catch {file delete rsrc.file} +return diff --git a/contrib/tcl/tests/safe.test b/contrib/tcl/tests/safe.test new file mode 100644 index 0000000000000..702bf8d2bc5dc --- /dev/null +++ b/contrib/tcl/tests/safe.test @@ -0,0 +1,324 @@ +# safe.test -- +# +# This file contains a collection of tests for security policies, safe Tcl, +# and using safe interpreters. Sourcing this file into tcl runs the tests +# and generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) safe.test 1.13 97/06/24 17:33:22 + +# NOTE: The tests in this file only pass if you invoke them from the +# "tests" directory. + +if {[string compare test [info procs test]] == 1} then {source defs} + +foreach i [interp slaves] { + interp delete $i +} + +proc equiv {x} {return $x} + +test safe-1.1 {creating interpreters, should have no aliases} { + interp aliases +} "" +test safe-1.2 {creating interpreters, should have no aliases} { + catch {tcl_safeDeleteInterp a} + interp create a + set l [a aliases] + interp delete a + set l +} "" +test safe-1.3 {creating safe interpreters, should have no aliases} { + catch {tcl_safeDeleteInterp a} + interp create a -safe + set l [a aliases] + interp delete a + set l +} "" + +test safe-2.1 {calling tcl_SafeInit is safe} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + catch {interp eval a exec ls} msg + tcl_safeDeleteInterp a + set msg +} {invalid command name "exec"} +test safe-2.2 {calling tcl_safeCreateInterp on trusted interp} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + set l [lsort [a aliases]] + tcl_safeDeleteInterp a + set l +} {exit file load source tclPkgUnknown} +test safe-2.3 {calling tcl_safeCreateInterp on trusted interp} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + set x [interp eval a {source [file join $tcl_library init.tcl]}] + tcl_safeDeleteInterp a + set x +} "" +test safe-2.4 {calling tcl_safeCreateInterp on trusted interp} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + catch {set x \ + [interp eval a {source [file join $tcl_library init.tcl]}]} msg + tcl_safeDeleteInterp a + list $x $msg +} {{} {}} + +test safe-3.1 {tcl_safeDeleteInterp} { + catch {tcl_safeDeleteInterp a} + interp create a + tcl_safeDeleteInterp a +} "" +test safe-3.2 {tcl_safeDeleteInterp, indirectly} { + catch {tcl_safeDeleteInterp a} + interp create a + a alias exit tcl_safeDeleteInterp a + a eval exit +} "" +test safe-3.3 {tcl_safeDeleteInterp, state array} { + catch {tcl_safeDeleteInterp a} + set tclSafea(foo) 33 + tcl_safeDeleteInterp a + catch {set tclSafea(foo)} msg + set msg +} {can't read "tclSafea(foo)": no such variable} +test safe-3.4 {tcl_safeDeleteInterp, state array, indirectly} { + catch {tcl_safeDeleteInterp a} + set tclSafea(foo) 33 + tcl_safeCreateInterp a + a eval exit + catch {set tclSafea(foo)} msg + set msg +} {can't read "tclSafea(foo)": no such variable} +test safe-3.5 {tcl_safeDeleteInterp} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + catch {tcl_safeCreateInterp a} msg + set msg +} {interpreter named "a" already exists, cannot create} +test safe-3.6 {tcl_safeDeleteInterp, indirectly} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + a eval exit +} "" +test safe-3.7 {tcl_safeDeleteInterp, state array} { + catch {tcl_safeDeleteInterp a} + set tclSafea(foo) 33 + tcl_safeCreateInterp a + tcl_safeDeleteInterp a + catch {set tclSafea(foo)} msg + set msg +} {can't read "tclSafea(foo)": no such variable} +test safe-3.8 {tcl_safeDeleteInterp, state array, indirectly} { + catch {tcl_safeDeleteInterp a} + set tclSafea(foo) 33 + tcl_safeCreateInterp a + a eval exit + catch {set tclSafea(foo)} msg + set msg +} {can't read "tclSafea(foo)": no such variable} + +# For the following tests, we need a policyPath; we assume that the +# test directory has a subdirectory policies, and we will use that. + +# Save old value of tcl_PolicyPath so we can restore it once we are +# done with this test sequence: + +set my_old_auto_path $auto_path +lappend auto_path [pwd] + +test safe-4.1 {loading a policy from the main directory} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + set l [a eval {package require globalPolicy}] + tcl_safeDeleteInterp a + set l +} 1.0 +test safe-4.2 {same, loading into safe interpreter} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + set l [a eval {package require globalPolicy}] + tcl_safeDeleteInterp a + set l +} 1.0 +test safe-4.3 {loading a policy from a subdirectory} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + set l [a eval {package require policyA}] + tcl_safeDeleteInterp a + set l +} 1.0 +test safe-4.4 {loading a policy, unloading, reloading -- clean} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + set l "" + lappend l [a eval {package require policyA}] + tcl_safeDeleteInterp a + tcl_safeCreateInterp a + lappend l [a eval {package require policyA}] + tcl_safeDeleteInterp a + set l +} {1.0 1.0} +test safe-4.5 {loading two policies - prevented} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + set l "" + lappend l [a eval {package require policyA}] + lappend l [catch {a eval {package require policyB}} msg] + lappend l $msg + tcl_safeDeleteInterp a + set l +} {1.0 1 {security policy policyA already loaded}} +test safe-4.6 {two interpreters can have different policies} { + catch {tcl_safeDeleteInterp a} + catch {tcl_safeDeleteInterp b} + tcl_safeCreateInterp a + tcl_safeCreateInterp b + set l "" + lappend l [a eval {package require policyA}] + lappend l [b eval {package require policyB}] + tcl_safeDeleteInterp a + tcl_safeDeleteInterp b + set l +} {1.0 1.0} +test safe-4.7 {safe, loading policy, unloading, reloading: clean} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + set l "" + lappend l [a eval {package require policyA}] + tcl_safeDeleteInterp a + tcl_safeCreateInterp a + lappend l [a eval {package require policyA}] + tcl_safeDeleteInterp a + set l +} {1.0 1.0} +test safe-4.8 {safe, loading two policies - prevented} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + set l "" + lappend l [a eval {package require policyA}] + lappend l [catch {a eval {package require policyB}} msg] + lappend l $msg + tcl_safeDeleteInterp a + set l +} {1.0 1 {security policy policyA already loaded}} +test safe-4.9 {safe, two interpreters have different policies} { + catch {tcl_safeDeleteInterp a} + catch {tcl_safeDeleteInterp b} + tcl_safeCreateInterp a + tcl_safeCreateInterp b + set l "" + lappend l [a eval {package require policyA}] + lappend l [b eval {package require policyB}] + tcl_safeDeleteInterp a + tcl_safeDeleteInterp b + set l +} {1.0 1.0} + +test safe-5.1 {unloading runs policy cleanup code} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + set l "" + lappend l [a eval {package require policyC}] + tcl_safeDeleteInterp a + set l ;# the cleanup side-effects the global variable "l" +} {1.0 bye} + +# For the following tests we need an auto_path that has the policies and +# packages directories in it. + +lappend auto_path [file join [pwd] policies] \ + [file join [pwd] policies packages] + +proc findPackage {i n} { + set l [$i eval {package names}] + if {[lsearch $l $n] > -1} { + return 1 + } + return 0 +} + +test safe-6.1 {loading packages still works} { + catch {tcl_safeDeleteInterp a} + interp create a + set l "" + a eval [list set auto_path $auto_path] + lappend l [a eval {package require packageA 1.0}] + lappend l [a eval hoohum] + lappend l [a eval info proc hoohum] + tcl_safeDeleteInterp a + set l +} {1.0 bazooka hoohum} +test safe-6.2 {tcl_safeCreateInterp, loading packages} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + set l "" + lappend l [a eval {package require packageA 1.0}] + lappend l [a eval hoohum] + lappend l [a eval info proc hoohum] + tcl_safeDeleteInterp a + set l +} {1.0 bazooka hoohum} +test safe-6.3 {policies vs packages} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + set l "" + lappend l [a eval {package require policyA}] + lappend l [a eval {package require packageA}] + lappend l [findPackage a policyA] + lappend l [findPackage a packageA] + lappend l [findPackage a hohum] + tcl_safeDeleteInterp a + set l +} {1.0 1.0 1 1 0} +test safe-6.4 {policies vs packages} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + set l "" + lappend l [a eval {package require policyA}] + lappend l [a eval {package require packageA}] + lappend l [findPackage a Tcl] + lappend l [findPackage a policyA] + lappend l [findPackage a hohum] + tcl_safeDeleteInterp a + set l +} {1.0 1.0 1 1 0} +test safe-6.5 {policies vs packages vs policies} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + set l "" + lappend l [a eval {package require policyA}] + lappend l [a eval {package require packageA}] + catch {a eval {package require policyB}} msg + lappend l $msg + lappend l [findPackage a Tcl] + lappend l [findPackage a policyA] + lappend l [findPackage a policyB] + tcl_safeDeleteInterp a + set l +} {1.0 1.0 {security policy policyA already loaded} 1 1 0} + +# The following test checks whether the definition of tcl_endOfWord can be +# obtained from auto_loading. + +test safe-7.1 {test auto-loading in safe interpreters} { + catch {tcl_safeDeleteInterp a} + tcl_safeCreateInterp a + set r [catch {interp eval a {tcl_endOfWord "" 0}} msg] + tcl_safeDeleteInterp a + list $r $msg +} {0 -1} + +# Restore settings to what they were before this file was sourced: + +set auto_path $my_old_auto_path +unset my_old_auto_path + +# set auto_path $old_auto_path +# unset old_auto_path diff --git a/contrib/tcl/tests/scan.test b/contrib/tcl/tests/scan.test index 0b2da90cda12b..9f73bf13ecfb5 100644 --- a/contrib/tcl/tests/scan.test +++ b/contrib/tcl/tests/scan.test @@ -5,12 +5,12 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# 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. # -# SCCS: @(#) scan.test 1.23 96/02/16 08:56:24 +# SCCS: @(#) scan.test 1.25 97/01/21 21:16:03 if {[string compare test [info procs test]] == 1} then {source defs} @@ -55,6 +55,11 @@ test scan-1.10 {integer scanning} { set a {}; set b {}; set c {}; set d {} list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d } {2 1 2 {} {}} +# +# The behavior for scaning intergers larger than MAX_INT is +# not defined by the ANSI spec. Some implementations wrap the +# input (-16) some return MAX_INT. +# test scan-1.11 {integer scanning} {nonPortable} { set a {}; set b {}; list [scan "4294967280 4294967280" "%u %d" a b] $a $b @@ -62,35 +67,44 @@ test scan-1.11 {integer scanning} {nonPortable} { test scan-2.1 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} - list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d + list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] \ + [format %.6g $a] [format %.6g $b] [format %.6g $c] $d } {3 2.1 -3e+08 0.99962 {}} test scan-2.2 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} - list [scan "-1.2345 +8.2 9" "%3e %3lf %f %f" a b c d] $a $b $c $d -} {4 -1.0 234.0 5.0 8.2} + list [scan "-1.2345 +8.2 9" "%3e %3lf %f %f" a b c d] \ + [format %.6g $a] [format %.6g $b] [format %.6g $c] [format %.6g $d] +} {4 -1 234 5 8.2} test scan-2.3 {floating-point scanning} { set a {}; set b {}; set c {} list [scan "1e00004 332E-4 3e+4" "%Lf %*2e %f %f" a b c] $a $c } {3 10000.0 30000.0} +# +# Some libc implementations consider 3.e- bad input. The ANSI +# spec states that digits must follow the - sign. +# test scan-2.4 {floating-point scanning} {nonPortable} { set a {}; set b {}; set c {} list [scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c] $a $b $c } {3 1.0 200.0 3.0} test scan-2.5 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} - list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d -} {4 4.6 99999.7 87.643 118.0} + list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] \ + [format %.6g $a] [format %.6g $b] [format %.6g $c] [format %.6g $d] +} {4 4.6 99999.7 87.643 118} test scan-2.6 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} - list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d -} {4 1.2345 0.697 124.0 5e-05} + list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] \ + [format %.6g $a] [format %.6g $b] [format %.6g $c] [format %.6g $d] +} {4 1.2345 0.697 124 5e-05} test scan-2.7 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} - list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d + list [scan "4.6abc" "%f %f %f %f" a b c d] [format %.6g $a] $b $c $d } {1 4.6 {} {} {}} test scan-2.8 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} - list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d + list [scan "4.6 5.2" "%f %f %f %f" a b c d] \ + [format %.6g $a] [format %.6g $b] $c $d } {2 4.6 5.2 {} {}} test scan-3.1 {string and character scanning} { @@ -214,26 +228,6 @@ test scan-6.4 {miscellaneous tests} { set a {} list [catch {scan ab%c14 ab%%c%d a} msg] $msg $a } {0 1 14} -test scan-6.5 {miscellaneous tests} { - catch {unset tcl_precision} - set a {} - scan 1.111122223333 %f a - set a -} {1.11112} -test scan-6.6 {miscellaneous tests} { - set tcl_precision 10 - set a {} - scan 1.111122223333 %lf a - unset tcl_precision - set a -} {1.111122223} -test scan-6.7 {miscellaneous tests} { - set tcl_precision 10 - set a {} - scan 1.111122223333 %f a - unset tcl_precision - set a -} {1.111122223} test scan-7.1 {alignment in results array (TCL_ALIGN)} { scan "123 13.6" "%s %f" a b diff --git a/contrib/tcl/tests/set-old.test b/contrib/tcl/tests/set-old.test new file mode 100644 index 0000000000000..17e67f74a39d8 --- /dev/null +++ b/contrib/tcl/tests/set-old.test @@ -0,0 +1,679 @@ +# Commands covered: set, unset, array +# +# This file includes the original set of tests for Tcl's set command. +# Since the set command is now compiled, a new set of tests covering +# the new implementation is in the file "set.test". Sourcing this file +# into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) set-old.test 1.19 96/09/09 18:36:24 + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc ignore args {} + +# Simple variable operations. + +catch {unset a} +test set-old-1.1 {basic variable setting and unsetting} { + set a 22 +} 22 +test set-old-1.2 {basic variable setting and unsetting} { + set a 123 + set a +} 123 +test set-old-1.3 {basic variable setting and unsetting} { + set a xxx + format %s $a +} xxx +test set-old-1.4 {basic variable setting and unsetting} { + set a 44 + unset a + list [catch {set a} msg] $msg +} {1 {can't read "a": no such variable}} + +# Basic array operations. + +catch {unset a} +set a(xyz) 2 +set a(44) 3 +set {a(a long name)} test +test set-old-2.1 {basic array operations} { + lsort [array names a] +} {44 {a long name} xyz} +test set-old-2.2 {basic array operations} { + set a(44) +} 3 +test set-old-2.3 {basic array operations} { + set a(xyz) +} 2 +test set-old-2.4 {basic array operations} { + set "a(a long name)" +} test +test set-old-2.5 {basic array operations} { + list [catch {set a(other)} msg] $msg +} {1 {can't read "a(other)": no such element in array}} +test set-old-2.6 {basic array operations} { + list [catch {set a} msg] $msg +} {1 {can't read "a": variable is array}} +test set-old-2.7 {basic array operations} { + format %s $a(44) +} 3 +test set-old-2.8 {basic array operations} { + format %s $a(a long name) +} test +unset a(44) +test set-old-2.9 {basic array operations} { + lsort [array names a] +} {{a long name} xyz} +test set-old-2.10 {basic array operations} { + catch {unset b} + list [catch {set b(123)} msg] $msg +} {1 {can't read "b(123)": no such variable}} +test set-old-2.11 {basic array operations} { + catch {unset b} + set b 44 + list [catch {set b(123)} msg] $msg +} {1 {can't read "b(123)": variable isn't array}} +test set-old-2.12 {basic array operations} { + list [catch {set a 14} msg] $msg +} {1 {can't set "a": variable is array}} +unset a +test set-old-2.13 {basic array operations} { + list [catch {set a(xyz)} msg] $msg +} {1 {can't read "a(xyz)": no such variable}} + +# Test the set commands, and exercise the corner cases of the code +# that parses array references into two parts. + +test set-old-3.1 {set command} { + list [catch {set} msg] $msg +} {1 {wrong # args: should be "set varName ?newValue?"}} +test set-old-3.2 {set command} { + list [catch {set x y z} msg] $msg +} {1 {wrong # args: should be "set varName ?newValue?"}} +test set-old-3.3 {set command} { + catch {unset a} + list [catch {set a} msg] $msg +} {1 {can't read "a": no such variable}} +test set-old-3.4 {set command} { + catch {unset a} + set a(14) 83 + list [catch {set a 22} msg] $msg +} {1 {can't set "a": variable is array}} + +# Test the corner-cases of parsing array names, using set and unset. + +test set-old-4.1 {parsing array names} { + catch {unset a} + set a(()) 44 + list [catch {array names a} msg] $msg +} {0 ()} +test set-old-4.2 {parsing array names} { + catch {unset a a(abcd} + set a(abcd 33 + info exists a(abcd +} 1 +test set-old-4.3 {parsing array names} { + catch {unset a a(abcd} + set a(abcd 33 + list [catch {array names a} msg] $msg +} {0 {}} +test set-old-4.4 {parsing array names} { + catch {unset a abcd)} + set abcd) 33 + info exists abcd) +} 1 +test set-old-4.5 {parsing array names} { + set a(bcd yyy + catch {unset a} + list [catch {set a(bcd} msg] $msg +} {0 yyy} +test set-old-4.6 {parsing array names} { + catch {unset a} + set a 44 + list [catch {set a(bcd test} msg] $msg +} {0 test} + +# Errors in reading variables + +test set-old-5.1 {errors in reading variables} { + catch {unset a} + list [catch {set a} msg] $msg +} {1 {can't read "a": no such variable}} +test set-old-5.2 {errors in reading variables} { + catch {unset a} + set a 44 + list [catch {set a(18)} msg] $msg +} {1 {can't read "a(18)": variable isn't array}} +test set-old-5.3 {errors in reading variables} { + catch {unset a} + set a(6) 44 + list [catch {set a(18)} msg] $msg +} {1 {can't read "a(18)": no such element in array}} +test set-old-5.4 {errors in reading variables} { + catch {unset a} + set a(6) 44 + list [catch {set a} msg] $msg +} {1 {can't read "a": variable is array}} + +# Errors and other special cases in writing variables + +test set-old-6.1 {creating array during write} { + catch {unset a} + trace var a rwu ignore + list [catch {set a(14) 186} msg] $msg [array names a] +} {0 186 14} +test set-old-6.2 {errors in writing variables} { + catch {unset a} + set a xxx + list [catch {set a(14) 186} msg] $msg +} {1 {can't set "a(14)": variable isn't array}} +test set-old-6.3 {errors in writing variables} { + catch {unset a} + set a(100) yyy + list [catch {set a 2} msg] $msg +} {1 {can't set "a": variable is array}} +test set-old-6.4 {expanding variable size} { + catch {unset a} + list [set a short] [set a "longer name"] [set a "even longer name"] \ + [set a "a much much truly longer name"] +} {short {longer name} {even longer name} {a much much truly longer name}} + +# Unset command, Tcl_UnsetVar procedures + +test set-old-7.1 {unset command} { + catch {unset a}; catch {unset b}; catch {unset c}; catch {unset d} + set a 44 + set b 55 + set c 66 + set d 77 + unset a b c + list [catch {set a(0) 0}] [catch {set b(0) 0}] [catch {set c(0) 0}] \ + [catch {set d(0) 0}] +} {0 0 0 1} +test set-old-7.2 {unset command} { + list [catch {unset} msg] $msg +} {1 {wrong # args: should be "unset varName ?varName ...?"}} +test set-old-7.3 {unset command} { + catch {unset a} + list [catch {unset a} msg] $msg +} {1 {can't unset "a": no such variable}} +test set-old-7.4 {unset command} { + catch {unset a} + set a 44 + list [catch {unset a(14)} msg] $msg +} {1 {can't unset "a(14)": variable isn't array}} +test set-old-7.5 {unset command} { + catch {unset a} + set a(0) xx + list [catch {unset a(14)} msg] $msg +} {1 {can't unset "a(14)": no such element in array}} +test set-old-7.6 {unset command} { + catch {unset a}; catch {unset b}; catch {unset c} + set a foo + set c gorp + list [catch {unset a a a(14)} msg] $msg [info exists c] +} {1 {can't unset "a": no such variable} 1} +test set-old-7.7 {unsetting globals from within procedures} { + set y 0 + proc p1 {} { + global y + set z [p2] + return [list $z [catch {set y} msg] $msg] + } + proc p2 {} {global y; unset y; list [catch {set y} msg] $msg} + p1 +} {{1 {can't read "y": no such variable}} 1 {can't read "y": no such variable}} +test set-old-7.8 {unsetting globals from within procedures} { + set y 0 + proc p1 {} { + global y + p2 + return [list [catch {set y 44} msg] $msg] + } + proc p2 {} {global y; unset y} + concat [p1] [list [catch {set y} msg] $msg] +} {0 44 0 44} +test set-old-7.9 {unsetting globals from within procedures} { + set y 0 + proc p1 {} { + global y + unset y + return [list [catch {set y 55} msg] $msg] + } + concat [p1] [list [catch {set y} msg] $msg] +} {0 55 0 55} +test set-old-7.10 {unset command} { + catch {unset a} + set a(14) 22 + unset a(14) + list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2 +} {1 {can't read "a(14)": no such element in array} 0 {}} +test set-old-7.11 {unset command} { + catch {unset a} + set a(14) 22 + unset a + list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2 +} {1 {can't read "a(14)": no such variable} 0 {}} + +# Array command. + +test set-old-8.1 {array command} { + list [catch {array} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} +test set-old-8.2 {array command} { + list [catch {array a} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} +test set-old-8.3 {array command} { + catch {unset a} + list [catch {array anymore a b} msg] $msg +} {1 {"a" isn't an array}} +test set-old-8.4 {array command} { + catch {unset a} + set a 44 + list [catch {array anymore a b} msg] $msg +} {1 {"a" isn't an array}} +test set-old-8.5 {array command} { + proc foo {} { + set a 44 + upvar 0 a x + list [catch {array anymore x b} msg] $msg + } + foo +} {1 {"x" isn't an array}} +test set-old-8.6 {array command} { + catch {unset a} + set a(22) 3 + list [catch {array gorp a} msg] $msg +} {1 {bad option "gorp": should be anymore, donesearch, exists, get, names, nextelement, set, size, or startsearch}} +test set-old-8.7 {array command, anymore option} { + catch {unset a} + list [catch {array anymore a x} msg] $msg +} {1 {"a" isn't an array}} +test set-old-8.8 {array command, donesearch option} { + catch {unset a} + list [catch {array donesearch a x} msg] $msg +} {1 {"a" isn't an array}} +test set-old-8.9 {array command, exists option} { + list [catch {array exists a b} msg] $msg +} {1 {wrong # args: should be "array exists arrayName"}} +test set-old-8.10 {array command, exists option} { + catch {unset a} + array exists a +} {0} +test set-old-8.11 {array command, exists option} { + catch {unset a} + set a(0) 1 + array exists a +} {1} +test set-old-8.12 {array command, get option} { + list [catch {array get} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} +test set-old-8.13 {array command, get option} { + list [catch {array get a b c} msg] $msg +} {1 {wrong # args: should be "array get arrayName ?pattern?"}} +test set-old-8.14 {array command, get option} { + catch {unset a} + array get a +} {} +test set-old-8.15 {array command, get option} { + catch {unset a} + set a(22) 3 + set {a(long name)} {} + array get a +} {22 3 {long name} {}} +test set-old-8.16 {array command, get option (unset variable)} { + catch {unset a} + set a(x) 3 + trace var a(y) w ignore + array get a +} {x 3} +test set-old-8.17 {array command, get option, with pattern} { + catch {unset a} + set a(x1) 3 + set a(x2) 4 + set a(x3) 5 + set a(b1) 24 + set a(b2) 25 + array get a x* +} {x1 3 x2 4 x3 5} +test set-old-8.18 {array command, names option} { + catch {unset a} + set a(22) 3 + list [catch {array names a 4 5} msg] $msg +} {1 {wrong # args: should be "array names arrayName ?pattern?"}} +test set-old-8.19 {array command, names option} { + catch {unset a} + array names a +} {} +test set-old-8.20 {array command, names option} { + catch {unset a} + set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx + list [catch {lsort [array names a]} msg] $msg +} {0 {22 Textual_name {name with spaces}}} +test set-old-8.21 {array command, names option} { + catch {unset a} + set a(22) 3; set a(33) 44; + trace var a(xxx) w ignore + list [catch {lsort [array names a]} msg] $msg +} {0 {22 33}} +test set-old-8.22 {array command, names option} { + catch {unset a} + set a(22) 3; set a(33) 44; + trace var a(xxx) w ignore + set a(xxx) value + list [catch {lsort [array names a]} msg] $msg +} {0 {22 33 xxx}} +test set-old-8.23 {array command, names option} { + catch {unset a} + set a(axy) 3 + set a(bxy) 44 + set a(no) yes + set a(xxx) value + list [lsort [array names a *xy]] [lsort [array names a]] +} {{axy bxy} {axy bxy no xxx}} +test set-old-8.24 {array command, nextelement option} { + list [catch {array nextelement a} msg] $msg +} {1 {wrong # args: should be "array nextelement arrayName searchId"}} +test set-old-8.25 {array command, nextelement option} { + catch {unset a} + list [catch {array nextelement a b} msg] $msg +} {1 {"a" isn't an array}} +test set-old-8.26 {array command, set option} { + list [catch {array set a} msg] $msg +} {1 {wrong # args: should be "array set arrayName list"}} +test set-old-8.27 {array command, set option} { + list [catch {array set a 1 2} msg] $msg +} {1 {wrong # args: should be "array set arrayName list"}} +test set-old-8.28 {array command, set option} { + list [catch {array set a "a \{ c"} msg] $msg +} {1 {unmatched open brace in list}} +test set-old-8.29 {array command, set option} { + catch {unset a} + set a 44 + list [catch {array set a {a b c d}} msg] $msg +} {1 {can't set "a(a)": variable isn't array}} +test set-old-8.30 {array command, set option} { + catch {unset a} + set a(xx) yy + array set a {b c d e} + array get a +} {d e xx yy b c} +test set-old-8.31 {array command, size option} { + list [catch {array size a 4} msg] $msg +} {1 {wrong # args: should be "array size arrayName"}} +test set-old-8.32 {array command, size option} { + catch {unset a} + array size a +} {0} +test set-old-8.33 {array command, size option} { + catch {unset a} + set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx + list [catch {array size a} msg] $msg +} {0 3} +test set-old-8.34 {array command, size option} { + catch {unset a} + set a(22) 3; set a(xx) 44; set a(y) xxx + unset a(22) a(y) a(xx) + list [catch {array size a} msg] $msg +} {0 0} +test set-old-8.35 {array command, size option} { + catch {unset a} + set a(22) 3; + trace var a(33) rwu ignore + list [catch {array size a} msg] $msg +} {0 1} +test set-old-8.36 {array command, startsearch option} { + list [catch {array startsearch a b} msg] $msg +} {1 {wrong # args: should be "array startsearch arrayName"}} +test set-old-8.37 {array command, startsearch option} { + catch {unset a} + list [catch {array startsearch a} msg] $msg +} {1 {"a" isn't an array}} + +test set-old-9.1 {ids for array enumeration} { + catch {unset a} + set a(a) 1 + list [array st a] [array st a] [array done a s-1-a; array st a] \ + [array done a s-2-a; array d a s-3-a; array start a] +} {s-1-a s-2-a s-3-a s-1-a} +test set-old-9.2 {array enumeration} { + catch {unset a} + set a(a) 1 + set a(b) 1 + set a(c) 1 + set x [array startsearch a] + list [array nextelement a $x] [array ne a $x] [array next a $x] \ + [array next a $x] [array next a $x] +} {a b c {} {}} +test set-old-9.3 {array enumeration} { + catch {unset a} + set a(a) 1 + set a(b) 1 + set a(c) 1 + set x [array startsearch a] + set y [array startsearch a] + set z [array startsearch a] + list [array nextelement a $x] [array ne a $x] \ + [array next a $y] [array next a $z] [array next a $y] \ + [array next a $z] [array next a $y] [array next a $z] \ + [array next a $y] [array next a $z] [array next a $x] \ + [array next a $x] +} {a b a a b b c c {} {} c {}} +test set-old-9.4 {array enumeration: stopping searches} { + catch {unset a} + set a(a) 1 + set a(b) 1 + set a(c) 1 + set x [array startsearch a] + set y [array startsearch a] + set z [array startsearch a] + list [array next a $x] [array next a $x] [array next a $y] \ + [array done a $z; array next a $x] \ + [array done a $x; array next a $y] [array next a $y] +} {a b a c b c} +test set-old-9.5 {array enumeration: stopping searches} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + array done a $x + list [catch {array next a $x} msg] $msg +} {1 {couldn't find search "s-1-a"}} +test set-old-9.6 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + set a(b) 1 + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} +test set-old-9.7 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + set a(a) 2 + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {0 a 0 a} +test set-old-9.8 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set a(c) 2 + set x [array startsearch a] + set y [array startsearch a] + catch {unset a(c)} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} +test set-old-9.9 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + catch {unset a(c)} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {0 a 0 a} +test set-old-9.10 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + trace var a(b) r {} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} +test set-old-9.11 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + trace var a(a) r {} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {0 a 0 a} +test set-old-9.12 {array enumeration with traced undefined elements} { + catch {unset a} + set a(a) 1 + trace var a(b) r {} + set x [array startsearch a] + list [array next a $x] [array next a $x] +} {a {}} + +test set-old-10.1 {array enumeration errors} { + list [catch {array start} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} +test set-old-10.2 {array enumeration errors} { + list [catch {array start a b} msg] $msg +} {1 {wrong # args: should be "array startsearch arrayName"}} +test set-old-10.3 {array enumeration errors} { + catch {unset a} + list [catch {array start a} msg] $msg +} {1 {"a" isn't an array}} +test set-old-10.4 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a} msg] $msg +} {1 {wrong # args: should be "array nextelement arrayName searchId"}} +test set-old-10.5 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a b c} msg] $msg +} {1 {wrong # args: should be "array nextelement arrayName searchId"}} +test set-old-10.6 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a a-1-a} msg] $msg +} {1 {illegal search identifier "a-1-a"}} +test set-old-10.7 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a sx1-a} msg] $msg +} {1 {illegal search identifier "sx1-a"}} +test set-old-10.8 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s--a} msg] $msg +} {1 {illegal search identifier "s--a"}} +test set-old-10.9 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s-1-b} msg] $msg +} {1 {search identifier "s-1-b" isn't for variable "a"}} +test set-old-10.10 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s-1ba} msg] $msg +} {1 {illegal search identifier "s-1ba"}} +test set-old-10.11 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s-2-a} msg] $msg +} {1 {couldn't find search "s-2-a"}} +test set-old-10.12 {array enumeration errors} { + list [catch {array done a} msg] $msg +} {1 {wrong # args: should be "array donesearch arrayName searchId"}} +test set-old-10.13 {array enumeration errors} { + list [catch {array done a b c} msg] $msg +} {1 {wrong # args: should be "array donesearch arrayName searchId"}} +test set-old-10.14 {array enumeration errors} { + list [catch {array done a b} msg] $msg +} {1 {illegal search identifier "b"}} +test set-old-10.15 {array enumeration errors} { + list [catch {array anymore a} msg] $msg +} {1 {wrong # args: should be "array anymore arrayName searchId"}} +test set-old-10.16 {array enumeration errors} { + list [catch {array any a b c} msg] $msg +} {1 {wrong # args: should be "array anymore arrayName searchId"}} +test set-old-10.17 {array enumeration errors} { + catch {unset a} + set a(0) 44 + list [catch {array any a bogus} msg] $msg +} {1 {illegal search identifier "bogus"}} + +# Array enumeration with "anymore" option + +test set-old-11.1 {array anymore option} { + catch {unset a} + set a(a) 1 + set a(b) 2 + set a(c) 3 + array startsearch a + list [array anymore a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] +} {1 a 1 b 1 c 0 {}} +test set-old-11.2 {array anymore option} { + catch {unset a} + set a(a) 1 + set a(b) 2 + set a(c) 3 + array startsearch a + list [array next a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] \ + [array next a s-1-a] [array anymore a s-1-a] +} {a b 1 c {} 0} + +# Special check to see that the value of a variable is handled correctly +# if it is returned as the result of a procedure (must not free the variable +# string while deleting the call frame). Errors will only be detected if +# a memory consistency checker such as Purify is being used. + +test set-old-12.1 {cleanup on procedure return} { + proc foo {} { + set x 12345 + } + foo +} 12345 +test set-old-12.2 {cleanup on procedure return} { + proc foo {} { + set x(1) 23456 + } + foo +} 23456 + +# Must delete variables when done, since these arrays get used as +# scalars by other tests. + +catch {unset a} +catch {unset b} +catch {unset c} +return "" diff --git a/contrib/tcl/tests/set.test b/contrib/tcl/tests/set.test index 8a8d88700a5f6..4d0f352d450f4 100644 --- a/contrib/tcl/tests/set.test +++ b/contrib/tcl/tests/set.test @@ -1,677 +1,233 @@ -# Commands covered: set, unset, array +# Commands covered: set # # 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) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1995 Sun Microsystems, Inc. +# Copyright (c) 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) set.test 1.18 96/02/16 08:56:25 +# SCCS: @(#) set.test 1.6 97/06/23 18:18:54 if {[string compare test [info procs test]] == 1} then {source defs} -proc ignore args {} +catch {unset x} +catch {unset i} -# Simple variable operations. - -catch {unset a} -test set-1.1 {basic variable setting and unsetting} { - set a 22 -} 22 -test set-1.2 {basic variable setting and unsetting} { - set a 123 - set a -} 123 -test set-1.3 {basic variable setting and unsetting} { - set a xxx - format %s $a -} xxx -test set-1.4 {basic variable setting and unsetting} { - set a 44 - unset a - list [catch {set a} msg] $msg -} {1 {can't read "a": no such variable}} - -# Basic array operations. - -catch {unset a} -set a(xyz) 2 -set a(44) 3 -set {a(a long name)} test -test set-2.1 {basic array operations} { - lsort [array names a] -} {44 {a long name} xyz} -test set-2.2 {basic array operations} { - set a(44) -} 3 -test set-2.3 {basic array operations} { - set a(xyz) -} 2 -test set-2.4 {basic array operations} { - set "a(a long name)" -} test -test set-2.5 {basic array operations} { - list [catch {set a(other)} msg] $msg -} {1 {can't read "a(other)": no such element in array}} -test set-2.6 {basic array operations} { - list [catch {set a} msg] $msg -} {1 {can't read "a": variable is array}} -test set-2.7 {basic array operations} { - format %s $a(44) -} 3 -test set-2.8 {basic array operations} { - format %s $a(a long name) -} test -unset a(44) -test set-2.9 {basic array operations} { - lsort [array names a] -} {{a long name} xyz} -test set-2.10 {basic array operations} { - catch {unset b} - list [catch {set b(123)} msg] $msg -} {1 {can't read "b(123)": no such variable}} -test set-2.11 {basic array operations} { - catch {unset b} - set b 44 - list [catch {set b(123)} msg] $msg -} {1 {can't read "b(123)": variable isn't array}} -test set-2.12 {basic array operations} { - list [catch {set a 14} msg] $msg -} {1 {can't set "a": variable is array}} -unset a -test set-2.13 {basic array operations} { - list [catch {set a(xyz)} msg] $msg -} {1 {can't read "a(xyz)": no such variable}} - -# Test the set commands, and exercise the corner cases of the code -# that parses array references into two parts. - -test set-3.1 {set command} { +test set-1.1 {TclCompileSetCmd: missing variable name} { list [catch {set} msg] $msg } {1 {wrong # args: should be "set varName ?newValue?"}} -test set-3.2 {set command} { - list [catch {set x y z} msg] $msg -} {1 {wrong # args: should be "set varName ?newValue?"}} -test set-3.3 {set command} { - catch {unset a} - list [catch {set a} msg] $msg -} {1 {can't read "a": no such variable}} -test set-3.4 {set command} { +test set-1.2 {TclCompileSetCmd: simple variable name} { + set i 10 + list [set i] $i +} {10 10} +test set-1.3 {TclCompileSetCmd: error compiling variable name} { + set i 10 + catch {set "i"xxx} msg + set msg +} {quoted string doesn't terminate properly} +test set-1.4 {TclCompileSetCmd: simple variable name in quotes} { + set i 17 + list [set "i"] $i +} {17 17} +test set-1.5 {TclCompileSetCmd: simple variable name in braces} { + catch {unset {a simple var}} + set {a simple var} 27 + list [set {a simple var}] ${a simple var} +} {27 27} +test set-1.6 {TclCompileSetCmd: simple array variable name} { + catch {unset a} + set a(foo) 37 + list [set a(foo)] $a(foo) +} {37 37} +test set-1.7 {TclCompileSetCmd: non-simple (computed) variable name} { + set x "i" + set i 77 + list [set $x] $i +} {77 77} +test set-1.8 {TclCompileSetCmd: non-simple (computed) variable name} { + set x "i" + set i 77 + list [set [set x] 2] $i +} {2 2} + +test set-1.9 {TclCompileSetCmd: 3rd arg => assignment} { + set i "abcdef" + list [set i] $i +} {abcdef abcdef} +test set-1.10 {TclCompileSetCmd: only two args => just getting value} { + set i {one two} + set i +} {one two} + +test set-1.11 {TclCompileSetCmd: simple global name} { + proc p {} { + global i + set i 54 + set i + } + p +} {54} +test set-1.12 {TclCompileSetCmd: simple local name} { + proc p {bar} { + set foo $bar + set foo + } + p 999 +} {999} +test set-1.13 {TclCompileSetCmd: simple but new (unknown) local name} { + proc p {} { + set bar + } + catch {p} msg + set msg +} {can't read "bar": no such variable} +test set-1.14 {TclCompileSetCmd: simple local name, >255 locals} { + proc 260locals {} { + # create 260 locals (the last ones with index > 255) + set a0 0; set a1 0; set a2 0; set a3 0; set a4 0 + set a5 0; set a6 0; set a7 0; set a8 0; set a9 0 + set b0 0; set b1 0; set b2 0; set b3 0; set b4 0 + set b5 0; set b6 0; set b7 0; set b8 0; set b9 0 + set c0 0; set c1 0; set c2 0; set c3 0; set c4 0 + set c5 0; set c6 0; set c7 0; set c8 0; set c9 0 + set d0 0; set d1 0; set d2 0; set d3 0; set d4 0 + set d5 0; set d6 0; set d7 0; set d8 0; set d9 0 + set e0 0; set e1 0; set e2 0; set e3 0; set e4 0 + set e5 0; set e6 0; set e7 0; set e8 0; set e9 0 + set f0 0; set f1 0; set f2 0; set f3 0; set f4 0 + set f5 0; set f6 0; set f7 0; set f8 0; set f9 0 + set g0 0; set g1 0; set g2 0; set g3 0; set g4 0 + set g5 0; set g6 0; set g7 0; set g8 0; set g9 0 + set h0 0; set h1 0; set h2 0; set h3 0; set h4 0 + set h5 0; set h6 0; set h7 0; set h8 0; set h9 0 + set i0 0; set i1 0; set i2 0; set i3 0; set i4 0 + set i5 0; set i6 0; set i7 0; set i8 0; set i9 0 + set j0 0; set j1 0; set j2 0; set j3 0; set j4 0 + set j5 0; set j6 0; set j7 0; set j8 0; set j9 0 + set k0 0; set k1 0; set k2 0; set k3 0; set k4 0 + set k5 0; set k6 0; set k7 0; set k8 0; set k9 0 + set l0 0; set l1 0; set l2 0; set l3 0; set l4 0 + set l5 0; set l6 0; set l7 0; set l8 0; set l9 0 + set m0 0; set m1 0; set m2 0; set m3 0; set m4 0 + set m5 0; set m6 0; set m7 0; set m8 0; set m9 0 + set n0 0; set n1 0; set n2 0; set n3 0; set n4 0 + set n5 0; set n6 0; set n7 0; set n8 0; set n9 0 + set o0 0; set o1 0; set o2 0; set o3 0; set o4 0 + set o5 0; set o6 0; set o7 0; set o8 0; set o9 0 + set p0 0; set p1 0; set p2 0; set p3 0; set p4 0 + set p5 0; set p6 0; set p7 0; set p8 0; set p9 0 + set q0 0; set q1 0; set q2 0; set q3 0; set q4 0 + set q5 0; set q6 0; set q7 0; set q8 0; set q9 0 + set r0 0; set r1 0; set r2 0; set r3 0; set r4 0 + set r5 0; set r6 0; set r7 0; set r8 0; set r9 0 + set s0 0; set s1 0; set s2 0; set s3 0; set s4 0 + set s5 0; set s6 0; set s7 0; set s8 0; set s9 0 + set t0 0; set t1 0; set t2 0; set t3 0; set t4 0 + set t5 0; set t6 0; set t7 0; set t8 0; set t9 0 + set u0 0; set u1 0; set u2 0; set u3 0; set u4 0 + set u5 0; set u6 0; set u7 0; set u8 0; set u9 0 + set v0 0; set v1 0; set v2 0; set v3 0; set v4 0 + set v5 0; set v6 0; set v7 0; set v8 0; set v9 0 + set w0 0; set w1 0; set w2 0; set w3 0; set w4 0 + set w5 0; set w6 0; set w7 0; set w8 0; set w9 0 + set x0 0; set x1 0; set x2 0; set x3 0; set x4 0 + set x5 0; set x6 0; set x7 0; set x8 0; set x9 0 + set y0 0; set y1 0; set y2 0; set y3 0; set y4 0 + set y5 0; set y6 0; set y7 0; set y8 0; set y9 0 + set z0 0; set z1 0; set z2 0; set z3 0; set z4 0 + set z5 0; set z6 0; set z7 0; set z8 0; set z9 1234 + } + 260locals +} {1234} +test set-1.15 {TclCompileSetCmd: variable is array} { catch {unset a} - set a(14) 83 - list [catch {set a 22} msg] $msg -} {1 {can't set "a": variable is array}} - -# Test the corner-cases of parsing array names, using set and unset. - -test set-4.1 {parsing array names} { + set x 27 + set x [set a(foo) 11] catch {unset a} - set a(()) 44 - list [catch {array names a} msg] $msg -} {0 ()} -test set-4.2 {parsing array names} { - catch {unset a a(abcd} - set a(abcd 33 - info exists a(abcd -} 1 -test set-4.3 {parsing array names} { - catch {unset a a(abcd} - set a(abcd 33 - list [catch {array names a} msg] $msg -} {0 {}} -test set-4.4 {parsing array names} { - catch {unset a abcd)} - set abcd) 33 - info exists abcd) -} 1 -test set-4.5 {parsing array names} { - set a(bcd yyy + set x +} 11 +test set-1.16 {TclCompileSetCmd: variable is array, elem substitutions} { catch {unset a} - list [catch {set a(bcd} msg] $msg -} {0 yyy} -test set-4.6 {parsing array names} { + set i 5 + set x 789 + set a(foo5) 27 + set x [set a(foo$i)] catch {unset a} - set a 44 - list [catch {set a(bcd test} msg] $msg -} {0 test} - -# Errors in reading variables + set x +} 27 -test set-5.1 {errors in reading variables} { - catch {unset a} - list [catch {set a} msg] $msg -} {1 {can't read "a": no such variable}} -test set-5.2 {errors in reading variables} { - catch {unset a} - set a 44 - list [catch {set a(18)} msg] $msg -} {1 {can't read "a(18)": variable isn't array}} -test set-5.3 {errors in reading variables} { +test set-1.17 {TclCompileSetCmd: doing assignment, simple int} { + set i 5 + set i 123 +} 123 +test set-1.18 {TclCompileSetCmd: doing assignment, simple int} { + set i 5 + set i -100 +} -100 +test set-1.19 {TclCompileSetCmd: doing assignment, simple but not int} { + set i 5 + set i 0x12MNOP + set i +} {0x12MNOP} +test set-1.20 {TclCompileSetCmd: doing assignment, in quotes} { + set i 25 + set i "-100" +} -100 +test set-1.21 {TclCompileSetCmd: doing assignment, in braces} { + set i 24 + set i {126} +} 126 +test set-1.22 {TclCompileSetCmd: doing assignment, large int} { + set i 5 + set i 200000 +} 200000 +test set-1.23 {TclCompileSetCmd: doing assignment, formatted int != int} { + set i 25 + set i 000012345 ;# an octal literal == 5349 decimal + list $i [incr i] +} {000012345 5350} + +test set-1.24 {TclCompileSetCmd: too many arguments} { + set i 10 + catch {set i 20 30} msg + set msg +} {wrong # args: should be "set varName ?newValue?"} + +test set-2.1 {set command: runtime error, bad variable name} { + list [catch {set {"foo}} msg] $msg $errorInfo +} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable + while executing +"set {"foo}"}} +test set-2.2 {set command: runtime error, not array variable} { + catch {unset b} + set b 44 + list [catch {set b(123)} msg] $msg +} {1 {can't read "b(123)": variable isn't array}} +test set-2.3 {set command: runtime error, errors in reading variables} { catch {unset a} set a(6) 44 list [catch {set a(18)} msg] $msg } {1 {can't read "a(18)": no such element in array}} -test set-5.4 {errors in reading variables} { - catch {unset a} - set a(6) 44 +test set-2.4 {set command: runtime error, readonly variable} { + proc readonly args {error "variable is read-only"} + set x 123 + trace var x w readonly + list [catch {set x 1} msg] $msg $errorInfo +} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only + while executing +"set x 1"}} +test set-2.5 {set command: runtime error, basic array operations} { + list [catch {set a(other)} msg] $msg +} {1 {can't read "a(other)": no such element in array}} +test set-2.6 {set command: runtime error, basic array operations} { list [catch {set a} msg] $msg } {1 {can't read "a": variable is array}} -# Errors and other special cases in writing variables - -test set-6.1 {creating array during write} { - catch {unset a} - trace var a rwu ignore - list [catch {set a(14) 186} msg] $msg [array names a] -} {0 186 14} -test set-6.2 {errors in writing variables} { - catch {unset a} - set a xxx - list [catch {set a(14) 186} msg] $msg -} {1 {can't set "a(14)": variable isn't array}} -test set-6.3 {errors in writing variables} { - catch {unset a} - set a(100) yyy - list [catch {set a 2} msg] $msg -} {1 {can't set "a": variable is array}} -test set-6.4 {expanding variable size} { - catch {unset a} - list [set a short] [set a "longer name"] [set a "even longer name"] \ - [set a "a much much truly longer name"] -} {short {longer name} {even longer name} {a much much truly longer name}} - -# Unset command, Tcl_UnsetVar procedures - -test set-7.1 {unset command} { - catch {unset a}; catch {unset b}; catch {unset c}; catch {unset d} - set a 44 - set b 55 - set c 66 - set d 77 - unset a b c - list [catch {set a(0) 0}] [catch {set b(0) 0}] [catch {set c(0) 0}] \ - [catch {set d(0) 0}] -} {0 0 0 1} -test set-7.2 {unset command} { - list [catch {unset} msg] $msg -} {1 {wrong # args: should be "unset varName ?varName ...?"}} -test set-7.3 {unset command} { - catch {unset a} - list [catch {unset a} msg] $msg -} {1 {can't unset "a": no such variable}} -test set-7.4 {unset command} { - catch {unset a} - set a 44 - list [catch {unset a(14)} msg] $msg -} {1 {can't unset "a(14)": variable isn't array}} -test set-7.5 {unset command} { - catch {unset a} - set a(0) xx - list [catch {unset a(14)} msg] $msg -} {1 {can't unset "a(14)": no such element in array}} -test set-7.6 {unset command} { - catch {unset a}; catch {unset b}; catch {unset c} - set a foo - set c gorp - list [catch {unset a a a(14)} msg] $msg [info exists c] -} {1 {can't unset "a": no such variable} 1} -test set-7.7 {unsetting globals from within procedures} { - set y 0 - proc p1 {} { - global y - set z [p2] - return [list $z [catch {set y} msg] $msg] - } - proc p2 {} {global y; unset y; list [catch {set y} msg] $msg} - p1 -} {{1 {can't read "y": no such variable}} 1 {can't read "y": no such variable}} -test set-7.8 {unsetting globals from within procedures} { - set y 0 - proc p1 {} { - global y - p2 - return [list [catch {set y 44} msg] $msg] - } - proc p2 {} {global y; unset y} - concat [p1] [list [catch {set y} msg] $msg] -} {0 44 0 44} -test set-7.9 {unsetting globals from within procedures} { - set y 0 - proc p1 {} { - global y - unset y - return [list [catch {set y 55} msg] $msg] - } - concat [p1] [list [catch {set y} msg] $msg] -} {0 55 0 55} -test set-7.10 {unset command} { - catch {unset a} - set a(14) 22 - unset a(14) - list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2 -} {1 {can't read "a(14)": no such element in array} 0 {}} -test set-7.11 {unset command} { - catch {unset a} - set a(14) 22 - unset a - list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2 -} {1 {can't read "a(14)": no such variable} 0 {}} - -# Array command. - -test set-8.1 {array command} { - list [catch {array} msg] $msg -} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} -test set-8.2 {array command} { - list [catch {array a} msg] $msg -} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} -test set-8.3 {array command} { - catch {unset a} - list [catch {array anymore a b} msg] $msg -} {1 {"a" isn't an array}} -test set-8.4 {array command} { - catch {unset a} - set a 44 - list [catch {array anymore a b} msg] $msg -} {1 {"a" isn't an array}} -test set-8.5 {array command} { - proc foo {} { - set a 44 - upvar 0 a x - list [catch {array anymore x b} msg] $msg - } - foo -} {1 {"x" isn't an array}} -test set-8.6 {array command} { - catch {unset a} - set a(22) 3 - list [catch {array gorp a} msg] $msg -} {1 {bad option "gorp": should be anymore, donesearch, exists, get, names, nextelement, set, size, or startsearch}} -test set-8.7 {array command, anymore option} { - catch {unset a} - list [catch {array anymore a x} msg] $msg -} {1 {"a" isn't an array}} -test set-8.8 {array command, donesearch option} { - catch {unset a} - list [catch {array donesearch a x} msg] $msg -} {1 {"a" isn't an array}} -test set-8.9 {array command, exists option} { - list [catch {array exists a b} msg] $msg -} {1 {wrong # args: should be "array exists arrayName"}} -test set-8.10 {array command, exists option} { - catch {unset a} - array exists a -} {0} -test set-8.11 {array command, exists option} { - catch {unset a} - set a(0) 1 - array exists a -} {1} -test set-8.12 {array command, get option} { - list [catch {array get} msg] $msg -} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} -test set-8.13 {array command, get option} { - list [catch {array get a b c} msg] $msg -} {1 {wrong # args: should be "array get arrayName ?pattern?"}} -test set-8.14 {array command, get option} { - catch {unset a} - array get a -} {} -test set-8.15 {array command, get option} { - catch {unset a} - set a(22) 3 - set {a(long name)} {} - array get a -} {22 3 {long name} {}} -test set-8.16 {array command, get option (unset variable)} { - catch {unset a} - set a(x) 3 - trace var a(y) w ignore - array get a -} {x 3} -test set-8.17 {array command, get option, with pattern} { - catch {unset a} - set a(x1) 3 - set a(x2) 4 - set a(x3) 5 - set a(b1) 24 - set a(b2) 25 - array get a x* -} {x1 3 x2 4 x3 5} -test set-8.18 {array command, names option} { - catch {unset a} - set a(22) 3 - list [catch {array names a 4 5} msg] $msg -} {1 {wrong # args: should be "array names arrayName ?pattern?"}} -test set-8.19 {array command, names option} { - catch {unset a} - array names a -} {} -test set-8.20 {array command, names option} { - catch {unset a} - set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx - list [catch {lsort [array names a]} msg] $msg -} {0 {22 Textual_name {name with spaces}}} -test set-8.21 {array command, names option} { - catch {unset a} - set a(22) 3; set a(33) 44; - trace var a(xxx) w ignore - list [catch {lsort [array names a]} msg] $msg -} {0 {22 33}} -test set-8.22 {array command, names option} { - catch {unset a} - set a(22) 3; set a(33) 44; - trace var a(xxx) w ignore - set a(xxx) value - list [catch {lsort [array names a]} msg] $msg -} {0 {22 33 xxx}} -test set-8.23 {array command, names option} { - catch {unset a} - set a(axy) 3 - set a(bxy) 44 - set a(no) yes - set a(xxx) value - list [lsort [array names a *xy]] [lsort [array names a]] -} {{axy bxy} {axy bxy no xxx}} -test set-8.24 {array command, nextelement option} { - list [catch {array nextelement a} msg] $msg -} {1 {wrong # args: should be "array nextelement arrayName searchId"}} -test set-8.25 {array command, nextelement option} { - catch {unset a} - list [catch {array nextelement a b} msg] $msg -} {1 {"a" isn't an array}} -test set-8.26 {array command, set option} { - list [catch {array set a} msg] $msg -} {1 {wrong # args: should be "array set arrayName list"}} -test set-8.27 {array command, set option} { - list [catch {array set a 1 2} msg] $msg -} {1 {wrong # args: should be "array set arrayName list"}} -test set-8.28 {array command, set option} { - list [catch {array set a "a \{ c"} msg] $msg -} {1 {unmatched open brace in list}} -test set-8.29 {array command, set option} { - catch {unset a} - set a 44 - list [catch {array set a {a b c d}} msg] $msg -} {1 {can't set "a(a)": variable isn't array}} -test set-8.30 {array command, set option} { - catch {unset a} - set a(xx) yy - array set a {b c d e} - array get a -} {d e xx yy b c} -test set-8.31 {array command, size option} { - list [catch {array size a 4} msg] $msg -} {1 {wrong # args: should be "array size arrayName"}} -test set-8.32 {array command, size option} { - catch {unset a} - array size a -} {0} -test set-8.33 {array command, size option} { - catch {unset a} - set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx - list [catch {array size a} msg] $msg -} {0 3} -test set-8.34 {array command, size option} { - catch {unset a} - set a(22) 3; set a(xx) 44; set a(y) xxx - unset a(22) a(y) a(xx) - list [catch {array size a} msg] $msg -} {0 0} -test set-8.35 {array command, size option} { - catch {unset a} - set a(22) 3; - trace var a(33) rwu ignore - list [catch {array size a} msg] $msg -} {0 1} -test set-8.36 {array command, startsearch option} { - list [catch {array startsearch a b} msg] $msg -} {1 {wrong # args: should be "array startsearch arrayName"}} -test set-8.37 {array command, startsearch option} { - catch {unset a} - list [catch {array startsearch a} msg] $msg -} {1 {"a" isn't an array}} - -test set-9.1 {ids for array enumeration} { - catch {unset a} - set a(a) 1 - list [array st a] [array st a] [array done a s-1-a; array st a] \ - [array done a s-2-a; array d a s-3-a; array start a] -} {s-1-a s-2-a s-3-a s-1-a} -test set-9.2 {array enumeration} { - catch {unset a} - set a(a) 1 - set a(b) 1 - set a(c) 1 - set x [array startsearch a] - list [array nextelement a $x] [array ne a $x] [array next a $x] \ - [array next a $x] [array next a $x] -} {a b c {} {}} -test set-9.3 {array enumeration} { - catch {unset a} - set a(a) 1 - set a(b) 1 - set a(c) 1 - set x [array startsearch a] - set y [array startsearch a] - set z [array startsearch a] - list [array nextelement a $x] [array ne a $x] \ - [array next a $y] [array next a $z] [array next a $y] \ - [array next a $z] [array next a $y] [array next a $z] \ - [array next a $y] [array next a $z] [array next a $x] \ - [array next a $x] -} {a b a a b b c c {} {} c {}} -test set-9.4 {array enumeration: stopping searches} { - catch {unset a} - set a(a) 1 - set a(b) 1 - set a(c) 1 - set x [array startsearch a] - set y [array startsearch a] - set z [array startsearch a] - list [array next a $x] [array next a $x] [array next a $y] \ - [array done a $z; array next a $x] \ - [array done a $x; array next a $y] [array next a $y] -} {a b a c b c} -test set-9.5 {array enumeration: stopping searches} { - catch {unset a} - set a(a) 1 - set x [array startsearch a] - array done a $x - list [catch {array next a $x} msg] $msg -} {1 {couldn't find search "s-1-a"}} -test set-9.6 {array enumeration: searches automatically stopped} { - catch {unset a} - set a(a) 1 - set x [array startsearch a] - set y [array startsearch a] - set a(b) 1 - list [catch {array next a $x} msg] $msg \ - [catch {array next a $y} msg2] $msg2 -} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} -test set-9.7 {array enumeration: searches automatically stopped} { - catch {unset a} - set a(a) 1 - set x [array startsearch a] - set y [array startsearch a] - set a(a) 2 - list [catch {array next a $x} msg] $msg \ - [catch {array next a $y} msg2] $msg2 -} {0 a 0 a} -test set-9.8 {array enumeration: searches automatically stopped} { - catch {unset a} - set a(a) 1 - set a(c) 2 - set x [array startsearch a] - set y [array startsearch a] - catch {unset a(c)} - list [catch {array next a $x} msg] $msg \ - [catch {array next a $y} msg2] $msg2 -} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} -test set-9.9 {array enumeration: searches automatically stopped} { - catch {unset a} - set a(a) 1 - set x [array startsearch a] - set y [array startsearch a] - catch {unset a(c)} - list [catch {array next a $x} msg] $msg \ - [catch {array next a $y} msg2] $msg2 -} {0 a 0 a} -test set-9.10 {array enumeration: searches automatically stopped} { - catch {unset a} - set a(a) 1 - set x [array startsearch a] - set y [array startsearch a] - trace var a(b) r {} - list [catch {array next a $x} msg] $msg \ - [catch {array next a $y} msg2] $msg2 -} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} -test set-9.11 {array enumeration: searches automatically stopped} { - catch {unset a} - set a(a) 1 - set x [array startsearch a] - set y [array startsearch a] - trace var a(a) r {} - list [catch {array next a $x} msg] $msg \ - [catch {array next a $y} msg2] $msg2 -} {0 a 0 a} -test set-9.12 {array enumeration with traced undefined elements} { - catch {unset a} - set a(a) 1 - trace var a(b) r {} - set x [array startsearch a] - list [array next a $x] [array next a $x] -} {a {}} - -test set-10.1 {array enumeration errors} { - list [catch {array start} msg] $msg -} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} -test set-10.2 {array enumeration errors} { - list [catch {array start a b} msg] $msg -} {1 {wrong # args: should be "array startsearch arrayName"}} -test set-10.3 {array enumeration errors} { - catch {unset a} - list [catch {array start a} msg] $msg -} {1 {"a" isn't an array}} -test set-10.4 {array enumeration errors} { - catch {unset a} - set a(a) 1 - set x [array startsearch a] - list [catch {array next a} msg] $msg -} {1 {wrong # args: should be "array nextelement arrayName searchId"}} -test set-10.5 {array enumeration errors} { - catch {unset a} - set a(a) 1 - set x [array startsearch a] - list [catch {array next a b c} msg] $msg -} {1 {wrong # args: should be "array nextelement arrayName searchId"}} -test set-10.6 {array enumeration errors} { - catch {unset a} - set a(a) 1 - set x [array startsearch a] - list [catch {array next a a-1-a} msg] $msg -} {1 {illegal search identifier "a-1-a"}} -test set-10.7 {array enumeration errors} { - catch {unset a} - set a(a) 1 - set x [array startsearch a] - list [catch {array next a sx1-a} msg] $msg -} {1 {illegal search identifier "sx1-a"}} -test set-10.8 {array enumeration errors} { - catch {unset a} - set a(a) 1 - set x [array startsearch a] - list [catch {array next a s--a} msg] $msg -} {1 {illegal search identifier "s--a"}} -test set-10.9 {array enumeration errors} { - catch {unset a} - set a(a) 1 - set x [array startsearch a] - list [catch {array next a s-1-b} msg] $msg -} {1 {search identifier "s-1-b" isn't for variable "a"}} -test set-10.10 {array enumeration errors} { - catch {unset a} - set a(a) 1 - set x [array startsearch a] - list [catch {array next a s-1ba} msg] $msg -} {1 {illegal search identifier "s-1ba"}} -test set-10.11 {array enumeration errors} { - catch {unset a} - set a(a) 1 - set x [array startsearch a] - list [catch {array next a s-2-a} msg] $msg -} {1 {couldn't find search "s-2-a"}} -test set-10.12 {array enumeration errors} { - list [catch {array done a} msg] $msg -} {1 {wrong # args: should be "array donesearch arrayName searchId"}} -test set-10.13 {array enumeration errors} { - list [catch {array done a b c} msg] $msg -} {1 {wrong # args: should be "array donesearch arrayName searchId"}} -test set-10.14 {array enumeration errors} { - list [catch {array done a b} msg] $msg -} {1 {illegal search identifier "b"}} -test set-10.15 {array enumeration errors} { - list [catch {array anymore a} msg] $msg -} {1 {wrong # args: should be "array anymore arrayName searchId"}} -test set-10.16 {array enumeration errors} { - list [catch {array any a b c} msg] $msg -} {1 {wrong # args: should be "array anymore arrayName searchId"}} -test set-10.17 {array enumeration errors} { - catch {unset a} - set a(0) 44 - list [catch {array any a bogus} msg] $msg -} {1 {illegal search identifier "bogus"}} - -# Array enumeration with "anymore" option - -test set-11.1 {array anymore option} { - catch {unset a} - set a(a) 1 - set a(b) 2 - set a(c) 3 - array startsearch a - list [array anymore a s-1-a] [array next a s-1-a] \ - [array anymore a s-1-a] [array next a s-1-a] \ - [array anymore a s-1-a] [array next a s-1-a] \ - [array anymore a s-1-a] [array next a s-1-a] -} {1 a 1 b 1 c 0 {}} -test set-11.2 {array anymore option} { - catch {unset a} - set a(a) 1 - set a(b) 2 - set a(c) 3 - array startsearch a - list [array next a s-1-a] [array next a s-1-a] \ - [array anymore a s-1-a] [array next a s-1-a] \ - [array next a s-1-a] [array anymore a s-1-a] -} {a b 1 c {} 0} - -# Special check to see that the value of a variable is handled correctly -# if it is returned as the result of a procedure (must not free the variable -# string while deleting the call frame). Errors will only be detected if -# a memory consistency checker such as Purify is being used. - -test set-12.1 {cleanup on procedure return} { - proc foo {} { - set x 12345 - } - foo -} 12345 -test set-12.2 {cleanup on procedure return} { - proc foo {} { - set x(1) 23456 - } - foo -} 23456 - -# Must delete variables when done, since these arrays get used as -# scalars by other tests. - catch {unset a} catch {unset b} -catch {unset c} +catch {unset i} +catch {unset x} return "" diff --git a/contrib/tcl/tests/socket.test b/contrib/tcl/tests/socket.test index 8a356f6000915..2389016ba0b60 100644 --- a/contrib/tcl/tests/socket.test +++ b/contrib/tcl/tests/socket.test @@ -59,7 +59,7 @@ # listening at port 2048. If all fails, a message is printed and the tests # using the remote server are not performed. # -# SCCS: @(#) socket.test 1.62 96/08/01 15:57:49 +# SCCS: @(#) socket.test 1.75 97/04/30 15:42:58 if {[string compare test [info procs test]] == 1} then {source defs} @@ -102,7 +102,8 @@ if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} { # platforms that do not support exec, the remote server must be started # by the user before running the tests. -set remotePid -1 +set remoteProcChan "" +set commandSocket "" if {$doTestsWithRemoteServer == 1} { catch {close $commandSocket} if {[catch {set commandSocket [socket $remoteServerIP \ @@ -112,10 +113,12 @@ if {$doTestsWithRemoteServer == 1} { set doTestsWithRemoteServer 0 } else { set remoteServerIP localhost - if {[catch {set remotePid [exec $tcltest remote.tcl \ - -serverIsSilent \ - -port $remoteServerPort \ - -address $remoteServerIP &]} \ + if {[catch {set remoteProcChan \ + [open "|$tcltest remote.tcl \ + -serverIsSilent \ + -port $remoteServerPort \ + -address $remoteServerIP" \ + w+]} \ msg] == 0} { after 1000 if {[catch {set commandSocket [socket $remoteServerIP \ @@ -233,6 +236,7 @@ test socket-2.1 {tcp connection} {unixOrPc} { removeFile script set f [open script w] puts $f { + set timer [after 2000 "set x timed_out"] set f [socket -server accept 2828] proc accept {file addr port} { global x @@ -241,8 +245,9 @@ test socket-2.1 {tcp connection} {unixOrPc} { } puts ready vwait x + after cancel $timer close $f - puts done + puts $x } close $f set f [open "|$tcltest script" r] @@ -267,6 +272,7 @@ test socket-2.2 {tcp connection with client port specified} {unixOrPc} { removeFile script set f [open script w] puts $f { + set timer [after 2000 "set x done"] set f [socket -server accept 2828] proc accept {file addr port} { global x @@ -276,6 +282,7 @@ test socket-2.2 {tcp connection with client port specified} {unixOrPc} { } puts ready vwait x + after cancel $timer close $f } close $f @@ -299,6 +306,7 @@ test socket-2.3 {tcp connection with client interface specified} {unixOrPc} { removeFile script set f [open script w] puts $f { + set timer [after 2000 "set x done"] set f [socket -server accept 2828] proc accept {file addr port} { global x @@ -308,6 +316,7 @@ test socket-2.3 {tcp connection with client interface specified} {unixOrPc} { } puts ready vwait x + after cancel $timer close $f } close $f @@ -328,6 +337,7 @@ test socket-2.4 {tcp connection with server interface specified} {unixOrPc} { removeFile script set f [open script w] puts $f { + set timer [after 2000 "set x done"] set f [socket -server accept -myaddr [info hostname] 2828] proc accept {file addr port} { global x @@ -337,6 +347,7 @@ test socket-2.4 {tcp connection with server interface specified} {unixOrPc} { } puts ready vwait x + after cancel $timer close $f } close $f @@ -357,6 +368,7 @@ test socket-2.5 {tcp connection with redundant server port} {unixOrPc} { removeFile script set f [open script w] puts $f { + set timer [after 2000 "set x done"] set f [socket -server accept 2828] proc accept {file addr port} { global x @@ -366,6 +378,7 @@ test socket-2.5 {tcp connection with redundant server port} {unixOrPc} { } puts ready vwait x + after cancel $timer close $f } close $f @@ -396,13 +409,14 @@ test socket-2.7 {echo server, one line} {unixOrPc} { removeFile script set f [open script w] puts $f { + set timer [after 2000 "set x done"] set f [socket -server accept 2828] proc accept {s a p} { fileevent $s readable [list echo $s] fconfigure $s -translation lf -buffering line } proc echo {s} { - set l [gets $s] + set l [gets $s] if {[eof $s]} { global x close $s @@ -413,6 +427,7 @@ test socket-2.7 {echo server, one line} {unixOrPc} { } puts ready vwait x + after cancel $timer close $f puts done } @@ -451,7 +466,9 @@ test socket-2.8 {echo server, loop 50 times, single connection} {unixOrPc} { } set i 0 puts ready + set timer [after 20000 "set x done"] vwait x + after cancel $timer close $f puts "done $i" } @@ -483,13 +500,12 @@ test socket-2.9 {socket conflict} {unixOrPc} { set x } {1 {couldn't open socket: address already in use while executing -"socket -server accept 2828" - invoked from within -"set f [socket -server accept 2828]..." +"set f [socket -server accept 2828]" (file "script" line 1)}} test socket-2.10 {close on accept, accepted socket lives} { set done 0 - set ss [socket -server accept 2828] + set timer [after 20000 "set done timed_out"] + set ss [socket -server accept 2830] proc accept {s a p} { global ss close $ss @@ -502,10 +518,11 @@ test socket-2.10 {close on accept, accepted socket lives} { close $s set done 1 } - set cs [socket [info hostname] 2828] + set cs [socket [info hostname] 2830] puts $cs hello close $cs vwait done + after cancel $timer set done } 1 @@ -531,6 +548,9 @@ test socket-3.2 {server with several clients} {unixOrPc} { removeFile script set f [open script w] puts $f { + set t1 [after 30000 "set x timed_out"] + set t2 [after 31000 "set x timed_out"] + set t3 [after 32000 "set x timed_out"] set counter 0 set s [socket -server accept 2828] proc accept {s a p} { @@ -549,10 +569,13 @@ test socket-3.2 {server with several clients} {unixOrPc} { } puts ready vwait x + after cancel $t1 vwait x + after cancel $t2 vwait x + after cancel $t3 close $s - puts done + puts $x } close $f set f [open "|$tcltest script" r+] @@ -615,6 +638,9 @@ test socket-4.1 {server with several clients} {unixOrPc} { puts $s $l } } + set t1 [after 30000 "set x timed_out"] + set t2 [after 31000 "set x timed_out"] + set t3 [after 32000 "set x timed_out"] set s [socket -server accept 2828] puts $p1 open puts $p2 open @@ -622,11 +648,14 @@ test socket-4.1 {server with several clients} {unixOrPc} { vwait x vwait x vwait x + after cancel $t1 + after cancel $t2 + after cancel $t3 close $s set l "" - lappend l [list p1 [gets $p1]] - lappend l [list p2 [gets $p2]] - lappend l [list p3 [gets $p3]] + lappend l [list p1 [gets $p1] $x] + lappend l [list p2 [gets $p2] $x] + lappend l [list p3 [gets $p3] $x] puts $p1 bye puts $p2 bye puts $p3 bye @@ -634,7 +663,7 @@ test socket-4.1 {server with several clients} {unixOrPc} { close $p2 close $p3 set l -} {{p1 bye} {p2 bye} {p3 bye}} +} {{p1 bye done} {p2 bye done} {p3 bye done}} test socket-4.2 {byte order problems, socket numbers, htons} { set x ok if {[catch {socket -server dodo 0x3000} msg]} { @@ -693,7 +722,9 @@ test socket-6.1 {accept callback error} {unixOrPc} { set s [socket -server accept 2848] puts $f hello close $f + set timer [after 10000 "set x timed_out"] vwait x + after cancel $timer close $s rename bgerror {} set x @@ -703,84 +734,93 @@ test socket-7.1 {testing socket specific options} {unixOrPc} { removeFile script set f [open script w] puts $f { - socket -server accept 2828 + socket -server accept 2820 proc accept args { global x set x done } puts ready + set timer [after 10000 "set x timed_out"] vwait x + after cancel $timer } close $f set f [open "|$tcltest script" r] gets $f - set s [socket localhost 2828] + set s [socket localhost 2820] set p [fconfigure $s -peername] close $s close $f set l "" lappend l [string compare [lindex $p 0] 127.0.0.1] - lappend l [string compare [lindex $p 2] 2828] + lappend l [string compare [lindex $p 2] 2820] lappend l [llength $p] } {0 0 3} test socket-7.2 {testing socket specific options} {unixOrPc} { removeFile script set f [open script w] puts $f { - socket -server accept 2828 + socket -server accept 2821 proc accept args { global x set x done } puts ready + set timer [after 10000 "set x timed_out"] vwait x + after cancel $timer } close $f set f [open "|$tcltest script" r] gets $f - set s [socket localhost 2828] + set s [socket localhost 2821] set p [fconfigure $s -sockname] close $s close $f set l "" lappend l [llength $p] lappend l [lindex $p 0] - lappend l [expr [lindex $p 2] == 2828] + lappend l [expr [lindex $p 2] == 2821] } {3 127.0.0.1 0} test socket-7.3 {testing socket specific options} { - set s [socket -server accept 2828] + set s [socket -server accept 2822] set l [fconfigure $s] close $s + update llength $l } 10 test socket-7.4 {testing socket specific options} { - set s [socket -server accept 2828] + set s [socket -server accept 2823] proc accept {s a p} { global x set x [fconfigure $s -sockname] close $s } - set s1 [socket [info hostname] 2828] + set s1 [socket [info hostname] 2823] + set timer [after 10000 "set x timed_out"] vwait x + after cancel $timer close $s close $s1 set l "" lappend l [lindex $x 2] [llength $x] -} {2828 3} +} {2823 3} test socket-7.5 {testing socket specific options} {unixOrPc} { - set s [socket -server accept 2828] + set s [socket -server accept 2829] proc accept {s a p} { global x set x [fconfigure $s -sockname] close $s } - set s1 [socket localhost 2828] + set s1 [socket localhost 2829] + set timer [after 10000 "set x timed_out"] vwait x + after cancel $timer close $s close $s1 set l "" lappend l [lindex $x 0] [lindex $x 2] [llength $x] -} {127.0.0.1 2828 3} +} {127.0.0.1 2829 3} test socket-8.1 {testing -async flag on sockets} { # NOTE: This test may fail on some Solaris 2.4 systems. If it does, @@ -797,14 +837,14 @@ test socket-8.1 {testing -async flag on sockets} { # problem, please email jyl@eng.sun.com. We have not observed this # failure on Solaris 2.5, so another option (instead of installing # these patches) is to upgrade to Solaris 2.5. - set s [socket -server accept 2828] + set s [socket -server accept 2830] proc accept {s a p} { global x puts $s bye close $s set x done } - set s1 [socket -async [info hostname] 2828] + set s1 [socket -async [info hostname] 2830] vwait x set z [gets $s1] close $s @@ -834,11 +874,13 @@ test socket-9.1 {testing spurious events} { fconfigure $s -buffering none -blocking off fileevent $s readable [list readlittle $s] } - set s [socket -server accept 2828] - set c [socket [info hostname] 2828] + set s [socket -server accept 2831] + set c [socket [info hostname] 2831] puts -nonewline $c 01234567890123456789012345678901234567890123456789 close $c + set timer [after 10000 "set done timed_out"] vwait done + after cancel $timer close $s list $spurious $len } {0 50} @@ -849,7 +891,7 @@ test socket-9.2 {testing async write, fileevents, flush on close} { for {set i 0} {$i < 16} {incr i} { set secondblock "b$secondblock$secondblock" } - set l [socket -server accept 8080] + set l [socket -server accept 2832] proc accept {s a p} { fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ -buffering line @@ -870,7 +912,7 @@ test socket-9.2 {testing async write, fileevents, flush on close} { puts -nonewline $s $secondblock close $s } - set s [socket [info hostname] 8080] + set s [socket [info hostname] 2832] fconfigure $s -blocking 0 -trans lf -buffering line set count 0 puts $s hello @@ -884,10 +926,51 @@ test socket-9.2 {testing async write, fileevents, flush on close} { } } fileevent $s readable "readit $s" + set timer [after 10000 "set done timed_out"] vwait done + after cancel $timer close $l set count } 65566 +test socket-9.3 {testing EOF stickyness} { + proc count_to_eof {s} { + global count done timer + set l [gets $s] + if {[eof $s]} { + incr count + if {$count > 9} { + close $s + set done true + set count {eof is sticky} + after cancel $timer + } + } + } + proc timerproc {} { + global done count c + set done true + set count {timer went off, eof is not sticky} + close $c + } + set count 0 + set done false + proc write_then_close {s} { + puts $s bye + close $s + } + proc accept {s a p} { + fconfigure $s -buffering line -translation lf + fileevent $s writable "write_then_close $s" + } + set s [socket -server accept 2833] + set c [socket [info hostname] 2833] + fconfigure $c -blocking off -buffering line -translation lf + fileevent $c readable "count_to_eof $c" + set timer [after 1000 timerproc] + vwait done + close $s + set count +} {eof is sticky} removeFile script @@ -902,13 +985,13 @@ if {$doTestsWithRemoteServer == 0} { test socket-10.1 {tcp connection} { sendCommand { - set socket9_1_test_server [socket -server accept 2828] + set socket9_1_test_server [socket -server accept 2834] proc accept {s a p} { puts $s done close $s } } - set s [socket $remoteServerIP 2828] + set s [socket $remoteServerIP 2834] set r [gets $s] close $s sendCommand {close $socket9_1_test_server} @@ -921,13 +1004,13 @@ test socket-10.2 {client specifies its port} { set port [expr 2048 + [pid]%1024] } sendCommand { - set socket9_2_test_server [socket -server accept 2828] + set socket9_2_test_server [socket -server accept 2835] proc accept {s a p} { puts $s $p close $s } } - set s [socket -myport $port $remoteServerIP 2828] + set s [socket -myport $port $remoteServerIP 2835] set r [gets $s] close $s sendCommand {close $socket9_2_test_server} @@ -943,7 +1026,7 @@ test socket-10.2 {client specifies its port} { # test socket-10.5 {trying to connect, no server} { set status ok - if {![catch {set s [socket $remoteServerIp 2828]}]} { + if {![catch {set s [socket $remoteServerIp 2836]}]} { if {![catch {gets $s}]} { set status broken } @@ -953,7 +1036,7 @@ test socket-10.5 {trying to connect, no server} { } ok test socket-10.6 {remote echo, one line} { sendCommand { - set socket10_6_test_server [socket -server accept 2828] + set socket10_6_test_server [socket -server accept 2836] proc accept {s a p} { fileevent $s readable [list echo $s] fconfigure $s -buffering line -translation crlf @@ -967,7 +1050,7 @@ test socket-10.6 {remote echo, one line} { } } } - set f [socket $remoteServerIP 2828] + set f [socket $remoteServerIP 2836] fconfigure $f -translation crlf -buffering line puts $f hello set r [gets $f] @@ -977,7 +1060,7 @@ test socket-10.6 {remote echo, one line} { } hello test socket-10.7 {remote echo, 50 lines} { sendCommand { - set socket10_7_test_server [socket -server accept 2828] + set socket10_7_test_server [socket -server accept 2836] proc accept {s a p} { fileevent $s readable [list echo $s] fconfigure $s -buffering line -translation crlf @@ -991,7 +1074,7 @@ test socket-10.7 {remote echo, 50 lines} { } } } - set f [socket $remoteServerIP 2828] + set f [socket $remoteServerIP 2836] fconfigure $f -translation crlf -buffering line for {set cnt 0} {$cnt < 50} {incr cnt} { puts $f "hello, $cnt" @@ -1005,13 +1088,13 @@ test socket-10.7 {remote echo, 50 lines} { } 50 # Macintosh sockets can have more than one server per port if {$tcl_platform(platform) == "macintosh"} { - set conflictResult {0 2828} + set conflictResult {0 2836} } else { set conflictResult {1 {couldn't open socket: address already in use}} } test socket-10.8 {socket conflict} { - set s1 [socket -server accept 2828] - if {[catch {set s2 [socket -server accept 2828]} msg]} { + set s1 [socket -server accept 2836] + if {[catch {set s2 [socket -server accept 2836]} msg]} { set result [list 1 $msg] } else { set result [list 0 [lindex [fconfigure $s2 -sockname] 2]] @@ -1022,7 +1105,7 @@ test socket-10.8 {socket conflict} { } $conflictResult test socket-10.9 {server with several clients} { sendCommand { - set socket10_9_test_server [socket -server accept 2828] + set socket10_9_test_server [socket -server accept 2836] proc accept {s a p} { fconfigure $s -buffering line fileevent $s readable [list echo $s] @@ -1036,11 +1119,11 @@ test socket-10.9 {server with several clients} { } } } - set s1 [socket $remoteServerIP 2828] + set s1 [socket $remoteServerIP 2836] fconfigure $s1 -buffering line - set s2 [socket $remoteServerIP 2828] + set s2 [socket $remoteServerIP 2836] fconfigure $s2 -buffering line - set s3 [socket $remoteServerIP 2828] + set s3 [socket $remoteServerIP 2836] fconfigure $s3 -buffering line for {set i 0} {$i < 100} {incr i} { puts $s1 hello,s1 @@ -1058,17 +1141,17 @@ test socket-10.9 {server with several clients} { } 100 test socket-10.10 {client with several servers} { sendCommand { - set s1 [socket -server "accept 3000" 3000] - set s2 [socket -server "accept 3001" 3001] - set s3 [socket -server "accept 3002" 3002] + set s1 [socket -server "accept 4003" 4003] + set s2 [socket -server "accept 4004" 4004] + set s3 [socket -server "accept 4005" 4005] proc accept {mp s a p} { puts $s $mp close $s } } - set s1 [socket $remoteServerIP 3000] - set s2 [socket $remoteServerIP 3001] - set s3 [socket $remoteServerIP 3002] + set s1 [socket $remoteServerIP 4003] + set s2 [socket $remoteServerIP 4004] + set s3 [socket $remoteServerIP 4005] set l "" lappend l [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \ [gets $s3] [gets $s3] [eof $s3] @@ -1081,9 +1164,9 @@ test socket-10.10 {client with several servers} { close $s3 } set l -} {3000 {} 1 3001 {} 1 3002 {} 1} +} {4003 {} 1 4004 {} 1 4005 {} 1} test socket-10.11 {accept callback error} { - set s [socket -server accept 2828] + set s [socket -server accept 2836] proc accept {s a p} {expr 10 / 0} proc bgerror args { global x @@ -1091,23 +1174,25 @@ test socket-10.11 {accept callback error} { } if {[catch {sendCommand { set peername [fconfigure $callerSocket -peername] - set s [socket [lindex $peername 0] 2828] + set s [socket [lindex $peername 0] 2836] close $s }} msg]} { close $s error $msg } + set timer [after 10000 "set x timed_out"] vwait x + after cancel $timer close $s rename bgerror {} set x } {{divide by zero}} test socket-10.12 {testing socket specific options} { sendCommand { - set socket10_12_test_server [socket -server accept 2828] + set socket10_12_test_server [socket -server accept 2836] proc accept {s a p} {close $s} } - set s [socket $remoteServerIP 2828] + set s [socket $remoteServerIP 2836] set p [fconfigure $s -peername] set n [fconfigure $s -sockname] set l "" @@ -1115,13 +1200,138 @@ test socket-10.12 {testing socket specific options} { close $s sendCommand {close $socket10_12_test_server} set l -} {2828 3 3} +} {2836 3 3} +test socket-10.13 {testing spurious events} { + sendCommand { + set socket10_13_test_server [socket -server accept 2836] + proc accept {s a p} { + fconfigure $s -translation "auto lf" + after 100 writesome $s + } + proc writesome {s} { + for {set i 0} {$i < 100} {incr i} { + puts $s "line $i from remote server" + } + close $s + } + } + set len 0 + set spurious 0 + set done 0 + proc readlittle {s} { + global spurious done len + set l [read $s 1] + if {[string length $l] == 0} { + if {![eof $s]} { + incr spurious + } else { + close $s + set done 1 + } + } else { + incr len [string length $l] + } + } + set c [socket $remoteServerIP 2836] + fileevent $c readable "readlittle $c" + set timer [after 10000 "set done timed_out"] + vwait done + after cancel $timer + sendCommand {close $socket10_13_test_server} + list $spurious $len +} {0 2690} +test socket-10.14 {testing EOF stickyness} { + set counter 0 + set done 0 + proc count_up {s} { + global counter done after_id + set l [gets $s] + if {[eof $s]} { + incr counter + if {$counter > 9} { + set done {EOF is sticky} + after cancel $after_id + close $s + } + } + } + proc timed_out {} { + global c done + set done {timed_out, EOF is not sticky} + close $c + } + sendCommand { + set socket10_14_test_server [socket -server accept 2836] + proc accept {s a p} { + after 100 close $s + } + } + set c [socket $remoteServerIP 2836] + fileevent $c readable "count_up $c" + set after_id [after 1000 timed_out] + vwait done + sendCommand {close $socket10_14_test_server} + set done +} {EOF is sticky} +test socket-10.15 {testing async write, async flush, async close} { + proc readit {s} { + global count done + set l [read $s] + incr count [string length $l] + if {[eof $s]} { + close $s + set done 1 + } + } + sendCommand { + set firstblock "" + for {set i 0} {$i < 5} {incr i} { + set firstblock "a$firstblock$firstblock" + } + set secondblock "" + for {set i 0} {$i < 16} {incr i} { + set secondblock "b$secondblock$secondblock" + } + set l [socket -server accept 2845] + proc accept {s a p} { + fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ + -buffering line + fileevent $s readable "readable $s" + } + proc readable {s} { + set l [gets $s] + fileevent $s readable {} + after 1000 respond $s + } + proc respond {s} { + global firstblock + puts -nonewline $s $firstblock + after 1000 writedata $s + } + proc writedata {s} { + global secondblock + puts -nonewline $s $secondblock + close $s + } + } + set s [socket $remoteServerIP 2845] + fconfigure $s -blocking 0 -trans lf -buffering line + set count 0 + puts $s hello + fileevent $s readable "readit $s" + set timer [after 10000 "set done timed_out"] + vwait done + after cancel $timer + sendCommand {close $l} + set count +} 65566 -if {$remotePid != -1} { +if {[string match sock* $commandSocket] == 1} { puts $commandSocket exit flush $commandSocket } catch {close $commandSocket} +catch {close $remoteProcChan} set x "" unset x diff --git a/contrib/tcl/tests/source.test b/contrib/tcl/tests/source.test index f335c0ec68e26..2d62284b0def5 100644 --- a/contrib/tcl/tests/source.test +++ b/contrib/tcl/tests/source.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) source.test 1.22 96/04/05 15:27:13 +# SCCS: @(#) source.test 1.24 96/10/22 11:34:29 if {[string compare test [info procs test]] == 1} then {source defs} @@ -57,7 +57,7 @@ test source-2.3 {source error conditions} { } {1 {error in sourced file} {error in sourced file while executing "error "error in sourced file"" - (file "source.file" line 3) + (file "source.file" line 1) invoked from within "source source.file"}} test source-2.4 {source error conditions} { @@ -149,7 +149,7 @@ test source-5.2 {source resource files} {macOnly} { test source-5.3 {source resource files} {macOnly} { testWriteTextResource -rsrc rsrcName -file rsrc.file {set msg2 ok; return} set result [catch {source -rsrc rsrcName rsrc.file} msg] - rm rsrc.file + removeFile rsrc.file list $msg2 $result $msg } [list ok 0 {}] test source-5.4 {source resource files} {macOnly} { @@ -157,23 +157,23 @@ test source-5.4 {source resource files} {macOnly} { testWriteTextResource -rsrc fileRsrcName -file rsrc.file {set msg2 ok; return} source -rsrc fileRsrcName rsrc.file set result [catch {source -rsrc fileRsrcName} msg] - rm rsrc.file + removeFile rsrc.file list $msg2 $result $msg } [list ok 1 {The resource "fileRsrcName" could not be loaded from application.}] test source-5.5 {source resource files} {macOnly} { testWriteTextResource -rsrcid 200 -file rsrc.file {set msg2 hello; set msg3 bye} set result [catch {source -rsrcid 200 rsrc.file} msg] - rm rsrc.file + removeFile rsrc.file list $msg2 $result $msg } [list hello 0 bye] test source-5.6 {source resource files} {macOnly} { testWriteTextResource -rsrcid 200 -file rsrc.file {set msg2 hello; error bad; set msg3 bye} set result [catch {source -rsrcid 200 rsrc.file} msg] - rm rsrc.file + removeFile rsrc.file list $msg2 $result $msg } [list hello 1 bad] -catch {exec rm source.file} +catch {removeFile source.file} # Generate null final value diff --git a/contrib/tcl/tests/split.test b/contrib/tcl/tests/split.test index e87fcd47bcfc3..2e2af25192679 100644 --- a/contrib/tcl/tests/split.test +++ b/contrib/tcl/tests/split.test @@ -5,12 +5,12 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) split.test 1.8 96/02/16 08:56:28 +# SCCS: @(#) split.test 1.9 96/12/30 17:10:16 if {[string compare test [info procs test]] == 1} then {source defs} @@ -35,6 +35,16 @@ test split-1.6 {basic split commands} { test split-1.7 {basic split commands} { split { } } {{} {} {} {}} +test split-1.8 {basic split commands} { + proc foo {} { + set x {} + foreach f [split {]\n} {}] { + append x $f + } + return $x + } + foo +} {]\n} test split-2.1 {split errors} { list [catch split msg] $msg $errorCode diff --git a/contrib/tcl/tests/string.test b/contrib/tcl/tests/string.test index 77e1bc778bb38..08ade640db315 100644 --- a/contrib/tcl/tests/string.test +++ b/contrib/tcl/tests/string.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) string.test 1.12 96/02/16 08:56:29 +# SCCS: @(#) string.test 1.14 97/03/09 17:47:19 if {[string compare test [info procs test]] == 1} then {source defs} @@ -223,10 +223,16 @@ test string-7.11 {string range} { } {1 {wrong # args: should be "string range string first last"}} test string-7.12 {string range} { list [catch {string range abc abc 1} msg] $msg -} {1 {expected integer but got "abc"}} +} {1 {bad index "abc": must be integer or "end"}} test string-7.13 {string range} { list [catch {string range abc 1 eof} msg] $msg -} {1 {expected integer or "end" but got "eof"}} +} {1 {bad index "eof": must be integer or "end"}} +test string-7.14 {string range} { + string range abcdefghijklmnop end end +} {p} +test string-7.15 {string range} { + string range abcdefghijklmnop e 1000 +} {p} test string-8.1 {string trim} { string trim " XYZ " @@ -263,7 +269,7 @@ test string-9.1 {string trimleft} { string trimleft " XYZ " } {XYZ } test string-9.2 {string trimleft} { - list [catch {string triml} msg] $msg + list [catch {string trimleft} msg] $msg } {1 {wrong # args: should be "string trimleft string ?chars?"}} test string-10.1 {string trimright} { @@ -276,11 +282,11 @@ test string-10.3 {string trimright} { string trimright "" } {} test string-10.4 {string trimright errors} { - list [catch {string trimr} msg] $msg + list [catch {string trimright} msg] $msg } {1 {wrong # args: should be "string trimright string ?chars?"}} test string-10.5 {string trimright errors} { list [catch {string trimg a} msg] $msg -} {1 {bad option "trimg": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {bad option "trimg": must be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-11.1 {string tolower} { string tolower ABCDeF @@ -341,7 +347,7 @@ test string-13.8 {string wordend} { test string-14.1 {string wordstart} { list [catch {string word a} msg] $msg -} {1 {bad option "word": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {ambiguous option "word": must be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-14.2 {string wordstart} { list [catch {string wordstart a} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} @@ -369,7 +375,7 @@ test string-14.9 {string wordend} { test string-15.1 {error conditions} { list [catch {string gorp a b} msg] $msg -} {1 {bad option "gorp": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {bad option "gorp": must be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-15.2 {error conditions} { list [catch {string} msg] $msg } {1 {wrong # args: should be "string option arg ?arg ...?"}} diff --git a/contrib/tcl/tests/stringObj.test b/contrib/tcl/tests/stringObj.test new file mode 100644 index 0000000000000..3d03bad41c644 --- /dev/null +++ b/contrib/tcl/tests/stringObj.test @@ -0,0 +1,189 @@ +# Commands covered: none +# +# This file contains tests for the procedures in tclStringObj.c +# that implement the Tcl type manager for the string type. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# @(#) stringObj.test 1.8 97/04/09 11:29:37 + +if {[info commands testobj] == {}} { + puts "This application hasn't been compiled with the \"testobj\"" + puts "command, so I can't test the Tcl type and object support." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test stringObj-1.1 {string type registration} { + set t [testobj types] + set first [string first "string" $t] + set result [expr {$first != -1}] +} {1} + +test stringObj-2.1 {Tcl_NewStringObj} { + set result "" + lappend result [testobj freeallvars] + lappend result [teststringobj set 1 abcd] + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} abcd string 2} + +test stringObj-3.1 {Tcl_SetStringObj, existing "empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testobj newobj 1] + lappend result [teststringobj set 1 xyz] ;# makes existing obj a string + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} {} xyz string 2} +test stringObj-3.2 {Tcl_SetStringObj, existing non-"empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testintobj set 1 512] + lappend result [teststringobj set 1 foo] ;# makes existing obj a string + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 512 foo string 2} + +test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} { + testobj freeallvars + teststringobj set 1 test + teststringobj setlength 1 3 + list [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj get 1] +} {3 4 tes} +test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} { + testobj freeallvars + teststringobj set 1 abcdef + teststringobj setlength 1 10 + list [teststringobj length 1] [teststringobj length2 1] +} {10 10} +test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} { + testobj freeallvars + teststringobj set 1 abcdef + teststringobj append 1 xyzq -1 + list [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj get 1] +} {10 20 abcdefxyzq} +test stringObj-4.4 {Tcl_SetObjLength procedure, "expty string", length 0} { + testobj freeallvars + testobj newobj 1 + teststringobj setlength 1 0 + list [teststringobj length2 1] [teststringobj get 1] +} {0 {}} + +test stringObj-5.1 {Tcl_AppendToObj procedure, type conversion} { + testobj freeallvars + testintobj set2 1 43 + teststringobj append 1 xyz -1 + teststringobj get 1 +} {43xyz} +test stringObj-5.2 {Tcl_AppendToObj procedure, length calculation} { + testobj freeallvars + teststringobj set 1 {x y } + teststringobj append 1 bbCCddEE 4 + teststringobj append 1 123 -1 + teststringobj get 1 +} {x y bbCC123} +test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} { + testobj freeallvars + teststringobj set 1 xyz + teststringobj setlength 1 15 + teststringobj setlength 1 2 + set result {} + teststringobj append 1 1234567890123 -1 + lappend result [teststringobj length 1] [teststringobj length2 1] + teststringobj setlength 1 10 + teststringobj append 1 abcdef -1 + lappend result [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj get 1] +} {15 15 16 32 xy12345678abcdef} + +test stringObj-6.1 {Tcl_AppendStringsToObj procedure, type conversion} { + testobj freeallvars + teststringobj set2 1 [list a b] + teststringobj appendstrings 1 xyz { 1234 } foo + teststringobj get 1 +} {a bxyz 1234 foo} +test stringObj-6.2 {Tcl_AppendStringsToObj procedure, counting space} { + testobj freeallvars + teststringobj set 1 abc + teststringobj appendstrings 1 + list [teststringobj length 1] [teststringobj get 1] +} {3 abc} +test stringObj-6.3 {Tcl_AppendStringsToObj procedure, counting space} { + testobj freeallvars + teststringobj set 1 abc + teststringobj appendstrings 1 {} {} {} {} + list [teststringobj length 1] [teststringobj get 1] +} {3 abc} +test stringObj-6.4 {Tcl_AppendStringsToObj procedure, counting space} { + testobj freeallvars + teststringobj set 1 abc + teststringobj appendstrings 1 { 123 } abcdefg + list [teststringobj length 1] [teststringobj get 1] +} {15 {abc 123 abcdefg}} +test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} { + testobj freeallvars + testobj newobj 1 + teststringobj appendstrings 1 123 abcdefg + list [teststringobj length 1] [teststringobj length2 1] [teststringobj get 1] +} {10 10 123abcdefg} +test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} { + testobj freeallvars + teststringobj set 1 abc + teststringobj setlength 1 10 + teststringobj setlength 1 2 + teststringobj appendstrings 1 34567890 + list [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj get 1] +} {10 10 ab34567890} +test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} { + testobj freeallvars + teststringobj set 1 abc + teststringobj setlength 1 10 + teststringobj setlength 1 2 + teststringobj appendstrings 1 34567890x + list [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj get 1] +} {11 22 ab34567890x} +test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} { + testobj freeallvars + testobj newobj 1 + teststringobj appendstrings 1 {} + list [teststringobj length2 1] [teststringobj get 1] +} {0 {}} + +test stringObj-7.1 {ConvertToStringType procedure} { + testobj freeallvars + teststringobj set2 1 [list a b] + teststringobj append 1 x -1 + list [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj get 1] +} {4 8 {a bx}} +test stringObj-7.2 {ConvertToStringType procedure, null object} { + testobj freeallvars + testobj newobj 1 + teststringobj appendstrings 1 {} + list [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj get 1] +} {0 0 {}} + +test stringObj-8.1 {DupStringInternalRep procedure} { + testobj freeallvars + teststringobj set 1 {} + teststringobj append 1 abcde -1 + testobj duplicate 1 2 + list [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj length 2] [teststringobj length2 2] \ + [teststringobj get 2] +} {5 10 5 5 abcde} + +testobj freeallvars diff --git a/contrib/tcl/tests/subst.test b/contrib/tcl/tests/subst.test index 5c7f556cb7361..356114d892c39 100644 --- a/contrib/tcl/tests/subst.test +++ b/contrib/tcl/tests/subst.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) subst.test 1.7 96/02/16 08:56:30 +# SCCS: @(#) subst.test 1.8 97/06/23 18:20:15 if {[string compare test [info procs test]] == 1} then {source defs} @@ -70,7 +70,7 @@ test subst-5.2 {command substitutions} { test subst-5.3 {command substitutions} { subst {x.[concat foo].y.[concat bar].z} } {x.foo.y.bar.z} -test subst-5.3 {command substitutions} { +test subst-5.4 {command substitutions} { list [catch {subst {$long [set long] [bogus_command]}} msg] $msg } {1 {invalid command name "bogus_command"}} diff --git a/contrib/tcl/tests/switch.test b/contrib/tcl/tests/switch.test index 740ecb16771c4..347e7a59f7cc6 100644 --- a/contrib/tcl/tests/switch.test +++ b/contrib/tcl/tests/switch.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) switch.test 1.5 96/02/16 08:56:31 +# SCCS: @(#) switch.test 1.7 97/02/10 17:27:13 if {[string compare test [info procs test]] == 1} then {source defs} @@ -85,7 +85,7 @@ test switch-3.5 {-exact vs. -glob vs. -regexp} { } exact test switch-3.6 {-exact vs. -glob vs. -regexp} { list [catch {switch -foo a b c} msg] $msg -} {1 {bad option "-foo": should be -exact, -glob, -regexp, or --}} +} {1 {bad option "-foo": must be -exact, -glob, -regexp, or --}} test switch-4.1 {error in executed command} { list [catch {switch a a {error "Just a test"} default {format 1}} msg] \ @@ -168,3 +168,12 @@ test switch-7.3 {"-" bodies} { } } msg] $msg } {1 {invalid command name "-foo"}} + +test switch-8.1 {empty body} { + set msg {} + switch {2} { + 1 {set msg 1} + 2 {} + default {set msg 2} + } +} {} diff --git a/contrib/tcl/tests/timer.test b/contrib/tcl/tests/timer.test new file mode 100644 index 0000000000000..4671366c0b57d --- /dev/null +++ b/contrib/tcl/tests/timer.test @@ -0,0 +1,455 @@ +# This file contains a collection of tests for the procedures in the +# file tclTimer.c, which includes the "after" Tcl command. Sourcing +# this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# 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) 1997 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) timer.test 1.2 97/04/29 11:59:59 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test timer-1.1 {Tcl_CreateTimerHandler procedure} { + foreach i [after info] { + after cancel $i + } + set x "" + foreach i {100 200 1000 50 150} { + after $i lappend x $i + } + after 200 + update + set x +} {50 100 150 200} + +test timer-2.1 {Tcl_DeleteTimerHandler procedure} { + foreach i [after info] { + after cancel $i + } + set x "" + foreach i {100 200 300 50 150} { + after $i lappend x $i + } + after cancel lappend x 150 + after cancel lappend x 50 + after 200 + update + set x +} {100 200} + +# No tests for Tcl_ServiceTimer or ResetTimer, since it is already tested +# above. + +test timer-3.1 {TimerHandlerEventProc procedure: event masks} { + set x start + after 100 { set x fired } + update idletasks + set result $x + after 200 + update + lappend result $x +} {start fired} +test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} { + foreach i [after info] { + after cancel $i + } + foreach i {200 600 1000} { + after $i lappend x $i + } + after 200 + set result "" + set x "" + update + lappend result $x + after 400 + update + lappend result $x + after 400 + update + lappend result $x +} {200 {200 600} {200 600 1000}} +test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} { + foreach i [after info] { + after cancel $i + } + set x {} + after 100 lappend x 100 + set i [after 300 lappend x 300] + after 200 after cancel $i + after 400 + update + set x +} 100 +test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} { + foreach i [after info] { + after cancel $i + } + set x {} + after 100 lappend x a + after 200 lappend x b + after 300 lappend x c + after 300 + vwait x + set x +} {a b c} +test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} { + foreach i [after info] { + after cancel $i + } + set x {} + after 100 {lappend x a; after 0 lappend x b} + after 100 + vwait x + set x +} a +test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} { + foreach i [after info] { + after cancel $i + } + set x {} + after 100 {lappend x a; after 100 lappend x b; after 100} + after 100 + vwait x + set result $x + vwait x + lappend result $x +} {a {a b}} + +# No tests for Tcl_DoWhenIdle: it's already tested by other tests +# below. + +test timer-4.1 {Tcl_CancelIdleCall procedure} { + foreach i [after info] { + after cancel $i + } + set x before + set y before + set z before + after idle set x after1 + after idle set y after2 + after idle set z after3 + after cancel set y after2 + update idletasks + concat $x $y $z +} {after1 before after3} +test timer-4.2 {Tcl_CancelIdleCall procedure} { + foreach i [after info] { + after cancel $i + } + set x before + set y before + set z before + after idle set x after1 + after idle set y after2 + after idle set z after3 + after cancel set x after1 + update idletasks + concat $x $y $z +} {before after2 after3} + +test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} { + foreach i [after info] { + after cancel $i + } + set x 1 + set y 23 + after idle {incr x; after idle {incr x; after idle {incr x}}} + after idle {incr y} + vwait x + set result "$x $y" + update idletasks + lappend result $x +} {2 24 4} + +test timer-6.1 {Tcl_AfterCmd procedure, basics} { + list [catch {after} msg] $msg +} {1 {wrong # args: should be "after option ?arg arg ...?"}} +test timer-6.2 {Tcl_AfterCmd procedure, basics} { + list [catch {after 2x} msg] $msg +} {1 {expected integer but got "2x"}} +test timer-6.3 {Tcl_AfterCmd procedure, basics} { + list [catch {after gorp} msg] $msg +} {1 {bad argument "gorp": must be cancel, idle, info, or a number}} +test timer-6.4 {Tcl_AfterCmd procedure, ms argument} { + set x before + after 400 {set x after} + after 200 + update + set y $x + after 400 + update + list $y $x +} {before after} +test timer-6.5 {Tcl_AfterCmd procedure, ms argument} { + set x before + after 300 set x after + after 200 + update + set y $x + after 200 + update + list $y $x +} {before after} +test timer-6.6 {Tcl_AfterCmd procedure, cancel option} { + list [catch {after cancel} msg] $msg +} {1 {wrong # args: should be "after cancel id|command"}} +test timer-6.7 {Tcl_AfterCmd procedure, cancel option} { + after cancel after#1 +} {} +test timer-6.8 {Tcl_AfterCmd procedure, cancel option} { + after cancel {foo bar} +} {} +test timer-6.9 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x before + set y [after 100 set x after] + after cancel $y + after 200 + update + set x +} {before} +test timer-6.10 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x before + after 100 set x after + after cancel {set x after} + after 200 + update + set x +} {before} +test timer-6.11 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x before + after 100 set x after + set id [after 300 set x after] + after cancel $id + after 200 + update + set y $x + set x cleared + after 200 + update + list $y $x +} {after cleared} +test timer-6.12 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x first + after idle lappend x second + after idle lappend x third + set i [after idle lappend x fourth] + after cancel {lappend x second} + after cancel $i + update idletasks + set x +} {first third} +test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} { + foreach i [after info] { + after cancel $i + } + set x first + after idle lappend x second + after idle lappend x third + set i [after idle lappend x fourth] + after cancel lappend x second + after cancel $i + update idletasks + set x +} {first third} +test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} { + foreach i [after info] { + after cancel $i + } + set id [ + after 100 { + set x done + after cancel $id + } + ] + vwait x +} {} +test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} { + foreach i [after info] { + after cancel $i + } + interp create x + x eval {set a before; set b before; after idle {set a a-after}; + after idle {set b b-after}} + set result [llength [x eval after info]] + lappend result [llength [after info]] + after cancel {set b b-after} + set a aaa + set b bbb + x eval {after cancel set a a-after} + update idletasks + lappend result $a $b [x eval {list $a $b}] + interp delete x + set result +} {2 0 aaa bbb {before b-after}} +test timer-6.16 {Tcl_AfterCmd procedure, idle option} { + list [catch {after idle} msg] $msg +} {1 {wrong # args: should be "after idle script script ..."}} +test timer-6.17 {Tcl_AfterCmd procedure, idle option} { + set x before + after idle {set x after} + set y $x + update idletasks + list $y $x +} {before after} +test timer-6.18 {Tcl_AfterCmd procedure, idle option} { + set x before + after idle set x after + set y $x + update idletasks + list $y $x +} {before after} +set event1 [after idle event 1] +set event2 [after 1000 event 2] +interp create x +set childEvent [x eval {after idle event in child}] +test timer-6.19 {Tcl_AfterCmd, info option} { + lsort [after info] +} [lsort "$event1 $event2"] +test timer-6.20 {Tcl_AfterCmd, info option} { + list [catch {after info a b} msg] $msg +} {1 {wrong # args: should be "after info ?id?"}} +test timer-6.21 {Tcl_AfterCmd, info option} { + list [catch {after info $childEvent} msg] $msg +} "1 {event \"$childEvent\" doesn't exist}" +test timer-6.22 {Tcl_AfterCmd, info option} { + list [after info $event1] [after info $event2] +} {{{event 1} idle} {{event 2} timer}} +after cancel $event1 +after cancel $event2 +interp delete x + +set event [after idle foo bar] +scan $event after#%d id +test timer-7.1 {GetAfterEvent procedure} { + list [catch {after info xfter#$id} msg] $msg +} "1 {event \"xfter#$id\" doesn't exist}" +test timer-7.2 {GetAfterEvent procedure} { + list [catch {after info afterx$id} msg] $msg +} "1 {event \"afterx$id\" doesn't exist}" +test timer-7.3 {GetAfterEvent procedure} { + list [catch {after info after#ab} msg] $msg +} {1 {event "after#ab" doesn't exist}} +test timer-7.4 {GetAfterEvent procedure} { + list [catch {after info after#} msg] $msg +} {1 {event "after#" doesn't exist}} +test timer-7.5 {GetAfterEvent procedure} { + list [catch {after info after#${id}x} msg] $msg +} "1 {event \"after#${id}x\" doesn't exist}" +test timer-7.6 {GetAfterEvent procedure} { + list [catch {after info afterx[expr $id+1]} msg] $msg +} "1 {event \"afterx[expr $id+1]\" doesn't exist}" +after cancel $event + +test timer-8.1 {AfterProc procedure} { + set x before + proc foo {} { + set x untouched + after 100 {set x after} + after 200 + update + return $x + } + list [foo] $x +} {untouched after} +test timer-8.2 {AfterProc procedure} { + catch {rename bgerror {}} + proc bgerror msg { + global x errorInfo + set x [list $msg $errorInfo] + } + set x empty + after 100 {error "After error"} + after 200 + set y $x + update + catch {rename bgerror {}} + list $y $x +} {empty {{After error} {After error + while executing +"error "After error"" + ("after" script)}}} +test timer-8.3 {AfterProc procedure, deleting handler from itself} { + foreach i [after info] { + after cancel $i + } + proc foo {} { + global x + set x {} + foreach i [after info] { + lappend x [after info $i] + } + after cancel foo + } + after idle foo + after 1000 {error "I shouldn't ever have executed"} + update idletasks + set x +} {{{error "I shouldn't ever have executed"} timer}} +test timer-8.4 {AfterProc procedure, deleting handler from itself} { + foreach i [after info] { + after cancel $i + } + proc foo {} { + global x + set x {} + foreach i [after info] { + lappend x [after info $i] + } + after cancel foo + } + after 1000 {error "I shouldn't ever have executed"} + after idle foo + update idletasks + set x +} {{{error "I shouldn't ever have executed"} timer}} + +foreach i [after info] { + after cancel $i +} + +# No test for FreeAfterPtr, since it is already tested above. + + +test timer-9.1 {AfterCleanupProc procedure} { + catch {interp delete x} + interp create x + x eval {after 200 { + lappend x after + puts "part 1: this message should not appear" + }} + after 200 {lappend x after2} + x eval {after 200 { + lappend x after3 + puts "part 2: this message should not appear" + }} + after 200 {lappend x after4} + x eval {after 200 { + lappend x after5 + puts "part 3: this message should not appear" + }} + interp delete x + set x before + after 300 + update + set x +} {before after2 after4} + diff --git a/contrib/tcl/tests/trace.test b/contrib/tcl/tests/trace.test index 9077906a87c5f..d67c2528ca811 100644 --- a/contrib/tcl/tests/trace.test +++ b/contrib/tcl/tests/trace.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) trace.test 1.24 96/02/16 08:56:32 +# SCCS: @(#) trace.test 1.25 96/08/23 11:44:46 if {[string compare test [info procs test]] == 1} then {source defs} @@ -142,6 +142,11 @@ test trace-2.5 {trace variable writes} { set info } {} +# append no longer triggers read traces when fetching the old values of +# variables before doing the append operation. However, lappend _does_ +# still trigger these read traces. Also lappend triggers only one write +# trace: after appending all arguments to the list. + test trace-3.1 {trace variable read-modify-writes} { catch {unset x} set info {} @@ -150,7 +155,7 @@ test trace-3.1 {trace variable read-modify-writes} { append x 456 lappend x 789 set info -} {x {} r 1 {can't read "x": no such variable} x {} r 0 123 x {} r 0 123456} +} {x {} r 0 123456} test trace-3.2 {trace variable read-modify-writes} { catch {unset x} set info {} @@ -158,7 +163,7 @@ test trace-3.2 {trace variable read-modify-writes} { append x 123 lappend x 456 set info -} {x {} r 1 {can't read "x": no such variable} x {} w 0 123 x {} r 0 123 x {} w 0 {123 456}} +} {x {} w 0 123 x {} r 0 123 x {} w 0 {123 456}} # Basic unset-tracing on variables @@ -335,10 +340,9 @@ test trace-7.3 {error returns from traces} { catch {unset x} set x 123 set info {} - trace var x r traceError - trace var x w traceScalar + trace var x w traceError list [catch {append x 44} msg] $msg $info -} {1 {can't read "x": trace returned error} {}} +} {1 {can't set "x": trace returned error} {}} test trace-7.4 {error returns from traces} { catch {unset x} set x 123 diff --git a/contrib/tcl/tests/unixFCmd.test b/contrib/tcl/tests/unixFCmd.test new file mode 100644 index 0000000000000..8fc1f2ea17b7f --- /dev/null +++ b/contrib/tcl/tests/unixFCmd.test @@ -0,0 +1,241 @@ +# This file tests the tclUnixFCmd.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) unixFCmd.test 1.11 97/06/23 17:30:25 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {$tcl_platform(platform) != "unix"} { + return +} + +if {$user == "root"} { + puts "Skipping unixFCmd tests. They depend on not being able to write to" + puts "certain directories. It would be too dangerous to run them as root." + return +} + +proc openup {path} { + testchmod 777 $path + if {[file isdirectory $path]} { + catch { + foreach p [glob [file join $path *]] { + openup $p + } + } + } +} + +proc cleanup {args} { + foreach p ". $args" { + set x "" + catch { + set x [glob [file join $p tf*] [file join $p td*]] + } + foreach file $x { + if {[catch {file delete -force -- $file}]} { + openup $file + file delete -force -- $file + } + } + } +} + +test unixFCmd-1.1 {TclpRenameFile: EACCES} { + cleanup + file mkdir td1/td2/td3 + exec chmod 000 td1/td2 + set msg [list [catch {file rename td1/td2/td3 td2} msg] $msg] + exec chmod 755 td1/td2 + set msg +} {1 {error renaming "td1/td2/td3": permission denied}} +test unixFCmd-1.2 {TclpRenameFile: EEXIST} { + cleanup + file mkdir td1/td2 + file mkdir td2 + list [catch {file rename td2 td1} msg] $msg +} {1 {error renaming "td2" to "td1/td2": file already exists}} +test unixFCmd-1.3 {TclpRenameFile: EINVAL} { + cleanup + file mkdir td1 + list [catch {file rename td1 td1} msg] $msg +} {1 {error renaming "td1" to "td1/td1": trying to rename a volume or move a directory into itself}} +test unixFCmd-1.4 {TclpRenameFile: EISDIR} { + # can't make it happen +} {} +test unixFCmd-1.5 {TclpRenameFile: ENOENT} { + cleanup + file mkdir td1 + list [catch {file rename td2 td1} msg] $msg +} {1 {error renaming "td2": no such file or directory}} +test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} { + # can't make it happen +} {} +test unixFCmd-1.7 {TclpRenameFile: EXDEV} {nonPortable} { + cleanup + file mkdir td1 + if [file exists /kernel] { + set msg [list [catch {file rename /kernel td1} msg] $msg] + set a1 {1 {can't unlink "/kernel": permission denied}} + expr {$msg == $a1} + } else { + list 1 + } +} {1} + +test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} { + cleanup + exec touch tf1 + exec touch tf2 + file copy -force tf1 tf2 +} {} +test unixFCmd-2.2 {TclpCopyFile: src is symlink} { + cleanup + exec ln -s tf1 tf2 + file copy tf2 tf3 + file type tf3 +} {link} +test unixFCmd-2.3 {TclpCopyFile: src is block} { + cleanup + set null "/dev/null" + while {[file type $null] != "characterSpecial"} { + set null [file join [file dirname $null] [file readlink $null]] + } + # file copy $null tf1 +} {} +test unixFCmd-2.4 {TclpCopyFile: src is fifo} { + cleanup + if [catch {exec mknod tf1 p}] { + list 1 + } else { + file copy tf1 tf2 + expr {"[file type tf1]" == "[file type tf2]"} + } +} {1} +test unixFCmd-2.5 {TclpCopyFile: copy attributes} { + cleanup + exec touch tf1 + exec chmod 472 tf1 + file copy tf1 tf2 + string range [exec ls -l tf2] 0 9 +} {-r--rwx-w-} + +test unixFCmd-3.1 {CopyFile not done} { +} {} + +test unixFCmd-4.1 {TclpDeleteFile not done} { +} {} + +test unixFCmd-5.1 {TclpCreateDirectory not done} { +} {} + +test unixFCmd-6.1 {TclpCopyDirectory not done} { +} {} + +test unixFCmd-7.1 {TclpRemoveDirectory not done} { +} {} + +test unixFCmd-8.1 {TraverseUnixTree not done} { +} {} + +test unixFCmd-9.1 {TraversalCopy not done} { +} {} + +test unixFCmd-10.1 {TraversalDelete not done} { +} {} + +test unixFCmd-11.1 {CopyFileAttrs not done} { +} {} + +set testConfig(tclGroup) 0 +if {[catch {exec {groups}} groupList] == 0} { + if {[lsearch $groupList tcl] != -1} { + set testConfig(tclGroup) 1 + } +} + +test unixFCmd-12.1 {GetGroupAttribute - file not found} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -group} msg] $msg +} {1 {could not stat file "foo.test": no such file or directory}} +test unixFCmd-12.2 {GetGroupAttribute - file found} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -group}] [file delete -force -- foo.test] +} {0 {}} + +test unixFCmd-13.1 {GetOwnerAttribute - file not found} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -group} msg] $msg +} {1 {could not stat file "foo.test": no such file or directory}} +test unixFCmd-13.2 {GetOwnerAttribute} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -owner} msg] [string compare $msg $user] [file delete -force -- foo.test] +} {0 0 {}} + +test unixFCmd-14.1 {GetPermissionsAttribute - file not found} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -permissions} msg] $msg +} {1 {could not stat file "foo.test": no such file or directory}} +test unixFCmd-14.2 {GetPermissionsAttribute} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attribute foo.test -permissions}] [file delete -force -- foo.test] +} {0 {}} + +#groups hard to test +test unixFCmd-15.1 {SetGroupAttribute - invalid group} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -group foozzz} msg] $msg [file delete -force -- foo.test] +} {1 {could not set group for file "foo.test": group "foozzz" does not exist} {}} +test unixFCmd-15.2 {SetGroupAttribute - invalid file} {tclGroup} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -group tcl} msg] $msg +} {1 {could not set group for file "foo.test": no such file or directory}} + +#changing owners hard to do +test unixFCmd-16.1 {SetOwnerAttribute - current owner} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -owner $user} msg] $msg [string compare [file attributes foo.test -owner] $user] [file delete -force -- foo.test] +} {0 {} 0 {}} +test unixFCmd-16.2 {SetOwnerAttribute - invalid file} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -owner $user} msg] $msg +} {1 {could not set owner for file "foo.test": no such file or directory}} +test unixFCmd-16.3 {SetOwnerAttribute - invalid owner} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -owner foozzz} msg] $msg +} {1 {could not set owner for file "foo.test": user "foozzz" does not exist}} + + +test unixFCmd-17.1 {SetPermissionsAttribute} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -permissions 0000} msg] $msg [file attributes foo.test -permissions] [file delete -force -- foo.test] +} {0 {} 00000 {}} +test unixFCmd-17.2 {SetPermissionsAttribute} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -permissions 0000} msg] $msg +} {1 {could not set permissions for file "foo.test": no such file or directory}} +test unixFCmd-17.3 {SetPermissionsAttribute} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -permissions foo} msg] $msg [file delete -force -- foo.test] +} {1 {expected integer but got "foo"} {}} + +cleanup + + + + + diff --git a/contrib/tcl/tests/unixNotfy.test b/contrib/tcl/tests/unixNotfy.test new file mode 100644 index 0000000000000..ba99db103eaa7 --- /dev/null +++ b/contrib/tcl/tests/unixNotfy.test @@ -0,0 +1,40 @@ +# This file contains tests for tclUnixNotfy.c. +# +# 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) 1997 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) unixNotfy.test 1.2 97/06/16 17:26:28 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {$tcl_platform(platform) != "unix"} { + return +} +test unixNotfy-1.1 {Tcl_DeleteFileHandler} { + catch {vwait x} + set f [open foo w] + fileevent $f writable {set x 1} + vwait x + close $f + list [catch {vwait x} msg] $msg +} {1 {can't wait for variable "x": would wait forever}} +test unixNotfy-1.2 {Tcl_DeleteFileHandler} { + catch {vwait x} + set f1 [open foo w] + set f2 [open foo2 w] + fileevent $f1 writable {set x 1} + fileevent $f2 writable {set y 1} + vwait x + close $f1 + vwait y + close $f2 + list [catch {vwait x} msg] $msg +} {1 {can't wait for variable "x": would wait forever}} + +file delete foo diff --git a/contrib/tcl/tests/unknown.test b/contrib/tcl/tests/unknown.test index fd4110961c891..83ad160473bdf 100644 --- a/contrib/tcl/tests/unknown.test +++ b/contrib/tcl/tests/unknown.test @@ -10,10 +10,11 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) unknown.test 1.11 96/02/16 08:56:34 +# SCCS: @(#) unknown.test 1.12 96/08/26 11:29:29 if {[string compare test [info procs test]] == 1} then {source defs} +catch {unset x} catch {rename unknown unknown.old} test unknown-1.1 {non-existent "unknown" command} { diff --git a/contrib/tcl/tests/upvar.test b/contrib/tcl/tests/upvar.test index accc74c622b20..23419debd664d 100644 --- a/contrib/tcl/tests/upvar.test +++ b/contrib/tcl/tests/upvar.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) upvar.test 1.11 96/02/28 21:45:36 +# SCCS: @(#) upvar.test 1.14 96/10/22 11:34:39 if {[string compare test [info procs test]] == 1} then {source defs} @@ -310,6 +310,11 @@ test upvar-8.7 {errors in upvar command} { proc p1 {} {trace variable a w foo; upvar b a} list [catch p1 msg] $msg } {1 {variable "a" has traces: can't use for upvar}} +test upvar-8.8 {create nested array with upvar} { + proc p1 {} {upvar x(a) b; set b(2) 44} + catch {unset x} + list [catch p1 msg] $msg +} {1 {can't set "b(2)": variable isn't array}} if {[info commands testupvar] != {}} { test upvar-9.1 {Tcl_UpVar2 procedure} { diff --git a/contrib/tcl/tests/util.test b/contrib/tcl/tests/util.test new file mode 100644 index 0000000000000..e7a3f2fd493e5 --- /dev/null +++ b/contrib/tcl/tests/util.test @@ -0,0 +1,64 @@ +# This file is a Tcl script to test the code in the file tclUtil.c. +# This file is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) util.test 1.5 97/06/16 13:21:57 + +if {[info commands testobj] == {}} { + puts "This application hasn't been compiled with the \"testobj\"" + puts "command, so I can't test the Tcl type and object support." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test util-1.1 {TclFindElement procedure - binary element in middle of list} { + lindex {0 foo\x00help 1} 1 +} "foo\x00help" +test util-1.2 {TclFindElement procedure - binary element at end of list} { + lindex {0 foo\x00help} 1 +} "foo\x00help" + +test util-2.1 {TclCopyAndCollapse procedure - normal string} { + lindex {0 foo} 1 +} {foo} +test util-2.2 {TclCopyAndCollapse procedure - string with backslashes} { + lindex {0 foo\n\x00help 1} 1 +} "foo\n\x00help" + +test util-3.1 {Tcl_ScanCountedElement procedure - don't leave unmatched braces} { + # This test checks for a very tricky feature. Any list element + # generated with Tcl_ScanCountedElement and Tcl_ConvertElement must + # have the property that it can be enclosing in curly braces to make + # an embedded sub-list. If this property doesn't hold, then + # Tcl_DStringStartSublist doesn't work. + + set x {} + lappend x " \\\{ \\" + concat $x [llength "{$x}"] +} {\ \\\{\ \\ 1} + +test util-4.1 {Tcl_SetObjErrorCode - one arg} { + catch {testsetobjerrorcode 1} + list [set errorCode] +} {1} +test util-4.2 {Tcl_SetObjErrorCode - two args} { + catch {testsetobjerrorcode 1 2} + list [set errorCode] +} {{1 2}} +test util-4.3 {Tcl_SetObjErrorCode - three args} { + catch {testsetobjerrorcode 1 2 3} + list [set errorCode] +} {{1 2 3}} +test util-4.4 {Tcl_SetObjErrorCode - four args} { + catch {testsetobjerrorcode 1 2 3 4} + list [set errorCode] +} {{1 2 3 4}} +test util-4.5 {Tcl_SetObjErrorCode - five args} { + catch {testsetobjerrorcode 1 2 3 4 5} + list [set errorCode] +} {{1 2 3 4 5}} diff --git a/contrib/tcl/tests/var.test b/contrib/tcl/tests/var.test new file mode 100644 index 0000000000000..a51a47b2698f2 --- /dev/null +++ b/contrib/tcl/tests/var.test @@ -0,0 +1,436 @@ +# This file contains tests for the tclVar.c source file. Tests appear in +# the same order as the C code that they test. The set of tests is +# currently incomplete since it currently includes only new tests for +# code changed for the addition of Tcl namespaces. Other variable- +# related tests appear in several other test files including +# namespace.test, set.test, trace.test, and upvar.test. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) var.test 1.8 97/06/25 09:02:03 +# + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {rename p ""} +catch {namespace delete test_ns_var} +catch {unset xx} +catch {unset x} +catch {unset y} +catch {unset i} +catch {unset a} +catch {unset arr} + +test var-1.1 {TclLookupVar, TCL_PARSE_PART1 flag set} { + catch {unset a} + set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd + set i 10 + set arr(foo) 37 + list [$x i] $i [$x arr(foo)] $arr(foo) +} {11 11 38 38} +test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} { + set x "global value" + namespace eval test_ns_var { + variable x "namespace value" + proc p {} { + global x ;# specifies TCL_GLOBAL_ONLY to get global x + return $x + } + } + test_ns_var::p +} {global value} +test var-1.3 {TclLookupVar, TCL_NAMESPACE_ONLY implies namespace var} { + namespace eval test_ns_var { + proc q {} { + variable x ;# specifies TCL_NAMESPACE_ONLY to get namespace x + return $x + } + } + test_ns_var::q +} {namespace value} +test var-1.4 {TclLookupVar, no active call frame implies global namespace var} { + set x +} {global value} +test var-1.5 {TclLookupVar, active call frame pushed for namespace eval implies namespace var} { + namespace eval test_ns_var {set x} +} {namespace value} +test var-1.6 {TclLookupVar, name starts with :: implies some namespace var} { + namespace eval test_ns_var {set ::x} +} {global value} +test var-1.7 {TclLookupVar, error finding namespace var} { + list [catch {set a:::b} msg] $msg +} {1 {can't read "a:::b": no such variable}} +test var-1.8 {TclLookupVar, error finding namespace var} { + list [catch {set ::foobarfoo} msg] $msg +} {1 {can't read "::foobarfoo": no such variable}} +test var-1.9 {TclLookupVar, create new namespace var} { + namespace eval test_ns_var { + set v hello + } +} {hello} +test var-1.10 {TclLookupVar, create new namespace var} { + catch {unset y} + namespace eval test_ns_var { + set ::y 789 + } + set y +} {789} +test var-1.11 {TclLookupVar, error creating new namespace var} { + namespace eval test_ns_var { + list [catch {set ::test_ns_var::foo::bar 314159} msg] $msg + } +} {1 {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist}} +test var-1.12 {TclLookupVar, error creating new namespace var} { + namespace eval test_ns_var { + list [catch {set ::test_ns_var::foo:: 1997} msg] $msg + } +} {1 {can't set "::test_ns_var::foo::": parent namespace doesn't exist}} +test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} { + catch {unset aNeWnAmEiNnS} + namespace eval test_ns_var { + namespace eval test_ns_var2::test_ns_var3 { + set aNeWnAmEiNnS 77777 + } + # namespace which builds a name by traversing nsPtr chain to :: + namespace which -variable test_ns_var2::test_ns_var3::aNeWnAmEiNnS + } +} {::test_ns_var::test_ns_var2::test_ns_var3::aNeWnAmEiNnS} +test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of var names} { + namespace eval test_ns_var { + set : 123 + set v: 456 + set x:y: 789 + list [set :] [set v:] [set x:y:] \ + ${:} ${v:} ${x:y:} \ + [expr {[lsearch [info vars] :] != -1}] \ + [expr {[lsearch [info vars] v:] != -1}] \ + [expr {[lsearch [info vars] x:y:] != -1}] + } +} {123 456 789 123 456 789 1 1 1} + +test var-2.1 {Tcl_LappendObjCmd, create var if new} { + catch {unset x} + lappend x 1 2 +} {1 2} + +test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} { + catch {unset x} + set x 1997 + proc p {} { + global x ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x + return $x + } + p +} {1997} +test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { + namespace eval test_ns_var { + catch {unset v} + variable v 1998 + proc p {} { + variable v ;# TCL_NAMESPACE_ONLY specified for other var x + return $v + } + p + } +} {1998} +if {[info commands testupvar] != {}} { + test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} { + catch {unset a} + set a 123321 + proc p {} { + # create global xx linked to global a + testupvar 1 a {} xx global + } + list [p] $xx [set xx 789] $a + } {{} 123321 789 789} + test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} { + catch {unset a} + set a 456 + namespace eval test_ns_var { + catch {unset ::test_ns_var::vv} + proc p {} { + # create namespace var vv linked to global a + testupvar 1 a {} vv namespace + } + p + } + list $test_ns_var::vv [set test_ns_var::vv 123] $a + } {456 123 123} +} +test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} { + catch {unset aaaaa} + catch {unset xxxxx} + set aaaaa 77777 + upvar #0 aaaaa xxxxx + list [set xxxxx] [set aaaaa] +} {77777 77777} +test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} { + catch {unset a} + set a 121212 + namespace eval test_ns_var { + upvar ::a vvv + set vvv + } +} {121212} +test var-3.7 {MakeUpvar, my var has ::s} { + catch {unset a} + set a 789789 + upvar #0 a test_ns_var::lnk + namespace eval test_ns_var { + set lnk + } +} {789789} +test var-3.8 {MakeUpvar, my var already exists in global ns} { + catch {unset aaaaa} + catch {unset xxxxx} + set aaaaa 456654 + set xxxxx hello + upvar #0 aaaaa xxxxx + set xxxxx +} {hello} +test var-3.9 {MakeUpvar, my var has invalid ns name} { + catch {unset aaaaa} + set aaaaa 789789 + list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg +} {1 {bad variable name "test_ns_fred::lnk": unknown namespace}} + +if {[info commands testgetvarfullname] != {}} { + test var-4.1 {Tcl_GetVariableName, global variable} { + catch {unset a} + set a 123 + testgetvarfullname a global + } ::a + test var-4.2 {Tcl_GetVariableName, namespace variable} { + namespace eval test_ns_var { + variable george + testgetvarfullname george namespace + } + } ::test_ns_var::george + test var-4.3 {Tcl_GetVariableName, variable can't be array element} { + catch {unset a} + set a(1) foo + list [catch {testgetvarfullname a(1) global} msg] $msg + } {1 {unknown variable "a(1)"}} +} + +test var-5.1 {Tcl_GetVariableFullName, global variable} { + catch {unset a} + set a bar + namespace which -variable a +} {::a} +test var-5.2 {Tcl_GetVariableFullName, namespace variable} { + namespace eval test_ns_var { + variable martha + namespace which -variable martha + } +} {::test_ns_var::martha} +test var-5.3 {Tcl_GetVariableFullName, namespace variable} { + namespace which -variable test_ns_var::martha +} {::test_ns_var::martha} + +test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { + namespace eval test_ns_var { + variable boeing 777 + } + proc p {} { + global ::test_ns_var::boeing + set boeing + } + p +} {777} +test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { + namespace eval test_ns_var { + namespace eval test_ns_nested { + variable java java + } + proc p {} { + global ::test_ns_var::test_ns_nested::java + set java + } + } + test_ns_var::p +} {java} +test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} { + set ::test_ns_var::test_ns_nested:: 24 + proc p {} { + global ::test_ns_var::test_ns_nested:: + set {} + } + p +} {24} + +test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} { + catch {namespace delete test_ns_var} + namespace eval test_ns_var { + variable one 1 + } + list [info vars test_ns_var::*] [set test_ns_var::one] +} {::test_ns_var::one 1} +test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} { + set two 2222222 + namespace eval test_ns_var { + variable two + } + list [info vars test_ns_var::*] [catch {set test_ns_var::two} msg] $msg +} {::test_ns_var::one 1 {can't read "test_ns_var::two": no such variable}} +test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} { + namespace eval test_ns_var { + variable two 2 + } + list [info vars test_ns_var::*] \ + [namespace eval test_ns_var {set two}] +} {{::test_ns_var::two ::test_ns_var::one} 2} +test var-7.4 {Tcl_VariableObjCmd, list of vars} { + namespace eval test_ns_var { + variable three 3 four 4 + } + list [info vars test_ns_var::*] \ + [namespace eval test_ns_var {expr $three+$four}] +} {{::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one} 7} +test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} { + catch {unset a} + catch {unset five} + catch {unset six} + set a "" + set five 555 + set six 666 + namespace eval test_ns_var { + variable five 5 six + lappend a $five + } + lappend a $test_ns_var::five \ + [set test_ns_var::six 6] [set test_ns_var::six] $six + catch {unset five} + catch {unset six} + set a +} {5 5 6 6 666} +catch {unset newvar} +test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} { + namespace eval test_ns_var { + variable ::newvar cheers! + } + set newvar +} {cheers!} +catch {unset newvar} +test var-7.7 {Tcl_VariableObjCmd, bad var name} { + namespace eval test_ns_var { + list [catch {variable sev:::en 7} msg] $msg + } +} {1 {can't define "sev:::en": parent namespace doesn't exist}} +test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} { + set a "" + namespace eval test_ns_var { + variable eight 8 + lappend a $eight + variable eight + lappend a $eight + } + set a +} {8 8} +test var-7.9 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { + namespace eval test_ns_var { + proc p {} { + variable eight + list [set eight] [info vars] + } + p + } +} {8 eight} +test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { + proc p {} { ;# note this proc is at global :: scope + variable test_ns_var::eight + list [set eight] [info vars] + } + p +} {8 eight} +test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { + namespace eval test_ns_var { + variable {} {My name is empty} + } + proc p {} { ;# note this proc is at global :: scope + variable test_ns_var:: + list [set {}] [info vars] + } + p +} {{My name is empty} {{}}} + +test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} { + catch {namespace delete test_ns_var} + catch {unset a} + namespace eval test_ns_var { + variable v 123 + variable info "" + + proc traceUnset {name1 name2 op} { + variable info + set info [concat $info [list $name1 $name2 $op]] + } + + trace var v u [namespace code traceUnset] + } + list [unset test_ns_var::v] $test_ns_var::info +} {{} {test_ns_var::v {} u}} + +test var-9.1 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { + testsetnoerr v 1 +} 1 +test var-9.2 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { + catch {unset v} + list [catch {testsetnoerr v} res] $res; +} {1 {before get}} +test var-9.3 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { + catch {unset arr} + set arr(1) 1; + list [catch {testsetnoerr arr} res] $res; +} {1 {before get}} +test var-9.4 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { + namespace eval ns {variable v nsv} + testsetnoerr ns::v; +} nsv; +test var-9.5 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { + catch {namespace delete ns} + list [catch {testsetnoerr ns::v} res] $res; +} {1 {before get}} +test var-9.6 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { + catch {unset arr} + set arr(1) 1; + list [catch {testsetnoerr arr 2} res] $res; +} {1 {before set}} +test var-9.6 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { + catch {unset arr} + set arr(1) 1; + list [catch {testsetnoerr arr 2} res] $res; +} {1 {before set}} +test var-9.7 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { + # this test currently fails, should not... + # (some namespace function resets the interp while it should not) + catch {namespace delete ns} + list [catch {testsetnoerr ns::v 1} res] $res; +} {1 {before set}} +test var-9.8 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { + proc readonly args {error "read-only"} + set v 456 + trace var v w readonly + list [catch {testsetnoerr v 2} msg] $msg +} {1 {before set}} + +catch {namespace delete ns} +catch {unset arr} +catch {unset v} + +catch {rename p ""} +catch {namespace delete test_ns_var} +catch {unset xx} +catch {unset x} +catch {unset y} +catch {unset i} +catch {unset a} +catch {unset xxxxx} +catch {unset aaaaa} + diff --git a/contrib/tcl/tests/while-old.test b/contrib/tcl/tests/while-old.test new file mode 100644 index 0000000000000..f5e5b05faaa3a --- /dev/null +++ b/contrib/tcl/tests/while-old.test @@ -0,0 +1,113 @@ +# Commands covered: while +# +# This file contains the original set of tests for Tcl's while command. +# Since the while command is now compiled, a new set of tests covering +# the new implementation is in the file "while.test". Sourcing this file +# into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) while-old.test 1.14 97/05/16 10:44:19 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test while-old-1.1 {basic while loops} { + set count 0 + while {$count < 10} {set count [expr $count+1]} + set count +} 10 +test while-old-1.2 {basic while loops} { + set value xxx + while {2 > 3} {set value yyy} + set value +} xxx +test while-old-1.3 {basic while loops} { + set value 1 + while {"true"} { + incr value; + if {$value > 5} { + break; + } + } + set value +} 6 +test while-old-1.4 {basic while loops, multiline test expr} { + set value 1 + while {($tcl_platform(platform) != "foobar1") && \ + ($tcl_platform(platform) != "foobar2")} { + incr value + break + } + set value +} {2} +test while-old-1.5 {basic while loops, test expr in quotes} { + set value 1 + while "0 < 3" {set value 2; break} + set value +} {2} + +test while-old-2.1 {continue in while loop} { + set list {1 2 3 4 5} + set index 0 + set result {} + while {$index < 5} { + if {$index == 2} {set index [expr $index+1]; continue} + set result [concat $result [lindex $list $index]] + set index [expr $index+1] + } + set result +} {1 2 4 5} + +test while-old-3.1 {break in while loop} { + set list {1 2 3 4 5} + set index 0 + set result {} + while {$index < 5} { + if {$index == 3} break + set result [concat $result [lindex $list $index]] + set index [expr $index+1] + } + set result +} {1 2 3} + +test while-old-4.1 {errors in while loops} { + set err [catch {while} msg] + list $err $msg +} {1 {wrong # args: should be "while test command"}} +test while-old-4.2 {errors in while loops} { + set err [catch {while 1} msg] + list $err $msg +} {1 {wrong # args: should be "while test command"}} +test while-old-4.3 {errors in while loops} { + set err [catch {while 1 2 3} msg] + list $err $msg +} {1 {wrong # args: should be "while test command"}} +test while-old-4.4 {errors in while loops} { + set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] + list $err $msg +} {1 {can't use non-numeric string as operand of "+"}} +test while-old-4.5 {errors in while loops} { + catch {unset x} + set x 1 + set err [catch {while {$x} {set x foo}} msg] + list $err $msg +} {1 {expected boolean value but got "foo"}} +test while-old-4.6 {errors in while loops} { + set err [catch {while {1} {error "loop aborted"}} msg] + list $err $msg $errorInfo +} {1 {loop aborted} {loop aborted + while executing +"error "loop aborted""}} + +test while-old-5.1 {while return result} { + while {0} {set a 400} +} {} +test while-old-5.2 {while return result} { + set x 1 + while {$x} {set x 0} +} {} diff --git a/contrib/tcl/tests/while.test b/contrib/tcl/tests/while.test index ad3d3280d2faf..3cb43d0cc33ec 100644 --- a/contrib/tcl/tests/while.test +++ b/contrib/tcl/tests/while.test @@ -4,27 +4,46 @@ # 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) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) while.test 1.9 96/02/16 08:56:37 +# SCCS: @(#) @(#) while.test 1.8 97/06/24 10:36:56 if {[string compare test [info procs test]] == 1} then {source defs} -test while-1.1 {basic while loops} { - set count 0 - while {$count < 10} {set count [expr $count+1]} - set count -} 10 -test while-1.2 {basic while loops} { - set value xxx - while {2 > 3} {set value yyy} +# Basic "while" operation. + +catch {unset i} +catch {unset a} + +test while-1.1 {TclCompileWhileCmd: missing test expression} { + catch {while } msg + set msg +} {wrong # args: should be "while test command"} +test while-1.2 {TclCompileWhileCmd: error in test expression} { + set i 0 + catch {while {$i<}} msg + set errorInfo +} {syntax error in expression "$i<" + ("while" test expression) + while compiling +"while"} +test while-1.3 {TclCompileWhileCmd: error in test expression} { + set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] + list $err $msg +} {1 {can't use non-numeric string as operand of "+"}} +test while-1.4 {TclCompileWhileCmd: multiline test expr} { + set value 1 + while {($tcl_platform(platform) != "foobar1") && \ + ($tcl_platform(platform) != "foobar2")} { + incr value + break + } set value -} xxx -test while-1.3 {basic while loops} { +} {2} +test while-1.5 {TclCompileWhileCmd: non-numeric boolean test expr} { set value 1 while {"true"} { incr value; @@ -34,66 +53,267 @@ test while-1.3 {basic while loops} { } set value } 6 +test while-1.6 {TclCompileWhileCmd: test expr is enclosed in quotes} { + set i 0 + while "$i > 5" {} +} {} +test while-1.7 {TclCompileWhileCmd: missing command body} { + set i 0 + catch {while {$i < 5} } msg + set msg +} {wrong # args: should be "while test command"} +test while-1.8 {TclCompileWhileCmd: error compiling command body} { + set i 0 + catch {while {$i < 5} {set}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("while" body line 1) + while compiling +"while"} +test while-1.9 {TclCompileWhileCmd: simple command body} { + set a {} + set i 1 + while {$i<6} { + if $i==4 break + set a [concat $a $i] + incr i + } + set a +} {1 2 3} +test while-1.10 {TclCompileWhileCmd: command body in quotes} { + set a {} + set i 1 + while {$i<6} "append a x; incr i" + set a +} {xxxxx} +test while-1.11 {TclCompileWhileCmd: computed command body} { + catch {unset x1} + catch {unset bb} + catch {unset x2} + set x1 {append a x1; } + set bb {break} + set x2 {; append a x2; incr i} + set a {} + set i 1 + while {$i<6} $x1$bb$x2 + set a +} {x1} +test while-1.12 {TclCompileWhileCmd: long command body} { + set a {} + set i 1 + while {$i<6} { + if $i==4 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + incr i + } + set a +} {1 2 3} +test while-1.13 {TclCompileWhileCmd: while command result} { + set i 0 + set a [while {$i < 5} {incr i}] + set a +} {} +test while-1.14 {TclCompileWhileCmd: while command result} { + set i 0 + set a [while {$i < 5} {if $i==3 break; incr i}] + set a +} {} + +# Check "while" and "continue". + +test while-2.1 {continue tests} { + set a {} + set i 1 + while {$i <= 4} { + incr i + if {$i == 3} continue + set a [concat $a $i] + } + set a +} {2 4 5} +test while-2.2 {continue tests} { + set a {} + set i 1 + while {$i <= 4} { + incr i + if {$i != 2} continue + set a [concat $a $i] + } + set a +} {2} +test while-2.3 {continue tests, nested loops} { + set msg {} + set i 1 + while {$i <= 4} { + incr i + set a 1 + while {$a <= 2} { + incr a + if {$i>=3 && $a>=3} continue + set msg [concat $msg "$i.$a"] + } + } + set msg +} {2.2 2.3 3.2 4.2 5.2} +test while-2.4 {continue tests, long command body} { + set a {} + set i 1 + while {$i<6} { + if $i==2 {incr i; continue} + if $i==4 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + incr i + } + set a +} {1 3} -test while-2.1 {continue in while loop} { - set list {1 2 3 4 5} - set index 0 - set result {} - while {$index < 5} { - if {$index == 2} {set index [expr $index+1]; continue} - set result [concat $result [lindex $list $index]] - set index [expr $index+1] +# Check "while" and "break". + +test while-3.1 {break tests} { + set a {} + set i 1 + while {$i <= 4} { + if {$i == 3} break + set a [concat $a $i] + incr i + } + set a +} {1 2} +test while-3.2 {break tests, nested loops} { + set msg {} + set i 1 + while {$i <= 4} { + set a 1 + while {$a <= 2} { + if {$i>=2 && $a>=2} break + set msg [concat $msg "$i.$a"] + incr a + } + incr i + } + set msg +} {1.1 1.2 2.1 3.1 4.1} +test while-3.3 {break tests, long command body} { + set a {} + set i 1 + while {$i<6} { + if $i==2 {incr i; continue} + if $i==5 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if $i==4 break + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + incr i } - set result -} {1 2 4 5} + set a +} {1 3} + +# Check "while", "break", "continue" and computed command names. -test while-3.1 {break in while loop} { - set list {1 2 3 4 5} - set index 0 - set result {} - while {$index < 5} { - if {$index == 3} break - set result [concat $result [lindex $list $index]] - set index [expr $index+1] +test while-4.1 {while and computed command names} { + set i 0 + set z while + $z {$i < 10} { + incr i } - set result -} {1 2 3} + set i +} 10 -test while-4.1 {errors in while loops} { - set err [catch {while} msg] - list $err $msg -} {1 {wrong # args: should be "while test command"}} -test while-4.2 {errors in while loops} { - set err [catch {while 1} msg] - list $err $msg -} {1 {wrong # args: should be "while test command"}} -test while-4.3 {errors in while loops} { - set err [catch {while 1 2 3} msg] - list $err $msg -} {1 {wrong # args: should be "while test command"}} -test while-4.4 {errors in while loops} { - set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] - list $err $msg -} {1 {can't use non-numeric string as operand of "+"}} -test while-4.5 {errors in while loops} { - set x 1 - set err [catch {while {$x} {set x foo}} msg] - list $err $msg -} {1 {expected boolean value but got "foo"}} -test while-4.6 {errors in while loops} { - set err [catch {while {1} {error "loop aborted"}} msg] - list $err $msg $errorInfo -} {1 {loop aborted} {loop aborted - while executing -"error "loop aborted"" - ("while" body line 1) - invoked from within -"while {1} {error "loop aborted"}"}} +test while-5.1 {break and computed command names} { + set i 0 + set z break + while 1 { + if {$i > 10} $z + incr i + } + set i +} 11 -test while-5.1 {while return result} { - while {0} {set a 400} -} {} -test while-5.2 {while return result} { - set x 1 - while {$x} {set x 0} -} {} +test while-6.1 {continue and computed command names} { + set i 0 + set z continue + while 1 { + incr i + if {$i < 10} $z + break + } + set i +} 10 diff --git a/contrib/tcl/tests/winFCmd.test b/contrib/tcl/tests/winFCmd.test new file mode 100644 index 0000000000000..83691b0e13512 --- /dev/null +++ b/contrib/tcl/tests/winFCmd.test @@ -0,0 +1,975 @@ +# This file tests the tclWinFCmd.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winFCmd.test 1.8 97/05/21 14:49:13 +# + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {$tcl_platform(platform) != "windows"} { + return +} + +proc createfile {file {string a}} { + set f [open $file w] + puts -nonewline $f $string + close $f + return $string +} + +proc contents {file} { + set f [open $file r] + set r [read $f] + close $f + set r +} + +proc cleanup {args} { + foreach p ". $args" { + set x "" + catch { + set x [glob [file join $p tf*] [file join $p td*]] + } + if {$x != ""} { + catch {eval file delete -force -- $x} + } + } +} + +set testConfig(32s) 0 +set testConfig(95) 0 +set testConfig(NT) 0 +set testConfig(cdrom) 0 +set testConfig(exdev) 0 +set testConfig(UNCPath} 0 + +# find a CD-ROM so we can test read-only filesystems. + +set cdrom {} +set nodrive x: +foreach p {d e f g h i j k l m n o p q r s t u v w x y z} { + set name ${p}:/dummy~~.fil + if [catch {set fd [open $name w]}] { + set err [lindex $errorCode 1] + if {$cdrom == "" && $err == "EACCES"} { + set cdrom ${p}: + } + if {$err == "ENOENT"} { + set nodrive ${p}: + } + } else { + close $fd + file delete $name + } +} + +proc findfile {dir} { + foreach p [glob $dir/*] { + if {[file type $p] == "file"} { + return $p + } + } + foreach p [glob $dir/*] { + if {[file type $p] == "directory"} { + set f [findfile $p] + if {$f != ""} { + return $f + } + } + } + return "" +} + +if {$cdrom == ""} { + puts "Couldn't find a CD-ROM. Skipping tests that access CD-ROM." + puts "If you have a CD-ROM, insert a data disk and rerun tests." +} else { + set testConfig(cdrom) 1 + set cdfile [findfile $cdrom] +} + +if {[file exists c:/] && [file exists d:/]} { + catch {file delete d:/tf1} + if {[catch {close [open d:/tf1 w]}] == 0} { + file delete d:/tf1 + set testConfig(exdev) 1 + } +} + +switch $tcl_platform(os) { + "Windows NT" {set testConfig(NT) 1} + "Windows 95" {set testConfig(95) 1} + "Win32s" {set testConfig(32s) 1} +} + +if {[file exists //bisque/icepick]} { + set testConfig(UNCPath) 1 +} + +file delete -force -- td1 +set foo [catch {open td1 w} testfile] +if {$foo} { + set testConfig(longFileNames) 0 +} else { + close $testfile + set testConfig(longFileNames) 1 + file delete -force -- td1 +} + +# A really long file name +# length of longname is 1216 chars, which should be greater than any static +# buffer or allowable filename. + +set longname "abcdefghihjllmnopqrstuvwxyz01234567890" +append longname $longname +append longname $longname +append longname $longname +append longname $longname +append longname $longname + +# Uses the "testfile" command instead of the "file" command. The "file" +# command provides several layers of sanity checks on the arguments and +# it can be difficult to actually forward "insane" arguments to the +# low-level posix emulation layer. + +test winFCmd-1.1 {TclpRenameFile: errno: EACCES} {cdrom} { + list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} { + cleanup + file mkdir td1/td2/td3 + file mkdir td2 + list [catch {testfile mv td2 td1/td2} msg] $msg +} {1 EEXIST} +test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} { + cleanup + list [catch {testfile mv / td1} msg] $msg +} {1 EINVAL} +test winFCmd-1.4 {TclpRenameFile: errno: EINVAL} { + cleanup + file mkdir td1 + list [catch {testfile mv td1 td1/td2} msg] $msg +} {1 EINVAL} +test winFCmd-1.5 {TclpRenameFile: errno: EISDIR} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {testfile mv tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-1.6 {TclpRenameFile: errno: ENOENT} { + cleanup + list [catch {testfile mv tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.7 {TclpRenameFile: errno: ENOENT} { + cleanup + list [catch {testfile mv "" tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.8 {TclpRenameFile: errno: ENOENT} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 ""} msg] $msg +} {1 ENOENT} +test winFCmd-1.9 {TclpRenameFile: errno: ENOTDIR} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {testfile mv td1 tf1} msg] $msg +} {1 ENOTDIR} +test winFCmd-1.10 {TclpRenameFile: errno: EXDEV} {exdev} { + file delete -force d:/tf1 + file mkdir c:/tf1 + set msg [list [catch {testfile mv c:/tf1 d:/tf1} msg] $msg] + file delete -force c:/tf1 + set msg +} {1 EXDEV} +test winFCmd-1.11 {TclpRenameFile: errno: EACCES} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile mv tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-1.12 {TclpRenameFile: errno: EACCES} { + cleanup + createfile tf1 + set fd [open tf2 w] + set msg [list [catch {testfile mv tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-1.13 {TclpRenameFile: errno: EACCES} { + cleanup + list [catch {testfile mv nul tf1} msg] $msg +} {1 EACCES} +test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {95} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 nul} msg] $msg +} {1 EACCES} +test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {NT} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 nul} msg] $msg +} {1 EEXIST} +test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} { + cleanup + createfile tf1 tf1 + testfile mv tf1 tf2 + list [file exists tf1] [contents tf2] +} {0 tf1} +test winFCmd-1.17 {TclpRenameFile: MoveFile() == FALSE} { + cleanup + list [catch {testfile mv tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} { + cleanup + list [catch {testfile mv tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.19 {TclpRenameFile: errno == EACCES} { + cleanup + list [catch {testfile mv nul g} msg] $msg +} {1 EACCES} +# under 95, this would actually move the current dir out from under yourself. +test winFCmd-1.20 {TclpRenameFile: src is dir} {NT} { + cleanup + file delete /tf1 + list [catch {testfile mv [pwd] /tf1} msg] $msg +} {1 EACCES} +test winFCmd-1.21 {TclpRenameFile: obscenely long src} { + list [catch {testfile mv $longname tf1} msg] $msg +} {1 ENAMETOOLONG} +test winFCmd-1.22 {TclpRenameFile: obscenely long dst} {NT} { + # return ENOENT if name is too long! + cleanup + createfile tf1 + list [catch {testfile mv tf1 $longname} msg] $msg +} {1 ENOENT} +test winFCmd-1.23 {TclpRenameFile: obscenely long dst} {95} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 $longname} msg] $msg +} {1 ENAMETOOLONG} +test winFCmd-1.24 {TclpRenameFile: move dir into self} { + cleanup + file mkdir td1 + list [catch {testfile mv [pwd]/td1 td1/td2} msg] $msg +} {1 EINVAL} +test winFCmd-1.25 {TclpRenameFile: move a root dir} { + cleanup + list [catch {testfile mv / c:/} msg] $msg +} {1 EINVAL} +test winFCmd-1.26 {TclpRenameFile: cross file systems} {cdrom} { + cleanup + file mkdir td1 + list [catch {testfile mv td1 $cdrom/td1} msg] $msg +} {1 EXDEV} +test winFCmd-1.27 {TclpRenameFile: readonly fs} {cdrom} { + cleanup + list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-1.28 {TclpRenameFile: open file} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile mv tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-1.29 {TclpRenameFile: errno == EEXIST} { + cleanup + createfile tf1 + createfile tf2 + testfile mv tf1 tf2 + list [file exist tf1] [file exist tf2] +} {0 1} +test winFCmd-1.30 {TclpRenameFile: src is dir} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {testfile mv td1 tf1} msg] $msg +} {1 ENOTDIR} +test winFCmd-1.31 {TclpRenameFile: dst is dir} { + cleanup + file mkdir td1 + file mkdir td2/td2 + list [catch {testfile mv td1 td2} msg] $msg +} {1 EEXIST} +test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory fails} { + cleanup + file mkdir td1 + file mkdir td2/td2 + list [catch {testfile mv td1 td2} msg] $msg +} {1 EEXIST} +test winFCmd-1.33 {TclpRenameFile: TclpRemoveDirectory succeeds} { + cleanup + file mkdir td1/td2 + file mkdir td2 + testfile mv td1 td2 + list [file exist td1] [file exist td2] [file exist td2/td2] +} {0 1 1} +test winFCmd-1.34 {TclpRenameFile: After removing dst dir, MoveFile fails} {exdev} { + file mkdir d:/td1 + testchmod 000 d:/td1 + set msg [list [catch {testfile mv c:/windows d:/td1} msg] $msg] + set msg "$msg [file writable d:/td1]" + file delete d:/td1 + set msg +} {1 EXDEV 0} +test winFCmd-1.35 {TclpRenameFile: src is dir, dst is not} { + file mkdir td1 + createfile tf1 + list [catch {testfile mv td1 tf1} msg] $msg +} {1 ENOTDIR} +test winFCmd-1.36 {TclpRenameFile: src is not dir, dst is} { + file mkdir td1 + createfile tf1 + list [catch {testfile mv tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-1.37 {TclpRenameFile: src and dst not dir} { + createfile tf1 tf1 + createfile tf2 tf2 + testfile mv tf1 tf2 + contents tf2 +} {tf1} +test winFCmd-1.38 {TclpRenameFile: need to restore temp file} { + # Can't figure out how to cause this. + # Need a file that can't be copied. +} {} + +test winFCmd-2.1 {TclpCopyFile: errno: EACCES} {cdrom} { + cleanup + list [catch {testfile cp $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-2.2 {TclpCopyFile: errno: EISDIR} { + cleanup + file mkdir td1 + list [catch {testfile cp td1 tf1} msg] $msg +} {1 EISDIR} +test winFCmd-2.3 {TclpCopyFile: errno: EISDIR} { + cleanup + createfile tf1 + file mkdir td1 + list [catch {testfile cp tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-2.4 {TclpCopyFile: errno: ENOENT} { + cleanup + list [catch {testfile cp tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-2.5 {TclpCopyFile: errno: ENOENT} { + cleanup + list [catch {testfile cp "" tf2} msg] $msg +} {1 ENOENT} +test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} { + cleanup + createfile tf1 + list [catch {testfile cp tf1 ""} msg] $msg +} {1 ENOENT} +test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {95} { + cleanup + createfile tf1 + set fd [open tf2 w] + set msg [list [catch {testfile cp tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {NT} { + cleanup + list [catch {testfile cp nul tf1} msg] $msg +} {1 EACCES} +test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} {95} { + cleanup + list [catch {testfile cp nul tf1} msg] $msg +} {1 ENOENT} +test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} { + cleanup + createfile tf1 tf1 + testfile cp tf1 tf2 + list [contents tf1] [contents tf2] +} {tf1 tf1} +test winFCmd-2.11 {TclpCopyFile: CopyFile succeeds} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + testfile cp tf1 tf2 + list [contents tf1] [contents tf2] +} {tf1 tf1} +test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} { + cleanup + createfile tf1 tf1 + testchmod 000 tf1 + testfile cp tf1 tf2 + list [contents tf2] [file writable tf2] +} {tf1 0} +test winFCmd-2.13 {TclpCopyFile: CopyFile fails} { + cleanup + createfile tf1 + file mkdir td1 + list [catch {testfile cp tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-2.14 {TclpCopyFile: errno == EACCES} { + cleanup + file mkdir td1 + list [catch {testfile cp td1 tf1} msg] $msg +} {1 EISDIR} +test winFCmd-2.15 {TclpCopyFile: src is directory} { + cleanup + file mkdir td1 + list [catch {testfile cp td1 tf1} msg] $msg +} {1 EISDIR} +test winFCmd-2.16 {TclpCopyFile: dst is directory} { + cleanup + createfile tf1 + file mkdir td1 + list [catch {testfile cp tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-2.17 {TclpCopyFile: dst is readonly} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + testchmod 000 tf2 + testfile cp tf1 tf2 + list [file writable tf2] [contents tf2] +} {1 tf1} +test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} {95} { + cleanup + createfile tf1 + createfile tf2 + testchmod 000 tf2 + set fd [open tf2] + set msg [list [catch {testfile cp tf1 tf2} msg] $msg] + close $fd + set msg "$msg [file writable tf2]" +} {1 EACCES 0} + +test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} {cdrom} { + list [catch {testfile rm $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-3.2 {TclpDeleteFile: errno: EISDIR} { + cleanup + file mkdir td1 + list [catch {testfile rm td1} msg] $msg +} {1 EISDIR} +test winFCmd-3.3 {TclpDeleteFile: errno: ENOENT} { + cleanup + list [catch {testfile rm tf1} msg] $msg +} {1 ENOENT} +test winFCmd-3.4 {TclpDeleteFile: errno: ENOENT} { + cleanup + list [catch {testfile rm ""} msg] $msg +} {1 ENOENT} +test winFCmd-3.5 {TclpDeleteFile: errno: EACCES} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile rm tf1} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-3.6 {TclpDeleteFile: errno: EACCES} { + cleanup + list [catch {testfile rm nul} msg] $msg +} {1 EACCES} +test winFCmd-3.7 {TclpDeleteFile: DeleteFile succeeds} { + cleanup + createfile tf1 + testfile rm tf1 + file exist tf1 +} {0} +test winFCmd-3.8 {TclpDeleteFile: DeleteFile fails} { + cleanup + file mkdir td1 + list [catch {testfile rm td1} msg] $msg +} {1 EISDIR} +test winFCmd-3.9 {TclpDeleteFile: errno == EACCES} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile rm tf1} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-3.10 {TclpDeleteFile: path is readonly} { + cleanup + createfile tf1 + testchmod 000 tf1 + testfile rm tf1 + file exists tf1 +} {0} +test winFCmd-3.11 {TclpDeleteFile: still can't remove path} { + cleanup + set fd [open tf1 w] + testchmod 000 tf1 + set msg [list [catch {testfile rm tf1} msg] $msg] + close $fd + set msg +} {1 EACCES} + +test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {cdrom NT} { + list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg +} {1 EACCES} +test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} {cdrom 95} { + list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg +} {1 ENOSPC} +test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} { + cleanup + file mkdir td1 + list [catch {testfile mkdir td1} msg] $msg +} {1 EEXIST} +test winFCmd-4.4 {TclpCreateDirectory: errno: ENOENT} { + cleanup + list [catch {testfile mkdir td1/td2} msg] $msg +} {1 ENOENT} +test winFCmd-4.5 {TclpCreateDirectory: CreateDirectory succeeds} { + cleanup + testfile mkdir td1 + file type td1 +} {directory} + +test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} { + cleanup + file mkdir td1 + testfile cpdir td1 td2 + list [file type td1] [file type td2] +} {directory directory} + +test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} { + cleanup + file mkdir td1 + testchmod 000 td1 + testfile rmdir td1 + file exist td1 +} {0} +test winFCmd-6.2 {TclpRemoveDirectory: errno: EEXIST} { + cleanup + file mkdir td1/td2 + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-6.3 {TclpRemoveDirectory: errno: EACCES} { + # can't test this w/o removing everything on your hard disk first! + # testfile rmdir / +} {} +test winFCmd-6.4 {TclpRemoveDirectory: errno: ENOENT} { + cleanup + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 ENOENT}} +test winFCmd-6.5 {TclpRemoveDirectory: errno: ENOENT} { + cleanup + list [catch {testfile rmdir ""} msg] $msg +} {1 ENOENT} +test winFCmd-6.6 {TclpRemoveDirectory: errno: ENOTDIR} { + cleanup + createfile tf1 + list [catch {testfile rmdir tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.7 {TclpRemoveDirectory: RemoveDirectory succeeds} { + cleanup + file mkdir td1 + testfile rmdir td1 + file exists td1 +} {0} +test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} { + cleanup + createfile tf1 + list [catch {testfile rmdir tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} { + cleanup + file mkdir td1 + testchmod 000 td1 + testfile rmdir td1 + file exists td1 +} {0} +test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {95} { + cleanup + list [catch {testfile rmdir nul} msg] $msg +} {1 {nul EACCES}} +test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {NT} { + cleanup + list [catch {testfile rmdir /} msg] $msg +} {1 {\ EACCES}} +test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {95} { + cleanup + createfile tf1 + list [catch {testfile rmdir tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.13 {TclpRemoveDirectory: write-protected} { + cleanup + file mkdir td1 + testchmod 000 td1 + testfile rmdir td1 + file exists td1 +} {0} +test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {95} { + cleanup + file mkdir td1/td2 + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-6.15 {TclpRemoveDirectory: !recursive} { + cleanup + file mkdir td1/td2 + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-6.16 {TclpRemoveDirectory: recursive, but errno != EEXIST} { + cleanup + createfile tf1 + list [catch {testfile rmdir -force tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.17 {TclpRemoveDirectory: calls TraverseWinTree} { + cleanup + file mkdir td1/td2 + testfile rmdir -force td1 + file exists td1 +} {0} + +test winFCmd-7.1 {TraverseWinTree: targetPtr == NULL} { + cleanup + file mkdir td1/td2/td3 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.2 {TraverseWinTree: targetPtr != NULL} { + cleanup + file mkdir td1/td2/td3 + testfile cpdir td1 td2 + list [file exists td1] [file exists td2] +} {1 1} +test winFCmd-7.3 {TraverseWinTree: sourceAttr == -1} { + cleanup + list [catch {testfile cpdir td1 td2} msg] $msg +} {1 {td1 ENOENT}} +test winFCmd-7.4 {TraverseWinTree: source isn't directory} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.5 {TraverseWinTree: call TraversalCopy: DOTREE_F} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.6 {TraverseWinTree: call TraversalDelete: DOTREE_F} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {95 cdrom} { + list [catch {testfile rmdir $cdrom/} msg] $msg +} "1 {$cdrom\\ EEXIST}" +test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} {NT cdrom} { + list [catch {testfile rmdir $cdrom/} msg] $msg +} "1 {$cdrom\\ EACCES}" +test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} { + # can't make it happen +} {} +test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} { + cleanup + file mkdir td1 + testchmod 000 td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + list [file exists td2] [file writable td2] +} {1 0} +test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {95} { + cleanup + file mkdir td1 + list [catch {testfile cpdir td1 /} msg] $msg +} {1 {\ EEXIST}} +test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {NT} { + cleanup + file mkdir td1 + list [catch {testfile cpdir td1 /} msg] $msg +} {1 {\ EACCES}} +test winFCmd-7.16 {TraverseWinTree: recurse on files: no files} { + cleanup + file mkdir td1 + testfile cpdir td1 td2 +} {} +test winFCmd-7.17 {TraverseWinTree: recurse on files: one file} { + cleanup + file mkdir td1 + createfile td1/td2 + testfile cpdir td1 td2 + glob td2/* +} {td2/td2} +test winFCmd-7.18 {TraverseWinTree: recurse on files: several files and dir} { + cleanup + file mkdir td1 + createfile td1/tf1 + createfile td1/tf2 + file mkdir td1/td2/td3 + createfile td1/tf3 + createfile td1/tf4 + testfile cpdir td1 td2 + glob td2/* +} {td2/tf1 td2/tf2 td2/td2 td2/tf3 td2/tf4} +test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} { + cleanup + file mkdir td1 + testchmod 000 td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + list [file exists td2] [file writable td2] +} {1 0} +test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.21 {TraverseWinTree: fill errorPtr} { + cleanup + list [catch {testfile cpdir td1 td2} msg] $msg +} {1 {td1 ENOENT}} + +test winFCmd-8.1 {TraversalCopy: DOTREE_F} { + cleanup + file mkdir td1 + list [catch {testfile cpdir td1 td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} { + cleanup + file mkdir td1/td2 + testchmod 000 td1 + testfile cpdir td1 td2 + list [file writable td1] [file writable td1/td2] +} {0 1} +test winFCmd-8.3 {TraversalCopy: DOTREE_POSTD} { + cleanup + file mkdir td1 + testfile cpdir td1 td2 +} {} + +test winFCmd-9.1 {TraversalDelete: DOTREE_F} { + cleanup + file mkdir td1 + createfile td1/tf1 + testfile rmdir -force td1 +} {} +test winFCmd-9.2 {TraversalDelete: DOTREE_F} {95} { + cleanup + file mkdir td1 + set fd [open td1/tf1 w] + set msg [list [catch {testfile rmdir -force td1} msg] $msg] + close $fd + set msg +} {1 {td1\tf1 EACCES}} +test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} { + cleanup + file mkdir td1/td2 + testchmod 000 td1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} { + cleanup + file mkdir td1/td1/td3/td4/td5 + testfile rmdir -force td1 +} {} + +test winFCmd-10.1 {AttributesPosixError - get} { + cleanup + list [catch {file attributes td1 -archive} msg] $msg +} {1 {cannot get attribute "-archive" for file "td1": no such file or directory}} +test winFCmd-10.2 {AttributesPosixError - set} { + cleanup + list [catch {file attributes td1 -archive 0} msg] $msg +} {1 {cannot set attribute "-archive" for file "td1": no such file or directory}} + +test winFCmd-11.1 {GetWinFileAttributes} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -archive} msg] $msg [cleanup] +} {0 1 {}} +test winFCmd-11.2 {GetWinFileAttributes} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -readonly} msg] $msg [cleanup] +} {0 0 {}} +test winFCmd-11.3 {GetWinFileAttributes} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -hidden} msg] $msg [cleanup] +} {0 0 {}} +test winFCmd-11.4 {GetWinFileAttributes} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -system} msg] $msg [cleanup] +} {0 0 {}} + +test winFCmd-12.1 {ConvertFileNameFormat} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -longname} msg] $msg [cleanup] +} {0 td1 {}} +test winFCmd-12.2 {ConvertFileNameFormat} { + cleanup + file mkdir td1 + close [open td1/td1 w] + list [catch {file attributes td1/td1 -longname} msg] $msg [cleanup] +} {0 td1/td1 {}} +test winFCmd-12.3 {ConvertFileNameFormat} { + cleanup + file mkdir td1 + file mkdir td1/td2 + close [open td1/td3 w] + list [catch {file attributes td1/td2/../td3 -longname} msg] $msg [cleanup] +} {0 td1/td2/../td3 {}} +test winFCmd-12.4 {ConvertFileNameFormat} { + cleanup + close [open td1 w] + list [catch {file attributes ./td1 -longname} msg] $msg [cleanup] +} {0 ./td1 {}} +test winFCmd-12.5 {ConvertFileNameFormat} { + catch {file delete -force -- c:/td1} + close [open c:/td1 w] + list [catch {file attributes c:/td1 -longname} msg] $msg [file delete -force -- c:/td1] +} {0 c:/td1 {}} +test winFCmd-12.6 {ConvertFileNameFormat} {UNCPath} { + catch {file delete -force -- //bisque/icepick/test/td1} + close [open //bisque/icepick/test/td1 w] + list [catch {file attributes //bisque/icepick/test/td1 -longname} msg] $msg [file delete -force -- //bisque/icepick/test/td1] +} {0 //bisque/icepick/test/td1 {}} +test winFCmd-12.7 {ConvertFileNameFormat} {longFileNames} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -longname} msg] $msg [cleanup] +} {0 td1 {}} +test winFCmd-12.8 {ConvertFileNameFormat} {32s} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -longname} msg] $msg [cleanup] +} {0 td1 {}} +test winFCmd-12.9 {ConvertFileNameFormat} {longFileNames} { + cleanup + close [open td1td1td1 w] + list [catch {file attributes td1td1td1 -shortname}] [cleanup] +} {0 {}} +test winFCmd-12.10 {ConvertFileNameFormat} {longFileNames} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -shortname} msg] $msg [cleanup] +} {0 td1 {}} + +test winFCmd-13.1 {GetWinFileLongName} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -longname} msg] $msg [cleanup] +} {0 td1 {}} + +test winFCmd-14.1 {GetWinFileShortName} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -shortname} msg] $msg [cleanup] +} {0 td1 {}} + +test winFCmd-15.1 {SetWinFileAttributes} { + cleanup + list [catch {file attributes td1 -archive 0} msg] $msg +} {1 {cannot set attribute "-archive" for file "td1": no such file or directory}} +test winFCmd-15.2 {SetWinFileAttributes - archive} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -archive 1} msg] $msg [file attributes td1 -archive] [cleanup] +} {0 {} 1 {}} +test winFCmd-15.3 {SetWinFileAttributes - archive} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -archive 0} msg] $msg [file attributes td1 -archive] [cleanup] +} {0 {} 0 {}} +test winFCmd-15.4 {SetWinFileAttributes - hidden} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -hidden 1} msg] $msg [file attributes td1 -hidden] [file attributes td1 -hidden 0] [cleanup] +} {0 {} 1 {} {}} +test winFCmd-15.5 {SetWinFileAttributes - hidden} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -hidden 0} msg] $msg [file attributes td1 -hidden] [cleanup] +} {0 {} 0 {}} +test winFCmd-15.6 {SetWinFileAttributes - readonly} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -readonly 1} msg] $msg [file attributes td1 -readonly] [cleanup] +} {0 {} 1 {}} +test winFCmd-15.7 {SetWinFileAttributes - readonly} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -readonly 0} msg] $msg [file attributes td1 -readonly] [cleanup] +} {0 {} 0 {}} +test winFCmd-15.8 {SetWinFileAttributes - system} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -system 1} msg] $msg [file attributes td1 -system] [cleanup] +} {0 {} 1 {}} +test winFCmd-15.9 {SetWinFileAttributes - system} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -system 0} msg] $msg [file attributes td1 -system] [cleanup] +} {0 {} 0 {}} +test winFCmd-15.10 {SetWinFileAttributes - failing} {cdrom} { + cleanup + catch {file attributes $cdfile -archive 1} +} {1} + +cleanup + +return + +foreach source {tef ted tnf tnd "" nul com1} { + foreach chmodsrc {000 755} { + foreach dest "tfn tfe tdn tdempty tdfull td1/td2 $p $p/td1 {} nul" { + foreach chmoddst {000 755} { + puts hi + cleanup + file delete -force ted tef + file mkdir ted + createfile tef + createfile tfe + file mkdir tdempty + file mkdir tdfull/td1/td2 + + catch {testchmod $chmodsrc $source} + catch {testchmod $chmoddst $dest} + + if [catch {file rename $source $dest} msg] { + puts "file rename $source ($chmodsrc) $dest ($chmoddst)" + puts $msg + } + } + } + } +} + diff --git a/contrib/tcl/tests/winNotify.test b/contrib/tcl/tests/winNotify.test new file mode 100644 index 0000000000000..2914a41b1abb6 --- /dev/null +++ b/contrib/tcl/tests/winNotify.test @@ -0,0 +1,155 @@ +# This file tests the tclWinNotify.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winNotify.test 1.2 97/04/14 17:24:56 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {$tcl_platform(platform) != "windows"} { + return +} + +# There is no explicit test for InitNotifier or NotifierExitHandler + +test winNotify-1.1 {Tcl_SetTimer: positive timeout} { + set done 0 + after 1000 { set done 1 } + vwait done + set done +} 1 +test winNotify-1.2 {Tcl_SetTimer: positive timeout, message pending} { + set x 0 + set y 1 + set a1 [after 0 { incr y }] + after cancel $a1 + after 500 { incr x } + vwait x + list $x $y +} {1 1} +test winNotify-1.3 {Tcl_SetTimer: cancelling positive timeout} { + set x 0 + set y 1 + set id [after 10000 { incr y }] + after 0 { incr x } + vwait x + after cancel $id + list $x $y +} {1 1} +test winNotify-1.4 {Tcl_SetTimer: null timeout, message pending} { + set x 0 + set y 1 + after 0 { incr x } + after 0 { incr y } + vwait x + list $x $y +} {1 2} + +test winNotify-2.1 {Tcl_ResetIdleTimer} { + set x 0 + update + after idle { incr x } + vwait x + set x +} 1 +test winNotify-2.2 {Tcl_ResetIdleTimer: message pending} { + set x 0 + set y 1 + update + after idle { incr x } + after idle { incr y } + update + list $x $y +} {1 2} + +test winNotify-3.1 {NotifierProc: non-modal normal timer} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + after 500 { incr x; testeventloop done } + testeventloop wait + set x +} 1 +test winNotify-3.2 {NotifierProc: non-modal normal timer, rescheduled} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + after 500 { incr x; after 100 {incr x; testeventloop done }} + testeventloop wait + set x +} 2 +test winNotify-3.3 {NotifierProc: modal normal timer} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + after 500 { incr x } + vwait x + set x +} 1 +test winNotify-3.4 {NotifierProc: modal normal timer, rescheduled} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + set y 0 + after 500 { incr y; after 100 {incr x}} + vwait x + list $x $y +} {1 1} +test winNotify-3.5 {NotifierProc: non-modal idle timer} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + after idle { incr x; testeventloop done } + testeventloop wait + set x +} 1 +test winNotify-3.6 {NotifierProc: non-modal idle timer, rescheduled} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + after idle { incr x; after idle {incr x; testeventloop done }} + testeventloop wait + set x +} 2 +test winNotify-3.7 {NotifierProc: modal idle timer} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + after idle { incr x } + vwait x + set x +} 1 +test winNotify-3.8 {NotifierProc: modal idle timer, rescheduled} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + set y 0 + after idle { incr y; after idle {incr x}} + vwait x + list $x $y +} {1 1} + +# Tcl_DoOneEvent is tested by the timer.test, io.test, and event.test files diff --git a/contrib/tcl/tests/winPipe.test b/contrib/tcl/tests/winPipe.test new file mode 100644 index 0000000000000..af26db4537207 --- /dev/null +++ b/contrib/tcl/tests/winPipe.test @@ -0,0 +1,283 @@ +# +# winPipe.test -- +# +# This file contains a collection of tests for tclWinPipe.c + +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winPipe.test 1.7 97/06/23 17:30:41 + +if {$tcl_platform(platform) != "windows"} { + return +} + +set cat16 [file join $tcl_library ../win/cat16.exe] +set cat32 [file join $tcl_library ../win/cat32.exe] + +if {[string compare test [info procs test]] == 1} then {source defs} + +if [catch {puts console1 ""}] { + set testConfig(AllocConsole) 1 +} else { + set testConfig(.console) 1 +} + +set big aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n +append big $big +append big $big +append big $big +append big $big +append big $big +append big $big + +set f [open "little" w] +puts -nonewline $f "little" +close $f + +set f [open "big" w] +puts -nonewline $f $big +close $f + +proc contents {file} { + set f [open $file r] + set r [read $f] + close $f + set r +} + +if [file exists $cat32] { +test winpipe-1.1 {32 bit comprehensive tests: from little file} { + exec $cat32 < little > stdout 2> stderr + list [contents stdout] [contents stderr] +} "little stderr32" +test winpipe-1.2 {32 bit comprehensive tests: from big file} { + exec $cat32 < big > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr32" +test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {nt} { + exec more < little | $cat32 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{little\n} stderr32" +test winpipe-1.4 {32 bit comprehensive tests: a little from pipe} {95} { + exec more < little |& $cat32 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\nlittle} stderr32" +test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {nt} { + exec more < big | $cat32 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr32" +test winpipe-1.6 {32 bit comprehensive tests: a lot from pipe} {95} { + exec command /c type big |& $cat32 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr32" +test winpipe-1.7 {32 bit comprehensive tests: from console} {AllocConsole} { + # would block waiting for human input +} {} +test winpipe-1.8 {32 bit comprehensive tests: from NUL} { + exec $cat32 < nul > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{} stderr32" +test winpipe-1.9 {32 bit comprehensive tests: from socket} { + # doesn't work +} {} +test winpipe-1.10 {32 bit comprehensive tests: from nowhere} {.console} { + exec $cat32 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{} stderr32" +test winpipe-1.11 {32 bit comprehensive tests: from file handle} { + set f [open "little" r] + exec $cat32 <@$f > stdout 2> stderr + close $f + list [contents stdout] [contents stderr] +} "little stderr32" +test winpipe-1.12 {32 bit comprehensive tests: read from application} { + set f [open "|$cat32 < little" r] + gets $f line + catch {close $f} msg + list $line $msg +} "little stderr32" +test winpipe-1.13 {32 bit comprehensive tests: a little to file} { + exec $cat32 < little > stdout 2> stderr + list [contents stdout] [contents stderr] +} "little stderr32" +test winpipe-1.14 {32 bit comprehensive tests: a lot to file} { + exec $cat32 < big > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr32" +test winpipe-1.15 {32 bit comprehensive tests: a little to pipe} {nt} { + exec $cat32 < little | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{little\n} stderr32" +test winpipe-1.16 {32 bit comprehensive tests: a little to pipe} {95} { + exec $cat32 < little | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\nlittle} stderr32" +test winpipe-1.17 {32 bit comprehensive tests: a lot to pipe} {nt} { + exec $cat32 < big | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big\n} stderr32" +test winpipe-1.18 {32 bit comprehensive tests: a lot to pipe} {95} { + exec $cat32 < big | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\n$big} stderr32" +test winpipe-1.19 {32 bit comprehensive tests: to console} { + catch {exec $cat32 << "You should see this\n" >@stdout} msg + set msg +} stderr32 +test winpipe-1.20 {32 bit comprehensive tests: to NUL} { + # some apps hang when sending a large amount to NUL. $cat32 isn't one. + catch {exec $cat32 < big > nul} msg + set msg +} stderr32 +test winpipe-1.21 {32 bit comprehensive tests: to nowhere} {.console} { + exec $cat32 < big >&@stdout +} {} +test winpipe-1.22 {32 bit comprehensive tests: to file handle} { + set f1 [open "stdout" w] + set f2 [open "stderr" w] + exec $cat32 < little >@$f1 2>@$f2 + close $f1 + close $f2 + list [contents stdout] [contents stderr] +} "little stderr32" +test winpipe-1.23 {32 bit comprehensive tests: write to application} { + set f [open "|$cat32 > stdout" w] + puts -nonewline $f "foo" + catch {close $f} msg + list [contents stdout] $msg +} "foo stderr32" +test winpipe-1.24 {32 bit comprehensive tests: read/write application} { + set f [open "|$cat32" r+] + puts $f $big + puts $f \032 + flush $f + set r [read $f 64] + catch {close $f} + set r +} "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" +test winpipe-1.25 {32 bit comprehensive tests: to socket} { + # doesn't work +} {} +} + +if [file exists $cat16] { +test winpipe-2.1 {16 bit comprehensive tests: from little file} { + exec $cat16 < little > stdout 2> stderr + list [contents stdout] [contents stderr] +} "little stderr16" +test winpipe-2.2 {16 bit comprehensive tests: from big file} { + exec $cat16 < big > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr16" +test winpipe-2.3 {16 bit comprehensive tests: a little from pipe} {nt} { + exec more < little | $cat16 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{little\n} stderr16" +test winpipe-2.4 {16 bit comprehensive tests: a little from pipe} {95} { + exec more < little | $cat16 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\nlittle} stderr16" +test winpipe-2.5 {16 bit comprehensive tests: a lot from pipe} {nt} { + exec $cat16 < big | $cat16 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr16stderr16" +test winpipe-2.6 {16 bit comprehensive tests: a lot from pipe} {95} { + exec more < big | $cat16 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\n$big} stderr16" +test winpipe-2.7 {16 bit comprehensive tests: from console} {AllocConsole} { + # would block waiting for human input +} {} +test winpipe-2.8 {16 bit comprehensive tests: from NUL} {nt} { + exec $cat16 < nul > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{} stderr16" +test winpipe-2.9 {16 bit comprehensive tests: from socket} { + # doesn't work +} {} +test winpipe-2.10 {16 bit comprehensive tests: from nowhere} {.console} { + exec $cat16 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{} stderr16" +test winpipe-2.11 {16 bit comprehensive tests: from file handle} { + set f [open "little" r] + exec $cat16 <@$f > stdout 2> stderr + close $f + list [contents stdout] [contents stderr] +} "little stderr16" +test winpipe-2.12 {16 bit comprehensive tests: read from application} { + set f [open "|$cat16 < little" r] + gets $f line + catch {close $f} msg + list $line $msg +} {little stderr16} +test winpipe-2.13 {16 bit comprehensive tests: a little to file} { + exec $cat16 < little > stdout 2> stderr + list [contents stdout] [contents stderr] +} "little stderr16" +test winpipe-2.14 {16 bit comprehensive tests: a lot to file} { + exec $cat16 < big > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr16" +test winpipe-2.15 {16 bit comprehensive tests: a little to pipe} {nt} { + catch {exec $cat16 < little | more > stdout 2> stderr} + list [contents stdout] [contents stderr] +} "{little\n} stderr16" +test winpipe-2.16 {16 bit comprehensive tests: a little to pipe} {95} { + exec $cat16 < little | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\nlittle} stderr16" +test winpipe-2.17 {16 bit comprehensive tests: a lot to pipe} {nt} { + catch {exec $cat16 < big | more > stdout 2> stderr} + list [contents stdout] [contents stderr] +} "{$big\n} stderr16" +test winpipe-2.18 {16 bit comprehensive tests: a lot to pipe} {95} { + exec $cat16 < big | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\n$big} stderr16" +test winpipe-2.19 {16 bit comprehensive tests: to console} { + catch {exec $cat16 << "You should see this\n" >@stdout} msg + set msg +} stderr16 +test winpipe-2.20 {16 bit comprehensive tests: to NUL} {nt} { + # some apps hang when sending a large amount to NUL. cat16 isn't one. + catch {exec $cat16 < big > nul} msg + set msg +} stderr16 +test winpipe-2.21 {16 bit comprehensive tests: to nowhere} {.console} { + exec $cat16 < big >&@stdout +} {} +test winpipe-2.22 {16 bit comprehensive tests: to file handle} { + set f1 [open "stdout" w] + set f2 [open "stderr" w] + exec $cat16 < little >@$f1 2>@$f2 + close $f1 + close $f2 + list [contents stdout] [contents stderr] +} "little stderr16" +test winpipe-2.23 {16 bit comprehensive tests: write to application} { + set f [open "|$cat16 > stdout" w] + puts -nonewline $f "foo" + catch {close $f} msg + list [contents stdout] $msg +} "foo stderr16" +test winpipe-2.24 {16 bit comprehensive tests: read/write application} {nt} { + set f [open "|$cat16" r+] + puts $f $big + puts $f \032 + flush $f + set r [read $f 64] + catch {close $f} + set r +} "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" +test winpipe-2.25 {16 bit comprehensive tests: to socket} { + # doesn't work +} {} +} + |