aboutsummaryrefslogtreecommitdiffstats
path: root/contrib/tcl/tests
diff options
context:
space:
mode:
authorPoul-Henning Kamp <phk@FreeBSD.org>1997-10-01 13:19:13 +0000
committerPoul-Henning Kamp <phk@FreeBSD.org>1997-10-01 13:19:13 +0000
commit539e1e66ff6f99c987c8e03872ddaea5260db8f7 (patch)
treebca582e352640f318b35228d0c250ddde3bd0e0b /contrib/tcl/tests
parent3d33409926539d866dcea9fc5cb14113b312adf0 (diff)
downloadsrc-539e1e66ff6f99c987c8e03872ddaea5260db8f7.tar.gz
src-539e1e66ff6f99c987c8e03872ddaea5260db8f7.zip
Upgrade to 8.0 release.
Notes
Notes: svn path=/vendor/tcl/dist/; revision=30037
Diffstat (limited to 'contrib/tcl/tests')
-rw-r--r--contrib/tcl/tests/all10
-rw-r--r--contrib/tcl/tests/basic.test39
-rw-r--r--contrib/tcl/tests/binary.test58
-rw-r--r--contrib/tcl/tests/cmdAH.test157
-rw-r--r--contrib/tcl/tests/cmdIL.test6
-rw-r--r--contrib/tcl/tests/compile.test44
-rw-r--r--contrib/tcl/tests/defs65
-rw-r--r--contrib/tcl/tests/env.test73
-rw-r--r--contrib/tcl/tests/error.test22
-rw-r--r--contrib/tcl/tests/eval.test4
-rw-r--r--contrib/tcl/tests/event.test145
-rw-r--r--contrib/tcl/tests/exec.test415
-rw-r--r--contrib/tcl/tests/execute.test3
-rw-r--r--contrib/tcl/tests/expr-old.test38
-rw-r--r--contrib/tcl/tests/expr.test25
-rw-r--r--contrib/tcl/tests/fCmd.test7
-rw-r--r--contrib/tcl/tests/fileName.test163
-rw-r--r--contrib/tcl/tests/for.test10
-rw-r--r--contrib/tcl/tests/foreach.test11
-rw-r--r--contrib/tcl/tests/format.test64
-rw-r--r--contrib/tcl/tests/history.test227
-rw-r--r--contrib/tcl/tests/http.test246
-rw-r--r--contrib/tcl/tests/httpold.test411
-rw-r--r--contrib/tcl/tests/if.test14
-rw-r--r--contrib/tcl/tests/incr.test8
-rw-r--r--contrib/tcl/tests/info.test15
-rw-r--r--contrib/tcl/tests/interp.test323
-rw-r--r--contrib/tcl/tests/io.test272
-rw-r--r--contrib/tcl/tests/ioCmd.test11
-rw-r--r--contrib/tcl/tests/misc.test10
-rw-r--r--contrib/tcl/tests/namespace.test42
-rw-r--r--contrib/tcl/tests/obj.test28
-rw-r--r--contrib/tcl/tests/opt.test236
-rw-r--r--contrib/tcl/tests/parse.test2
-rw-r--r--contrib/tcl/tests/pkg.test18
-rw-r--r--contrib/tcl/tests/proc-old.test6
-rw-r--r--contrib/tcl/tests/proc.test16
-rw-r--r--contrib/tcl/tests/pwd.test22
-rw-r--r--contrib/tcl/tests/registry.test19
-rw-r--r--contrib/tcl/tests/resource.test105
-rw-r--r--contrib/tcl/tests/safe.test595
-rw-r--r--contrib/tcl/tests/scan.test27
-rw-r--r--contrib/tcl/tests/set-old.test4
-rw-r--r--contrib/tcl/tests/socket.test101
-rw-r--r--contrib/tcl/tests/source.test4
-rw-r--r--contrib/tcl/tests/split.test15
-rw-r--r--contrib/tcl/tests/string.test7
-rw-r--r--contrib/tcl/tests/trace.test40
-rw-r--r--contrib/tcl/tests/unixFCmd.test25
-rw-r--r--contrib/tcl/tests/util.test80
-rw-r--r--contrib/tcl/tests/var.test49
-rw-r--r--contrib/tcl/tests/while.test6
-rw-r--r--contrib/tcl/tests/winFCmd.test83
-rw-r--r--contrib/tcl/tests/winPipe.test28
54 files changed, 3038 insertions, 1416 deletions
diff --git a/contrib/tcl/tests/all b/contrib/tcl/tests/all
index b50794c14489..4023e550c732 100644
--- a/contrib/tcl/tests/all
+++ b/contrib/tcl/tests/all
@@ -2,9 +2,15 @@
# tests. Execute it by invoking "source all" when running tclTest
# in this directory.
#
-# SCCS: @(#) all 1.7 96/02/16 08:55:38
+# SCCS: @(#) all 1.8 97/08/01 11:07:14
-foreach i [lsort [glob *.test]] {
+if {$tcl_platform(os) == "Win32s"} {
+ set files [glob *.tes]
+} else {
+ set files [glob *.test]
+}
+
+foreach i [lsort $files] {
if [string match l.*.test $i] {
# This is an SCCS lock file; ignore it.
continue
diff --git a/contrib/tcl/tests/basic.test b/contrib/tcl/tests/basic.test
index d2f370124417..a0b6ea0b2fef 100644
--- a/contrib/tcl/tests/basic.test
+++ b/contrib/tcl/tests/basic.test
@@ -14,7 +14,7 @@
# 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
+# SCCS: @(#) basic.test 1.18 97/08/07 10:36:59
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -82,6 +82,8 @@ test basic-3.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden c
[catch {localP} msg] $msg
} {27 27 {} 1 {invalid command name "p"} {} 1 {invalid command name "localP"}}
+# NB: More tests about hide/expose are found in interp.test
+
test basic-4.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} {
catch {interp delete test_interp}
interp create test_interp
@@ -92,9 +94,11 @@ test basic-4.1 {Tcl_HideCommand, names of hidden cmds can't have namespace quali
}
}
}
- list [catch {test_interp hide test_ns_basic::p} msg] $msg \
+ list [catch {test_interp hide test_ns_basic::p x} msg] $msg \
+ [catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \
[interp delete test_interp]
-} {1 {hidden command names can't have namespace qualifiers} {}}
+} {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers as hidden commandtoken (rename)} {}}
+
test basic-4.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} {
catch {namespace delete test_ns_basic}
catch {rename cmd ""}
@@ -120,7 +124,7 @@ test basic-4.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace
[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} {
+test basic-5.1 {Tcl_ExposeCommand, a command stays in the global namespace and can not go to another namespace} {
catch {namespace delete test_ns_basic}
catch {rename cmd ""}
proc cmd {} { ;# note that this is global
@@ -130,19 +134,24 @@ test basic-5.1 {Tcl_ExposeCommand, an exposed cmd goes back to its containing na
proc hideCmd {} {
interp hide {} cmd
}
- proc exposeCmd {} {
+ proc exposeCmdFailing {} {
interp expose {} cmd ::test_ns_basic::newCmd
}
+ proc exposeCmdWorkAround {} {
+ interp expose {} cmd;
+ rename cmd ::test_ns_basic::newCmd;
+ }
proc callCmd {} {
cmd
}
}
list [test_ns_basic::callCmd] \
[test_ns_basic::hideCmd] \
- [test_ns_basic::exposeCmd] \
+ [catch {test_ns_basic::exposeCmdFailing} msg] $msg \
+ [test_ns_basic::exposeCmdWorkAround] \
[test_ns_basic::newCmd] \
[namespace delete test_ns_basic]
-} {:: {} {} :: {}}
+} {:: {} 1 {can not expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}}
test basic-5.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} {
catch {rename p ""}
catch {rename cmd ""}
@@ -248,7 +257,7 @@ test basic-7.6 {TclRenameCommand, check for command shadowing by newly renamed c
list [test_ns_basic::callP] \
[rename q test_ns_basic::p] \
[test_ns_basic::callP]
-} {{p in ::} {} {q in ::}}
+} {{p in ::} {} {q in ::test_ns_basic}}
test basic-8.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {
catch {eval namespace delete [namespace children :: test_ns_*]}
@@ -271,7 +280,7 @@ test basic-8.2 {Tcl_GetCommandInfo, names for commands created outside namespace
[testcmdtoken name $x]
} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}
-test namespace-9.1 {Tcl_GetCommandFullName} {
+test basic-9.1 {Tcl_GetCommandFullName} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_basic1 {
namespace export cmd*
@@ -294,7 +303,7 @@ test namespace-9.1 {Tcl_GetCommandFullName} {
}
} {::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} {
+test basic-10.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {
catch {interp delete test_interp}
catch {unset x}
interp create test_interp
@@ -314,7 +323,7 @@ test basic-10.1 {Tcl_DeleteCommand2, invalidate all compiled code if cmd has com
[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} {
+test basic-10.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
proc p {} {
@@ -332,7 +341,7 @@ test basic-10.2 {Tcl_DeleteCommand2, deleting commands changes command epoch} {
[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} {
+test basic-10.3 {Tcl_DeleteCommandFromToken, 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 {
@@ -371,6 +380,10 @@ test basic-11.1 {TclObjInvoke, lookup of "unknown" command} {
[interp delete test_interp]
} {newAlias 0 {global unknown} {}}
+test basic-12.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
+ testcmdtrace {set stuff [info tclversion]}
+} {{info tclversion} {info tclversion} {set stuff [info tclversion]} {set stuff 8.0}}
+
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {namespace delete george}
catch {interp delete test_interp}
@@ -379,3 +392,5 @@ catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
catch {unset x}
+set x 0
+unset x
diff --git a/contrib/tcl/tests/binary.test b/contrib/tcl/tests/binary.test
index 13e1f8a949f3..f64b2bbd75e4 100644
--- a/contrib/tcl/tests/binary.test
+++ b/contrib/tcl/tests/binary.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: @(#) binary.test 1.6 97/05/13 15:56:39
+# SCCS: @(#) binary.test 1.10 97/08/06 08:56:11
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -22,7 +22,7 @@ test binary-1.2 {Tcl_BinaryObjCmd: bad args} {
test binary-1.3 {Tcl_BinaryObjCmd: format error} {
list [catch {binary f} msg] $msg
-} {1 {wrong # args: should be "binary f formatString ?arg arg ...?"}}
+} {1 {wrong # args: should be "binary format formatString ?arg arg ...?"}}
test binary-1.4 {Tcl_BinaryObjCmd: format} {
binary format ""
} {}
@@ -439,10 +439,10 @@ test binary-13.11 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
} \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
+} \xff\x7f\xff\xff
test binary-13.13 {Tcl_BinaryObjCmd: float overflow} {nonPortable pcOnly} {
binary format f -3.402825e+38
-} \x00\x00\x80\x00
+} \xff\xff\x7f\xff
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}}
@@ -560,7 +560,7 @@ test binary-18.1 {Tcl_BinaryObjCmd: format} {
test binary-19.1 {Tcl_BinaryObjCmd: errors} {
list [catch {binary s} msg] $msg
-} {1 {wrong # args: should be "binary s value formatString ?varName varName ...?"}}
+} {1 {wrong # args: should be "binary scan 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 ...?"}}
@@ -1053,27 +1053,27 @@ test binary-31.1 {Tcl_BinaryObjCmd: scan} {
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}}
+} {1 {1.60000002384 3.40000009537}}
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}}
+} {1 {1.60000002384 3.40000009537}}
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}
+} {1 1.60000002384}
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}
+} {1 1.60000002384}
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}
+} {1 1.60000002384}
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}
+} {1 1.60000002384}
test binary-31.8 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xcc\xcc\xcd f0 arg1] $arg1
@@ -1085,11 +1085,11 @@ test binary-31.9 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
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}}
+} {1 {1.60000002384 3.40000009537}}
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}}
+} {1 {1.60000002384 3.40000009537}}
test binary-31.12 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 foo
@@ -1105,13 +1105,13 @@ test binary-31.14 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
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}
+} {2 {1.60000002384 3.40000009537} 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}
+} {2 {1.60000002384 3.40000009537} 5}
test binary-32.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc d} msg] $msg
@@ -1119,27 +1119,27 @@ test binary-32.1 {Tcl_BinaryObjCmd: scan} {
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}}
+} {1 {1.6 3.4}}
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}}
+} {1 {1.6 3.4}}
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}
+} {1 1.6}
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}
+} {1 1.6}
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}
+} {1 1.6}
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}
+} {1 1.6}
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
@@ -1151,11 +1151,11 @@ test binary-32.9 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
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}}
+} {1 {1.6 3.4}}
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}}
+} {1 {1.6 3.4}}
test binary-32.12 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 foo
@@ -1171,13 +1171,13 @@ test binary-32.14 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
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}
+} {2 {1.6 3.4} 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}
+} {2 {1.6 3.4} 5}
test binary-33.1 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
@@ -1312,9 +1312,15 @@ test binary-37.8 {GetFormatSpec: numbers} {
set arg1 foo
list [binary scan abcdef "a0x3" arg1] $arg1
} {1 {}}
+test binary-37.8 {GetFormatSpec: numbers} {
+ # test format of neg numbers
+ # bug report/fix provided by Harald Kirsch
+ set x [binary format f* {1 -1 2 -2 0}]
+ binary scan $x f* bla
+ set bla
+} {1.0 -1.0 2.0 -2.0 0.0}
# 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
diff --git a/contrib/tcl/tests/cmdAH.test b/contrib/tcl/tests/cmdAH.test
index cbf3ae739e9d..351008ee92a7 100644
--- a/contrib/tcl/tests/cmdAH.test
+++ b/contrib/tcl/tests/cmdAH.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: @(#) cmdAH.test 1.30 97/06/23 18:17:47
+# SCCS: @(#) cmdAH.test 1.35 97/07/22 14:07:43
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -851,65 +851,83 @@ makeFile abcde gorp.file
makeDirectory dir.file
# readable
-# Can't run on macintosh - requires chmod
-if {$tcl_platform(platform) != "macintosh"} {
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-12.2 {Tcl_FileObjCmd: readable} {unixExecs} {file readable gorp.file} 1
-catch {exec chmod 333 gorp.file}
-if {$user != "root"} {
- test cmdAH-12.3 {Tcl_FileObjCmd: readable} {unixOnly} {
- file reada gorp.file
- } 0
-}
-}
+testchmod 444 gorp.file
+test cmdAH-12.2 {Tcl_FileObjCmd: readable} {
+ file readable gorp.file
+} 1
+testchmod 333 gorp.file
+test cmdAH-12.3 {Tcl_FileObjCmd: readable} {unixOnly && !root} {
+ file reada gorp.file
+} 0
# writable
-# Can't run on macintosh - requires chmod
-if {$tcl_platform(platform) != "macintosh"} {
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-13.2 {Tcl_FileObjCmd: writable} {unixExecs} {
- file writable gorp.file
- } 0
-}
-catch {exec chmod 222 gorp.file}
-test cmdAH-13.3 {Tcl_FileObjCmd: writable} {unixExecs} {file w gorp.file} 1
-}
+testchmod 555 gorp.file
+test cmdAH-13.2 {Tcl_FileObjCmd: writable} {!root} {
+ file writable gorp.file
+} 0
+testchmod 222 gorp.file
+test cmdAH-13.3 {Tcl_FileObjCmd: writable} {
+ file writable gorp.file
+} 1
# executable
-# Can't run on macintosh - requires chmod
-if {$tcl_platform(platform) != "macintosh"} {
-test cmdAH-14.1 {Tcl_FileObjCmd: executable} {unixExecs} {
+file delete -force dir.file gorp.file
+file mkdir dir.file
+makeFile abcde gorp.file
+
+test cmdAH-14.1 {Tcl_FileObjCmd: executable} {
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-14.2 {Tcl_FileObjCmd: executable} {unixOnly} {
- file executable gorp.file
- } 0
-}
-catch {exec chmod 775 gorp.file}
-test cmdAH-14.3 {Tcl_FileObjCmd: executable} {unixExecs} {file exe gorp.file} 1
-}
+test cmdAH-14.2 {Tcl_FileObjCmd: executable} {
+ file executable gorp.file
+} 0
+test cmdAH-14.3 {Tcl_FileObjCmd: executable} {unix} {
+ # Only on unix will setting the execute bit on a regular file
+ # cause that file to be executable.
+
+ testchmod 775 gorp.file
+ file exe gorp.file
+} 1
+test cmdAH-14.4 {Tcl_FileObjCmd: executable} {mac} {
+ # On mac, the only executable files are of type APPL.
+
+ set x [file exe gorp.file]
+ file attrib gorp.file -type APPL
+ lappend x [file exe gorp.file]
+} {0 1}
+test cmdAH-14.5 {Tcl_FileObjCmd: executable} {pc} {
+ # On pc, must be a .exe, .com, etc.
+
+ set x [file exe gorp.file]
+ makeFile foo gorp.exe
+ lappend x [file exe gorp.exe]
+ file delete gorp.exe
+ set x
+} {0 1}
+test cmdAH-14.6 {Tcl_FileObjCmd: executable} {
+ # Directories are always executable.
+
+ file exe dir.file
+} 1
+
+file delete -force dir.file
+file delete gorp.file
+file delete link.file
# 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}
-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]
@@ -919,8 +937,10 @@ catch {
makeDirectory dir.file
makeFile 12345 [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} {
+test cmdAH-15.4 {Tcl_FileObjCmd: exists} {
+ file exists gorp.file
+} 1
+test cmdAH-15.5 {Tcl_FileObjCmd: exists} {
file exists [file join dir.file gorp.file]
} 1
@@ -938,6 +958,14 @@ test cmdAH-15.8 {Tcl_FileObjCmd: nativename} {
list [catch {file nativename a/b} msg] $msg [testsetplatform $platform]
} {0 :a:b {}}
+test cmdAH-15.9 {Tcl_FileObjCmd: ~ : exists} {
+ file exists ~nOsUcHuSeR
+} 0
+test cmdAH-15.10 {Tcl_FileObjCmd: ~ : nativename} {
+ # should probably be 0 in fact...
+ catch {file nativename ~nOsUcHuSeR}
+} 1
+
# 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.
@@ -986,8 +1014,12 @@ test cmdAH-16.3 {Tcl_FileObjCmd: atime} {
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-17.2 {Tcl_FileObjCmd: isdirectory} {file isdirectory gorp.file} 0
-test cmdAH-17.3 {Tcl_FileObjCmd: 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} {
+ file isd dir.file
+} 1
# isfile
@@ -1001,10 +1033,10 @@ test cmdAH-18.3 {Tcl_FileObjCmd: isfile} {file isfile dir.file} 0
# sites will have symbolic links
catch {exec ln -s gorp.file link.file}
-test cmdAH-19.1 {Tcl_FileObjCmd: lstat} {unixExecs} {
+test cmdAH-19.1 {Tcl_FileObjCmd: lstat} {
list [catch {file lstat a} msg] $msg
} {1 {wrong # args: should be "file lstat name varName"}}
-test cmdAH-19.2 {Tcl_FileObjCmd: lstat} {unixExecs} {
+test cmdAH-19.2 {Tcl_FileObjCmd: lstat} {
list [catch {file lstat a b c} msg] $msg
} {1 {wrong # args: should be "file lstat name varName"}}
test cmdAH-19.3 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} {
@@ -1021,7 +1053,7 @@ 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-19.6 {Tcl_FileObjCmd: lstat errors} {unixExecs nonPortable} {
+test cmdAH-19.6 {Tcl_FileObjCmd: lstat errors} {
catch {unset x}
set x 44
list [catch {file lstat gorp.file x} msg] $msg $errorCode
@@ -1033,7 +1065,7 @@ catch {unset stat}
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-20.2 {Tcl_FileObjCmd: mtime} {unixExecs} {
+test cmdAH-20.2 {Tcl_FileObjCmd: mtime} {
set old [file mtime gorp.file]
after 2000
set f [open gorp.file w]
@@ -1042,13 +1074,13 @@ test cmdAH-20.2 {Tcl_FileObjCmd: mtime} {unixExecs} {
set new [file mtime gorp.file]
expr {($new > $old) && ($new <= ($old+5))}
} {1}
-test cmdAH-20.3 {Tcl_FileObjCmd: mtime} {unixExecs} {
+test cmdAH-20.3 {Tcl_FileObjCmd: mtime} {
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-20.4 {Tcl_FileObjCmd: mtime} {unixExecs} {
+test cmdAH-20.4 {Tcl_FileObjCmd: mtime} {
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}}}
@@ -1079,10 +1111,12 @@ test cmdAH-20.5 {Tcl_FileObjCmd: mtime} {
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-21.2 {Tcl_FileObjCmd: owned} {unixExecs} {file owned gorp.file} 1
-if {$user != "root"} {
- test cmdAH-21.3 {Tcl_FileObjCmd: owned} {unixOnly} {file owned /} 0
-}
+test cmdAH-21.2 {Tcl_FileObjCmd: owned} {
+ file owned gorp.file
+} 1
+test cmdAH-21.3 {Tcl_FileObjCmd: owned} {unixOnly && !root} {
+ file owned /
+} 0
# readlink
@@ -1140,16 +1174,21 @@ test cmdAH-24.3 {Tcl_FileObjCmd: stat} {
file stat gorp.file stat
lsort [array names stat]
} {atime ctime dev gid ino mode mtime nlink size type uid}
-test cmdAH-24.4 {Tcl_FileObjCmd: stat} {unixOnly} {
+test cmdAH-24.4 {Tcl_FileObjCmd: stat} {
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-24.5 {Tcl_FileObjCmd: stat} {
+ list $stat(nlink) $stat(size) $stat(type)
+} {1 12 file}
+test cmdAH-24.5 {Tcl_FileObjCmd: stat} {unix} {
+ catch {unset stat}
+ file stat gorp.file stat
+ expr $stat(mode)&0777
+} {501}
+test cmdAH-24.6 {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-24.6 {Tcl_FileObjCmd: stat} {
+test cmdAH-24.7 {Tcl_FileObjCmd: stat} {
catch {unset x}
set x 44
list [catch {file stat gorp.file x} msg] $msg $errorCode
@@ -1163,7 +1202,7 @@ file delete link.file
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-25.2 {Tcl_FileObjCmd: type} {unixExecs} {
+test cmdAH-25.2 {Tcl_FileObjCmd: type} {
file type dir.file
} directory
test cmdAH-25.3 {Tcl_FileObjCmd: type} {
diff --git a/contrib/tcl/tests/cmdIL.test b/contrib/tcl/tests/cmdIL.test
index 55210a1b9e45..ceeb86b0dc81 100644
--- a/contrib/tcl/tests/cmdIL.test
+++ b/contrib/tcl/tests/cmdIL.test
@@ -7,7 +7,7 @@
# 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
+# SCCS: @(#) cmdIL.test 1.17 97/07/11 15:33:16
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -46,7 +46,7 @@ test cmdIL-1.10 {Tcl_LsortObjCmd procedure, -index option} {
} {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"}}
+} {1 {bad index "foo": must be integer or "end"}}
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}}
@@ -154,7 +154,7 @@ test cmdIL-3.15 {SortCompare procedure, -command option} {
} {1 {comparison error} {comparison error
while executing
"error "comparison error""
- (procedure "cmp" line 1)
+ (procedure "cmp" line 2)
invoked from within
"cmp 48 6"
(-compare command)
diff --git a/contrib/tcl/tests/compile.test b/contrib/tcl/tests/compile.test
index 6d8e0328f925..9e30fb3bfc19 100644
--- a/contrib/tcl/tests/compile.test
+++ b/contrib/tcl/tests/compile.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: @(#) compile.test 1.5 97/06/25 11:43:49
+# SCCS: @(#) compile.test 1.7 97/08/12 13:34:13
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -22,12 +22,32 @@ catch {unset x}
catch {unset y}
catch {unset a}
-test compile-1.1 {TclCompileDollarVar: global scalar name with ::s} {
+test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} {
+ catch {namespace delete test_ns_compile}
+ catch {unset x}
+ set x 123
+ namespace eval test_ns_compile {
+ proc set {args} {
+ global x
+ lappend x test_ns_compile::set
+ }
+ proc p {} {
+ set 0
+ }
+ }
+ list [test_ns_compile::p] [set x]
+} {{123 test_ns_compile::set} {123 test_ns_compile::set}}
+test compile-1.2 {TclCompileString, error result is reset if TclGetLong determines word isn't an integer} {
+ proc p {x} {info commands 3m}
+ list [catch {p} msg] $msg
+} {1 {no value given for parameter "x" to "p"}}
+
+test compile-2.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} {
+test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} {
catch {unset y}
proc p {} {
set ::y 789
@@ -35,12 +55,12 @@ test compile-1.2 {TclCompileDollarVar: global scalar name with ::s} {
}
list [p] $::y [expr {[lsearch -exact [info globals] y] != 0}]
} {789 789 1}
-test compile-1.3 {TclCompileDollarVar: global array name with ::s} {
+test compile-2.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} {
+test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} {
catch {unset a}
proc p {} {
set ::a(1) 1
@@ -49,7 +69,7 @@ test compile-1.4 {TclCompileDollarVar: global scalar name with ::s} {
list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
} {1 1 1}
-test compile-2.1 {TclCompileSetCmd: global scalar names with ::s} {
+test compile-3.1 {TclCompileSetCmd: global scalar names with ::s} {
catch {unset x}
catch {unset y}
set x 123
@@ -60,7 +80,7 @@ test compile-2.1 {TclCompileSetCmd: global scalar names with ::s} {
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} {
+test compile-3.2 {TclCompileSetCmd: global array names with ::s} {
catch {unset a}
set ::a(1) 2
proc p {} {
@@ -69,7 +89,7 @@ test compile-2.2 {TclCompileSetCmd: global array names with ::s} {
}
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} {
+test compile-3.3 {TclCompileSetCmd: namespace var names with ::s} {
catch {namespace delete test_ns_compile}
catch {unset x}
namespace eval test_ns_compile {
@@ -81,17 +101,17 @@ test compile-2.3 {TclCompileSetCmd: namespace var names with ::s} {
list $::x $::test_ns_compile::arr(1)
} {hello 123}
-test compile-3.1 {CollectArgInfo: binary data} {
+test compile-4.1 {CollectArgInfo: binary data} {
list [catch "string length \000foo" msg] $msg
} {0 4}
-test compile-3.2 {CollectArgInfo: binary data} {
+test compile-4.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} {
+test compile-4.3 {CollectArgInfo: handle "]" at end of command properly} {
set x ]
} {]}
-test compile-4.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} {
+test compile-5.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} {
proc p {} {
set x {}
eval $x
diff --git a/contrib/tcl/tests/defs b/contrib/tcl/tests/defs
index ead6aebb25c6..61f90ec77fb4 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.52 97/06/24 11:13:36
+# SCCS: @(#) defs 1.60 97/08/13 18:10:19
if ![info exists VERBOSE] {
set VERBOSE 0
@@ -31,6 +31,7 @@ if {$tcl_platform(platform) == "unix"} {
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."
+ set testConfig(root) 1
}
}
@@ -69,6 +70,10 @@ if {[info commands memory] == ""} {
# where the configuration is well known. The presence
# of the file "doAllTests" in this directory indicates
# that it is safe to run non-portable tests.
+# knownBug - The test is known to fail and the bug is not yet
+# fixed. The test will be run only if the file
+# "doBuggyTests" exists (intended for Tcl dev. group
+# internal use only).
# tempNotPc - The inverse of pcOnly. This flag is used to
# temporarily disable a test.
# tempNotMac - The inverse of macOnly. This flag is used to
@@ -111,7 +116,8 @@ 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) [expr [file exists doAllTests] || [file exists doAllTe]]
+set testConfig(knownBug) [expr [file exists doBuggyTests] || [file exists doBuggyT]]
set testConfig(notIfCompiled) [file exists doAllCompilerTests]
set testConfig(unix) $testConfig(unixOnly)
@@ -126,7 +132,7 @@ set testConfig(win32s) [expr {$tcl_platform(os) == "Win32s"}]
# certain platforms, so that they can be reactivated again when the
# underlying problem is fixed.
-set testConfig(winCrash) $testConfig(macOrUnix)
+set testConfig(pcCrash) $testConfig(macOrUnix)
set testConfig(macCrash) $testConfig(unixOrPc)
set testConfig(unixCrash) $testConfig(macOrPc)
@@ -221,9 +227,13 @@ if {($testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} {
}
}
-proc print_verbose {name description script code answer} {
+proc print_verbose {name description constraints script code answer} {
puts stdout "\n"
- puts stdout "==== $name $description"
+ if {[string length $constraints]} {
+ puts stdout "==== $name $description\t--- ($constraints) ---"
+ } else {
+ puts stdout "==== $name $description"
+ }
puts stdout "==== Contents of test case:"
puts stdout "$script"
if {$code != 0} {
@@ -282,7 +292,7 @@ proc test {name description script answer args} {
}
set i [llength $args]
if {$i == 0} {
- # Empty body
+ set constraints {}
} elseif {$i == 1} {
# "constraints" argument exists; shuffle arguments down, then
# make sure that the constraints are satisfied.
@@ -294,7 +304,7 @@ proc test {name description script answer args} {
if {[string match {*[$\[]*} $constraints] != 0} {
# full expression, e.g. {$foo > [info tclversion]}
- catch {set doTest [uplevel #0 expr $constraints]}
+ catch {set doTest [uplevel #0 expr [list $constraints]]} msg
} elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
# something like {a || b} should be turned into
# $testConfig(a) || $testConfig(b).
@@ -325,18 +335,20 @@ proc test {name description script answer args} {
memory tag $name
set code [catch {uplevel $script} result]
if {$code != 0} {
- print_verbose $name $description $script \
+ print_verbose $name $description $constraints $script \
$code $result
} elseif {[string compare $result $answer] == 0} then {
if $VERBOSE then {
if {$VERBOSE > 0} {
- print_verbose $name $description $script \
+ print_verbose $name $description $constraints $script \
$code $result
}
- puts stdout "++++ $name PASSED"
+ if {$VERBOSE != -2} {
+ puts stdout "++++ $name PASSED"
+ }
}
} else {
- print_verbose $name $description $script \
+ print_verbose $name $description $constraints $script \
$code $result
puts stdout "---- Result should have been:"
puts stdout "$answer"
@@ -397,10 +409,39 @@ proc viewFile {name} {
# Locate tcltest executable
-set tcltest [list [info nameofexecutable]]
+set tcltest [info nameofexecutable]
+
if {$tcltest == "{}"} {
set tcltest {}
puts "Unable to find tcltest executable, multiple process tests will fail."
}
+if {$tcl_platform(os) != "Win32s"} {
+ # Don't even try running another copy of tcltest under win32s, or you
+ # get an error dialog about multiple instances.
+
+ catch {
+ file delete -force tmp
+ set f [open tmp w]
+ puts $f {
+ exit
+ }
+ close $f
+ set f [open "|[list $tcltest tmp]" r]
+ close $f
+ set testConfig(stdio) 1
+ }
+}
+
+if {($tcl_platform(platform) == "windows") && ($testConfig(stdio) == 0)} {
+ puts "(will skip tests that redirect stdio of exec'd 32-bit applications)"
+}
+
+catch {socket} msg
+set testConfig(socket) [expr {$msg != "sockets are not available on this system"}]
+
+if {$testConfig(socket) == 0} {
+ puts "(will skip tests that use sockets)"
+}
+
diff --git a/contrib/tcl/tests/env.test b/contrib/tcl/tests/env.test
index 22f128482142..e76ad7d58720 100644
--- a/contrib/tcl/tests/env.test
+++ b/contrib/tcl/tests/env.test
@@ -10,42 +10,50 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) env.test 1.9 96/02/16 08:55:47
+# SCCS: @(#) env.test 1.13 97/08/05 11:40:30
if {[string compare test [info procs test]] == 1} then {source defs}
-# If there is no "printenv" program on this system, then it's just too
-# much trouble to run this test (can't necessarily run csh to get the
-# environment: on some systems it barfs if there isn't a minimum set
-# predefined environment variables. Also, printenv returns a non-zero
-# status on some systems, so read the environment using a procedure
-# that catches errors.
+if {[info commands exec] == ""} {
+ puts "exec not implemented for this machine"
+ return
+}
-set printenv {}
-if [info exists env(PATH)] {
- set dirs [split $env(PATH) :]
-} else {
- set dirs {/bin /usr/bin /usr/ucb /usr/local /usr/public /usr/etc}
+if {$tcl_platform(os) == "Win32s"} {
+ puts "Cannot run multiple copies of tcl at the same time under Win32s"
+ return
}
-foreach i $dirs {
- if [file executable $i/printenv] {
- # The following hack is needed because of weirdness with
- # environment variables in symbolic lines on Apollos (?!#?).
- if ![catch {exec sh -c "cd $i; pwd"} x] {
- set printenv $x/printenv
- } else {
- set printenv $i/printenv
+
+set f [open printenv w]
+puts $f {
+ proc lrem {listname name} {
+ upvar $listname list
+ set i [lsearch $list $name]
+ if {$i >= 0} {
+ set list [lreplace $list $i $i]
}
- break
+ return $list
+ }
+
+ set names [lsort [array names env]]
+ if {$tcl_platform(platform) == "windows"} {
+ lrem names HOME
+ lrem names COMSPEC
+ lrem names ComSpec
+ lrem names ""
+ }
+ foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH} {
+ lrem names $name
+ }
+ foreach p $names {
+ puts "$p=$env($p)"
}
}
-if {$printenv == ""} {
- puts stdout "Skipping env tests: need \"printenv\" to read environment."
- return ""
-}
+close $f
+
proc getenv {} {
- global printenv
- catch {exec $printenv} out
+ global printenv tcltest
+ catch {exec $tcltest printenv} out
if {$out == "child process exited abnormally"} {
set out {}
}
@@ -59,6 +67,15 @@ foreach name [array names env] {
unset env($name)
}
+# Added the following lines so that child tcltest can actually find its
+# library if the initial tcltest is run from a non-standard place.
+# ('saved' env vars)
+foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH} {
+ if {[info exists env2($name)]} {
+ set env($name) $env2($name);
+ }
+}
+
test env-1.1 {adding environment variables} {
getenv
} {}
@@ -106,3 +123,5 @@ foreach name [array names env] {
foreach name [array names env2] {
set env($name) $env2($name)
}
+
+file delete printenv
diff --git a/contrib/tcl/tests/error.test b/contrib/tcl/tests/error.test
index 3421edc32f86..1421e9bdf71a 100644
--- a/contrib/tcl/tests/error.test
+++ b/contrib/tcl/tests/error.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: @(#) error.test 1.18 96/11/07 18:36:09
+# SCCS: @(#) error.test 1.22 97/08/12 17:02:43
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -42,7 +42,7 @@ test error-1.3 {simple errors from commands} {
set errorInfo
} {wrong # args: should be "string compare string1 string2"
while executing
-"format [string compare]"}
+"string compare"}
test error-1.4 {simple errors from commands} {
catch {error glorp} b
@@ -62,6 +62,17 @@ test error-1.7 {simple errors from commands} {
set b
} {wrong # args: should be "catch command ?varName?"}
+test error-1.8 {simple errors from commands} {nonPortable} {
+ # This test is non-portable: it generates a memory fault on
+ # machines like DEC Alphas (infinite recursion overflows
+ # stack?)
+
+ proc p {} {
+ uplevel 1 catch p error
+ }
+ p
+} 0
+
# Check errors nested in procedures. Also check the optional argument
# to "error" to generate a new error trace.
@@ -80,7 +91,7 @@ test error-2.3 {errors in nested procedures} {
} {Human-generated
while executing
"error {Human-generated}"
- (procedure "foo" line 1)
+ (procedure "foo" line 4)
invoked from within
"foo"}
@@ -98,8 +109,8 @@ test error-2.6 {errors in nested procedures} {
set errorInfo
} {glorp2
while executing
-"format [error glorp2]"
- (procedure "foo2" line 1)
+"error glorp2"
+ (procedure "foo2" line 3)
invoked from within
"foo2"}
@@ -160,4 +171,5 @@ test error-6.1 {catch must reset error state} {
list $errorCode $errorInfo
} {NONE 1}
+catch {rename p ""}
return ""
diff --git a/contrib/tcl/tests/eval.test b/contrib/tcl/tests/eval.test
index 48ee9ce6e798..07f610c40b17 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.9 96/09/10 13:50:39
+# SCCS: @(#) eval.test 1.10 97/07/02 16:40:56
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 1)
+ (\"eval\" body line 3)
invoked from within
\"eval {
set a 1
diff --git a/contrib/tcl/tests/event.test b/contrib/tcl/tests/event.test
index 67418364379d..027f7e040483 100644
--- a/contrib/tcl/tests/event.test
+++ b/contrib/tcl/tests/event.test
@@ -8,7 +8,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# "@(#) event.test 1.27 97/06/23 18:21:18"
+# "@(#) event.test 1.35 97/08/11 11:58:38"
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -46,7 +46,7 @@ if {[catch {testfilehandler create 0 off off}] == 0 } {
testfilehandler close
set result
} {{0 1} {0 2} {0 2}}
- test event-1.3 {Tcl_DeleteFileHandler} {
+ test event-1.3 {Tcl_DeleteFileHandler} {nonPortable} {
testfilehandler close
testfilehandler create 2 disabled disabled
testfilehandler create 1 readable writable
@@ -66,7 +66,7 @@ if {[catch {testfilehandler create 0 off off}] == 0 } {
set result
} {{0 1} {1 1} {1 2} {0 0}}
- test event-2.1 {Tcl_DeleteFileHandler} {
+ test event-2.1 {Tcl_DeleteFileHandler} {nonPortable} {
testfilehandler close
testfilehandler create 2 disabled disabled
testfilehandler create 1 readable writable
@@ -84,7 +84,7 @@ if {[catch {testfilehandler create 0 off off}] == 0 } {
testfilehandler close
set result
} {{0 1} {1 1} {1 2} {0 0}}
- test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} {
+ test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} {nonPortable} {
testfilehandler close
testfilehandler create 0 readable writable
testfilehandler fillpartial 0
@@ -109,7 +109,7 @@ if {[catch {testfilehandler create 0 off off}] == 0 } {
set result
} {0 0}
- test event-4.1 {FileHandlerEventProc, race between event and disabling } {
+ test event-4.1 {FileHandlerEventProc, race between event and disabling} {nonPortable} {
update
testfilehandler close
testfilehandler create 2 disabled disabled
@@ -128,7 +128,7 @@ if {[catch {testfilehandler create 0 off off}] == 0 } {
testfilehandler close
set result
} {{0 1} {1 1} {1 2} {0 0}}
- test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off } {
+ test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} {nonPortable} {
update
testfilehandler close
testfilehandler create 1 readable writable
@@ -208,70 +208,75 @@ test event-6.1 {BgErrorDeleteProc procedure} {
} {Unmodified
}
-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-7.2 {tkerror/bgerror backwards compabitility} {
- proc bgerror {x y} {
- return [expr 1 + $x + $y]
+test event-7.1 {bgerror / regular} {
+ set errRes {}
+ proc bgerror {err} {
+ global errRes;
+ set errRes $err;
}
- list [tkerror 6 -2] [bgerror 7 2]
-} {5 10}
-test event-7.3 {tkerror/bgerror backwards compabitility} {
- proc bgerror {x y} {
- return [expr 1 + $x + $y]
+ after 0 {error err1}
+ vwait errRes;
+ set errRes;
+} err1
+
+test event-7.2 {bgerror / accumulation} {
+ set errRes {}
+ proc bgerror {err} {
+ global errRes;
+ lappend errRes $err;
}
- set result [list [info commands bgerror] [info commands tkerror]]
- rename tkerror {}
- lappend result [info commands bgerror] [info commands tkerror]
-} {bgerror tkerror {} {}}
-test event-7.4 {tkerror/bgerror backwards compabitility} {
- proc tkerror {x y} {
- return [expr 1 + $x + $y]
+ after 0 {error err1}
+ after 0 {error err2}
+ after 0 {error err3}
+ update
+ set errRes;
+} {err1 err2 err3}
+
+test event-7.3 {bgerror / accumulation / break} {
+ set errRes {}
+ proc bgerror {err} {
+ global errRes;
+ lappend errRes $err;
+ return -code break "skip!";
}
- set result [list [info commands bgerror] [info commands tkerror]]
- rename bgerror {}
- lappend result [info commands bgerror] [info commands tkerror]
-} {bgerror tkerror {} {}}
-test event-7.5 {tkerror/bgerror backwards compabitility} {
- proc tkerror {x y} {
- return [expr 1 + $x + $y]
+ after 0 {error err1}
+ after 0 {error err2}
+ after 0 {error err3}
+ update
+ set errRes;
+} err1
+
+test event-7.4 {tkerror is nothing special anymore to tcl} {
+ set errRes {}
+ # we don't just rename bgerror to empty because it could then
+ # be autoloaded...
+ proc bgerror {err} {
+ global errRes;
+ lappend errRes "bg:$err";
}
- rename tkerror foo
- list [info commands bgerror] [info commands tkerror] [foo 4 3]
-} {{} {} 8}
-test event-7.6 {tkerror/bgerror backwards compabitility} {
- proc bgerror {x y} {
- return [expr 1 + $x + $y]
+ proc tkerror {err} {
+ global errRes;
+ lappend errRes "tk:$err";
}
- catch {rename foo {}}
- rename bgerror foo
- list [info commands bgerror] [info commands tkerror] [foo 4 3]
-} {{} {} 8}
-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-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-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}}
+ after 0 {error err1}
+ update
+ rename tkerror {}
+ set errRes
+} bg:err1
+
+# someday : add a test checking that
+# when there is no bgerror, an error msg goes to stderr
+# ideally one would use sub interp and transfer a fake stderr
+# to it, unfortunatly the current interp tcl API does not allow
+# that. the other option would be to use fork a test but it
+# then becomes more a file/exec test than a bgerror test.
+
+# end of bgerror tests
catch {rename bgerror {}}
+
if {[info commands testexithandler] != ""} {
- test event-8.1 {Tcl_CreateExitHandler procedure} {unixOrPc} {
+ test event-8.1 {Tcl_CreateExitHandler procedure} {stdio} {
set child [open |[list [info nameofexecutable]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; exit"
@@ -284,7 +289,7 @@ even 4
odd 41
}
- test event-9.1 {Tcl_DeleteExitHandler procedure} {unixOrPc} {
+ test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio} {
set child [open |[list [info nameofexecutable]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 41"
@@ -297,7 +302,7 @@ odd 41
even 6
even 4
}
- test event-9.2 {Tcl_DeleteExitHandler procedure} {unixOrPc} {
+ test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio} {
set child [open |[list [info nameofexecutable]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 4"
@@ -310,7 +315,7 @@ even 4
even 6
odd 41
}
- test event-9.3 {Tcl_DeleteExitHandler procedure} {unixOrPc} {
+ test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio} {
set child [open |[list [info nameofexecutable]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 6"
@@ -323,7 +328,7 @@ odd 41
even 4
odd 41
}
- test event-9.4 {Tcl_DeleteExitHandler procedure} {unixOrPc} {
+ test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio} {
set child [open |[list [info nameofexecutable]] r+]
puts $child "testexithandler create 41; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
@@ -335,7 +340,7 @@ odd 41
}
}
-test event-10.1 {Tcl_Exit procedure} {unixOrPc} {
+test event-10.1 {Tcl_Exit procedure} {stdio} {
set child [open |[list [info nameofexecutable]] r+]
puts $child "exit 3"
list [catch {close $child} msg] $msg [lindex $errorCode 0] \
@@ -357,6 +362,7 @@ test event-11.4 {Tcl_VwaitCmd procedure} {
foreach i [after info] {
after cancel $i
}
+ after 10; update; # On Mac make sure update won't take long
after 100 {set x x-done}
after 200 {set y y-done}
after 300 {set z z-done}
@@ -372,7 +378,7 @@ foreach i [after info] {
after cancel $i
}
-test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {
+test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} {
set f1 [open test1 w]
proc accept {s args} {
puts $s foobar
@@ -435,8 +441,9 @@ test event-12.4 {Tcl_UpdateCmd procedure} {
foreach i [after info] {
after cancel $i
}
+ after 10; update; # On Mac make sure update won't take long
after 200 {set x x-done}
- after 500 {set y y-done}
+ after 600 {set y y-done}
after idle {set z z-done}
set x before
set y before
diff --git a/contrib/tcl/tests/exec.test b/contrib/tcl/tests/exec.test
index 4b00c4449c46..169885a8315d 100644
--- a/contrib/tcl/tests/exec.test
+++ b/contrib/tcl/tests/exec.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: @(#) exec.test 1.56 97/06/20 13:27:37
+# SCCS: @(#) exec.test 1.58 97/08/01 11:10:00
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -20,181 +20,255 @@ if {[info commands exec] == ""} {
puts "exec not implemented for this machine"
return
}
+if {$testConfig(stdio) == 0} {
+ return
+}
-proc cat {name} {
- set f [open $name r]
- set x [read -nonewline $f]
- close $f
- set x
+set f [open echo w]
+puts $f {
+ puts -nonewline [lindex $argv 0]
+ foreach str [lrange $argv 1 end] {
+ puts -nonewline " $str"
+ }
+ puts {}
}
+close $f
+
+set f [open cat w]
+puts $f {
+ if {$argv == {}} {
+ set argv -
+ }
+ foreach name $argv {
+ if {$name == "-"} {
+ set f stdin
+ } elseif {[catch {open $name r} f] != 0} {
+ puts stderr $f
+ continue
+ }
+ while {[eof $f] == 0} {
+ puts -nonewline [read $f]
+ }
+ if {$f != "stdin"} {
+ close $f
+ }
+ }
+}
+close $f
+
+set f [open wc w]
+puts $f {
+ set data [read stdin]
+ set lines [regsub -all "\n" $data {} dummy]
+ set words [regsub -all "\[^ \t\n]+" $data {} dummy]
+ set chars [string length $data]
+ puts [format "%8.d%8.d%8.d" $lines $words $chars]
+}
+close $f
+
+set f [open sh w]
+puts $f {
+ if {[lindex $argv 0] != "-c"} {
+ error "sh: unexpected arguments $argv"
+ }
+ set cmd [lindex $argv 1]
+ lappend cmd ";"
+
+ set newcmd {}
+
+ foreach arg $cmd {
+ if {$arg == ";"} {
+ eval exec >@stdout 2>@stderr [list [info nameofexecutable]] $newcmd
+ set newcmd {}
+ continue
+ }
+ if {$arg == "1>&2"} {
+ set arg >@stderr
+ }
+ lappend newcmd $arg
+ }
+}
+close $f
+
+set f [open sleep w]
+puts $f {
+ after [expr $argv*1000]
+}
+close $f
+
+set f [open exit w]
+puts $f {
+ exit $argv
+}
+close $f
# Basic operations.
-test exec-1.1 {basic exec operation} {unixExecs} {
- exec echo a b c
+test exec-1.1 {basic exec operation} {
+ exec $tcltest echo a b c
} "a b c"
-test exec-1.2 {pipelining} {unixExecs} {
- exec echo a b c d | cat | cat
+test exec-1.2 {pipelining} {
+ exec $tcltest echo a b c d | $tcltest cat | $tcltest cat
} "a b c d"
-test exec-1.3 {pipelining} {unixExecs} {
- set a [exec echo a b c d | cat | wc]
+test exec-1.3 {pipelining} {
+ set a [exec $tcltest echo a b c d | $tcltest cat | $tcltest wc]
list [scan $a "%d %d %d" b c d] $b $c
} {3 1 4}
set arg {12345678901234567890123456789012345678901234567890}
set arg "$arg$arg$arg$arg$arg$arg"
-test exec-1.4 {long command lines} {unixExecs} {
- exec echo $arg
+test exec-1.4 {long command lines} {
+ exec $tcltest echo $arg
} $arg
set arg {}
# I/O redirection: input from Tcl command.
-test exec-2.1 {redirecting input from immediate source} {unixExecs} {
- exec cat << "Sample text"
+test exec-2.1 {redirecting input from immediate source} {
+ exec $tcltest cat << "Sample text"
} {Sample text}
-test exec-2.2 {redirecting input from immediate source} {unixExecs} {
- exec << "Sample text" cat | cat
+test exec-2.2 {redirecting input from immediate source} {
+ exec << "Sample text" $tcltest cat | $tcltest cat
} {Sample text}
-test exec-2.3 {redirecting input from immediate source} {unixExecs} {
- exec cat << "Sample text" | cat
+test exec-2.3 {redirecting input from immediate source} {
+ exec $tcltest cat << "Sample text" | $tcltest cat
} {Sample text}
-test exec-2.4 {redirecting input from immediate source} {unixExecs} {
- exec cat | cat << "Sample text"
+test exec-2.4 {redirecting input from immediate source} {
+ exec $tcltest cat | $tcltest cat << "Sample text"
} {Sample text}
-test exec-2.5 {redirecting input from immediate source} {unixExecs} {
- exec cat "<<Joined to arrows"
+test exec-2.5 {redirecting input from immediate source} {
+ exec $tcltest cat "<<Joined to arrows"
} {Joined to arrows}
# I/O redirection: output to file.
-catch {exec rm -f gorp.file}
-test exec-3.1 {redirecting output to file} {unixExecs} {
- exec echo "Some simple words" > gorp.file
- exec cat gorp.file
+file delete gorp.file
+test exec-3.1 {redirecting output to file} {
+ exec $tcltest echo "Some simple words" > gorp.file
+ exec $tcltest cat gorp.file
} "Some simple words"
-test exec-3.2 {redirecting output to file} {unixExecs} {
- exec echo "More simple words" | >gorp.file cat | cat
- exec cat gorp.file
+test exec-3.2 {redirecting output to file} {
+ exec $tcltest echo "More simple words" | >gorp.file $tcltest cat | $tcltest cat
+ exec $tcltest cat gorp.file
} "More simple words"
-test exec-3.3 {redirecting output to file} {unixExecs} {
- exec > gorp.file echo "Different simple words" | cat | cat
- exec cat gorp.file
+test exec-3.3 {redirecting output to file} {
+ exec > gorp.file $tcltest echo "Different simple words" | $tcltest cat | $tcltest cat
+ exec $tcltest cat gorp.file
} "Different simple words"
-test exec-3.4 {redirecting output to file} {unixExecs} {
- exec echo "Some simple words" >gorp.file
- exec cat gorp.file
+test exec-3.4 {redirecting output to file} {
+ exec $tcltest echo "Some simple words" >gorp.file
+ exec $tcltest cat gorp.file
} "Some simple words"
-test exec-3.5 {redirecting output to file} {unixExecs} {
- exec echo "First line" >gorp.file
- exec echo "Second line" >> gorp.file
- exec cat gorp.file
+test exec-3.5 {redirecting output to file} {
+ exec $tcltest echo "First line" >gorp.file
+ exec $tcltest echo "Second line" >> gorp.file
+ exec $tcltest cat gorp.file
} "First line\nSecond line"
-test exec-3.6 {redirecting output to file} {unixExecs} {
- exec echo "First line" >gorp.file
- exec echo "Second line" >>gorp.file
- exec cat gorp.file
+test exec-3.6 {redirecting output to file} {
+ exec $tcltest echo "First line" >gorp.file
+ exec $tcltest echo "Second line" >>gorp.file
+ exec $tcltest cat gorp.file
} "First line\nSecond line"
-test exec-3.7 {redirecting output to file} {unixExecs} {
+test exec-3.7 {redirecting output to file} {
set f [open gorp.file w]
puts $f "Line 1"
flush $f
- exec echo "More text" >@ $f
- exec echo >@$f "Even more"
+ exec $tcltest echo "More text" >@ $f
+ exec $tcltest echo >@$f "Even more"
puts $f "Line 3"
close $f
- exec cat gorp.file
+ exec $tcltest cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"
# I/O redirection: output and stderr to file.
-catch {exec rm -f gorp.file}
-test exec-4.1 {redirecting output and stderr to file} {unixExecs} {
- exec echo "test output" >& gorp.file
- exec cat gorp.file
+file delete gorp.file
+test exec-4.1 {redirecting output and stderr to file} {
+ exec $tcltest echo "test output" >& gorp.file
+ exec $tcltest cat gorp.file
} "test output"
-test exec-4.2 {redirecting output and stderr to file} {unixExecs} {
- list [exec sh -c "echo foo bar 1>&2" >&gorp.file] \
- [exec cat gorp.file]
+test exec-4.2 {redirecting output and stderr to file} {
+ list [exec $tcltest sh -c "echo foo bar 1>&2" >&gorp.file] \
+ [exec $tcltest cat gorp.file]
} {{} {foo bar}}
-test exec-4.3 {redirecting output and stderr to file} {unixExecs} {
- exec echo "first line" > gorp.file
- list [exec sh -c "echo foo bar 1>&2" >>&gorp.file] \
- [exec cat gorp.file]
+test exec-4.3 {redirecting output and stderr to file} {
+ exec $tcltest echo "first line" > gorp.file
+ list [exec $tcltest sh -c "echo foo bar 1>&2" >>&gorp.file] \
+ [exec $tcltest cat gorp.file]
} "{} {first line\nfoo bar}"
-test exec-4.4 {redirecting output and stderr to file} {unixExecs} {
+test exec-4.4 {redirecting output and stderr to file} {
set f [open gorp.file w]
puts $f "Line 1"
flush $f
- exec echo "More text" >&@ $f
- exec echo >&@$f "Even more"
+ exec $tcltest echo "More text" >&@ $f
+ exec $tcltest echo >&@$f "Even more"
puts $f "Line 3"
close $f
- exec cat gorp.file
+ exec $tcltest cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"
-test exec-4.5 {redirecting output and stderr to file} {unixExecs} {
+test exec-4.5 {redirecting output and stderr to file} {
set f [open gorp.file w]
puts $f "Line 1"
flush $f
- exec >&@ $f sh -c "echo foo bar 1>&2"
- exec >&@$f sh -c "echo xyzzy 1>&2"
+ exec >&@ $f $tcltest sh -c "echo foo bar 1>&2"
+ exec >&@$f $tcltest sh -c "echo xyzzy 1>&2"
puts $f "Line 3"
close $f
- exec cat gorp.file
+ exec $tcltest cat gorp.file
} "Line 1\nfoo bar\nxyzzy\nLine 3"
# I/O redirection: input from file.
-catch {exec echo "Just a few thoughts" > gorp.file}
-test exec-5.1 {redirecting input from file} {unixExecs} {
- exec cat < gorp.file
+exec $tcltest echo "Just a few thoughts" > gorp.file
+test exec-5.1 {redirecting input from file} {
+ exec $tcltest cat < gorp.file
} {Just a few thoughts}
-test exec-5.2 {redirecting input from file} {unixExecs} {
- exec cat | cat < gorp.file
+test exec-5.2 {redirecting input from file} {
+ exec $tcltest cat | $tcltest cat < gorp.file
} {Just a few thoughts}
-test exec-5.3 {redirecting input from file} {unixExecs} {
- exec cat < gorp.file | cat
+test exec-5.3 {redirecting input from file} {
+ exec $tcltest cat < gorp.file | $tcltest cat
} {Just a few thoughts}
-test exec-5.4 {redirecting input from file} {unixExecs} {
- exec < gorp.file cat | cat
+test exec-5.4 {redirecting input from file} {
+ exec < gorp.file $tcltest cat | $tcltest cat
} {Just a few thoughts}
-test exec-5.5 {redirecting input from file} {unixExecs} {
- exec cat <gorp.file
+test exec-5.5 {redirecting input from file} {
+ exec $tcltest cat <gorp.file
} {Just a few thoughts}
-test exec-5.6 {redirecting input from file} {unixExecs} {
+test exec-5.6 {redirecting input from file} {
set f [open gorp.file r]
- set result [exec cat <@ $f]
+ set result [exec $tcltest cat <@ $f]
close $f
set result
} {Just a few thoughts}
-test exec-5.7 {redirecting input from file} {unixExecs} {
+test exec-5.7 {redirecting input from file} {
set f [open gorp.file r]
- set result [exec <@$f cat]
+ set result [exec <@$f $tcltest cat]
close $f
set result
} {Just a few thoughts}
# I/O redirection: standard error through a pipeline.
-test exec-6.1 {redirecting stderr through a pipeline} {unixExecs} {
- exec sh -c "echo foo bar" |& cat
+test exec-6.1 {redirecting stderr through a pipeline} {
+ exec $tcltest sh -c "echo foo bar" |& $tcltest cat
} "foo bar"
-test exec-6.2 {redirecting stderr through a pipeline} {unixExecs} {
- exec sh -c "echo foo bar 1>&2" |& cat
+test exec-6.2 {redirecting stderr through a pipeline} {
+ exec $tcltest sh -c "echo foo bar 1>&2" |& $tcltest cat
} "foo bar"
-test exec-6.3 {redirecting stderr through a pipeline} {unixExecs} {
- exec sh -c "echo foo bar 1>&2" \
- |& sh -c "echo second msg 1>&2; cat" |& cat
+test exec-6.3 {redirecting stderr through a pipeline} {
+ exec $tcltest sh -c "echo foo bar 1>&2" \
+ |& $tcltest sh -c "echo second msg 1>&2 ; cat" |& $tcltest cat
} "second msg\nfoo bar"
# I/O redirection: combinations.
catch {exec rm -f gorp.file2}
-test exec-7.1 {multiple I/O redirections} {unixExecs} {
- exec << "command input" > gorp.file2 cat < gorp.file
- exec cat gorp.file2
+test exec-7.1 {multiple I/O redirections} {
+ exec << "command input" > gorp.file2 $tcltest cat < gorp.file
+ exec $tcltest cat gorp.file2
} {Just a few thoughts}
-test exec-7.2 {multiple I/O redirections} {unixExecs} {
- exec < gorp.file << "command input" cat
+test exec-7.2 {multiple I/O redirections} {
+ exec < gorp.file << "command input" $tcltest cat
} {command input}
# Long input to command and output from command.
@@ -204,8 +278,8 @@ set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
-test exec-8.1 {long input and output} {unixExecs} {
- exec cat << $a
+test exec-8.1 {long input and output} {
+ exec $tcltest cat << $a
} $a
# Commands that return errors.
@@ -214,25 +288,25 @@ test exec-9.1 {commands returning errors} {
set x [catch {exec gorp456} msg]
list $x [string tolower $msg] [string tolower $errorCode]
} {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}}
-test exec-9.2 {commands returning errors} {unixExecs} {
- string tolower [list [catch {exec echo foo | foo123} msg] $msg $errorCode]
+test exec-9.2 {commands returning errors} {
+ string tolower [list [catch {exec $tcltest 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 {exec sleep 1 | sh -c "exit 43" | sleep 1} msg] $msg
+test exec-9.3 {commands returning errors} {
+ list [catch {exec $tcltest sleep 1 | $tcltest exit 43 | $tcltest sleep 1} msg] $msg
} {1 {child process exited abnormally}}
-test exec-9.4 {commands returning errors} {unixExecs} {
- list [catch {exec sh -c "exit 43" | echo "foo bar"} msg] $msg
+test exec-9.4 {commands returning errors} {
+ list [catch {exec $tcltest exit 43 | $tcltest 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]
+test exec-9.5 {commands returning errors} {
+ list [catch {exec gorp456 | $tcltest 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 {exec sh -c "echo error msg 1>&2"} msg] $msg
+test exec-9.6 {commands returning errors} {
+ list [catch {exec $tcltest sh -c "echo error msg 1>&2"} msg] $msg
} {1 {error msg}}
-test exec-9.7 {commands returning errors} {unixExecs} {
- list [catch {exec sh -c "echo error msg 1>&2" \
- | sh -c "echo error msg 1>&2"} msg] $msg
+test exec-9.7 {commands returning errors} {
+ list [catch {exec $tcltest sh -c "echo error msg 1>&2" \
+ | $tcltest sh -c "echo error msg 1>&2"} msg] $msg
} {1 {error msg
error msg}}
@@ -281,13 +355,13 @@ test exec-10.13 {errors in exec invocation} {
test exec-10.14 {errors in exec invocation} {
list [catch {exec cat <@} msg] $msg
} {1 {can't specify "<@" as last word in command}}
-test exec-10.15 {errors in exec invocation} {unixExecs} {
+test exec-10.15 {errors in exec invocation} {
list [catch {exec cat < a/b/c} msg] [string tolower $msg]
} {1 {couldn't read file "a/b/c": no such file or directory}}
-test exec-10.16 {errors in exec invocation} {unixExecs} {
+test exec-10.16 {errors in exec invocation} {
list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
-test exec-10.17 {errors in exec invocation} {unixExecs} {
+test exec-10.17 {errors in exec invocation} {
list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
set f [open gorp.file w]
@@ -303,36 +377,36 @@ close $f
test exec-10.20 {errors in exec invocation} {
list [catch {exec ~non_existent_user/foo/bar} msg] $msg
} {1 {user "non_existent_user" doesn't exist}}
-test exec-10.21 {errors in exec invocation} {unixExecs} {
- list [catch {exec true | ~xyzzy_bad_user/x | false} msg] $msg
+test exec-10.21 {errors in exec invocation} {
+ list [catch {exec $tcltest true | ~xyzzy_bad_user/x | false} msg] $msg
} {1 {user "xyzzy_bad_user" doesn't exist}}
# Commands in background.
-test exec-11.1 {commands in background} {unixExecs} {
- set x [lindex [time {exec sleep 2 &}] 0]
+test exec-11.1 {commands in background} {
+ set x [lindex [time {exec $tcltest sleep 2 &}] 0]
expr $x<1000000
} 1
-test exec-11.2 {commands in background} {unixExecs} {
- list [catch {exec echo a &b} msg] $msg
+test exec-11.2 {commands in background} {
+ list [catch {exec $tcltest echo a &b} msg] $msg
} {0 {a &b}}
-test exec-11.3 {commands in background} {unixExecs} {
- llength [exec sleep 1 &]
+test exec-11.3 {commands in background} {
+ llength [exec $tcltest sleep 1 &]
} 1
-test exec-11.4 {commands in background} {unixExecs} {
- llength [exec sleep 1 | sleep 1 | sleep 1 &]
+test exec-11.4 {commands in background} {
+ llength [exec $tcltest sleep 1 | $tcltest sleep 1 | $tcltest sleep 1 &]
} 3
-test exec-11.5 {commands in background} {unixExecs} {
+test exec-11.5 {commands in background} {
set f [open gorp.file w]
- puts $f { catch { exec echo foo & } }
+ puts $f { catch { exec [info nameofexecutable] echo foo & } }
close $f
- string compare "foo" [exec [info nameofexecutable] gorp.file]
+ string compare "foo" [exec $tcltest gorp.file]
} 0
# Make sure that background commands are properly reaped when
# they eventually die.
-catch {exec sleep 3}
+exec $tcltest sleep 3
test exec-12.1 {reaping background processes} {unixOnly nonPortable} {
for {set i 0} {$i < 20} {incr i} {
exec echo foo > /dev/null &
@@ -341,7 +415,7 @@ test exec-12.1 {reaping background processes} {unixOnly nonPortable} {
catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg
lindex $msg 0
} 0
-test exec-12.2 {reaping background processes} {unixExecs nonPortable} {
+test exec-12.2 {reaping background processes} {unixOnly nonPortable} {
exec sleep 2 | sleep 2 | sleep 2 &
catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
set x [lindex $msg 0]
@@ -372,11 +446,11 @@ test exec-12.3 {reaping background processes} {unixOnly nonPortable} {
# Make sure "errorCode" is set correctly.
-test exec-13.1 {setting errorCode variable} {unixExecs} {
- list [catch {exec cat < a/b/c} msg] [string tolower $errorCode]
+test exec-13.1 {setting errorCode variable} {
+ list [catch {exec $tcltest cat < a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
-test exec-13.2 {setting errorCode variable} {unixExecs} {
- list [catch {exec cat > a/b/c} msg] [string tolower $errorCode]
+test exec-13.2 {setting errorCode variable} {
+ list [catch {exec $tcltest cat > a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.3 {setting errorCode variable} {
set x [catch {exec _weird_cmd_} msg]
@@ -386,8 +460,8 @@ test exec-13.3 {setting errorCode variable} {
# Switches before the first argument
-test exec-14.1 {-keepnewline switch} {unixExecs} {
- exec -keepnewline echo foo
+test exec-14.1 {-keepnewline switch} {
+ exec -keepnewline $tcltest echo foo
} "foo\n"
test exec-14.2 {-keepnewline switch} {
list [catch {exec -keepnewline} msg] $msg
@@ -401,75 +475,77 @@ test exec-14.4 {-- switch} {
# Redirecting standard error separately from standard output
-test exec-15.1 {standard error redirection} {unixExecs} {
- exec echo "First line" > gorp.file
- list [exec sh -c "echo foo bar 1>&2" 2> gorp.file] \
- [exec cat gorp.file]
+test exec-15.1 {standard error redirection} {
+ exec $tcltest echo "First line" > gorp.file
+ list [exec $tcltest sh -c "echo foo bar 1>&2" 2> gorp.file] \
+ [exec $tcltest cat gorp.file]
} {{} {foo bar}}
-test exec-15.2 {standard error redirection} {unixExecs} {
- 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]
+test exec-15.2 {standard error redirection} {
+ list [exec $tcltest sh -c "echo foo bar 1>&2" \
+ | $tcltest echo biz baz >gorp.file 2> gorp.file2] \
+ [exec $tcltest cat gorp.file] \
+ [exec $tcltest cat gorp.file2]
} {{} {biz baz} {foo bar}}
-test exec-15.3 {standard error redirection} {unixExecs} {
- 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]
+test exec-15.3 {standard error redirection} {
+ list [exec $tcltest sh -c "echo foo bar 1>&2" \
+ | $tcltest echo biz baz 2>gorp.file > gorp.file2] \
+ [exec $tcltest cat gorp.file] \
+ [exec $tcltest cat gorp.file2]
} {{} {foo bar} {biz baz}}
-test exec-15.4 {standard error redirection} {unixExecs} {
+test exec-15.4 {standard error redirection} {
set f [open gorp.file w]
puts $f "Line 1"
flush $f
- exec sh -c "echo foo bar 1>&2" 2>@ $f
+ exec $tcltest sh -c "echo foo bar 1>&2" 2>@ $f
puts $f "Line 3"
close $f
- exec cat gorp.file
+ exec $tcltest cat gorp.file
} {Line 1
foo bar
Line 3}
-test exec-15.5 {standard error redirection} {unixExecs} {
- exec echo "First line" > gorp.file
- exec sh -c "echo foo bar 1>&2" 2>> gorp.file
- exec cat gorp.file
+test exec-15.5 {standard error redirection} {
+ exec $tcltest echo "First line" > gorp.file
+ exec $tcltest sh -c "echo foo bar 1>&2" 2>> gorp.file
+ exec $tcltest cat gorp.file
} {First line
foo bar}
-test exec-15.6 {standard error redirection} {unixExecs} {
- 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]
+test exec-15.6 {standard error redirection} {
+ exec $tcltest sh -c "echo foo bar 1>&2" > gorp.file2 2> gorp.file \
+ >& gorp.file 2> gorp.file2 | $tcltest echo biz baz
+ list [exec $tcltest cat gorp.file] [exec $tcltest cat gorp.file2]
} {{biz baz} {foo bar}}
-test exec-16.1 {flush output before exec} {unixExecs} {
+test exec-16.1 {flush output before exec} {
set f [open gorp.file w]
puts $f "First line"
- exec echo "Second line" >@ $f
+ exec $tcltest echo "Second line" >@ $f
puts $f "Third line"
close $f
- exec cat gorp.file
+ exec $tcltest cat gorp.file
} {First line
Second line
Third line}
test exec-16.2 {flush output before exec} {} {
set f [open gorp.file w]
puts $f "First line"
- exec [lindex $tcltest 0] << {puts stderr {Second line}} >&@ $f > gorp.file2
+ exec $tcltest << {puts stderr {Second line}} >&@ $f > gorp.file2
puts $f "Third line"
close $f
- cat gorp.file
+ exec $tcltest cat gorp.file
} {First line
Second line
Third line}
-test exec-17.1 { inheriting standard I/O } {unixOrPc unixExecs} {
+test exec-17.1 { inheriting standard I/O } {
set f [open script w]
puts $f {close stdout
set f [open gorp.file w]
- catch {exec echo foobar &}
- exec sleep 2
+ catch {exec [info nameofexecutable] echo foobar &}
+ exec [info nameofexecutable] sleep 2
close $f
}
close $f
- catch {eval exec $tcltest script} result
+ catch {exec $tcltest script} result
set f [open gorp.file r]
lappend result [read $f]
close $f
@@ -477,8 +553,5 @@ test exec-17.1 { inheriting standard I/O } {unixOrPc unixExecs} {
} {{foobar
}}
-removeFile script
-removeFile gorp.file
-removeFile gorp.file2
-
-return {}
+file delete script gorp.file gorp.file2
+file delete echo cat wc sh sleep exit
diff --git a/contrib/tcl/tests/execute.test b/contrib/tcl/tests/execute.test
index 6c63750d9b3d..81fde454f791 100644
--- a/contrib/tcl/tests/execute.test
+++ b/contrib/tcl/tests/execute.test
@@ -13,7 +13,7 @@
# 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
+# SCCS: @(#) execute.test 1.5 97/08/12 11:16:31
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -111,3 +111,4 @@ catch {rename { } ""}
catch {unset x}
catch {unset y}
catch {unset msg}
+concat {}
diff --git a/contrib/tcl/tests/expr-old.test b/contrib/tcl/tests/expr-old.test
index e25a1eb2d382..b2f577e6af4a 100644
--- a/contrib/tcl/tests/expr-old.test
+++ b/contrib/tcl/tests/expr-old.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: @(#) expr-old.test 1.59 97/06/26 14:33:32
+# SCCS: @(#) expr-old.test 1.61 97/08/13 10:26:38
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -82,19 +82,17 @@ 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.1 {floating-point operators} {expr -4.2} -4.2
+test expr-old-2.2 {floating-point operators} {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.7 {floating-point operators} {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.10 {floating-point operators} {expr 2.3+2.1} 4.4
+test expr-old-2.11 {floating-point operators} {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
@@ -119,12 +117,10 @@ 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.36 {floating-point operators} {expr 3.3>2.3?44.3:66.3} 44.3
+test expr-old-2.37 {floating-point operators} {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
+ list [catch {expr 028.1 + 09.2} msg] $msg
} {0 37.3}
# Operators that aren't legal on floating-point numbers
@@ -385,7 +381,7 @@ test expr-old-24.2 {numbers in different bases} {expr 015} 13
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.4 {type conversions} {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
@@ -400,7 +396,7 @@ 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.19 {type conversions} {expr 2.0e15} 2e+15
test expr-old-25.20 {type conversions} {expr 10.0} 10.0
# Various error conditions.
@@ -589,7 +585,7 @@ test expr-old-28.14 {Tcl_ExprBool usage} {
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.3 {braces} {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
@@ -705,7 +701,7 @@ 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)]
+ expr double(1.1)
} {1.1}
test expr-old-32.28 {math functions in expressions} {
expr int(1)
@@ -861,11 +857,11 @@ test expr-old-36.2 {ExprLooksLikeInt procedure} {
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
+ list [catch {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
+ list [catch {expr {$x+1}} msg] $msg
} {0 290.1}
test expr-old-36.5 {ExprLooksLikeInt procedure} {
set x { +22}
@@ -892,6 +888,10 @@ test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if
testexprlong
} {This is a result: 5}
+test expr-old-38.1 {Verify Tcl_ExprString's basic operation} {
+ list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \
+ [catch {testexprstring "1+"} msg] $msg
+} {5 10.2 1 {syntax error in expression "1+"}}
# Special test for Pentium arithmetic bug of 1994:
diff --git a/contrib/tcl/tests/expr.test b/contrib/tcl/tests/expr.test
index 481e3abd0200..e0825f971fa2 100644
--- a/contrib/tcl/tests/expr.test
+++ b/contrib/tcl/tests/expr.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: @(#) expr.test 1.29 97/06/23 18:46:25
+# SCCS: @(#) expr.test 1.33 97/08/07 10:45:57
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -77,7 +77,7 @@ 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]
+ expr -8.2 -6
} -14.2
test expr-1.4 {TclCompileExprCmd: five expression words} {
expr 20 - 5 +10 -7
@@ -117,6 +117,11 @@ test expr-1.13 {TclCompileExprCmd: second level of substitutions in expr not in
set x 27; set bool {$x}; if $bool {set a foo}
set a
} foo
+test expr-1.14 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} {
+ set a xxx
+ set x 2; set b {$x}; set a [expr $b == 2]
+ set a
+} 1
test expr-2.1 {TclCompileExpr: are builtin functions registered?} {
expr double(5*[llength "6 2"])
@@ -426,7 +431,7 @@ 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]
+ 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\
@@ -466,7 +471,7 @@ test expr-14.16 {CompilePrimaryExpr: error compiling var reference primary} {
} {missing )
(parsing index for array "a")
while compiling
-"expr"}
+"expr {$a(foo}"}
test expr-14.17 {CompilePrimaryExpr: string primary that looks like var ref} {
expr $
} $
@@ -476,12 +481,12 @@ test expr-14.18 {CompilePrimaryExpr: quoted string primary} {
test expr-14.19 {CompilePrimaryExpr: quoted string primary} {
set i 123
set x 456
- format %.6g [expr "$i+$x"]
+ expr "$i+$x"
} 579
test expr-14.20 {CompilePrimaryExpr: quoted string primary} {
set i 3
set x 6
- format %.6g [expr 2+"$i.$x"]
+ expr 2+"$i.$x"
} 5.6
test expr-14.21 {CompilePrimaryExpr: error in quoted string primary} {
catch {expr "[set]"} msg
@@ -497,15 +502,15 @@ test expr-14.23 {CompilePrimaryExpr: error in subcommand primary} {
while compiling
"set"
while compiling
-"expr"}
+"expr {[set]}"}
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"
+"set i"
while compiling
-"expr"}
+"expr {[set i}"}
test expr-14.25 {CompilePrimaryExpr: math function primary} {
format %.6g [expr exp(1.0)]
} 2.71828
@@ -528,7 +533,7 @@ test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} {
while compiling
"set"
while compiling
-"expr"}
+"expr 2+(3*[set])"}
test expr-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} {
catch {expr 2+(3*(4+5)} msg
set errorInfo
diff --git a/contrib/tcl/tests/fCmd.test b/contrib/tcl/tests/fCmd.test
index f53da0c3e33a..e7d2279ef194 100644
--- a/contrib/tcl/tests/fCmd.test
+++ b/contrib/tcl/tests/fCmd.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: @(#) fCmd.test 1.30 97/06/23 17:29:36
+# SCCS: @(#) fCmd.test 1.31 97/08/05 11:42:09
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -468,7 +468,10 @@ test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} {
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} {
+test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} {!$testConfig(win32s) || ($root == "C:/")} {
+ # Don't run this test under Win32s on a drive mounted from an NT
+ # machine; it causes the NT machine to die.
+
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}}]
diff --git a/contrib/tcl/tests/fileName.test b/contrib/tcl/tests/fileName.test
index f7f45946aa35..f6be5acc3550 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.28 97/06/23 17:30:15
+# SCCS: @(#) fileName.test 1.30 97/08/01 11:13:27
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -1089,34 +1089,34 @@ test filename-11.13 {Tcl_GlobCmd} {
list [catch {file join [lindex [glob ~] 0]} msg] $msg
} [list 0 [file join $env(HOME)]]
-# The following tests will work on Windows platforms only if MKS
-# toolkit is installed.
+set oldhome $env(HOME)
+set env(HOME) [pwd]
+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]
+close [open "globTest/weird name.c" w]
+close [open globTest/a1/b1/x2.c w]
+close [open globTest/a1/b2/y2.c w]
-catch {
- set oldhome $env(HOME)
- set env(HOME) [pwd]
- 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]
- close [open globTest/x,z1.c w]
- close [open "globTest/weird name.c" w]
- close [open globTest/.1 w]
- close [open globTest/a1/b1/x2.c w]
- close [open globTest/a1/b2/y2.c w]
-}
+# Cannot create a file with the following names under Win32s. We have to
+# skip the tests that are checking the difference between a "." or "," in
+# the file name vs. a "." or "," in the glob pattern.
+
+catch {close [open globTest/.1 w]}
+catch {close [open globTest/x,z1.c w]}
-test filename-11.14 {Tcl_GlobCmd} {unixExecs} {
+test filename-11.14 {Tcl_GlobCmd} {
list [catch {glob ~/globTest} msg] $msg
} [list 0 [list [file join $env(HOME) globTest]]]
-test filename-11.15 {Tcl_GlobCmd} {unixExecs} {
+test filename-11.15 {Tcl_GlobCmd} {
list [catch {glob ~\\/globTest} msg] $msg
} [list 0 [list [file join $env(HOME) globTest]]]
-test filename-11.16 {Tcl_GlobCmd} {unixExecs} {
+test filename-11.16 {Tcl_GlobCmd} {
list [catch {glob globTest} msg] $msg
} {0 globTest}
@@ -1140,14 +1140,14 @@ set y1 y1.c
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} {
+test filename-12.5 {simple globbing} {
list [catch {glob globTest\\/x1.c} msg] $msg
} "0 $globPreResult$x1"
-test filename-12.6 {simple globbing} {unixExecs} {
+test filename-12.6 {simple globbing} {
list [catch {glob globTest\\/\\x1.c} msg] $msg
} "0 $globPreResult$x1"
-test filename-13.1 {globbing with brace substitution} {unixExecs} {
+test filename-13.1 {globbing with brace substitution} {
list [catch {glob globTest/\{\}} msg] $msg
} "0 $globPreResult"
test filename-13.2 {globbing with brace substitution} {
@@ -1162,107 +1162,119 @@ test filename-13.4 {globbing with brace substitution} {
test filename-13.5 {globbing with brace substitution} {
list [catch {glob globTest/\}} msg] $msg
} {1 {unmatched close-brace in file name}}
-test filename-13.6 {globbing with brace substitution} {unixExecs} {
+test filename-13.6 {globbing with brace substitution} {
list [catch {glob globTest/\{\}x1.c} msg] $msg
} "0 $globPreResult$x1"
-test filename-13.7 {globbing with brace substitution} {unixExecs} {
+test filename-13.7 {globbing with brace substitution} {
list [catch {glob globTest/\{x\}1.c} msg] $msg
} "0 $globPreResult$x1"
-test filename-13.8 {globbing with brace substitution} {unixExecs} {
+test filename-13.8 {globbing with brace substitution} {
list [catch {glob globTest/\{x\{\}\}1.c} msg] $msg
} "0 $globPreResult$x1"
-test filename-13.9 {globbing with brace substitution} {unixExecs} {
+test filename-13.9 {globbing with brace substitution} {!win32s} {
list [lsort [catch {glob globTest/\{x,y\}1.c} msg]] $msg
} [list 0 [list $globPreResult$x1 $globPreResult$y1]]
-test filename-13.10 {globbing with brace substitution} {unixExecs} {
+test filename-13.10 {globbing with brace substitution} {!win32s} {
list [lsort [catch {glob globTest/\{x,,y\}1.c} msg]] $msg
} [list 0 [list $globPreResult$x1 $globPreResult$y1]]
-test filename-13.11 {globbing with brace substitution} {unixOrPc unixExecs} {
+test filename-13.11 {globbing with brace substitution} {unixOrPc && !win32s} {
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} {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.13 {globbing with brace substitution} {unixExecs} {
+test filename-13.13 {globbing with brace substitution} {
lsort [glob globTest/{a,b,x,y}1.c]
} [list $globPreResult$x1 $globPreResult$y1]
-test filename-13.14 {globbing with brace substitution} {unixOrPc unixExecs} {
+test filename-13.14 {globbing with brace substitution} {unixOrPc} {
lsort [glob {globTest/{x1,y2,weird name}.c}]
} {{globTest/weird name.c} globTest/x1.c}
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.16 {globbing with brace substitution} {unixOrPc unixExecs} {
+test filename-13.16 {globbing with brace substitution} {unixOrPc} {
lsort [glob globTest/{x1.c,a1/*}]
} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c}
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.18 {globbing with brace substitution} {unixOrPc unixExecs} {
+test filename-13.18 {globbing with brace substitution} {unixOrPc} {
lsort [glob globTest/{x1.c,{a},a1/*}]
} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c}
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.20 {globbing with brace substitution} {unixOrPc unixExecs} {
+test filename-13.20 {globbing with brace substitution} {unixOrPc} {
lsort [glob globTest/{a,x}1/*/{x,y}*]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
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.22 {globbing with brace substitution} {unixExecs} {
+test filename-13.22 {globbing with brace substitution} {
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} {
+test filename-14.1 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
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} {win32s} {
+ lsort [glob g*/*.c]
+} {globtest/weirdn~1.c globtest/x1.c globtest/y1.c globtest/z1.c}
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.3 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob globTest/?1.c]
} {globTest/x1.c globTest/y1.c globTest/z1.c}
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.5 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
lsort [glob */*/*/*.c]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
+test filename-14.5 {asterisks, question marks, and brackets} {win32s} {
+ lsort [glob */*/*/*.c]
+} {globtest/a1/b1/x2.c globtest/a1/b2/y2.c}
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.7 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.7 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
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.7 {asterisks, question marks, and brackets} {win32s} {
+ lsort [glob globTest/*]
+} {globTest/a1 globTest/a2 globTest/a3 globTest/weirdn~1.c globTest/x1.c globTest/y1.c globTest/z1.c}
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.9 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.9 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
lsort [glob globTest/.*]
} {globTest/. globTest/.. globTest/.1}
+test filename-14.9 {asterisks, question marks, and brackets} {win32s} {
+ lsort [glob globTest/.*]
+} {globTest/. globTest/..}
test filename-14.10 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob globTest/.*]
} {:globTest:.1}
-test filename-14.11 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.11 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob globTest/*/*]
} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3}
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.13 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.13 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob {globTest/[xyab]1.*}]
} {globTest/x1.c globTest/y1.c}
test filename-14.14 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob {globTest/[xyab]1.*}]
} {:globTest:x1.c :globTest:y1.c}
-test filename-14.15 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.15 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob globTest/*/]
} {globTest/a1/ globTest/a2/ globTest/a3/}
test filename-14.16 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob globTest/*/]
} {:globTest:a1: :globTest:a2: :globTest:a3:}
-test filename-14.17 {asterisks, question marks, and brackets} {unixExecs} {
+test filename-14.17 {asterisks, question marks, and brackets} {
global env
set temp $env(HOME)
set env(HOME) [file join $env(HOME) globTest]
@@ -1270,9 +1282,12 @@ test filename-14.17 {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.18 {asterisks, question marks, and brackets} {unixExecs unixOrPc} {
+test filename-14.18 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
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.18 {asterisks, question marks, and brackets} {win32s} {
+ list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg
+} {0 {globTest/weirdn~1.c globTest/x1.c globTest/y1.c globTest/z1.c}}
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}}
@@ -1303,10 +1318,9 @@ if {$tcl_platform(platform) == "unix"} {
string tolower [list [catch {glob globTest/*} msg] $msg $errorCode]
} {1 {couldn't read directory "globtest": permission denied} {posix eacces {permission denied}}}
exec chmod 755 globTest
-
- test filename-15.2 {unix specific globbing} {nonPortable} {
- glob ~ouster/.csh*
- } "/home/ouster/.cshrc"
+ test filename-15.2 {unix specific globbing} {nonPortable} {
+ glob ~ouster/.csh*
+ } "/home/ouster/.cshrc"
close [open globTest/odd\\\[\]*?\{\}name w]
test filename-15.3 {unix specific globbing} {
global env
@@ -1332,44 +1346,67 @@ if {$tcl_platform(platform) == "windows"} {
close [open globTest/z1.bat w]
}
- test filename-16.1 {windows specific globbing} {unixExecs} {
+ test filename-16.1 {windows specific globbing} {!win32s} {
lsort [glob globTest/*.bat]
} {globTest/x1.BAT globTest/y1.Bat globTest/z1.bat}
+ test filename-16.1 {windows specific globbing} {win32s} {
+ lsort [glob globTest/*.bat]
+ } {globTest/x1.bat globTest/y1.bat globTest/z1.bat}
test filename-16.2 {windows specific globbing} {
glob c:
} c:
- test filename-16.3 {windows specific globbing} {unixExecs} {
+ test filename-16.3 {windows specific globbing} {
glob c:\\\\
} c:/
test filename-16.4 {windows specific globbing} {
glob c:/
} c:/
- test filename-16.5 {windows specific globbing} {unixExecs} {
+ test filename-16.5 {windows specific globbing} {!win32s} {
glob c:*Test
} c:globTest
- test filename-16.6 {windows specific globbing} {unixExecs} {
+ test filename-16.5 {windows specific globbing} {win32s} {
+ glob c:*Test
+ } c:globtest
+ test filename-16.6 {windows specific globbing} {!win32s} {
glob c:\\\\*Test
} c:/globTest
- test filename-16.7 {windows specific globbing} {unixExecs} {
+ test filename-16.6 {windows specific globbing} {win32s} {
+ glob c:\\\\*Test
+ } c:/globtest
+ test filename-16.7 {windows specific globbing} {!win32s} {
glob c:/*Test
} c:/globTest
- test filename-16.8 {windows specific globbing} {unixExecs} {
+ test filename-16.7 {windows specific globbing} {win32s} {
+ glob c:/*Test
+ } c:/globtest
+ test filename-16.8 {windows specific globbing} {!win32s} {
lsort [glob c:globTest/*.bat]
} {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat}
- test filename-16.9 {windows specific globbing} {unixExecs} {
+ test filename-16.8 {windows specific globbing} {win32s} {
+ lsort [glob c:globTest/*.bat]
+ } {c:globTest/x1.bat c:globTest/y1.bat c:globTest/z1.bat}
+ test filename-16.9 {windows specific globbing} {!win32s} {
lsort [glob c:/globTest/*.bat]
} {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat}
- test filename-16.10 {windows specific globbing} {unixExecs} {
+ test filename-16.9 {windows specific globbing} {win32s} {
+ lsort [glob c:/globTest/*.bat]
+ } {c:/globTest/x1.bat c:/globTest/y1.bat c:/globTest/z1.bat}
+ test filename-16.10 {windows specific globbing} {!win32s} {
lsort [glob c:globTest\\\\*.bat]
} {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat}
- test filename-16.11 {windows specific globbing} {unixExecs} {
+ test filename-16.10 {windows specific globbing} {win32s} {
+ lsort [glob c:globTest\\\\*.bat]
+ } {c:globTest/x1.bat c:globTest/y1.bat c:globTest/z1.bat}
+ test filename-16.11 {windows specific globbing} {!win32s} {
lsort [glob c:\\\\globTest\\\\*.bat]
} {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat}
+ test filename-16.11 {windows specific globbing} {win32s} {
+ lsort [glob c:\\\\globTest\\\\*.bat]
+ } {c:/globTest/x1.bat c:/globTest/y1.bat c:/globTest/z1.bat}
removeDirectory globTest
- if $testConfig(nonPortable) {
- cd //gaspode/d
+ if {($testConfig(nonPortable) != 0) && [catch {cd //gaspode/d}] == 0} {
removeDirectory globTest
makeDirectory globTest
diff --git a/contrib/tcl/tests/for.test b/contrib/tcl/tests/for.test
index 7b518febf048..aa918ec082f1 100644
--- a/contrib/tcl/tests/for.test
+++ b/contrib/tcl/tests/for.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: @(#) for.test 1.9 97/06/23 18:40:35
+# SCCS: @(#) for.test 1.10 97/07/02 16:40:59
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -22,7 +22,7 @@ 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"}}
+"for {set}"}}
catch {unset i}
test for-1.3 {TclCompileForCmd: missing test expression} {
catch {for {set i 0}} msg
@@ -33,7 +33,7 @@ test for-1.4 {TclCompileForCmd: error in test expression} {
set errorInfo
} {wrong # args: should be "for start test next command"
while compiling
-"for"}
+"for {set i 0} {$i<}"}
test for-1.5 {TclCompileForCmd: test expression is enclosed in quotes} {
set i 0
for {} "$i > 5" {incr i} {}
@@ -54,7 +54,7 @@ test for-1.8 {TclCompileForCmd: error compiling command body} {
"set"
("for" body line 1)
while compiling
-"for"}
+"for {set i 0} {$i < 5} {incr i} {set}"}
catch {unset a}
test for-1.9 {TclCompileForCmd: simple command body} {
set a {}
@@ -88,7 +88,7 @@ test for-1.12 {TclCompileForCmd: error in "next" command} {
"set"
("for" loop-end command)
while compiling
-"for"}
+"for {set i 0} {$i < 5} {set} {puts $i}"}
test for-1.13 {TclCompileForCmd: long command body} {
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]} {
diff --git a/contrib/tcl/tests/foreach.test b/contrib/tcl/tests/foreach.test
index 64fffc5d5dbb..f87dd39d24b6 100644
--- a/contrib/tcl/tests/foreach.test
+++ b/contrib/tcl/tests/foreach.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: @(#) foreach.test 1.7 97/06/23 18:23:42
+# SCCS: @(#) foreach.test 1.8 97/08/12 18:19:27
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -157,6 +157,15 @@ test foreach-3.1 {compiled foreach backward jump works correctly} {
foo x
} {{0 zero} {1 one} {2 two} {3 three}}
+test foreach-4.1 {noncompiled foreach and shared variable or value list objects that are converted to another type} {
+ catch {unset x}
+ foreach {12.0} {a b c} {
+ set x 12.0
+ set x [expr $x + 1]
+ }
+ set x
+} 13.0
+
# Check "continue".
test foreach-4.1 {continue tests} {catch continue} 4
diff --git a/contrib/tcl/tests/format.test b/contrib/tcl/tests/format.test
index 219327b43189..680b626af0b0 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.24 96/10/08 17:40:55
+# SCCS: @(#) format.test 1.28 97/08/11 14:45:15
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -302,11 +302,15 @@ test format-7.22 {error conditions} {
catch {format %d} msg
set msg
} {not enough arguments for all format specifiers}
+test format-7.23 {error conditions} {
+ catch {format "%d %d" 24 xyz} msg
+ set msg
+} {expected integer but got "xyz"}
test format-8.1 {long result} {
set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
- format {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 %s %s %s} $a $a $a
-} {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 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
+ format {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 %s %s} $a $a
+} {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 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
test format-9.1 {"h" format specifier} {nonPortable} {
format %hd 0xffff
@@ -358,3 +362,57 @@ test format-10.12 {XPG3 %$n specifiers} {
test format-11.1 {negative width specifiers} {
format "%*d" -47 25
} {25}
+test format-12.1 {tcl_precision fuzzy comparison} {
+ catch {unset a}
+ catch {unset b}
+ catch {unset c}
+ catch {unset d}
+ set a 0.0000000000001
+ set b 0.00000000000001
+ set c 0.00000000000000001
+ set d [expr $a + $b + $c]
+ format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d
+} {0.0000000000 0.000000000000 0.000000000000110 0.00000000000011001}
+test format-12.2 {tcl_precision fuzzy comparison} {
+ catch {unset a}
+ catch {unset b}
+ catch {unset c}
+ catch {unset d}
+ set a 0.000000000001
+ set b 0.000000000000005
+ set c 0.0000000000000008
+ set d [expr $a + $b + $c]
+ format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d
+} {0.0000000000 0.000000000001 0.000000000001006 0.00000000000100580}
+test format-12.3 {tcl_precision fuzzy comparison} {
+ catch {unset a}
+ catch {unset b}
+ catch {unset c}
+ set a 0.00000000000099
+ set b 0.000000000000011
+ set c [expr $a + $b]
+ format {%0.10f %0.12f %0.15f %0.17f} $c $c $c $c
+} {0.0000000000 0.000000000001 0.000000000001001 0.00000000000100100}
+test format-12.4 {tcl_precision fuzzy comparison} {
+ catch {unset a}
+ catch {unset b}
+ catch {unset c}
+ set a 0.444444444444
+ set b 0.33333333333333
+ set c [expr $a + $b]
+ format {%0.10f %0.12f %0.15f %0.16f} $c $c $c $c
+} {0.7777777778 0.777777777777 0.777777777777330 0.7777777777773300}
+test format-12.5 {tcl_precision fuzzy comparison} {
+ catch {unset a}
+ catch {unset b}
+ catch {unset c}
+ set a 0.444444444444
+ set b 0.99999999999999
+ set c [expr $a + $b]
+ format {%0.10f %0.12f %0.15f} $c $c $c
+} {1.4444444444 1.444444444444 1.444444444443990}
+catch {unset a}
+catch {unset b}
+catch {unset c}
+catch {unset d}
+return
diff --git a/contrib/tcl/tests/history.test b/contrib/tcl/tests/history.test
index 1d30955be991..498fb2e83f8c 100644
--- a/contrib/tcl/tests/history.test
+++ b/contrib/tcl/tests/history.test
@@ -10,9 +10,9 @@
# 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.12 96/03/11 18:06:04
+# SCCS: @(#) history.test 1.15 97/08/13 14:37:10
-if {[info commands history] == ""} {
+if {[catch {history}]} {
puts stdout "This version of Tcl was built without the history command;\n"
puts stdout "history tests will be skipped.\n"
return
@@ -94,7 +94,7 @@ test history-3.9 {add option} {
history change "A test value"
test history-4.1 {change option} {history event [expr {[history n]-1}]} \
"A test value"
-history c "Another test" -1
+history ch "Another test" -1
test history-4.2 {change option} {history e} "Another test"
test history-4.3 {change option} {history event [expr {[history n]-1}]} \
"A test value"
@@ -106,10 +106,11 @@ test history-4.5 {change option} {
test history-4.6 {change option} {
catch {history change Foo [expr {[history n]-4}]}
} 1
+set num [expr {[history n]-4}]
test history-4.7 {change option} {
- catch {history change Foo [expr {[history n]-4}]}
+ catch {history change Foo $num} msg
set msg
-} {wrong # args: should be "history change newValue ?event?"}
+} "event \"$num\" is too far in the past"
# "history info"
@@ -162,17 +163,20 @@ test history-6.10 {keep option} {catch {history keep 4 6}} 1
test history-6.11 {keep option} {
catch {history keep 4 6} msg
set msg
-} {wrong # args: should be "history keep number"}
-test history-6.12 {keep option} {catch {history keep}} 1
+} {wrong # args: should be "history keep ?count?"}
+test history-6.12 {keep option} {catch {history keep}} 0
test history-6.13 {keep option} {
- catch {history keep} msg
- set msg
-} {wrong # args: should be "history keep number"}
+ history keep
+} {5}
test history-6.14 {keep option} {catch {history keep -3}} 1
test history-6.15 {keep option} {
catch {history keep -3} msg
set msg
} {illegal keep count "-3"}
+test history-6.16 {keep option} {
+ catch {history keep butter} msg
+ set msg
+} {illegal keep count "butter"}
# "history nextid"
@@ -187,200 +191,21 @@ test history-7.4 {nextid option} {
set msg
} {wrong # args: should be "history nextid"}
-# "history substitute"
-
-test history-8.1 {substitute option} {
- history add "set a {test foo test b c test}"
- history add "Test command 2"
- set a 0
- history substitute foo bar -1
- set a
-} {test bar test b c test}
-test history-8.2 {substitute option} {
- history add "set a {test foo test b c test}"
- history add "Test command 2"
- set a 0
- history substitute test gorp
- set a
-} {gorp foo gorp b c gorp}
-test history-8.3 {substitute option} {
- history add "set a {test foo test b c test}"
- history add "Test command 2"
- set a 0
- history sub " te" to
- set a
-} {test footost b ctost}
-test history-8.4 {substitute option} {catch {history sub xxx yyy}} 1
-test history-8.5 {substitute option} {
- catch {history sub xxx yyy} msg
- set msg
-} {"xxx" doesn't appear in event}
-test history-8.6 {substitute option} {catch {history s a b -10}} 1
-test history-8.7 {substitute option} {
- catch {history s a b -10} msg
- set msg
-} {event "-10" is too far in the past}
-test history-8.8 {substitute option} {catch {history s a b -1 20}} 1
-test history-8.9 {substitute option} {
- catch {history s a b -1 20} msg
- set msg
-} {wrong # args: should be "history substitute old new ?event?"}
+# "history clear"
-# "history words"
-
-test history-9.1 {words option} {
- history add {word0 word1 word2 a b c word6}
- history add foo
- history words 0-$
-} {word0 word1 word2 a b c word6}
-test history-9.2 {words option} {
- history add {word0 word1 word2 a b c word6}
- history add foo
- history w 2 -1
-} word2
-test history-9.3 {words option} {
- history add {word0 word1 word2 a b c word6}
- history add foo
- history wo $
-} word6
-test history-9.4 {words option} {catch {history w 1--1} msg} 1
-test history-9.5 {words option} {
- catch {history w 1--1} msg
- set msg
-} {bad word selector "1--1": should be num-num or pattern}
-test history-9.6 {words option} {
- history add {word0 word1 word2 a b c word6}
- history add foo
- history w w
-} {}
-test history-9.7 {words option} {
- history add {word0 word1 word2 a b c word6}
- history add foo
- history w *2
-} word2
-test history-9.8 {words option} {
- history add {word0 word1 word2 a b c word6}
- history add foo
- history w *or*
-} {word0 word1 word2 word6}
-test history-9.9 {words option} {catch {history words 10}} 1
-test history-9.10 {words option} {
- catch {history words 10} msg
- set msg
-} {word selector "10" specified non-existent words}
-test history-9.11 {words option} {catch {history words 1 -1 20}} 1
-test history-9.12 {words option} {
- catch {history words 1 -1 20} msg
- set msg
-} {wrong # args: should be "history words num-num/pat ?event?"}
-
-# history revision
-
-test history-10.1 {history revision} {
- set a 0
- history a {set a 12345}
- history a {set a [history e]} exec
- set a
-} {set a 12345}
-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} {notIfCompiled} {
- set a 0
- history a {set a 12345}
- history a {set a [history e]} exec
- history a foo
- history a {history r -2} exec
- history a {set a 12345}
- history ev -1
-} {set a {set a 12345}}
-test history-10.4 {history revision} {notIfCompiled} {
- history a {set a 12345}
- history a {history s 123 999} exec
- history a foo
- history ev -1
-} {set a 99945}
-test history-10.5 {history revision} {
- history add {word0 word1 word2 a b c word6}
- 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} {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} {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}
- history add {word0 word1 word2 a b c word6}
- set a 0
- history add {set [history subs b a -2] [list abc [history r -2] [history w 1-3]]} exec
- history add foo
- history ev
-} {set [format a] [list abc [format b] {word1 word2 a}]}
-test history-10.8 {history revision} {notIfCompiled} {
- history add {set a 12345}
- concat a b c
- history add {history redo; set b 44} exec
- history add foo
- history ev
-} {set a 12345; set b 44}
-test history-10.9 {history revision} {
- history add {set a 12345}
- history add {history redo; history change "A simple test"; history subs 45 xx} exec
- set a
-} 123xx
-test history-10.10 {history revision} {
- history add {set a 12345}
- history add {history redo; history change "A simple test"; history subs 45 xx} exec
- history add foo
- history e
-} {A simple test}
-test history-10.11 {history revision} {
- history add {word0 word1 $ a b c word6}
- history add {set a [history w 4-[history word 2]]} exec
- set a
-} {b c word6}
-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
- history e
-} {set a {b c word6}}
-test history-10.13 {history revision} {
- history add {history word 0} exec
- history add foo
- history e
-} {history word 0}
-test history-10.14 {history revision} {
- history add {set a [history word 0; format c]} exec
- history add foo
- history e
-} {set a [history word 0; format c]}
-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} {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
-} {set a word1; history add foo; set a [history words 0]}
+set num [history n]
+history add "Testing"
+history add "Testing2"
+test history-8.1 {clear option} {catch {history clear junk}} 1
+test history-8.2 {clear option} {history clear} {}
+history add "Testing"
+test history-8.3 {clear option} {history} { 1 Testing}
# miscellaneous
-test history-11.1 {miscellaneous} {catch {history gorp} msg} 1
-test history-11.2 {miscellaneous} {
+test history-9.1 {miscellaneous} {catch {history gorp} msg} 1
+test history-9.2 {miscellaneous} {
catch {history gorp} msg
set msg
-} {bad option "gorp": must be add, change, event, info, keep, nextid, redo, substitute, or words}
+} {bad option "gorp": must be add, change, clear, event, info, keep, nextid, or redo}
+
diff --git a/contrib/tcl/tests/http.test b/contrib/tcl/tests/http.test
index 3c47c27d531e..2770e1389154 100644
--- a/contrib/tcl/tests/http.test
+++ b/contrib/tcl/tests/http.test
@@ -1,4 +1,4 @@
-# Commands covered: http_config, http_get, http_wait, http_reset
+# Commands covered: http::config, http::geturl, 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
@@ -10,14 +10,23 @@
# 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
+#
+# SCCS: @(#) http2.test 1.8 97/08/13 11:16:50
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
+if {[catch {package require http 2.0}]} {
+ if {[info exist http2]} {
+ catch {puts stderr "Cannot load http 2.0 package"}
+ return
+ } else {
+ catch {puts stderr "Running http 2.0 tests in slave interp"}
+ set interp [interp create http2]
+ $interp eval [list set http2 "running"]
+ $interp eval [list source [info script]]
+ interp delete $interp
+ return
+ }
}
############### The httpd_ procedures implement a stub http server. ########
@@ -117,22 +126,30 @@ upvar #0 httpd$sock data
# Respond to the query.
+set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
proc httpdRespond { sock } {
- global httpd
+ global httpd bindata port
upvar #0 httpd$sock data
- set html "<html><head><title>HTTP/1.0 TEST</title></head><body>
+ if {[string match *binary* $data(url)]} {
+ set html "$bindata[info hostname]:$port$data(url)"
+ set type application/octet-stream
+ } else {
+ set type text/html
+
+ 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"
+ 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 </dl>\n
+ append html </body></html>
}
- append html </body></html>
if {$data(proto) == "HEAD"} {
puts $sock "HTTP/1.0 200 OK"
@@ -140,7 +157,7 @@ proc httpdRespond { sock } {
puts $sock "HTTP/1.0 200 Data follows"
}
puts $sock "Date: [clock format [clock clicks]]"
- puts $sock "Content-Type: text/html"
+ puts $sock "Content-Type: $type"
puts $sock "Content-Length: [string length $html]"
puts $sock ""
if {$data(proto) != "HEAD"} {
@@ -150,7 +167,7 @@ proc httpdRespond { sock } {
httpd_log $sock Done ""
httpdSockDone $sock
}
-##################### end server ###########################33
+##################### end server ###########################
set port 8010
if [catch {httpd_init $port} listen] {
@@ -159,46 +176,58 @@ if [catch {httpd_init $port} listen] {
return
}
-test http-1.1 {http_config} {
- http_config
-} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}}
+test http-1.1 {http::config} {
+ http::config
+} {-accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 2.0}}
-test http-1.2 {http_config} {
- http_config -proxyfilter
-} httpProxyRequired
+test http-1.2 {http::config} {
+ http::config -proxyfilter
+} http::ProxyRequired
-test http-1.3 {http_config} {
- catch {http_config -junk}
+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
+test http-1.4 {http::config} {
+ set savedconf [http::config]
+ http::config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
+ set x [http::config]
+ eval http::config $savedconf
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}
+test http-1.5 {http::config} {
+ catch {http::config -proxyhost {} -junk 8080}
} 1
-test http-2.1 {http_reset} {
- catch {http_reset http#1}
+test http-2.1 {http::reset} {
+ catch {http::reset http#1}
} 0
-test http-3.1 {http_get} {
- catch {http_get -bogus flag}
+test http-3.1 {http::geturl} {
+ catch {http::geturl -bogus flag}
} 1
-test http-3.2 {http_get} {
- catch {http_get junk} err
+test http-3.2 {http::geturl} {
+ catch {http::geturl http:junk} err
set err
-} {Unsupported URL: junk}
+} {Unsupported URL: http:junk}
+
+set url [info hostname]:$port
+test http-3.3 {http::geturl} {
+ set token [http::geturl $url]
+ http::data $token
+} "<html><head><title>HTTP/1.0 TEST</title></head><body>
+<h1>Hello, World!</h1>
+<h2>GET /</h2>
+</body></html>"
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
+set binurl [info hostname]:$port/binary
+
+test http-3.4 {http::geturl} {
+ set token [http::geturl $url]
+ http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
@@ -208,37 +237,37 @@ 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
+test http-3.5 {http::geturl} {
+ http::config -proxyfilter selfproxy
+ set token [http::geturl $url]
+ http::config -proxyfilter http::ProxyRequired
+ 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
+test http-3.6 {http::geturl} {
+ http::config -proxyfilter bogus
+ set token [http::geturl $url]
+ http::config -proxyfilter http::ProxyRequired
+ 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
+test http-3.7 {http::geturl} {
+ set token [http::geturl $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
+test http-3.8 {http::geturl} {
+ set token [http::geturl $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>
@@ -249,33 +278,34 @@ test http-3.7 {http_get} {
</dl>
</body></html>"
-test http-3.8 {http_get} {
- set token [http_get $url -validate 1]
- http_code $token
+test http-3.9 {http::geturl} {
+ set token [http::geturl $url -validate 1]
+ http::code $token
} "HTTP/1.0 200 OK"
-test http-4.1 {httpEvent} {
- set token [http_get $url]
+
+test http-4.1 {http::Event} {
+ set token [http::geturl $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]
+test http-4.2 {http::Event} {
+ set token [http::geturl $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
+test http-4.3 {http::Event} {
+ set token [http::geturl $url]
+ http::code $token
} {HTTP/1.0 200 Data follows}
-test http-4.4 {httpEvent} {
+test http-4.4 {http::Event} {
set out [open testfile w]
- set token [http_get $url -channel $out]
+ set token [http::geturl $url -channel $out]
close $out
set in [open testfile]
set x [read $in]
@@ -287,15 +317,27 @@ test http-4.4 {httpEvent} {
<h2>GET $tail</h2>
</body></html>"
-test http-4.5 {httpEvent} {
+test http-4.5 {http::Event} {
set out [open testfile w]
- set token [http_get $url -channel $out]
+ set token [http::geturl $url -channel $out]
close $out
upvar #0 $token data
file delete testfile
expr $data(currentsize) == $data(totalsize)
} 1
+test http-4.6 {http::Event} {
+ set out [open testfile w]
+ set token [http::geturl $binurl -channel $out]
+ close $out
+ set in [open testfile]
+ fconfigure $in -translation binary
+ set x [read $in]
+ close $in
+ file delete testfile
+ set x
+} "$bindata$binurl"
+
proc myProgress {token total current} {
global progress httpLog
if {[info exists httpLog] && $httpLog} {
@@ -306,55 +348,55 @@ proc myProgress {token 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]
+ test http-4.6 {http::Event} {
+ set token [http::geturl $url -blocksize 50 -progress myProgress]
set progress
} {111 111}
}
-test http-4.7 {httpEvent} {
- set token [http_get $url -progress myProgress]
+test http-4.7 {http::Event} {
+ set token [http::geturl $url -progress myProgress]
set progress
} {111 111}
-test http-4.8 {httpEvent} {
- set token [http_get $url]
- http_status $token
+test http-4.8 {http::Event} {
+ set token [http::geturl $url]
+ http::status $token
} {ok}
-test http-4.9 {httpEvent} {
- set token [http_get $url -progress myProgress]
- http_code $token
+test http-4.9 {http::Event} {
+ set token [http::geturl $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
+test http-4.10 {http::Event} {
+ set token [http::geturl $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
+test http-4.11 {http::Event} {
+ set token [http::geturl $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
+test http-4.12 {http::Event} {
+ set token [http::geturl $url -timeout 1 -command {#}]
+ http::wait $token
+ http::status $token
} {timeout}
-test http-5.1 {http_formatQuery} {
- http_formatQuery name1 value1 name2 "value two"
+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
+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"
+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 {}
+test http-6.1 {http::ProxyRequired} {
+ http::config -proxyhost [info hostname] -proxyport $port
+ set token [http::geturl $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>
diff --git a/contrib/tcl/tests/httpold.test b/contrib/tcl/tests/httpold.test
new file mode 100644
index 000000000000..5e9ba0cb1187
--- /dev/null
+++ b/contrib/tcl/tests/httpold.test
@@ -0,0 +1,411 @@
+# 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.12 97/07/29 17:04:12
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+
+if {[catch {package require http 1.0}]} {
+ if {[info exist httpold]} {
+ catch {puts stderr "Cannot load http 1.0 package"}
+ return
+ } else {
+ catch {puts stderr "Running http 1.0 tests in slave interp"}
+ set interp [interp create httpold]
+ $interp eval [list set httpold "running"]
+ $interp eval [list source [info script]]
+ interp delete $interp
+ 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
+ catch {close $sock}
+}
+
+# Respond to the query.
+
+set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
+proc httpdRespond { sock } {
+ global httpd bindata port
+ upvar #0 httpd$sock data
+
+ if {[string match *binary* $data(url)]} {
+ set html "$bindata[info hostname]:$port$data(url)"
+ set type application/octet-stream
+ } else {
+ set type text/html
+
+ 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: $type"
+ 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 ###########################
+
+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 \
+ -useragent "Tcl http client package 1.0"
+ 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 http:junk} err
+ set err
+} {Unsupported URL: http:junk}
+
+set url [info hostname]:$port
+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 /</h2>
+</body></html>"
+
+set tail /a/b/c
+set url [info hostname]:$port/a/b/c
+set binurl [info hostname]:$port/binary
+
+test http-3.4 {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.5 {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.6 {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.7 {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.8 {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.9 {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
+
+test http-4.6 {httpEvent} {
+ set out [open testfile w]
+ set token [http_get $binurl -channel $out]
+ close $out
+ set in [open testfile]
+ fconfigure $in -translation binary
+ set x [read $in]
+ close $in
+ file delete testfile
+ set x
+} "$bindata$binurl"
+
+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} {
+ update
+ 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} {
+ update
+ 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.test b/contrib/tcl/tests/if.test
index 8bc288fb079e..03b8bcd62e8b 100644
--- a/contrib/tcl/tests/if.test
+++ b/contrib/tcl/tests/if.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: @(#) if.test 1.8 97/06/23 18:18:30
+# SCCS: @(#) if.test 1.9 97/07/02 16:40:58
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -27,7 +27,7 @@ test if-1.3 {TclCompileIfCmd: error in if/elseif test} {
} {1 {syntax error in expression "1+"} {syntax error in expression "1+"
("if" test expression)
while compiling
-"if"}}
+"if {1+}"}}
test if-1.4 {TclCompileIfCmd: if/elseif test in braces} {
set a {}
if {1<2} {set a 1}
@@ -65,9 +65,9 @@ test if-1.10 {TclCompileIfCmd: error in "then" body} {
} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
- ("if" body script)
+ ("if" then script line 1)
while compiling
-"if"}}
+"if {$a!="xxx"} then {set}"}}
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}}
@@ -179,7 +179,7 @@ test if-2.4 {TclCompileIfCmd: error in expression after "elseif"} {
} {1 {syntax error in expression "1>"} {syntax error in expression "1>"
("if" test expression)
while compiling
-"if"}}
+"if 3>4 {set a 1} elseif {1>}"}}
test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long "elseif" body} {
catch {unset i}
set a {}
@@ -307,9 +307,9 @@ test if-3.4 {TclCompileIfCmd: error compiling body after "else"} {
} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
- ("if" else script)
+ ("if" else script line 1)
while compiling
-"if"}
+"if 2<1 {set a 1} else {set}"}
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
diff --git a/contrib/tcl/tests/incr.test b/contrib/tcl/tests/incr.test
index 30db386f38bc..e187d41d0ac3 100644
--- a/contrib/tcl/tests/incr.test
+++ b/contrib/tcl/tests/incr.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: @(#) incr.test 1.8 97/06/20 16:53:28
+# SCCS: @(#) incr.test 1.9 97/07/02 16:41:32
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -177,9 +177,9 @@ test incr-1.19 {TclCompileIncrCmd: increment given, but erroneous} {
} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
- (reading increment)
+ (increment expression)
while compiling
-"incr"}
+"incr i [set]"}
test incr-1.20 {TclCompileIncrCmd: increment given, in quotes} {
set i 25
incr i "-100"
@@ -221,7 +221,7 @@ test incr-1.27 {TclCompileIncrCmd: runtime error, bad variable name} {
while compiling
"set"
while compiling
-"incr"}}
+"incr [set]"}}
test incr-1.28 {TclCompileIncrCmd: runtime error, readonly variable} {
proc readonly args {error "variable is read-only"}
set x 123
diff --git a/contrib/tcl/tests/info.test b/contrib/tcl/tests/info.test
index 7e7a22645ddb..784dad102fb0 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.38 97/05/20 16:35:54
+# SCCS: @(#) info.test 1.39 97/08/01 11:10:24
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -487,25 +487,30 @@ test info-15.3 {info procs option} {
list [catch {info procs 2 3} msg] $msg
} {1 {wrong # args: should be "info procs ?pattern?"}}
+set self info.test
+if {$tcl_platform(os) == "Win32s"} {
+ set self info~1.tes
+}
+
test info-16.1 {info script option} {
list [catch {info script x} msg] $msg
} {1 {wrong # args: should be "info script"}}
test info-16.2 {info script option} {
file tail [info sc]
-} info.test
+} $self
removeFile gorp.info
makeFile "info script\n" gorp.info
test info-16.3 {info script option} {
list [source gorp.info] [file tail [info script]]
-} {gorp.info info.test}
+} [list gorp.info $self]
test info-16.4 {resetting "info script" after errors} {
catch {source ~_nobody_/foo}
file tail [info script]
-} {info.test}
+} $self
test info-16.5 {resetting "info script" after errors} {
catch {source _nonexistent_}
file tail [info script]
-} {info.test}
+} $self
removeFile gorp.info
test info-17.1 {info sharedlibextension option} {
diff --git a/contrib/tcl/tests/interp.test b/contrib/tcl/tests/interp.test
index 85aee328e222..9127bcb54bcf 100644
--- a/contrib/tcl/tests/interp.test
+++ b/contrib/tcl/tests/interp.test
@@ -9,16 +9,16 @@
# 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.52 97/06/23 17:29:50
+# SCCS: @(#) interp.test 1.61 97/08/04 19:59:52
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}
+ set hidden_cmds {beep cd echo exit fconfigure file glob load ls open pwd socket source}
} else {
- set hidden_cmds {cd exec exit fconfigure file glob load open pwd socket source vwait}
+ set hidden_cmds {cd exec exit fconfigure file glob load open pwd socket source}
}
foreach i [interp slaves] {
@@ -95,7 +95,27 @@ test interp-2.10 {basic interpreter creation} {
interp create {a x2}
interp create {a x3} -safe
} {a x3}
-
+test interp-2.11 {anonymous interps vs existing procs} {
+ set x [interp create]
+ regexp "interp(\[0-9]+)" $x dummy thenum
+ interp delete $x
+ incr thenum
+ proc interp$thenum {} {}
+ set x [interp create]
+ regexp "interp(\[0-9]+)" $x dummy anothernum
+ expr $anothernum - $thenum
+} 1
+test interp-2.12 {anonymous interps vs existing procs} {
+ set x [interp create -safe]
+ regexp "interp(\[0-9]+)" $x dummy thenum
+ interp delete $x
+ incr thenum
+ proc interp$thenum {} {}
+ set x [interp create -safe]
+ regexp "interp(\[0-9]+)" $x dummy anothernum
+ expr $anothernum - $thenum
+} 1
+
foreach i [interp slaves] {
interp delete $i
}
@@ -362,6 +382,17 @@ test interp-11.5 {testing interp target} {
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}}
+test interp-11.6 {testing interp target} {
+ foreach a [interp aliases] {
+ rename $a {}
+ }
+ list [catch {interp target {} foo} msg] $msg
+} {1 {alias "foo" in path "" not found}}
+test interp-11.7 {testing interp target} {
+ catch {interp delete a}
+ interp create a
+ list [catch {interp target a foo} msg] $msg
+} {1 {alias "foo" in path "a" not found}}
# Part 11: testing "interp issafe"
test interp-12.1 {testing interp issafe} {
@@ -555,9 +586,8 @@ test interp-16.5 {testing deletion order, bgerror} {
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
+ after 200
+ update
interp exists xxx
} 0
@@ -1405,6 +1435,49 @@ test interp-20.44 {invokehidden at global level} {
interp delete a
list $r $msg
} {0 91}
+test interp-20.45 {interp hide vs namespaces} {
+ catch {interp delete a}
+ interp create a
+ a eval {
+ namespace eval foo {}
+ proc foo::x {} {}
+ }
+ set l [list [catch {interp hide a foo::x} msg] $msg]
+ interp delete a
+ set l
+} {1 {cannot use namespace qualifiers as hidden commandtoken (rename)}}
+test interp-20.46 {interp hide vs namespaces} {
+ catch {interp delete a}
+ interp create a
+ a eval {
+ namespace eval foo {}
+ proc foo::x {} {}
+ }
+ set l [list [catch {interp hide a foo::x x} msg] $msg]
+ interp delete a
+ set l
+} {1 {can only hide global namespace commands (use rename then hide)}}
+test interp-20.47 {interp hide vs namespaces} {
+ catch {interp delete a}
+ interp create a
+ a eval {
+ proc x {} {}
+ }
+ set l [list [catch {interp hide a x foo::x} msg] $msg]
+ interp delete a
+ set l
+} {1 {cannot use namespace qualifiers as hidden commandtoken (rename)}}
+test interp-20.48 {interp hide vs namespaces} {
+ catch {interp delete a}
+ interp create a
+ a eval {
+ namespace eval foo {}
+ proc foo::x {} {}
+ }
+ set l [list [catch {interp hide a foo::x bar::x} msg] $msg]
+ interp delete a
+ set l
+} {1 {cannot use namespace qualifiers as hidden commandtoken (rename)}}
test interp-21.1 {interp hidden} {
interp hidden {}
@@ -1605,7 +1678,7 @@ test interp-23.2 {testing hiding vs aliases} {pc || unix} {
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}}
+} {{cd exec exit fconfigure file glob load open pwd socket source} bar {cd exec exit fconfigure file glob load open pwd socket source} bar {bar cd exec exit fconfigure file glob load open pwd socket source} {} {cd exec exit fconfigure file glob load open pwd socket source}}
test interp-23.3 {testing hiding vs aliases} {macOnly} {
catch {interp delete a}
@@ -1623,7 +1696,7 @@ test interp-23.3 {testing hiding vs aliases} {macOnly} {
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}}
+} {{beep cd echo exit fconfigure file glob load ls open pwd socket source} bar {beep cd echo exit fconfigure file glob load ls open pwd socket source} bar {bar beep cd echo exit fconfigure file glob load ls open pwd socket source} {} {beep cd echo exit fconfigure file glob load ls open pwd socket source}}
test interp-24.1 {result resetting on error} {
catch {interp delete a}
@@ -1855,6 +1928,238 @@ test interp-25.1 {testing aliasing of string commands} {
interp delete a
} ""
+
+# Interps result transmission
+test interp-26.1 {result code transmission 1} {knownBug} {
+ # This test currently fails ! (only ok/error are passed, not the other
+ # codes). Fixing the code is thus needed... -- dl
+ # (the only other acceptable result list would be
+ # {-1 0 1 0 3 4 5} because of the way return -code return(=2) works)
+ # test that all the possibles error codes from Tcl get passed
+ catch {interp delete a}
+ interp create a
+ interp eval a {proc ret {code} {return -code $code $code}}
+ set res {}
+ # use a for so if a return -code break 'escapes' we would notice
+ for {set code -1} {$code<=5} {incr code} {
+ lappend res [catch {interp eval a ret $code} msg]
+ }
+ interp delete a
+ set res
+} {-1 0 1 2 3 4 5}
+
+test interp-26.2 {result code transmission 2} {knownBug} {
+ # This test currently fails ! (error is cleared)
+ # Code fixing is needed... -- dl
+ # (the only other acceptable result list would be
+ # {-1 0 1 0 3 4 5} because of the way return -code return(=2) works)
+ # test that all the possibles error codes from Tcl get passed
+ set interp [interp create];
+ proc MyTestAlias {interp args} {
+ global aliasTrace;
+ lappend aliasTrace $args;
+ eval interp invokehidden [list $interp] $args
+ }
+ foreach c {return} {
+ interp hide $interp $c;
+ interp alias $interp $c {} MyTestAlias $interp $c;
+ }
+ interp eval $interp {proc ret {code} {return -code $code $code}}
+ set res {}
+ set aliasTrace {}
+ for {set code -1} {$code<=5} {incr code} {
+ lappend res [catch {interp eval $interp ret $code} msg]
+ }
+ interp delete $interp;
+ list $res
+} {-1 0 1 2 3 4 5}
+
+
+# Interps & Namespaces
+test interp-27.1 {interp aliases & namespaces} {
+ set i [interp create];
+ set aliasTrace {};
+ proc tstAlias {args} {
+ global aliasTrace;
+ lappend aliasTrace [list [namespace current] $args];
+ }
+ $i alias foo::bar tstAlias foo::bar;
+ $i eval foo::bar test
+ interp delete $i
+ set aliasTrace;
+} {{:: {foo::bar test}}}
+
+test interp-27.2 {interp aliases & namespaces} {
+ set i [interp create];
+ set aliasTrace {};
+ proc tstAlias {args} {
+ global aliasTrace;
+ lappend aliasTrace [list [namespace current] $args];
+ }
+ $i alias foo::bar tstAlias foo::bar;
+ $i eval namespace eval foo {bar test}
+ interp delete $i
+ set aliasTrace;
+} {{:: {foo::bar test}}}
+
+test interp-27.3 {interp aliases & namespaces} {
+ set i [interp create];
+ set aliasTrace {};
+ proc tstAlias {args} {
+ global aliasTrace;
+ lappend aliasTrace [list [namespace current] $args];
+ }
+ interp eval $i {namespace eval foo {proc bar {} {error "bar called"}}}
+ interp alias $i foo::bar {} tstAlias foo::bar;
+ interp eval $i {namespace eval foo {bar test}}
+ interp delete $i
+ set aliasTrace;
+} {{:: {foo::bar test}}}
+
+test interp-27.4 {interp aliases & namespaces} {
+ set i [interp create];
+ namespace eval foo2 {
+ variable aliasTrace {};
+ proc bar {args} {
+ variable aliasTrace;
+ lappend aliasTrace [list [namespace current] $args];
+ }
+ }
+ $i alias foo::bar foo2::bar foo::bar;
+ $i eval namespace eval foo {bar test}
+ set r $foo2::aliasTrace;
+ namespace delete foo2;
+ set r
+} {{::foo2 {foo::bar test}}}
+
+# the following tests are commented out while we don't support
+# hiding in namespaces
+
+# test interp-27.5 {interp hidden & namespaces} {
+# set i [interp create];
+# interp eval $i {
+# namespace eval foo {
+# proc bar {args} {
+# return "bar called ([namespace current]) ($args)"
+# }
+# }
+# }
+# set res [list [interp eval $i {namespace eval foo {bar test1}}]]
+# interp hide $i foo::bar;
+# lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg]
+# interp delete $i;
+# set res;
+#} {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}}
+
+# test interp-27.6 {interp hidden & aliases & namespaces} {
+# set i [interp create];
+# set v root-master;
+# namespace eval foo {
+# variable v foo-master;
+# proc bar {interp args} {
+# variable v;
+# list "master bar called ($v) ([namespace current]) ($args)"\
+# [interp invokehidden $interp foo::bar $args];
+# }
+# }
+# interp eval $i {
+# namespace eval foo {
+# namespace export *
+# variable v foo-slave;
+# proc bar {args} {
+# variable v;
+# return "slave bar called ($v) ([namespace current]) ($args)"
+# }
+# }
+# }
+# set res [list [interp eval $i {namespace eval foo {bar test1}}]]
+# $i hide foo::bar;
+# $i alias foo::bar foo::bar $i;
+# set res [concat $res [interp eval $i {
+# set v root-slave;
+# namespace eval test {
+# variable v foo-test;
+# namespace import ::foo::*;
+# bar test2
+# }
+# }]]
+# namespace delete foo;
+# interp delete $i;
+# set res
+# } {{slave bar called (foo-slave) (::foo) (test1)} {master bar called (foo-master) (::foo) (test2)} {slave bar called (foo-slave) (::foo) (test2)}}
+
+
+# test interp-27.7 {interp hidden & aliases & imports & namespaces} {
+# set i [interp create];
+# set v root-master;
+# namespace eval mfoo {
+# variable v foo-master;
+# proc bar {interp args} {
+# variable v;
+# list "master bar called ($v) ([namespace current]) ($args)"\
+# [interp invokehidden $interp test::bar $args];
+# }
+# }
+# interp eval $i {
+# namespace eval foo {
+# namespace export *
+# variable v foo-slave;
+# proc bar {args} {
+# variable v;
+# return "slave bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)"
+# }
+# }
+# set v root-slave;
+# namespace eval test {
+# variable v foo-test;
+# namespace import ::foo::*;
+# }
+# }
+# set res [list [interp eval $i {namespace eval test {bar test1}}]]
+# $i hide test::bar;
+# $i alias test::bar mfoo::bar $i;
+# set res [concat $res [interp eval $i {test::bar test2}]];
+# namespace delete mfoo;
+# interp delete $i;
+# set res
+# } {{slave bar called (foo-slave) (bar test1) (::test) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}}
+
+#test interp-27.8 {hiding, namespaces and integrity} {
+# namespace eval foo {
+# variable v 3;
+# proc bar {} {variable v; set v}
+# # next command would currently generate an unknown command "bar" error.
+# interp hide {} bar;
+# }
+# namespace delete foo;
+# list [catch {interp invokehidden {} foo} msg] $msg;
+#} {1 {invalid hidden command name "foo"}}
+
+
+test interp-28.1 {getting fooled by slave's namespace ?} {
+ set i [interp create -safe];
+ proc master {interp args} {interp hide $interp list}
+ $i alias master master $i;
+ set r [interp eval $i {
+ namespace eval foo {
+ proc list {args} {
+ return "dummy foo::list";
+ }
+ master;
+ }
+ info commands list
+ }]
+ interp delete $i;
+ set r
+} {}
+
+# more tests needed...
+
+# Interp & stack
+#test interp-29.1 {interp and stack (info level)} {
+#} {}
+
+
foreach i [interp slaves] {
interp delete $i
}
diff --git a/contrib/tcl/tests/io.test b/contrib/tcl/tests/io.test
index c83033b4a1a8..739248281a6d 100644
--- a/contrib/tcl/tests/io.test
+++ b/contrib/tcl/tests/io.test
@@ -6,12 +6,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-1996 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: @(#) io.test 1.119 97/06/23 18:47:01
+# SCCS: @(#) io.test 1.128 97/08/13 10:24:56
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -24,13 +24,6 @@ if {"[info commands testchannel]" != "testchannel"} {
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]
@@ -42,6 +35,28 @@ for { set i 0 } { $i < 100 } { incr i} {
}
close $f
+set f [open cat w]
+puts $f {
+ if {$argv == {}} {
+ set argv -
+ }
+ foreach name $argv {
+ if {$name == "-"} {
+ set f stdin
+ } elseif {[catch {open $name r} f] != 0} {
+ puts stderr $f
+ continue
+ }
+ while {[eof $f] == 0} {
+ puts -nonewline stdout [read $f]
+ }
+ if {$f != "stdin"} {
+ close $f
+ }
+ }
+}
+close $f
+
# These tests are disabled until we decide what to do with "unsupported0".
#
#test io-1.7 {unsupported0 command} {
@@ -51,7 +66,7 @@ close $f
# unsupported0 $f1 $f2
# close $f1
# catch {close $f2}
-# set s1 [file size io.test]
+# set s1 [file size [info script]]
# set s2 [file size test1]
# set x ok
# if {"$s1" != "$s2"} {
@@ -61,7 +76,7 @@ close $f
#} ok
#test io-1.8 {unsupported0 command} {
# removeFile test1
-# set f1 [open io.test]
+# set f1 [open [info script]]
# set f2 [open test1 w]
# unsupported0 $f1 $f2 40
# close $f1
@@ -70,13 +85,13 @@ close $f
#} 40
#test io-1.9 {unsupported0 command} {
# removeFile test1
-# set f1 [open io.test]
+# set f1 [open [info script]]
# set f2 [open test1 w]
# unsupported0 $f1 $f2 -1
# close $f1
# close $f2
# set x ok
-# set s1 [file size io.test]
+# set s1 [file size [info script]]
# set s2 [file size test1]
# if {$s1 != $s2} {
# set x broken
@@ -89,11 +104,11 @@ close $f
# set f1 [open pipe w]
# puts $f1 {puts ready}
# puts $f1 {gets stdin}
-# puts $f1 {set f1 [open io.test r]}
+# puts $f1 {set f1 [open [info script] r]}
# puts $f1 {puts [read $f1 100]}
# puts $f1 {close $f1}
# close $f1
-# set f1 [open "|$tcltest pipe" r+]
+# set f1 [open "|[list $tcltest pipe]" r+]
# gets $f1
# puts $f1 ready
# flush $f1
@@ -135,7 +150,7 @@ test io-1.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} {
interp delete x
set l
} {line line none}
-test io-1.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOrPc} {
+test io-1.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {stdio} {
set f [open test1 w]
puts $f {
close stdin
@@ -152,7 +167,7 @@ test io-1.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOrPc} {
close $f3
}
close $f
- set result [eval exec $tcltest test1]
+ set result [exec $tcltest test1]
set f [open test2 r]
set f2 [open test3 r]
lappend result [read $f] [read $f2]
@@ -180,7 +195,7 @@ test io-1.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOnly} {
close $f3
}
close $f
- set result [eval exec $tcltest test1]
+ set result [exec $tcltest test1]
set f [open test2 r]
set f2 [open test3 r]
lappend result [read $f] [read $f2]
@@ -235,12 +250,12 @@ test io-1.8 {reuse of stdio special channels} {unixOnly} {
puts [gets $f]
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
set c [gets $f]
close $f
set c
} hello
-test io-1.9 {reuse of stdio special channels} {unixOnly} {
+test io-1.9 {reuse of stdio special channels} {stdio} {
removeFile script
removeFile test1
set f [open script w]
@@ -249,11 +264,11 @@ test io-1.9 {reuse of stdio special channels} {unixOnly} {
puts $f hello
close $f
close stderr
- set f [open "|cat test1" r]
+ set f [open "|[list [info nameofexecutable] cat test1]" r]
puts [gets $f]
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
set c [gets $f]
close $f
set c
@@ -500,7 +515,7 @@ test io-4.5 {FlushChannel, implicit flush when buffer fills and on close} {unixO
lappend l [file size test1]
set l
} {0 60 72}
-test io-4.6 {FlushChannel, async flushing, async close} {unixOrPc asyncPipeClose} {
+test io-4.6 {FlushChannel, async flushing, async close} {stdio && asyncPipeClose} {
removeFile pipe
removeFile output
set f [open pipe w]
@@ -520,7 +535,7 @@ test io-4.6 {FlushChannel, async flushing, async close} {unixOrPc asyncPipeClose
}
set f [open output w]
close $f
- set f [open "|$tcltest pipe" w]
+ set f [open "|[list $tcltest pipe]" w]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
@@ -567,7 +582,7 @@ test io-5.2 {CloseChannel called when all references are dropped} {
close $f
set l
} abcdef
-test io-5.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 nonPortable tempNotPc} {
removeFile pipe
removeFile output
set f [open pipe w]
@@ -595,8 +610,12 @@ test io-5.3 {CloseChannel, not called before output queue is empty} {unixOrPc as
}
set f [open output w]
close $f
- set f [open "|$tcltest pipe" r+]
+ set f [open "|[list $tcltest pipe]" r+]
fconfigure $f -blocking off -eofchar {}
+
+ # Under windows, the first 24576 bytes of $x are copied to $f, and
+ # then the writing fails.
+
puts -nonewline $f $x
close $f
set counter 0
@@ -632,7 +651,7 @@ test io-5.5 {Tcl_Close vs standard handles} {unixOnly} {
puts [testchannel open]
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
set l [gets $f]
close $f
set l
@@ -766,7 +785,7 @@ test io-6.11 {Tcl_Write, no newline, implicit flush} {
close $f2
file size test1
} 377
-test io-6.12 {Tcl_Write on a pipe} {unixOrPc} {
+test io-6.12 {Tcl_Write on a pipe} {stdio} {
removeFile test1
removeFile pipe
set f1 [open pipe w]
@@ -777,7 +796,7 @@ test io-6.12 {Tcl_Write on a pipe} {unixOrPc} {
}
}
close $f1
- set f1 [open "|$tcltest pipe" r]
+ set f1 [open "|[list $tcltest pipe]" r]
set f2 [open longfile r]
set y ok
for {set x 0} {$x < 10} {incr x} {
@@ -791,7 +810,7 @@ test io-6.12 {Tcl_Write on a pipe} {unixOrPc} {
close $f2
set y
} ok
-test io-6.13 {Tcl_Write to a pipe, line buffered} {unixOrPc} {
+test io-6.13 {Tcl_Write to a pipe, line buffered} {stdio} {
removeFile test1
removeFile pipe
set f1 [open pipe w]
@@ -801,7 +820,7 @@ test io-6.13 {Tcl_Write to a pipe, line buffered} {unixOrPc} {
}
close $f1
set y ok
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
fconfigure $f1 -buffering line
set f2 [open longfile r]
set line [gets $f2]
@@ -842,8 +861,8 @@ test io-6.15 {Tcl_Flush, channel not open for writing} {
string compare $x \
[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
-test io-6.16 {Tcl_Flush on pipe opened only for reading} {unixOrPc unixExecs} {
- set fd [open "|cat longfile" r]
+test io-6.16 {Tcl_Flush on pipe opened only for reading} {stdio} {
+ set fd [open "|[list $tcltest cat longfile]" r]
set x [list [catch {flush $fd} msg] $msg]
catch {close $fd}
string compare $x \
@@ -916,21 +935,21 @@ test io-6.20 {Implicit flush when buffer is full} {
lappend z [file size test1]
set z
} {4096 12288 12600}
-test io-6.21 {Tcl_Flush to pipe} {unixOrPc} {
+test io-6.21 {Tcl_Flush to pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {set x [read stdin 6]}
puts $f1 {set cnt [string length $x]}
puts $f1 {puts "read $cnt characters"}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
puts $f1 hello
flush $f1
set x [gets $f1]
catch {close $f1}
set x
} "read 6 characters"
-test io-6.22 {Tcl_Flush called at other end of pipe} {unixOrPc} {
+test io-6.22 {Tcl_Flush called at other end of pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {
@@ -943,7 +962,7 @@ test io-6.22 {Tcl_Flush called at other end of pipe} {unixOrPc} {
flush stdout
}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
set x ""
lappend x [gets $f1]
lappend x [gets $f1]
@@ -953,7 +972,7 @@ test io-6.22 {Tcl_Flush called at other end of pipe} {unixOrPc} {
close $f1
set x
} {hello hello bye}
-test io-6.23 {Tcl_Flush and line buffering at end of pipe} {unixOrPc} {
+test io-6.23 {Tcl_Flush and line buffering at end of pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {
@@ -963,7 +982,7 @@ test io-6.23 {Tcl_Flush and line buffering at end of pipe} {unixOrPc} {
puts bye
}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
set x ""
lappend x [gets $f1]
lappend x [gets $f1]
@@ -989,9 +1008,9 @@ test io-6.24 {Tcl_Write and Tcl_Flush move end of file} {
set x
} {{} {Line 1
Line 2}}
-test io-6.25 {Implicit flush with Tcl_Flush to command pipelines} {unixOrPc unixExecs} {
+test io-6.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio} {
removeFile test3
- set f [open "| cat | cat > test3" w]
+ set f [open "|[list $tcltest cat | $tcltest cat > test3]" w]
puts $f "Line 1"
puts $f "Line 2"
close $f
@@ -1003,20 +1022,20 @@ test io-6.25 {Implicit flush with Tcl_Flush to command pipelines} {unixOrPc unix
} {Line 1
Line 2
}
-test io-6.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {unixOrPc unixExecs} {
- set f [open "| cat -u" r+]
+test io-6.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {unixOrPc && unixExecs && tempNotPc} {
+ set f [open "|[list cat -u]" r+]
puts $f "Line1"
flush $f
set x [gets $f]
close $f
set x
} {Line1}
-test io-6.27 {Tcl_Flush on closed pipeline} {unixOrPc tempNotPc} {
+test io-6.27 {Tcl_Flush on closed pipeline} {stdio && tempNotPc} {
removeFile pipe
set f [open pipe w]
puts $f {exit}
close $f
- set f [open "|$tcltest pipe" r+]
+ set f [open "|[list $tcltest pipe]" r+]
gets $f
puts $f output
after 50
@@ -1065,7 +1084,7 @@ test io-6.30 {Tcl_Write, crlf mode} {
close $f
file size test1
} 25
-test io-6.31 {Tcl_Write, background flush} {unixOrPc} {
+test io-6.31 {Tcl_Write, background flush} {stdio} {
removeFile pipe
removeFile output
set f [open pipe w]
@@ -1085,7 +1104,7 @@ test io-6.31 {Tcl_Write, background flush} {unixOrPc} {
}
set f [open output w]
close $f
- set f [open "|$tcltest pipe" r+]
+ set f [open "|[list $tcltest pipe]" r+]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
@@ -1101,7 +1120,7 @@ test io-6.31 {Tcl_Write, background flush} {unixOrPc} {
set result ok
}
} ok
-test io-6.32 {Tcl_Write, background flush to slow reader} {unixOrPc asyncPipeClose} {
+test io-6.32 {Tcl_Write, background flush to slow reader} {stdio && asyncPipeClose} {
removeFile pipe
removeFile output
set f [open pipe w]
@@ -1122,7 +1141,7 @@ test io-6.32 {Tcl_Write, background flush to slow reader} {unixOrPc asyncPipeClo
}
set f [open output w]
close $f
- set f [open "|$tcltest pipe" r+]
+ set f [open "|[list $tcltest pipe]" r+]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
@@ -1138,7 +1157,7 @@ test io-6.32 {Tcl_Write, background flush to slow reader} {unixOrPc asyncPipeClo
set result ok
}
} ok
-test io-6.33 {Tcl_Flush, implicit flush on exit} {unixOrPc} {
+test io-6.33 {Tcl_Flush, implicit flush on exit} {stdio} {
set f [open script w]
puts $f {
set f [open test1 w]
@@ -1148,7 +1167,7 @@ test io-6.33 {Tcl_Flush, implicit flush on exit} {unixOrPc} {
puts $f strange
}
close $f
- eval exec $tcltest script
+ exec $tcltest script
set f [open test1 r]
set r [read $f]
close $f
@@ -1158,7 +1177,7 @@ bye
strange
}
-test io-6.34 {Tcl_Close, async flush on close, using sockets} {tempNotMac} {
+test io-6.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac} {
set c 0
set x running
set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
@@ -1194,7 +1213,7 @@ test io-6.34 {Tcl_Close, async flush on close, using sockets} {tempNotMac} {
vwait x
set c
} 2000
-test io-6.35 {Tcl_Close vs fileevent vs multiple interpreters} {
+test io-6.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket} {
catch {interp delete x}
catch {interp delete y}
interp create x
@@ -2345,25 +2364,25 @@ test io-9.9 {Tcl_Read, read to end of file} {
}
set x
} ok
-test io-9.10 {Tcl_Read from a pipe} {unixOrPc} {
+test io-9.10 {Tcl_Read from a pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {puts [gets stdin]}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
puts $f1 hello
flush $f1
set x [read $f1]
close $f1
set x
} "hello\n"
-test io-9.11 {Tcl_Read from a pipe} {unixOrPc} {
+test io-9.11 {Tcl_Read from a pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {puts [gets stdin]}
puts $f1 {puts [gets stdin]}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
puts $f1 hello
flush $f1
set x ""
@@ -2467,12 +2486,12 @@ test io-10.2 {Tcl_Gets into variable} {
close $f1
set z
} ok
-test io-10.3 {Tcl_Gets from pipe} {unixOrPc} {
+test io-10.3 {Tcl_Gets from pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {puts [gets stdin]}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
puts $f1 hello
flush $f1
set x [gets $f1]
@@ -2664,8 +2683,8 @@ test io-11.7 {Tcl_Seek to offset from end of file, then to current position} {
close $f1
list $c1 $r1 $c2
} {44 rstuv 49}
-test io-11.8 {Tcl_Seek on pipes: not supported} {unixOrPc} {
- set f1 [open "|$tcltest" r+]
+test io-11.8 {Tcl_Seek on pipes: not supported} {stdio} {
+ set f1 [open "|[list $tcltest]" r+]
set x [list [catch {seek $f1 0 current} msg] $msg]
close $f1
regsub {".*":} $x {"":} x
@@ -2771,14 +2790,14 @@ test io-11.15 {Tcl_Tell combined with seeking} {
close $f1
list $c1 $c2
} {10 20}
-test io-11.16 {Tcl_tell on pipe: always -1} {unixOrPc} {
- set f1 [open "|$tcltest" r+]
+test io-11.16 {Tcl_tell on pipe: always -1} {stdio} {
+ set f1 [open "|[list $tcltest]" r+]
set c [tell $f1]
close $f1
set c
} -1
-test io-11.17 {Tcl_Tell on pipe: always -1} {unixOrPc} {
- set f1 [open "|$tcltest" r+]
+test io-11.17 {Tcl_Tell on pipe: always -1} {stdio} {
+ set f1 [open "|[list $tcltest]" r+]
puts $f1 {puts hello}
flush $f1
set c [tell $f1]
@@ -2854,13 +2873,13 @@ test io-12.1 {Tcl_Eof} {
close $f
set x
} {0 0 0 0 1 1}
-test io-12.2 {Tcl_Eof with pipe} {unixOrPc} {
+test io-12.2 {Tcl_Eof with pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
puts $f1 hello
set x [eof $f1]
flush $f1
@@ -2872,13 +2891,13 @@ test io-12.2 {Tcl_Eof with pipe} {unixOrPc} {
close $f1
set x
} {0 0 0 1}
-test io-12.3 {Tcl_Eof with pipe} {unixOrPc} {
+test io-12.3 {Tcl_Eof with pipe} {stdio} {
removeFile pipe
set f1 [open pipe w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
puts $f1 hello
set x [eof $f1]
flush $f1
@@ -2906,14 +2925,14 @@ test io-12.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} {
close $f
set l
} {{} 1}
-test io-12.5 {Tcl_Eof, eof detection on nonblocking pipe} {unixOrPc} {
+test io-12.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio} {
removeFile pipe
set f [open pipe w]
puts $f {
exit
}
close $f
- set f [open "|$tcltest pipe" r]
+ set f [open "|[list $tcltest pipe]" r]
set l ""
lappend l [gets $f]
lappend l [eof $f]
@@ -3098,7 +3117,7 @@ test io-12.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} {
# Test Tcl_InputBlocked
test io-13.1 {Tcl_InputBlocked on nonblocking pipe} {unixOrPc tempNotPc} {
- set f1 [open "|$tcltest" r+]
+ set f1 [open "|[list $tcltest]" r+]
puts $f1 {puts hello_from_pipe}
flush $f1
gets $f1
@@ -3117,7 +3136,7 @@ test io-13.1 {Tcl_InputBlocked on nonblocking pipe} {unixOrPc tempNotPc} {
set x
} {{} 1 hello 0 {} 1}
test io-13.2 {Tcl_InputBlocked on blocking pipe} {unixOrPc tempNotPc} {
- set f1 [open "|$tcltest" r+]
+ set f1 [open "|[list $tcltest]" r+]
fconfigure $f1 -buffering line
puts $f1 {puts hello_from_pipe}
set x ""
@@ -3375,7 +3394,7 @@ test io-16.10 {Tcl_SetChannelOption, blocking mode} {unixOrPc tempNotPc} {
puts $f1 {gets stdin}
close $f1
set x ""
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
fconfigure $f1 -blocking off -buffering line
lappend x [fconfigure $f1 -blocking]
lappend x [gets $f1]
@@ -3448,7 +3467,7 @@ test io-17.2 {POSIX open access modes: CREAT} {unixOnly} {
close $f
set x
} {0600 {line 1}}
-test io-17.3 {POSIX open access modes: CREAT} {unixOnly nonPortable umask2} {
+test io-17.3 {POSIX open access modes: CREAT} {$testConfig(unix) && ([exec umask] == 2)} {
# This test only works if your umask is 2, like ouster's.
removeFile test3
set f [open test3 {WRONLY CREAT}]
@@ -3639,8 +3658,8 @@ test io-19.2 {Tcl_FileeventCmd: replacing} {
if {($tcl_platform(platform) != "macintosh") && \
($testConfig(unixExecs) == 1)} {
-catch {set f2 [open {|cat -u} r+]}
-catch {set f3 [open {|cat -u} r+]}
+catch {set f2 [open "|[list cat -u]" r+]}
+catch {set f3 [open "|[list cat -u]" r+]}
test io-20.1 {Tcl_FileeventCmd: creating, deleting, querying} {
set result {}
@@ -3715,8 +3734,8 @@ test io-21.4 {FileEventProc procedure: eror in write event} {
rename bgerror {}
list $x [fileevent $f2 writable]
} {bad-write {}}
-test io-21.5 {FileEventProc procedure: end of file} {unixOrPc unixExecs} {
- set f4 [open {|cat << foo} r]
+test io-21.5 {FileEventProc procedure: end of file} {unixOrPc} {
+ set f4 [open "|[list $tcltest cat << foo]" r]
fileevent $f4 readable {
if {[gets $f4 line] < 0} {
lappend x eof
@@ -4012,7 +4031,7 @@ test io-25.3 {testing readability conditions} {unixOnly nonBlockFiles} {
}
}
close $f
- set f [open |$tcltest r+]
+ set f [open "|[list $tcltest]" r+]
fileevent $f readable [list consume $f]
fconfigure $f -buffering line
fconfigure $f -blocking off
@@ -4610,7 +4629,7 @@ 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} {
+test io-28.1 {Test old socket deletion on Macintosh} {socket} {
set x 0
set result ""
proc accept {s a p} {
@@ -4650,7 +4669,7 @@ test io-28.1 {Test old socket deletion on Macintosh} {tempNotMac} {
test io-29.1 {TclCopyChannel} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
fcopy $f1 $f2 -command { # }
catch { fcopy $f1 $f2 } msg
@@ -4660,9 +4679,9 @@ test io-29.1 {TclCopyChannel} {
} {0}
test io-29.2 {TclCopyChannel} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
- set f3 [open io.test]
+ set f3 [open [info script]]
fcopy $f1 $f2 -command { # }
catch { fcopy $f3 $f2 } msg
close $f1
@@ -4672,7 +4691,7 @@ test io-29.2 {TclCopyChannel} {
} {0}
test io-29.3 {TclCopyChannel} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
@@ -4680,7 +4699,7 @@ test io-29.3 {TclCopyChannel} {
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
- set s1 [file size io.test]
+ set s1 [file size [info script]]
set s2 [file size test1]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
@@ -4689,7 +4708,7 @@ test io-29.3 {TclCopyChannel} {
} {0 0 ok}
test io-29.4 {TclCopyChannel} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
@@ -4701,7 +4720,7 @@ test io-29.4 {TclCopyChannel} {
} {0 0 40}
test io-29.5 {TclCopyChannel} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
@@ -4709,7 +4728,7 @@ test io-29.5 {TclCopyChannel} {
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
- set s1 [file size io.test]
+ set s1 [file size [info script]]
set s2 [file size test1]
if {"$s1" == "$s2"} {
lappend result ok
@@ -4718,15 +4737,15 @@ test io-29.5 {TclCopyChannel} {
} {0 0 ok}
test io-29.6 {TclCopyChannel} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
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 s0 [fcopy $f1 $f2 -size [expr [file size [info script]] + 5]]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
- set s1 [file size io.test]
+ set s1 [file size [info script]]
set s2 [file size test1]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
@@ -4735,13 +4754,13 @@ test io-29.6 {TclCopyChannel} {
} {0 0 ok}
test io-29.7 {TclCopyChannel} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
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 s1 [file size [info script]]
set s2 [file size test1]
close $f1
close $f2
@@ -4750,23 +4769,27 @@ test io-29.7 {TclCopyChannel} {
}
set result
} {0 0 ok}
-test io-29.8 {TclCopyChannel} {unixOrPc} {
+test io-29.8 {TclCopyChannel} {stdio} {
removeFile test1
removeFile pipe
set f1 [open pipe w]
+ fconfigure $f1 -translation lf
puts $f1 {
puts ready
gets stdin
- set f1 [open io.test r]
+ set f1 [open [info script] r]
+ fconfigure $f1 -translation lf
puts [read $f1 100]
close $f1
}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
+ fconfigure $f1 -translation lf
gets $f1
puts $f1 ready
flush $f1
set f2 [open test1 w]
+ fconfigure $f2 -translation lf
set s0 [fcopy $f1 $f2 -size 40]
catch {close $f1}
close $f2
@@ -4775,7 +4798,7 @@ test io-29.8 {TclCopyChannel} {unixOrPc} {
test io-30.1 {CopyData} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
@@ -4787,7 +4810,7 @@ test io-30.1 {CopyData} {
} {0 0 0}
test io-30.2 {CopyData} {
removeFile test1
- set f1 [open io.test]
+ set f1 [open [info script]]
set f2 [open test1 w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
@@ -4796,7 +4819,7 @@ test io-30.2 {CopyData} {
vwait s0
close $f1
close $f2
- set s1 [file size io.test]
+ set s1 [file size [info script]]
set s2 [file size test1]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
@@ -4818,7 +4841,7 @@ test io-30.3 {CopyData: background read underflow} {unixOnly} {
close $f
}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
set result [gets $f1]
puts $f1 line1
flush $f1
@@ -4851,7 +4874,7 @@ test io-30.4 {CopyData: background write overflow} {unixOnly} {
close $f
}
close $f1
- set f1 [open "|$tcltest pipe" r+]
+ set f1 [open "|[list $tcltest pipe]" r+]
set result [gets $f1]
fconfigure $f1 -blocking 0
puts $f1 $big
@@ -4885,21 +4908,38 @@ 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 in [open [info script]] ;# 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
+ vwait fcopyTestDone ;# The error occurs here in the b.g.
}
close $in
close $out
- set fcopyTestDone
+ set fcopyTestDone ;# 1 for error condition
} 1
}
+test io-30.6 {CopyData: error during fcopy} {stdio} {
+ removeFile pipe
+ removeFile test1
+ catch {unset fcopyTestDone}
+ set f1 [open pipe w]
+ puts $f1 "exit 1"
+ close $f1
+ set in [open "|[list $tcltest pipe]" r+]
+ set out [open test1 w]
+ fcopy $in $out -command [list FcopyTestDone]
+ if ![info exists fcopyTestDone] {
+ vwait fcopyTestDone
+ }
+ catch {close $in}
+ close $out
+ set fcopyTestDone ;# 0 for plain end of file
+} {0}
-test io-31.1 {Recursive channel events} {
+test io-31.1 {Recursive channel events} {socket} {
# This test checks to see if file events are delivered during recursive
# event loops when there is buffered data on the channel.
@@ -4951,7 +4991,7 @@ test io-31.1 {Recursive channel events} {
close $cs
list $result $x
} {{{line 1} 1 2} 2}
-test io-31.2 {Testing for busy-wait in recursive channel events} {
+test io-31.2 {Testing for busy-wait in recursive channel events} {socket} {
set s [socket -server accept 3939]
proc accept {s a p} {
global counter
@@ -4998,7 +5038,23 @@ test io-31.2 {Testing for busy-wait in recursive channel events} {
close $s
set counter
} 1
+test io-32.1 {ChannelEventScriptInvoker: deletion} {
+ proc eventScript {fd} {
+ close $fd
+ error "planned error"
+ set ::x whoops
+ }
+ proc bgerror {args} {
+ set ::x got_error
+ }
+ set f [open fooBar w]
+ fileevent $f writable [list eventScript $f]
+ set x not_done
+ vwait x
+ set x
+} {got_error}
+removeFile fooBar
removeFile longfile
removeFile script
removeFile output
@@ -5010,5 +5066,7 @@ removeFile bar
removeFile test2
removeFile test3
+file delete cat
+
set x ""
unset x
diff --git a/contrib/tcl/tests/ioCmd.test b/contrib/tcl/tests/ioCmd.test
index 149d6c744586..95a5975594e4 100644
--- a/contrib/tcl/tests/ioCmd.test
+++ b/contrib/tcl/tests/ioCmd.test
@@ -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.47 97/06/23 18:21:31"
+# "@(#) ioCmd.test 1.48 97/08/01 11:11:23"
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -262,13 +262,13 @@ proc iocmdSSHTDWN {} {
}
}
-test iocmd-8.15 {fconfigure command / tcp channel} {
+test iocmd-8.15 {fconfigure command / tcp channel} {socket} {
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} {
+test iocmd-8.16 {fconfigure command / tcp channel} {socket} {
iocmdSSETUP
set r [expr [lindex [fconfigure $cli -peername] 2]==$port];
iocmdSSHTDWN
@@ -293,8 +293,9 @@ test iocmd-8.18 {fconfigure command / unix tty channel} {nonPortable unixOnly} {
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
+test iocmd-8.19 {fconfigure command / win tty channel} {pcOnly && !win32s} {
+ # None of the com port functions are implemented on Win32s.
+ # Also, might fail if com1 is unavailable
set tty [open com1]
set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
close $tty;
diff --git a/contrib/tcl/tests/misc.test b/contrib/tcl/tests/misc.test
index 59292064ce71..b2168c11272c 100644
--- a/contrib/tcl/tests/misc.test
+++ b/contrib/tcl/tests/misc.test
@@ -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.
#
-# SCCS: @(#) misc.test 1.11 97/06/20 16:53:28
+# SCCS: @(#) misc.test 1.12 97/07/02 16:41:34
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -48,10 +48,4 @@ 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-bracket or close-brace} \
-{missing close-bracket or close-brace
- while compiling
-"set"
- (compiling body of proc "tstProc", line 4)
- invoked from within
-"tstProc"}]
+} {1 {missing close-bracket or close-brace} missing\ close-bracket\ or\ close-brace\n\ \ \ \ while\ compiling\n\"set\ tst\ \$a(\[winfo\ name\ \$\{zz)\"\n\ \ \ \ (compiling\ body\ of\ proc\ \"tstProc\",\ line\ 4)\n\ \ \ \ invoked\ from\ within\n\"tstProc\"}
diff --git a/contrib/tcl/tests/namespace.test b/contrib/tcl/tests/namespace.test
index c021d21511e5..e876391cd63c 100644
--- a/contrib/tcl/tests/namespace.test
+++ b/contrib/tcl/tests/namespace.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: @(#) namespace.test 1.11 97/06/23 18:24:39
+# SCCS: @(#) namespace.test 1.15 97/07/30 15:26:42
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -18,7 +18,7 @@ if {[string compare test [info procs test]] == 1} then {source defs}
catch {eval namespace delete [namespace children :: test_ns_*]}
test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
- namespace children ::
+ namespace children :: test_ns_*
} {}
catch {unset l}
@@ -90,10 +90,18 @@ 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} {
+test namespace-6.3 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} {
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} {
+} {0 ::test_ns_7}
+test namespace-6.4 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ namespace eval test_ns_1:: {
+ namespace eval test_ns_2:: {}
+ namespace eval test_ns_3:: {}
+ }
+ namespace children ::test_ns_1
+} {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_3}
+test namespace-6.5 {Tcl_CreateNamespace, relative ns names now only looked up in current ns} {
set trigger {
namespace eval test_ns_2 {namespace current}
}
@@ -297,7 +305,7 @@ test namespace-14.1 {TclGetNamespaceForQualName, absolute names} {
}
namespace eval test_ns_1 {
list $::v $::test_ns_2::v $::test_ns_1::test_ns_2::v \
- [namespace children ::]
+ [namespace children :: test_ns_*]
}
} {10 30 20 {::test_ns_1 ::test_ns_2}}
test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} {
@@ -364,10 +372,18 @@ test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for
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} {
+test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ namespace eval test_ns_1 {
+ variable {}
+ set test_ns_1::(x) y
+ }
+ set test_ns_1::(x)
+} y
+test namespace-14.13 {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}}
+} {1 {can't create namespace "": only global namespace can have empty name}}
test namespace-15.1 {Tcl_FindNamespace, absolute name found} {
catch {eval namespace delete [namespace children :: test_ns_*]}
@@ -604,16 +620,16 @@ test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} {
} {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}}
+} {1 {bad option "wombat": must 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 ::
+ namespace ch :: test_ns_*
} {}
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}
+ expr {[string first ::test_ns_1 [namespace children]] != -1}
+} {1}
test namespace-21.2 {NamespaceChildrenCmd, no args} {
namespace eval test_ns_1 {
namespace children
@@ -700,7 +716,7 @@ test namespace-25.1 {NamespaceEvalCmd, bad args} {
} {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}}
+} {1 {bad option "test_ns_1": must 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
diff --git a/contrib/tcl/tests/obj.test b/contrib/tcl/tests/obj.test
index cc8ea3c8893c..e8ee3b32f94f 100644
--- a/contrib/tcl/tests/obj.test
+++ b/contrib/tcl/tests/obj.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.
#
-# @(#) obj.test 1.10 97/05/19 14:38:29
+# @(#) obj.test 1.11 97/08/06 08:56:09
if {[info commands testobj] == {}} {
puts "This application hasn't been compiled with the \"testobj\""
@@ -171,7 +171,7 @@ test obj-12.1 {SetBooleanFromAny, int to boolean special case} {
} {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 [testdoubleobj set 1 3.14159]
lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny
lappend result [testobj type 1]
} {3.14159 0 boolean}
@@ -219,10 +219,10 @@ test obj-13.1 {UpdateStringOfBoolean} {
test obj-14.1 {Tcl_NewDoubleObj} {
set result ""
lappend result [testobj freeallvars]
- lappend result [format %.6g [testdoubleobj set 1 3.1459]]
+ lappend result [testdoubleobj set 1 3.1459]
lappend result [testobj type 1]
lappend result [testobj refcount 1]
-} {{} 3.1459 double 1}
+} {{} 3.1459 double 2}
test obj-15.1 {Tcl_SetDoubleObj, existing "empty string" object} {
set result ""
@@ -236,20 +236,20 @@ 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 [testdoubleobj set 1 27.56] ;# makes existing obj double
lappend result [testobj type 1]
lappend result [testobj refcount 1]
-} {{} 98765 27.56 double 1}
+} {{} 98765 27.56 double 2}
test obj-16.1 {Tcl_GetDoubleFromObj, existing double object} {
set result ""
- lappend result [format %.6g [testdoubleobj set 1 16.1]]
+ lappend result [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 [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} {
@@ -267,9 +267,9 @@ test obj-16.4 {Tcl_GetDoubleFromObj, error converting from "empty string"} {
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]]
+ lappend result [testdoubleobj set 1 17.1]
+ lappend result [testobj duplicate 1 2] ;# uses DupDoubleInternalRep
+ lappend result [testdoubleobj get 2]
} {17.1 17.1 17.1}
test obj-18.1 {SetDoubleFromAny, int to double special case} {
@@ -312,9 +312,9 @@ test obj-18.6 {SetDoubleFromAny, error converting from "empty string"} {
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
+ lappend result [testdoubleobj set 1 3.14159]
+ lappend result [testdoubleobj mult10 1]
+ lappend result [testdoubleobj get 1] ;# must update string rep
} {3.14159 31.4159 31.4159}
test obj-20.1 {Tcl_NewIntObj} {
diff --git a/contrib/tcl/tests/opt.test b/contrib/tcl/tests/opt.test
new file mode 100644
index 000000000000..2f23bc6890dc
--- /dev/null
+++ b/contrib/tcl/tests/opt.test
@@ -0,0 +1,236 @@
+# Package covered: opt0.1/optparse.tcl
+#
+# 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: @(#) opt.test 1.1 97/08/14 00:53:59
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+# the package we are going to test
+package require opt 0.1
+
+# we are using implementation specifics to test the package
+
+
+#### functions tests #####
+
+set n $::tcl::OptDescN
+
+test opt-1.1 {OptKeyRegister / check that auto allocation is skipping existing keys} {
+ list [::tcl::OptKeyRegister {} $n] [::tcl::OptKeyRegister {} [expr $n+1]] [::tcl::OptKeyRegister {}]
+} "$n [expr $n+1] [expr $n+2]"
+
+test opt-2.1 {OptKeyDelete} {
+ list [::tcl::OptKeyRegister {} testkey] [::tcl::OptKeyDelete testkey] \
+ [catch {::tcl::OptKeyDelete testkey} msg] $msg;
+} {testkey {} 1 {can't unset "OptDesc(testkey)": no such element in array}}
+
+
+test opt-3.1 {OptParse / temp key is removed} {
+ set n $::tcl::OptDescN
+ set prev [array names ::tcl::OptDesc]
+ ::tcl::OptKeyRegister {} $n
+ list [info exists ::tcl::OptDesc($n)]\
+ [::tcl::OptKeyDelete $n]\
+ [::tcl::OptParse {{-foo}} {}]\
+ [info exists ::tcl::OptDesc($n)]\
+ [expr {"[lsort $prev]"=="[lsort [array names ::tcl::OptDesc]]"}]
+} {1 {} {} 0 1}
+
+
+test opt-3.2 {OptParse / temp key is removed even on errors} {
+ set n $::tcl::OptDescN
+ catch {::tcl::OptKeyDelete $n}
+ list [catch {::tcl::OptParse {{-foo}} {-blah}}] \
+ [info exists ::tcl::OptDesc($n)]
+} {1 0}
+
+test opt-4.1 {OptProc} {
+ ::tcl::OptProc optTest {} {}
+ optTest ;
+ ::tcl::OptKeyDelete optTest
+} {}
+
+
+test opt-5.1 {OptProcArgGiven} {
+ ::tcl::OptProc optTest {{-foo}} {
+ if {[::tcl::OptProcArgGiven "-foo"]} {
+ return 1
+ } else {
+ return 0
+ }
+ }
+ list [optTest] [optTest -f] [optTest -F] [optTest -fOO]
+} {0 1 1 1}
+
+test opt-6.1 {OptKeyParse} {
+ ::tcl::OptKeyRegister {} test;
+ list [catch {::tcl::OptKeyParse test {-help}} msg] $msg
+} {1 {Usage information:
+ Var/FlagName Type Value Help
+ ------------ ---- ----- ----
+ ( -help gives this help )}}
+
+
+test opt-7.1 {OptCheckType} {
+ list \
+ [::tcl::OptCheckType 23 int] \
+ [::tcl::OptCheckType 23 float] \
+ [::tcl::OptCheckType true boolean] \
+ [::tcl::OptCheckType "-blah" any] \
+ [::tcl::OptCheckType {a b c} list] \
+ [::tcl::OptCheckType maYbe choice {yes maYbe no}] \
+ [catch {::tcl::OptCheckType "-blah" string}] \
+ [catch {::tcl::OptCheckType 6 boolean}] \
+ [catch {::tcl::OptCheckType x float}] \
+ [catch {::tcl::OptCheckType "a \{ c" list}] \
+ [catch {::tcl::OptCheckType 2.3 int}] \
+ [catch {::tcl::OptCheckType foo choice {x y Foo z}}]
+} {23 23.0 1 -blah {a b c} maYbe 1 1 1 1 1 1}
+
+
+test opt-8.1 {List utilities} {
+ ::tcl::Lempty {}
+} 1
+test opt-8.2 {List utilities} {
+ ::tcl::Lempty {a b c}
+} 0
+test opt-8.3 {List utilities} {
+ ::tcl::Lget {a {b c d} e} {1 2}
+} d
+
+test opt-8.4 {List utilities} {
+ set l {a {b c d e} f}
+ ::tcl::Lvarset l {1 2} D
+ set l
+} {a {b c D e} f}
+
+test opt-8.5 {List utilities} {
+ set l {a b c}
+ ::tcl::Lvarset1 l 6 X
+ set l
+} {a b c {} {} {} X}
+
+test opt-8.6 {List utilities} {
+ set l {a {b c 7 e} f}
+ ::tcl::Lvarincr l {1 2}
+ set l
+} {a {b c 8 e} f}
+
+test opt-8.7 {List utilities} {
+ set l {a {b c 7 e} f}
+ ::tcl::Lvarincr l {1 2} -9
+ set l
+} {a {b c -2 e} f}
+
+test opt-8.8 {List utilities} {
+ set l {{b c 7 e} f}
+ ::tcl::Lfirst $l
+} {b c 7 e}
+
+
+test opt-8.9 {List utilities} {
+ set l {a {b c 7 e} f}
+ ::tcl::Lrest $l
+} {{b c 7 e} f}
+
+test opt-8.10 {List utilities} {
+ set l {a {b c 7 e} f}
+ ::tcl::Lvarpop l
+ set l
+} {{b c 7 e} f}
+
+test opt-8.11 {List utilities} {
+ set l {a {b c 7 e} f}
+ list [::tcl::Lassign $l u v w x] \
+ $u $v $w [info exists x]
+} {3 a {b c 7 e} f 0}
+
+test opt-9.1 {Misc utilities} {
+ catch {unset v}
+ ::tcl::SetMax v 3
+ ::tcl::SetMax v 7
+ ::tcl::SetMax v 6
+ set v
+} 7
+
+test opt-9.2 {Misc utilities} {
+ catch {unset v}
+ ::tcl::SetMin v 3
+ ::tcl::SetMin v -7
+ ::tcl::SetMin v 1
+ set v
+} -7
+
+#### behaviour tests #####
+
+test opt-10.1 {ambigous flags} {
+ ::tcl::OptProc optTest {{-flag1xyz} {-other} {-flag2xyz} {-flag3xyz}} {}
+ catch {optTest -fL} msg
+ set msg
+} {ambigous option "-fL", choose from:
+ -flag1xyz boolflag (false)
+ -flag2xyz boolflag (false)
+ -flag3xyz boolflag (false) }
+
+test opt-10.2 {non ambigous flags} {
+ ::tcl::OptProc optTest {{-flag1xyz} {-other} {-flag2xyz} {-flag3xyz}} {
+ return $flag2xyz
+ }
+ optTest -fLaG2
+} 1
+
+
+# medium size overall test example: (defined once)
+::tcl::OptProc optTest {
+ {cmd -choice {print save delete} "sub command to choose"}
+ {-allowBoing -boolean true}
+ {arg2 -string "this is help"}
+ {?arg3? 7 "optional number"}
+ {-moreflags}
+} {
+ list $cmd $allowBoing $arg2 $arg3 $moreflags
+}
+
+test opt-10.3 {medium size overall test} {
+ list [catch {optTest} msg] $msg
+} {1 {no value given for parameter "cmd" (use -help for full usage) :
+ cmd choice (print save delete) sub command to choose}}
+
+
+test opt-10.4 {medium size overall test} {
+ list [catch {optTest -help} msg] $msg
+} {1 {Usage information:
+ Var/FlagName Type Value Help
+ ------------ ---- ----- ----
+ ( -help gives this help )
+ cmd choice (print save delete) sub command to choose
+ -allowBoing boolean (true)
+ arg2 string () this is help
+ ?arg3? int (7) optional number
+ -moreflags boolflag (false) }}
+
+test opt-10.5 {medium size overall test} {
+ optTest save tst
+} {save 1 tst 7 0}
+
+test opt-10.6 {medium size overall test} {
+ optTest save -allowBoing false -- 8
+} {save 0 8 7 0}
+
+test opt-10.7 {medium size overall test} {
+ optTest save tst -m --
+} {save 1 tst 7 1}
+
+test opt-10.8 {medium size overall test} {
+ list [catch {optTest save tst foo} msg] [lindex [split $msg "\n"] 0]
+} {1 {too many arguments (unexpected argument(s): foo), usage:}}
+
diff --git a/contrib/tcl/tests/parse.test b/contrib/tcl/tests/parse.test
index 124126287d35..514ed2a81988 100644
--- a/contrib/tcl/tests/parse.test
+++ b/contrib/tcl/tests/parse.test
@@ -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.
#
-# SCCS: @(#) parse.test 1.40 97/06/23 18:19:53
+# SCCS: @(#) parse.test 1.42 97/08/04 11:05:53
if {[string compare test [info procs test]] == 1} then {source defs}
diff --git a/contrib/tcl/tests/pkg.test b/contrib/tcl/tests/pkg.test
index 37a5b9ced970..e6a99c6f7657 100644
--- a/contrib/tcl/tests/pkg.test
+++ b/contrib/tcl/tests/pkg.test
@@ -9,11 +9,21 @@
# 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.9 96/11/15 17:56:01
+# SCCS: @(#) pkg.test 1.12 97/08/14 01:33:54
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+# Do all this in a slave interp to avoid garbaging the
+# package list
+set i [interp create]
+interp eval $i [list set VERBOSE $VERBOSE]
+interp eval $i [list set TESTS $TESTS]
+interp eval $i {
if {[string compare test [info procs test]] == 1} then {source defs}
eval package forget [package names]
+set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
set auto_path ""
@@ -192,7 +202,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 1)
+ (procedure "pkgUnknown" line 2)
invoked from within
"pkgUnknown t {}"
("package unknown" script)
@@ -546,4 +556,8 @@ test pkg-6.9 {ComparePkgVersions procedure} {
} {0}
set auto_path $oldPath
+package unknown $oldPkgUnknown
concat
+
+}
+interp delete $i
diff --git a/contrib/tcl/tests/proc-old.test b/contrib/tcl/tests/proc-old.test
index 5da63359e967..c770edba3a69 100644
--- a/contrib/tcl/tests/proc-old.test
+++ b/contrib/tcl/tests/proc-old.test
@@ -13,7 +13,7 @@
# 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
+# SCCS: @(#) proc-old.test 1.31 97/07/02 16:41:36
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -316,7 +316,7 @@ test proc-old-5.13 {error conditions} {
} {error in procedure
while executing
"error "error in procedure""
- (procedure "tproc" line 1)
+ (procedure "tproc" line 3)
invoked from within
"tproc"}
test proc-old-5.14 {error conditions} {
@@ -358,7 +358,7 @@ test proc-old-5.16 {error conditions} {
} {1 {Nested error} {Nested error
while executing
"error "Nested error""
- (procedure "tproc" line 1)
+ (procedure "tproc" line 5)
invoked from within
"tproc"} {foo was called: x {} u}}
diff --git a/contrib/tcl/tests/proc.test b/contrib/tcl/tests/proc.test
index 96473998fd20..eeace97fc037 100644
--- a/contrib/tcl/tests/proc.test
+++ b/contrib/tcl/tests/proc.test
@@ -1,8 +1,8 @@
# 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.
+# currently incomplete since it includes only new tests, in particular
+# tests for code changed for the addition of Tcl namespaces. Other
+# procedure-related tests appear in other test files such as proc-old.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
@@ -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: @(#) proc.test 1.9 97/06/20 18:55:03
+# SCCS: @(#) proc.test 1.11 97/08/12 13:31:43
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -143,7 +143,7 @@ test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespa
p
}
} {p in ::}
-test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined} {
+test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
namespace eval test_ns_1::baz {
@@ -151,7 +151,11 @@ test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they we
rename ::test_ns_1::baz::p ::p
list [p] [namespace which p]
}
-} {{p in ::test_ns_1::baz} ::p}
+} {{p in ::} ::p}
+test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} {
+ proc p {x} {info commands 3m}
+ list [catch {p} msg] $msg
+} {1 {no value given for parameter "x" to "p"}}
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
diff --git a/contrib/tcl/tests/pwd.test b/contrib/tcl/tests/pwd.test
new file mode 100644
index 000000000000..e2837999268f
--- /dev/null
+++ b/contrib/tcl/tests/pwd.test
@@ -0,0 +1,22 @@
+# Commands covered: pwd
+#
+# 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: @(#) pwd.test 1.2 97/08/13 23:06:41
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+test pwd-1.1 {simple pwd} {
+ catch pwd
+} 0
+test pwd-1.2 {simple pwd} {
+ expr [string length pwd]>0
+} 1
diff --git a/contrib/tcl/tests/registry.test b/contrib/tcl/tests/registry.test
index 6a6b99ff958c..605c84b07a91 100644
--- a/contrib/tcl/tests/registry.test
+++ b/contrib/tcl/tests/registry.test
@@ -9,7 +9,7 @@
#
# Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved.
#
-# SCCS: @(#) registry.test 1.3 97/02/11 16:58:43
+# SCCS: @(#) registry.test 1.5 97/08/01 11:14:25
if {$tcl_platform(platform) != "windows"} {
return
@@ -22,6 +22,11 @@ if [catch {package require registry}] {
return
}
+if {$testConfig(win32s)} {
+ puts "Skipping registry tests under Win32s"
+ return
+}
+
switch $tcl_platform(os) {
"Windows NT" {set testConfig(NT) 1}
"Windows 95" {set testConfig(95) 1}
@@ -38,7 +43,7 @@ test registry-1.2 {argument parsing for registry command} {
test registry-1.3 {argument parsing for registry command} {
list [catch {registry d} msg] $msg
-} {1 {wrong # args: should be "registry d keyName ?valueName?"}}
+} {1 {wrong # args: should be "registry delete 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?"}}
@@ -48,7 +53,7 @@ test registry-1.5 {argument parsing for registry command} {
test registry-1.6 {argument parsing for registry command} {
list [catch {registry g} msg] $msg
-} {1 {wrong # args: should be "registry g keyName valueName"}}
+} {1 {wrong # args: should be "registry get 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"}}
@@ -61,7 +66,7 @@ test registry-1.9 {argument parsing for registry command} {
test registry-1.10 {argument parsing for registry command} {
list [catch {registry k} msg] $msg
-} {1 {wrong # args: should be "registry k keyName ?pattern?"}}
+} {1 {wrong # args: should be "registry keys 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?"}}
@@ -71,7 +76,7 @@ test registry-1.12 {argument parsing for registry command} {
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??"}}
+} {1 {wrong # args: should be "registry set 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??"}}
@@ -84,7 +89,7 @@ test registry-1.16 {argument parsing for registry command} {
test registry-1.17 {argument parsing for registry command} {
list [catch {registry t} msg] $msg
-} {1 {wrong # args: should be "registry t keyName valueName"}}
+} {1 {wrong # args: should be "registry type 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"}}
@@ -97,7 +102,7 @@ test registry-1.20 {argument parsing for registry command} {
test registry-1.21 {argument parsing for registry command} {
list [catch {registry v} msg] $msg
-} {1 {wrong # args: should be "registry v keyName ?pattern?"}}
+} {1 {wrong # args: should be "registry values 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?"}}
diff --git a/contrib/tcl/tests/resource.test b/contrib/tcl/tests/resource.test
index dc60535ef89e..efb3c8270a77 100644
--- a/contrib/tcl/tests/resource.test
+++ b/contrib/tcl/tests/resource.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: @(#) resource.test 1.5 97/05/15 17:51:48
+# SCCS: @(#) resource.test 1.6 97/07/23 17:41:51
# Only run this test on Macintosh systems
if {$tcl_platform(platform) != "macintosh"} {
@@ -36,39 +36,130 @@ test resource-2.3 {resource open & close tests} {
} {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}}
+} {1 {file does not exist}}
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} msg] $msg
+} {1 {wrong # args: should be "resource close resourceRef"}}
+test resource-2.7 {resource open & close tests} {
+ list [catch {resource close foo bar} msg] $msg
+} {1 {wrong # args: should be "resource close resourceRef"}}
+test resource-2.8 {resource open & close tests} {
list [catch {resource close _bad_resource_} msg] $msg
} {1 {invalid resource file reference "_bad_resource_"}}
+# Tests for listing resources
+test resource-3.1 {resource list tests} {
+ list [catch {resource list} msg] $msg
+} {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}}
+test resource-3.2 {resource list tests} {
+ list [catch {resource list _bad_type_} msg] $msg
+} {1 {expected Macintosh OS type but got "_bad_type_"}}
+test resource-3.3 {resource list tests} {
+ list [catch {resource list TEXT _bad_ref_} msg] $msg
+} {1 {invalid resource file reference "_bad_ref_"}}
+test resource-3.4 {resource list tests} {
+ list [catch {resource list TEXT _bad_ref_ extraArg} msg] $msg
+} {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}}
+test resource-3.5 {resource list tests} {
+ catch {file delete rsrc.file}
+ testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"}
+ set id [resource open rsrc.file]
+ catch "resource list TEXT $id" result
+ resource close $id
+ set result
+} {fileRsrcName}
+test resource-3.6 {resource list tests} {
+ # There should be any resource of this type
+ resource list XXXX
+} {}
+test resource-3.7 {resource list tests} {
+ set resourceList [resource list STR#]
+ if {[lsearch $resourceList {Tcl Environment Variables}] == -1} {
+ set result {couldn't find resource that should exist}
+ } else {
+ set result ok
+ }
+} {ok}
+
+# Tests for listing resources
+test resource-4.1 {resource read tests} {
+ list [catch {resource read} msg] $msg
+} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}}
+test resource-4.2 {resource read tests} {
+ list [catch {resource read TEXT} msg] $msg
+} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}}
+test resource-4.3 {resource read tests} {
+ list [catch {resource read STR# {_non_existant_resource_}} msg] $msg
+} {1 {could not load resource}}
+test resource-4.4 {resource read tests} {
+ # The following resource should exist and load OK without error
+ catch {resource read STR# {Tcl Environment Variables}}
+} {0}
+
+# Tests for getting resource types
+test resource-5.1 {resource types tests} {
+ list [catch {resource types _bad_ref_} msg] $msg
+} {1 {invalid resource file reference "_bad_ref_"}}
+test resource-5.2 {resource types tests} {
+ list [catch {resource types _bad_ref_ extraArg} msg] $msg
+} {1 {wrong # args: should be "resource types ?resourceRef?"}}
+test resource-5.3 {resource types tests} {
+ # This should never cause an error
+ catch {resource types}
+} {0}
+test resource-5.4 {resource types tests} {
+ testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"}
+ set id [resource open rsrc.file]
+ set result [resource types $id]
+ resource close $id
+ set result
+} {TEXT}
+
+# resource write tests
+test resource-6.1 {resource write tests} {
+ list [catch {resource write} msg] $msg
+} {1 {wrong # args: should be "resource write ?-id resourceId? ?-name resourceName? ?-file resourceRef? resourceType data"}}
+test resource-6.2 {resource write tests} {
+ list [catch {resource write _bad_type_ data} msg] $msg
+} {1 {expected Macintosh OS type but got "_bad_type_"}}
+test resource-6.3 {resource write tests} {
+ catch {file delete rsrc2.file}
+ set id [resource open rsrc2.file w]
+ resource write -file $id -name Hello TEXT {set x "our test data"}
+ source -rsrc Hello rsrc2.file
+ resource close $id
+ file delete rsrc2.file
+ set x
+} {our test data}
+
# 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} {
+test resource-7.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} {
+test resource-7.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} {
+test resource-7.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} {
+test resource-7.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} {
+test resource-7.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.}}
diff --git a/contrib/tcl/tests/safe.test b/contrib/tcl/tests/safe.test
index 702bf8d2bc5d..d68424bdf404 100644
--- a/contrib/tcl/tests/safe.test
+++ b/contrib/tcl/tests/safe.test
@@ -1,6 +1,6 @@
# safe.test --
#
-# This file contains a collection of tests for security policies, safe Tcl,
+# This file contains a collection of tests for safe Tcl, packages loading,
# and using safe interpreters. Sourcing this file into tcl runs the tests
# and generates output for errors. No output means no errors were found.
#
@@ -9,10 +9,7 @@
# 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.
+# SCCS: @(#) safe.test 1.31 97/08/14 00:55:56
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -20,305 +17,387 @@ foreach i [interp slaves] {
interp delete $i
}
+# Force actual loading of the safe package
+# because we use un exported (and thus un-autoindexed) APIs
+# in this test result arguments:
+catch {safe::interpConfigure}
+
proc equiv {x} {return $x}
-test safe-1.1 {creating interpreters, should have no aliases} {
+test safe-1.1 {safe::interpConfigure syntax} {
+ list [catch {safe::interpConfigure} msg] $msg;
+} {1 {no value given for parameter "slave" (use -help for full usage) :
+ slave name () name of the slave}}
+
+test safe-1.2 {safe::interpCreate syntax} {
+ list [catch {safe::interpCreate -help} msg] $msg;
+} {1 {Usage information:
+ Var/FlagName Type Value Help
+ ------------ ---- ----- ----
+ ( -help gives this help )
+ ?slave? name () name of the slave (optional)
+ -accessPath list () access path for the slave
+ -noStatics boolflag (false) prevent loading of statically linked pkgs
+ -nestedLoadOk boolflag (false) allow nested loading
+ -deleteHook script () delete hook}}
+
+test safe-1.3 {safe::interpInit syntax} {
+ list [catch {safe::interpInit -noStatics} msg] $msg;
+} {1 {bad value "-noStatics" for parameter
+ slave name () name of the slave}}
+
+
+test safe-2.1 {creating interpreters, should have no aliases} {
interp aliases
} ""
-test safe-1.2 {creating interpreters, should have no aliases} {
- catch {tcl_safeDeleteInterp a}
+test safe-2.2 {creating interpreters, should have no aliases} {
+ catch {safe::interpDelete a}
interp create a
set l [a aliases]
- interp delete a
+ safe::interpDelete a
set l
} ""
-test safe-1.3 {creating safe interpreters, should have no aliases} {
- catch {tcl_safeDeleteInterp a}
+test safe-2.3 {creating safe interpreters, should have no aliases} {
+ catch {safe::interpDelete 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
+test safe-3.1 {calling safe::interpInit is safe} {
+ catch {safe::interpDelete a}
+ interp create a -safe
+ safe::interpInit a
catch {interp eval a exec ls} msg
- tcl_safeDeleteInterp a
+ safe::interpDelete a
set msg
} {invalid command name "exec"}
-test safe-2.2 {calling tcl_safeCreateInterp on trusted interp} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
+test safe-3.2 {calling safe::interpCreate on trusted interp} {
+ catch {safe::interpDelete a}
+ safe::interpCreate a
set l [lsort [a aliases]]
- tcl_safeDeleteInterp a
+ safe::interpDelete 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
+} {exit file load source}
+test safe-3.3 {calling safe::interpCreate on trusted interp} {
+ catch {safe::interpDelete a}
+ safe::interpCreate a
set x [interp eval a {source [file join $tcl_library init.tcl]}]
- tcl_safeDeleteInterp a
+ safe::interpDelete a
set x
} ""
-test safe-2.4 {calling tcl_safeCreateInterp on trusted interp} {
- catch {tcl_safeDeleteInterp a}
- tcl_safeCreateInterp a
+test safe-3.4 {calling safe::interpCreate on trusted interp} {
+ catch {safe::interpDelete a}
+ safe::interpCreate a
catch {set x \
[interp eval a {source [file join $tcl_library init.tcl]}]} msg
- tcl_safeDeleteInterp a
+ safe::interpDelete a
list $x $msg
} {{} {}}
-test safe-3.1 {tcl_safeDeleteInterp} {
- catch {tcl_safeDeleteInterp a}
+test safe-4.1 {safe::interpDelete} {
+ catch {safe::interpDelete a}
interp create a
- tcl_safeDeleteInterp a
+ safe::interpDelete a
} ""
-test safe-3.2 {tcl_safeDeleteInterp, indirectly} {
- catch {tcl_safeDeleteInterp a}
+test safe-4.2 {safe::interpDelete, indirectly} {
+ catch {safe::interpDelete a}
interp create a
- a alias exit tcl_safeDeleteInterp a
+ a alias exit safe::interpDelete 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
+test safe-4.3 {safe::interpDelete, state array (not a public api)} {
+ catch {safe::interpDelete a}
+ namespace eval safe {set [InterpStateName a](foo) 33}
+ # not an error anymore to call it if interp is already
+ # deleted, to make trhings smooth if it's called twice...
+ catch {safe::interpDelete a} m1
+ catch {namespace eval safe {set [InterpStateName a](foo)}} m2
+ list $m1 $m2
+} "{}\
+ {can't read \"[safe::InterpStateName a]\": no such variable}"
+
+
+test safe-4.4 {safe::interpDelete, state array, indirectly (not a public api)} {
+ catch {safe::interpDelete a}
+ safe::interpCreate a
+ namespace eval safe {set [InterpStateName a](foo) 33}
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
+ catch {namespace eval safe {set [InterpStateName a](foo)}} msg
+} 1
+
+test safe-4.5 {safe::interpDelete} {
+ catch {safe::interpDelete a}
+ safe::interpCreate a
+ catch {safe::interpCreate 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
+test safe-4.6 {safe::interpDelete, indirectly} {
+ catch {safe::interpDelete a}
+ safe::interpCreate 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.
+# The following test checks whether the definition of tcl_endOfWord can be
+# obtained from auto_loading.
-# Save old value of tcl_PolicyPath so we can restore it once we are
-# done with this test sequence:
+test safe-5.1 {test auto-loading in safe interpreters} {
+ catch {safe::interpDelete a}
+ safe::interpCreate a
+ set r [catch {interp eval a {tcl_endOfWord "" 0}} msg]
+ safe::interpDelete a
+ list $r $msg
+} {0 -1}
-set my_old_auto_path $auto_path
-lappend auto_path [pwd]
+# test safe interps 'information leak'
+proc SI {} {
+ global I
+ set I [interp create -safe];
+}
+proc DI {} {
+ global I;
+ interp delete $I;
+}
+test safe-6.1 {test safe interpreters knowledge of the world} {
+ SI; set r [lsort [$I eval {info globals}]]; DI; set r
+} {tcl_interactive tcl_patchLevel tcl_platform tcl_version}
+test safe-6.2 {test safe interpreters knowledge of the world} {
+ SI; set r [$I eval {info script}]; DI; set r
+} {}
+test safe-6.3 {test safe interpreters knowledge of the world} {
+ SI; set r [lsort [$I eval {array names tcl_platform}]]; DI; set r
+} {byteOrder platform}
-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
+# more test should be added to check that hostname, nameofexecutable,
+# aren't leaking infos, but they still do...
+
+# high level general test
+test safe-7.1 {tests that everything works at high level} {
+ set i [safe::interpCreate];
+ # no error shall occur:
+ # (because the default access_path shall include 1st level sub dirs
+ # so package require in a slave works like in the master)
+ set v [interp eval $i {package require http 1}]
+ # no error shall occur:
+ interp eval $i {http_config};
+ safe::interpDelete $i
+ set v
} 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
+
+test safe-7.2 {tests specific path and interpFind/AddToAccessPath} {
+ set i [safe::interpCreate -nostat -nested -accessPath [list [info library]]];
+ # should not add anything (p0)
+ set token1 [safe::interpAddToAccessPath $i [info library]]
+ # should add as p1
+ set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"];
+ # an error shall occur (http is not anymore in the secure 0-level
+ # provided deep path)
+ list $token1 $token2 \
+ [catch {interp eval $i {package require http 1}} msg] $msg \
+ [safe::interpConfigure $i]\
+ [safe::interpDelete $i]
+} "{\$p(:0:)} {\$p(:1:)} 1 {can't find package http 1} {-accessPath {$tcl_library /dummy/unixlike/test/path} -noStatics -nestedLoadOk -deleteHook {}} {}"
+
+
+# test source control on file name
+test safe-8.1 {safe source control on file} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ list [catch {$i eval {source}} msg] \
+ $msg \
+ [safe::interpDelete $i] ;
+} {1 {wrong # args: should be "source fileName"} {}}
+
+# test source control on file name
+test safe-8.2 {safe source control on file} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ list [catch {$i eval {source}} msg] \
+ $msg \
+ [safe::interpDelete $i] ;
+} {1 {wrong # args: should be "source fileName"} {}}
+
+test safe-8.3 {safe source control on file} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ set log {};
+ proc safe-test-log {str} {global log; lappend log $str}
+ set prevlog [safe::setLogCmd];
+ safe::setLogCmd safe-test-log;
+ list [catch {$i eval {source .}} msg] \
+ $msg \
+ $log \
+ [safe::setLogCmd $prevlog; unset log] \
+ [safe::interpDelete $i] ;
+} {1 {permission denied} {{ERROR for slave a : ".": is a directory}} {} {}}
+
+
+test safe-8.4 {safe source control on file} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ set log {};
+ proc safe-test-log {str} {global log; lappend log $str}
+ set prevlog [safe::setLogCmd];
+ safe::setLogCmd safe-test-log;
+ list [catch {$i eval {source /abc/def}} msg] \
+ $msg \
+ $log \
+ [safe::setLogCmd $prevlog; unset log] \
+ [safe::interpDelete $i] ;
+} {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}} {} {}}
+
+
+test safe-8.5 {safe source control on file} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ set log {};
+ proc safe-test-log {str} {global log; lappend log $str}
+ set prevlog [safe::setLogCmd];
+ safe::setLogCmd safe-test-log;
+ list [catch {$i eval {source [file join [info lib] blah]}} msg] \
+ $msg \
+ $log \
+ [safe::setLogCmd $prevlog; unset log] \
+ [safe::interpDelete $i] ;
+} "1 {blah: must be a *.tcl or tclIndex} {{ERROR for slave a : [file join [info library] blah]:blah: must be a *.tcl or tclIndex}} {} {}"
+
+
+test safe-8.6 {safe source control on file} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ set log {};
+ proc safe-test-log {str} {global log; lappend log $str}
+ set prevlog [safe::setLogCmd];
+ safe::setLogCmd safe-test-log;
+ list [catch {$i eval {source [file join [info lib] blah.tcl]}} msg] \
+ $msg \
+ $log \
+ [safe::setLogCmd $prevlog; unset log] \
+ [safe::interpDelete $i] ;
+} "1 {no such file or directory} {{ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory}} {} {}"
+
+
+test safe-8.7 {safe source control on file} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ set log {};
+ proc safe-test-log {str} {global log; lappend log $str}
+ set prevlog [safe::setLogCmd];
+ safe::setLogCmd safe-test-log;
+ list [catch {$i eval {source [file join [info lib] xxxxxxxxxxx.tcl]}}\
+ msg] \
+ $msg \
+ $log \
+ [safe::setLogCmd $prevlog; unset log] \
+ [safe::interpDelete $i] ;
+} "1 {xxxxxxxxxxx.tcl: filename too long} {{ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:xxxxxxxxxxx.tcl: filename too long}} {} {}"
+
+test safe-8.8 {safe source forbids -rsrc} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ safe::interpCreate $i;
+ list [catch {$i eval {source -rsrc Init}} msg] \
+ $msg \
+ [safe::interpDelete $i] ;
+} {1 {wrong # args: should be "source fileName"} {}}
+
+
+test safe-9.1 {safe interps' deleteHook} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ set res {}
+ proc testDelHook {args} {
+ global res;
+ # the interp still exists at that point
+ interp eval a {set delete 1}
+ # mark that we've been here (successfully)
+ set res $args;
}
- return 0
-}
+ safe::interpCreate $i -deleteHook "testDelHook arg1 arg2";
+ list [interp eval $i exit] $res
+} {{} {arg1 arg2 a}}
-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}
+test safe-9.2 {safe interps' error in deleteHook} {
+ set i "a";
+ catch {safe::interpDelete $i}
+ set res {}
+ proc testDelHook {args} {
+ global res;
+ # the interp still exists at that point
+ interp eval a {set delete 1}
+ # mark that we've been here (successfully)
+ set res $args;
+ # create an exception
+ error "being catched";
+ }
+ set log {};
+ proc safe-test-log {str} {global log; lappend log $str}
+ safe::interpCreate $i -deleteHook "testDelHook arg1 arg2";
+ set prevlog [safe::setLogCmd];
+ safe::setLogCmd safe-test-log;
+ list [safe::interpDelete $i] $res \
+ $log \
+ [safe::setLogCmd $prevlog; unset log];
+} {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}} {}}
-# 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:
+# features which still need test cases:
+# -nostatics and -nestedloadok which
+# are not easily tested from tclsh, can be
+# tested in wish though (safetk.test)
+# (we'd need a static package)
+# we have Tcltest !
+
+if {[catch {package require Tcltest} msg]} {
+ puts "This application hasn't been compiled with Tcltest"
+ puts "skipping remining safe test that relies on it."
+} else {
-set auto_path $my_old_auto_path
-unset my_old_auto_path
+ # we use the Tcltest package , which has no Safe_Init
-# set auto_path $old_auto_path
-# unset old_auto_path
+test safe-10.1 {testing statics loading} {
+ set i [safe::interpCreate]
+ list \
+ [catch {interp eval $i {load {} Tcltest}} msg] \
+ $msg \
+ [safe::interpDelete $i];
+} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}
+
+test safe-10.2 {testing statics loading / -nostatics} {
+ set i [safe::interpCreate -nostatics]
+ list \
+ [catch {interp eval $i {load {} Tcltest}} msg] \
+ $msg \
+ [safe::interpDelete $i];
+} {1 {permission denied (static package)} {}}
+
+
+
+test safe-10.3 {testing nested statics loading / no nested by default} {
+ set i [safe::interpCreate]
+ list \
+ [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \
+ $msg \
+ [safe::interpDelete $i];
+} {1 {permission denied (nested load)} {}}
+
+
+test safe-10.4 {testing nested statics loading / -nestedloadok} {
+ set i [safe::interpCreate -nested]
+ list \
+ [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \
+ $msg \
+ [safe::interpDelete $i];
+} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}
+
+
+}
diff --git a/contrib/tcl/tests/scan.test b/contrib/tcl/tests/scan.test
index 9f73bf13ecfb..50bf876a1b8c 100644
--- a/contrib/tcl/tests/scan.test
+++ b/contrib/tcl/tests/scan.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: @(#) scan.test 1.25 97/01/21 21:16:03
+# SCCS: @(#) scan.test 1.26 97/08/06 08:56:08
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -67,14 +67,12 @@ 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] \
- [format %.6g $a] [format %.6g $b] [format %.6g $c] $d
-} {3 2.1 -3e+08 0.99962 {}}
+ list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d
+} {3 2.1 -300000000.0 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] \
- [format %.6g $a] [format %.6g $b] [format %.6g $c] [format %.6g $d]
-} {4 -1 234 5 8.2}
+ 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}
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
@@ -89,22 +87,19 @@ test scan-2.4 {floating-point scanning} {nonPortable} {
} {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] \
- [format %.6g $a] [format %.6g $b] [format %.6g $c] [format %.6g $d]
-} {4 4.6 99999.7 87.643 118}
+ 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}
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] \
- [format %.6g $a] [format %.6g $b] [format %.6g $c] [format %.6g $d]
-} {4 1.2345 0.697 124 5e-05}
+ 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}
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] [format %.6g $a] $b $c $d
+ list [scan "4.6abc" "%f %f %f %f" a b c d] $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] \
- [format %.6g $a] [format %.6g $b] $c $d
+ list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d
} {2 4.6 5.2 {} {}}
test scan-3.1 {string and character scanning} {
diff --git a/contrib/tcl/tests/set-old.test b/contrib/tcl/tests/set-old.test
index 17e67f74a39d..2b4cd620f1fe 100644
--- a/contrib/tcl/tests/set-old.test
+++ b/contrib/tcl/tests/set-old.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: @(#) set-old.test 1.19 96/09/09 18:36:24
+# SCCS: @(#) set-old.test 1.20 97/07/25 17:45:55
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -292,7 +292,7 @@ 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}}
+} {1 {bad option "gorp": must 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
diff --git a/contrib/tcl/tests/socket.test b/contrib/tcl/tests/socket.test
index 2389016ba0b6..280db1ba5549 100644
--- a/contrib/tcl/tests/socket.test
+++ b/contrib/tcl/tests/socket.test
@@ -59,10 +59,14 @@
# 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.75 97/04/30 15:42:58
+# SCCS: @(#) socket.test 1.82 97/08/05 13:30:55
if {[string compare test [info procs test]] == 1} then {source defs}
+if {$testConfig(socket) == 0} {
+ return
+}
+
#
# If remoteServerIP or remoteServerPort are not set, check in the
# environment variables for externally set values.
@@ -104,20 +108,23 @@ if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} {
set remoteProcChan ""
set commandSocket ""
-if {$doTestsWithRemoteServer == 1} {
+if {$doTestsWithRemoteServer} {
catch {close $commandSocket}
if {[catch {set commandSocket [socket $remoteServerIP \
$remoteServerPort]}] != 0} {
if {[info commands exec] == ""} {
set noRemoteTestReason "can't exec"
set doTestsWithRemoteServer 0
+ } elseif {$testConfig(win32s)} {
+ set noRemoteTestReason "\ncan't run multiple instances of tcltest under win32s."
+ set doTestsWithRemoteServer 0
} else {
set remoteServerIP localhost
if {[catch {set remoteProcChan \
- [open "|$tcltest remote.tcl \
+ [open "|[list $tcltest remote.tcl \
-serverIsSilent \
-port $remoteServerPort \
- -address $remoteServerIP" \
+ -address $remoteServerIP]" \
w+]} \
msg] == 0} {
after 1000
@@ -232,7 +239,7 @@ test socket-1.12 {arg parsing for socket command} {
list [catch {socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}
-test socket-2.1 {tcp connection} {unixOrPc} {
+test socket-2.1 {tcp connection} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -250,7 +257,7 @@ test socket-2.1 {tcp connection} {unixOrPc} {
puts $x
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f x
if {[catch {socket localhost 2828} msg]} {
set x $msg
@@ -268,7 +275,7 @@ if [info exists port] {
} else {
set port [expr 2048 + [pid]%1024]
}
-test socket-2.2 {tcp connection with client port specified} {unixOrPc} {
+test socket-2.2 {tcp connection with client port specified} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -286,7 +293,7 @@ test socket-2.2 {tcp connection with client port specified} {unixOrPc} {
close $f
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f x
global port
if {[catch {socket -myport $port localhost 2828} sock]} {
@@ -302,7 +309,7 @@ test socket-2.2 {tcp connection with client port specified} {unixOrPc} {
close $f
set x
} [list ready "hello $port"]
-test socket-2.3 {tcp connection with client interface specified} {unixOrPc} {
+test socket-2.3 {tcp connection with client interface specified} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -320,7 +327,7 @@ test socket-2.3 {tcp connection with client interface specified} {unixOrPc} {
close $f
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f x
if {[catch {socket -myaddr localhost localhost 2828} sock]} {
set x $sock
@@ -333,7 +340,7 @@ test socket-2.3 {tcp connection with client interface specified} {unixOrPc} {
close $f
set x
} {ready {hello 127.0.0.1}}
-test socket-2.4 {tcp connection with server interface specified} {unixOrPc} {
+test socket-2.4 {tcp connection with server interface specified} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -351,7 +358,7 @@ test socket-2.4 {tcp connection with server interface specified} {unixOrPc} {
close $f
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f x
if {[catch {socket [info hostname] 2828} sock]} {
set x $sock
@@ -364,7 +371,7 @@ test socket-2.4 {tcp connection with server interface specified} {unixOrPc} {
close $f
set x
} {ready hello}
-test socket-2.5 {tcp connection with redundant server port} {unixOrPc} {
+test socket-2.5 {tcp connection with redundant server port} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -382,7 +389,7 @@ test socket-2.5 {tcp connection with redundant server port} {unixOrPc} {
close $f
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f x
if {[catch {socket localhost 2828} sock]} {
set x $sock
@@ -405,7 +412,7 @@ test socket-2.6 {tcp connection} {unixOrPc} {
}
set status
} ok
-test socket-2.7 {echo server, one line} {unixOrPc} {
+test socket-2.7 {echo server, one line} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -432,7 +439,7 @@ test socket-2.7 {echo server, one line} {unixOrPc} {
puts done
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f
set s [socket localhost 2828]
fconfigure $s -buffering line -translation lf
@@ -443,7 +450,7 @@ test socket-2.7 {echo server, one line} {unixOrPc} {
close $f
list $x $y
} {{hello abcdefghijklmnop} done}
-test socket-2.8 {echo server, loop 50 times, single connection} {unixOrPc} {
+test socket-2.8 {echo server, loop 50 times, single connection} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -473,7 +480,7 @@ test socket-2.8 {echo server, loop 50 times, single connection} {unixOrPc} {
puts "done $i"
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f
set s [socket localhost 2828]
fconfigure $s -buffering line
@@ -486,13 +493,13 @@ test socket-2.8 {echo server, loop 50 times, single connection} {unixOrPc} {
close $f
set x
} {done 50}
-test socket-2.9 {socket conflict} {unixOrPc} {
+test socket-2.9 {socket conflict} {stdio} {
set s [socket -server accept 2828]
removeFile script
set f [open script w]
puts $f {set f [socket -server accept 2828]}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f
after 100
set x [list [catch {close $f} msg] $msg]
@@ -500,7 +507,7 @@ test socket-2.9 {socket conflict} {unixOrPc} {
set x
} {1 {couldn't open socket: address already in use
while executing
-"set f [socket -server accept 2828]"
+"socket -server accept 2828"
(file "script" line 1)}}
test socket-2.10 {close on accept, accepted socket lives} {
set done 0
@@ -526,7 +533,7 @@ test socket-2.10 {close on accept, accepted socket lives} {
set done
} 1
-test socket-3.1 {socket conflict} {unixOrPc} {
+test socket-3.1 {socket conflict} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -536,7 +543,7 @@ test socket-3.1 {socket conflict} {unixOrPc} {
close $f
}
close $f
- set f [open "|$tcltest script" r+]
+ set f [open "|[list $tcltest script]" r+]
gets $f
set x [list [catch {socket -server accept 2828} msg] \
$msg]
@@ -544,7 +551,7 @@ test socket-3.1 {socket conflict} {unixOrPc} {
close $f
set x
} {1 {couldn't open socket: address already in use}}
-test socket-3.2 {server with several clients} {unixOrPc} {
+test socket-3.2 {server with several clients} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -578,7 +585,7 @@ test socket-3.2 {server with several clients} {unixOrPc} {
puts $x
}
close $f
- set f [open "|$tcltest script" r+]
+ set f [open "|[list $tcltest script]" r+]
set x [gets $f]
set s1 [socket localhost 2828]
fconfigure $s1 -buffering line
@@ -602,7 +609,7 @@ test socket-3.2 {server with several clients} {unixOrPc} {
set x
} {ready done}
-test socket-4.1 {server with several clients} {unixOrPc} {
+test socket-4.1 {server with several clients} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -618,11 +625,11 @@ test socket-4.1 {server with several clients} {unixOrPc} {
gets stdin
}
close $f
- set p1 [open "|$tcltest script" r+]
+ set p1 [open "|[list $tcltest script]" r+]
fconfigure $p1 -buffering line
- set p2 [open "|$tcltest script" r+]
+ set p2 [open "|[list $tcltest script]" r+]
fconfigure $p2 -buffering line
- set p3 [open "|$tcltest script" r+]
+ set p3 [open "|[list $tcltest script]" r+]
fconfigure $p3 -buffering line
proc accept {s a p} {
fconfigure $s -buffering line
@@ -705,7 +712,7 @@ test socket-5.3 {byte order problems, socket numbers, htons} {unixOnly} {
set x
} {couldn't open socket: not owner}
-test socket-6.1 {accept callback error} {unixOrPc} {
+test socket-6.1 {accept callback error} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -713,7 +720,7 @@ test socket-6.1 {accept callback error} {unixOrPc} {
socket localhost 2848
}
close $f
- set f [open "|$tcltest script" r+]
+ set f [open "|[list $tcltest script]" r+]
proc bgerror args {
global x
set x $args
@@ -730,7 +737,7 @@ test socket-6.1 {accept callback error} {unixOrPc} {
set x
} {{divide by zero}}
-test socket-7.1 {testing socket specific options} {unixOrPc} {
+test socket-7.1 {testing socket specific options} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -745,7 +752,7 @@ test socket-7.1 {testing socket specific options} {unixOrPc} {
after cancel $timer
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f
set s [socket localhost 2820]
set p [fconfigure $s -peername]
@@ -756,7 +763,7 @@ test socket-7.1 {testing socket specific options} {unixOrPc} {
lappend l [string compare [lindex $p 2] 2820]
lappend l [llength $p]
} {0 0 3}
-test socket-7.2 {testing socket specific options} {unixOrPc} {
+test socket-7.2 {testing socket specific options} {stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -771,7 +778,7 @@ test socket-7.2 {testing socket specific options} {unixOrPc} {
after cancel $timer
}
close $f
- set f [open "|$tcltest script" r]
+ set f [open "|[list $tcltest script]" r]
gets $f
set s [socket localhost 2821]
set p [fconfigure $s -sockname]
@@ -884,7 +891,7 @@ test socket-9.1 {testing spurious events} {
close $s
list $spurious $len
} {0 50}
-test socket-9.2 {testing async write, fileevents, flush on close} {
+test socket-9.2 {testing async write, fileevents, flush on close} {tempNotMac} {
set firstblock ""
for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
set secondblock ""
@@ -1024,7 +1031,7 @@ test socket-10.2 {client specifies its port} {
#
# Tests io-10.3, io-10.4 have been removed.
#
-test socket-10.5 {trying to connect, no server} {
+test socket-10.3 {trying to connect, no server} {
set status ok
if {![catch {set s [socket $remoteServerIp 2836]}]} {
if {![catch {gets $s}]} {
@@ -1034,7 +1041,7 @@ test socket-10.5 {trying to connect, no server} {
}
set status
} ok
-test socket-10.6 {remote echo, one line} {
+test socket-10.4 {remote echo, one line} {
sendCommand {
set socket10_6_test_server [socket -server accept 2836]
proc accept {s a p} {
@@ -1058,7 +1065,7 @@ test socket-10.6 {remote echo, one line} {
sendCommand {close $socket10_6_test_server}
set r
} hello
-test socket-10.7 {remote echo, 50 lines} {
+test socket-10.5 {remote echo, 50 lines} {
sendCommand {
set socket10_7_test_server [socket -server accept 2836]
proc accept {s a p} {
@@ -1092,7 +1099,7 @@ if {$tcl_platform(platform) == "macintosh"} {
} else {
set conflictResult {1 {couldn't open socket: address already in use}}
}
-test socket-10.8 {socket conflict} {
+test socket-10.6 {socket conflict} {
set s1 [socket -server accept 2836]
if {[catch {set s2 [socket -server accept 2836]} msg]} {
set result [list 1 $msg]
@@ -1103,7 +1110,7 @@ test socket-10.8 {socket conflict} {
close $s1
set result
} $conflictResult
-test socket-10.9 {server with several clients} {
+test socket-10.7 {server with several clients} {
sendCommand {
set socket10_9_test_server [socket -server accept 2836]
proc accept {s a p} {
@@ -1139,7 +1146,7 @@ test socket-10.9 {server with several clients} {
sendCommand {close $socket10_9_test_server}
set i
} 100
-test socket-10.10 {client with several servers} {
+test socket-10.8 {client with several servers} {
sendCommand {
set s1 [socket -server "accept 4003" 4003]
set s2 [socket -server "accept 4004" 4004]
@@ -1165,7 +1172,7 @@ test socket-10.10 {client with several servers} {
}
set l
} {4003 {} 1 4004 {} 1 4005 {} 1}
-test socket-10.11 {accept callback error} {
+test socket-10.9 {accept callback error} {
set s [socket -server accept 2836]
proc accept {s a p} {expr 10 / 0}
proc bgerror args {
@@ -1187,7 +1194,7 @@ test socket-10.11 {accept callback error} {
rename bgerror {}
set x
} {{divide by zero}}
-test socket-10.12 {testing socket specific options} {
+test socket-10.10 {testing socket specific options} {
sendCommand {
set socket10_12_test_server [socket -server accept 2836]
proc accept {s a p} {close $s}
@@ -1201,7 +1208,7 @@ test socket-10.12 {testing socket specific options} {
sendCommand {close $socket10_12_test_server}
set l
} {2836 3 3}
-test socket-10.13 {testing spurious events} {
+test socket-10.11 {testing spurious events} {
sendCommand {
set socket10_13_test_server [socket -server accept 2836]
proc accept {s a p} {
@@ -1240,7 +1247,7 @@ test socket-10.13 {testing spurious events} {
sendCommand {close $socket10_13_test_server}
list $spurious $len
} {0 2690}
-test socket-10.14 {testing EOF stickyness} {
+test socket-10.12 {testing EOF stickyness} {
set counter 0
set done 0
proc count_up {s} {
@@ -1273,7 +1280,7 @@ test socket-10.14 {testing EOF stickyness} {
sendCommand {close $socket10_14_test_server}
set done
} {EOF is sticky}
-test socket-10.15 {testing async write, async flush, async close} {
+test socket-10.13 {testing async write, async flush, async close} {
proc readit {s} {
global count done
set l [read $s]
diff --git a/contrib/tcl/tests/source.test b/contrib/tcl/tests/source.test
index 2d62284b0def..1e0ff696c211 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.24 96/10/22 11:34:29
+# SCCS: @(#) source.test 1.25 97/07/02 16:41:34
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 1)
+ (file "source.file" line 3)
invoked from within
"source source.file"}}
test source-2.4 {source error conditions} {
diff --git a/contrib/tcl/tests/split.test b/contrib/tcl/tests/split.test
index 2e2af2519267..a57c714a3ab9 100644
--- a/contrib/tcl/tests/split.test
+++ b/contrib/tcl/tests/split.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: @(#) split.test 1.9 96/12/30 17:10:16
+# SCCS: @(#) split.test 1.10 97/07/07 16:30:07
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -41,10 +41,21 @@ test split-1.8 {basic split commands} {
foreach f [split {]\n} {}] {
append x $f
}
- return $x
+ return $x
}
foo
} {]\n}
+test split-1.9 {basic split commands} {
+ proc foo {} {
+ set x ab\000c
+ set y [split $x {}]
+ return $y
+ }
+ foo
+} "a b \000 c"
+test split-1.10 {basic split commands} {
+ split "a0ab1b2bbb3\000c4" ab\000c
+} {{} 0 {} 1 2 {} {} 3 {} 4}
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 08ade640db31..6643d4f355b9 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.14 97/03/09 17:47:19
+# SCCS: @(#) string.test 1.15 97/07/02 16:49:27
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -43,9 +43,12 @@ test string-2.4 {string first} {
string first xxx x123xx345xxx789xxx012
} 9
test string-2.5 {string first} {
+ string first "" x123xx345xxx789xxx012
+} -1
+test string-2.6 {string first} {
list [catch {string first a} msg] $msg
} {1 {wrong # args: should be "string first string1 string2"}}
-test string-2.6 {string first} {
+test string-2.7 {string first} {
list [catch {string first a b c} msg] $msg
} {1 {wrong # args: should be "string first string1 string2"}}
diff --git a/contrib/tcl/tests/trace.test b/contrib/tcl/tests/trace.test
index d67c2528ca81..b4d02d33a9e6 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.25 96/08/23 11:44:46
+# SCCS: @(#) trace.test 1.27 97/07/23 17:08:38
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -26,6 +26,10 @@ proc traceArray {name1 name2 op} {
global info
set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg]
}
+proc traceArray2 {name1 name2 op} {
+ global info
+ set info [list $name1 $name2 $op]
+}
proc traceProc {name1 name2 op} {
global info
set info [concat $info [list $name1 $name2 $op]]
@@ -80,20 +84,48 @@ test trace-1.5 {trace array element reads} {
trace var x(2) r traceArray
list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 r 0 zzz}}
-test trace-1.6 {trace reads on whole arrays} {
+test trace-1.6 {trace array element reads} {
+ catch {unset x}
+ set info {}
+ trace variable x r traceArray2
+ proc p {} {
+ global x
+ set x(2) willi
+ return $x(2)
+ }
+ list [catch {p} msg] $msg $info
+} {0 willi {x 2 r}}
+test trace-1.7 {trace array element reads, create element undefined if nonexistant} {
+ catch {unset x}
+ set info {}
+ trace variable x r q
+ proc q {name1 name2 op} {
+ global info
+ set info [list $name1 $name2 $op]
+ global $name1
+ set ${name1}($name2) wolf
+ }
+ proc p {} {
+ global x
+ set x(X) willi
+ return $x(Y)
+ }
+ list [catch {p} msg] $msg $info
+} {0 wolf {x Y r}}
+test trace-1.8 {trace reads on whole arrays} {
catch {unset x}
set info {}
trace var x r traceArray
list [catch {set x(2)} msg] $msg $info
} {1 {can't read "x(2)": no such variable} {}}
-test trace-1.7 {trace reads on whole arrays} {
+test trace-1.9 {trace reads on whole arrays} {
catch {unset x}
set x(2) zzz
set info {}
trace var x r traceArray
list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 r 0 zzz}}
-test trace-1.8 {trace variable reads} {
+test trace-1.10 {trace variable reads} {
catch {unset x}
set x 444
set info {}
diff --git a/contrib/tcl/tests/unixFCmd.test b/contrib/tcl/tests/unixFCmd.test
index 8fc1f2ea17b7..6b57e7565f87 100644
--- a/contrib/tcl/tests/unixFCmd.test
+++ b/contrib/tcl/tests/unixFCmd.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: @(#) unixFCmd.test 1.11 97/06/23 17:30:25
+# SCCS: @(#) unixFCmd.test 1.14 97/08/15 10:22:11
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -232,10 +232,19 @@ test unixFCmd-17.3 {SetPermissionsAttribute} {
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
-
-
-
-
-
+test unixFCmd-18.1 { nix pwd} {nonPortable} {
+ # This test is nonportable because SunOS generates a weird error
+ # message when the current directory isn't readable.
+ set cd [pwd]
+ set nd $cd/tstdir
+ file mkdir $nd
+ cd $nd
+ exec chmod 000 $nd
+ set r [list [catch {pwd} res] [string range $res 0 36]];
+ cd $cd;
+ exec chmod 755 $nd
+ file delete $nd
+ set r
+} {1 {error getting working directory name:}}
+
+cleanup
diff --git a/contrib/tcl/tests/util.test b/contrib/tcl/tests/util.test
index e7a3f2fd493e..ee37047cd659 100644
--- a/contrib/tcl/tests/util.test
+++ b/contrib/tcl/tests/util.test
@@ -6,7 +6,7 @@
# 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
+# SCCS: @(#) util.test 1.8 97/08/12 15:50:02
if {[info commands testobj] == {}} {
puts "This application hasn't been compiled with the \"testobj\""
@@ -42,23 +42,91 @@ test util-3.1 {Tcl_ScanCountedElement procedure - don't leave unmatched braces}
concat $x [llength "{$x}"]
} {\ \\\{\ \\ 1}
-test util-4.1 {Tcl_SetObjErrorCode - one arg} {
+test util-4.1 {Tcl_ConcatObj - backslash-space at end of argument} {
+ concat a {b\ } c
+} {a b\ c}
+test util-4.2 {Tcl_ConcatObj - backslash-space at end of argument} {
+ concat a {b\ } c
+} {a b\ c}
+test util-4.3 {Tcl_ConcatObj - backslash-space at end of argument} {
+ concat a {b\\ } c
+} {a b\\ c}
+test util-4.4 {Tcl_ConcatObj - backslash-space at end of argument} {
+ concat a {b } c
+} {a b c}
+test util-4.5 {Tcl_ConcatObj - backslash-space at end of argument} {
+ concat a { } c
+} {a c}
+
+test util-5.1 {Tcl_SetObjErrorCode - one arg} {
catch {testsetobjerrorcode 1}
list [set errorCode]
} {1}
-test util-4.2 {Tcl_SetObjErrorCode - two args} {
+test util-5.2 {Tcl_SetObjErrorCode - two args} {
catch {testsetobjerrorcode 1 2}
list [set errorCode]
} {{1 2}}
-test util-4.3 {Tcl_SetObjErrorCode - three args} {
+test util-5.3 {Tcl_SetObjErrorCode - three args} {
catch {testsetobjerrorcode 1 2 3}
list [set errorCode]
} {{1 2 3}}
-test util-4.4 {Tcl_SetObjErrorCode - four args} {
+test util-5.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} {
+test util-5.5 {Tcl_SetObjErrorCode - five args} {
catch {testsetobjerrorcode 1 2 3 4 5}
list [set errorCode]
} {{1 2 3 4 5}}
+
+test util-6.1 {Tcl_PrintDouble - using tcl_precision} {
+ concat x[expr 1.4]
+} {x1.4}
+test util-6.2 {Tcl_PrintDouble - using tcl_precision} {
+ concat x[expr 1.39999999999]
+} {x1.39999999999}
+test util-6.3 {Tcl_PrintDouble - using tcl_precision} {
+ concat x[expr 1.399999999999]
+} {x1.4}
+test util-6.4 {Tcl_PrintDouble - using tcl_precision} {
+ set tcl_precision 5
+ concat x[expr 1.123412341234]
+} {x1.1234}
+set tcl_precision 12
+test util-6.4 {Tcl_PrintDouble - make sure there's a decimal point} {
+ concat x[expr 2.0]
+} {x2.0}
+test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} {
+ concat x[expr 3.0e98]
+} {x3e+98}
+
+test util-7.1 {TclPrecTraceProc - unset callbacks} {
+ set tcl_precision 7
+ set x $tcl_precision
+ unset tcl_precision
+ list $x $tcl_precision
+} {7 7}
+test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} {
+ set tcl_precision 12
+ interp create child
+ set x [child eval set tcl_precision]
+ child eval {set tcl_precision 6}
+ interp delete child
+ list $x $tcl_precision
+} {12 6}
+test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} {
+ set tcl_precision 12
+ interp create -safe child
+ set x [child eval {
+ list [catch {set tcl_precision 8} msg] $msg
+ }]
+ interp delete child
+ list $x $tcl_precision
+} {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12}
+test util-7.3 {TclPrecTraceProc - write traces, bogus values} {
+ set tcl_precision 12
+ list [catch {set tcl_precision abc} msg] $msg $tcl_precision
+} {1 {can't set "tcl_precision": improper value for precision} 12}
+
+set tcl_precision 12
+concat ""
diff --git a/contrib/tcl/tests/var.test b/contrib/tcl/tests/var.test
index a51a47b2698f..645257771eba 100644
--- a/contrib/tcl/tests/var.test
+++ b/contrib/tcl/tests/var.test
@@ -13,7 +13,7 @@
# 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
+# SCCS: @(#) var.test 1.10 97/07/28 18:31:47
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -277,8 +277,8 @@ test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} {
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}}
+ list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg
+} {0 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
@@ -333,7 +333,37 @@ test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, l
}
set a
} {8 8}
-test var-7.9 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
+test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} {
+ catch {namespace delete test_ns_var2}
+ set a ""
+ namespace eval test_ns_var2 {
+ variable x 123
+ variable y
+ variable z
+ }
+ lappend a [info vars test_ns_var2::*]
+ lappend a [info exists test_ns_var2::x] [info exists test_ns_var2::y] \
+ [info exists test_ns_var2::z]
+ lappend a [list [catch {set test_ns_var2::y} msg] $msg]
+ lappend a [info vars test_ns_var2::*]
+ lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
+ lappend a [set test_ns_var2::y hello]
+ lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
+ lappend a [list [catch {unset test_ns_var2::y} msg] $msg]
+ lappend a [info vars test_ns_var2::*]
+ lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
+ lappend a [list [catch {unset test_ns_var2::z} msg] $msg]
+ lappend a [namespace delete test_ns_var2]
+ set a
+} {{::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z} 1 0 0\
+{1 {can't read "test_ns_var2::y": no such variable}}\
+{::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z} 0 0\
+hello 1 0\
+{0 {}}\
+{::test_ns_var2::x ::test_ns_var2::z} 0 0\
+{1 {can't unset "test_ns_var2::z": no such variable}}\
+{}}
+test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
namespace eval test_ns_var {
proc p {} {
variable eight
@@ -342,14 +372,14 @@ test var-7.9 {Tcl_VariableObjCmd, variable cmd inside proc creates local link va
p
}
} {8 eight}
-test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
+test var-7.11 {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} {
+test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
namespace eval test_ns_var {
variable {} {My name is empty}
}
@@ -402,18 +432,18 @@ test var-9.6 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
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} {
+test var-9.7 {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} {
+test var-9.8 {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} {
+test var-9.9 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
proc readonly args {error "read-only"}
set v 456
trace var v w readonly
@@ -426,6 +456,7 @@ catch {unset v}
catch {rename p ""}
catch {namespace delete test_ns_var}
+catch {namespace delete test_ns_var2}
catch {unset xx}
catch {unset x}
catch {unset y}
diff --git a/contrib/tcl/tests/while.test b/contrib/tcl/tests/while.test
index 3cb43d0cc33e..86427479fc23 100644
--- a/contrib/tcl/tests/while.test
+++ b/contrib/tcl/tests/while.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: @(#) @(#) while.test 1.8 97/06/24 10:36:56
+# SCCS: @(#) @(#) while.test 1.9 97/07/02 16:41:35
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -29,7 +29,7 @@ test while-1.2 {TclCompileWhileCmd: error in test expression} {
} {syntax error in expression "$i<"
("while" test expression)
while compiling
-"while"}
+"while {$i<}"}
test while-1.3 {TclCompileWhileCmd: error in test expression} {
set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
list $err $msg
@@ -71,7 +71,7 @@ test while-1.8 {TclCompileWhileCmd: error compiling command body} {
"set"
("while" body line 1)
while compiling
-"while"}
+"while {$i < 5} {set}"}
test while-1.9 {TclCompileWhileCmd: simple command body} {
set a {}
set i 1
diff --git a/contrib/tcl/tests/winFCmd.test b/contrib/tcl/tests/winFCmd.test
index 83691b0e1351..bca8c4bbc736 100644
--- a/contrib/tcl/tests/winFCmd.test
+++ b/contrib/tcl/tests/winFCmd.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: @(#) winFCmd.test 1.8 97/05/21 14:49:13
+# SCCS: @(#) winFCmd.test 1.10 97/08/05 11:44:57
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -44,9 +44,6 @@ proc cleanup {args} {
}
}
-set testConfig(32s) 0
-set testConfig(95) 0
-set testConfig(NT) 0
set testConfig(cdrom) 0
set testConfig(exdev) 0
set testConfig(UNCPath} 0
@@ -104,12 +101,6 @@ if {[file exists c:/] && [file exists d:/]} {
}
}
-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
}
@@ -149,7 +140,10 @@ test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} {
file mkdir td2
list [catch {testfile mv td2 td1/td2} msg] $msg
} {1 EEXIST}
-test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} {
+test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} {!$testConfig(win32s) || ("[lindex [file split [pwd]] end]" == "C:/")} {
+ # Don't run this test under Win32s on a drive mounted from an NT
+ # machine; it causes the NT machine to die.
+
cleanup
list [catch {testfile mv / td1} msg] $msg
} {1 EINVAL}
@@ -214,7 +208,7 @@ test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {95} {
createfile tf1
list [catch {testfile mv tf1 nul} msg] $msg
} {1 EACCES}
-test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {NT} {
+test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {nt} {
cleanup
createfile tf1
list [catch {testfile mv tf1 nul} msg] $msg
@@ -235,18 +229,22 @@ test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} {
} {1 ENOENT}
test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {
cleanup
- list [catch {testfile mv nul g} msg] $msg
+ list [catch {testfile mv nul tf1} 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} {
+# under 95, this would actually succed and move the current dir out from
+# under yourself.
+test winFCmd-1.20 {TclpRenameFile: src is dir} {!95} {
cleanup
file delete /tf1
list [catch {testfile mv [pwd] /tf1} msg] $msg
} {1 EACCES}
-test winFCmd-1.21 {TclpRenameFile: obscenely long src} {
+test winFCmd-1.21 {TclpRenameFile: obscenely long src} {!win32s} {
+ # Really long file names cause all the file system calls to lock up,
+ # endlessly throwing an access violation and retrying the operation.
+
list [catch {testfile mv $longname tf1} msg] $msg
} {1 ENAMETOOLONG}
-test winFCmd-1.22 {TclpRenameFile: obscenely long dst} {NT} {
+test winFCmd-1.22 {TclpRenameFile: obscenely long dst} {nt} {
# return ENOENT if name is too long!
cleanup
createfile tf1
@@ -262,7 +260,10 @@ test winFCmd-1.24 {TclpRenameFile: move dir into self} {
file mkdir td1
list [catch {testfile mv [pwd]/td1 td1/td2} msg] $msg
} {1 EINVAL}
-test winFCmd-1.25 {TclpRenameFile: move a root dir} {
+test winFCmd-1.25 {TclpRenameFile: move a root dir} {!$testConfig(win32s) || ("[lindex [file split [pwd]] end]" == "C:/")} {
+ # Don't run this test under Win32s on a drive mounted from an NT
+ # machine; it causes the NT machine to die.
+
cleanup
list [catch {testfile mv / c:/} msg] $msg
} {1 EINVAL}
@@ -371,7 +372,7 @@ test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} {
createfile tf1
list [catch {testfile cp tf1 ""} msg] $msg
} {1 ENOENT}
-test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {95} {
+test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {!nt} {
cleanup
createfile tf1
set fd [open tf2 w]
@@ -379,7 +380,7 @@ test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {95} {
close $fd
set msg
} {1 EACCES}
-test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {NT} {
+test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {nt} {
cleanup
list [catch {testfile cp nul tf1} msg] $msg
} {1 EACCES}
@@ -509,7 +510,7 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} {
set msg
} {1 EACCES}
-test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {cdrom NT} {
+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} {
@@ -584,15 +585,15 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} {
testfile rmdir td1
file exists td1
} {0}
-test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {95} {
+test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {!nt} {
cleanup
list [catch {testfile rmdir nul} msg] $msg
} {1 {nul EACCES}}
-test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {NT} {
+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} {
+test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {!nt} {
cleanup
createfile tf1
list [catch {testfile rmdir tf1} msg] $msg
@@ -604,7 +605,7 @@ test winFCmd-6.13 {TclpRemoveDirectory: write-protected} {
testfile rmdir td1
file exists td1
} {0}
-test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {95} {
+test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {!nt} {
cleanup
file mkdir td1/td2
list [catch {testfile rmdir td1} msg] $msg
@@ -670,10 +671,10 @@ test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} {
testfile cpdir td1 td2
contents td2/tf1
} {tf1}
-test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {95 cdrom} {
+test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {!nt && cdrom} {
list [catch {testfile rmdir $cdrom/} msg] $msg
} "1 {$cdrom\\ EEXIST}"
-test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} {NT cdrom} {
+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} {
@@ -701,12 +702,12 @@ test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} {
testfile cpdir td1 td2
contents td2/tf1
} {tf1}
-test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {95} {
+test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {!nt} {
cleanup
file mkdir td1
list [catch {testfile cpdir td1 /} msg] $msg
} {1 {\ EEXIST}}
-test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {NT} {
+test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {nt} {
cleanup
file mkdir td1
list [catch {testfile cpdir td1 /} msg] $msg
@@ -832,45 +833,45 @@ test winFCmd-11.4 {GetWinFileAttributes} {
test winFCmd-12.1 {ConvertFileNameFormat} {
cleanup
close [open td1 w]
- list [catch {file attributes td1 -longname} msg] $msg [cleanup]
+ list [catch {string tolower [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]
+ list [catch {string tolower [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]
+ list [catch {string tolower [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]
+ list [catch {string tolower [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]
+ list [catch {string tolower [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]
+ list [catch {string tolower [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]
+ list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
-test winFCmd-12.8 {ConvertFileNameFormat} {32s} {
+test winFCmd-12.8 {ConvertFileNameFormat} {win32s} {
cleanup
close [open td1 w]
- list [catch {file attributes td1 -longname} msg] $msg [cleanup]
+ list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-12.9 {ConvertFileNameFormat} {longFileNames} {
cleanup
@@ -880,19 +881,19 @@ test winFCmd-12.9 {ConvertFileNameFormat} {longFileNames} {
test winFCmd-12.10 {ConvertFileNameFormat} {longFileNames} {
cleanup
close [open td1 w]
- list [catch {file attributes td1 -shortname} msg] $msg [cleanup]
+ list [catch {string tolower [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]
+ list [catch {string tolower [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]
+ list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-15.1 {SetWinFileAttributes} {
diff --git a/contrib/tcl/tests/winPipe.test b/contrib/tcl/tests/winPipe.test
index af26db453720..483dfec9cc12 100644
--- a/contrib/tcl/tests/winPipe.test
+++ b/contrib/tcl/tests/winPipe.test
@@ -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.
#
-# SCCS: @(#) winPipe.test 1.7 97/06/23 17:30:41
+# SCCS: @(#) winPipe.test 1.9 97/08/05 11:44:28
if {$tcl_platform(platform) != "windows"} {
return
@@ -51,7 +51,7 @@ proc contents {file} {
set r
}
-if [file exists $cat32] {
+if {$testConfig(stdio) && [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]
@@ -166,15 +166,19 @@ test winpipe-1.25 {32 bit comprehensive tests: to socket} {
} {}
}
+set stderr16 "stderr16"
+if {$tcl_platform(os) == "Win32s"} {
+ set stderr16 "{}"
+}
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"
+} "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"
+} "{$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]
@@ -210,21 +214,21 @@ test winpipe-2.11 {16 bit comprehensive tests: from file handle} {
exec $cat16 <@$f > stdout 2> stderr
close $f
list [contents stdout] [contents stderr]
-} "little stderr16"
+} "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}
+} "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"
+} "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"
+} "{$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]
@@ -244,7 +248,7 @@ test winpipe-2.18 {16 bit comprehensive tests: a lot to pipe} {95} {
test winpipe-2.19 {16 bit comprehensive tests: to console} {
catch {exec $cat16 << "You should see this\n" >@stdout} msg
set msg
-} stderr16
+} [lindex $stderr16 0]
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
@@ -260,8 +264,8 @@ test winpipe-2.22 {16 bit comprehensive tests: to file handle} {
close $f1
close $f2
list [contents stdout] [contents stderr]
-} "little stderr16"
-test winpipe-2.23 {16 bit comprehensive tests: write to application} {
+} "little $stderr16"
+test winpipe-2.23 {16 bit comprehensive tests: write to application} {!win32s} {
set f [open "|$cat16 > stdout" w]
puts -nonewline $f "foo"
catch {close $f} msg
@@ -281,3 +285,5 @@ test winpipe-2.25 {16 bit comprehensive tests: to socket} {
} {}
}
+file delete big little
+