diff options
Diffstat (limited to 'contrib/tcl/tests')
54 files changed, 3038 insertions, 1416 deletions
diff --git a/contrib/tcl/tests/all b/contrib/tcl/tests/all index b50794c..4023e55 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 d2f3701..a0b6ea0 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 13e1f8a..f64b2bb 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 cbf3ae7..351008e 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 55210a1..ceeb86b 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 6d8e032..9e30fb3 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 ead6aeb..61f90ec 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 22f1284..e76ad7d 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 3421edc..1421e9b 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 48ee9ce..07f610c 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 6741836..027f7e0 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 4b00c44..169885a 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 6c63750..81fde45 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 e25a1eb..b2f577e 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 481e3ab..e0825f9 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 f53da0c..e7d2279 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 f7f4594..f6be5ac 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 7b518fe..aa918ec 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 64fffc5..f87dd39 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 219327b..680b626 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 1d30955..498fb2e 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 3c47c27..2770e13 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 0000000..5e9ba0c --- /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 8bc288f..03b8bcd 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 30db386f..e187d41 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 7e7a226..784dad1 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 85aee32..9127bcb 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 c83033b..7392482 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 149d6c7..95a5975 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 5929206..b2168c1 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 c021d21..e876391 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 cc8ea3c..e8ee3b3 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 0000000..2f23bc6 --- /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 1241262..514ed2a 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 37a5b9c..e6a99c6 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 5da6335..c770edb 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 9647399..eeace97 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 0000000..e283799 --- /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 6a6b99f..605c84b 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 dc60535..efb3c82 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 702bf8d..d68424b 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 9f73bf1..50bf876 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 17e67f7..2b4cd62 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 2389016..280db1b 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 2d62284..1e0ff69 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 2e2af25..a57c714 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 08ade64..6643d4f 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 d67c252..b4d02d3 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 8fc1f2e..6b57e75 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 e7a3f2f..ee37047 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 a51a47b..6452577 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 3cb43d0..8642747 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 83691b0..bca8c4b 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 af26db4..483dfec 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 + |
