aboutsummaryrefslogtreecommitdiffstats
path: root/contrib/tcl/tests
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/tcl/tests')
-rw-r--r--contrib/tcl/tests/append.test18
-rw-r--r--contrib/tcl/tests/basic.test7
-rw-r--r--contrib/tcl/tests/binary.test99
-rw-r--r--contrib/tcl/tests/clock.test30
-rw-r--r--contrib/tcl/tests/cmdIL.test41
-rw-r--r--contrib/tcl/tests/env.test41
-rw-r--r--contrib/tcl/tests/expr-old.test24
-rw-r--r--contrib/tcl/tests/expr.test45
-rw-r--r--contrib/tcl/tests/fCmd.test50
-rw-r--r--contrib/tcl/tests/fileName.test28
-rw-r--r--contrib/tcl/tests/format.test22
-rw-r--r--contrib/tcl/tests/get.test55
-rw-r--r--contrib/tcl/tests/init.test149
-rw-r--r--contrib/tcl/tests/interp.test95
-rw-r--r--contrib/tcl/tests/io.test73
-rw-r--r--contrib/tcl/tests/ioCmd.test6
-rw-r--r--contrib/tcl/tests/join.test12
-rw-r--r--contrib/tcl/tests/linsert.test13
-rw-r--r--contrib/tcl/tests/lreplace.test11
-rw-r--r--contrib/tcl/tests/obj.test6
-rw-r--r--contrib/tcl/tests/opt.test37
-rw-r--r--contrib/tcl/tests/resource.test196
-rw-r--r--contrib/tcl/tests/safe.test50
-rw-r--r--contrib/tcl/tests/set-old.test154
-rw-r--r--contrib/tcl/tests/socket.test6
-rw-r--r--contrib/tcl/tests/source.test11
-rw-r--r--contrib/tcl/tests/unixFCmd.test23
-rw-r--r--contrib/tcl/tests/unixNotfy.test11
-rw-r--r--contrib/tcl/tests/upvar.test14
-rw-r--r--contrib/tcl/tests/winFCmd.test17
-rw-r--r--contrib/tcl/tests/winPipe.test86
31 files changed, 1220 insertions, 210 deletions
diff --git a/contrib/tcl/tests/append.test b/contrib/tcl/tests/append.test
index 6733454ee100..f89ade5bd4c9 100644
--- a/contrib/tcl/tests/append.test
+++ b/contrib/tcl/tests/append.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) append.test 1.16 97/04/09 11:29:33
+# SCCS: @(#) append.test 1.17 97/10/28 15:45:52
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -156,3 +156,19 @@ test append-6.2 {lappend errors} {
set x ""
list [catch {lappend x(0) 44} msg] $msg
} {1 {can't set "x(0)": variable isn't array}}
+
+test append-7.1 {lappend-created var and error in trace on that var} {
+ catch {rename foo ""}
+ catch {unset x}
+ trace variable x w foo
+ proc foo {} {global x; unset x}
+ catch {lappend x 1}
+ proc foo {args} {global x; unset x}
+ info exists x
+ set x
+ lappend x 1
+ list [info exists x] [catch {set x} msg] $msg
+} {0 1 {can't read "x": no such variable}}
+
+catch {unset x}
+catch {rename foo ""}
diff --git a/contrib/tcl/tests/basic.test b/contrib/tcl/tests/basic.test
index a0b6ea0b2fef..502e3e5f4d55 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.18 97/08/07 10:36:59
+# SCCS: @(#) basic.test 1.19 97/10/31 16:02:26
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -381,8 +381,11 @@ test basic-11.1 {TclObjInvoke, lookup of "unknown" command} {
} {newAlias 0 {global unknown} {}}
test basic-12.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
- testcmdtrace {set stuff [info tclversion]}
+ testcmdtrace tracetest {set stuff [info tclversion]}
} {{info tclversion} {info tclversion} {set stuff [info tclversion]} {set stuff 8.0}}
+test basic-12.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
+ testcmdtrace deletetest {set stuff [info tclversion]}
+} 8.0
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {namespace delete george}
diff --git a/contrib/tcl/tests/binary.test b/contrib/tcl/tests/binary.test
index f64b2bbd75e4..dcc5cf640fc3 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.10 97/08/06 08:56:11
+# SCCS: @(#) binary.test 1.13 97/09/11 18:50:30
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -443,18 +443,24 @@ test binary-13.12 {Tcl_BinaryObjCmd: float overflow} {nonPortable macOrUnix} {
test binary-13.13 {Tcl_BinaryObjCmd: float overflow} {nonPortable pcOnly} {
binary format f -3.402825e+38
} \xff\xff\x7f\xff
-test binary-13.14 {Tcl_BinaryObjCmd: format} {
+test binary-13.14 {Tcl_BinaryObjCmd: float underflow} {nonPortable macOrUnix} {
+ binary format f -3.402825e-100
+} \x80\x00\x00\x00
+test binary-13.15 {Tcl_BinaryObjCmd: float underflow} {nonPortable pcOnly} {
+ binary format f -3.402825e-100
+} \x00\x00\x00\x80
+test binary-13.16 {Tcl_BinaryObjCmd: format} {
list [catch {binary format f2 {1.6}} msg] $msg
} {1 {number of elements in list does not match count}}
-test binary-13.15 {Tcl_BinaryObjCmd: format} {
+test binary-13.17 {Tcl_BinaryObjCmd: format} {
set a {1.6 3.4}
list [catch {binary format f $a} msg] $msg
} [list 1 "expected floating-point number but got \"1.6 3.4\""]
-test binary-13.16 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+test binary-13.18 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
set a {1.6 3.4}
binary format f1 $a
} \x3f\xcc\xcc\xcd
-test binary-13.17 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+test binary-13.19 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
set a {1.6 3.4}
binary format f1 $a
} \xcd\xcc\xcc\x3f
@@ -1312,7 +1318,7 @@ test binary-37.8 {GetFormatSpec: numbers} {
set arg1 foo
list [binary scan abcdef "a0x3" arg1] $arg1
} {1 {}}
-test binary-37.8 {GetFormatSpec: numbers} {
+test binary-37.9 {GetFormatSpec: numbers} {
# test format of neg numbers
# bug report/fix provided by Harald Kirsch
set x [binary format f* {1 -1 2 -2 0}]
@@ -1320,37 +1326,61 @@ test binary-37.8 {GetFormatSpec: numbers} {
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} {
+test binary-38.1 {FormatNumber: word alignment} {
+ set x [binary format c1s1 1 1]
+} \x01\x01\x00
+test binary-38.2 {FormatNumber: word alignment} {
+ set x [binary format c1S1 1 1]
+} \x01\x00\x01
+test binary-38.3 {FormatNumber: word alignment} {
+ set x [binary format c1i1 1 1]
+} \x01\x01\x00\x00\x00
+test binary-38.4 {FormatNumber: word alignment} {
+ set x [binary format c1I1 1 1]
+} \x01\x00\x00\x00\x01
+test binary-38.5 {FormatNumber: word alignment} {nonPortable macOrUnix} {
+ set x [binary format c1d1 1 1.6]
+} \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a
+test binary-38.6 {FormatNumber: word alignment} {nonPortable pcOnly} {
+ set x [binary format c1d1 1 1.6]
+} \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f
+test binary-38.7 {FormatNumber: word alignment} {nonPortable macOrUnix} {
+ set x [binary format c1f1 1 1.6]
+} \x01\x3f\xcc\xcc\xcd
+test binary-38.8 {FormatNumber: word alignment} {nonPortable pcOnly} {
+ set x [binary format c1f1 1 1.6]
+} \x01\xcd\xcc\xcc\x3f
+
+test binary-39.1 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x52\xa3 c2 arg1] $arg1
} {1 {82 -93}}
-test binary-38.2 {ScanNumber: sign extension} {
+test binary-39.2 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 s4 arg1] $arg1
} {1 {513 -32511 386 -32127}}
-test binary-38.3 {ScanNumber: sign extension} {
+test binary-39.3 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 S4 arg1] $arg1
} {1 {258 385 -32255 -32382}}
-test binary-38.4 {ScanNumber: sign extension} {
+test binary-39.4 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 i5 arg1] $arg1
} {1 {33620225 16843137 16876033 25297153 -2130640639}}
-test binary-38.5 {ScanNumber: sign extension} {
+test binary-39.5 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 I5 arg1] $arg1
} {1 {16843010 -2130640639 25297153 16876033 16843137}}
-test binary-39.1 {ScanNumber: floating point overflow} {nonPortable unixOnly} {
+test binary-40.1 {ScanNumber: floating point overflow} {nonPortable unixOnly} {
catch {unset arg1}
list [binary scan \xff\xff\xff\xff f1 arg1] $arg1
} {1 -NaN}
-test binary-39.2 {ScanNumber: floating point overflow} {nonPortable macOnly} {
+test binary-40.2 {ScanNumber: floating point overflow} {nonPortable macOnly} {
catch {unset arg1}
list [binary scan \xff\xff\xff\xff f1 arg1] $arg1
} {1 -NAN(255)}
-test binary-39.3 {ScanNumber: floating point overflow} {nonPortable pcOnly} {
+test binary-40.3 {ScanNumber: floating point overflow} {nonPortable pcOnly} {
catch {unset arg1}
set result [binary scan \xff\xff\xff\xff f1 arg1]
if {([string compare $arg1 -1.\#QNAN] == 0)
@@ -1360,15 +1390,15 @@ test binary-39.3 {ScanNumber: floating point overflow} {nonPortable pcOnly} {
lappend result failure
}
} {1 success}
-test binary-39.4 {ScanNumber: floating point overflow} {nonPortable unixOnly} {
+test binary-40.4 {ScanNumber: floating point overflow} {nonPortable unixOnly} {
catch {unset arg1}
list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1] $arg1
} {1 -NaN}
-test binary-39.5 {ScanNumber: floating point overflow} {nonPortable macOnly} {
+test binary-40.5 {ScanNumber: floating point overflow} {nonPortable macOnly} {
catch {unset arg1}
list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1] $arg1
} {1 -NAN(255)}
-test binary-39.6 {ScanNumber: floating point overflow} {nonPortable pcOnly} {
+test binary-40.6 {ScanNumber: floating point overflow} {nonPortable pcOnly} {
catch {unset arg1}
set result [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1]
if {([string compare $arg1 -1.\#QNAN] == 0)
@@ -1378,3 +1408,36 @@ test binary-39.6 {ScanNumber: floating point overflow} {nonPortable pcOnly} {
lappend result failure
}
} {1 success}
+
+test binary-41.1 {ScanNumber: word alignment} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\x01\x00 c1s1 arg1 arg2] $arg1 $arg2
+} {2 1 1}
+test binary-41.2 {ScanNumber: word alignment} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\x00\x01 c1S1 arg1 arg2] $arg1 $arg2
+} {2 1 1}
+test binary-41.3 {ScanNumber: word alignment} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\x01\x00\x00\x00 c1i1 arg1 arg2] $arg1 $arg2
+} {2 1 1}
+test binary-41.4 {ScanNumber: word alignment} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\x00\x00\x00\x01 c1I1 arg1 arg2] $arg1 $arg2
+} {2 1 1}
+test binary-41.5 {ScanNumber: word alignment} {nonPortable macOrUnix} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2
+} {2 1 1.60000002384}
+test binary-41.6 {ScanNumber: word alignment} {nonPortable pcOnly} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2
+} {2 1 1.60000002384}
+test binary-41.7 {ScanNumber: word alignment} {nonPortable macOrUnix} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2
+} {2 1 1.6}
+test binary-41.8 {ScanNumber: word alignment} {nonPortable pcOnly} {
+ catch {unset arg1; unset arg2}
+ list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2
+} {2 1 1.6}
diff --git a/contrib/tcl/tests/clock.test b/contrib/tcl/tests/clock.test
index b75ee32f4b24..95f73ac3cbaa 100644
--- a/contrib/tcl/tests/clock.test
+++ b/contrib/tcl/tests/clock.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: @(#) clock.test 1.14 97/06/02 10:18:12
+# SCCS: @(#) clock.test 1.17 97/11/24 15:05:38
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -145,3 +145,31 @@ test clock-6.4 {clock roll over dates} {
set time [clock scan "2/29/2000" -gmt true]
clock format [expr $time + $day] -format {%b %d,%Y %H:%M GMT} -gmt true
} {Mar 01,2000 00:00 GMT}
+test clock-6.5 {clock roll over dates} {
+ set time [clock scan "January 1, 2000" -gmt true]
+ clock format $time -format %A -gmt true
+} {Saturday}
+test clock-6.6 {clock roll over dates} {
+ set time [clock scan "January 1, 2000" -gmt true]
+ clock format $time -format %j -gmt true
+} {001}
+test clock-6.7 {clock roll over dates} {
+ set time [clock scan "February 29, 2000" -gmt true]
+ clock format $time -format %A -gmt true
+} {Tuesday}
+test clock-6.8 {clock roll over dates} {
+ set time [clock scan "February 29, 2000" -gmt true]
+ clock format $time -format %j -gmt true
+} {060}
+test clock-6.9 {clock roll over dates} {
+ set time [clock scan "March 1, 2000" -gmt true]
+ clock format $time -format %A -gmt true
+} {Wednesday}
+test clock-6.10 {clock roll over dates} {
+ set time [clock scan "March 1, 2000" -gmt true]
+ clock format $time -format %j -gmt true
+} {061}
+test clock-6.11 {clock roll over dates} {
+ set time [clock scan "March 1, 2001" -gmt true]
+ clock format $time -format %j -gmt true
+} {060}
diff --git a/contrib/tcl/tests/cmdIL.test b/contrib/tcl/tests/cmdIL.test
index ceeb86b0dc81..5b561054addc 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.17 97/07/11 15:33:16
+# SCCS: @(#) cmdIL.test 1.18 97/09/18 11:42:12
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -194,57 +194,60 @@ test cmdIL-4.3 {DictionaryCompare procedure, numerics, leading zeros} {
test cmdIL-4.4 {DictionaryCompare procedure, numerics, leading zeros} {
lsort -dictionary {a3b a03B}
} {a3b a03B}
-test cmdIL-4.5 {DictionaryCompare procedure, numerics, different lengths} {
+test cmdIL-4.5 {DictionaryCompare procedure, numerics, leading zeros} {
+ lsort -dictionary {00000 000}
+} {000 00000}
+test cmdIL-4.6 {DictionaryCompare procedure, numerics, different lengths} {
lsort -dictionary {a321b a03210b}
} {a321b a03210b}
-test cmdIL-4.6 {DictionaryCompare procedure, numerics, different lengths} {
+test cmdIL-4.7 {DictionaryCompare procedure, numerics, different lengths} {
lsort -dictionary {a03210b a321b}
} {a321b a03210b}
-test cmdIL-4.7 {DictionaryCompare procedure, numerics} {
+test cmdIL-4.8 {DictionaryCompare procedure, numerics} {
lsort -dictionary {48 6a 18b 22a 21aa 35 36}
} {6a 18b 21aa 22a 35 36 48}
-test cmdIL-4.8 {DictionaryCompare procedure, numerics} {
+test cmdIL-4.9 {DictionaryCompare procedure, numerics} {
lsort -dictionary {a123x a123b}
} {a123b a123x}
-test cmdIL-4.9 {DictionaryCompare procedure, numerics} {
+test cmdIL-4.10 {DictionaryCompare procedure, numerics} {
lsort -dictionary {a123b a123x}
} {a123b a123x}
-test cmdIL-4.10 {DictionaryCompare procedure, numerics} {
+test cmdIL-4.11 {DictionaryCompare procedure, numerics} {
lsort -dictionary {a1b aab}
} {a1b aab}
-test cmdIL-4.11 {DictionaryCompare procedure, numerics} {
+test cmdIL-4.12 {DictionaryCompare procedure, numerics} {
lsort -dictionary {a1b a!b}
} {a!b a1b}
-test cmdIL-4.12 {DictionaryCompare procedure, numerics} {
+test cmdIL-4.13 {DictionaryCompare procedure, numerics} {
lsort -dictionary {a1b2c a1b1c}
} {a1b1c a1b2c}
-test cmdIL-4.13 {DictionaryCompare procedure, numerics} {
+test cmdIL-4.14 {DictionaryCompare procedure, numerics} {
lsort -dictionary {a1b2c a1b3c}
} {a1b2c a1b3c}
-test cmdIL-4.14 {DictionaryCompare procedure, long numbers} {
+test cmdIL-4.15 {DictionaryCompare procedure, long numbers} {
lsort -dictionary {a7654884321988762b a7654884321988761b}
} {a7654884321988761b a7654884321988762b}
-test cmdIL-4.15 {DictionaryCompare procedure, long numbers} {
+test cmdIL-4.16 {DictionaryCompare procedure, long numbers} {
lsort -dictionary {a8765488432198876b a7654884321988761b}
} {a7654884321988761b a8765488432198876b}
-test cmdIL-4.16 {DictionaryCompare procedure, case} {
+test cmdIL-4.17 {DictionaryCompare procedure, case} {
lsort -dictionary {aBCd abcc}
} {abcc aBCd}
-test cmdIL-4.17 {DictionaryCompare procedure, case} {
+test cmdIL-4.18 {DictionaryCompare procedure, case} {
lsort -dictionary {aBCd abce}
} {aBCd abce}
-test cmdIL-4.18 {DictionaryCompare procedure, case} {
+test cmdIL-4.19 {DictionaryCompare procedure, case} {
lsort -dictionary {abcd ABcc}
} {ABcc abcd}
-test cmdIL-4.19 {DictionaryCompare procedure, case} {
+test cmdIL-4.20 {DictionaryCompare procedure, case} {
lsort -dictionary {abcd ABce}
} {abcd ABce}
-test cmdIL-4.20 {DictionaryCompare procedure, case} {
+test cmdIL-4.21 {DictionaryCompare procedure, case} {
lsort -dictionary {abCD ABcd}
} {ABcd abCD}
-test cmdIL-4.21 {DictionaryCompare procedure, case} {
+test cmdIL-4.22 {DictionaryCompare procedure, case} {
lsort -dictionary {ABcd aBCd}
} {ABcd aBCd}
-test cmdIL-4.22 {DictionaryCompare procedure, case} {
+test cmdIL-4.23 {DictionaryCompare procedure, case} {
lsort -dictionary {ABcd AbCd}
} {ABcd AbCd}
diff --git a/contrib/tcl/tests/env.test b/contrib/tcl/tests/env.test
index e76ad7d58720..1bfc8ddaf1f3 100644
--- a/contrib/tcl/tests/env.test
+++ b/contrib/tcl/tests/env.test
@@ -10,10 +10,35 @@
# 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.13 97/08/05 11:40:30
+# SCCS: @(#) env.test 1.14 97/10/31 17:00:03
if {[string compare test [info procs test]] == 1} then {source defs}
+#
+# These tests will run on any platform (and indeed crashed
+# on the Mac). So put them before you test for the existance
+# of exec.
+#
+test env-1.1 {propagation of env values to child interpreters} {
+ catch {interp delete child}
+ catch {unset env(test)}
+ interp create child
+ set env(test) garbage
+ set return [child eval {set env(test)}]
+ interp delete child
+ unset env(test)
+ set return
+} {garbage}
+#
+# This one crashed on Solaris under Tcl8.0, so we only
+# want to make sure it runs.
+#
+test env-1.2 {lappend to env value} {
+ catch {unset env(test)}
+ set env(test) aaaaaaaaaaaaaaaa
+ append env(test) bbbbbbbbbbbbbb
+ unset env(test)
+} {}
if {[info commands exec] == ""} {
puts "exec not implemented for this machine"
return
@@ -76,42 +101,42 @@ foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH} {
}
}
-test env-1.1 {adding environment variables} {
+test env-2.1 {adding environment variables} {
getenv
} {}
set env(NAME1) "test string"
-test env-1.2 {adding environment variables} {
+test env-2.2 {adding environment variables} {
getenv
} {NAME1=test string}
set env(NAME2) "more"
-test env-1.3 {adding environment variables} {
+test env-2.3 {adding environment variables} {
getenv
} {NAME1=test string
NAME2=more}
set env(XYZZY) "garbage"
-test env-1.4 {adding environment variables} {
+test env-2.4 {adding environment variables} {
getenv
} {NAME1=test string
NAME2=more
XYZZY=garbage}
set env(NAME2) "new value"
-test env-2.1 {changing environment variables} {
+test env-3.1 {changing environment variables} {
getenv
} {NAME1=test string
NAME2=new value
XYZZY=garbage}
unset env(NAME2)
-test env-3.1 {unsetting environment variables} {
+test env-4.1 {unsetting environment variables} {
getenv
} {NAME1=test string
XYZZY=garbage}
unset env(NAME1)
-test env-3.2 {unsetting environment variables} {
+test env-4.2 {unsetting environment variables} {
getenv
} {XYZZY=garbage}
diff --git a/contrib/tcl/tests/expr-old.test b/contrib/tcl/tests/expr-old.test
index b2f577e6af4a..8fb8ad9f996c 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.61 97/08/13 10:26:38
+# SCCS: @(#) expr-old.test 1.63 97/10/31 17:23:24
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -78,6 +78,12 @@ test expr-old-1.49 {integer operators} {expr -36%-5} -1
test expr-old-1.50 {integer operators} {expr +36} 36
test expr-old-1.51 {integer operators} {expr +--++36} 36
test expr-old-1.52 {integer operators} {expr +36%+5} 1
+test expr-old-1.53 {integer operators} {
+ catch {unset x}
+ set x yes
+ list [expr {1 && $x}] [expr {$x && 1}] \
+ [expr {0 || $x}] [expr {$x || 0}]
+} {1 1 1 1}
# Check the floating-point operators individually, along with
# automatic conversion to integers where needed.
@@ -694,9 +700,19 @@ test expr-old-32.23 {math functions in expressions} {
test expr-old-32.24 {math functions in expressions} {
format %.6g [expr abs(66)]
} {66}
-test expr-old-32.25 {math functions in expressions} {nonPortable} {
- list [catch {expr abs(0x80000000)} msg] $msg
-} {1 {integer value too large to represent}}
+
+# The following test is different for 32-bit versus 64-bit architectures.
+
+if {0x80000000 > 0} {
+ test expr-old-32.25 {math functions in expressions} {nonPortable} {
+ list [catch {expr abs(0x8000000000000000)} msg] $msg
+ } {1 {integer value too large to represent}}
+} else {
+ test expr-old-32.25 {math functions in expressions} {nonPortable} {
+ list [catch {expr abs(0x80000000)} msg] $msg
+ } {1 {integer value too large to represent}}
+}
+
test expr-old-32.26 {math functions in expressions} {
expr double(1)
} {1.0}
diff --git a/contrib/tcl/tests/expr.test b/contrib/tcl/tests/expr.test
index e0825f971fa2..3c4779fc9b76 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.33 97/08/07 10:45:57
+# SCCS: @(#) expr.test 1.39 97/11/03 16:04:47
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -292,9 +292,19 @@ test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
-test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
- expr {1<<31}
-} -2147483648
+
+# The following test is different for 32-bit versus 64-bit
+# architectures because LONG_MIN is different
+
+if {0x80000000 > 0} {
+ test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
+ expr {1<<63}
+ } -9223372036854775808
+} else {
+ test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
+ expr {1<<31}
+ } -2147483648
+}
test expr-9.6 {CompileRelationalExpr: error in shift expr} {
catch {expr x>>3} msg
set msg
@@ -540,7 +550,11 @@ test expr-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} {
} {syntax error in expression "2+(3*(4+5)"
while executing
"expr 2+(3*(4+5)"}
-test expr-14.31 {CompilePrimaryExpr: unexpected token} {
+test expr-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} {
+ set i "5+10"
+ list "[expr $i] == 15" "[expr ($i)] == 15" "[eval expr ($i)] == 15"
+} {{15 == 15} {15 == 15} {15 == 15}}
+test expr-14.32 {CompilePrimaryExpr: unexpected token} {
catch {expr @} msg
set errorInfo
} {syntax error in expression "@"
@@ -602,9 +616,22 @@ if $gotT1 {
} -17.5
}
+test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
+ catch {unset a}
+ set a(VALUE) ff15
+ set i 123
+ if {[expr 0x$a(VALUE)] & 16} {
+ set i {}
+ }
+ set i
+} {}
+test expr-16.2 {GetToken: check for string literal in braces} {
+ expr {{1}}
+} {1}
+
# Check "expr" and computed command names.
-test expr-16.1 {expr and computed command names} {
+test expr-17.1 {expr and computed command names} {
set i 0
set z expr
$z 1+2
@@ -614,7 +641,7 @@ test expr-16.1 {expr and computed command names} {
# an integer, convert to integer. Otherwise, if the string looks like a
# double, convert to double.
-test expr-17.1 {expr and conversion of operands to numbers} {
+test expr-18.1 {expr and conversion of operands to numbers} {
set x [lindex 11 0]
catch {expr int($x)}
expr {$x}
@@ -623,7 +650,7 @@ test expr-17.1 {expr and conversion of operands to numbers} {
# Check "expr" and interpreter result object resetting before appending
# an error msg during evaluation of exprs not in {}s
-test expr-18.1 {expr and interpreter result object resetting} {
+test expr-19.1 {expr and interpreter result object resetting} {
proc p {} {
set t 10.0
set x 2.0
@@ -639,3 +666,5 @@ test expr-18.1 {expr and interpreter result object resetting} {
}
p
} 3
+
+unset a
diff --git a/contrib/tcl/tests/fCmd.test b/contrib/tcl/tests/fCmd.test
index e7d2279ef194..ae2b8b08cf9a 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.31 97/08/05 11:42:09
+# SCCS: @(#) fCmd.test 1.33 97/11/03 15:58:08
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -304,10 +304,15 @@ test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} {
file mkdir td1
list $x [file exist td1]
} {0 1}
-test fCmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {unixOnly nonPortable} {
+test fCmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {unixOnly} {
cleanup
- list [catch {file mkdir /tf1} msg] $msg
-} {1 {can't create directory "/tf1": permission denied}}
+ file delete -force foo
+ file mkdir foo
+ file attr foo -perm 040000
+ set result [list [catch {file mkdir foo/tf1} msg] $msg]
+ file delete -force foo
+ set result
+} {1 {can't create directory "foo/tf1": permission denied}}
test fCmd-4.15 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {macOnly} {
list [catch {file mkdir ${root}:} msg] $msg
} [subst {1 {can't create directory "${root}:": no such file or directory}}]
@@ -568,15 +573,17 @@ test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} {unixOnly xdev} {
file rename td1 /tmp
glob td* /tmp/td1/t*
} {/tmp/td1/td2}
-test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} {unixOnly nonPortable} {
+test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} {unixOnly} {
cleanup
- if [file exists /kernel] {
- set msg [list [catch {file rename /kernel td1} msg] $msg]
- set a1 {1 {can't unlink "/kernel": permission denied}}
- expr {$msg == $a1}
- } else {
- list 1
- }
+ file mkdir foo/bar
+ file attr foo -perm 040555
+ set msg [list [catch {file rename foo/bar /tmp} msg] $msg]
+ set a1 {1 {can't unlink "foo/bar": permission denied}}
+ set result [expr {$msg == $a1}]
+ catch {file delete /tmp/bar}
+ catch {file attr foo -perm 040777}
+ catch {file delete -force foo}
+ set result
} {1}
test fCmd-6.31 {CopyRenameOneFile: TclpDeleteFile passed} {unixOnly xdev} {
catch {cleanup /tmp}
@@ -618,15 +625,24 @@ test fCmd-7.5 {FileForceOption: multiple times through loop} {
list [catch {glob -- -- -force} msg] $msg
} {1 {no files matched glob patterns "-- -force"}}
-test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} {unixOnly nonPortable} {
- list [catch {file rename ~$user /} msg] $msg
-} "1 {error renaming \"~$user\" to \"/[file tail ~$user]\": permission denied}"
+test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} {unixOnly} {
+ file mkdir td1
+ file attr td1 -perm 040000
+ set result [list [catch {file rename ~$user td1} msg] $msg]
+ file delete -force td1
+ set result
+} "1 {error renaming \"~$user\" to \"td1/[file tail ~$user]\": permission denied}"
test fCmd-9.1 {file rename: comprehensive: EACCES} {unixOnly} {
cleanup
file mkdir td1
- list [catch {file rename td1 /} msg] $msg
-} {1 {error renaming "td1" to "/td1": permission denied}}
+ file mkdir td2
+ file attr td2 -perm 040000
+ set result [list [catch {file rename td1 td2/} msg] $msg]
+ file delete -force td2
+ file delete -force td1
+ set result
+} {1 {error renaming "td1" to "td2/td1": permission denied}}
test fCmd-9.2 {file rename: comprehensive: source doesn't exist} {
cleanup
list [catch {file rename tf1 tf2} msg] $msg
diff --git a/contrib/tcl/tests/fileName.test b/contrib/tcl/tests/fileName.test
index f6be5acc3550..e0f7260f2cee 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.30 97/08/01 11:13:27
+# SCCS: @(#) fileName.test 1.31 97/08/19 18:45:07
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -1313,16 +1313,30 @@ if {$tcl_platform(platform) == "unix"} {
# On some systems, like AFS, "000" protection doesn't prevent
# access by owner, so the following test is not portable.
- exec chmod 000 globTest
+ exec chmod 000 globTest/a1
test filename-15.1 {unix specific globbing} {nonPortable} {
- 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} {
+ string tolower [list [catch {glob globTest/a1/*} msg] $msg $errorCode]
+ } {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}}
+ test filename-15.2 {unix specific no complain: no errors} {nonPortable} {
+ glob -nocomplain globTest/a1/*
+ } {}
+ test filename-15.3 {unix specific no complain: no errors, good result} {nonPortable knownBug} {
+ # test fails because if an error occur , the interp's result
+ # is reset...
+ glob -nocomplain globTest/a2 globTest/a1/* globTest/a3
+ } {globTest/a2 globTest/a3}
+ exec chmod 755 globTest/a1
+ test filename-15.4 {unix specific no complain: no errors, good result} {nonPortable knownBug} {
+ # test fails because if an error occur , the interp's result
+ # is reset... (or you don't run at sunscript where the
+ # outser and demailly's users exists
+ glob -nocomplain ~ouster ~foo ~demailly
+ } {/home/ouster /home/demailly}
+ test filename-15.5 {unix specific globbing} {nonPortable} {
glob ~ouster/.csh*
} "/home/ouster/.cshrc"
close [open globTest/odd\\\[\]*?\{\}name w]
- test filename-15.3 {unix specific globbing} {
+ test filename-15.6 {unix specific globbing} {
global env
set temp $env(HOME)
set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name
diff --git a/contrib/tcl/tests/format.test b/contrib/tcl/tests/format.test
index 680b626af0b0..758825ba293c 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.28 97/08/11 14:45:15
+# SCCS: @(#) format.test 1.29 97/09/03 15:51:02
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -411,6 +411,26 @@ test format-12.5 {tcl_precision fuzzy comparison} {
set c [expr $a + $b]
format {%0.10f %0.12f %0.15f} $c $c $c
} {1.4444444444 1.444444444444 1.444444444443990}
+test format-13.1 {testing MAX_FLOAT_SIZE for 0 and 1} {
+ format {%s} ""
+} {}
+test format-13.2 {testing MAX_FLOAT_SIZE for 0 and 1} {
+ format {%s} "a"
+} {a}
+
+set a "0123456789"
+set b ""
+for {set i 0} {$i < 290} {incr i} {
+ append b $a
+}
+for {set i 290} {$i < 400} {incr i} {
+ test format-14.[expr $i -290] {testing MAX_FLOAT_SIZE} {
+ format {%s} $b
+ } $b
+ append b "x"
+}
+
+
catch {unset a}
catch {unset b}
catch {unset c}
diff --git a/contrib/tcl/tests/get.test b/contrib/tcl/tests/get.test
index 50e68bb03112..5155b95e2d3d 100644
--- a/contrib/tcl/tests/get.test
+++ b/contrib/tcl/tests/get.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) get.test 1.6 96/10/08 17:39:21
+# SCCS: @(#) get.test 1.7 97/10/31 17:23:00
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -39,24 +39,43 @@ test get-1.6 {Tcl_GetInt procedure} {
} {1 {expected integer but got "16 x"}}
# The following tests are non-portable because they depend on
-# word size.
+# word size. 18446744073709551614
-test get-1.7 {Tcl_GetInt procedure} {nonPortable unixOnly} {
- set x 44
- list [catch {incr x 4294967296} msg] $msg $errorCode
-} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
-test get-1.8 {Tcl_GetInt procedure} {nonPortable} {
- set x 0
- list [catch {incr x 4294967294} msg] $msg
-} {0 -2}
-test get-1.9 {Tcl_GetInt procedure} {nonPortable} {
- set x 0
- list [catch {incr x +4294967294} msg] $msg
-} {0 -2}
-test get-1.10 {Tcl_GetInt procedure} {nonPortable} {
- set x 0
- list [catch {incr x -4294967294} msg] $msg
-} {0 2}
+if {0x80000000 > 0} {
+ test get-1.7 {Tcl_GetInt procedure} {nonPortable unixOnly} {
+ set x 44
+ list [catch {incr x 18446744073709551616} msg] $msg $errorCode
+ } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
+ test get-1.8 {Tcl_GetInt procedure} {nonPortable} {
+ set x 0
+ list [catch {incr x 18446744073709551614} msg] $msg
+ } {0 -2}
+ test get-1.9 {Tcl_GetInt procedure} {nonPortable} {
+ set x 0
+ list [catch {incr x +18446744073709551614} msg] $msg
+ } {0 -2}
+ test get-1.10 {Tcl_GetInt procedure} {nonPortable} {
+ set x 0
+ list [catch {incr x -18446744073709551614} msg] $msg
+ } {0 2}
+} else {
+ test get-1.7 {Tcl_GetInt procedure} {nonPortable unixOnly} {
+ set x 44
+ list [catch {incr x 4294967296} msg] $msg $errorCode
+ } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
+ test get-1.8 {Tcl_GetInt procedure} {nonPortable} {
+ set x 0
+ list [catch {incr x 4294967294} msg] $msg
+ } {0 -2}
+ test get-1.9 {Tcl_GetInt procedure} {nonPortable} {
+ set x 0
+ list [catch {incr x +4294967294} msg] $msg
+ } {0 -2}
+ test get-1.10 {Tcl_GetInt procedure} {nonPortable} {
+ set x 0
+ list [catch {incr x -4294967294} msg] $msg
+ } {0 2}
+}
test get-2.1 {Tcl_GetInt procedure} {
format %g 1.23
diff --git a/contrib/tcl/tests/init.test b/contrib/tcl/tests/init.test
new file mode 100644
index 000000000000..2d6e068412b6
--- /dev/null
+++ b/contrib/tcl/tests/init.test
@@ -0,0 +1,149 @@
+# Functionality covered: this file contains a collection of tests for the
+# auto loading and namespaces.
+#
+# Sourcing this file into Tcl runs the tests and generates output for
+# errors. No output means no errors were found.
+#
+# Copyright (c) 1997 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# SCCS: @(#) init.test 1.5 97/11/19 18:08:20
+
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+# Clear out any namespaces called test_ns_*
+catch {eval namespace delete [namespace children :: test_ns_*]}
+
+# Six cases - white box testing
+
+test init-1.1 {auto_qualify - absolute cmd - namespace} {
+ auto_qualify ::foo::bar ::blue
+} ::foo::bar
+
+test init-1.2 {auto_qualify - absolute cmd - global} {
+ auto_qualify ::global ::sub
+} global
+
+test init-1.3 {auto_qualify - no colons cmd - global} {
+ auto_qualify nocolons ::
+} nocolons
+
+test init-1.4 {auto_qualify - no colons cmd - namespace} {
+ auto_qualify nocolons ::sub
+} {::sub::nocolons nocolons}
+
+test init-1.5 {auto_qualify - colons in cmd - global} {
+ auto_qualify foo::bar ::
+} ::foo::bar
+
+test init-1.6 {auto_qualify - colons in cmd - namespace} {
+ auto_qualify foo::bar ::sub
+} {::sub::foo::bar ::foo::bar}
+
+# Some additional tests
+
+test init-1.7 {auto_qualify - multiples colons 1} {
+ auto_qualify :::foo::::bar ::blue
+} ::foo::bar
+
+test init-1.8 {auto_qualify - multiple colons 2} {
+ auto_qualify :::foo ::bar
+} foo
+
+
+# we use a sub interp and auto_reset and double the tests because there is 2
+# places where auto_loading occur (before loading the indexes files and after)
+
+set testInterp [interp create]
+interp eval $testInterp [list set VERBOSE $VERBOSE]
+interp eval $testInterp [list set TESTS $TESTS]
+
+interp eval $testInterp {
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+auto_reset
+catch {rename parray {}}
+
+test init-2.0 {load parray - stage 1} {
+ set ret [catch {namespace eval ::test {parray}} error]
+ rename parray {} ; # remove it, for the next test - that should not fail.
+ list $ret $error
+} {1 {no value given for parameter "a" to "parray"}}
+
+
+test init-2.1 {load parray - stage 2} {
+ set ret [catch {namespace eval ::test {parray}} error]
+ list $ret $error
+} {1 {no value given for parameter "a" to "parray"}}
+
+
+auto_reset
+catch {rename ::safe::setLogCmd {}}
+#unset auto_index(::safe::setLogCmd)
+#unset auto_oldpath
+
+test init-2.2 {load ::safe::setLogCmd - stage 1} {
+ ::safe::setLogCmd
+ rename ::safe::setLogCmd {} ; # should not fail
+} {}
+
+test init-2.3 {load ::safe::setLogCmd - stage 2} {
+ ::safe::setLogCmd
+ rename ::safe::setLogCmd {} ; # should not fail
+} {}
+
+auto_reset
+catch {rename ::safe::setLogCmd {}}
+
+test init-2.4 {load safe:::setLogCmd - stage 1} {
+ safe:::setLogCmd ; # intentionally 3 :
+ rename ::safe::setLogCmd {} ; # should not fail
+} {}
+
+test init-2.5 {load safe:::setLogCmd - stage 2} {
+ safe:::setLogCmd ; # intentionally 3 :
+ rename ::safe::setLogCmd {} ; # should not fail
+} {}
+
+auto_reset
+catch {rename ::safe::setLogCmd {}}
+
+test init-2.6 {load setLogCmd from safe:: - stage 1} {
+ namespace eval safe setLogCmd
+ rename ::safe::setLogCmd {} ; # should not fail
+} {}
+
+test init-2.7 {oad setLogCmd from safe:: - stage 2} {
+ namespace eval safe setLogCmd
+ rename ::safe::setLogCmd {} ; # should not fail
+} {}
+
+
+auto_reset
+package require http 2.0
+catch {rename ::http::geturl {}}
+
+test init-2.8 {load http::geturl (package)} {
+ # 3 ':' on purpose
+ set ret [catch {namespace eval ::test {http:::geturl}} error]
+ # removing it, for the next test. should not fail.
+ rename ::http::geturl {} ;
+ list $ret $error
+} {1 {no value given for parameter "url" to "http:::geturl"}}
+
+
+test init-3.0 {random stuff in the auto_index, should still work} {
+ set auto_index(foo:::bar::blah) {
+ namespace eval foo {namespace eval bar {proc blah {} {return 1}}}
+ }
+ foo:::bar::blah
+} 1
+
+}
+
+interp delete $testInterp
+
diff --git a/contrib/tcl/tests/interp.test b/contrib/tcl/tests/interp.test
index 9127bcb54bcf..919774f7bb32 100644
--- a/contrib/tcl/tests/interp.test
+++ b/contrib/tcl/tests/interp.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: @(#) interp.test 1.61 97/08/04 19:59:52
+# SCCS: @(#) interp.test 1.64 97/09/04 16:02:23
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -1974,6 +1974,43 @@ test interp-26.2 {result code transmission 2} {knownBug} {
list $res
} {-1 0 1 2 3 4 5}
+test interp-26.3 {errorInfo transmission : regular interps} {
+ set interp [interp create];
+ proc MyError {secret} {
+ return -code error "msg"
+ }
+ proc MyTestAlias {interp args} {
+ MyError "some secret"
+ }
+ interp alias $interp test {} MyTestAlias $interp;
+ set res [interp eval $interp {catch test;set errorInfo}]
+ interp delete $interp;
+ set res
+} {msg
+ while executing
+"MyError "some secret""
+ (procedure "test" line 2)
+ invoked from within
+"catch test"}
+
+test interp-26.4 {errorInfo transmission : safe interps} {knownBug} {
+ # this test fails because the errorInfo is fully transmitted
+ # whether the interp is safe or not. this is maybe a feature
+ # and not a bug.
+ set interp [interp create -safe];
+ proc MyError {secret} {
+ return -code error "msg"
+ }
+ proc MyTestAlias {interp args} {
+ MyError "some secret"
+ }
+ interp alias $interp test {} MyTestAlias $interp;
+ set res [interp eval $interp {catch test;set errorInfo}]
+ interp delete $interp;
+ set res
+} {msg
+ while executing
+"catch test"}
# Interps & Namespaces
test interp-27.1 {interp aliases & namespaces} {
@@ -2153,12 +2190,68 @@ test interp-28.1 {getting fooled by slave's namespace ?} {
set r
} {}
+# Tests of recursionlimit
+# We need testsetrecursionlimit so we need Tcltest package
+if {[catch {package require Tcltest} msg]} {
+ puts "This application hasn't been compiled with Tcltest"
+ puts "skipping remining interp tests that relies on it."
+} else {
+ #
+test interp-29.1 {recursion limit} {
+ set i [interp create]
+ load {} Tcltest $i
+ set r [interp eval $i {
+ testsetrecursionlimit 50
+ proc p {} {incr ::i; p}
+ set i 0
+ catch p
+ set i
+ }]
+ interp delete $i
+ set r
+} 49
+
+test interp-29.2 {recursion limit inheritance} {
+ set i [interp create]
+ load {} Tcltest $i
+ set ii [interp eval $i {
+ testsetrecursionlimit 50
+ interp create
+ }]
+ set r [interp eval [list $i $ii] {
+ proc p {} {incr ::i; p}
+ set i 0
+ catch p
+ set i
+ }]
+ interp delete $i
+ set r
+} 49
+
+# # Deep recursion (into interps when the regular one fails):
+# # still crashes...
+# proc p {} {
+# if {[catch p ret]} {
+# catch {
+# set i [interp create]
+# interp eval $i [list proc p {} [info body p]]
+# interp eval $i p
+# }
+# interp delete $i
+# return ok
+# }
+# return $ret
+# }
+# p
+
# 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 739248281a6d..2b6670fb9e20 100644
--- a/contrib/tcl/tests/io.test
+++ b/contrib/tcl/tests/io.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: @(#) io.test 1.128 97/08/13 10:24:56
+# SCCS: @(#) io.test 1.131 97/09/22 11:15:05
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -3439,6 +3439,58 @@ test io-16.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
close $f
set x
} 40000
+test io-16.14 {Tcl_SetChannelOption, setting read mode independently} \
+ {socket} {
+ proc accept {s a p} {close $s}
+ set s1 [socket -server accept 0]
+ set port [lindex [fconfigure $s1 -sockname] 2]
+ set s2 [socket localhost $port]
+ update
+ fconfigure $s2 -translation {auto lf}
+ set modes [fconfigure $s2 -translation]
+ close $s1
+ close $s2
+ set modes
+} {auto lf}
+test io-16.15 {Tcl_SetChannelOption, setting read mode independently} \
+ {socket} {
+ proc accept {s a p} {close $s}
+ set s1 [socket -server accept 0]
+ set port [lindex [fconfigure $s1 -sockname] 2]
+ set s2 [socket localhost $port]
+ update
+ fconfigure $s2 -translation {auto crlf}
+ set modes [fconfigure $s2 -translation]
+ close $s1
+ close $s2
+ set modes
+} {auto crlf}
+test io-16.16 {Tcl_SetChannelOption, setting read mode independently} \
+ {socket} {
+ proc accept {s a p} {close $s}
+ set s1 [socket -server accept 0]
+ set port [lindex [fconfigure $s1 -sockname] 2]
+ set s2 [socket localhost $port]
+ update
+ fconfigure $s2 -translation {auto cr}
+ set modes [fconfigure $s2 -translation]
+ close $s1
+ close $s2
+ set modes
+} {auto cr}
+test io-16.17 {Tcl_SetChannelOption, setting read mode independently} \
+ {socket} {
+ proc accept {s a p} {close $s}
+ set s1 [socket -server accept 0]
+ set port [lindex [fconfigure $s1 -sockname] 2]
+ set s2 [socket localhost $port]
+ update
+ fconfigure $s2 -translation {auto auto}
+ set modes [fconfigure $s2 -translation]
+ close $s1
+ close $s2
+ set modes
+} {auto crlf}
test io-17.1 {POSIX open access modes: RDWR} {
removeFile test3
@@ -5054,6 +5106,25 @@ test io-32.1 {ChannelEventScriptInvoker: deletion} {
set x
} {got_error}
+test io-33.1 {ChannelTimerProc} {
+ set f [open fooBar w]
+ puts $f "this is a test"
+ close $f
+ set f [open fooBar r]
+ testchannelevent $f add readable {
+ read $f 1
+ incr x
+ }
+ set x 0
+ vwait x
+ vwait x
+ set result $x
+ testchannelevent $f set 0 none
+ after idle {set y done}
+ vwait y
+ lappend result $y
+} {2 done}
+
removeFile fooBar
removeFile longfile
removeFile script
diff --git a/contrib/tcl/tests/ioCmd.test b/contrib/tcl/tests/ioCmd.test
index 95a5975594e4..fd39263a0ed4 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.48 97/08/01 11:11:23"
+# "@(#) ioCmd.test 1.49 97/10/31 17:23:22"
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -281,11 +281,11 @@ test iocmd-8.17 {fconfigure command / tcp channel} {nonPortable} {
update;
puts $cli "blah"; flush $cli; # that flush could/should fail too
update;
- set r [list [catch {fconfigure $cli -peername} msg] $msg];
+ set r [catch {fconfigure $cli -peername} msg]
iocmdSSHTDWN
regsub -all {can([^:])+: } $r {} r;
set r
-} {1 {connection reset by peer}}
+} 1
test iocmd-8.18 {fconfigure command / unix tty channel} {nonPortable unixOnly} {
# might fail if /dev/ttya is unavailable
set tty [open /dev/ttya]
diff --git a/contrib/tcl/tests/join.test b/contrib/tcl/tests/join.test
index 4023de2cab6a..62af644fa088 100644
--- a/contrib/tcl/tests/join.test
+++ b/contrib/tcl/tests/join.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: @(#) join.test 1.6 96/02/16 08:56:02
+# SCCS: @(#) join.test 1.7 97/10/06 13:04:59
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -36,3 +36,13 @@ test join-2.2 {join errors} {
test join-2.3 {join errors} {
list [catch {join "a \{ c" 111} msg] $msg $errorCode
} {1 {unmatched open brace in list} NONE}
+
+test join-3.1 {joinString is binary ok} {
+ string length [join {a b c} a\0b]
+} 9
+
+test join-3.2 {join is binary ok} {
+ string length [join "a\0b a\0b a\0b"]
+} 11
+
+
diff --git a/contrib/tcl/tests/linsert.test b/contrib/tcl/tests/linsert.test
index 6611394a6182..86a47f5290df 100644
--- a/contrib/tcl/tests/linsert.test
+++ b/contrib/tcl/tests/linsert.test
@@ -10,10 +10,13 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) linsert.test 1.13 97/02/27 16:53:19
+# SCCS: @(#) linsert.test 1.14 97/11/18 13:54:18
if {[string compare test [info procs test]] == 1} then {source defs}
+catch {unset lis}
+catch {rename p ""}
+
test linsert-1.1 {linsert command} {
linsert {1 2 3 4 5} 0 a
} {a 1 2 3 4 5}
@@ -92,3 +95,11 @@ test linsert-3.1 {linsert won't modify shared argument objects} {
}
p
} "a b c"
+test linsert-3.2 {linsert won't modify shared argument objects} {
+ catch {unset lis}
+ set lis [format "a \"%s\" c" "b"]
+ linsert $lis 0 [string length $lis]
+} "7 a b c"
+
+catch {unset lis}
+catch {rename p ""}
diff --git a/contrib/tcl/tests/lreplace.test b/contrib/tcl/tests/lreplace.test
index 197084e7bd21..44e8ee17525f 100644
--- a/contrib/tcl/tests/lreplace.test
+++ b/contrib/tcl/tests/lreplace.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) lreplace.test 1.15 96/12/16 21:43:57
+# SCCS: @(#) lreplace.test 1.16 97/10/29 16:32:39
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -89,6 +89,13 @@ test lreplace-1.24 {lreplace command} {
test lreplace-1.25 {lreplace command} {
concat \"[lreplace {\}\ hello} end end]\"
} {"\}\ "}
+test lreplace-1.26 {lreplace command} {
+ catch {unset foo}
+ set foo {a b}
+ list [set foo [lreplace $foo end end]] \
+ [set foo [lreplace $foo end end]] \
+ [set foo [lreplace $foo end end]]
+} {a {} {}}
test lreplace-2.1 {lreplace errors} {
@@ -120,3 +127,5 @@ test lreplace-3.1 {lreplace won't modify shared argument objects} {
}
p
} "a b c"
+
+catch {unset foo}
diff --git a/contrib/tcl/tests/obj.test b/contrib/tcl/tests/obj.test
index e8ee3b32f94f..08f230b542be 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.11 97/08/06 08:56:09
+# @(#) obj.test 1.12 97/10/31 17:23:23
if {[info commands testobj] == {}} {
puts "This application hasn't been compiled with the \"testobj\""
@@ -411,10 +411,10 @@ test obj-24.5 {SetIntFromAny, error parsing string} {
} {x17 1 {expected integer but got "x17"}}
test obj-24.6 {SetIntFromAny, integer too large} {nonPortable} {
set result ""
- lappend result [teststringobj set 1 12345678901234567890]
+ lappend result [teststringobj set 1 123456789012345678901]
lappend result [catch {testintobj mult10 1} msg]
lappend result $msg
-} {12345678901234567890 1 {integer value too large to represent}}
+} {123456789012345678901 1 {integer value too large to represent}}
test obj-24.7 {SetIntFromAny, error converting from "empty string"} {
set result ""
lappend result [testobj newobj 1]
diff --git a/contrib/tcl/tests/opt.test b/contrib/tcl/tests/opt.test
index 2f23bc6890dc..0b35b764a451 100644
--- a/contrib/tcl/tests/opt.test
+++ b/contrib/tcl/tests/opt.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: @(#) opt.test 1.1 97/08/14 00:53:59
+# SCCS: @(#) opt.test 1.2 97/08/20 15:57:18
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -149,6 +149,7 @@ test opt-8.10 {List utilities} {
} {{b c 7 e} f}
test opt-8.11 {List utilities} {
+ catch {unset x}
set l {a {b c 7 e} f}
list [::tcl::Lassign $l u v w x] \
$u $v $w [info exists x]
@@ -173,11 +174,11 @@ test opt-9.2 {Misc utilities} {
#### behaviour tests #####
test opt-10.1 {ambigous flags} {
- ::tcl::OptProc optTest {{-flag1xyz} {-other} {-flag2xyz} {-flag3xyz}} {}
+ ::tcl::OptProc optTest {{-fla} {-other} {-flag2xyz} {-flag3xyz}} {}
catch {optTest -fL} msg
set msg
} {ambigous option "-fL", choose from:
- -flag1xyz boolflag (false)
+ -fla boolflag (false)
-flag2xyz boolflag (false)
-flag3xyz boolflag (false) }
@@ -188,6 +189,24 @@ test opt-10.2 {non ambigous flags} {
optTest -fLaG2
} 1
+test opt-10.3 {non ambigous flags because of exact match} {
+ ::tcl::OptProc optTest {{-flag1x} {-other} {-flag1} {-flag1xy}} {
+ return $flag1
+ }
+ optTest -flAg1
+} 1
+
+test opt-10.4 {ambigous flags, not exact match} {
+ ::tcl::OptProc optTest {{-flag1xy} {-other} {-flag1} {-flag1xyz}} {
+ return $flag1
+ }
+ catch {optTest -fLag1X} msg
+ set msg
+} {ambigous option "-fLag1X", choose from:
+ -flag1xy boolflag (false)
+ -flag1xyz boolflag (false) }
+
+
# medium size overall test example: (defined once)
::tcl::OptProc optTest {
@@ -200,13 +219,13 @@ test opt-10.2 {non ambigous flags} {
list $cmd $allowBoing $arg2 $arg3 $moreflags
}
-test opt-10.3 {medium size overall test} {
+test opt-10.5 {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} {
+test opt-10.6 {medium size overall test} {
list [catch {optTest -help} msg] $msg
} {1 {Usage information:
Var/FlagName Type Value Help
@@ -218,19 +237,19 @@ test opt-10.4 {medium size overall test} {
?arg3? int (7) optional number
-moreflags boolflag (false) }}
-test opt-10.5 {medium size overall test} {
+test opt-10.7 {medium size overall test} {
optTest save tst
} {save 1 tst 7 0}
-test opt-10.6 {medium size overall test} {
+test opt-10.8 {medium size overall test} {
optTest save -allowBoing false -- 8
} {save 0 8 7 0}
-test opt-10.7 {medium size overall test} {
+test opt-10.9 {medium size overall test} {
optTest save tst -m --
} {save 1 tst 7 1}
-test opt-10.8 {medium size overall test} {
+test opt-10.10 {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/resource.test b/contrib/tcl/tests/resource.test
index efb3c8270a77..e815ef8c494d 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.6 97/07/23 17:41:51
+# SCCS: @(#) resource.test 1.8 97/11/06 12:36:32
# Only run this test on Macintosh systems
if {$tcl_platform(platform) != "macintosh"} {
@@ -22,7 +22,7 @@ test resource-1.1 {resource tests} {
} {1 {wrong # args: should be "resource option ?arg ...?"}}
test resource-1.2 {resource tests} {
list [catch {resource _bad_} msg] $msg
-} {1 {bad option "_bad_": must be close, list, open, read, types, or write}}
+} {1 {bad option "_bad_": must be close, delete, files, list, open, read, types, or write}}
# resource open & close tests
test resource-2.1 {resource open & close tests} {
@@ -41,16 +41,34 @@ 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
+ file delete rsrc.file
} {}
test resource-2.6 {resource open & close tests} {
+ catch {file delete rsrc.file}
+ testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"}
+ set id [resource open rsrc.file]
+ set result [string compare [resource open rsrc.file] $id]
+ resource close $id
+ file delete rsrc.file
+ set result
+} {0}
+test resource-2.7 {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} {
+test resource-2.8 {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} {
+test resource-2.9 {resource open & close tests} {
list [catch {resource close _bad_resource_} msg] $msg
} {1 {invalid resource file reference "_bad_resource_"}}
+test resource-2.10 {resource open & close tests} {
+ set result [catch {resource close System} mssg]
+ lappend result $mssg
+} {1 {can't close "System" resource file}}
+test resource-2.11 {resource open & close tests} {
+ set result [catch {resource close application} mssg]
+ lappend result $mssg
+} {1 {can't close "application" resource file}}
# Tests for listing resources
test resource-3.1 {resource list tests} {
@@ -74,7 +92,7 @@ test resource-3.5 {resource list tests} {
set result
} {fileRsrcName}
test resource-3.6 {resource list tests} {
- # There should be any resource of this type
+ # There should not be any resource of this type
resource list XXXX
} {}
test resource-3.7 {resource list tests} {
@@ -86,7 +104,7 @@ test resource-3.7 {resource list tests} {
}
} {ok}
-# Tests for listing resources
+# Tests for reading resources
test resource-4.1 {resource read tests} {
list [catch {resource read} msg] $msg
} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}}
@@ -123,43 +141,197 @@ test resource-5.4 {resource types tests} {
# 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"}}
+} {1 {wrong # args: should be "resource write ?-id resourceId? ?-name resourceName? ?-file resourceRef? ?-force? 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 close $id
+ set id [resource open rsrc2.file r]
+ set result [catch {resource write -file $id -name Hello TEXT foo} errMsg]
+ lappend result [string compare $errMsg "cannot write to resource file \"$id\", it was opened read only"]
+ lappend result [lsearch [resource list TEXT $id] Hello]
+ resource close $id
+ file delete rsrc2.file
+ set result
+} {1 0 -1}
+test resource-6.4 {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}
+test resource-6.5 {resource write tests} {
+ catch {file delete rsrc2.file}
+ set id [resource open rsrc2.file w]
+ resource write -file $id -id 256 TEXT {HAHAHAHAHAHAHA}
+ set result [catch {resource write -file $id -id 256 TEXT {HOHOHOHOHOHO}} mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result $mssg
+} {1 {the resource 256 already exists, use "-force" to overwrite it.}}
+test resource-6.6 {resource write tests} {
+ catch {file delete rsrc2.file}
+ testWriteTextResource -rsrc fileRsrcName -rsrcid 256 -file rsrc2.file -protected {error "don't tread on me"}
+ set id [resource open rsrc2.file w]
+ set result [catch {resource write -id 256 -force -file $id TEXT {NAHNAHNANAHNAH}} mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result $mssg
+} {1 {could not write resource id 256 of type TEXT, it was protected.}}
+test resource-6.7 {resource write tests} {
+ catch {file delete rsrc2.file}
+ set id [resource open rsrc2.file w]
+ resource write -file $id -id 256 -name FOO TEXT {set x [list "our first test data"]}
+ resource write -file $id -id 256 -name BAR -force TEXT {set x [list "our second test data"]}
+ source -rsrcid 256 rsrc2.file
+ lappend x [resource list TEXT $id]
+ resource close $id
+ file delete rsrc2.file
+ set x
+} {{our second test data} BAR}
+#Tests for listing open resource files
+test resource-7.1 {resource file tests} {
+ catch {resource files foo bar} mssg
+ set mssg
+} {wrong # args: should be "resource files ?resourceId?"}
+test resource-7.2 {resource file tests} {
+ catch {file delete rsrc2.file}
+ set rsrcFiles [resource files]
+ set id [resource open rsrc2.file w]
+ set result [string compare $rsrcFiles [lrange [resource files] 1 end]]
+ lappend result [string compare $id [lrange [resource files] 0 0]]
+ resource close $id
+ file delete rsrc2.file
+ set result
+} {0 0}
+test resource-7.3 {resource file tests} {
+ set result 0
+ foreach file [resource files] {
+ if {[catch {resource types $file}] != 0} {
+ set result 1
+ }
+ }
+ set result
+} {0}
+test resource-7.4 {resource file tests} {
+ catch {resource files __NO_SUCH_RESOURCE__} mssg
+ set mssg
+} {invalid resource file reference "__NO_SUCH_RESOURCE__"}
+test resource-7.5 {resource file tests} {
+ set sys [resource files System]
+ string compare $sys [file join $env(SYS_FOLDER) System]
+} {0}
+test resource-7.6 {resource file tests} {
+ set app [resource files application]
+ string compare $app [info nameofexecutable]
+} {0}
+
+#Tests for the resource delete command
+test resource-8.1 {resource delete tests} {
+ list [catch {resource delete} msg] $msg
+} {1 {wrong # args: should be "resource delete ?-id resourceId? ?-name resourceName? ?-file resourceRef? resourceType"}}
+test resource-8.2 {resource delete tests} {
+ list [catch {resource delete TEXT} msg] $msg
+} {1 {you must specify either "-id" or "-name" or both to "resource delete"}}
+test resource-8.3 {resource delete tests} {
+ set result [catch {resource delete -file ffffff -id 128 TEXT} mssg]
+ lappend result $mssg
+} {1 {invalid resource file reference "ffffff"}}
+test resource-8.4 {resource delete tests} {
+ catch {file delete rsrc2.file}
+ testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
+ set id [resource open rsrc2.file r]
+ set result [catch {resource delete -id 128 -file $id TEXT} mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result [string compare $mssg "cannot delete from resource file \"$id\", it was opened read only"]
+} {1 0}
+test resource-8.5 {resource delete tests} {
+ catch {file delete rsrc2.file}
+ testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
+ set id [resource open rsrc2.file w]
+ set result [catch {resource delete -id 128 -file $id _bad_type_} mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result $mssg
+} {1 {expected Macintosh OS type but got "_bad_type_"}}
+test resource-8.5 {resource delete tests} {
+ catch {file delete rsrc2.file}
+ set id [resource open rsrc2.file w]
+ set result [catch {resource delete -id 128 -file $id TEXT} mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result $mssg
+} {1 {resource not found}}
+test resource-8.6 {resource delete tests} {
+ catch {file delete rsrc2.file}
+ set id [resource open rsrc2.file w]
+ set result [catch {resource delete -name foo -file $id TEXT} mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result $mssg
+} {1 {resource not found}}
+test resource-8.7 {resource delete tests} {
+ catch {file delete rsrc2.file}
+ set id [resource open rsrc2.file w]
+ resource write -file $id -name foo -id 128 TEXT {some stuff}
+ resource write -file $id -name bar -id 129 TEXT {some stuff}
+ set result [catch {resource delete -name foo -id 129 -file $id TEXT} mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result $mssg
+} {1 {"-id" and "-name" values do not point to the same resource}}
+test resource-8.8 {resource delete tests} {
+ catch {file delete rsrc2.file}
+ testWriteTextResource -rsrc fileRsrcName -rsrcid 256 -file rsrc2.file -protected {error "don't tread on me"}
+ set id [resource open rsrc2.file w]
+ set result [catch {resource delete -id 256 -file $id TEXT } mssg]
+ resource close $id
+ file delete rsrc2.file
+ lappend result $mssg
+} {1 {resource cannot be deleted: it is protected.}}
+test resource-8.9 {resource delete tests} {
+ catch {file delete rsrc2.file}
+ testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
+ set id [resource open rsrc2.file w]
+ set result [resource list TEXT $id]
+ resource delete -id 128 -file $id TEXT
+ lappend result [resource list TEXT $id]
+ resource close $id
+ file delete rsrc2.file
+ set result
+} {fileRsrcName {}}
+
# 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-7.1 {source command} {
+test resource-9.1 {source command} {
catch {unset rsrc_foo}
source -rsrc fileRsrcName rsrc.file
list [catch {set rsrc_foo} msg] $msg
} {0 1}
-test resource-7.2 {source command} {
+test resource-9.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-7.3 {source command} {
+test resource-9.3 {source command} {
catch {unset rsrc_foo}
source -rsrcid 128 rsrc.file
list [catch {set rsrc_foo} msg] $msg
} {0 1}
-test resource-7.4 {source command} {
+test resource-9.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-7.5 {source command} {
+test resource-9.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 d68424bdf404..c23f06aa18c8 100644
--- a/contrib/tcl/tests/safe.test
+++ b/contrib/tcl/tests/safe.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: @(#) safe.test 1.31 97/08/14 00:55:56
+# SCCS: @(#) safe.test 1.34 97/11/19 14:59:13
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -38,7 +38,9 @@ test safe-1.2 {safe::interpCreate syntax} {
?slave? name () name of the slave (optional)
-accessPath list () access path for the slave
-noStatics boolflag (false) prevent loading of statically linked pkgs
+ -statics boolean (true) loading of statically linked pkgs
-nestedLoadOk boolflag (false) allow nested loading
+ -nested boolean (false) nested loading
-deleteHook script () delete hook}}
test safe-1.3 {safe::interpInit syntax} {
@@ -186,7 +188,7 @@ test safe-7.1 {tests that everything works at high level} {
} 1.0
test safe-7.2 {tests specific path and interpFind/AddToAccessPath} {
- set i [safe::interpCreate -nostat -nested -accessPath [list [info library]]];
+ set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]];
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p1
@@ -197,7 +199,7 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} {
[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 {}} {}"
+} "{\$p(:0:)} {\$p(:1:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"
# test source control on file name
@@ -349,13 +351,41 @@ test safe-9.2 {safe interps' error in deleteHook} {
} {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}} {}}
+test safe-9.3 {dual specification of statics} {
+ list [catch {safe::interpCreate -stat true -nostat} msg] $msg
+} {1 {conflicting values given for -statics and -noStatics}}
-# 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 !
+test safe-9.4 {dual specification of statics} {
+ # no error shall occur
+ safe::interpDelete [safe::interpCreate -stat false -nostat]
+} {}
+
+test safe-9.5 {dual specification of nested} {
+ list [catch {safe::interpCreate -nested 0 -nestedload} msg] $msg
+} {1 {conflicting values given for -nested and -nestedLoadOk}}
+
+test safe-9.6 {interpConfigure widget like behaviour} {
+ # this test shall work, don't try to "fix it" unless
+ # you *really* know what you are doing (ie you are me :p) -- dl
+ list [set i [safe::interpCreate \
+ -noStatics \
+ -nestedLoadOk \
+ -deleteHook {foo bar}];
+ safe::interpConfigure $i -accessPath /foo/bar ;
+ safe::interpConfigure $i]\
+ [safe::interpConfigure $i -aCCess]\
+ [safe::interpConfigure $i -nested]\
+ [safe::interpConfigure $i -statics]\
+ [safe::interpConfigure $i -DEL]\
+ [safe::interpConfigure $i -accessPath /blah -statics 1;
+ safe::interpConfigure $i]\
+ [safe::interpConfigure $i -deleteHook toto -nosta -nested 0;
+ safe::interpConfigure $i]
+} {{-accessPath /foo/bar -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath /foo/bar} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath /blah -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath /blah -statics 0 -nested 0 -deleteHook toto}}
+
+
+# testing that nested and statics do what is advertised
+# (we use a static package : Tcltest)
if {[catch {package require Tcltest} msg]} {
puts "This application hasn't been compiled with Tcltest"
@@ -392,7 +422,7 @@ test safe-10.3 {testing nested statics loading / no nested by default} {
test safe-10.4 {testing nested statics loading / -nestedloadok} {
- set i [safe::interpCreate -nested]
+ set i [safe::interpCreate -nestedloadok]
list \
[catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \
$msg \
diff --git a/contrib/tcl/tests/set-old.test b/contrib/tcl/tests/set-old.test
index 2b4cd620f1fe..a101e7bb4290 100644
--- a/contrib/tcl/tests/set-old.test
+++ b/contrib/tcl/tests/set-old.test
@@ -7,12 +7,12 @@
# 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.
+# 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: @(#) set-old.test 1.20 97/07/25 17:45:55
+# SCCS: @(#) set-old.test 1.22 97/10/29 14:05:07
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -297,45 +297,72 @@ test set-old-8.7 {array command, anymore option} {
catch {unset a}
list [catch {array anymore a x} msg] $msg
} {1 {"a" isn't an array}}
-test set-old-8.8 {array command, donesearch option} {
+test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array anymore a x]
+ }
+ set a(x) 123
+ }
+ list [catch {foo 1} msg] $msg
+} {1 {"a" isn't an array}}
+test set-old-8.9 {array command, donesearch option} {
catch {unset a}
list [catch {array donesearch a x} msg] $msg
} {1 {"a" isn't an array}}
-test set-old-8.9 {array command, exists option} {
+test set-old-8.10 {array command, donesearch option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array donesearch a x]
+ }
+ set a(x) 123
+ }
+ list [catch {foo 1} msg] $msg
+} {1 {"a" isn't an array}}
+test set-old-8.11 {array command, exists option} {
list [catch {array exists a b} msg] $msg
} {1 {wrong # args: should be "array exists arrayName"}}
-test set-old-8.10 {array command, exists option} {
+test set-old-8.12 {array command, exists option} {
catch {unset a}
array exists a
} {0}
-test set-old-8.11 {array command, exists option} {
+test set-old-8.13 {array command, exists option} {
catch {unset a}
set a(0) 1
array exists a
} {1}
-test set-old-8.12 {array command, get option} {
+test set-old-8.14 {array command, exists option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array exists a]
+ }
+ set a(x) 123
+ }
+ list [catch {foo 1} msg] $msg
+} {0 0}
+test set-old-8.15 {array command, get option} {
list [catch {array get} msg] $msg
} {1 {wrong # args: should be "array option arrayName ?arg ...?"}}
-test set-old-8.13 {array command, get option} {
+test set-old-8.16 {array command, get option} {
list [catch {array get a b c} msg] $msg
} {1 {wrong # args: should be "array get arrayName ?pattern?"}}
-test set-old-8.14 {array command, get option} {
+test set-old-8.17 {array command, get option} {
catch {unset a}
array get a
} {}
-test set-old-8.15 {array command, get option} {
+test set-old-8.18 {array command, get option} {
catch {unset a}
set a(22) 3
set {a(long name)} {}
array get a
} {22 3 {long name} {}}
-test set-old-8.16 {array command, get option (unset variable)} {
+test set-old-8.19 {array command, get option (unset variable)} {
catch {unset a}
set a(x) 3
trace var a(y) w ignore
array get a
} {x 3}
-test set-old-8.17 {array command, get option, with pattern} {
+test set-old-8.20 {array command, get option, with pattern} {
catch {unset a}
set a(x1) 3
set a(x2) 4
@@ -344,7 +371,16 @@ test set-old-8.17 {array command, get option, with pattern} {
set a(b2) 25
array get a x*
} {x1 3 x2 4 x3 5}
-test set-old-8.18 {array command, names option} {
+test set-old-8.21 {array command, get option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array get a]
+ }
+ set a(x) 123
+ }
+ list [catch {foo 1} msg] $msg
+} {0 {}}
+test set-old-8.22 {array command, names option} {
catch {unset a}
set a(22) 3
list [catch {array names a 4 5} msg] $msg
@@ -353,25 +389,25 @@ test set-old-8.19 {array command, names option} {
catch {unset a}
array names a
} {}
-test set-old-8.20 {array command, names option} {
+test set-old-8.23 {array command, names option} {
catch {unset a}
set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx
list [catch {lsort [array names a]} msg] $msg
} {0 {22 Textual_name {name with spaces}}}
-test set-old-8.21 {array command, names option} {
+test set-old-8.24 {array command, names option} {
catch {unset a}
set a(22) 3; set a(33) 44;
trace var a(xxx) w ignore
list [catch {lsort [array names a]} msg] $msg
} {0 {22 33}}
-test set-old-8.22 {array command, names option} {
+test set-old-8.25 {array command, names option} {
catch {unset a}
set a(22) 3; set a(33) 44;
trace var a(xxx) w ignore
set a(xxx) value
list [catch {lsort [array names a]} msg] $msg
} {0 {22 33 xxx}}
-test set-old-8.23 {array command, names option} {
+test set-old-8.26 {array command, names option} {
catch {unset a}
set a(axy) 3
set a(bxy) 44
@@ -379,64 +415,119 @@ test set-old-8.23 {array command, names option} {
set a(xxx) value
list [lsort [array names a *xy]] [lsort [array names a]]
} {{axy bxy} {axy bxy no xxx}}
-test set-old-8.24 {array command, nextelement option} {
+test set-old-8.27 {array command, names option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array names a]
+ }
+ set a(x) 123
+ }
+ list [catch {foo 1} msg] $msg
+} {0 {}}
+test set-old-8.28 {array command, nextelement option} {
list [catch {array nextelement a} msg] $msg
} {1 {wrong # args: should be "array nextelement arrayName searchId"}}
-test set-old-8.25 {array command, nextelement option} {
+test set-old-8.29 {array command, nextelement option} {
catch {unset a}
list [catch {array nextelement a b} msg] $msg
} {1 {"a" isn't an array}}
-test set-old-8.26 {array command, set option} {
+test set-old-8.30 {array command, nextelement option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array nextelement a b]
+ }
+ set a(x) 123
+ }
+ list [catch {foo 1} msg] $msg
+} {1 {"a" isn't an array}}
+test set-old-8.31 {array command, set option} {
list [catch {array set a} msg] $msg
} {1 {wrong # args: should be "array set arrayName list"}}
-test set-old-8.27 {array command, set option} {
+test set-old-8.32 {array command, set option} {
list [catch {array set a 1 2} msg] $msg
} {1 {wrong # args: should be "array set arrayName list"}}
-test set-old-8.28 {array command, set option} {
+test set-old-8.33 {array command, set option} {
list [catch {array set a "a \{ c"} msg] $msg
} {1 {unmatched open brace in list}}
-test set-old-8.29 {array command, set option} {
+test set-old-8.34 {array command, set option} {
catch {unset a}
set a 44
list [catch {array set a {a b c d}} msg] $msg
} {1 {can't set "a(a)": variable isn't array}}
-test set-old-8.30 {array command, set option} {
+test set-old-8.35 {array command, set option} {
catch {unset a}
set a(xx) yy
array set a {b c d e}
array get a
} {d e xx yy b c}
-test set-old-8.31 {array command, size option} {
+test set-old-8.36 {array command, set option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array set a {x 0}]
+ }
+ set a(x)
+ }
+ list [catch {foo 1} msg] $msg
+} {0 {}}
+test set-old-8.37 {array command, set option} {
+ catch {unset aVaRnAmE}
+ array set aVaRnAmE {}
+ list [info exists aVaRnAmE] [catch {set aVaRnAmE} msg] $msg
+} {1 1 {can't read "aVaRnAmE": variable is array}}
+test set-old-8.38 {array command, size option} {
+ catch {unset a}
+ array size a
+} {0}
+test set-old-8.39 {array command, size option} {
list [catch {array size a 4} msg] $msg
} {1 {wrong # args: should be "array size arrayName"}}
-test set-old-8.32 {array command, size option} {
+test set-old-8.40 {array command, size option} {
catch {unset a}
array size a
} {0}
-test set-old-8.33 {array command, size option} {
+test set-old-8.41 {array command, size option} {
catch {unset a}
set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx
list [catch {array size a} msg] $msg
} {0 3}
-test set-old-8.34 {array command, size option} {
+test set-old-8.42 {array command, size option} {
catch {unset a}
set a(22) 3; set a(xx) 44; set a(y) xxx
unset a(22) a(y) a(xx)
list [catch {array size a} msg] $msg
} {0 0}
-test set-old-8.35 {array command, size option} {
+test set-old-8.43 {array command, size option} {
catch {unset a}
set a(22) 3;
trace var a(33) rwu ignore
list [catch {array size a} msg] $msg
} {0 1}
-test set-old-8.36 {array command, startsearch option} {
+test set-old-8.44 {array command, size option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ proc foo {x} {
+ if {$x==1} {
+ return [array size a]
+ }
+ set a(x) 123
+ }
+ list [catch {foo 1} msg] $msg
+} {0 0}
+test set-old-8.45 {array command, startsearch option} {
list [catch {array startsearch a b} msg] $msg
} {1 {wrong # args: should be "array startsearch arrayName"}}
-test set-old-8.37 {array command, startsearch option} {
+test set-old-8.46 {array command, startsearch option} {
catch {unset a}
list [catch {array startsearch a} msg] $msg
} {1 {"a" isn't an array}}
+test set-old-8.47 {array command, startsearch option, array doesn't exist yet but has compiler-allocated procedure slot} {
+ catch {rename p ""}
+ proc p {x} {
+ if {$x==1} {
+ return [array startsearch a]
+ }
+ set a(x) 123
+ }
+ list [catch {p 1} msg] $msg
+} {1 {"a" isn't an array}}
test set-old-9.1 {ids for array enumeration} {
catch {unset a}
@@ -676,4 +767,5 @@ test set-old-12.2 {cleanup on procedure return} {
catch {unset a}
catch {unset b}
catch {unset c}
+catch {unset aVaRnAmE}
return ""
diff --git a/contrib/tcl/tests/socket.test b/contrib/tcl/tests/socket.test
index 280db1ba5549..b2719de67b73 100644
--- a/contrib/tcl/tests/socket.test
+++ b/contrib/tcl/tests/socket.test
@@ -59,7 +59,7 @@
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.
#
-# SCCS: @(#) socket.test 1.82 97/08/05 13:30:55
+# SCCS: @(#) socket.test 1.83 97/09/15 16:29:47
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -402,7 +402,7 @@ test socket-2.5 {tcp connection with redundant server port} {stdio} {
close $f
set x
} {ready hello}
-test socket-2.6 {tcp connection} {unixOrPc} {
+test socket-2.6 {tcp connection} {} {
set status ok
if {![catch {set sock [socket localhost 2828]}]} {
if {![catch {gets $sock}]} {
@@ -891,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} {tempNotMac} {
+test socket-9.2 {testing async write, fileevents, flush on close} {} {
set firstblock ""
for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
set secondblock ""
diff --git a/contrib/tcl/tests/source.test b/contrib/tcl/tests/source.test
index 1e0ff696c211..9a7e2305e9a1 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.25 97/07/02 16:41:34
+# SCCS: @(#) source.test 1.26 97/09/24 16:33:37
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -31,7 +31,7 @@ test source-1.2 {source command} {
source source.file
} result
-# The mac version of source returns a differnt result for
+# The mac version of source returns a different result for
# the next two tests.
if {$tcl_platform(platform) == "macintosh"} {
@@ -173,6 +173,13 @@ test source-5.6 {source resource files} {macOnly} {
list $msg2 $result $msg
} [list hello 1 bad]
+test source-6.1 {source is binary ok} {
+ set x {}
+ makeFile [list set x "a b\0c"] source.file
+ source source.file
+ string length $x
+} 5
+
catch {removeFile source.file}
# Generate null final value
diff --git a/contrib/tcl/tests/unixFCmd.test b/contrib/tcl/tests/unixFCmd.test
index 6b57e7565f87..037b5b472fe0 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.14 97/08/15 10:22:11
+# SCCS: @(#) unixFCmd.test 1.15 97/11/03 15:58:22
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -79,16 +79,17 @@ test unixFCmd-1.5 {TclpRenameFile: ENOENT} {
test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} {
# can't make it happen
} {}
-test unixFCmd-1.7 {TclpRenameFile: EXDEV} {nonPortable} {
+test unixFCmd-1.7 {TclpRenameFile: EXDEV} {
cleanup
- file mkdir td1
- if [file exists /kernel] {
- set msg [list [catch {file rename /kernel td1} msg] $msg]
- set a1 {1 {can't unlink "/kernel": permission denied}}
- expr {$msg == $a1}
- } else {
- list 1
- }
+ file mkdir foo/bar
+ file attr foo -perm 040555
+ set msg [list [catch {file rename foo/bar /tmp} msg] $msg]
+ set a1 {1 {can't unlink "foo/bar": permission denied}}
+ set result [expr {$msg == $a1}]
+ catch {file delete /tmp/bar}
+ catch {file attr foo -perm 040777}
+ catch {file delete -force foo}
+ set result
} {1}
test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} {
@@ -232,7 +233,7 @@ 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"} {}}
-test unixFCmd-18.1 { nix pwd} {nonPortable} {
+test unixFCmd-18.1 {Unix pwd} {nonPortable} {
# This test is nonportable because SunOS generates a weird error
# message when the current directory isn't readable.
set cd [pwd]
diff --git a/contrib/tcl/tests/unixNotfy.test b/contrib/tcl/tests/unixNotfy.test
index ba99db103eaa..5ed5f12adede 100644
--- a/contrib/tcl/tests/unixNotfy.test
+++ b/contrib/tcl/tests/unixNotfy.test
@@ -9,13 +9,22 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) unixNotfy.test 1.2 97/06/16 17:26:28
+# SCCS: @(#) unixNotfy.test 1.3 97/09/15 15:39:53
if {[string compare test [info procs test]] == 1} then {source defs}
if {$tcl_platform(platform) != "unix"} {
return
}
+
+# The tests should not be run if you have a notifier which is unable to
+# detect infinite vwaits, as the tests below will hang. The presence of
+# the "testeventloop" command indicates that this is the case.
+
+if {"[info commands testeventloop]" == "testeventloop"} {
+ return
+}
+
test unixNotfy-1.1 {Tcl_DeleteFileHandler} {
catch {vwait x}
set f [open foo w]
diff --git a/contrib/tcl/tests/upvar.test b/contrib/tcl/tests/upvar.test
index 23419debd664..d9548b068bac 100644
--- a/contrib/tcl/tests/upvar.test
+++ b/contrib/tcl/tests/upvar.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) upvar.test 1.14 96/10/22 11:34:39
+# SCCS: @(#) upvar.test 1.15 97/10/29 18:25:56
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -315,6 +315,18 @@ test upvar-8.8 {create nested array with upvar} {
catch {unset x}
list [catch p1 msg] $msg
} {1 {can't set "b(2)": variable isn't array}}
+test upvar-8.9 {upvar won't create namespace variable that refers to procedure variable} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {rename MakeLink ""}
+ namespace eval ::test_ns_1 {}
+ proc MakeLink {a} {
+ namespace eval ::test_ns_1 {
+ upvar a a
+ }
+ unset ::test_ns_1::a
+ }
+ list [catch {MakeLink 1} msg] $msg
+} {1 {bad variable name "a": upvar won't create namespace variable that refers to procedure variable}}
if {[info commands testupvar] != {}} {
test upvar-9.1 {Tcl_UpVar2 procedure} {
diff --git a/contrib/tcl/tests/winFCmd.test b/contrib/tcl/tests/winFCmd.test
index bca8c4bbc736..a38d72f62e02 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.10 97/08/05 11:44:57
+# SCCS: @(#) winFCmd.test 1.11 97/10/10 11:50:05
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -853,32 +853,35 @@ test winFCmd-12.4 {ConvertFileNameFormat} {
close [open td1 w]
list [catch {string tolower [file attributes ./td1 -longname]} msg] $msg [cleanup]
} {0 ./td1 {}}
-test winFCmd-12.5 {ConvertFileNameFormat} {
+test winFCmd-12.5 {ConvertFileNameFormat: absolute path} {
+ list [file attributes / -longname] [file attributes \\ -longname]
+} {/ /}
+test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} {
catch {file delete -force -- c:/td1}
close [open c:/td1 w]
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} {
+test winFCmd-12.7 {ConvertFileNameFormat} {UNCPath} {
catch {file delete -force -- //bisque/icepick/test/td1}
close [open //bisque/icepick/test/td1 w]
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} {
+test winFCmd-12.8 {ConvertFileNameFormat} {longFileNames} {
cleanup
close [open td1 w]
list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
-test winFCmd-12.8 {ConvertFileNameFormat} {win32s} {
+test winFCmd-12.9 {ConvertFileNameFormat} {win32s} {
cleanup
close [open td1 w]
list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
-test winFCmd-12.9 {ConvertFileNameFormat} {longFileNames} {
+test winFCmd-12.10 {ConvertFileNameFormat} {longFileNames} {
cleanup
close [open td1td1td1 w]
list [catch {file attributes td1td1td1 -shortname}] [cleanup]
} {0 {}}
-test winFCmd-12.10 {ConvertFileNameFormat} {longFileNames} {
+test winFCmd-12.11 {ConvertFileNameFormat} {longFileNames} {
cleanup
close [open td1 w]
list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup]
diff --git a/contrib/tcl/tests/winPipe.test b/contrib/tcl/tests/winPipe.test
index 483dfec9cc12..404251fd342a 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.9 97/08/05 11:44:28
+# SCCS: @(#) winPipe.test 1.11 97/10/09 17:06:16
if {$tcl_platform(platform) != "windows"} {
return
@@ -161,9 +161,6 @@ test winpipe-1.24 {32 bit comprehensive tests: read/write application} {
catch {close $f}
set r
} "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
-test winpipe-1.25 {32 bit comprehensive tests: to socket} {
- # doesn't work
-} {}
}
set stderr16 "stderr16"
@@ -280,10 +277,83 @@ test winpipe-2.24 {16 bit comprehensive tests: read/write application} {nt} {
catch {close $f}
set r
} "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
-test winpipe-2.25 {16 bit comprehensive tests: to socket} {
- # doesn't work
-} {}
}
-file delete big little
+test winpipe-3.1 {Tcl_WaitPid} {nt} {
+ proc readResults {f} {
+ global x result
+ if { [eof $f] } {
+ close $f
+ set x 1
+ } else {
+ set line [read $f ]
+ set result "$result$line"
+ }
+ }
+
+ set f [open "|$cat32 < big 2> stderr" r]
+ fconfigure $f -buffering none -blocking 0
+ fileevent $f readable "readResults $f"
+ set x 0
+ set result ""
+ vwait x
+ list $result $x [contents stderr]
+} "{$big} 1 stderr32"
+
+close [open nothing w]
+
+catch {set env_tmp $env(TMP)}
+catch {set env_temp $env(TEMP)}
+
+set env(TMP) c:/
+set env(TEMP) c:/
+
+test winpipe-3.1 {TclpCreateTempFile: cleanup temp files} {
+ set x {}
+ set existing [glob -nocomplain c:/tcl*.tmp]
+ exec $tcltest < nothing
+ foreach p [glob -nocomplain c:/tcl*.tmp] {
+ if {[lsearch $existing $p] != -1} {
+ lappend x $p
+ }
+ }
+ set x
+} {}
+test winpipe-3.2 {TclpCreateTempFile: TMP and TEMP not defined} {
+ set tmp $env(TMP)
+ set temp $env(TEMP)
+ unset env(TMP)
+ unset env(TEMP)
+ exec $tcltest < nothing
+ set env(TMP) $tmp
+ set env(TEMP) $temp
+ set x {}
+} {}
+test winpipe-3.3 {TclpCreateTempFile: TMP specifies non-existent directory} {
+ set tmp $env(TMP)
+ set env(TMP) snarky
+ exec $tcltest < nothing
+ set env(TMP) $tmp
+ set x {}
+} {}
+test winpipe-3.3 {TclpCreateTempFile: TEMP specifies non-existent directory} {
+ set tmp $env(TMP)
+ set temp $env(TEMP)
+ unset env(TMP)
+ set env(TEMP) snarky
+ exec $tcltest < nothing
+ set env(TMP) $tmp
+ set env(TEMP) $temp
+ set x {}
+} {}
+
+# restore old values fro env(TMP) and env(TEMP)
+
+if {[catch {set env(TMP) $env_tmp}]} {
+ unset $env(TMP)
+}
+if {[catch {set env(TEMP) $env_temp}]} {
+ unset $env(TEMP)
+}
+file delete big little stdout stderr nothing