diff options
Diffstat (limited to 'tests')
106 files changed, 16407 insertions, 2235 deletions
diff --git a/tests/all b/tests/all deleted file mode 100644 index 4023e55..0000000 --- a/tests/all +++ /dev/null @@ -1,22 +0,0 @@ -# This file contains a top-level script to run all of the Tcl -# tests. Execute it by invoking "source all" when running tclTest -# in this directory. -# -# SCCS: @(#) all 1.8 97/08/01 11:07:14 - -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 - } - puts stdout $i - if [catch {source $i} msg] { - puts $msg - } -} diff --git a/tests/append.test b/tests/append.test index f89ade5..cac10ba 100644 --- a/tests/append.test +++ b/tests/append.test @@ -10,11 +10,12 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) append.test 1.17 97/10/28 15:45:52 +# SCCS: @(#) append.test 1.19 97/12/24 10:40:56 -if {[string compare test [info procs test]] == 1} then {source defs} +if {[info procs test] != "test"} {source defs} catch {unset x} + test append-1.1 {append command} { catch {unset x} list [append x 1 2 abc "long string"] $x @@ -170,5 +171,8 @@ test append-7.1 {lappend-created var and error in trace on that var} { list [info exists x] [catch {set x} msg] $msg } {0 1 {can't read "x": no such variable}} -catch {unset x} +catch {unset i x result y} catch {rename foo ""} +catch {rename check ""} + +return diff --git a/tests/assocd.test b/tests/assocd.test index 20e8223..6d8fac5 100644 --- a/tests/assocd.test +++ b/tests/assocd.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. # -# "@(#) assocd.test 1.5 95/08/02 17:11:37" +# "@(#) assocd.test 1.6 97/12/08 15:04:52" if {[string compare test [info procs test]] == 1} then {source defs} @@ -55,3 +55,5 @@ test assocd-3.2 {testing deleting assoc data} { test assocd-3.3 {testing deleting assoc data} { list [catch {testdelassocdata nonexistent} msg] $msg } {0 {}} + +return diff --git a/tests/async.test b/tests/async.test index cfc572c..1933111 100644 --- a/tests/async.test +++ b/tests/async.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: @(#) async.test 1.5 96/04/05 15:29:38 +# SCCS: @(#) async.test 1.6 97/12/08 15:02:15 if {[info commands testasync] == {}} { puts "This application hasn't been compiled with the \"testasync\"" @@ -129,3 +129,4 @@ test async-3.1 {deleting handlers} { } {3 del2 {0 0 0 del1 del2}} testasync delete +return diff --git a/tests/basic.test b/tests/basic.test index 502e3e5..b4b8c55 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -14,11 +14,16 @@ # 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.19 97/10/31 16:02:26 +# SCCS: @(#) basic.test 1.23 97/12/09 16:34:32 # if {[string compare test [info procs test]] == 1} then {source defs} +if {[info commands testcreatecommand] == ""} { + puts "This application hasn't been compiled with the testcreatecommand" + puts "command. Skipping all of these tests." +} + catch {namespace delete test_ns_basic} catch {interp delete test_interp} catch {rename p ""} @@ -40,7 +45,31 @@ test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} { [interp delete test_interp] } {::test_ns_basic {}} -test basic-2.1 {DeleteInterpProc, destroys interp's global namespace} { +test basic-2.1 {TclHideUnsafeCommands} { +} {} + +test basic-3.1 {Tcl_CallWhenDeleted: see dcall.test} { +} {} + +test basic-4.1 {Tcl_DontCallWhenDeleted: see dcall.test} { +} {} + +test basic-5.1 {Tcl_SetAssocData: see assoc.test} { +} {} + +test basic-6.1 {Tcl_DeleteAssocData: see assoc.test} { +} {} + +test basic-7.1 {Tcl_GetAssocData: see assoc.test} { +} {} + +test basic-8.1 {Tcl_InterpDeleted} { +} {} + +test basic-9.1 {Tcl_DeleteInterp: see interp.test} { +} {} + +test basic-10.1 {DeleteInterpProc, destroys interp's global namespace} { catch {interp delete test_interp} interp create test_interp interp eval test_interp { @@ -65,7 +94,7 @@ test basic-2.1 {DeleteInterpProc, destroys interp's global namespace} { [interp delete test_interp] } {{::test_ns_basic 27} {} 1 {invalid command name "set"} {}} -test basic-3.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} { +test basic-11.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} { catch {interp delete test_interp} interp create test_interp interp eval test_interp { @@ -84,7 +113,7 @@ test basic-3.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden c # 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} { +test basic-12.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} { catch {interp delete test_interp} interp create test_interp interp eval test_interp { @@ -99,7 +128,7 @@ test basic-4.1 {Tcl_HideCommand, names of hidden cmds can't have namespace quali [interp delete test_interp] } {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} { +test basic-12.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} { catch {namespace delete test_ns_basic} catch {rename cmd ""} proc cmd {} { ;# note that this is global @@ -124,7 +153,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, a command stays in the global namespace and can not go to another namespace} { +test basic-13.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 @@ -152,7 +181,7 @@ test basic-5.1 {Tcl_ExposeCommand, a command stays in the global namespace and c [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} { +test basic-13.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} { catch {rename p ""} catch {rename cmd ""} proc p {} { @@ -170,22 +199,21 @@ test basic-5.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being expos [p] } {42 {} {} Hello {} {} 42} -if {[info commands testcreatecommand] != {}} { - test basic-6.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} { - catch {eval namespace delete [namespace children :: test_ns_*]} - list [testcreatecommand create] \ - [test_ns_basic::createdcommand] \ - [testcreatecommand delete] - } {{} {CreatedCommandProc in ::test_ns_basic} {}} - test basic-6.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} { - catch {eval namespace delete [namespace children :: test_ns_*]} - catch {rename value:at: ""} - list [testcreatecommand create2] \ - [value:at:] \ - [testcreatecommand delete2] - } {{} {CreatedCommandProc2 in ::} {}} -} -test basic-6.3 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} { +test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [testcreatecommand create] \ + [test_ns_basic::createdcommand] \ + [testcreatecommand delete] +} {{} {CreatedCommandProc in ::test_ns_basic} {}} +test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename value:at: ""} + list [testcreatecommand create2] \ + [value:at:] \ + [testcreatecommand delete2] +} {{} {CreatedCommandProc2 in ::} {}} + +test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} { catch {eval namespace delete [namespace children :: test_ns_*]} namespace eval test_ns_basic {} proc test_ns_basic::cmd {} { ;# proc requires that ns already exist @@ -195,7 +223,13 @@ test basic-6.3 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in [namespace delete test_ns_basic] } {::test_ns_basic {}} -test basic-7.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} { +test basic-16.1 {TclInvokeStringCommand} { +} {} + +test basic-17.1 {TclInvokeObjCommand} { +} {} + +test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename cmd ""} namespace eval test_ns_basic { @@ -207,11 +241,11 @@ test basic-7.1 {TclRenameCommand, name of existing cmd can have namespace qualif [rename test_ns_basic::p test_ns_basic::q] \ [test_ns_basic::q] } {{p in ::test_ns_basic} {} {p in ::test_ns_basic}} -test basic-7.2 {TclRenameCommand, existing cmd must be found} { +test basic-18.2 {TclRenameCommand, existing cmd must be found} { catch {eval namespace delete [namespace children :: test_ns_*]} list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg } {1 {can't rename "test_ns_basic::p": command doesn't exist}} -test basic-7.3 {TclRenameCommand, delete cmd if new name is empty} { +test basic-18.3 {TclRenameCommand, delete cmd if new name is empty} { catch {eval namespace delete [namespace children :: test_ns_*]} namespace eval test_ns_basic { proc p {} { @@ -222,7 +256,7 @@ test basic-7.3 {TclRenameCommand, delete cmd if new name is empty} { [rename test_ns_basic::p ""] \ [info commands test_ns_basic::*] } {::test_ns_basic::p {} {}} -test basic-7.4 {TclRenameCommand, bad new name} { +test basic-18.4 {TclRenameCommand, bad new name} { catch {eval namespace delete [namespace children :: test_ns_*]} namespace eval test_ns_basic { proc p {} { @@ -231,7 +265,7 @@ test basic-7.4 {TclRenameCommand, bad new name} { } rename test_ns_basic::p :::george::martha } {} -test basic-7.5 {TclRenameCommand, new name must not already exist} { +test basic-18.5 {TclRenameCommand, new name must not already exist} { namespace eval test_ns_basic { proc q {} { return 42 @@ -239,7 +273,7 @@ test basic-7.5 {TclRenameCommand, new name must not already exist} { } list [catch {rename test_ns_basic::q :::george::martha} msg] $msg } {1 {can't rename to ":::george::martha": command already exists}} -test basic-7.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} { +test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename p ""} catch {rename q ""} @@ -259,7 +293,10 @@ test basic-7.6 {TclRenameCommand, check for command shadowing by newly renamed c [test_ns_basic::callP] } {{p in ::} {} {q in ::test_ns_basic}} -test basic-8.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} { +test basic-19.1 {Tcl_SetCommandInfo} { +} {} + +test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename p ""} catch {rename q ""} @@ -272,7 +309,7 @@ test basic-8.1 {Tcl_GetCommandInfo, names for commands created inside namespaces [rename ::p q] \ [testcmdtoken name $x] } {{p ::p} {} {q ::q}} -test basic-8.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} { +test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} { catch {rename q ""} set x [testcmdtoken create test_ns_basic::test_ns_basic2::p] list [testcmdtoken name $x] \ @@ -280,7 +317,10 @@ 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 basic-9.1 {Tcl_GetCommandFullName} { +test basic-21.1 {Tcl_GetCommandName} { +} {} + +test basic-22.1 {Tcl_GetCommandFullName} { catch {eval namespace delete [namespace children :: test_ns_*]} namespace eval test_ns_basic1 { namespace export cmd* @@ -303,7 +343,10 @@ test basic-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_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} { +test basic-23.1 {Tcl_DeleteCommand} { +} {} + +test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} { catch {interp delete test_interp} catch {unset x} interp create test_interp @@ -323,7 +366,7 @@ test basic-10.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd [interp eval test_interp {useSet}] \ [interp delete test_interp] } {123 {set called with a 123} {}} -test basic-10.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} { +test basic-24.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename p ""} proc p {} { @@ -341,7 +384,7 @@ test basic-10.2 {Tcl_DeleteCommandFromToken, deleting commands changes command e [rename test_ns_basic::p ""] \ [test_ns_basic::callP] } {{namespace p} {} {global p}} -test basic-10.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} { +test basic-24.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 { @@ -361,7 +404,54 @@ test basic-10.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to [info commands test_ns_basic2::*] } {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP} -test basic-11.1 {TclObjInvoke, lookup of "unknown" command} { +test basic-25.1 {TclCleanupCommand} { +} {} + +test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} { + # If object isn't preserved, errorInfo would be set to + # "foo\n while executing\n\"garbage bytes\"" because the object's + # string would have been freed, leaving garbage bytes for the error + # message. + + proc bgerror {args} {set ::x $::errorInfo} + set f [open test1 w] + fileevent $f writable "fileevent $f writable {}; error foo" + set x {} + vwait x + close $f + file delete test1 + rename bgerror {} + set x +} "foo\n while executing\n\"error foo\"" + +test basic-27.1 {Tcl_ExprLong} { +} {} + +test basic-28.1 {Tcl_ExprDouble} { +} {} + +test basic-29.1 {Tcl_ExprBoolean} { +} {} + +test basic-30.1 {Tcl_ExprLongObj} { +} {} + +test basic-31.1 {Tcl_ExprDoubleObj} { +} {} + +test basic-32.1 {Tcl_ExprBooleanObj} { +} {} + +test basic-33.1 {TclInvoke} { +} {} + +test basic-34.1 {TclGlobalInvoke} { +} {} + +test basic-35.1 {TclObjInvokeGlobal} { +} {} + +test basic-36.1 {TclObjInvoke, lookup of "unknown" command} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {interp delete test_interp} interp create test_interp @@ -380,12 +470,42 @@ 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} { +test basic-37.1 {Tcl_ExprString: see expr.test} { +} {} + +test basic-38.1 {Tcl_ExprObj} { +} {} + +test basic-39.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} { + testcmdtrace tracetest {set stuff [expr 14 + 16]} +} {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}} +test basic-39.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} { testcmdtrace tracetest {set stuff [info tclversion]} -} {{info tclversion} {info tclversion} {set stuff [info tclversion]} {set stuff 8.0}} -test basic-12.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} { +} {{info tclversion} {info tclversion} {set stuff [info tclversion]} {set stuff 8.1}} +test basic-39.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} { testcmdtrace deletetest {set stuff [info tclversion]} -} 8.0 +} 8.1 + +test basic-40.1 {Tcl_DeleteTrace} { +} {} + +test basic-41.1 {Tcl_AddErrorInfo} { +} {} + +test basic-42.1 {Tcl_AddObjErrorInfo} { +} {} + +test basic-43.1 {Tcl_VarEval} { +} {} + +test basic-44.1 {Tcl_GlobalEval} { +} {} + +test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} { +} {} + +test basic-46.1 {Tcl_AllowExceptions} { +} {} catch {eval namespace delete [namespace children :: test_ns_*]} catch {namespace delete george} @@ -395,5 +515,5 @@ catch {rename q ""} catch {rename cmd ""} catch {rename value:at: ""} catch {unset x} -set x 0 -unset x + +return diff --git a/tests/binary.test b/tests/binary.test index dcc5cf6..4f49acd 100644 --- a/tests/binary.test +++ b/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.13 97/09/11 18:50:30 +# SCCS: @(#) binary.test 1.15 98/01/07 16:22:49 if {[string compare test [info procs test]] == 1} then {source defs} @@ -18,7 +18,7 @@ test binary-1.1 {Tcl_BinaryObjCmd: bad args} { } {1 {wrong # args: should be "binary option ?arg arg ...?"}} test binary-1.2 {Tcl_BinaryObjCmd: bad args} { list [catch {binary foo} msg] $msg -} {1 {bad option "foo": must be format, or scan}} +} {1 {bad option "foo": must be format or scan}} test binary-1.3 {Tcl_BinaryObjCmd: format error} { list [catch {binary f} msg] $msg @@ -1441,3 +1441,5 @@ test binary-41.8 {ScanNumber: word alignment} {nonPortable pcOnly} { catch {unset arg1; unset arg2} list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2 } {2 1 1.6} + +return diff --git a/tests/case.test b/tests/case.test index 9224372..bd7d870 100644 --- a/tests/case.test +++ b/tests/case.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: @(#) case.test 1.13 96/02/16 08:55:41 +# SCCS: @(#) case.test 1.14 97/12/08 15:02:20 if {[string compare test [info procs test]] == 1} then {source defs} @@ -81,3 +81,5 @@ test case-3.2 {single-argument form for pattern/command pairs} { test case-3.3 {single-argument form for pattern/command pairs} { list [catch {case z in {a 2 b}} msg] $msg } {1 {extra case pattern with no body}} + +return diff --git a/tests/clock.test b/tests/clock.test index 95f73ac..6af00ec 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -4,12 +4,12 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# Copyright (c) 1995-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) clock.test 1.17 97/11/24 15:05:38 +# SCCS: @(#) clock.test 1.22 98/02/02 22:03:36 if {[string compare test [info procs test]] == 1} then {source defs} @@ -41,29 +41,60 @@ test clock-3.1 {clock format tests} {unixOnly} { clock format $clockval -format {%a %b %d %I:%M:%S %p %Y} -gmt true } {Sun Nov 04 03:02:46 AM 1990} test clock-3.2 {clock format tests} { + # TCL_USE_TIMEZONE_VAR + + catch {set oldtz $env(TZ)} + set env(TZ) PST + set x {} + append x [clock format 863800000 -format %Z -gmt 1] + append x [set env(TZ)] + catch {unset env(TZ); set env(TZ) $oldtz} + set x +} {GMTPST} +test clock-3.3 {clock format tests} { + # tzset() under Borland doesn't seem to set up tzname[] for local + # timezone, which caused "clock format" to think that %Z was an invalid + # string. Don't care about answer, just that test runs w/o error. + + clock format 863800000 -format %Z + set x {} +} {} +test clock-3.4 {clock format tests} { + # tzset() under Borland doesn't seem to set up tzname[] for gmt timezone. + # tzset() under MSVC has the following weird observed behavior: + # First time we call "clock format [clock seconds] -format %Z -gmt 1" + # we get "GMT", but on all subsequent calls we get the current time + # zone string, even though env(TZ) is GMT and the variable _timezone + # is 0. + + set x {} + append x [clock format 863800000 -format %Z -gmt 1] + append x [clock format 863800000 -format %Z -gmt 1] +} {GMTGMT} +test clock-3.5 {clock format tests} { list [catch {clock format} msg] $msg } {1 {wrong # args: should be "clock format clockval ?-format string? ?-gmt boolean?"}} -test clock-3.3 {clock format tests} { +test clock-3.6 {clock format tests} { list [catch {clock format foo} msg] $msg } {1 {expected integer but got "foo"}} -test clock-3.4 {clock format tests} {unixOrPc} { +test clock-3.7 {clock format tests} {unixOrPc} { set clockval 657687766 clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true } "Sun Nov 04 03:02:46 AM 1990" -test clock-3.5 {clock format tests} { +test clock-3.8 {clock format tests} { list [catch {clock format a b c d e g} msg] $msg } {1 {wrong # args: should be "clock format clockval ?-format string? ?-gmt boolean?"}} -test clock-3.6 {clock format tests} {unixOrPc nonPortable} { +test clock-3.9 {clock format tests} {unixOrPc nonPortable} { set clockval -1 clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true } "Wed Dec 31 11:59:59 PM 1969" -test clock-3.7 {clock format tests} { +test clock-3.10 {clock format tests} { list [catch {clock format 123 -bad arg} msg] $msg -} {1 {bad switch "-bad": must be -format, or -gmt}} -test clock-3.8 {clock format tests} { +} {1 {bad switch "-bad": must be -format or -gmt}} +test clock-3.11 {clock format tests} { clock format 123 -format "x" } x -test clock-3.9 {clock format tests} { +test clock-3.12 {clock format tests} { clock format 123 -format "" } "" @@ -101,7 +132,7 @@ test clock-4.8 {clock scan tests} { } {Oct 23,1992 15:00 GMT} test clock-4.9 {clock scan tests} { list [catch {clock scan "Jan 12" -bad arg} msg] $msg -} {1 {bad switch "-bad": must be -base, or -gmt}} +} {1 {bad switch "-bad": must be -base or -gmt}} # The following two two tests test the two year date policy test clock-4.10 {clock scan tests} { set time [clock scan "1/1/71" -gmt true] @@ -173,3 +204,5 @@ test clock-6.11 {clock roll over dates} { set time [clock scan "March 1, 2001" -gmt true] clock format $time -format %j -gmt true } {060} + +return diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 351008e..4c23dae 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -4,35 +4,83 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996-1997 by Sun Microsystems, Inc. +# Copyright (c) 1996-1998 by Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) cmdAH.test 1.35 97/07/22 14:07:43 +# SCCS: @(#) cmdAH.test 1.41 98/02/02 21:59:54 if {[string compare test [info procs test]] == 1} then {source defs} global env set platform [testgetplatform] -test cmdAH-1.1 {Tcl_FileObjCmd} { +test cmdAH-1.1 {Tcl_CdObjCmd} { + list [catch {cd foo bar} msg] $msg +} {1 {wrong # args: should be "cd ?dirName?"}} +test cmdAH-1.2 {Tcl_CdObjCmd} { + file delete -force foo + file mkdir foo + cd foo + set result [file tail [pwd]] + cd .. + file delete foo + set result +} foo +test cmdAH-1.3 {Tcl_CdObjCmd} { + global env + set oldpwd [pwd] + set temp $env(HOME) + set env(HOME) $oldpwd + file delete -force foo + file mkdir foo + cd foo + cd ~ + set result [string match [pwd] $oldpwd] + file delete foo + set env(HOME) $temp + set result +} 1 +test cmdAH-1.4 {Tcl_CdObjCmd} { + global env + set oldpwd [pwd] + set temp $env(HOME) + set env(HOME) $oldpwd + file delete -force foo + file mkdir foo + cd foo + cd + set result [string match [pwd] $oldpwd] + file delete foo + set env(HOME) $temp + set result +} 1 +test cmdAH-1.5 {Tcl_CdObjCmd} { + list [catch {cd ~~} msg] $msg +} {1 {user "~" doesn't exist}} +test cmdAH-1.6 {Tcl_CdObjCmd} { + list [catch {cd _foobar} msg] $msg +} {1 {couldn't change working directory to "_foobar": no such file or directory}} + + +test cmdAH-2.1 {Tcl_FileObjCmd} { list [catch file msg] $msg } {1 {wrong # args: should be "file option ?arg ...?"}} -test cmdAH-1.2 {Tcl_FileObjCmd} { +test cmdAH-2.2 {Tcl_FileObjCmd} { list [catch {file x} msg] $msg } {1 {bad option "x": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-1.3 {Tcl_FileObjCmd} { +test cmdAH-2.3 {Tcl_FileObjCmd} { list [catch {file atime} msg] $msg -} {1 {wrong # args: should be "file atime name ?arg ...?"}} +} {1 {wrong # args: should be "file atime name"}} #volume -test cmdAH-2.1 {Tcl_FileObjCmd: volumes} { +test cmdAH-3.1 {Tcl_FileObjCmd: volumes} { list [catch {file volumes x} msg] $msg } {1 {wrong # args: should be "file volumes"}} -test cmdAH-2.2 {Tcl_FileObjCmd: volumes} { +test cmdAH-3.2 {Tcl_FileObjCmd: volumes} { set volumeList [file volumes] if { [llength $volumeList] == 0 } { set result 0 @@ -40,18 +88,18 @@ test cmdAH-2.2 {Tcl_FileObjCmd: volumes} { set result 1 } } {1} -test cmdAH-2.3 {Tcl_FileObjCmd: volumes} {macOrUnix} { +test cmdAH-3.3 {Tcl_FileObjCmd: volumes} {macOrUnix} { set volumeList [file volumes] catch [list glob -nocomplain [lindex $volumeList 0]*] } {0} -test cmdAH-2.4 {Tcl_FileObjCmd: volumes} {pcOnly} { - set volumeList [file volumes] +test cmdAH-3.4 {Tcl_FileObjCmd: volumes} {pcOnly} { + set volumeList [string tolower [file volumes]] list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}] } {0 1 0} # attributes -test cmdAH-3.1 {Tcl_FileObjCmd - file attrs} { +test cmdAH-4.1 {Tcl_FileObjCmd - file attrs} { catch {file delete -force foo.file} close [open foo.file w] list [catch {file attributes foo.file}] [file delete -force foo.file] @@ -59,175 +107,175 @@ test cmdAH-3.1 {Tcl_FileObjCmd - file attrs} { # dirname -test cmdAH-4.1 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.1 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname a b} msg] $msg } {1 {wrong # args: should be "file dirname name"}} -test cmdAH-4.2 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.2 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname /a/b } /a -test cmdAH-4.3 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.3 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname {} } . -test cmdAH-4.4 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.4 {Tcl_FileObjCmd: dirname} { testsetplatform mac file dirname {} } : -test cmdAH-4.5 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.5 {Tcl_FileObjCmd: dirname} { testsetplatform win file dirname {} } . -test cmdAH-4.6 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.6 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname .def } . -test cmdAH-4.7 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.7 {Tcl_FileObjCmd: dirname} { testsetplatform mac file dirname a } : -test cmdAH-4.8 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.8 {Tcl_FileObjCmd: dirname} { testsetplatform win file dirname a } . -test cmdAH-4.9 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.9 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname a/b/c.d } a/b -test cmdAH-4.10 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.10 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname a/b.c/d } a/b.c -test cmdAH-4.11 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.11 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname /. } / -test cmdAH-4.12 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.12 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname /} msg] $msg } {0 /} -test cmdAH-4.13 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.13 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname /foo} msg] $msg } {0 /} -test cmdAH-4.14 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.14 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname //foo} msg] $msg } {0 /} -test cmdAH-4.15 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.15 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname //foo/bar} msg] $msg } {0 /foo} -test cmdAH-4.16 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.16 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname {//foo\/bar/baz}} msg] $msg } {0 {/foo\/bar}} -test cmdAH-4.17 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.17 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname {//foo\/bar/baz/blat}} msg] $msg } {0 {/foo\/bar/baz}} -test cmdAH-4.18 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.18 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname /foo//} msg] $msg } {0 /} -test cmdAH-4.19 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.19 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname ./a} msg] $msg } {0 .} -test cmdAH-4.20 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.20 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname a/.a} msg] $msg } {0 a} -test cmdAH-4.21 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.21 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname c:foo} msg] $msg } {0 c:} -test cmdAH-4.22 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.22 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname c:} msg] $msg } {0 c:} -test cmdAH-4.23 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.23 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname c:/} msg] $msg } {0 c:/} -test cmdAH-4.24 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.24 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname {c:\foo}} msg] $msg } {0 c:/} -test cmdAH-4.25 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.25 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname {//foo/bar/baz}} msg] $msg } {0 //foo/bar} -test cmdAH-4.26 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.26 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname {//foo/bar}} msg] $msg } {0 //foo/bar} -test cmdAH-4.27 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.27 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :} msg] $msg } {0 :} -test cmdAH-4.28 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.28 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :Foo} msg] $msg } {0 :} -test cmdAH-4.29 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.29 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname Foo:} msg] $msg } {0 Foo:} -test cmdAH-4.30 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.30 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname Foo:bar} msg] $msg } {0 Foo:} -test cmdAH-4.31 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.31 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :Foo:bar} msg] $msg } {0 :Foo} -test cmdAH-4.32 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.32 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ::} msg] $msg } {0 :} -test cmdAH-4.33 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.33 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :::} msg] $msg } {0 ::} -test cmdAH-4.34 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.34 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname /foo/bar/} msg] $msg } {0 foo:} -test cmdAH-4.35 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.35 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname /foo/bar} msg] $msg } {0 foo:} -test cmdAH-4.36 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.36 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname /foo} msg] $msg } {0 foo:} -test cmdAH-4.37 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.37 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname foo} msg] $msg } {0 :} -test cmdAH-4.38 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.38 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname ~/foo} msg] $msg } {0 ~} -test cmdAH-4.39 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.39 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname ~bar/foo} msg] $msg } {0 ~bar} -test cmdAH-4.40 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.40 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ~bar/foo} msg] $msg } {0 ~bar:} -test cmdAH-4.41 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.41 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ~/foo} msg] $msg } {0 ~:} -test cmdAH-4.42 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.42 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ~:baz} msg] $msg } {0 ~:} -test cmdAH-4.43 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.43 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -236,7 +284,7 @@ test cmdAH-4.43 {Tcl_FileObjCmd: dirname} { set env(HOME) $temp set result } {0 /home} -test cmdAH-4.44 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.44 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "~" @@ -245,7 +293,7 @@ test cmdAH-4.44 {Tcl_FileObjCmd: dirname} { set env(HOME) $temp set result } {0 ~} -test cmdAH-4.45 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.45 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -254,7 +302,7 @@ test cmdAH-4.45 {Tcl_FileObjCmd: dirname} { set env(HOME) $temp set result } {0 /home} -test cmdAH-4.46 {Tcl_FileObjCmd: dirname} { +test cmdAH-5.46 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -266,171 +314,171 @@ test cmdAH-4.46 {Tcl_FileObjCmd: dirname} { # tail -test cmdAH-5.1 {Tcl_FileObjCmd: tail} { +test cmdAH-6.1 {Tcl_FileObjCmd: tail} { testsetplatform unix list [catch {file tail a b} msg] $msg } {1 {wrong # args: should be "file tail name"}} -test cmdAH-5.2 {Tcl_FileObjCmd: tail} { +test cmdAH-6.2 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /a/b } b -test cmdAH-5.3 {Tcl_FileObjCmd: tail} { +test cmdAH-6.3 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {} } {} -test cmdAH-5.4 {Tcl_FileObjCmd: tail} { +test cmdAH-6.4 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail {} } {} -test cmdAH-5.5 {Tcl_FileObjCmd: tail} { +test cmdAH-6.5 {Tcl_FileObjCmd: tail} { testsetplatform win file tail {} } {} -test cmdAH-5.6 {Tcl_FileObjCmd: tail} { +test cmdAH-6.6 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail .def } .def -test cmdAH-5.7 {Tcl_FileObjCmd: tail} { +test cmdAH-6.7 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail a } a -test cmdAH-5.8 {Tcl_FileObjCmd: tail} { +test cmdAH-6.8 {Tcl_FileObjCmd: tail} { testsetplatform win file tail a } a -test cmdAH-5.9 {Tcl_FileObjCmd: tail} { +test cmdAH-6.9 {Tcl_FileObjCmd: tail} { testsetplatform unix file ta a/b/c.d } c.d -test cmdAH-5.10 {Tcl_FileObjCmd: tail} { +test cmdAH-6.10 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail a/b.c/d } d -test cmdAH-5.11 {Tcl_FileObjCmd: tail} { +test cmdAH-6.11 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /. } . -test cmdAH-5.12 {Tcl_FileObjCmd: tail} { +test cmdAH-6.12 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail / } {} -test cmdAH-5.13 {Tcl_FileObjCmd: tail} { +test cmdAH-6.13 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /foo } foo -test cmdAH-5.14 {Tcl_FileObjCmd: tail} { +test cmdAH-6.14 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail //foo } foo -test cmdAH-5.15 {Tcl_FileObjCmd: tail} { +test cmdAH-6.15 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail //foo/bar } bar -test cmdAH-5.16 {Tcl_FileObjCmd: tail} { +test cmdAH-6.16 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {//foo\/bar/baz} } baz -test cmdAH-5.17 {Tcl_FileObjCmd: tail} { +test cmdAH-6.17 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {//foo\/bar/baz/blat} } blat -test cmdAH-5.18 {Tcl_FileObjCmd: tail} { +test cmdAH-6.18 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /foo// } foo -test cmdAH-5.19 {Tcl_FileObjCmd: tail} { +test cmdAH-6.19 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail ./a } a -test cmdAH-5.20 {Tcl_FileObjCmd: tail} { +test cmdAH-6.20 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail a/.a } .a -test cmdAH-5.21 {Tcl_FileObjCmd: tail} { +test cmdAH-6.21 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:foo } foo -test cmdAH-5.22 {Tcl_FileObjCmd: tail} { +test cmdAH-6.22 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c: } {} -test cmdAH-5.23 {Tcl_FileObjCmd: tail} { +test cmdAH-6.23 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:/ } {} -test cmdAH-5.24 {Tcl_FileObjCmd: tail} { +test cmdAH-6.24 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {c:\foo} } foo -test cmdAH-5.25 {Tcl_FileObjCmd: tail} { +test cmdAH-6.25 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {//foo/bar/baz} } baz -test cmdAH-5.26 {Tcl_FileObjCmd: tail} { +test cmdAH-6.26 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {//foo/bar} } {} -test cmdAH-5.27 {Tcl_FileObjCmd: tail} { +test cmdAH-6.27 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail : } : -test cmdAH-5.28 {Tcl_FileObjCmd: tail} { +test cmdAH-6.28 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail :Foo } Foo -test cmdAH-5.29 {Tcl_FileObjCmd: tail} { +test cmdAH-6.29 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail Foo: } {} -test cmdAH-5.30 {Tcl_FileObjCmd: tail} { +test cmdAH-6.30 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail Foo:bar } bar -test cmdAH-5.31 {Tcl_FileObjCmd: tail} { +test cmdAH-6.31 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail :Foo:bar } bar -test cmdAH-5.32 {Tcl_FileObjCmd: tail} { +test cmdAH-6.32 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail :: } :: -test cmdAH-5.33 {Tcl_FileObjCmd: tail} { +test cmdAH-6.33 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ::: } :: -test cmdAH-5.34 {Tcl_FileObjCmd: tail} { +test cmdAH-6.34 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail /foo/bar/ } bar -test cmdAH-5.35 {Tcl_FileObjCmd: tail} { +test cmdAH-6.35 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail /foo/bar } bar -test cmdAH-5.36 {Tcl_FileObjCmd: tail} { +test cmdAH-6.36 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail /foo } {} -test cmdAH-5.37 {Tcl_FileObjCmd: tail} { +test cmdAH-6.37 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail foo } foo -test cmdAH-5.38 {Tcl_FileObjCmd: tail} { +test cmdAH-6.38 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~:foo } foo -test cmdAH-5.39 {Tcl_FileObjCmd: tail} { +test cmdAH-6.39 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~bar:foo } foo -test cmdAH-5.40 {Tcl_FileObjCmd: tail} { +test cmdAH-6.40 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~bar/foo } foo -test cmdAH-5.41 {Tcl_FileObjCmd: tail} { +test cmdAH-6.41 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~/foo } foo -test cmdAH-5.42 {Tcl_FileObjCmd: tail} { +test cmdAH-6.42 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -439,7 +487,7 @@ test cmdAH-5.42 {Tcl_FileObjCmd: tail} { set env(HOME) $temp set result } test -test cmdAH-5.43 {Tcl_FileObjCmd: tail} { +test cmdAH-6.43 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "~" @@ -448,7 +496,7 @@ test cmdAH-5.43 {Tcl_FileObjCmd: tail} { set env(HOME) $temp set result } {} -test cmdAH-5.44 {Tcl_FileObjCmd: tail} { +test cmdAH-6.44 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -457,7 +505,7 @@ test cmdAH-5.44 {Tcl_FileObjCmd: tail} { set env(HOME) $temp set result } test -test cmdAH-5.45 {Tcl_FileObjCmd: tail} { +test cmdAH-6.45 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -466,166 +514,166 @@ test cmdAH-5.45 {Tcl_FileObjCmd: tail} { set env(HOME) $temp set result } test -test cmdAH-5.46 {Tcl_FileObjCmd: tail} { +test cmdAH-6.46 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {f.oo\bar/baz.bat} } baz.bat -test cmdAH-5.47 {Tcl_FileObjCmd: tail} { +test cmdAH-6.47 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:foo } foo -test cmdAH-5.48 {Tcl_FileObjCmd: tail} { +test cmdAH-6.48 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c: } {} -test cmdAH-5.49 {Tcl_FileObjCmd: tail} { +test cmdAH-6.49 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:/foo } foo -test cmdAH-5.50 {Tcl_FileObjCmd: tail} { +test cmdAH-6.50 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {c:/foo\bar} } bar -test cmdAH-5.51 {Tcl_FileObjCmd: tail} { +test cmdAH-6.51 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {foo\bar} } bar # rootname -test cmdAH-6.1 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.1 {Tcl_FileObjCmd: rootname} { testsetplatform unix list [catch {file rootname a b} msg] $msg } {1 {wrong # args: should be "file rootname name"}} -test cmdAH-6.2 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.2 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname {} } {} -test cmdAH-6.3 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.3 {Tcl_FileObjCmd: rootname} { testsetplatform unix file ro foo } foo -test cmdAH-6.4 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.4 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname foo. } foo -test cmdAH-6.5 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.5 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname .foo } {} -test cmdAH-6.6 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.6 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname abc.def } abc -test cmdAH-6.7 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.7 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname abc.def.ghi } abc.def -test cmdAH-6.8 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.8 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname a/b/c.d } a/b/c -test cmdAH-6.9 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.9 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname a/b.c/d } a/b.c/d -test cmdAH-6.10 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.10 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname a/b.c/ } a/b.c/ -test cmdAH-6.11 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.11 {Tcl_FileObjCmd: rootname} { testsetplatform mac file ro foo } foo -test cmdAH-6.12 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.12 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname {} } {} -test cmdAH-6.13 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.13 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname foo. } foo -test cmdAH-6.14 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.14 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname .foo } {} -test cmdAH-6.15 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.15 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname abc.def } abc -test cmdAH-6.16 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.16 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname abc.def.ghi } abc.def -test cmdAH-6.17 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.17 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a:b:c.d } a:b:c -test cmdAH-6.18 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.18 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a:b.c:d } a:b.c:d -test cmdAH-6.19 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.19 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a/b/c.d } a/b/c -test cmdAH-6.20 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.20 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a/b.c/d } a/b.c/d -test cmdAH-6.21 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.21 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname /a.b } /a -test cmdAH-6.22 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.22 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname foo.c: } foo.c: -test cmdAH-6.23 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.23 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname {} } {} -test cmdAH-6.24 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.24 {Tcl_FileObjCmd: rootname} { testsetplatform windows file ro foo } foo -test cmdAH-6.25 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.25 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname foo. } foo -test cmdAH-6.26 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.26 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname .foo } {} -test cmdAH-6.27 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.27 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname abc.def } abc -test cmdAH-6.28 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.28 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname abc.def.ghi } abc.def -test cmdAH-6.29 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.29 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a/b/c.d } a/b/c -test cmdAH-6.30 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.30 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a/b.c/d } a/b.c/d -test cmdAH-6.31 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.31 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b.c\\ } a\\b.c\\ -test cmdAH-6.32 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.32 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b\\c.d } a\\b\\c -test cmdAH-6.33 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.33 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b.c\\d } a\\b.c\\d -test cmdAH-6.34 {Tcl_FileObjCmd: rootname} { +test cmdAH-7.34 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b.c\\ } a\\b.c\\ @@ -643,139 +691,139 @@ foreach outer { {} a .a a. a.a } { # extension -test cmdAH-7.1 {Tcl_FileObjCmd: extension} { +test cmdAH-8.1 {Tcl_FileObjCmd: extension} { testsetplatform unix list [catch {file extension a b} msg] $msg } {1 {wrong # args: should be "file extension name"}} -test cmdAH-7.2 {Tcl_FileObjCmd: extension} { +test cmdAH-8.2 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension {} } {} -test cmdAH-7.3 {Tcl_FileObjCmd: extension} { +test cmdAH-8.3 {Tcl_FileObjCmd: extension} { testsetplatform unix file ext foo } {} -test cmdAH-7.4 {Tcl_FileObjCmd: extension} { +test cmdAH-8.4 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension foo. } . -test cmdAH-7.5 {Tcl_FileObjCmd: extension} { +test cmdAH-8.5 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension .foo } .foo -test cmdAH-7.6 {Tcl_FileObjCmd: extension} { +test cmdAH-8.6 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension abc.def } .def -test cmdAH-7.7 {Tcl_FileObjCmd: extension} { +test cmdAH-8.7 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension abc.def.ghi } .ghi -test cmdAH-7.8 {Tcl_FileObjCmd: extension} { +test cmdAH-8.8 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension a/b/c.d } .d -test cmdAH-7.9 {Tcl_FileObjCmd: extension} { +test cmdAH-8.9 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension a/b.c/d } {} -test cmdAH-7.10 {Tcl_FileObjCmd: extension} { +test cmdAH-8.10 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension a/b.c/ } {} -test cmdAH-7.11 {Tcl_FileObjCmd: extension} { +test cmdAH-8.11 {Tcl_FileObjCmd: extension} { testsetplatform mac file ext foo } {} -test cmdAH-7.12 {Tcl_FileObjCmd: extension} { +test cmdAH-8.12 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension {} } {} -test cmdAH-7.13 {Tcl_FileObjCmd: extension} { +test cmdAH-8.13 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension foo. } . -test cmdAH-7.14 {Tcl_FileObjCmd: extension} { +test cmdAH-8.14 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension .foo } .foo -test cmdAH-7.15 {Tcl_FileObjCmd: extension} { +test cmdAH-8.15 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension abc.def } .def -test cmdAH-7.16 {Tcl_FileObjCmd: extension} { +test cmdAH-8.16 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension abc.def.ghi } .ghi -test cmdAH-7.17 {Tcl_FileObjCmd: extension} { +test cmdAH-8.17 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a:b:c.d } .d -test cmdAH-7.18 {Tcl_FileObjCmd: extension} { +test cmdAH-8.18 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a:b.c:d } {} -test cmdAH-7.19 {Tcl_FileObjCmd: extension} { +test cmdAH-8.19 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a/b/c.d } .d -test cmdAH-7.20 {Tcl_FileObjCmd: extension} { +test cmdAH-8.20 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a/b.c/d } {} -test cmdAH-7.21 {Tcl_FileObjCmd: extension} { +test cmdAH-8.21 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension /a.b } .b -test cmdAH-7.22 {Tcl_FileObjCmd: extension} { +test cmdAH-8.22 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension foo.c: } {} -test cmdAH-7.23 {Tcl_FileObjCmd: extension} { +test cmdAH-8.23 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension {} } {} -test cmdAH-7.24 {Tcl_FileObjCmd: extension} { +test cmdAH-8.24 {Tcl_FileObjCmd: extension} { testsetplatform windows file ext foo } {} -test cmdAH-7.25 {Tcl_FileObjCmd: extension} { +test cmdAH-8.25 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension foo. } . -test cmdAH-7.26 {Tcl_FileObjCmd: extension} { +test cmdAH-8.26 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension .foo } .foo -test cmdAH-7.27 {Tcl_FileObjCmd: extension} { +test cmdAH-8.27 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension abc.def } .def -test cmdAH-7.28 {Tcl_FileObjCmd: extension} { +test cmdAH-8.28 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension abc.def.ghi } .ghi -test cmdAH-7.29 {Tcl_FileObjCmd: extension} { +test cmdAH-8.29 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a/b/c.d } .d -test cmdAH-7.30 {Tcl_FileObjCmd: extension} { +test cmdAH-8.30 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a/b.c/d } {} -test cmdAH-7.31 {Tcl_FileObjCmd: extension} { +test cmdAH-8.31 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b.c\\ } {} -test cmdAH-7.32 {Tcl_FileObjCmd: extension} { +test cmdAH-8.32 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b\\c.d } .d -test cmdAH-7.33 {Tcl_FileObjCmd: extension} { +test cmdAH-8.33 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b.c\\d } {} -test cmdAH-7.34 {Tcl_FileObjCmd: extension} { +test cmdAH-8.34 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b.c\\ } {} @@ -792,56 +840,56 @@ foreach value {a..b a...b a.c..b ..b} result {..b ...b ..b ..b} { # pathtype -test cmdAH-8.1 {Tcl_FileObjCmd: pathtype} { +test cmdAH-9.1 {Tcl_FileObjCmd: pathtype} { testsetplatform unix list [catch {file pathtype a b} msg] $msg } {1 {wrong # args: should be "file pathtype name"}} -test cmdAH-8.2 {Tcl_FileObjCmd: pathtype} { +test cmdAH-9.2 {Tcl_FileObjCmd: pathtype} { testsetplatform unix file pathtype /a } absolute -test cmdAH-8.3 {Tcl_FileObjCmd: pathtype} { +test cmdAH-9.3 {Tcl_FileObjCmd: pathtype} { testsetplatform unix file p a } relative -test cmdAH-8.4 {Tcl_FileObjCmd: pathtype} { +test cmdAH-9.4 {Tcl_FileObjCmd: pathtype} { testsetplatform windows file pathtype c:a } volumerelative # split -test cmdAH-9.1 {Tcl_FileObjCmd: split} { +test cmdAH-10.1 {Tcl_FileObjCmd: split} { testsetplatform unix list [catch {file split a b} msg] $msg } {1 {wrong # args: should be "file split name"}} -test cmdAH-9.2 {Tcl_FileObjCmd: split} { +test cmdAH-10.2 {Tcl_FileObjCmd: split} { testsetplatform unix file split a } a -test cmdAH-9.3 {Tcl_FileObjCmd: split} { +test cmdAH-10.3 {Tcl_FileObjCmd: split} { testsetplatform unix file split a/b } {a b} # join -test cmdAH-10.1 {Tcl_FileObjCmd: join} { +test cmdAH-11.1 {Tcl_FileObjCmd: join} { testsetplatform unix file join a } a -test cmdAH-10.2 {Tcl_FileObjCmd: join} { +test cmdAH-11.2 {Tcl_FileObjCmd: join} { testsetplatform unix file join a b } a/b -test cmdAH-10.3 {Tcl_FileObjCmd: join} { +test cmdAH-11.3 {Tcl_FileObjCmd: join} { testsetplatform unix file join a b c d } a/b/c/d # error handling of Tcl_TranslateFileName -test cmdAH-11.1 {Tcl_FileObjCmd} { +test cmdAH-12.1 {Tcl_FileObjCmd} { testsetplatform unix list [catch {file atime ~_bad_user} msg] $msg } {1 {user "_bad_user" doesn't exist}} @@ -852,29 +900,29 @@ makeDirectory dir.file # readable -test cmdAH-12.1 {Tcl_FileObjCmd: readable} { +test cmdAH-13.1 {Tcl_FileObjCmd: readable} { list [catch {file readable a b} msg] $msg } {1 {wrong # args: should be "file readable name"}} testchmod 444 gorp.file -test cmdAH-12.2 {Tcl_FileObjCmd: readable} { +test cmdAH-13.2 {Tcl_FileObjCmd: readable} { file readable gorp.file } 1 testchmod 333 gorp.file -test cmdAH-12.3 {Tcl_FileObjCmd: readable} {unixOnly && !root} { +test cmdAH-13.3 {Tcl_FileObjCmd: readable} {unixOnly && !root} { file reada gorp.file } 0 # writable -test cmdAH-13.1 {Tcl_FileObjCmd: writable} { +test cmdAH-14.1 {Tcl_FileObjCmd: writable} { list [catch {file writable a b} msg] $msg } {1 {wrong # args: should be "file writable name"}} testchmod 555 gorp.file -test cmdAH-13.2 {Tcl_FileObjCmd: writable} {!root} { +test cmdAH-14.2 {Tcl_FileObjCmd: writable} {!root} { file writable gorp.file } 0 testchmod 222 gorp.file -test cmdAH-13.3 {Tcl_FileObjCmd: writable} { +test cmdAH-14.3 {Tcl_FileObjCmd: writable} { file writable gorp.file } 1 @@ -884,13 +932,13 @@ file delete -force dir.file gorp.file file mkdir dir.file makeFile abcde gorp.file -test cmdAH-14.1 {Tcl_FileObjCmd: executable} { +test cmdAH-15.1 {Tcl_FileObjCmd: executable} { list [catch {file executable a b} msg] $msg } {1 {wrong # args: should be "file executable name"}} -test cmdAH-14.2 {Tcl_FileObjCmd: executable} { +test cmdAH-15.2 {Tcl_FileObjCmd: executable} { file executable gorp.file } 0 -test cmdAH-14.3 {Tcl_FileObjCmd: executable} {unix} { +test cmdAH-15.3 {Tcl_FileObjCmd: executable} {unix} { # Only on unix will setting the execute bit on a regular file # cause that file to be executable. @@ -898,14 +946,14 @@ test cmdAH-14.3 {Tcl_FileObjCmd: executable} {unix} { file exe gorp.file } 1 -test cmdAH-14.4 {Tcl_FileObjCmd: executable} {mac} { +test cmdAH-15.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} { +test cmdAH-15.5 {Tcl_FileObjCmd: executable} {pc} { # On pc, must be a .exe, .com, etc. set x [file exe gorp.file] @@ -914,7 +962,7 @@ test cmdAH-14.5 {Tcl_FileObjCmd: executable} {pc} { file delete gorp.exe set x } {0 1} -test cmdAH-14.6 {Tcl_FileObjCmd: executable} { +test cmdAH-15.6 {Tcl_FileObjCmd: executable} { # Directories are always executable. file exe dir.file @@ -925,11 +973,11 @@ file delete gorp.file file delete link.file # exists -test cmdAH-15.1 {Tcl_FileObjCmd: exists} { +test cmdAH-16.1 {Tcl_FileObjCmd: exists} { list [catch {file exists a b} msg] $msg } {1 {wrong # args: should be "file exists name"}} -test cmdAH-15.2 {Tcl_FileObjCmd: exists} {file exists gorp.file} 0 -test cmdAH-15.3 {Tcl_FileObjCmd: exists} { +test cmdAH-16.2 {Tcl_FileObjCmd: exists} {file exists gorp.file} 0 +test cmdAH-16.3 {Tcl_FileObjCmd: exists} { file exists [file join dir.file gorp.file] } 0 catch { @@ -937,31 +985,31 @@ catch { makeDirectory dir.file makeFile 12345 [file join dir.file gorp.file] } -test cmdAH-15.4 {Tcl_FileObjCmd: exists} { +test cmdAH-16.4 {Tcl_FileObjCmd: exists} { file exists gorp.file } 1 -test cmdAH-15.5 {Tcl_FileObjCmd: exists} { +test cmdAH-16.5 {Tcl_FileObjCmd: exists} { file exists [file join dir.file gorp.file] } 1 # nativename -test cmdAH-15.6 {Tcl_FileObjCmd: nativename} { +test cmdAH-16.6 {Tcl_FileObjCmd: nativename} { testsetplatform unix list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] } {0 a/b {}} -test cmdAH-15.7 {Tcl_FileObjCmd: nativename} { +test cmdAH-16.7 {Tcl_FileObjCmd: nativename} { testsetplatform windows list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] } {0 {a\b} {}} -test cmdAH-15.8 {Tcl_FileObjCmd: nativename} { +test cmdAH-16.8 {Tcl_FileObjCmd: nativename} { testsetplatform mac list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] } {0 :a:b {}} -test cmdAH-15.9 {Tcl_FileObjCmd: ~ : exists} { +test cmdAH-16.9 {Tcl_FileObjCmd: ~ : exists} { file exists ~nOsUcHuSeR } 0 -test cmdAH-15.10 {Tcl_FileObjCmd: ~ : nativename} { +test cmdAH-16.10 {Tcl_FileObjCmd: ~ : nativename} { # should probably be 0 in fact... catch {file nativename ~nOsUcHuSeR} } 1 @@ -977,7 +1025,7 @@ if {$tcl_platform(platform) == "unix"} { makeFile 12345 /tmp/tcl.foo.dir/file exec chmod 000 /tmp/tcl.foo.dir if {$user != "root"} { - test cmdAH-15.9 {Tcl_FileObjCmd: exists} { + test cmdAH-16.11 {Tcl_FileObjCmd: exists} { file exists /tmp/tcl.foo.dir/file } 0 } @@ -995,65 +1043,65 @@ catch {exec chmod 765 gorp.file} # atime -test cmdAH-16.1 {Tcl_FileObjCmd: atime} { +test cmdAH-17.1 {Tcl_FileObjCmd: atime} { list [catch {file atime a b} msg] $msg } {1 {wrong # args: should be "file atime name"}} -test cmdAH-16.2 {Tcl_FileObjCmd: atime} { +test cmdAH-17.2 {Tcl_FileObjCmd: atime} { catch {unset stat} file stat gorp.file stat list [expr {[file mtime gorp.file] == $stat(mtime)}] \ [expr {[file atime gorp.file] == $stat(atime)}] } {1 1} -test cmdAH-16.3 {Tcl_FileObjCmd: atime} { +test cmdAH-17.3 {Tcl_FileObjCmd: atime} { string tolower [list [catch {file atime _bogus_} msg] \ $msg $errorCode] -} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} # isdirectory -test cmdAH-17.1 {Tcl_FileObjCmd: isdirectory} { +test cmdAH-18.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} { +test cmdAH-18.2 {Tcl_FileObjCmd: isdirectory} { file isdirectory gorp.file } 0 -test cmdAH-17.3 {Tcl_FileObjCmd: isdirectory} { +test cmdAH-18.3 {Tcl_FileObjCmd: isdirectory} { file isd dir.file } 1 # isfile -test cmdAH-18.1 {Tcl_FileObjCmd: isfile} { +test cmdAH-19.1 {Tcl_FileObjCmd: isfile} { list [catch {file isfile a b} msg] $msg } {1 {wrong # args: should be "file isfile name"}} -test cmdAH-18.2 {Tcl_FileObjCmd: isfile} {file isfile gorp.file} 1 -test cmdAH-18.3 {Tcl_FileObjCmd: isfile} {file isfile dir.file} 0 +test cmdAH-19.2 {Tcl_FileObjCmd: isfile} {file isfile gorp.file} 1 +test cmdAH-19.3 {Tcl_FileObjCmd: isfile} {file isfile dir.file} 0 # lstat and readlink: don't run these tests everywhere, since not all # sites will have symbolic links catch {exec ln -s gorp.file link.file} -test cmdAH-19.1 {Tcl_FileObjCmd: lstat} { +test cmdAH-20.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} { +test cmdAH-20.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} { +test cmdAH-20.3 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} { catch {unset stat} file lstat link.file stat lsort [array names stat] } {atime ctime dev gid ino mode mtime nlink size type uid} -test cmdAH-19.4 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} { +test cmdAH-20.4 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} { catch {unset stat} file lstat link.file stat list $stat(nlink) [expr $stat(mode)&0777] $stat(type) } {1 511 link} -test cmdAH-19.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} { +test cmdAH-20.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} { +} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdAH-20.6 {Tcl_FileObjCmd: lstat errors} { catch {unset x} set x 44 list [catch {file lstat gorp.file x} msg] $msg $errorCode @@ -1062,10 +1110,10 @@ catch {unset stat} # mtime -test cmdAH-20.1 {Tcl_FileObjCmd: mtime} { +test cmdAH-21.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} { +test cmdAH-21.2 {Tcl_FileObjCmd: mtime} { set old [file mtime gorp.file] after 2000 set f [open gorp.file w] @@ -1074,17 +1122,17 @@ test cmdAH-20.2 {Tcl_FileObjCmd: mtime} { set new [file mtime gorp.file] expr {($new > $old) && ($new <= ($old+5))} } {1} -test cmdAH-20.3 {Tcl_FileObjCmd: mtime} { +test cmdAH-21.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} { +test cmdAH-21.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}}} -test cmdAH-20.5 {Tcl_FileObjCmd: mtime} { +} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdAH-21.5 {Tcl_FileObjCmd: mtime} { # Under Unix, use a file in /tmp to avoid clock skew due to NFS. # On other platforms, just use a file in the local directory. @@ -1094,9 +1142,8 @@ test cmdAH-20.5 {Tcl_FileObjCmd: mtime} { set name tf } - # Borland file times were off by timezone. Make sure that a new file's - # time is correct. 10 seconds variance is allowed used due to slow - # networks or clock skew on a network drive. + # Make sure that a new file's time is correct. 10 seconds variance + # is allowed used due to slow networks or clock skew on a network drive. file delete -force $name close [open $name w] @@ -1108,43 +1155,43 @@ test cmdAH-20.5 {Tcl_FileObjCmd: mtime} { # owned -test cmdAH-21.1 {Tcl_FileObjCmd: owned} { +test cmdAH-22.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} { +test cmdAH-22.2 {Tcl_FileObjCmd: owned} { file owned gorp.file } 1 -test cmdAH-21.3 {Tcl_FileObjCmd: owned} {unixOnly && !root} { +test cmdAH-22.3 {Tcl_FileObjCmd: owned} {unixOnly && !root} { file owned / } 0 # readlink -test cmdAH-22.1 {Tcl_FileObjCmd: readlink} { +test cmdAH-23.1 {Tcl_FileObjCmd: readlink} { list [catch {file readlink a b} msg] $msg } {1 {wrong # args: should be "file readlink name"}} -test cmdAH-22.2 {Tcl_FileObjCmd: readlink} {unixOnly nonPortable} { +test cmdAH-23.2 {Tcl_FileObjCmd: readlink} {unixOnly nonPortable} { file readlink link.file } gorp.file -test cmdAH-22.3 {Tcl_FileObjCmd: readlink errors} {unixOnly nonPortable} { +test cmdAH-23.3 {Tcl_FileObjCmd: readlink errors} {unixOnly nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] -} {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} -test cmdAH-22.4 {Tcl_FileObjCmd: readlink errors} {macOnly nonPortable} { +} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdAH-23.4 {Tcl_FileObjCmd: readlink errors} {macOnly nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] -} {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} -test cmdAH-22.5 {Tcl_FileObjCmd: readlink errors} {pcOnly nonPortable} { +} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdAH-23.5 {Tcl_FileObjCmd: readlink errors} {pcOnly nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] -} {1 {couldn't readlink "_bogus_": invalid argument} {posix einval {invalid argument}}} +} {1 {could not readlink "_bogus_": invalid argument} {posix einval {invalid argument}}} # size -test cmdAH-23.1 {Tcl_FileObjCmd: size} { +test cmdAH-24.1 {Tcl_FileObjCmd: size} { list [catch {file size a b} msg] $msg } {1 {wrong # args: should be "file size name"}} -test cmdAH-23.2 {Tcl_FileObjCmd: size} { +test cmdAH-24.2 {Tcl_FileObjCmd: size} { set oldsize [file size gorp.file] set f [open gorp.file a] fconfigure $f -translation lf -eofchar {} @@ -1152,10 +1199,10 @@ test cmdAH-23.2 {Tcl_FileObjCmd: size} { close $f expr {[file size gorp.file] - $oldsize} } {10} -test cmdAH-23.3 {Tcl_FileObjCmd: size} { +test cmdAH-24.3 {Tcl_FileObjCmd: size} { string tolower [list [catch {file size _bogus_} msg] $msg \ $errorCode] -} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} # stat @@ -1163,85 +1210,137 @@ testsetplatform $platform makeFile "Test string" gorp.file catch {exec chmod 765 gorp.file} -test cmdAH-24.1 {Tcl_FileObjCmd: stat} { +test cmdAH-25.1 {Tcl_FileObjCmd: stat} { list [catch {file stat _bogus_} msg] $msg $errorCode } {1 {wrong # args: should be "file stat name varName"} NONE} -test cmdAH-24.2 {Tcl_FileObjCmd: stat} { +test cmdAH-25.2 {Tcl_FileObjCmd: stat} { list [catch {file stat _bogus_ a b} msg] $msg $errorCode } {1 {wrong # args: should be "file stat name varName"} NONE} -test cmdAH-24.3 {Tcl_FileObjCmd: stat} { +test cmdAH-25.3 {Tcl_FileObjCmd: stat} { catch {unset stat} file stat gorp.file stat lsort [array names stat] } {atime ctime dev gid ino mode mtime nlink size type uid} -test cmdAH-24.4 {Tcl_FileObjCmd: stat} { +test cmdAH-25.4 {Tcl_FileObjCmd: stat} { catch {unset stat} file stat gorp.file stat list $stat(nlink) $stat(size) $stat(type) } {1 12 file} -test cmdAH-24.5 {Tcl_FileObjCmd: stat} {unix} { +test cmdAH-25.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} { +test cmdAH-25.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.7 {Tcl_FileObjCmd: stat} { +} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdAH-25.7 {Tcl_FileObjCmd: stat} { catch {unset x} set x 44 list [catch {file stat gorp.file x} msg] $msg $errorCode } {1 {can't set "x(dev)": variable isn't array} NONE} +test cmdAH-25.8 {Tcl_FileObjCmd: stat} { + # Sign extension of purported unsigned short to int. + + close [open foo.test w] + file stat foo.test stat + set x [expr {$stat(mode) > 0}] + file delete foo.test + set x +} 1 +test cmdAH-25.9 {Tcl_FileObjCmd: stat} {pc} { + # stat of root directory was failing. + # don't care about answer, just that test runs. + + # relative paths that resolve to root + set old [pwd] + cd c:/ + file stat c: stat + file stat c:. stat + file stat . stat + cd $old + + file stat / stat + file stat c:/ stat + file stat c:/. stat +} {} +test cmdAH-25.10 {Tcl_FileObjCmd: stat} {pc nonPortable} { + # stat of root directory was failing. + # don't care about answer, just that test runs. + + file stat //bisque/tcl stat + file stat //bisque/tcl/ stat + file stat //bisque/tcl/. stat +} {} +test cmdAH-25.11 {Tcl_FileObjCmd: stat} {pc nonPortable} { + # stat of network directory was returning id of current local drive. + + set old [pwd] + cd c:/ + + file stat //bisque/tcl stat + cd $old + expr {$stat(dev) == 2} +} 0 +test cmdAH-25.12 {Tcl_FileObjCmd: stat} { + # stat(mode) with S_IFREG flag was returned as a negative number + # if mode_t was a short instead of an unsigned short. + + close [open foo.test w] + file stat foo.test stat + file delete foo.test + expr {$stat(mode) > 0} +} 1 catch {unset stat} # type file delete link.file -test cmdAH-25.1 {Tcl_FileObjCmd: type} { +test cmdAH-26.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} { +test cmdAH-26.2 {Tcl_FileObjCmd: type} { file type dir.file } directory -test cmdAH-25.3 {Tcl_FileObjCmd: type} { +test cmdAH-26.3 {Tcl_FileObjCmd: type} { file type gorp.file } file -test cmdAH-25.4 {Tcl_FileObjCmd: type} {unixOnly nonPortable} { +test cmdAH-26.4 {Tcl_FileObjCmd: type} {unixOnly nonPortable} { exec ln -s a/b/c link.file set result [file type link.file] file delete link.file set result } link -test cmdAH-25.5 {Tcl_FileObjCmd: type} { +test cmdAH-26.5 {Tcl_FileObjCmd: type} { string tolower [list [catch {file type _bogus_} msg] $msg $errorCode] -} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} # Error conditions -test cmdAH-26.1 {error conditions} { +test cmdAH-27.1 {error conditions} { list [catch {file gorp x} msg] $msg } {1 {bad option "gorp": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-26.2 {error conditions} { +test cmdAH-27.2 {error conditions} { list [catch {file ex x} msg] $msg } {1 {ambiguous option "ex": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-26.3 {error conditions} { +test cmdAH-27.3 {error conditions} { list [catch {file is x} msg] $msg } {1 {ambiguous option "is": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-26.4 {error conditions} { +test cmdAH-27.4 {error conditions} { list [catch {file z x} msg] $msg } {1 {bad option "z": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-26.5 {error conditions} { +test cmdAH-27.5 {error conditions} { list [catch {file read x} msg] $msg } {1 {ambiguous option "read": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-26.6 {error conditions} { +test cmdAH-27.6 {error conditions} { list [catch {file s x} msg] $msg } {1 {ambiguous option "s": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-26.7 {error conditions} { +test cmdAH-27.7 {error conditions} { list [catch {file t x} msg] $msg } {1 {ambiguous option "t": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-26.8 {error conditions} { +test cmdAH-27.8 {error conditions} { list [catch {file dirname ~woohgy} msg] $msg } {1 {user "woohgy" doesn't exist}} @@ -1253,4 +1352,4 @@ file delete -force dir.file file delete gorp.file file delete link.file -concat "" +return diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 5b56105..572c77e 100644 --- a/tests/cmdIL.test +++ b/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.18 97/09/18 11:42:12 +# SCCS: @(#) cmdIL.test 1.22 98/01/13 18:24:45 if {[string compare test [info procs test]] == 1} then {source defs} @@ -251,3 +251,17 @@ test cmdIL-4.22 {DictionaryCompare procedure, case} { test cmdIL-4.23 {DictionaryCompare procedure, case} { lsort -dictionary {ABcd AbCd} } {ABcd AbCd} +test cmdIL-4.24 {DictionaryCompare procedure, international characters} {hasIsoLocale} { + set_iso8859_1_locale + set result [lsort -dictionary "a b c A B C \xe3 \xc4"] + restore_locale + set result +} "A a B b C c \xe3 \xc4" +test cmdIL-4.25 {DictionaryCompare procedure, international characters} {hasIsoLocale} { + set_iso8859_1_locale + set result [lsort -dictionary "a23\xe3 a23\xc5 a23\xe4"] + restore_locale + set result +} "a23\xe3 a23\xe4 a23\xc5" + +return diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test index 14267ac..2b2b00b 100644 --- a/tests/cmdInfo.test +++ b/tests/cmdInfo.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) cmdInfo.test 1.10 97/06/20 14:51:12 +# SCCS: @(#) cmdInfo.test 1.11 97/12/08 15:05:59 if {[info commands testcmdinfo] == {}} { puts "This application hasn't been compiled with the \"testcmdinfo\"" @@ -95,4 +95,5 @@ test cmdinfo-6.1 {Names for commands created when outside namespaces} { catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1} catch {rename x1 ""} -concat {} + +return diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test new file mode 100644 index 0000000..142ab29 --- /dev/null +++ b/tests/cmdMZ.test @@ -0,0 +1,559 @@ +# The tests in this file cover the procedures in tclCmdMZ.c. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994 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: @(#) cmdMZ.test 1.20 98/01/08 18:23:43 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Tcl_PwdObjCmd + +test cmdMZ-1.1 {Tcl_PwdObjCmd} { + list [catch {pwd a} msg] $msg +} {1 {wrong # args: should be "pwd"}} +test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} { + catch pwd +} 0 +test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} { + expr [string length pwd]>0 +} 1 +test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unixOnly} { + file delete -force foo + file mkdir foo + set cwd [pwd] + cd foo + file attr . -permissions 000 + set result [list [catch {pwd} msg] $msg] + cd $cwd + file delete -force foo + set result +} {1 {error getting working directory name: permission denied}} + +# The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test + +# Tcl_RenameObjCmd + +test cmdMZ-2.1 {Tcl_RenameObjCmd: error conditions} { + list [catch {rename r1} msg] $msg $errorCode +} {1 {wrong # args: should be "rename oldName newName"} NONE} +test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} { + list [catch {rename r1 r2 r3} msg] $msg $errorCode +} {1 {wrong # args: should be "rename oldName newName"} NONE} +test cmdMZ-2.3 {Tcl_RenameObjCmd: success} { + catch {rename r2 {}} + proc r1 {} {return "r1"} + rename r1 r2 + r2 +} {r1} +test cmdMZ-2.4 {Tcl_RenameObjCmd: success} { + proc r1 {} {return "r1"} + rename r1 {} + list [catch {r1} msg] $msg +} {1 {invalid command name "r1"}} + +# The tests for Tcl_ReturnObjCmd are in proc-old.test +# The tests for Tcl_ScanObjCmd are in scan.test + +# Tcl_SourceObjCmd + +test cmdMZ-3.1 {Tcl_SourceObjCmd: error conditions} {macOnly} { + list [catch {source} msg] $msg +} {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} +test cmdMZ-3.2 {Tcl_SourceObjCmd: error conditions} {macOnly} { + list [catch {source a b} msg] $msg +} {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} +test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} {unixOrPc} { + list [catch {source} msg] $msg +} {1 {wrong # args: should be "source fileName"}} +test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} {unixOrPc} { + list [catch {source a b} msg] $msg +} {1 {wrong # args: should be "source fileName"}} +test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} { + makeFile { + set x 146 + error "error in sourced file" + set y $x + } source.file + list [catch {source source.file} msg] $msg $errorInfo +} {1 {error in sourced file} {error in sourced file + while executing +"error "error in sourced file"" + (file "source.file" line 3) + invoked from within +"source source.file"}} +test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} { + makeFile {list result} source.file + source source.file +} result + +# Tcl_SplitObjCmd + +test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} { + list [catch split msg] $msg $errorCode +} {1 {wrong # args: should be "split string ?splitChars?"} NONE} +test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} { + list [catch {split a b c} msg] $msg $errorCode +} {1 {wrong # args: should be "split string ?splitChars?"} NONE} +test cmdMZ-4.3 {Tcl_SplitObjCmd: basic split commands} { + split "a\n b\t\r c\n " +} {a {} b {} {} c {} {}} +test cmdMZ-4.4 {Tcl_SplitObjCmd: basic split commands} { + split "word 1xyzword 2zword 3" xyz +} {{word 1} {} {} {word 2} {word 3}} +test cmdMZ-4.5 {Tcl_SplitObjCmd: basic split commands} { + split "12345" {} +} {1 2 3 4 5} +test cmdMZ-4.6 {Tcl_SplitObjCmd: basic split commands} { + split "a\}b\[c\{\]\$" +} "a\\}b\\\[c\\{\\\]\\\$" +test cmdMZ-4.7 {Tcl_SplitObjCmd: basic split commands} { + split {} {} +} {} +test cmdMZ-4.8 {Tcl_SplitObjCmd: basic split commands} { + split {} +} {} +test cmdMZ-4.9 {Tcl_SplitObjCmd: basic split commands} { + split { } +} {{} {} {} {}} +test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} { + proc foo {} { + set x {} + foreach f [split {]\n} {}] { + append x $f + } + return $x + } + foo +} {]\n} +test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} { + proc foo {} { + set x ab\000c + set y [split $x {}] + return $y + } + foo +} "a b \000 c" +test cmdMZ-4.12 {Tcl_SplitObjCmd: basic split commands} { + split "a0ab1b2bbb3\000c4" ab\000c +} {{} 0 {} 1 2 {} {} 3 {} 4} +test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} { + # if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq" + split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e" +} "a b qw\u5e4eN wq" + +# Tcl_StringObjCmd + +test cmdMZ-5.1 {Tcl_StringObjCmd: error conditions} { + list [catch {string} msg] $msg +} {1 {wrong # args: should be "string option arg ?arg ...?"}} +test cmdMZ-5.2 {Tcl_StringObjCmd: error conditions} { + list [catch {string gorp a b} msg] $msg +} {1 {bad option "gorp": must be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} + +test cmdMZ-6.1 {Tcl_StringObjCmd: string compare} { + list [catch {string compare a} msg] $msg +} {1 {wrong # args: should be "string compare string1 string2"}} +test cmdMZ-6.2 {Tcl_StringObjCmd: string compare} { + list [catch {string compare a b c} msg] $msg +} {1 {wrong # args: should be "string compare string1 string2"}} +test cmdMZ-6.3 {Tcl_StringObjCmd: string compare} { + string compare abcde abdef +} -1 +test cmdMZ-6.4 {Tcl_StringObjCmd: string compare} { + string c abcde ABCDE +} 1 +test cmdMZ-6.5 {Tcl_StringObjCmd: string compare} { + string compare abcde abcde +} 0 +test cmdMZ-6.6 {Tcl_StringObjCmd: string compare} { + string compare ab abcde +} -1 +test cmdMZ-6.7 {Tcl_StringObjCmd: string compare} { + string compare abcde ab +} 1 +test cmdMZ-6.8 {Tcl_StringObjCmd: string compare} { + string compare cde ab +} 1 +test cmdMZ-6.9 {Tcl_StringObjCmd: string compare} { + string compare ab cde +} -1 +test cmdMZ-6.10 {Tcl_StringObjCmd: string compare, unicode} { + string compare ab\u7266 ab\u7267 +} -1 +test cmdMZ-6.11 {Tcl_StringObjCmd: string compare, high bit} { + # This test will fail if the underlying comparaison + # is using signed chars instead of unsigned chars. + # (like SunOS's default memcmp thus the compat/memcmp.c) + string compare "\x80" "@" + # Nb this tests works also in utf8 space because \x80 is + # translated into a 2 or more bytes but whose first byte has + # the high bit set. +} 1 + +test cmdMZ-7.1 {Tcl_StringObjCmd: string first} { + list [catch {string first a} msg] $msg +} {1 {wrong # args: should be "string first string1 string2"}} +test cmdMZ-7.2 {Tcl_StringObjCmd: string first} { + list [catch {string first a b c} msg] $msg +} {1 {wrong # args: should be "string first string1 string2"}} +test cmdMZ-7.3 {Tcl_StringObjCmd: string first} { + string first bq abcdefgbcefgbqrs +} 12 +test cmdMZ-7.4 {Tcl_StringObjCmd: string first} { + string fir bcd abcdefgbcefgbqrs +} 1 +test cmdMZ-7.5 {Tcl_StringObjCmd: string first} { + string f b abcdefgbcefgbqrs +} 1 +test cmdMZ-7.6 {Tcl_StringObjCmd: string first} { + string first xxx x123xx345xxx789xxx012 +} 9 +test cmdMZ-7.7 {Tcl_StringObjCmd: string first} { + string first "" x123xx345xxx789xxx012 +} -1 +test cmdMZ-7.8 {Tcl_StringObjCmd: string first, unicode} { + string first x abc\u7266x +} 4 +test cmdMZ-7.9 {Tcl_StringObjCmd: string first, unicode} { + string first \u7266 abc\u7266x +} 3 + +test cmdMZ-8.1 {Tcl_StringObjCmd: string index} { + list [catch {string index} msg] $msg +} {1 {wrong # args: should be "string index string charIndex"}} +test cmdMZ-8.2 {Tcl_StringObjCmd: string index} { + list [catch {string index a b c} msg] $msg +} {1 {wrong # args: should be "string index string charIndex"}} +test cmdMZ-8.3 {Tcl_StringObjCmd: string index} { + list [catch {string index a xyz} msg] $msg +} {1 {expected integer but got "xyz"}} +test cmdMZ-8.4 {Tcl_StringObjCmd: string index} { + string index abcde 0 +} a +test cmdMZ-8.5 {Tcl_StringObjCmd: string index} { + string i abcde 4 +} e +test cmdMZ-8.6 {Tcl_StringObjCmd: string index} { + string index abcde 5 +} {} +test cmdMZ-8.7 {Tcl_StringObjCmd: string index} { + list [catch {string index abcde -10} msg] $msg +} {0 {}} +test cmdMZ-8.8 {Tcl_StringObjCmd: string index, unicode} { + string index abc\u7266d 4 +} d +test cmdMZ-8.9 {Tcl_StringObjCmd: string index, unicode} { + string index abc\u7266d 3 +} \u7266 + +test cmdMZ-9.1 {Tcl_StringObjCmd: string last} { + list [catch {string last a} msg] $msg +} {1 {wrong # args: should be "string last string1 string2"}} +test cmdMZ-9.2 {Tcl_StringObjCmd: string last} { + list [catch {string last a b c} msg] $msg +} {1 {wrong # args: should be "string last string1 string2"}} +test cmdMZ-9.3 {Tcl_StringObjCmd: string last} { + string la xxx xxxx123xx345x678 +} 1 +test cmdMZ-9.4 {Tcl_StringObjCmd: string last} { + string last xx xxxx123xx345x678 +} 7 +test cmdMZ-9.5 {Tcl_StringObjCmd: string last} { + string las x xxxx123xx345x678 +} 12 +test cmdMZ-9.6 {Tcl_StringObjCmd: string last, unicode} { + string las x xxxx12\u7266xx345x678 +} 12 +test cmdMZ-9.7 {Tcl_StringObjCmd: string last, unicode} { + string las \u7266 xxxx12\u7266xx345x678 +} 6 + +test cmdMZ-10.1 {Tcl_StringObjCmd: string length} { + list [catch {string length} msg] $msg +} {1 {wrong # args: should be "string length string"}} +test cmdMZ-10.2 {Tcl_StringObjCmd: string length} { + list [catch {string length a b} msg] $msg +} {1 {wrong # args: should be "string length string"}} +test cmdMZ-10.3 {Tcl_StringObjCmd: string length} { + string length "a little string" +} 15 +test cmdMZ-10.4 {Tcl_StringObjCmd: string length} { + string le "" +} 0 +test cmdMZ-10.5 {Tcl_StringObjCmd: string length, unicode} { + string le "abcd\u7266" +} 5 + +test cmdMZ-11.1 {Tcl_StringObjCmd: string match} { + list [catch {string match a} msg] $msg +} {1 {wrong # args: should be "string match pattern string"}} +test cmdMZ-11.2 {Tcl_StringObjCmd: string match} { + list [catch {string match a b c} msg] $msg +} {1 {wrong # args: should be "string match pattern string"}} +test cmdMZ-11.3 {Tcl_StringObjCmd: string match} { + string match abc abc +} 1 +test cmdMZ-11.4 {Tcl_StringObjCmd: string match} { + string m abc abd +} 0 + +test cmdMZ-12.1 {Tcl_StringObjCmd: string range} { + list [catch {string range} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test cmdMZ-12.2 {Tcl_StringObjCmd: string range} { + list [catch {string range a 1} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test cmdMZ-12.3 {Tcl_StringObjCmd: string range} { + list [catch {string range a 1 2 3} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test cmdMZ-12.4 {Tcl_StringObjCmd: string range} { + list [catch {string range abc abc 1} msg] $msg +} {1 {bad index "abc": must be integer or "end"}} +test cmdMZ-12.5 {Tcl_StringObjCmd: string range} { + list [catch {string range abc 1 eof} msg] $msg +} {1 {bad index "eof": must be integer or "end"}} +test cmdMZ-12.6 {Tcl_StringObjCmd: string range, first < 0} { + string range abcdefghijklmnop -3 2 +} {abc} +test cmdMZ-12.7 {Tcl_StringObjCmd: string range} { + string range abcdefghijklmnop 2 14 +} {cdefghijklmno} +test cmdMZ-12.8 {Tcl_StringObjCmd: string range, last > length} { + string range abcdefghijklmnop 7 1000 +} {hijklmnop} +test cmdMZ-12.9 {Tcl_StringObjCmd: string range} { + string range abcdefghijklmnop 10 e +} {klmnop} +test cmdMZ-12.10 {Tcl_StringObjCmd: string range, last < first} { + string range abcdefghijklmnop 10 9 +} {} +test cmdMZ-12.11 {Tcl_StringObjCmd: string range} { + string range abcdefghijklmnop -3 -2 +} {} +test cmdMZ-12.12 {Tcl_StringObjCmd: string range} { + string range abcdefghijklmnop 1000 1010 +} {} +test cmdMZ-12.13 {Tcl_StringObjCmd: string range} { + string range abcdefghijklmnop -100 end +} {abcdefghijklmnop} +test cmdMZ-12.14 {Tcl_StringObjCmd: string range} { + string range abcdefghijklmnop end end +} {p} +test cmdMZ-12.15 {Tcl_StringObjCmd: string range} { + string range abcdefghijklmnop e 1000 +} {p} +test cmdMZ-12.16 {Tcl_StringObjCmd: string range, unicode} { + string range ab\u7266cdefghijklmnop 5 5 +} e +test cmdMZ-12.17 {Tcl_StringObjCmd: string range, unicode} { + string range ab\u7266cdefghijklmnop 2 3 +} \u7266c + +test cmdMZ-13.1 {Tcl_StringObjCmd: string tolower} { + list [catch {string tolower} msg] $msg +} {1 {wrong # args: should be "string tolower string"}} +test cmdMZ-13.2 {Tcl_StringObjCmd: string tolower} { + list [catch {string tolower a b} msg] $msg +} {1 {wrong # args: should be "string tolower string"}} +test cmdMZ-13.3 {Tcl_StringObjCmd: string tolower} { + string tolower ABCDeF +} {abcdef} +test cmdMZ-13.4 {Tcl_StringObjCmd: string tolower} { + string tolower "ABC XyZ" +} {abc xyz} +test cmdMZ-13.5 {Tcl_StringObjCmd: string tolower} { + string tolower {123#$&*()} +} {123#$&*()} +test cmdMZ-13.6 {Tcl_StringObjCmd: string tolower, unicode} {hasIsoLocale} { + set_iso8859_1_locale + set result [string tolower ABCabc\xc7\xe7] + restore_locale + set result +} "abcabc\xe7\xe7" + +test cmdMZ-14.1 {Tcl_StringObjCmd: string toupper} { + list [catch {string toupper} msg] $msg +} {1 {wrong # args: should be "string toupper string"}} +test cmdMZ-14.2 {Tcl_StringObjCmd: string toupper} { + list [catch {string toupper a b} msg] $msg +} {1 {wrong # args: should be "string toupper string"}} +test cmdMZ-14.3 {Tcl_StringObjCmd: string toupper} { + string toupper abCDEf +} {ABCDEF} +test cmdMZ-14.4 {Tcl_StringObjCmd: string toupper} { + string toupper "abc xYz" +} {ABC XYZ} +test cmdMZ-14.5 {Tcl_StringObjCmd: string toupper} { + string toupper {123#$&*()} +} {123#$&*()} +test cmdMZ-14.6 {Tcl_StringObjCmd: string toupper, unicode} {hasIsoLocale} { + set_iso8859_1_locale + set result [string toupper ABCabc\xc7\xe7] + restore_locale + set result +} "ABCABC\xc7\xc7" + +test cmdMZ-15.1 {Tcl_StringObjCmd: string trim} { + list [catch {string trim} msg] $msg +} {1 {wrong # args: should be "string trim string ?chars?"}} +test cmdMZ-15.2 {Tcl_StringObjCmd: string trim} { + list [catch {string trim a b c} msg] $msg +} {1 {wrong # args: should be "string trim string ?chars?"}} +test cmdMZ-15.3 {Tcl_StringObjCmd: string trim} { + string trim " XYZ " +} {XYZ} +test cmdMZ-15.4 {Tcl_StringObjCmd: string trim} { + string trim "\t\nXYZ\t\n\r\n" +} {XYZ} +test cmdMZ-15.5 {Tcl_StringObjCmd: string trim} { + string trim " A XYZ A " +} {A XYZ A} +test cmdMZ-15.6 {Tcl_StringObjCmd: string trim} { + string trim "XXYYZZABC XXYYZZ" ZYX +} {ABC } +test cmdMZ-15.7 {Tcl_StringObjCmd: string trim} { + string trim " \t\r " +} {} +test cmdMZ-15.8 {Tcl_StringObjCmd: string trim} { + string trim {abcdefg} {} +} {abcdefg} +test cmdMZ-15.9 {Tcl_StringObjCmd: string trim} { + string trim {} +} {} +test cmdMZ-15.10 {Tcl_StringObjCmd: string trim} { + string trim ABC DEF +} {ABC} +test cmdMZ-15.11 {Tcl_StringObjCmd: string trim, unicode} { + string trim "\xe7\xe8 AB\xe7C \xe8\xe7" \xe7\xe8 +} " AB\xe7C " + +test cmdMZ-16.1 {Tcl_StringObjCmd: string trimleft} { + string trimleft " XYZ " +} {XYZ } +test cmdMZ-16.2 {Tcl_StringObjCmd: string trimleft} { + list [catch {string trimleft} msg] $msg +} {1 {wrong # args: should be "string trimleft string ?chars?"}} +test cmdMZ-16.3 {Tcl_StringObjCmd: string trimleft} { + string length [string trimleft " "] +} {0} + +test cmdMZ-17.1 {Tcl_StringObjCmd: string trimright} { + string trimright " XYZ " +} { XYZ} +test cmdMZ-17.2 {Tcl_StringObjCmd: string trimright} { + string trimright " " +} {} +test cmdMZ-17.3 {Tcl_StringObjCmd: string trimright} { + string trimright "" +} {} +test cmdMZ-17.4 {Tcl_StringObjCmd: string trimright errors} { + list [catch {string trimright} msg] $msg +} {1 {wrong # args: should be "string trimright string ?chars?"}} +test cmdMZ-17.5 {Tcl_StringObjCmd: string trimright errors} { + list [catch {string trimg a} msg] $msg +} {1 {bad option "trimg": must be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} + +test cmdMZ-18.1 {Tcl_StringObjCmd: string wordend} { + list [catch {string wordend a} msg] $msg +} {1 {wrong # args: should be "string wordend string index"}} +test cmdMZ-18.2 {Tcl_StringObjCmd: string wordend} { + list [catch {string wordend a b c} msg] $msg +} {1 {wrong # args: should be "string wordend string index"}} +test cmdMZ-18.3 {Tcl_StringObjCmd: string wordend} { + list [catch {string wordend a gorp} msg] $msg +} {1 {expected integer but got "gorp"}} +test cmdMZ-18.4 {Tcl_StringObjCmd: string wordend} { + string wordend abc. -1 +} 3 +test cmdMZ-18.5 {Tcl_StringObjCmd: string wordend} { + string wordend abc. 100 +} 4 +test cmdMZ-18.6 {Tcl_StringObjCmd: string wordend} { + string wordend "word_one two three" 2 +} 8 +test cmdMZ-18.7 {Tcl_StringObjCmd: string wordend} { + string wordend "one .&# three" 5 +} 6 +test cmdMZ-18.8 {Tcl_StringObjCmd: string wordend} { + string worde "x.y" 0 +} 1 +test cmdMZ-18.9 {Tcl_StringObjCmd: string wordend, unicode} {hasIsoLocale} { + set_iso8859_1_locale + set result [string wordend "xyz\u00c7de fg" 0] + restore_locale + set result +} 6 +test cmdMZ-18.10 {Tcl_StringObjCmd: string wordend, unicode} {hasIsoLocale} { + set_iso8859_1_locale + set result [string wordend "xyz\uc700de fg" 0] + restore_locale + set result +} 3 +test cmdMZ-18.11 {Tcl_StringObjCmd: string wordend, unicode} {hasIsoLocale} { + set_iso8859_1_locale + set result [string wordend "xyz\uc700de fg" 0] + restore_locale + set result +} 3 +test cmdMZ-18.12 {Tcl_StringObjCmd: string wordend, unicode} { + string wordend "\uc700\uc700 abc" 8 +} 6 + +test cmdMZ-19.1 {Tcl_StringObjCmd: string wordstart} { + list [catch {string word a} msg] $msg +} {1 {ambiguous option "word": must be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} +test cmdMZ-19.2 {Tcl_StringObjCmd: string wordstart} { + list [catch {string wordstart a} msg] $msg +} {1 {wrong # args: should be "string wordstart string index"}} +test cmdMZ-19.3 {Tcl_StringObjCmd: string wordstart} { + list [catch {string wordstart a b c} msg] $msg +} {1 {wrong # args: should be "string wordstart string index"}} +test cmdMZ-19.4 {Tcl_StringObjCmd: string wordstart} { + list [catch {string wordstart a gorp} msg] $msg +} {1 {expected integer but got "gorp"}} +test cmdMZ-19.5 {Tcl_StringObjCmd: string wordstart} { + string wordstart "one two three_words" 400 +} 8 +test cmdMZ-19.6 {Tcl_StringObjCmd: string wordstart} { + string wordstart "one two three_words" 2 +} 0 +test cmdMZ-19.7 {Tcl_StringObjCmd: string wordstart} { + string wordstart "one two three_words" -2 +} 0 +test cmdMZ-19.8 {Tcl_StringObjCmd: string wordstart} { + string wordstart "one .*&^ three" 6 +} 6 +test cmdMZ-19.9 {Tcl_StringObjCmd: string wordstart} { + string wordstart "one two three" 4 +} 4 +test cmdMZ-19.10 {Tcl_StringObjCmd: string wordstart, unicode} {hasIsoLocale} { + set_iso8859_1_locale + set result [string wordstart "one tw\u00c7o three" 7] + restore_locale + set result +} 4 +test cmdMZ-19.11 {Tcl_StringObjCmd: string wordstart, unicode} {hasIsoLocale} { + set_iso8859_1_locale + set result [string wordstart "ab\uc700\uc700 cdef ghi" 12] + restore_locale + set result +} 10 +test cmdMZ-19.12 {Tcl_StringObjCmd: string wordstart, unicode} { + string wordstart "\uc700\uc700 abc" 8 +} 3 + +# The tests for Tcl_SubstObjCmd are in subst.test +# The tests for Tcl_SwitchObjCmd are in switch.test +# There are no tests for Tcl_TimeObjCmd +# The tests for Tcl_TraceObjCmd and TraceVarProc are in trace.test +# The tests for Tcl_WhileObjCmd are in while.test + +return diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test new file mode 100644 index 0000000..848a59e --- /dev/null +++ b/tests/compExpr-old.test @@ -0,0 +1,670 @@ +# Commands covered: expr +# +# This file contains the original set of tests for the compilation (and +# indirectly execution) of Tcl's expr command. A new set of tests covering +# the new implementation are in the files "parseExpr.test and +# "compExpr.test". Sourcing this file into Tcl runs the tests and generates +# output for errors. No output means no errors were found. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) compExpr-old.test 1.47 97/12/19 11:57:15 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { + set gotT1 0 + puts "This application hasn't been compiled with the \"T1\" and" + puts "\"T2\" math functions, so I'll skip some of the expr tests." +} else { + set gotT1 1 +} + +# procedures used below + +proc put_hello_char {c} { + global a + append a [format %c $c] + return $c +} +proc hello_world {} { + global a + set a "" + set L1 [set l0 [set h_1 [set q 0]]] + for {put_hello_char [expr [put_hello_char [expr [set h 7]*10+2]]+29]} {$l0?[put_hello_char $l0] + :!$h_1} {put_hello_char $ll;expr {$L1==2?[set ll [expr 32+0-0+[set bar 0]]]:0}} {expr {[incr L1]==[expr 1+([string length "abc"]-[string length "abc"])] + ?[set ll [set l0 [expr 54<<1]]]:$ll==108&&$L1<3? + [incr ll [expr 1|1<<1]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]; set l0; set l0 $l0; set l0; set l0]:$L1==4&&$ll==32?[set ll [expr 19+$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+[set foo [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]]]] + :[set q [expr $q-$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]};expr {$L1==5?[incr ll -8; set ll $ll; set ll]:$q&&$h1&&1};expr {$L1==4+2 + ?[incr ll 3]:[expr ([string length "abc"]-[string length "abc"])+1]};expr {$ll==($h<<4)+2+0&&$L1!=6?[incr ll -6]:[set h1 [expr 100+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]} + expr {$L1!=1<<3?[incr q [expr ([string length "abc"]-[string length "abc"])-1]]:[set h_1 [set ll $h1]]} + } + set a +} + +proc 12days {a b c} { + global xxx + expr {1<$a?[expr {$a<3?[12days -79 -13 [string range $c [12days -87 \ + [expr 1-$b] [string range $c [12days -86 0 [string range $c 1 end]] \ + end]] end]]:1};expr {$a<$b?[12days [expr $a+1] $b $c]:3};expr {[12days \ + -94 [expr $a-27] $c]&&$a==2?$b<13?[12days 2 [expr $b+1] "%s %d %d\n"]:9 + :16}]:$a<0?$a<-72?[12days $b $a "@n'+,#'/*\{\}w+/w#cdnr/+,\{\}r/*de\}+,/*\{*+,/w\{%+,/w#q#n+,/#\{l+,/n\{n+,/+#n+,/#;#q#n+,/+k#;*+,/'r :'d*'3,\}\{w+K w'K:'+\}e#';dq#'l q#'+d'K#!/+k#;q#'r\}eKK#\}w'r\}eKK\{nl\]'/#;#q#n')\{)#\}w')\{)\{nl\]'/+#n';d\}rw' i;# )\{nl\]!/n\{n#'; r\{#w'r nc\{nl\]'/#\{l,+'K \{rw' iK\{;\[\{nl\]'/w#q#n'wk nw' iwk\{KK\{nl\]!/w\{%'l##w#' i; :\{nl\]'/*\{q#'ld;r'\}\{nlwb!/*de\}'c ;;\{nl'-\{\}rw\]'/+,\}##'*\}#nc,',#nw\]'/+kd'+e\}+;#'rdq#w! nr'/ ') \}+\}\{rl#'\{n' ')# \}'+\}##(!!/"] + :$a<-50?[string compare [format %c $b] [string index $c 0]]==0?[append \ + xxx [string index $c 31];scan [string index $c 31] %c x;set x] + :[12days -65 $b [string range $c 1 end]]:[12days [expr ([string compare \ + [string index $c 0] "/"]==0)+$a] $b [string range $c 1 end]]:0<$a + ?[12days 2 2 "%s"]:[string compare [string index $c 0] "/"]==0|| + [12days 0 [12days -61 [scan [string index $c 0] %c x; set x] \ + "!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \ + [string range $c 1 end]]} +} +proc do_twelve_days {} { + global xxx + set xxx "" + 12days 1 1 1 + string length $xxx +} + +# start of tests + +catch {unset a b i x} + +test expr-1.1 {TclCompileExprCmd: no expression} { + list [catch {expr } msg] $msg +} {1 {wrong # args: should be "expr arg ?arg ...?"}} +test expr-1.2 {TclCompileExprCmd: one expression word} { + expr -25 +} -25 +test expr-1.3 {TclCompileExprCmd: two expression words} { + expr -8.2 -6 +} -14.2 +test expr-1.4 {TclCompileExprCmd: five expression words} { + expr 20 - 5 +10 -7 +} 18 +test expr-1.5 {TclCompileExprCmd: quoted expression word} { + expr "0005" +} 5 +test expr-1.6 {TclCompileExprCmd: quoted expression word} { + catch {expr "0005"zxy} msg + set msg +} {extra characters after close-quote} +test expr-1.7 {TclCompileExprCmd: expression word in braces} { + expr {-0005} +} -5 +test expr-1.8 {TclCompileExprCmd: expression word in braces} { + expr {{-0x1234}} +} -4660 +test expr-1.9 {TclCompileExprCmd: expression word in braces} { + catch {expr {-0005}foo} msg + set msg +} {extra characters after close-brace} +test expr-1.10 {TclCompileExprCmd: other expression word in braces} { + expr 4*[llength "6 2"] +} 8 +test expr-1.11 {TclCompileExprCmd: expression word terminated by ;} { + expr 4*[llength "6 2"]; +} 8 +test expr-1.12 {TclCompileExprCmd: inlined expr (in "catch") inside other catch} { + set a xxx + catch { + # Might not be a number + set a [expr 10*$a] + } +} 1 +test expr-1.13 {TclCompileExprCmd: second level of substitutions in expr not in braces with single var reference} { + set a xxx + set x 27; set bool {$x}; if $bool {set a foo} + set a +} foo +test expr-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"]) +} 10.0 +test expr-2.2 {TclCompileExpr: error in expr} { + catch {expr 2**3} msg + set msg +} {syntax error in expression "2**3"} +test expr-2.3 {TclCompileExpr: junk after legal expr} { + catch {expr 7*[llength "a b"]foo} msg + set msg +} {syntax error in expression "7*2foo"} +test expr-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} { + expr {0001} +} 1 + +test expr-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1 +test expr-3.2 {CompileCondExpr: error in lor expr} { + catch {expr x||3} msg + set msg +} {syntax error in expression "x||3"} +test expr-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44 +test expr-3.4 {CompileCondExpr: error compiling true arm} { + catch {expr 3>2?2**3:66} msg + set msg +} {syntax error in expression "3>2?2**3:66"} +test expr-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66 +test expr-3.6 {CompileCondExpr: error compiling false arm} { + catch {expr 2>3?44:2**3} msg + set msg +} {syntax error in expression "2>3?44:2**3"} +test expr-3.7 {CompileCondExpr: long arms & nested cond exprs} {nonPortable} { + puts "Note: doing test expr-3.7 which can take several minutes to run" + hello_world +} {Hello world} +catch {unset xxx} +test expr-3.8 {CompileCondExpr: long arms & nested cond exprs} {nonPortable} { + puts "Note: doing test expr-3.8 which can take several minutes to run" + do_twelve_days +} 2358 +catch {unset xxx} + +test expr-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1 +test expr-4.2 {CompileLorExpr: error in land expr} { + catch {expr x&&3} msg + set msg +} {syntax error in expression "x&&3"} +test expr-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1 +test expr-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1 +test expr-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1 +test expr-4.6 {CompileLorExpr: error compiling lor arm} { + catch {expr 2**3||4.0} msg + set msg +} {syntax error in expression "2**3||4.0"} +test expr-4.7 {CompileLorExpr: error compiling lor arm} { + catch {expr 1.3||2**3} msg + set msg +} {syntax error in expression "1.3||2**3"} +test expr-4.8 {CompileLorExpr: error compiling lor arms} { + list [catch {expr {"a"||"b"}} msg] $msg +} {1 {expected boolean value but got "a"}} +test expr-4.9 {CompileLorExpr: long lor arm} { + set a "abcdefghijkl" + set i 7 + expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} +} 1 + +test expr-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23 +test expr-5.2 {CompileLandExpr: error in bitor expr} { + catch {expr x|3} msg + set msg +} {syntax error in expression "x|3"} +test expr-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0 +test expr-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0 +test expr-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1 +test expr-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1 +test expr-5.7 {CompileLandExpr: error compiling land arm} { + catch {expr 2**3&&4.0} msg + set msg +} {syntax error in expression "2**3&&4.0"} +test expr-5.8 {CompileLandExpr: error compiling land arm} { + catch {expr 1.3&&2**3} msg + set msg +} {syntax error in expression "1.3&&2**3"} +test expr-5.9 {CompileLandExpr: error compiling land arm} { + list [catch {expr {"a"&&"b"}} msg] $msg +} {1 {expected boolean value but got "a"}} +test expr-5.10 {CompileLandExpr: long land arms} { + set a "abcdefghijkl" + set i 7 + expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]} +} 1 + +test expr-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3 +test expr-6.2 {CompileBitXorExpr: error in bitand expr} { + catch {expr x|3} msg + set msg +} {syntax error in expression "x|3"} +test expr-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20 +test expr-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19 +test expr-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7 +test expr-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8 +test expr-6.7 {CompileBitXorExpr: error compiling bitxor arm} { + catch {expr 2**3|6} msg + set msg +} {syntax error in expression "2**3|6"} +test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} { + catch {expr 2^x} msg + set msg +} {syntax error in expression "2^x"} +test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { + list [catch {expr {24.0^3}} msg] $msg +} {1 {can't use floating-point value as operand of "^"}} +test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { + list [catch {expr {"a"^"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "^"}} + +test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 +test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 +test expr-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1 +test expr-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0 +test expr-7.5 {CompileBitAndExpr: error in equality expr} { + catch {expr x==3} msg + set msg +} {syntax error in expression "x==3"} +test expr-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3 +test expr-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82 +test expr-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2 +test expr-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7 +test expr-7.10 {CompileBitAndExpr: error compiling bitand arm} { + catch {expr 2**3&6} msg + set msg +} {syntax error in expression "2**3&6"} +test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} { + catch {expr 2&x} msg + set msg +} {syntax error in expression "2&x"} +test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} { + list [catch {expr {24.0&3}} msg] $msg +} {1 {can't use floating-point value as operand of "&"}} +test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} { + list [catch {expr {"a"&"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "&"}} + +test expr-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1 +test expr-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1 +test expr-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1 +test expr-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0 +test expr-8.5 {CompileEqualityExpr: error in relational expr} { + catch {expr x>3} msg + set msg +} {syntax error in expression "x>3"} +test expr-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0 +test expr-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1 +test expr-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1 +test expr-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1 +test expr-8.10 {CompileEqualityExpr: error compiling equality arm} { + catch {expr 2**3==6} msg + set msg +} {syntax error in expression "2**3==6"} +test expr-8.11 {CompileEqualityExpr: error compiling equality arm} { + catch {expr 2!=x} msg + set msg +} {syntax error in expression "2!=x"} + + +test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 +test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 +test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 +test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 + +# The following test is different for 32-bit versus 64-bit +# architectures because LONG_MIN is different + +if {0x80000000 > 0} { + test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} { + expr {1<<63} + } -9223372036854775808 +} else { + test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} { + expr {1<<31} + } -2147483648 +} +test expr-9.6 {CompileRelationalExpr: error in shift expr} { + catch {expr x>>3} msg + set msg +} {syntax error in expression "x>>3"} +test expr-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1 +test expr-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1 +test expr-9.9 {CompileRelationalExpr: error compiling relational arm} { + catch {expr 2**3>6} msg + set msg +} {syntax error in expression "2**3>6"} +test expr-9.10 {CompileRelationalExpr: error compiling relational arm} { + catch {expr 2<x} msg + set msg +} {syntax error in expression "2<x"} + +test expr-10.1 {CompileShiftExpr: just add expr} {expr 4+-2} 2 +test expr-10.2 {CompileShiftExpr: just add expr} {expr 0xff-2} 253 +test expr-10.3 {CompileShiftExpr: just add expr} {expr -1--2} 1 +test expr-10.4 {CompileShiftExpr: just add expr} {expr 1-0123} -82 +test expr-10.5 {CompileShiftExpr: error in add expr} { + catch {expr x+3} msg + set msg +} {syntax error in expression "x+3"} +test expr-10.6 {CompileShiftExpr: simple shift exprs} {expr 0xff>>0x3} 31 +test expr-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936 +test expr-10.8 {CompileShiftExpr: error compiling shift arm} { + catch {expr 2**3>>6} msg + set msg +} {syntax error in expression "2**3>>6"} +test expr-10.9 {CompileShiftExpr: error compiling shift arm} { + catch {expr 2<<x} msg + set msg +} {syntax error in expression "2<<x"} +test expr-10.10 {CompileShiftExpr: runtime error} { + list [catch {expr {24.0>>43}} msg] $msg +} {1 {can't use floating-point value as operand of ">>"}} +test expr-10.11 {CompileShiftExpr: runtime error} { + list [catch {expr {"a"<<"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "<<"}} + +test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 +test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 +test expr-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1 +test expr-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 6 +test expr-11.5 {CompileAddExpr: error in multiply expr} { + catch {expr x*3} msg + set msg +} {syntax error in expression "x*3"} +test expr-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258 +test expr-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239 +test expr-11.8 {CompileAddExpr: error compiling add arm} { + catch {expr 2**3+6} msg + set msg +} {syntax error in expression "2**3+6"} +test expr-11.9 {CompileAddExpr: error compiling add arm} { + catch {expr 2-x} msg + set msg +} {syntax error in expression "2-x"} +test expr-11.10 {CompileAddExpr: runtime error} { + list [catch {expr {24.0+"xx"}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-11.11 {CompileAddExpr: runtime error} { + list [catch {expr {"a"-"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "-"}} +test expr-11.12 {CompileAddExpr: runtime error} { + list [catch {expr {3/0}} msg] $msg +} {1 {divide by zero}} +test expr-11.13 {CompileAddExpr: runtime error} { + list [catch {expr {2.3/0.0}} msg] $msg +} {1 {divide by zero}} + +test expr-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5 +test expr-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5 +test expr-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0 +test expr-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936 +test expr-12.5 {CompileMultiplyExpr: error in unary expr} { + catch {expr ~x} msg + set msg +} {syntax error in expression "~x"} +test expr-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765 +test expr-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2 +test expr-12.8 {CompileMultiplyExpr: error compiling multiply arm} { + catch {expr 2*3%%6} msg + set msg +} {syntax error in expression "2*3%%6"} +test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} { + catch {expr 2*x} msg + set msg +} {syntax error in expression "2*x"} +test expr-12.10 {CompileMultiplyExpr: runtime error} { + list [catch {expr {24.0*"xx"}} msg] $msg +} {1 {can't use non-numeric string as operand of "*"}} +test expr-12.11 {CompileMultiplyExpr: runtime error} { + list [catch {expr {"a"/"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "/"}} + +test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 +test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +000123} 83 +test expr-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36 +test expr-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0 +test expr-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0 +test expr-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1 +test expr-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0 +test expr-13.8 {CompileUnaryExpr: error compiling unary expr} { + catch {expr ~x} msg + set msg +} {syntax error in expression "~x"} +test expr-13.9 {CompileUnaryExpr: error compiling unary expr} { + catch {expr !1.x} msg + set msg +} {syntax error in expression "!1.x"} +test expr-13.10 {CompileUnaryExpr: runtime error} { + list [catch {expr {~"xx"}} msg] $msg +} {1 {can't use non-numeric string as operand of "~"}} +test expr-13.11 {CompileUnaryExpr: runtime error} { + list [catch {expr ~4.0} msg] $msg +} {1 {can't use floating-point value as operand of "~"}} +test expr-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291 +test expr-13.13 {CompileUnaryExpr: just primary expr} { + set a 27 + expr $a +} 27 +test expr-13.14 {CompileUnaryExpr: just primary expr} { + expr double(27) +} 27.0 +test expr-13.15 {CompileUnaryExpr: just primary expr} {expr "123"} 123 +test expr-13.16 {CompileUnaryExpr: error in primary expr} { + catch {expr [set]} msg + set msg +} {wrong # args: should be "set varName ?newValue?"} +test expr-14.1 {CompilePrimaryExpr: literal primary} {expr 1} 1 +test expr-14.2 {CompilePrimaryExpr: literal primary} {expr 123} 123 +test expr-14.3 {CompilePrimaryExpr: literal primary} {expr 0xff} 255 +test expr-14.4 {CompilePrimaryExpr: literal primary} {expr 00010} 8 +test expr-14.5 {CompilePrimaryExpr: literal primary} {expr 62.0} 62.0 +test expr-14.6 {CompilePrimaryExpr: literal primary} { + expr 3.1400000 +} 3.14 +test expr-14.7 {CompilePrimaryExpr: literal primary} {expr {{abcde}<{abcdef}}} 1 +test expr-14.8 {CompilePrimaryExpr: literal primary} {expr {{abc\ +def} < {abcdef}}} 1 +test expr-14.9 {CompilePrimaryExpr: literal primary} {expr {{abc\tde} > {abc\tdef}}} 0 +test expr-14.10 {CompilePrimaryExpr: literal primary} {expr {{123}}} 123 +test expr-14.11 {CompilePrimaryExpr: var reference primary} { + set i 789 + list [expr {$i}] [expr $i] +} {789 789} +test expr-14.12 {CompilePrimaryExpr: var reference primary} { + set i {789} ;# test expr's aggressive conversion to numeric semantics + list [expr {$i}] [expr $i] +} {789 789} +test expr-14.13 {CompilePrimaryExpr: var reference primary} { + catch {unset a} + set a(foo) foo + set a(bar) bar + set a(123) 123 + set result "" + lappend result [expr $a(123)] [expr {$a(bar)<$a(foo)}] + catch {unset a} + set result +} {123 1} +test expr-14.14 {CompilePrimaryExpr: var reference primary} { + set i 123 ;# test "$var.0" floating point conversion hack + list [expr $i] [expr $i.0] [expr $i.0/12.0] +} {123 123.0 10.25} +test expr-14.15 {CompilePrimaryExpr: var reference primary} { + set i 123 + catch {expr $i.2} msg + set msg +} 123.2 +test expr-14.16 {CompilePrimaryExpr: error compiling var reference primary} { + catch {expr {$a(foo}} msg + set errorInfo +} {missing ) + while compiling +"expr {$a(foo}"} +test expr-14.17 {CompilePrimaryExpr: string primary that looks like var ref} { + expr $ +} $ +test expr-14.18 {CompilePrimaryExpr: quoted string primary} { + expr "21" +} 21 +test expr-14.19 {CompilePrimaryExpr: quoted string primary} { + set i 123 + set x 456 + expr "$i+$x" +} 579 +test expr-14.20 {CompilePrimaryExpr: quoted string primary} { + set i 3 + set x 6 + expr 2+"$i.$x" +} 5.6 +test expr-14.21 {CompilePrimaryExpr: error in quoted string primary} { + catch {expr "[set]"} msg + set msg +} {wrong # args: should be "set varName ?newValue?"} +test expr-14.22 {CompilePrimaryExpr: subcommand primary} { + expr {[set i 123; set i]} +} 123 +test expr-14.23 {CompilePrimaryExpr: error in subcommand primary} { + catch {expr {[set]}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + while compiling +"expr {[set]}"} +test expr-14.24 {CompilePrimaryExpr: error in subcommand primary} { + catch {expr {[set i}} msg + set errorInfo +} {missing close-bracket + while compiling +"expr {[set i}"} +test expr-14.25 {CompilePrimaryExpr: math function primary} { + format %.6g [expr exp(1.0)] +} 2.71828 +test expr-14.26 {CompilePrimaryExpr: math function primary} { + format %.6g [expr pow(2.0+0.1,3.0+0.1)] +} 9.97424 +test expr-14.27 {CompilePrimaryExpr: error in math function primary} { + catch {expr sinh::(2.0)} msg + set errorInfo +} {syntax error in expression "sinh::(2.0)" + while compiling +"expr sinh::(2.0)"} +test expr-14.28 {CompilePrimaryExpr: subexpression primary} { + expr 2+(3*4) +} 14 +test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} { + catch {expr 2+(3*[set])} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + while compiling +"expr 2+(3*[set])"} +test expr-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} { + catch {expr 2+(3*(4+5)} msg + set errorInfo +} {syntax error in expression "2+(3*(4+5)" + while compiling +"expr 2+(3*(4+5)"} +test expr-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} { + set i "5+10" + list "[expr $i] == 15" "[expr ($i)] == 15" "[eval expr ($i)] == 15" +} {{15 == 15} {15 == 15} {15 == 15}} +test expr-14.32 {CompilePrimaryExpr: unexpected token} { + catch {expr @} msg + set errorInfo +} {syntax error in expression "@" + while compiling +"expr @"} + +test expr-15.1 {CompileMathFuncCall: missing parenthesis} { + catch {expr sinh2.0)} msg + set errorInfo +} {syntax error in expression "sinh2.0)" + while compiling +"expr sinh2.0)"} +test expr-15.2 {CompileMathFuncCall: unknown math function} { + catch {expr whazzathuh(1)} msg + set errorInfo +} {unknown math function "whazzathuh" + while compiling +"expr whazzathuh(1)"} +test expr-15.3 {CompileMathFuncCall: too many arguments} { + catch {expr sin(1,2,3)} msg + set errorInfo +} {too many arguments for math function + while compiling +"expr sin(1,2,3)"} +test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} { + catch {expr sin()} msg + set errorInfo +} {too few arguments for math function + while compiling +"expr sin()"} +test expr-15.5 {CompileMathFuncCall: too few arguments} { + catch {expr pow(1)} msg + set errorInfo +} {too few arguments for math function + while compiling +"expr pow(1)"} +test expr-15.6 {CompileMathFuncCall: missing ')'} { + catch {expr sin(1} msg + set errorInfo +} {syntax error in expression "sin(1" + while compiling +"expr sin(1"} +if $gotT1 { + test expr-15.7 {CompileMathFuncCall: call registered math function} { + expr 2*T1() + } 246 + test expr-15.8 {CompileMathFuncCall: call registered math function} { + expr T2()*3 + } 1035 + + test expr-15.9 {CompileMathFuncCall: call registered math function} { + expr T3(21, 37) + } 37 + test expr-15.10 {CompileMathFuncCall: call registered math function} { + expr T3(21.2, 37) + } 37.0 + test expr-15.11 {CompileMathFuncCall: call registered math function} { + expr T3(-21.2, -17.5) + } -17.5 +} + +test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { + catch {unset a} + set a(VALUE) ff15 + set i 123 + if {[expr 0x$a(VALUE)] & 16} { + set i {} + } + set i +} {} +test expr-16.2 {GetToken: check for string literal in braces} { + expr {{1}} +} {1} + +# Check "expr" and computed command names. + +test expr-17.1 {expr and computed command names} { + set i 0 + set z expr + $z 1+2 +} 3 + +# Check correct conversion of operands to numbers: If the string looks like +# an integer, convert to integer. Otherwise, if the string looks like a +# double, convert to double. + +test expr-18.1 {expr and conversion of operands to numbers} { + set x [lindex 11 0] + catch {expr int($x)} + expr {$x} +} 11 + +# Check "expr" and interpreter result object resetting before appending +# an error msg during evaluation of exprs not in {}s + +test expr-19.1 {expr and interpreter result object resetting} { + proc p {} { + set t 10.0 + set x 2.0 + set dx 0.2 + set f {$dx-$x/10} + set g {-$x/5} + set center 1.0 + set x [expr $x-$center] + set dx [expr $dx+$g] + set x [expr $x+$f+$center] + set x [expr $x+$f+$center] + set y [expr round($x)] + } + p +} 3 + +unset a +return diff --git a/tests/compExpr.test b/tests/compExpr.test new file mode 100644 index 0000000..ec07592 --- /dev/null +++ b/tests/compExpr.test @@ -0,0 +1,323 @@ +# This file contains a collection of tests for the procedures in the +# file tclCompExpr.c. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) compExpr.test 1.1 97/12/09 18:23:41 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { + set gotT1 0 + puts "This application hasn't been compiled with the \"T1\" and" + puts "\"T2\" math functions, so I'll skip some of the expr tests." +} else { + set gotT1 1 +} + +catch {unset a} + +test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} { + expr 1+2 +} 3 +test compExpr-1.2 {TclCompileExpr procedure, error parsing expr} { + list [catch {expr 1+2+} msg] $msg +} {1 {syntax error in expression "1+2+"}} +test compExpr-1.3 {TclCompileExpr procedure, error compiling expr} { + list [catch {expr "foo(123)"} msg] $msg +} {1 {unknown math function "foo"}} +test compExpr-1.4 {TclCompileExpr procedure, expr has no operators} { + set a {000123} + expr {$a} +} 83 + +test compExpr-2.1 {CompileSubExpr procedure, TCL_TOKEN_WORD parse token} { + catch {unset a} + set a 27 + expr {"foo$a" < "bar"} +} 0 +test compExpr-2.2 {CompileSubExpr procedure, error compiling TCL_TOKEN_WORD parse token} { + list [catch {expr {"00[expr 1+]" + 17}} msg] $msg +} {1 {syntax error in expression "1+"}} +test compExpr-2.3 {CompileSubExpr procedure, TCL_TOKEN_TEXT parse token} { + expr {{12345}} +} 12345 +test compExpr-2.4 {CompileSubExpr procedure, empty TCL_TOKEN_TEXT parse token} { + expr {{}} +} {} +test compExpr-2.5 {CompileSubExpr procedure, TCL_TOKEN_BS parse token} { + expr "\{ \\ + +123 \}" +} 123 +test compExpr-2.6 {CompileSubExpr procedure, TCL_TOKEN_COMMAND parse token} { + expr {[info tclversion] != ""} +} 1 +test compExpr-2.7 {CompileSubExpr procedure, TCL_TOKEN_COMMAND parse token} { + expr {[]} +} {} +test compExpr-2.8 {CompileSubExpr procedure, error in TCL_TOKEN_COMMAND parse token} { + list [catch {expr {[foo "bar"xxx] + 17}} msg] $msg +} {1 {extra characters after close-quote}} +test compExpr-2.9 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} { + catch {unset a} + set a 123 + expr {$a*2} +} 246 +test compExpr-2.10 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} { + catch {unset a} + catch {unset b} + set a(george) martha + set b geo + expr {$a(${b}rge)} +} martha +test compExpr-2.11 {CompileSubExpr procedure, error in TCL_TOKEN_VARIABLE parse token} { + catch {unset a} + list [catch {expr {$a + 17}} msg] $msg +} {1 {can't read "a": no such variable}} +test compExpr-2.12 {CompileSubExpr procedure, TCL_TOKEN_SUB_EXPR parse token} { + expr {27||3? 3<<(1+4) : 4&&9} +} 96 +test compExpr-2.13 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} { + catch {unset a} + set a 15 + list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg +} {1 {syntax error in expression "1+"}} +test compExpr-2.14 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, op found} { + expr {5*6} +} 30 +test compExpr-2.15 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function found} { + format %.6g [expr {sin(2.0)}] +} 0.909297 +test compExpr-2.16 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function not found} { + list [catch {expr {fred(2.0)}} msg] $msg +} {1 {unknown math function "fred"}} +test compExpr-2.17 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4*2} +} 8 +test compExpr-2.18 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4/2} +} 2 +test compExpr-2.19 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4%2} +} 0 +test compExpr-2.20 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4<<2} +} 16 +test compExpr-2.21 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4>>2} +} 1 +test compExpr-2.22 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4<2} +} 0 +test compExpr-2.23 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4>2} +} 1 +test compExpr-2.24 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4<=2} +} 0 +test compExpr-2.25 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4>=2} +} 1 +test compExpr-2.26 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4==2} +} 0 +test compExpr-2.27 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4!=2} +} 1 +test compExpr-2.28 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4&2} +} 0 +test compExpr-2.29 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4^2} +} 6 +test compExpr-2.30 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4|2} +} 6 +test compExpr-2.31 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, 1 operand} { + expr {!4} +} 0 +test compExpr-2.32 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, 1 operand} { + expr {~4} +} -5 +test compExpr-2.33 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, comparison} { + catch {unset a} + set a 15 + expr {$a==15} ;# compiled out-of-line to runtime call on Tcl_ExprObjCmd +} 1 +test compExpr-2.34 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { + expr {+2} +} 2 +test compExpr-2.35 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, error in special operator} { + list [catch {expr {+[expr 1+]}} msg] $msg +} {1 {syntax error in expression "1+"}} +test compExpr-2.36 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { + expr {4+2} +} 6 +test compExpr-2.37 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, error in special operator} { + list [catch {expr {[expr 1+]+5}} msg] $msg +} {1 {syntax error in expression "1+"}} +test compExpr-2.38 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, error in special operator} { + list [catch {expr {5+[expr 1+]}} msg] $msg +} {1 {syntax error in expression "1+"}} +test compExpr-2.39 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { + expr {-2} +} -2 +test compExpr-2.40 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { + expr {4-2} +} 2 +test compExpr-2.41 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { + catch {unset a} + set a true + expr {0||$a} +} 1 +test compExpr-2.42 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} { + catch {unset a} + set a 15 + list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg +} {1 {syntax error in expression "1+"}} +test compExpr-2.43 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { + catch {unset a} + set a false + expr {3&&$a} +} 0 +test compExpr-2.44 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { + catch {unset a} + set a false + expr {$a||1? 1 : 0} +} 1 +test compExpr-2.45 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} { + catch {unset a} + set a 15 + list [catch {expr {1? 54 : "$a[expr 1+]00"}} msg] $msg +} {1 {syntax error in expression "1+"}} + +test compExpr-3.1 {CompileLandOrLorExpr procedure, numeric 1st operand} { + catch {unset a} + set a 2 + expr {[set a]||0} +} 1 +test compExpr-3.2 {CompileLandOrLorExpr procedure, nonnumeric 1st operand} { + catch {unset a} + set a no + expr {$a&&1} +} 0 +test compExpr-3.3 {CompileSubExpr procedure, error in 1st operand} { + list [catch {expr {[expr *2]||0}} msg] $msg +} {1 {syntax error in expression "*2"}} +test compExpr-3.4 {CompileLandOrLorExpr procedure, result is 1 or 0} { + catch {unset a} + catch {unset b} + set a no + set b true + expr {$a || $b} +} 1 +test compExpr-3.5 {CompileLandOrLorExpr procedure, short-circuit semantics} { + catch {unset a} + set a yes + expr {$a || [exit]} +} 1 +test compExpr-3.6 {CompileLandOrLorExpr procedure, short-circuit semantics} { + catch {unset a} + set a no + expr {$a && [exit]} +} 0 +test compExpr-3.7 {CompileLandOrLorExpr procedure, numeric 2nd operand} { + catch {unset a} + set a 2 + expr {0||[set a]} +} 1 +test compExpr-3.8 {CompileLandOrLorExpr procedure, nonnumeric 2nd operand} { + catch {unset a} + set a no + expr {1&&$a} +} 0 +test compExpr-3.9 {CompileLandOrLorExpr procedure, error in 2nd operand} { + list [catch {expr {0||[expr %2]}} msg] $msg +} {1 {syntax error in expression "%2"}} +test compExpr-3.10 {CompileLandOrLorExpr procedure, long lor/land arm} { + set a "abcdefghijkl" + set i 7 + expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} +} 1 + +test compExpr-4.1 {CompileCondExpr procedure, simple test} { + catch {unset a} + set a 2 + expr {($a > 1)? "ok" : "nope"} +} ok +test compExpr-4.2 {CompileCondExpr procedure, complex test, convert to numeric} { + catch {unset a} + set a no + expr {[set a]? 27 : -54} +} -54 +test compExpr-4.3 {CompileCondExpr procedure, error in test} { + list [catch {expr {[expr *2]? +1 : -1}} msg] $msg +} {1 {syntax error in expression "*2"}} +test compExpr-4.4 {CompileCondExpr procedure, simple "true" clause} { + catch {unset a} + set a no + expr {1? (27-2) : -54} +} 25 +test compExpr-4.5 {CompileCondExpr procedure, convert "true" clause to numeric} { + catch {unset a} + set a no + expr {1? $a : -54} +} no +test compExpr-4.6 {CompileCondExpr procedure, error in "true" clause} { + list [catch {expr {1? [expr *2] : -127}} msg] $msg +} {1 {syntax error in expression "*2"}} +test compExpr-4.7 {CompileCondExpr procedure, simple "false" clause} { + catch {unset a} + set a no + expr {(2-2)? -3.14159 : "nope"} +} nope +test compExpr-4.8 {CompileCondExpr procedure, convert "false" clause to numeric} { + catch {unset a} + set a 00123 + expr {0? 42 : $a} +} 83 +test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} { + list [catch {expr {1? 15 : [expr *2]}} msg] $msg +} {1 {syntax error in expression "*2"}} + +test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { + format %.6g [expr atan2(1.0, 2.0)] +} 0.463648 +test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} { + list [catch {expr {do_it()}} msg] $msg +} {1 {unknown math function "do_it"}} +if $gotT1 { + test compExpr-5.3 {CompileMathFuncCall: call registered math function} { + expr 3*T1()-1 + } 368 + test compExpr-5.4 {CompileMathFuncCall: call registered math function} { + expr T2()*3 + } 1035 +} +test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} { + list [catch {expr {atan2(1.0)}} msg] $msg +} {1 {too few arguments for math function}} +test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} { + format %.6g [expr pow(2.1, 27.5-(24.4*(5%2)))] +} 9.97424 +test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} { + list [catch {expr {sinh(2.*)}} msg] $msg +} {1 {syntax error in expression "sinh(2.*)"}} +test compExpr-5.8 {CompileMathFuncCall procedure, too many arguments} { + list [catch {expr {sinh(2.0, 3.0)}} msg] $msg +} {1 {too many arguments for math function}} +test compExpr-5.9 {CompileMathFuncCall procedure, too many arguments} { + list [catch {expr {0 <= rand(5.2)}} msg] $msg +} {1 {too many arguments for math function}} + +test compExpr-6.1 {LogSyntaxError procedure, error in expr longer than 60 chars} { + list [catch {expr {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1 foo 3} msg] $msg +} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012"}} + +catch {unset a} +catch {unset b} +concat {} diff --git a/tests/compile.test b/tests/compile.test index 9e30fb3..53dc3d8 100644 --- a/tests/compile.test +++ b/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.7 97/08/12 13:34:13 +# SCCS: @(#) compile.test 1.9 97/12/16 13:32:14 if {[string compare test [info procs test]] == 1} then {source defs} @@ -69,7 +69,17 @@ test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} { list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] } {1 1 1} -test compile-3.1 {TclCompileSetCmd: global scalar names with ::s} { +test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} { + catch {unset a} + set a(1) xyzzyx + proc p {} { + global a + catch {set x 123} a(1) + } + list [p] $a(1) +} {0 123} + +test compile-4.1 {TclCompileSetCmd: global scalar names with ::s} { catch {unset x} catch {unset y} set x 123 @@ -80,7 +90,7 @@ test compile-3.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-3.2 {TclCompileSetCmd: global array names with ::s} { +test compile-4.2 {TclCompileSetCmd: global array names with ::s} { catch {unset a} set ::a(1) 2 proc p {} { @@ -89,7 +99,7 @@ test compile-3.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-3.3 {TclCompileSetCmd: namespace var names with ::s} { +test compile-4.3 {TclCompileSetCmd: namespace var names with ::s} { catch {namespace delete test_ns_compile} catch {unset x} namespace eval test_ns_compile { @@ -101,17 +111,17 @@ test compile-3.3 {TclCompileSetCmd: namespace var names with ::s} { list $::x $::test_ns_compile::arr(1) } {hello 123} -test compile-4.1 {CollectArgInfo: binary data} { +test compile-5.1 {CollectArgInfo: binary data} { list [catch "string length \000foo" msg] $msg } {0 4} -test compile-4.2 {CollectArgInfo: binary data} { +test compile-5.2 {CollectArgInfo: binary data} { list [catch "string length foo\000" msg] $msg } {0 4} -test compile-4.3 {CollectArgInfo: handle "]" at end of command properly} { +test compile-5.3 {CollectArgInfo: handle "]" at end of command properly} { set x ] } {]} -test compile-5.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} { +test compile-6.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} { proc p {} { set x {} eval $x @@ -126,3 +136,5 @@ catch {namespace delete test_ns_compile} catch {unset x} catch {unset y} catch {unset a} + +return diff --git a/tests/concat.test b/tests/concat.test index d0222e9..99972e9 100644 --- a/tests/concat.test +++ b/tests/concat.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: @(#) concat.test 1.10 96/12/20 18:53:31 +# SCCS: @(#) concat.test 1.11 97/12/08 15:02:29 if {[string compare test [info procs test]] == 1} then {source defs} @@ -44,3 +44,5 @@ test concat-4.2 {pruning off extra white space} { test concat-4.3 {pruning off extra white space sets length correctly} { llength [concat { {{a}} }] } 1 + +return diff --git a/tests/dcall.test b/tests/dcall.test index c7ad1c6..8ab615e 100644 --- a/tests/dcall.test +++ b/tests/dcall.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: @(#) dcall.test 1.6 96/02/16 08:55:44 +# SCCS: @(#) dcall.test 1.7 97/12/08 15:02:32 if {[info commands testdcall] == {}} { puts "This application hasn't been compiled with the \"testdcall\"" @@ -38,3 +38,5 @@ test dcall-1.5 {deletion callbacks} { test dcall-1.6 {deletion callbacks} { lsort -increasing [testdcall 20 21 22 -21 -22 -20] } {} + +return @@ -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.60 97/08/13 18:10:19 +# SCCS: @(#) defs 1.72 98/01/15 18:41:39 if ![info exists VERBOSE] { set VERBOSE 0 @@ -18,30 +18,6 @@ if ![info exists TESTS] { set TESTS {} } -# If tests are being run as root, issue a warning message and set a -# variable to prevent some tests from running at all. - -set user {} -if {$tcl_platform(platform) == "unix"} { - catch {set user [exec whoami]} - if {$user == ""} { - catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} - } - if {$user == ""} {set user root} - if {$user == "root"} { - puts stdout "Warning: you're executing as root. I'll have to" - puts stdout "skip some of the tests, since they'll fail as root." - set testConfig(root) 1 - } -} - -# Some of the tests don't work on some system configurations due to -# differences in word length, file system configuration, etc. In order -# to prevent false alarms, these tests are generally only run in the -# master development directory for Tcl. The presence of a file -# "doAllTests" in this directory is used to indicate that the non-portable -# tests should be run. - # If there is no "memory" command (because memory debugging isn't # enabled), generate a dummy command that does nothing. @@ -92,49 +68,74 @@ if {[info commands memory] == ""} { # skipped. As of 11/2/96 these are the history tests # since they depend on accurate source location # information. +# hasIsoLocale - 1 means the tests that need to switch to an iso +# locale can be run. +# catch {unset testConfig} -if {$tcl_platform(platform) == "unix"} { - set testConfig(unixOnly) 1 - set testConfig(tempNotPc) 1 - set testConfig(tempNotMac) 1 -} else { - set testConfig(unixOnly) 0 -} -if {$tcl_platform(platform) == "macintosh"} { - set testConfig(tempNotPc) 1 - set testConfig(macOnly) 1 -} else { - set testConfig(macOnly) 0 -} -if {$tcl_platform(platform) == "windows"} { - set testConfig(tempNotMac) 1 - set testConfig(pcOnly) 1 -} else { - set testConfig(pcOnly) 0 + +# The following trace procedure makes it so that we can safely refer to +# non-existent members of the testConfig array without causing an error. +# Instead, reading a non-existent member will return 0. This is necessary +# because tests are allowed to use constraint "X" without ensuring that +# testConfig("X") is defined. + +trace variable testConfig r safeFetch + +proc safeFetch {n1 n2 op} { + global testConfig + + if {($n2 != {}) && ([info exists testConfig($n2)] == 0)} { + set testConfig($n2) 0 + } +} + +# Some of the tests don't work on some system configurations due to +# differences in word length, file system configuration, etc. In order +# to prevent false alarms, these tests are generally only run in the +# master development directory for Tcl. The presence of a file +# "doAllTests" in this directory is used to indicate that the non-portable +# tests should be run. + +set testConfig(nonPortable) [expr [file exists doAllTests] || [file exists DOALLT~1]] +set testConfig(notIfCompiled) [file exists doAllCompilerTests] +set testConfig(knownBug) [expr [file exists doBuggyTests] || [file exists DOBUGG~1]] + +if {$testConfig(nonPortable) == 0} { + puts "(will skip non-portable tests)" } -set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)] -set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)] -set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)] -set testConfig(nonPortable) [expr [file exists doAllTests] || [file exists doAllTe]] -set testConfig(knownBug) [expr [file exists doBuggyTests] || [file exists doBuggyT]] -set testConfig(notIfCompiled) [file exists doAllCompilerTests] -set testConfig(unix) $testConfig(unixOnly) -set testConfig(mac) $testConfig(macOnly) -set testConfig(pc) $testConfig(pcOnly) +set testConfig(unixOnly) [expr {$tcl_platform(platform) == "unix"}] +set testConfig(macOnly) [expr {$tcl_platform(platform) == "macintosh"}] +set testConfig(pcOnly) [expr {$tcl_platform(platform) == "windows"}] + +set testConfig(unix) $testConfig(unixOnly) +set testConfig(mac) $testConfig(macOnly) +set testConfig(pc) $testConfig(pcOnly) + +set testConfig(unixOrPc) [expr $testConfig(unix) || $testConfig(pc)] +set testConfig(macOrPc) [expr $testConfig(mac) || $testConfig(pc)] +set testConfig(macOrUnix) [expr $testConfig(mac) || $testConfig(unix)] -set testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}] -set testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}] -set testConfig(win32s) [expr {$tcl_platform(os) == "Win32s"}] +set testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}] +set testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}] +set testConfig(win32s) [expr {$tcl_platform(os) == "Win32s"}] + +# The following config switches are used to mark tests that should work, +# but have been temporarily disabled on certain platforms because they don't +# and we haven't gotten around to fixing the underlying problem. + +set testConfig(tempNotPc) [expr !$testConfig(pc)] +set testConfig(tempNotMac) [expr !$testConfig(mac)] +set testConfig(tempNotUnix) [expr !$testConfig(unix)] # The following config switches are used to mark tests that crash on # certain platforms, so that they can be reactivated again when the # underlying problem is fixed. -set testConfig(pcCrash) $testConfig(macOrUnix) -set testConfig(macCrash) $testConfig(unixOrPc) -set testConfig(unixCrash) $testConfig(macOrPc) +set testConfig(pcCrash) [expr !$testConfig(pc)] +set testConfig(macCrash) [expr !$testConfig(mac)] +set testConfig(unixCrash) [expr !$testConfig(unix)] if {[catch {set f [open defs r]}]} { set testConfig(nonBlockFiles) 1 @@ -147,13 +148,20 @@ if {[catch {set f [open defs r]}]} { close $f } -trace variable testConfig r safeFetch - -proc safeFetch {n1 n2 op} { - global testConfig +# If tests are being run as root, issue a warning message and set a +# variable to prevent some tests from running at all. - if {($n2 != {}) && ([info exists testConfig($n2)] == 0)} { - set testConfig($n2) 0 +set user {} +if {$tcl_platform(platform) == "unix"} { + catch {set user [exec whoami]} + if {$user == ""} { + catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} + } + if {$user == ""} {set user root} + if {$user == "root"} { + puts stdout "Warning: you're executing as root. I'll have to" + puts stdout "skip some of the tests, since they'll fail as root." + set testConfig(root) 1 } } @@ -170,6 +178,15 @@ if {$tcl_platform(platform) == "unix"} { set testConfig(asyncPipeClose) 1 } +# Test to see if we have a broken version of sprintf with respect to the +# "e" format of floating-point numbers. + +set testConfig(eformat) 1 +if {[string compare "[format %g 5e-5]" "5e-05"] != 0} { + set testConfig(eformat) 0 + puts "(will skip tests that depend on the \"e\" format of floating-point numbers)" +} + # Test to see if execed commands such as cat, echo, rm and so forth are # present on this machine. @@ -222,10 +239,9 @@ if {($testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} { catch {exec rm -r removeMe} } if {$testConfig(unixExecs) == 0} { - puts stdout "Warning: Unix-style executables are not available, so" - puts stdout "some tests will be skipped." + puts "(will skip tests that depend on Unix-style executables)" } -} +} proc print_verbose {name description constraints script code answer} { puts stdout "\n" @@ -333,7 +349,14 @@ proc test {name description script answer args} { error "wrong # args: must be \"test name description ?constraints? script answer\"" } memory tag $name + set open [openfiles] set code [catch {uplevel $script} result] + if {[leakfiles $open] != ""} { + puts "\n" + puts "==== $name $description" + puts "==== Test leaking open files:" + puts [leakfiles $open] + } if {$code != 0} { print_verbose $name $description $constraints $script \ $code $result @@ -364,6 +387,45 @@ proc dotests {file args} { set TESTS $savedTests } +proc openfiles {} { + if {[catch {testchannel open} result]} { + return {} + } + return $result +} + +proc leakfiles {old} { + if {[catch {testchannel open} new]} { + return {} + } + set leak {} + foreach p $new { + if {[lsearch $old $p] < 0} { + lappend leak $p + } + } + return $leak +} + +set saveState {} + +proc saveState {} { + uplevel #0 {set ::saveState [list [info procs] [info vars]]} +} + +proc restoreState {} { + foreach p [info procs] { + if {[lsearch [lindex $::saveState 0] $p] < 0} { + rename $p {} + } + } + foreach p [uplevel #0 {info vars}] { + if {[lsearch [lindex $::saveState 1] $p] < 0} { + uplevel #0 "unset $p" + } + } +} + proc normalizeMsg {msg} { regsub "\n$" [string tolower $msg] "" msg regsub -all "\n\n" $msg "\n" msg @@ -407,6 +469,24 @@ proc viewFile {name} { } } +# +# Construct a string that consists of the requested sequence of bytes, +# as opposed to a string of properly formed UTF-8 characters. +# This allows the tester to +# 1. Create denormalized or improperly formed strings to pass to C procedures +# that are supposed to accept strings with embedded NULL bytes. +# 2. Confirm that a string result has a certain pattern of bytes, for instance +# to confirm that "\xe0\0" in a Tcl script is stored internally in +# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". +# +# Generally, it's a bad idea to examine the bytes in a Tcl string or to +# construct improperly formed strings in this manner, because it involves +# exposing that Tcl uses UTF-8 internally. + +proc bytestring {string} { + testencoding toutf $string identity +} + # Locate tcltest executable set tcltest [info nameofexecutable] @@ -416,6 +496,7 @@ if {$tcltest == "{}"} { puts "Unable to find tcltest executable, multiple process tests will fail." } +set testConfig(stdio) 0 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. @@ -443,5 +524,57 @@ set testConfig(socket) [expr {$msg != "sockets are not available on this system" if {$testConfig(socket) == 0} { puts "(will skip tests that use sockets)" } - - + +# +# Internationalization / ISO support procs -- dl +# +if {[info commands testlocale]==""} { + # No testlocale command, no tests... + # (it could be that we are a sub interp and we could just load + # the Tcltest package but that would interfere with tests + # that tests packages/loading in slaves...) + set testConfig(hasIsoLocale) 0 +} else { + proc set_iso8859_1_locale {} { + global previousLocale isoLocale + set previousLocale [testlocale ctype] + testlocale ctype $isoLocale + } + + proc restore_locale {} { + global previousLocale + testlocale ctype $previousLocale + } + + if {![info exists isoLocale]} { + set isoLocale fr + switch $tcl_platform(platform) { + "unix" { + # Try some 'known' values for some platforms: + switch -exact -- $tcl_platform(os) { + "FreeBSD" { + set isoLocale fr_FR.ISO_8859-1 + } + default { + # Works on SunOS 4 and Solaris, and maybe others... + # define it to something else on your system + #if you want to test those. + set isoLocale iso_8859_1 + } + } + } + "windows" { + set isoLocale French + } + } + } + + set testConfig(hasIsoLocale) [string length [set_iso8859_1_locale]] + restore_locale + + if {$testConfig(hasIsoLocale) == 0} { + puts "(will skip tests that needs to set an iso8859-1 locale)" + } + +} + diff --git a/tests/dstring.test b/tests/dstring.test index 93a84d4..23f37c7 100644 --- a/tests/dstring.test +++ b/tests/dstring.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) dstring.test 1.10 96/10/08 17:40:02 +# SCCS: @(#) dstring.test 1.11 97/12/08 15:02:36 if {[info commands testdstring] == {}} { puts "This application hasn't been compiled with the \"testdstring\"" @@ -246,3 +246,5 @@ test dstring-6.5 {Tcl_DStringGetResult} { } {{} {This is a specially-allocated stringz}} testdstring free + +return diff --git a/tests/encoding.test b/tests/encoding.test new file mode 100644 index 0000000..824ae48 --- /dev/null +++ b/tests/encoding.test @@ -0,0 +1,227 @@ +# This file contains a collection of tests for tclEncoding.c +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) encoding.test 1.11 97/12/16 13:03:49 +# + +if {[info procs test] != "test"} { + source defs +} + +proc toutf {args} { + global x + lappend x "toutf $args" +} +proc fromutf {args} { + global x + lappend x "fromutf $args" +} + +test encoding-1.1 {InitEncoding} { +} {} + +test encoding-3.1 {Tcl_CreateEncodingType: new} { + testencoding create foo {toutf 1} {fromutf 2} + set x {} + testencoding toutf abcd foo + testencoding fromutf abcd foo + testencoding delete foo + set x +} {{toutf 1} {fromutf 2}} +test encoding-3.2 {Tcl_CreateEncodingType: replace encoding} { + testencoding create foo {toutf a} {fromutf b} + set x {} + testencoding toutf abcd foo + testencoding fromutf abcd foo + testencoding delete foo + set x +} {{toutf a} {fromutf b}} + +test encoding-4.1 {Tcl_GetTextEncoding: existing encoding} { + testencoding create foo toutf fromutf + set x {} + testencoding fromutf abcd foo + testencoding delete foo + set x +} {{fromutf }} +test encoding-4.2 {Tcl_GetTextEncoding: load encoding} { + list [testencoding fromutf \u4e4e jis0208] \ + [testencoding toutf 8C jis0208] +} "8C \u4e4e" + +test encoding-5.1 {Tcl_GetTextEncodingName} { + set old [testencoding system] + testencoding system jis0208 + set x [testencoding system] + testencoding system identity + testencoding system $old + set x +} {jis0208} + +test encoding-6.1 {Tcl_FreeTextEncoding: refcount == 0} { + testencoding fromutf \u4e4e jis0208 +} {8C} +test encoding-6.2 {Tcl_FreeTextEncoding: refcount != 0} { + set system [testencoding system] + set path [testencoding path] + testencoding system jis0208 ;# incr ref count + testencoding path . + set x [testencoding fromutf \u4e4e jis0208] ;# old one found + testencoding system identity + lappend x [testencoding fromutf \u4e4e jis0208] + testencoding system identity + testencoding path $path + testencoding system $system + set x +} "8C \xe4\xb9\x8e" + +test encoding-7.1 {Tcl_SetSystemTextEncoding} { + set old [testencoding system] + testencoding system jis0208 + set x [testencoding fromutf \u4e4e snarky] + testencoding system identity + testencoding system $old + set x +} {8C} +test encoding-7.2 {Tcl_SetSystemTextEncoding: test ref count} { + set old [testencoding system] + testencoding system $old + string compare $old [testencoding system] +} {0} + + +test encoding-8.1 {Tcl_UtfToExternalDString: small buffer} { + testencoding fromutf "\u543e\u543e\u543e\u543e" jis0208 +} {8c8c8c8c} +test encoding-8.2 {Tcl_UtfToExternalDString: big buffer} { + set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e + append a $a + append a $a + append a $a + append a $a + append a $a + append a $a + set x [testencoding fromutf $a jis0208] + list [string length $x] [string range $x 0 1] +} "1024 8C" + +test encoding-10.1 {Tcl_UtfToExternal} { +} {} + +test encoding-11.1 {Tcl_ExternalToUtfDString: small buffer} { + testencoding toutf 8c8c8c8c jis0208 +} "\u543e\u543e\u543e\u543e" +test encoding-11.2 {Tcl_UtfToExternalDString: big buffer} { + set a 8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C + append a $a + append a $a + append a $a + append a $a + set x [testencoding toutf $a jis0208] + list [string length $x] [string index $x 0] +} "512 \u4e4e" + +test encoding-13.1 {Tcl_ExternalToUtf} { +} {} + +test encoding-14.1 {LoadEncodingTable: no encoding path} { + set system [testencoding system] + set path [testencoding path] + testencoding system iso8859-1 + testencoding path {} + set x [testencoding fromutf \u4e4e jis0208] + testencoding path $path + testencoding system $system + list $x [testencoding fromutf \u4e4e jis0208] +} "? 8C" +test encoding-14.2 {LoadEncodingTable: table file} { + testencoding fromutf \u4e4e jis0208 +} {8C} +test encoding-14.3 {LoadEncodingTable: escape file} { + testencoding fromutf \u4e4e iso2022 +} "\x1b(B\x1b$@8C" + +test encoding-15.1 {LoadConvertTable: bad file} { + set system [testencoding system] + set path [testencoding path] + testencoding system identity + testencoding path . + file mkdir encoding + set f [open encoding/splat.enc w] + fconfigure $f -translation binary + puts $f "abcdefghijklmnop" + close $f + set x [testencoding fromutf \u4e4e splat] + file delete encoding/splat.enc + catch {file delete encoding} + testencoding path $path + testencoding system $system + set x +} "\xe4\xb9\x8e" +test encoding-15.2 {LoadConvertTable: normal encoding} { + set x [testencoding fromutf \u120 iso8859-3] + append x [testencoding fromutf \ud5 iso8859-3] + append x [testencoding toutf \xd5 iso8859-3] +} "\xd5?\u120" +test encoding-15.3 {LoadConvertTable: single-byte encoding} { + set x [testencoding fromutf ab\u0120g iso8859-3] + append x [testencoding toutf ab\xd5g iso8859-3] +} "ab\xd5gab\u120g" +test encoding-15.4 {LoadConvertTable: multi-byte encoding} { + set x [testencoding fromutf ab\u4e4eg shiftjis] + append x [testencoding toutf ab\x8c\xc1g shiftjis] +} "ab\x8c\xc1gab\u4e4eg" +test encoding-15.5 {LoadConvertTable: double-byte encoding} { + set x [testencoding fromutf \u4e4e\u3b1 jis0208] + append x [testencoding toutf 8C&A jis0208] +} "8C&A\u4e4e\u3b1" +test encoding-15.6 {LoadConvertTable: symbol encoding} { + set x [testencoding fromutf \u3b3 symbol] + append x [testencoding fromutf \u67 symbol] + append x [testencoding toutf \x67 symbol] +} "\x67\x67\u3b3" + +test encoding-16.1 {LoadEscapeTable} { + set x [testencoding fromutf ab\u4e4e\u68d9g iso2022] +} "\x1b(Bab\x1b$@8C\x1b$(DD%\x1b(Bg" + +test encoding-17.1 {BinaryProc} { + testencoding fromutf \x12\x34\x56\xff\x69 identity +} "\x12\x34\x56\xc3\xbf\x69" + +test encoding-18.1 {UtfToUtfProc} { + testencoding fromutf \xa3 utf-8 +} "\xc2\xa3" + +test encoding-19.1 {UnicodeToUtfProc} { + testencoding toutf NN unicode +} "\u4e4e" + +test encoding-20.1 {UtfToUnicodeProc} { +} {} + +test encoding-21.1 {TableToUtfProc} { +} {} + +test encoding-22.1 {UtfToTableProc} { +} {} + +test encoding-23.1 {TableFreeProc} { +} {} + +test encoding-24.1 {EscapeToUtfProc} { +} {} + +test encoding-25.1 {UtfToEscapeProc} { +} {} + +test encoding-26.1 {EscapeFreeProc} { +} {} + +return diff --git a/tests/env.test b/tests/env.test index 1bfc8dd..cd2c354 100644 --- a/tests/env.test +++ b/tests/env.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: @(#) env.test 1.14 97/10/31 17:00:03 +# SCCS: @(#) env.test 1.18 98/02/17 23:45:10 if {[string compare test [info procs test]] == 1} then {source defs} @@ -38,7 +38,20 @@ test env-1.2 {lappend to env value} { set env(test) aaaaaaaaaaaaaaaa append env(test) bbbbbbbbbbbbbb unset env(test) -} {} +} {} +test env-1.3 {reflection of env by "array names"} { + catch {interp delete child} + catch {unset env(test)} + interp create child + child eval {set env(test) garbage} + set names [array names env] + interp delete child + set ix [lsearch $names test] + catch {unset env(test)} + expr {$ix >= 0} +} {1} +# + if {[info commands exec] == ""} { puts "exec not implemented for this machine" return @@ -67,7 +80,7 @@ puts $f { lrem names ComSpec lrem names "" } - foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH} { + foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH PURE_PROG_NAME DISPLAY} { lrem names $name } foreach p $names { @@ -95,7 +108,7 @@ foreach name [array names env] { # 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} { +foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH DISPLAY} { if {[info exists env2($name)]} { set env($name) $env2($name); } @@ -139,6 +152,22 @@ unset env(NAME1) test env-4.2 {unsetting environment variables} { getenv } {XYZZY=garbage} +unset env(XYZZY) + +test env-4.3 {setting international environment variables} { + set env(\ua7) \ub6 + getenv +} "\ua7=\ub6" +test env-4.4 {changing international environment variables} { + set env(\ua7) \ua7 + getenv +} "\ua7=\ua7" +test env-4.5 {unsetting international environment variables} { + set env(\ub6) \ua7 + unset env(\ua7) + getenv +} "\ub6=\ua7" +unset env(\ub6) # Restore the environment variables at the end of the test. @@ -150,3 +179,5 @@ foreach name [array names env2] { } file delete printenv + +return diff --git a/tests/error.test b/tests/error.test index 1421e9b..1e52543 100644 --- a/tests/error.test +++ b/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.22 97/08/12 17:02:43 +# SCCS: @(#) error.test 1.23 97/12/08 15:02:42 if {[string compare test [info procs test]] == 1} then {source defs} @@ -172,4 +172,4 @@ test error-6.1 {catch must reset error state} { } {NONE 1} catch {rename p ""} -return "" +return diff --git a/tests/eval.test b/tests/eval.test index 07f610c..1506baf 100644 --- a/tests/eval.test +++ b/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.10 97/07/02 16:40:56 +# SCCS: @(#) eval.test 1.11 97/12/08 15:02:45 if {[string compare test [info procs test]] == 1} then {source defs} @@ -53,3 +53,5 @@ test eval-2.5 {error in eval'ed command: setting errorInfo} { set a 1 error \"test error\" }\"" + +return diff --git a/tests/event.test b/tests/event.test index 027f7e0..2dc6eb6 100644 --- a/tests/event.test +++ b/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.35 97/08/11 11:58:38" +# "@(#) event.test 1.36 97/12/08 15:05:00" if {[string compare test [info procs test]] == 1} then {source defs} @@ -565,3 +565,5 @@ if {[info commands testfilewait] != ""} { foreach i [after info] { after cancel $i } + +return diff --git a/tests/exec.test b/tests/exec.test index 169885a..fb0355d 100644 --- a/tests/exec.test +++ b/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.58 97/08/01 11:10:00 +# SCCS: @(#) exec.test 1.62 97/12/24 13:42:34 if {[string compare test [info procs test]] == 1} then {source defs} @@ -262,7 +262,7 @@ test exec-6.3 {redirecting stderr through a pipeline} { # I/O redirection: combinations. -catch {exec rm -f gorp.file2} +file delete gorp.file2 test exec-7.1 {multiple I/O redirections} { exec << "command input" > gorp.file2 $tcltest cat < gorp.file exec $tcltest cat gorp.file2 @@ -282,6 +282,12 @@ test exec-8.1 {long input and output} { exec $tcltest cat << $a } $a +# More than 20 arguments to exec. + +test exec-8.1 {long input and output} { + exec $tcltest echo 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 +} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23} + # Commands that return errors. test exec-9.1 {commands returning errors} { @@ -309,6 +315,16 @@ test exec-9.7 {commands returning errors} { | $tcltest sh -c "echo error msg 1>&2"} msg] $msg } {1 {error msg error msg}} +test exec-9.8 {commands returning errors} { + set f [open err w] + puts $f { + puts stdout out + puts stderr err + } + close $f + list [catch {exec $tcltest err} msg] $msg +} {1 {out +err}} # Errors in executing the Tcl command, as opposed to errors in the # processes that are invoked. @@ -555,3 +571,6 @@ test exec-17.1 { inheriting standard I/O } { file delete script gorp.file gorp.file2 file delete echo cat wc sh sleep exit +file delete err + +return diff --git a/tests/execute.test b/tests/execute.test index 81fde45..092dcfd 100644 --- a/tests/execute.test +++ b/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.5 97/08/12 11:16:31 +# SCCS: @(#) execute.test 1.6 97/12/08 15:07:24 if {[string compare test [info procs test]] == 1} then {source defs} @@ -111,4 +111,4 @@ catch {rename { } ""} catch {unset x} catch {unset y} catch {unset msg} -concat {} +return diff --git a/tests/expr-old.test b/tests/expr-old.test index 8fb8ad9..98251be 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -2,9 +2,9 @@ # # This file contains the original set of tests for Tcl's expr command. # Since the expr command is now compiled, a new set of tests covering -# the new implementation is in the file "expr.test". Sourcing this file -# into Tcl runs the tests and generates output for errors. -# No output means no errors were found. +# the new implementation are in the files "parseExpr.test and +# "compExpr.test". Sourcing this file into Tcl runs the tests and generates +# output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -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.63 97/10/31 17:23:24 +# SCCS: @(#) expr-old.test 1.68 97/12/16 13:32:24 if {[string compare test [info procs test]] == 1} then {source defs} @@ -402,7 +402,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} {expr 2.0e15} 2e+15 +test expr-old-25.19 {type conversions} {eformat} {expr 2.0e15} 2e+15 test expr-old-25.20 {type conversions} {expr 10.0} 10.0 # Various error conditions. @@ -456,13 +456,13 @@ test expr-old-26.15 {error conditions} { } {1 {syntax error in expression "a@b"}} test expr-old-26.16 {error conditions} { list [catch {expr a[b} msg] $msg -} {1 {missing close-bracket or close-brace}} +} {1 {missing close-bracket}} test expr-old-26.17 {error conditions} { list [catch {expr a`b} msg] $msg } {1 {syntax error in expression "a`b"}} test expr-old-26.18 {error conditions} { list [catch {expr \"a\"\{b} msg] $msg -} {1 {missing close-brace}} +} {1 syntax\ error\ in\ expression\ \"\"a\"\{b\"} test expr-old-26.19 {error conditions} { list [catch {expr a} msg] $msg } {1 {syntax error in expression "a"}} @@ -777,10 +777,10 @@ test expr-old-32.45 {math functions in expressions} { } {1} test expr-old-32.46 {math functions in expressions} { list [catch {expr rand(24)} msg] $msg -} {1 {syntax error in expression "rand(24)"}} +} {1 {too many arguments for math function}} test expr-old-32.47 {math functions in expressions} { list [catch {expr srand()} msg] $msg -} {1 {syntax error in expression "srand()"}} +} {1 {too few arguments for math function}} test expr-old-32.48 {math functions in expressions} { list [catch {expr srand(3.79)} msg] $msg } {1 {can't use floating-point value as argument to srand}} @@ -862,7 +862,7 @@ test expr-old-34.16 {errors in math functions} { if $gotT1 { test expr-old-34.17 {errors in math functions} { list [catch {expr T1(4)} msg] $msg - } {1 {syntax error in expression "T1(4)"}} + } {1 {too many arguments for math function}} } test expr-old-36.1 {ExprLooksLikeInt procedure} { @@ -871,7 +871,7 @@ test expr-old-36.1 {ExprLooksLikeInt procedure} { test expr-old-36.2 {ExprLooksLikeInt procedure} { set x 0289 list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use floating-point value as operand of "+"}} test expr-old-36.3 {ExprLooksLikeInt procedure} { list [catch {expr 0289.1} msg] $msg } {0 289.1} @@ -918,3 +918,5 @@ if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} { puts "call Intel customer service immediately at 1-800-628-8686" puts "to request a replacement processor." } + +return diff --git a/tests/fCmd.test b/tests/fCmd.test index ae2b8b0..139ecab 100644 --- a/tests/fCmd.test +++ b/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.33 97/11/03 15:58:08 +# SCCS: @(#) fCmd.test 1.37 98/01/18 15:47:02 # if {[string compare test [info procs test]] == 1} then {source defs} @@ -71,8 +71,8 @@ proc cleanup {args} { } foreach file $x { if {[catch {file delete -force -- $file}]} { - openup $file - file delete -force -- $file + catch {openup $file} + catch {file delete -force -- $file} } } } @@ -2057,9 +2057,6 @@ test fCmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly} { set result } {1} -test fCmd-27.1 {TclFileAttrsCmd - wrong # args} { - list [catch {file attributes a b c d} msg] $msg -} {1 {wrong # args: must be "file attributes name ?option? ?value? ?option value? ..."}} test fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} { testsetplatform unix list [catch {file attributes ~_bad_user} msg] $msg [testsetplatform $platform] @@ -2100,3 +2097,4 @@ test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {tclGroup} { } {0 {} {}} cleanup +return diff --git a/tests/fileName.test b/tests/fileName.test index e0f7260..585a41b 100644 --- a/tests/fileName.test +++ b/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.31 97/08/19 18:45:07 +# SCCS: @(#) fileName.test 1.34 98/01/07 16:23:09 if {[string compare test [info procs test]] == 1} then {source defs} @@ -1446,4 +1446,4 @@ set env(HOME) $oldhome testsetplatform $platform catch {unset oldhome platform temp result} -concat "" +return diff --git a/tests/for-old.test b/tests/for-old.test index 354f3d68..29330ea 100644 --- a/tests/for-old.test +++ b/tests/for-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: @(#) for-old.test 1.14 97/01/13 13:42:18 +# SCCS: @(#) for-old.test 1.15 97/12/08 15:06:07 if {[string compare test [info procs test]] == 1} then {source defs} @@ -64,3 +64,5 @@ test for-old-1.9 {for tests} { } set a } {1 2 3} + +return diff --git a/tests/for.test b/tests/for.test index aa918ec..f6d4324 100644 --- a/tests/for.test +++ b/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.10 97/07/02 16:40:59 +# SCCS: @(#) for.test 1.13 97/12/08 15:02:58 if {[string compare test [info procs test]] == 1} then {source defs} @@ -582,11 +582,135 @@ test for-4.1 {break must reset the interp result} { set j } {} -# Check "for" and computed command names. - -test for-5.1 {for and computed command names} { - set j 0 +# Basic "for" operation with computed command names. +test for-5.1 {for cmd with computed command names: missing initial command} { set z for - $z {set i 0} {$i<10} {incr i} {set j $i} - set j -} 9 + list [catch {$z} msg] $msg +} {1 {wrong # args: should be "for start test next command"}} +test for-5.2 {for cmd with computed command names: error in initial command} { + set z for + list [catch {$z {set}} msg] $msg $errorInfo +} {1 {wrong # args: should be "for start test next command"} {wrong # args: should be "for start test next command" + while executing +"$z {set}"}} +test for-5.3 {for cmd with computed command names: missing test expression} { + set z for + catch {$z {set i 0}} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-5.4 {for cmd with computed command names: error in test expression} { + set z for + catch {$z {set i 0} {$i<}} msg + set errorInfo +} {wrong # args: should be "for start test next command" + while executing +"$z {set i 0} {$i<}"} +test for-5.5 {for cmd with computed command names: test expression is enclosed in quotes} { + set z for + set i 0 + $z {} "$i > 5" {incr i} {} +} {} +test for-5.6 {for cmd with computed command names: missing "next" command} { + set z for + catch {$z {set i 0} {$i < 5}} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-5.7 {for cmd with computed command names: missing command body} { + set z for + catch {$z {set i 0} {$i < 5} {incr i}} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-5.8 {for cmd with computed command names: error executing command body} { + set z for + catch {$z {set i 0} {$i < 5} {incr i} {set}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("for" body line 1) + invoked from within +"$z {set i 0} {$i < 5} {incr i} {set}"} +test for-5.9 {for cmd with computed command names: simple command body} { + set z for + set a {} + $z {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 break + set a [concat $a $i] + } + set a +} {1 2 3} +test for-5.10 {for cmd with computed command names: command body in quotes} { + set z for + set a {} + $z {set i 1} {$i<6} {set i [expr $i+1]} "append a x" + set a +} {xxxxx} +test for-5.11 {for cmd with computed command names: computed command body} { + set z for + catch {unset x1} + catch {unset bb} + catch {unset x2} + set x1 {append a x1; } + set bb {break} + set x2 {; append a x2} + set a {} + $z {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2 + set a +} {x1} +test for-5.12 {for cmd with computed command names: error in "next" command} { + set z for + catch {$z {set i 0} {$i < 5} {set} {set j 4}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("for" loop-end command) + invoked from within +"$z {set i 0} {$i < 5} {set} {set j 4}"} +test for-5.13 {for cmd with computed command names: long command body} { + set z for + set a {} + $z {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + } + set a +} {1 2 3} +test for-5.14 {for cmd with computed command names: for command result} { + set z for + set a [$z {set i 0} {$i < 5} {incr i} {}] + set a +} {} +test for-5.15 {for cmd with computed command names: for command result} { + set z for + set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}] + set a +} {} + +return diff --git a/tests/foreach.test b/tests/foreach.test index f87dd39..ef29d7c 100644 --- a/tests/foreach.test +++ b/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.8 97/08/12 18:19:27 +# SCCS: @(#) foreach.test 1.9 97/12/08 15:06:20 if {[string compare test [info procs test]] == 1} then {source defs} @@ -210,3 +210,5 @@ test foreach-5.4 {break tests} { catch {unset a} catch {unset x} + +return diff --git a/tests/format.test b/tests/format.test index 758825b..6a67fb4 100644 --- a/tests/format.test +++ b/tests/format.test @@ -5,14 +5,16 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1994-1998 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: @(#) format.test 1.29 97/09/03 15:51:02 +# SCCS: @(#) format.test 1.31 98/01/16 16:21:58 -if {[string compare test [info procs test]] == 1} then {source defs} +if {[info commands test] != "test"} { + source defs +} # The following code is needed because some versions of SCO Unix have # a round-off error in sprintf which would cause some of the tests to @@ -79,290 +81,297 @@ test format-2.4 {string formatting} { format "%s %s %% %c %s" abcd {This is a very long test string.} 120 x } {abcd This is a very long test string. % x x} -test format-3.1 {e and f formats} { +test format-3.1 {Tcl_FormatObjCmd: character formatting} { + format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 65 65 65 65 65 65 3 65 -4 65 +} "|A|A|A|A|A | A| A|A |" +test format-3.2 {Tcl_FormatObjCmd: international character formatting} { + format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 0xa2 0x4e4e 0x25a 0xc3 0xff08 0 3 0x6575 -4 0x4e4f +} "|\ua2|\u4e4e|\u25a|\uc3|\uff08 | \0| \u6575|\u4e4f |" + +test format-4.1 {e and f formats} {eformat} { format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053 } {3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} -test format-3.2 {e and f formats} { +test format-4.2 {e and f formats} {eformat} { format "%20e %20e %20e %20e" 34.2e12 68.514 -.125 -16000. .000053 } { 3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} if {!$roundOffBug} { - test format-3.3 {e and f formats} { + test format-4.3 {e and f formats} {eformat} { format "%.1e %.1e %.1e %.1e" 34.2e12 68.514 -.126 -16000. .000053 } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04} - test format-3.4 {e and f formats} { + test format-4.4 {e and f formats} {eformat} { format "%020e %020e %020e %020e" 34.2e12 68.514 -.126 -16000. .000053 } {000000003.420000e+13 000000006.851400e+01 -00000001.260000e-01 -00000001.600000e+04} - test format-3.5 {e and f formats} { + test format-4.5 {e and f formats} {eformat} { format "%7.1e %7.1e %7.1e %7.1e" 34.2e12 68.514 -.126 -16000. .000053 } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04} - test format-3.6 {e and f formats} { + test format-4.6 {e and f formats} { format "%f %f %f %f" 34.2e12 68.514 -.125 -16000. .000053 } {34200000000000.000000 68.514000 -0.125000 -16000.000000} } -test format-3.7 {e and f formats} {nonPortable} { +test format-4.7 {e and f formats} {nonPortable} { format "%.4f %.4f %.4f %.4f %.4f" 34.2e12 68.514 -.125 -16000. .000053 } {34200000000000.0000 68.5140 -0.1250 -16000.0000 0.0001} -test format-3.8 {e and f formats} { +test format-4.8 {e and f formats} {eformat} { format "%.4e %.5e %.6e" -9.99996 -9.99996 9.99996 } {-1.0000e+01 -9.99996e+00 9.999960e+00} -test format-3.9 {e and f formats} { +test format-4.9 {e and f formats} { format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996 } {-10.0000 -9.99996 9.999960} -test format-3.10 {e and f formats} { +test format-4.10 {e and f formats} { format "%20f %-20f %020f" -9.99996 -9.99996 9.99996 } { -9.999960 -9.999960 0000000000009.999960} -test format-3.11 {e and f formats} { +test format-4.11 {e and f formats} { format "%-020f %020f" -9.99996 -9.99996 9.99996 } {-9.999960 -000000000009.999960} -test format-3.12 {e and f formats} { +test format-4.12 {e and f formats} {eformat} { format "%.0e %#.0e" -9.99996 -9.99996 9.99996 } {-1e+01 -1.e+01} -test format-3.13 {e and f formats} { +test format-4.13 {e and f formats} { format "%.0f %#.0f" -9.99996 -9.99996 9.99996 } {-10 -10.} -test format-3.14 {e and f formats} { +test format-4.14 {e and f formats} { format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996 } {-10.0000 -9.99996 9.999960} -test format-3.15 {e and f formats} { +test format-4.15 {e and f formats} { format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001 } { 1 1 1 1} -test format-3.16 {e and f formats} { +test format-4.16 {e and f formats} { format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001 } {0.0 0.1 0.0 0.0} -test format-4.1 {g-format} { +test format-5.1 {g-format} {eformat} { format "%.3g" 12341.0 } {1.23e+04} -test format-4.2 {g-format} { +test format-5.2 {g-format} {eformat} { format "%.3G" 1234.12345 } {1.23E+03} -test format-4.3 {g-format} { +test format-5.3 {g-format} { format "%.3g" 123.412345 } {123} -test format-4.4 {g-format} { +test format-5.4 {g-format} { format "%.3g" 12.3412345 } {12.3} -test format-4.5 {g-format} { +test format-5.5 {g-format} { format "%.3g" 1.23412345 } {1.23} -test format-4.6 {g-format} { +test format-5.6 {g-format} { format "%.3g" 1.23412345 } {1.23} -test format-4.7 {g-format} { +test format-5.7 {g-format} { format "%.3g" .123412345 } {0.123} -test format-4.8 {g-format} { +test format-5.8 {g-format} { format "%.3g" .012341 } {0.0123} -test format-4.9 {g-format} { +test format-5.9 {g-format} { format "%.3g" .0012341 } {0.00123} -test format-4.10 {g-format} { +test format-5.10 {g-format} { format "%.3g" .00012341 } {0.000123} -test format-4.11 {g-format} { +test format-5.11 {g-format} {eformat} { format "%.3g" .00001234 } {1.23e-05} -test format-4.12 {g-format} { +test format-5.12 {g-format} {eformat} { format "%.4g" 9999.6 } {1e+04} -test format-4.13 {g-format} { +test format-5.13 {g-format} { format "%.4g" 999.96 } {1000} -test format-4.14 {g-format} { +test format-5.14 {g-format} { format "%.3g" 1.0 } {1} -test format-4.15 {g-format} { +test format-5.15 {g-format} { format "%.3g" .1 } {0.1} -test format-4.16 {g-format} { +test format-5.16 {g-format} { format "%.3g" .01 } {0.01} -test format-4.17 {g-format} { +test format-5.17 {g-format} { format "%.3g" .001 } {0.001} -test format-4.18 {g-format} { +test format-5.18 {g-format} {eformat} { format "%.3g" .00001 } {1e-05} -test format-4.19 {g-format} { +test format-5.19 {g-format} {eformat} { format "%#.3g" 1234.0 } {1.23e+03} -test format-4.20 {g-format} { +test format-5.20 {g-format} {eformat} { format "%#.3G" 9999.5 } {1.00E+04} -test format-5.1 {floating-point zeroes} { +test format-6.1 {floating-point zeroes} {eformat} { format "%e %f %g" 0.0 0.0 0.0 0.0 } {0.000000e+00 0.000000 0} -test format-5.2 {floating-point zeroes} { +test format-6.2 {floating-point zeroes} {eformat} { format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0 } {0.0000e+00 0.0000 0} -test format-5.3 {floating-point zeroes} { +test format-6.3 {floating-point zeroes} {eformat} { format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0 } {0.0000e+00 0.0000 0.000} -test format-5.4 {floating-point zeroes} { +test format-6.4 {floating-point zeroes} {eformat} { format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0 } {0e+00 0 0} -test format-5.5 {floating-point zeroes} { +test format-6.5 {floating-point zeroes} {eformat} { format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0 } {0.e+00 0. 0.} -test format-5.6 {floating-point zeroes} { +test format-6.6 {floating-point zeroes} { format "%3.0f %3.0f %3.0f %3.0f" 0.0 0.0 0.0 0.0 } { 0 0 0 0} -test format-5.7 {floating-point zeroes} { +test format-6.7 {floating-point zeroes} { format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001 } { 1 1 1 1} -test format-5.8 {floating-point zeroes} { +test format-6.8 {floating-point zeroes} { format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001 } {0.0 0.1 0.0 0.0} -test format-6.1 {various syntax features} { +test format-7.1 {various syntax features} { format "%*.*f" 12 3 12.345678901 } { 12.346} -test format-6.2 {various syntax features} { +test format-7.2 {various syntax features} { format "%0*.*f" 12 3 12.345678901 } {00000012.346} -test format-6.3 {various syntax features} { +test format-7.3 {various syntax features} { format "\*\t\\n" } {* \n} -test format-7.1 {error conditions} { +test format-8.1 {error conditions} { catch format } 1 -test format-7.2 {error conditions} { +test format-8.2 {error conditions} { catch format msg set msg } {wrong # args: should be "format formatString ?arg arg ...?"} -test format-7.3 {error conditions} { +test format-8.3 {error conditions} { catch {format %*d} } 1 -test format-7.4 {error conditions} { +test format-8.4 {error conditions} { catch {format %*d} msg set msg } {not enough arguments for all format specifiers} -test format-7.5 {error conditions} { +test format-8.5 {error conditions} { catch {format %*.*f 12} } 1 -test format-7.6 {error conditions} { +test format-8.6 {error conditions} { catch {format %*.*f 12} msg set msg } {not enough arguments for all format specifiers} -test format-7.7 {error conditions} { +test format-8.7 {error conditions} { catch {format %*.*f 12 3} } 1 -test format-7.8 {error conditions} { +test format-8.8 {error conditions} { catch {format %*.*f 12 3} msg set msg } {not enough arguments for all format specifiers} -test format-7.9 {error conditions} { +test format-8.9 {error conditions} { list [catch {format %*d x 3} msg] $msg } {1 {expected integer but got "x"}} -test format-7.10 {error conditions} { +test format-8.10 {error conditions} { list [catch {format %*.*f 2 xyz 3} msg] $msg } {1 {expected integer but got "xyz"}} -test format-7.11 {error conditions} { +test format-8.11 {error conditions} { catch {format %d 2a} } 1 -test format-7.12 {error conditions} { +test format-8.12 {error conditions} { catch {format %d 2a} msg set msg } {expected integer but got "2a"} -test format-7.13 {error conditions} { +test format-8.13 {error conditions} { catch {format %c 2x} } 1 -test format-7.14 {error conditions} { +test format-8.14 {error conditions} { catch {format %c 2x} msg set msg } {expected integer but got "2x"} -test format-7.15 {error conditions} { +test format-8.15 {error conditions} { catch {format %f 2.1z} } 1 -test format-7.16 {error conditions} { +test format-8.16 {error conditions} { catch {format %f 2.1z} msg set msg } {expected floating-point number but got "2.1z"} -test format-7.17 {error conditions} { +test format-8.17 {error conditions} { catch {format ab%} } 1 -test format-7.18 {error conditions} { +test format-8.18 {error conditions} { catch {format ab% 12} msg set msg } {format string ended in middle of field specifier} -test format-7.19 {error conditions} { +test format-8.19 {error conditions} { catch {format %q x} } 1 -test format-7.20 {error conditions} { +test format-8.20 {error conditions} { catch {format %q x} msg set msg } {bad field specifier "q"} -test format-7.21 {error conditions} { +test format-8.21 {error conditions} { catch {format %d} } 1 -test format-7.22 {error conditions} { +test format-8.22 {error conditions} { catch {format %d} msg set msg } {not enough arguments for all format specifiers} -test format-7.23 {error conditions} { +test format-8.23 {error conditions} { catch {format "%d %d" 24 xyz} msg set msg } {expected integer but got "xyz"} -test format-8.1 {long result} { +test format-9.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} $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} { +test format-10.1 {"h" format specifier} {nonPortable} { format %hd 0xffff } -1 -test format-9.2 {"h" format specifier} {nonPortable} { +test format-10.2 {"h" format specifier} {nonPortable} { format %hx 0x10fff } fff -test format-9.3 {"h" format specifier} {nonPortable} { +test format-10.3 {"h" format specifier} {nonPortable} { format %hd 0x10000 } 0 -test format-10.1 {XPG3 %$n specifiers} { +test format-11.1 {XPG3 %$n specifiers} { format {%2$d %1$d} 4 5 } {5 4} -test format-10.2 {XPG3 %$n specifiers} { +test format-11.2 {XPG3 %$n specifiers} { format {%2$d %1$d %1$d %3$d} 4 5 6 } {5 4 4 6} -test format-10.3 {XPG3 %$n specifiers} { +test format-11.3 {XPG3 %$n specifiers} { list [catch {format {%2$d %3$d} 4 5} msg] $msg } {1 {"%n$" argument index out of range}} -test format-10.4 {XPG3 %$n specifiers} { +test format-11.4 {XPG3 %$n specifiers} { list [catch {format {%2$d %0$d} 4 5 6} msg] $msg } {1 {"%n$" argument index out of range}} -test format-10.5 {XPG3 %$n specifiers} { +test format-11.5 {XPG3 %$n specifiers} { list [catch {format {%d %1$d} 4 5 6} msg] $msg } {1 {cannot mix "%" and "%n$" conversion specifiers}} -test format-10.6 {XPG3 %$n specifiers} { +test format-11.6 {XPG3 %$n specifiers} { list [catch {format {%2$d %d} 4 5 6} msg] $msg } {1 {cannot mix "%" and "%n$" conversion specifiers}} -test format-10.7 {XPG3 %$n specifiers} { +test format-11.7 {XPG3 %$n specifiers} { list [catch {format {%2$d %3d} 4 5 6} msg] $msg } {1 {cannot mix "%" and "%n$" conversion specifiers}} -test format-10.8 {XPG3 %$n specifiers} { +test format-11.8 {XPG3 %$n specifiers} { format {%2$*d %3$d} 1 10 4 } { 4 4} -test format-10.9 {XPG3 %$n specifiers} { +test format-11.9 {XPG3 %$n specifiers} { format {%2$.*s %4$d} 1 5 abcdefghijklmnop 44 } {abcde 44} -test format-10.10 {XPG3 %$n specifiers} { +test format-11.10 {XPG3 %$n specifiers} { list [catch {format {%2$*d} 4} msg] $msg } {1 {"%n$" argument index out of range}} -test format-10.11 {XPG3 %$n specifiers} { +test format-11.11 {XPG3 %$n specifiers} { list [catch {format {%2$*d} 4 5} msg] $msg } {1 {"%n$" argument index out of range}} -test format-10.12 {XPG3 %$n specifiers} { +test format-11.12 {XPG3 %$n specifiers} { list [catch {format {%2$*d} 4 5 6} msg] $msg } {0 { 6}} -test format-11.1 {negative width specifiers} { +test format-12.1 {negative width specifiers} { format "%*d" -47 25 -} {25} -test format-12.1 {tcl_precision fuzzy comparison} { +} {25 } +test format-13.1 {tcl_precision fuzzy comparison} { catch {unset a} catch {unset b} catch {unset c} @@ -373,7 +382,7 @@ test format-12.1 {tcl_precision fuzzy comparison} { 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} { +test format-13.2 {tcl_precision fuzzy comparison} { catch {unset a} catch {unset b} catch {unset c} @@ -384,7 +393,7 @@ test format-12.2 {tcl_precision fuzzy comparison} { 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} { +test format-13.3 {tcl_precision fuzzy comparison} { catch {unset a} catch {unset b} catch {unset c} @@ -393,7 +402,7 @@ test format-12.3 {tcl_precision fuzzy comparison} { 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} { +test format-13.4 {tcl_precision fuzzy comparison} { catch {unset a} catch {unset b} catch {unset c} @@ -402,7 +411,7 @@ test format-12.4 {tcl_precision fuzzy comparison} { 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} { +test format-13.5 {tcl_precision fuzzy comparison} { catch {unset a} catch {unset b} catch {unset c} @@ -411,10 +420,10 @@ test format-12.5 {tcl_precision fuzzy comparison} { set c [expr $a + $b] format {%0.10f %0.12f %0.15f} $c $c $c } {1.4444444444 1.444444444444 1.444444444443990} -test format-13.1 {testing MAX_FLOAT_SIZE for 0 and 1} { +test format-14.1 {testing MAX_FLOAT_SIZE for 0 and 1} { format {%s} "" } {} -test format-13.2 {testing MAX_FLOAT_SIZE for 0 and 1} { +test format-14.2 {testing MAX_FLOAT_SIZE for 0 and 1} { format {%s} "a" } {a} @@ -424,7 +433,7 @@ for {set i 0} {$i < 290} {incr i} { append b $a } for {set i 290} {$i < 400} {incr i} { - test format-14.[expr $i -290] {testing MAX_FLOAT_SIZE} { + test format-15.[expr $i -290] {testing MAX_FLOAT_SIZE} { format {%s} $b } $b append b "x" diff --git a/tests/get.test b/tests/get.test index 5155b95..8ba8be0 100644 --- a/tests/get.test +++ b/tests/get.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) get.test 1.7 97/10/31 17:23:00 +# SCCS: @(#) get.test 1.9 97/12/19 11:57:36 if {[string compare test [info procs test]] == 1} then {source defs} @@ -39,39 +39,39 @@ test get-1.6 {Tcl_GetInt procedure} { } {1 {expected integer but got "16 x"}} # The following tests are non-portable because they depend on -# word size. 18446744073709551614 +# word size. if {0x80000000 > 0} { - test get-1.7 {Tcl_GetInt procedure} {nonPortable unixOnly} { + test get-1.7 {Tcl_GetInt procedure} { set x 44 list [catch {incr x 18446744073709551616} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} - test get-1.8 {Tcl_GetInt procedure} {nonPortable} { + test get-1.8 {Tcl_GetInt procedure} { set x 0 list [catch {incr x 18446744073709551614} msg] $msg } {0 -2} - test get-1.9 {Tcl_GetInt procedure} {nonPortable} { + test get-1.9 {Tcl_GetInt procedure} { set x 0 list [catch {incr x +18446744073709551614} msg] $msg } {0 -2} - test get-1.10 {Tcl_GetInt procedure} {nonPortable} { + test get-1.10 {Tcl_GetInt procedure} { set x 0 list [catch {incr x -18446744073709551614} msg] $msg } {0 2} } else { - test get-1.7 {Tcl_GetInt procedure} {nonPortable unixOnly} { + test get-1.7 {Tcl_GetInt procedure} { set x 44 list [catch {incr x 4294967296} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} - test get-1.8 {Tcl_GetInt procedure} {nonPortable} { + test get-1.8 {Tcl_GetInt procedure} { set x 0 list [catch {incr x 4294967294} msg] $msg } {0 -2} - test get-1.9 {Tcl_GetInt procedure} {nonPortable} { + test get-1.9 {Tcl_GetInt procedure} { set x 0 list [catch {incr x +4294967294} msg] $msg } {0 -2} - test get-1.10 {Tcl_GetInt procedure} {nonPortable} { + test get-1.10 {Tcl_GetInt procedure} { set x 0 list [catch {incr x -4294967294} msg] $msg } {0 2} @@ -89,3 +89,5 @@ test get-2.3 {Tcl_GetInt procedure} { test get-2.4 {Tcl_GetInt procedure} {nonPortable} { list [catch {format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001} msg] $msg $errorCode } {1 {floating-point value too small to represent} {ARITH UNDERFLOW {floating-point value too small to represent}}} + +return diff --git a/tests/history.test b/tests/history.test index 498fb2e..317fc06 100644 --- a/tests/history.test +++ b/tests/history.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) history.test 1.15 97/08/13 14:37:10 +# SCCS: @(#) history.test 1.16 97/12/08 15:03:07 if {[catch {history}]} { puts stdout "This version of Tcl was built without the history command;\n" @@ -209,3 +209,4 @@ test history-9.2 {miscellaneous} { set msg } {bad option "gorp": must be add, change, clear, event, info, keep, nextid, or redo} +return diff --git a/tests/http.test b/tests/http.test index 2770e13..be43f21 100644 --- a/tests/http.test +++ b/tests/http.test @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # -# SCCS: @(#) http2.test 1.8 97/08/13 11:16:50 +# SCCS: @(#) http.test 1.11 98/02/20 14:51:59 if {[string compare test [info procs test]] == 1} then {source defs} @@ -29,152 +29,33 @@ if {[catch {package require http 2.0}]} { } } -############### The httpd_ procedures implement a stub http server. ######## -proc httpd_init {{port 8015}} { - socket -server httpdAccept $port -} -proc httpd_log {args} { - global httpLog - if {[info exists httpLog] && $httpLog} { - puts stderr "httpd: [join $args { }]" - } -} -array set httpdErrors { - 204 {No Content} - 400 {Bad Request} - 404 {Not Found} - 503 {Service Unavailable} - 504 {Service Temporarily Unavailable} - } - -proc httpdError {sock code args} { - global httpdErrors - puts $sock "$code $httpdErrors($code)" - httpd_log "error: [join $args { }]" -} -proc httpdAccept {newsock ipaddr port} { - global httpd - upvar #0 httpd$newsock data - - fconfigure $newsock -blocking 0 -translation {auto crlf} - httpd_log $newsock Connect $ipaddr $port - set data(ipaddr) $ipaddr - fileevent $newsock readable [list httpdRead $newsock] -} - -# read data from a client request - -proc httpdRead { sock } { - upvar #0 httpd$sock data - - set readCount [gets $sock line] - if {![info exists data(state)]} { - if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \ - $line x data(proto) data(url) data(query)] { - set data(state) mime - httpd_log $sock Query $line - } else { - httpdError $sock 400 - httpd_log $sock Error "bad first line:$line" - httpdSockDone $sock - } - return - } - - # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1 - - set state [string compare $readCount 0],$data(state),$data(proto) - httpd_log $sock $state - switch -- $state { - -1,mime,HEAD - - -1,mime,GET - - -1,mime,POST { - # gets would block - return - } - 0,mime,HEAD - - 0,mime,GET - - 0,query,POST { httpdRespond $sock } - 0,mime,POST { set data(state) query } - 1,mime,HEAD - - 1,mime,POST - - 1,mime,GET { - if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] { - set data(mime,[string tolower $key]) $value - } - } - 1,query,POST { - append data(query) $line - httpdRespond $sock - } - default { - if [eof $sock] { - httpd_log $sock Error "unexpected eof on <$data(url)> request" - } else { - httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>" - } - httpdError $sock 404 - httpdSockDone $sock - } - } -} -proc httpdSockDone { sock } { -upvar #0 httpd$sock data - unset data - close $sock -} - -# Respond to the query. +set port 8010 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" +if {[info commands testthread] == "testthread" && [file exists httpd]} { + set httpthread [testthread create { + source httpd + testthread wait + }] + testthread send $httpthread [list set port $port] + testthread send $httpthread [list set bindata $bindata] + testthread send $httpthread {httpd_init $port} + puts "Running httpd in thread $httpthread" +} else { + if ![file exists httpd] { + puts stderr "Cannot read httpd script, http test skipped" + unset port + return } - 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 + source httpd + if [catch {httpd_init $port} listen] { + puts stderr "Cannot start http server, http test skipped" + unset port + return } - 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 @@ -406,4 +287,10 @@ test http-6.1 {http::ProxyRequired} { unset url unset port -close $listen +if {[info exists httpthread]} { + testthread send -async $httpthread { + testthread exit + } +} else { + close $listen +} diff --git a/tests/httpd b/tests/httpd new file mode 100644 index 0000000..1531964 --- /dev/null +++ b/tests/httpd @@ -0,0 +1,148 @@ +# +# The httpd_ procedures implement a stub http server. +# +# Copyright (c) 1997-1998 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: @(#) httpd 1.2 98/02/20 14:51:59 + +proc httpd_init {{port 8015}} { + socket -server httpdAccept $port +} +proc httpd_log {args} { + global httpLog + if {[info exists httpLog] && $httpLog} { + puts stderr "httpd: [join $args { }]" + } +} +array set httpdErrors { + 204 {No Content} + 400 {Bad Request} + 404 {Not Found} + 503 {Service Unavailable} + 504 {Service Temporarily Unavailable} + } + +proc httpdError {sock code args} { + global httpdErrors + puts $sock "$code $httpdErrors($code)" + httpd_log "error: [join $args { }]" +} +proc httpdAccept {newsock ipaddr port} { + global httpd + upvar #0 httpd$newsock data + + fconfigure $newsock -blocking 0 -translation {auto crlf} + httpd_log $newsock Connect $ipaddr $port + set data(ipaddr) $ipaddr + fileevent $newsock readable [list httpdRead $newsock] +} + +# read data from a client request + +proc httpdRead { sock } { + upvar #0 httpd$sock data + + set readCount [gets $sock line] + if {![info exists data(state)]} { + if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \ + $line x data(proto) data(url) data(query)] { + set data(state) mime + httpd_log $sock Query $line + } else { + httpdError $sock 400 + httpd_log $sock Error "bad first line:$line" + httpdSockDone $sock + } + return + } + + # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1 + + set state [string compare $readCount 0],$data(state),$data(proto) + httpd_log $sock $state + switch -- $state { + -1,mime,HEAD - + -1,mime,GET - + -1,mime,POST { + # gets would block + return + } + 0,mime,HEAD - + 0,mime,GET - + 0,query,POST { httpdRespond $sock } + 0,mime,POST { set data(state) query } + 1,mime,HEAD - + 1,mime,POST - + 1,mime,GET { + if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] { + set data(mime,[string tolower $key]) $value + } + } + 1,query,POST { + append data(query) $line + httpdRespond $sock + } + default { + if [eof $sock] { + httpd_log $sock Error "unexpected eof on <$data(url)> request" + } else { + httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>" + } + httpdError $sock 404 + httpdSockDone $sock + } + } +} +proc httpdSockDone { sock } { +upvar #0 httpd$sock data + unset data + close $sock +} + +# Respond to the query. + +proc httpdRespond { sock } { + global httpd 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 +} + + diff --git a/tests/if-old.test b/tests/if-old.test index abade28..d4c3587 100644 --- a/tests/if-old.test +++ b/tests/if-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: @(#) if-old.test 1.10 96/10/22 11:33:06 +# SCCS: @(#) if-old.test 1.11 97/12/08 15:06:04 if {[string compare test [info procs test]] == 1} then {source defs} @@ -154,3 +154,5 @@ test if-old-4.10 {error conditions} { test if-old-4.11 {error conditions} { list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg } {1 {error in else clause}} + +return diff --git a/tests/if.test b/tests/if.test index 03b8bcd..79d4bbe 100644 --- a/tests/if.test +++ b/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.9 97/07/02 16:40:58 +# SCCS: @(#) if.test 1.11 97/12/08 15:02:55 if {[string compare test [info procs test]] == 1} then {source defs} @@ -495,11 +495,511 @@ test if-4.5 {TclCompileIfCmd: return value} { # Check "if" and computed command names. -test if-5.1 {if and computed command names} { - set i 0 +catch {unset a} +test if-5.1 {if cmd with computed command names: missing if/elseif test} { set z if - $z 1 { - set i 1 - } - set i + list [catch {$z} msg] $msg +} {1 {wrong # args: no expression after "if" argument}} +test if-5.2 {if cmd with computed command names: error in if/elseif test} { + set z if + list [catch {$z {[error "error in condition"]} foo} msg] $msg +} {1 {error in condition}} +test if-5.3 {if cmd with computed command names: error in if/elseif test} { + set z if + list [catch {$z {1+}} msg] $msg $errorInfo +} {1 {syntax error in expression "1+"} {syntax error in expression "1+" + while executing +"$z {1+}"}} +test if-5.4 {if cmd with computed command names: if/elseif test in braces} { + set z if + set a {} + $z {1<2} {set a 1} + set a +} {1} +test if-5.5 {if cmd with computed command names: if/elseif test not in braces} { + set z if + set a {} + $z 1<2 {set a 1} + set a +} {1} +test if-5.6 {if cmd with computed command names: multiline test expr} { + set z if + set a {} + $z {($tcl_platform(platform) != "foobar1") && \ + ($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4} + set a +} 3 +test if-5.7 {if cmd with computed command names: "then" after if/elseif test} { + set z if + set a {} + $z 4>3 then {set a 1} + set a +} {1} +test if-5.8 {if cmd with computed command names: keyword other than "then" after if/elseif test} { + set z if + set a {} + catch {$z 1<2 therefore {set a 1}} msg + set msg +} {invalid command name "therefore"} +test if-5.9 {if cmd with computed command names: missing "then" body} { + set z if + set a {} + catch {$z 1<2 then} msg + set msg +} {wrong # args: no script following "then" argument} +test if-5.10 {if cmd with computed command names: error in "then" body} { + set z if + set a {} + list [catch {$z {$a!="xxx"} then {set}} msg] $msg $errorInfo +} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + invoked from within +"$z {$a!="xxx"} then {set}"}} +test if-5.11 {if cmd with computed command names: error in "then" body} { + set z if + list [catch {$z 2 then {[error "error in then clause"]}} msg] $msg +} {1 {error in then clause}} +test if-5.12 {if cmd with computed command names: "then" body in quotes} { + set z if + set a {} + $z 27>17 "append a x" + set a +} {x} +test if-5.13 {if cmd with computed command names: computed "then" body} { + set z if + catch {unset x1} + catch {unset x2} + set a {} + set x1 {append a x1} + set x2 {; append a x2} + set a {} + $z 1 $x1$x2 + set a +} {x1x2} +test if-5.14 {if cmd with computed command names: taking proper branch} { + set z if + set a {} + $z 1<2 {set a 1} + set a } 1 +test if-5.15 {if cmd with computed command names: taking proper branch} { + set z if + set a {} + $z 1>2 {set a 1} + set a +} {} +test if-5.16 {if cmd with computed command names: test jumpFalse instruction replacement after long "then" body} { + set z if + catch {unset i} + set a {} + $z 1<2 { + set a 1 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 2 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 3 + } + set a +} 3 +test if-5.17 {if cmd with computed command names: if/elseif test in quotes} { + set z if + set a {} + list [catch {$z {"0 < 3"} {set a 1}} msg] $msg +} {1 {expected boolean value but got "0 < 3"}} + + +test if-6.1 {if cmd with computed command names: "elseif" after if/elseif test} { + set z if + set a {} + $z 3>4 {set a 1} elseif 1 {set a 2} + set a +} {2} +# Since "else" is optional, the "elwood" below is treated as a command. +# But then there shouldn't be any additional argument words for the "if". +test if-6.2 {if cmd with computed command names: keyword other than "elseif"} { + set z if + set a {} + catch {$z 1<2 {set a 1} elwood {set a 2}} msg + set msg +} {wrong # args: extra words after "else" clause in "if" command} +test if-6.3 {if cmd with computed command names: missing expression after "elseif"} { + set z if + set a {} + catch {$z 1<2 {set a 1} elseif} msg + set msg +} {wrong # args: no expression after "elseif" argument} +test if-6.4 {if cmd with computed command names: error in expression after "elseif"} { + set z if + set a {} + list [catch {$z 3>4 {set a 1} elseif {1>}} msg] $msg $errorInfo +} {1 {syntax error in expression "1>"} {syntax error in expression "1>" + while executing +"$z 3>4 {set a 1} elseif {1>}"}} +test if-6.5 {if cmd with computed command names: test jumpFalse instruction replacement after long "elseif" body} { + set z if + catch {unset i} + set a {} + $z 1>2 { + set a 1 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 2 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 3 + } elseif 1<2 then { #; this if arm should be taken + set a 4 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 5 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 6 + } + set a +} 6 + +test if-7.1 {if cmd with computed command names: "else" clause} { + set z if + set a {} + $z 3>4 {set a 1} elseif {$a == "foo"} {set a 2} else {set a 3} + set a +} 3 +# Since "else" is optional, the "elsex" below is treated as a command. +# But then there shouldn't be any additional argument words for the "if". +test if-7.2 {if cmd with computed command names: keyword other than "else"} { + set z if + set a {} + catch {$z 1<2 then {set a 1} elsex {set a 2}} msg + set msg +} {wrong # args: extra words after "else" clause in "if" command} +test if-7.3 {if cmd with computed command names: missing body after "else"} { + set z if + set a {} + catch {$z 2<1 {set a 1} else} msg + set msg +} {wrong # args: no script following "else" argument} +test if-7.4 {if cmd with computed command names: error compiling body after "else"} { + set z if + set a {} + catch {$z 2<1 {set a 1} else {set}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + invoked from within +"$z 2<1 {set a 1} else {set}"} +test if-7.5 {if cmd with computed command names: extra arguments after "else" argument} { + set z if + set a {} + catch {$z 2<1 {set a 1} else {set a 2} or something} msg + set msg +} {wrong # args: extra words after "else" clause in "if" command} +# The following test also checks whether contained loops and other +# commands are properly relocated because a short jump must be replaced +# by a "long distance" one. +test if-7.6 {if cmd with computed command names: test jumpFalse instruction replacement after long "else" clause} { + set z if + catch {unset i} + set a {} + $z 1>2 { + set a 1 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 2 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 3 + } elseif 1==2 then { #; this if arm should be taken + set a 4 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 5 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 6 + } else { + set a 7 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 8 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 9 + } + set a +} 9 + +test if-8.1 {if cmd with computed command names: "if" command result} { + set z if + set a {} + set a [$z 3<4 {set i 27}] + set a +} 27 +test if-8.2 {if cmd with computed command names: "if" command result} { + set z if + set a {} + set a [$z 3>4 {set i 27}] + set a +} {} +test if-8.3 {if cmd with computed command names: "if" command result} { + set z if + set a {} + set a [$z 0 {set i 1} elseif 1 {set i 2}] + set a +} 2 +test if-8.4 {if cmd with computed command names: "if" command result} { + set z if + set a {} + set a [$z 0 {set i 1} elseif 0 {set i 2} elseif 2>5 {set i 3} else {set i 4}] + set a +} 4 +test if-8.5 {if cmd with computed command names: return value} { + set z if + $z 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi} +} def + +return diff --git a/tests/incr-old.test b/tests/incr-old.test index 8fbd89f..710896c 100644 --- a/tests/incr-old.test +++ b/tests/incr-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: @(#) incr-old.test 1.11 96/11/19 16:56:23 +# SCCS: @(#) incr-old.test 1.12 97/12/08 15:06:10 if {[string compare test [info procs test]] == 1} then {source defs} @@ -86,4 +86,4 @@ test incr-old-2.10 {incr errors} { list [catch {incr x 1} msg] $msg } {1 {expected integer but got "20 x"}} -concat {} +return diff --git a/tests/incr.test b/tests/incr.test index e187d41..8dd9cce 100644 --- a/tests/incr.test +++ b/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.9 97/07/02 16:41:32 +# SCCS: @(#) incr.test 1.13 97/12/16 13:32:33 if {[string compare test [info procs test]] == 1} then {source defs} @@ -238,9 +238,259 @@ test incr-1.29 {TclCompileIncrCmd: runtime error, bad variable value} { # Check "incr" and computed command names. -test incr-2.1 {incr and computed command names} { +test incr-2.0 {incr and computed command names} { set i 5 set z incr $z i -1 set i } 4 +catch {unset x} +catch {unset i} + +test incr-2.1 {incr command (not compiled): missing variable name} { + set z incr + list [catch {$z} msg] $msg +} {1 {wrong # args: should be "incr varName ?increment?"}} +test incr-2.2 {incr command (not compiled): simple variable name} { + set z incr + set i 10 + list [$z i] $i +} {11 11} +test incr-2.3 {incr command (not compiled): error compiling variable name} { + set z incr + set i 10 + catch {$z "i"xxx} msg + set msg +} {extra characters after close-quote} +test incr-2.4 {incr command (not compiled): simple variable name in quotes} { + set z incr + set i 17 + list [$z "i"] $i +} {18 18} +test incr-2.5 {incr command (not compiled): simple variable name in braces} { + set z incr + catch {unset {a simple var}} + set {a simple var} 27 + list [$z {a simple var}] ${a simple var} +} {28 28} +test incr-2.6 {incr command (not compiled): simple array variable name} { + set z incr + catch {unset a} + set a(foo) 37 + list [$z a(foo)] $a(foo) +} {38 38} +test incr-2.7 {incr command (not compiled): non-simple (computed) variable name} { + set z incr + set x "i" + set i 77 + list [$z $x 2] $i +} {79 79} +test incr-2.8 {incr command (not compiled): non-simple (computed) variable name} { + set z incr + set x "i" + set i 77 + list [$z [set x] +2] $i +} {79 79} + +test incr-2.9 {incr command (not compiled): increment given} { + set z incr + set i 10 + list [$z i +07] $i +} {17 17} +test incr-2.10 {incr command (not compiled): no increment given} { + set z incr + set i 10 + list [$z i] $i +} {11 11} + +test incr-2.11 {incr command (not compiled): simple global name} { + proc p {} { + set z incr + global i + set i 54 + $z i + } + p +} {55} +test incr-2.12 {incr command (not compiled): simple local name} { + proc p {} { + set z incr + set foo 100 + $z foo + } + p +} {101} +test incr-2.13 {incr command (not compiled): simple but new (unknown) local name} { + proc p {} { + set z incr + $z bar + } + catch {p} msg + set msg +} {can't read "bar": no such variable} +test incr-2.14 {incr command (not compiled): simple local name, >255 locals} { + proc 260locals {} { + set z incr + # create 260 locals + set a0 0; set a1 0; set a2 0; set a3 0; set a4 0 + set a5 0; set a6 0; set a7 0; set a8 0; set a9 0 + set b0 0; set b1 0; set b2 0; set b3 0; set b4 0 + set b5 0; set b6 0; set b7 0; set b8 0; set b9 0 + set c0 0; set c1 0; set c2 0; set c3 0; set c4 0 + set c5 0; set c6 0; set c7 0; set c8 0; set c9 0 + set d0 0; set d1 0; set d2 0; set d3 0; set d4 0 + set d5 0; set d6 0; set d7 0; set d8 0; set d9 0 + set e0 0; set e1 0; set e2 0; set e3 0; set e4 0 + set e5 0; set e6 0; set e7 0; set e8 0; set e9 0 + set f0 0; set f1 0; set f2 0; set f3 0; set f4 0 + set f5 0; set f6 0; set f7 0; set f8 0; set f9 0 + set g0 0; set g1 0; set g2 0; set g3 0; set g4 0 + set g5 0; set g6 0; set g7 0; set g8 0; set g9 0 + set h0 0; set h1 0; set h2 0; set h3 0; set h4 0 + set h5 0; set h6 0; set h7 0; set h8 0; set h9 0 + set i0 0; set i1 0; set i2 0; set i3 0; set i4 0 + set i5 0; set i6 0; set i7 0; set i8 0; set i9 0 + set j0 0; set j1 0; set j2 0; set j3 0; set j4 0 + set j5 0; set j6 0; set j7 0; set j8 0; set j9 0 + set k0 0; set k1 0; set k2 0; set k3 0; set k4 0 + set k5 0; set k6 0; set k7 0; set k8 0; set k9 0 + set l0 0; set l1 0; set l2 0; set l3 0; set l4 0 + set l5 0; set l6 0; set l7 0; set l8 0; set l9 0 + set m0 0; set m1 0; set m2 0; set m3 0; set m4 0 + set m5 0; set m6 0; set m7 0; set m8 0; set m9 0 + set n0 0; set n1 0; set n2 0; set n3 0; set n4 0 + set n5 0; set n6 0; set n7 0; set n8 0; set n9 0 + set o0 0; set o1 0; set o2 0; set o3 0; set o4 0 + set o5 0; set o6 0; set o7 0; set o8 0; set o9 0 + set p0 0; set p1 0; set p2 0; set p3 0; set p4 0 + set p5 0; set p6 0; set p7 0; set p8 0; set p9 0 + set q0 0; set q1 0; set q2 0; set q3 0; set q4 0 + set q5 0; set q6 0; set q7 0; set q8 0; set q9 0 + set r0 0; set r1 0; set r2 0; set r3 0; set r4 0 + set r5 0; set r6 0; set r7 0; set r8 0; set r9 0 + set s0 0; set s1 0; set s2 0; set s3 0; set s4 0 + set s5 0; set s6 0; set s7 0; set s8 0; set s9 0 + set t0 0; set t1 0; set t2 0; set t3 0; set t4 0 + set t5 0; set t6 0; set t7 0; set t8 0; set t9 0 + set u0 0; set u1 0; set u2 0; set u3 0; set u4 0 + set u5 0; set u6 0; set u7 0; set u8 0; set u9 0 + set v0 0; set v1 0; set v2 0; set v3 0; set v4 0 + set v5 0; set v6 0; set v7 0; set v8 0; set v9 0 + set w0 0; set w1 0; set w2 0; set w3 0; set w4 0 + set w5 0; set w6 0; set w7 0; set w8 0; set w9 0 + set x0 0; set x1 0; set x2 0; set x3 0; set x4 0 + set x5 0; set x6 0; set x7 0; set x8 0; set x9 0 + set y0 0; set y1 0; set y2 0; set y3 0; set y4 0 + set y5 0; set y6 0; set y7 0; set y8 0; set y9 0 + set z0 0; set z1 0; set z2 0; set z3 0; set z4 0 + set z5 0; set z6 0; set z7 0; set z8 0; set z9 0 + # now increment the last one (local var index > 255) + $z z9 + } + 260locals +} {1} +test incr-2.15 {incr command (not compiled): variable is array} { + set z incr + catch {unset a} + set a(foo) 27 + set x [$z a(foo) 11] + catch {unset a} + set x +} 38 +test incr-2.16 {incr command (not compiled): variable is array, elem substitutions} { + set z incr + catch {unset a} + set i 5 + set a(foo5) 27 + set x [$z a(foo$i) 11] + catch {unset a} + set x +} 38 + +test incr-2.17 {incr command (not compiled): increment given, simple int} { + set z incr + set i 5 + $z i 123 +} 128 +test incr-2.18 {incr command (not compiled): increment given, simple int} { + set z incr + set i 5 + $z i -100 +} -95 +test incr-2.19 {incr command (not compiled): increment given, but erroneous} { + set z incr + set i 5 + catch {$z i [set]} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + while compiling +"$z i [set]"} +test incr-2.20 {incr command (not compiled): increment given, in quotes} { + set z incr + set i 25 + $z i "-100" +} -75 +test incr-2.21 {incr command (not compiled): increment given, in braces} { + set z incr + set i 24 + $z i {126} +} 150 +test incr-2.22 {incr command (not compiled): increment given, large int} { + set z incr + set i 5 + $z i 200000 +} 200005 +test incr-2.23 {incr command (not compiled): increment given, formatted int != int} { + set z incr + set i 25 + $z i 000012345 ;# an octal literal +} 5374 +test incr-2.24 {incr command (not compiled): increment given, formatted int != int} { + set z incr + set i 25 + catch {$z i 1a} msg + set msg +} {expected integer but got "1a"} + +test incr-2.25 {incr command (not compiled): too many arguments} { + set z incr + set i 10 + catch {$z i 10 20} msg + set msg +} {wrong # args: should be "incr varName ?increment?"} + + +test incr-2.26 {incr command (not compiled): runtime error, bad variable name} { + set z incr + list [catch {$z {"foo}} msg] $msg $errorInfo +} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable + (reading value of variable to increment) + invoked from within +"$z {"foo}"}} +test incr-2.27 {incr command (not compiled): runtime error, bad variable name} { + set z incr + list [catch {$z [set]} msg] $msg $errorInfo +} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + while compiling +"$z [set]"}} +test incr-2.28 {incr command (not compiled): runtime error, readonly variable} { + set z incr + proc readonly args {error "variable is read-only"} + set x 123 + trace var x w readonly + list [catch {$z x 1} msg] $msg $errorInfo +} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only + while executing +"$z x 1"}} +catch {unset x} +test incr-2.29 {incr command (not compiled): runtime error, bad variable value} { + set z incr + set x " - " + list [catch {$z x 1} msg] $msg +} {1 {expected integer but got " - "}} + +return diff --git a/tests/indexObj.test b/tests/indexObj.test index 9f30ee0..cbe32e8 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.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. # -# @(#) indexObj.test 1.3 97/06/23 18:23:09 +# @(#) indexObj.test 1.4 97/12/08 15:06:27 if {[info procs test] != "test"} { source defs @@ -66,3 +66,5 @@ test indexObj-4.1 {free old internal representation} { lindex $x 1 testindexobj 1 1 $x abc def {a b} zzz } {2} + +return diff --git a/tests/info.test b/tests/info.test index 784dad1..7bc5e84 100644 --- a/tests/info.test +++ b/tests/info.test @@ -5,15 +5,27 @@ # 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-1995 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: @(#) info.test 1.39 97/08/01 11:10:24 +# SCCS: @(#) info.test 1.43 98/02/11 17:28:43 if {[string compare test [info procs test]] == 1} then {source defs} +# Set up namespaces needed to test operation of "info args", "info body", +# "info default", and "info procs" with imported procedures. + +catch {namespace delete test_ns_info1 test_ns_info2} + +namespace eval test_ns_info1 { + namespace export * + proc p {x} {return "x=$x"} + proc q {{y 27} z} {return "y=$y"} +} + + test info-1.1 {info args option} { proc t1 {a bbb c} {return foo} info args t1 @@ -38,6 +50,13 @@ test info-1.6 {info args option} { t1 1 2 info args t1 } {a b} +test info-1.7 {info args option} { + catch {namespace delete test_ns_info2} + namespace eval test_ns_info2 { + namespace import ::test_ns_info1::* + list [info args p] [info args q] + } +} {x {y z}} test info-2.1 {info body option} { proc t1 {} {body of t1} @@ -49,6 +68,13 @@ test info-2.2 {info body option} { test info-2.3 {info body option} { list [catch {info args set 1} msg] $msg } {1 {wrong # args: should be "info args procname"}} +test info-2.4 {info body option} { + catch {namespace delete test_ns_info2} + namespace eval test_ns_info2 { + namespace import ::test_ns_info1::* + list [info body p] [info body q] + } +} {{return "x=$x"} {return "y=$y"}} # "info cmdcount" is no longer accurate for compiled commands! The expected # result for info-3.1 used to be "3" and is now "1" since the "set"s have @@ -59,7 +85,7 @@ test info-3.1 {info cmdcount option} { set z [info cm] expr $z-$x } 1 -test info-3.2 {info body option} { +test info-3.2 {info cmdcount option} { list [catch {info cmdcount 1} msg] $msg } {1 {wrong # args: should be "info cmdcount"}} @@ -93,145 +119,13 @@ test info-4.5 {info commands option} { } {1 {wrong # args: should be "info commands ?pattern?"}} test info-5.1 {info complete option} { - info complete "" -} 1 + list [catch {info complete} msg] $msg +} {1 {wrong # args: should be "info complete command"}} test info-5.2 {info complete option} { - info complete " \n" -} 1 -test info-5.3 {info complete option} { - info complete "abc def" -} 1 -test info-5.4 {info complete option} { - info complete "a b c d e f \t\n" -} 1 -test info-5.5 {info complete option} { - info complete {a b c"d} -} 1 -test info-5.6 {info complete option} { - info complete {a b "c d" e} -} 1 -test info-5.7 {info complete option} { - info complete {a b "c d"} -} 1 -test info-5.8 {info complete option} { - info complete {a b "c d"} -} 1 -test info-5.9 {info complete option} { - info complete {a b "c d} -} 0 -test info-5.10 {info complete option} { - info complete {a b "} -} 0 -test info-5.11 {info complete option} { - info complete {a b "cd"xyz} -} 1 -test info-5.12 {info complete option} { - info complete {a b "c $d() d"} -} 1 -test info-5.13 {info complete option} { - info complete {a b "c $dd("} -} 0 -test info-5.14 {info complete option} { - info complete {a b "c \"} -} 0 -test info-5.15 {info complete option} { - info complete {a b "c [d e f]"} -} 1 -test info-5.16 {info complete option} { - info complete {a b "c [d e f] g"} -} 1 -test info-5.17 {info complete option} { - info complete {a b "c [d e f"} -} 0 -test info-5.18 {info complete option} { - info complete {a {b c d} e} -} 1 -test info-5.19 {info complete option} { - info complete {a {b c d}} -} 1 -test info-5.20 {info complete option} { - info complete "a b\{c d" -} 1 -test info-5.21 {info complete option} { - info complete "a b \{c" -} 0 -test info-5.22 {info complete option} { - info complete "a b \{c{ }" -} 0 -test info-5.23 {info complete option} { - info complete "a b {c d e}xxx" -} 1 -test info-5.24 {info complete option} { - info complete "a b {c \\\{d e}xxx" -} 1 -test info-5.25 {info complete option} { - info complete {a b [ab cd ef]} -} 1 -test info-5.26 {info complete option} { - info complete {a b x[ab][cd][ef] gh} -} 1 -test info-5.27 {info complete option} { - info complete {a b x[ab][cd[ef] gh} -} 0 -test info-5.28 {info complete option} { - info complete {a b x[ gh} -} 0 -test info-5.29 {info complete option} { - info complete {[]]]} -} 1 -test info-5.30 {info complete option} { - info complete {abc x$yyy} -} 1 -test info-5.31 {info complete option} { - info complete "abc x\${abc\[\\d} xyz" -} 1 -test info-5.32 {info complete option} { - info complete "abc x\$\{ xyz" -} 0 -test info-5.33 {info complete option} { - info complete {word $a(xyz)} -} 1 -test info-5.34 {info complete option} { - info complete {word $a(} -} 0 -test info-5.35 {info complete option} { - info complete "set a \\\n" -} 0 -test info-5.36 {info complete option} { - info complete "set a \\n " + info complete abc } 1 -test info-5.37 {info complete option} { - info complete "set a \\" -} 1 -test info-5.38 {info complete option} { - info complete "foo \\\n\{" -} 0 -test info-5.39 {info complete option} { - info complete " # \{" -} 1 -test info-5.40 {info complete option} { - info complete "foo bar;# \{" -} 1 -test info-5.41 {info complete option} { - info complete "a\nb\n# \{\n# \{\nc\n" -} 1 -test info-5.42 {info complete option} { - info complete "#Incomplete comment\\\n" -} 0 -test info-5.43 {info complete option} { - info complete "#Incomplete comment\\\nBut now it's complete.\n" -} 1 -test info-5.44 {info complete option} { - info complete "# Complete comment\\\\\n" -} 1 -test info-5.45 {info complete option} { - info complete "abc\\\n def" -} 1 -test info-5.46 {info complete option} { - info complete "abc\\\n " -} 1 -test info-5.47 {info complete option} { - info complete "abc\\\n" +test info-5.2 {info complete option} { + info complete "\{abcd " } 0 test info-6.1 {info default option} { @@ -282,6 +176,13 @@ test info-6.10 {info default option} { proc t1 {{a 18} b} {} list [catch {info default t1 a a} msg] $msg } {1 {couldn't store default value in variable "a"}} +test info-6.11 {info default option} { + catch {namespace delete test_ns_info2} + namespace eval test_ns_info2 { + namespace import ::test_ns_info1::* + list [info default p x foo] $foo [info default q y bar] $bar + } +} {0 {} 1 27} catch {unset a} test info-7.1 {info exists option} { @@ -410,7 +311,7 @@ test info-11.1 {info loaded option} { } {1 {wrong # args: should be "info loaded ?interp?"}} test info-11.2 {info loaded option} { list [catch {info loaded {}}] [catch {info loaded gorp} msg] $msg -} {0 1 {couldn't find slave interpreter named "gorp"}} +} {0 1 {could not find interpreter "gorp"}} test info-12.1 {info locals option} { set a 22 @@ -486,6 +387,14 @@ catch {rename _tt2 {}} test info-15.3 {info procs option} { list [catch {info procs 2 3} msg] $msg } {1 {wrong # args: should be "info procs ?pattern?"}} +test info-15.4 {info procs option} { + catch {namespace delete test_ns_info2} + namespace eval test_ns_info2 { + namespace import ::test_ns_info1::* + proc r {} {} + list [info procs] [info procs p*] + } +} {{p q r} p} set self info.test if {$tcl_platform(os) == "Win32s"} { @@ -574,3 +483,6 @@ test info-20.4 {miscellaneous error conditions} { test info-20.5 {miscellaneous error conditions} { list [catch {info s} msg] $msg } {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} + +catch {namespace delete test_ns_info1 test_ns_info2} +return diff --git a/tests/init.test b/tests/init.test index 2d6e068..658b998 100644 --- a/tests/init.test +++ b/tests/init.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: @(#) init.test 1.5 97/11/19 18:08:20 +# SCCS: @(#) init.test 1.6 97/12/08 15:07:52 if {[string compare test [info procs test]] == 1} then {source defs} @@ -147,3 +147,4 @@ test init-3.0 {random stuff in the auto_index, should still work} { interp delete $testInterp +return diff --git a/tests/interp.test b/tests/interp.test index 919774f..4c43edb 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) interp.test 1.64 97/09/04 16:02:23 +# SCCS: @(#) interp.test 1.70 98/02/17 23:45:11 if {[string compare test [info procs test]] == 1} then {source defs} @@ -39,7 +39,7 @@ test interp-1.3 {options for interp command} { } "" test interp-1.4 {options for interp command} { list [catch {interp delete foo bar} msg] $msg -} {1 {interpreter named "foo" not found}} +} {1 {could not find interpreter "foo"}} test interp-1.5 {options for interp command} { list [catch {interp exists foo bar} msg] $msg } {1 {wrong # args: should be "interp exists ?path?"}} @@ -83,7 +83,7 @@ test interp-2.6 {basic interpreter creation} { } d test interp-2.7 {basic interpreter creation} { list [catch {interp create -froboz} msg] $msg -} {1 {bad option "-froboz": should be -safe}} +} {1 {bad option "-froboz": must be -safe or --}} test interp-2.8 {basic interpreter creation} { interp create -- -froboz } -froboz @@ -99,17 +99,15 @@ 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 + 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 @@ -164,10 +162,10 @@ test interp-4.1 {testing interp delete} { } "" test interp-4.2 {testing interp delete} { list [catch {interp delete nonexistent} msg] $msg -} {1 {interpreter named "nonexistent" not found}} +} {1 {could not find interpreter "nonexistent"}} test interp-4.3 {testing interp delete} { list [catch {interp delete x y z} msg] $msg -} {1 {interpreter named "x" not found}} +} {1 {could not find interpreter "x"}} test interp-4.4 {testing interp delete} { interp delete } "" @@ -187,7 +185,7 @@ test interp-4.7 {testing interp delete} { interp create c1 interp create c2 list [catch {interp delete c1 c2 c3} msg] $msg -} {1 {interpreter named "c3" not found}} +} {1 {could not find interpreter "c3"}} foreach i [interp slaves] { interp delete $i @@ -1594,7 +1592,7 @@ test interp-22.5 {testing interp marktrusted} { catch {a eval {interp marktrusted b}} msg interp delete a set msg -} {"interp marktrusted" can only be invoked from a trusted interpreter} +} {permission denied: safe interpreter cannot mark trusted} test interp-22.6 {testing interp marktrusted} { catch {interp delete a} interp create a -safe @@ -1602,7 +1600,7 @@ test interp-22.6 {testing interp marktrusted} { catch {a eval {b marktrusted}} msg interp delete a set msg -} {"b marktrusted" can only be invoked from a trusted interpreter} +} {permission denied: safe interpreter cannot mark trusted} test interp-22.7 {testing interp marktrusted} { catch {interp delete a} interp create a -safe @@ -1929,31 +1927,91 @@ test interp-25.1 {testing aliasing of string commands} { } "" +# # 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 +# + +test interp-26.1 {result code transmission : interp eval direct} { + # Test that all the possibles error codes from Tcl get passed up + # from the slave interp's context to the master, even though the + # slave nominally thinks the command is running at the root level. + + catch {interp delete a} + interp create a + 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 return -code $code} msg] + } + interp delete a + set res +} {-1 0 1 2 3 4 5} + + +test interp-26.2 {result code transmission : interp eval indirect} { + # retcode == 2 == return is special catch {interp delete a} interp create a - interp eval a {proc ret {code} {return -code $code $code}} + interp eval a {proc retcode {code} {return -code $code ret$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] + lappend res [catch {interp eval a retcode $code} msg] $msg + } + interp delete a + set res +} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} + +test interp-26.3 {result code transmission : aliases} { + # Test that all the possibles error codes from Tcl get passed up + # from the slave interp's context to the master, even though the + # slave nominally thinks the command is running at the root level. + + catch {interp delete a} + interp create a + set res {} + proc MyTestAlias {code} { + return -code $code ret$code + } + interp alias a Test {} MyTestAlias + for {set code -1} {$code<=5} {incr code} { + lappend res [interp eval a [list catch [list Test $code] msg]] + } + interp delete a + set res +} {-1 0 1 2 3 4 5} + +test interp-26.4 {result code transmission : invoke hidden direct} {knownBug} { + # The known bug is that code 2 is returned, not the -code argument + catch {interp delete a} + interp create a + set res {} + interp hide a return + for {set code -1} {$code<=5} {incr code} { + lappend res [catch {interp invokehidden a return -code $code ret$code}] } 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 +test interp-26.5 {result code transmission : invoke hidden indirect} {knownBug} { + # The known bug is that the break and continue should raise errors + # that they are used outside a loop. + catch {interp delete a} + interp create a + set res {} + interp eval a {proc retcode {code} {return -code $code ret$code}} + interp hide a retcode + for {set code -1} {$code<=5} {incr code} { + lappend res [catch {interp invokehidden a retcode $code} msg] $msg + } + interp delete a + set res +} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} + +test interp-26.6 {result code transmission : all combined} {knownBug} { + # Test that all the possibles error codes from Tcl get passed + # In both directions. This doesn't work. set interp [interp create]; proc MyTestAlias {interp args} { global aliasTrace; @@ -1964,17 +2022,22 @@ test interp-26.2 {result code transmission 2} {knownBug} { interp hide $interp $c; interp alias $interp $c {} MyTestAlias $interp $c; } - interp eval $interp {proc ret {code} {return -code $code $code}} + interp eval $interp {proc ret {code} {return -code $code ret$code}} set res {} set aliasTrace {} for {set code -1} {$code<=5} {incr code} { - lappend res [catch {interp eval $interp ret $code} msg] + lappend res [catch {interp eval $interp ret $code} msg] $msg } interp delete $interp; - list $res -} {-1 0 1 2 3 4 5} + set res +} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} -test interp-26.3 {errorInfo transmission : regular interps} { +# Some tests might need to be added to check for difference between +# toplevel and non toplevel evals. + +# End of return code transmission section + +test interp-26.5 {errorInfo transmission : regular interps} { set interp [interp create]; proc MyError {secret} { return -code error "msg" @@ -1989,11 +2052,11 @@ test interp-26.3 {errorInfo transmission : regular interps} { } {msg while executing "MyError "some secret"" - (procedure "test" line 2) + (procedure "MyTestAlias" line 2) invoked from within -"catch test"} +"test"} -test interp-26.4 {errorInfo transmission : safe interps} {knownBug} { +test interp-26.6 {errorInfo transmission : safe interps} {knownBug tasteIssue} { # this test fails because the errorInfo is fully transmitted # whether the interp is safe or not. this is maybe a feature # and not a bug. @@ -2010,7 +2073,7 @@ test interp-26.4 {errorInfo transmission : safe interps} {knownBug} { set res } {msg while executing -"catch test"} +"test"} # Interps & Namespaces test interp-27.1 {interp aliases & namespaces} { @@ -2256,3 +2319,5 @@ test interp-29.2 {recursion limit inheritance} { foreach i [interp slaves] { interp delete $i } + +return diff --git a/tests/io.test b/tests/io.test index 2b6670f..2f55660 100644 --- a/tests/io.test +++ b/tests/io.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) io.test 1.131 97/09/22 11:15:05 +# SCCS: @(#) io.test 1.149 98/02/10 17:49:32 if {[string compare test [info procs test]] == 1} then {source defs} @@ -21,6 +21,8 @@ if {"[info commands testchannel]" != "testchannel"} { return } +saveState + removeFile test1 removeFile pipe @@ -37,23 +39,22 @@ 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"} { + set f stdin + if {$argv != ""} { + set f [open $argv] + } + fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a + fconfigure stdout -encoding binary -translation lf -buffering none + fileevent $f readable "foo $f" + proc foo {f} { + set x [read $f] + catch {puts -nonewline $x} + if {[eof $f]} { close $f + exit 0 } } + vwait forever } close $f @@ -124,6 +125,1427 @@ close $f # list $c $x #} {40 ok} +proc contents {file} { + set f [open $file] + fconfigure $f -translation binary + set a [read $f] + close $f + return $a +} + +test io-1.1 {Tcl_WriteChars: CheckChannelErrors} { + # no test, need to cause an async error. +} {} +test io-1.2 {Tcl_WriteChars: WriteBytes} { + set f [open test1 w] + fconfigure $f -encoding binary + puts -nonewline $f "a\u4e4d\0" + close $f + contents test1 +} "a\x4d\x00" +test io-1.3 {Tcl_WriteChars: WriteChars} { + set f [open test1 w] + fconfigure $f -encoding shiftjis + puts -nonewline $f "a\u4e4d\0" + close $f + contents test1 +} "a\x93\xe1\x00" + +test io-2.1 {WriteBytes} { + # loop until all bytes are written + + set f [open test1 w] + fconfigure $f -encoding binary -buffersize 16 -translation crlf + puts $f "abcdefghijklmnopqrstuvwxyz" + close $f + contents test1 +} "abcdefghijklmnopqrstuvwxyz\r\n" +test io-2.2 {WriteBytes: savedLF > 0} { + # After flushing buffer, there was a \n left over from the last + # \n -> \r\n expansion. It gets stuck at beginning of this buffer. + + set f [open test1 w] + fconfigure $f -encoding binary -buffersize 16 -translation crlf + puts -nonewline $f "123456789012345\n12" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "123456789012345\r" "123456789012345\r\n12"] +test io-2.3 {WriteBytes: flush on line} { + # Tcl "line" buffering has weird behavior: if current buffer contains + # a \n, entire buffer gets flushed. Logical behavior would be to flush + # only up to the \n. + + set f [open test1 w] + fconfigure $f -encoding binary -buffering line -translation crlf + puts -nonewline $f "\n12" + set x [contents test1] + close $f + set x +} "\r\n12" + +test io-3.1 {WriteChars: compatibility with WriteBytes} { + # loop until all bytes are written + + set f [open test1 w] + fconfigure $f -encoding ascii -buffersize 16 -translation crlf + puts $f "abcdefghijklmnopqrstuvwxyz" + close $f + contents test1 +} "abcdefghijklmnopqrstuvwxyz\r\n" +test io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} { + # After flushing buffer, there was a \n left over from the last + # \n -> \r\n expansion. It gets stuck at beginning of this buffer. + + set f [open test1 w] + fconfigure $f -encoding ascii -buffersize 16 -translation crlf + puts -nonewline $f "123456789012345\n12" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "123456789012345\r" "123456789012345\r\n12"] +test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { + # Tcl "line" buffering has weird behavior: if current buffer contains + # a \n, entire buffer gets flushed. Logical behavior would be to flush + # only up to the \n. + + set f [open test1 w] + fconfigure $f -encoding ascii -buffering line -translation crlf + puts -nonewline $f "\n12" + set x [contents test1] + close $f + set x +} "\r\n12" +test io-3.4 {WriteChars: loop over stage buffer} { + # stage buffer maps to more than can be queued at once. + + set f [open test1 w] + fconfigure $f -encoding jis0208 -buffersize 16 + puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test io-3.5 {WriteChars: saved != 0} { + # Bytes produced by UtfToExternal from end of last channel buffer + # had to be moved to beginning of next channel buffer to preserve + # requested buffersize. + + set f [open test1 w] + fconfigure $f -encoding jis0208 -buffersize 17 + puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { + # One incomplete UTF-8 character at end of staging buffer. Backup + # in src to the beginning of that UTF-8 character and try again. + # + # Translate the first 16 bytes, produce 14 bytes of output, 2 left over + # (first two bytes of \uff21 in UTF-8). Given those two bytes try + # translating them again, find that no bytes are read produced, and break + # to outer loop where those two bytes will have the remaining 4 bytes + # (the last byte of \uff21 plus the all of \uff22) appended. + + set f [open test1 w] + fconfigure $f -encoding shiftjis -buffersize 16 + puts -nonewline $f "12345678901234\uff21\uff22" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] +test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { + # When translating UTF-8 to external, the produced bytes went past end + # of the channel buffer. This is done purpose -- we then truncate the + # bytes at the end of the partial character to preserve the requested + # blocksize on flush. The truncated bytes are moved to the beginning + # of the next channel buffer. + + set f [open test1 w] + fconfigure $f -encoding jis0208 -buffersize 17 + puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] + +test io-4.1 {TranslateOutputEOL: lf} { + # search for \n + + set f [open test1 w] + fconfigure $f -buffering line -translation lf + puts $f "abcde" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "abcde\n" "abcde\n"] +test io-4.2 {TranslateOutputEOL: cr} { + # search for \n, replace with \r + + set f [open test1 w] + fconfigure $f -buffering line -translation cr + puts $f "abcde" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "abcde\r" "abcde\r"] +test io-4.3 {TranslateOutputEOL: crlf} { + # simple case: search for \n, replace with \r + + set f [open test1 w] + fconfigure $f -buffering line -translation crlf + puts $f "abcde" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "abcde\r\n" "abcde\r\n"] +test io-4.4 {TranslateOutputEOL: crlf} { + # keep storing more bytes in output buffer until output buffer is full. + # We have 13 bytes initially that would turn into 18 bytes. Fill + # dest buffer while (dstEnd < dstMax). + + set f [open test1 w] + fconfigure $f -translation crlf -buffersize 16 + puts -nonewline $f "1234567\n\n\n\n\nA" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "1234567\r\n\r\n\r\n\r\n\r" "1234567\r\n\r\n\r\n\r\n\r\nA"] + +test io-5.1 {CheckFlush: not full} { + set f [open test1 w] + fconfigure $f + puts -nonewline $f "12345678901234567890" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "" "12345678901234567890"] +test io-5.2 {CheckFlush: full} { + set f [open test1 w] + fconfigure $f -buffersize 16 + puts -nonewline $f "12345678901234567890" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "1234567890123456" "12345678901234567890"] +test io-5.3 {CheckFlush: not line} { + set f [open test1 w] + fconfigure $f -buffering line + puts -nonewline $f "12345678901234567890" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "" "12345678901234567890"] +test io-5.4 {CheckFlush: line} { + set f [open test1 w] + fconfigure $f -buffering line -translation lf -encoding ascii + puts -nonewline $f "1234567890\n1234567890" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "1234567890\n1234567890" "1234567890\n1234567890"] +test io-5.5 {CheckFlush: none} { + set f [open test1 w] + fconfigure $f -buffering none + puts -nonewline $f "1234567890" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "1234567890" "1234567890"] + +test io-6.1 {Tcl_GetsObj: working} { + set f [open test1 w] + puts $f "foo\nboo" + close $f + set f [open test1] + set x [gets $f] + close $f + set x +} {foo} +test io-6.2 {Tcl_GetsObj: CheckChannelErrors() != 0} { + # no test, need to cause an async error. +} {} +test io-6.3 {Tcl_GetsObj: how many have we used?} { + # if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved} + + set f [open test1 w] + fconfigure $f -translation crlf + puts $f "abc\ndefg" + close $f + set f [open test1] + set x [list [tell $f] [gets $f line] [tell $f] [gets $f line] $line] + close $f + set x +} {0 3 5 4 defg} +test io-6.4 {Tcl_GetsObj: encoding == NULL} { + set f [open test1 w] + fconfigure $f -translation binary + puts $f "\x81\u1234\0" + close $f + set f [open test1] + fconfigure $f -translation binary + set x [list [gets $f line] $line] + close $f + set x +} [list 3 "\x81\x34\x00"] +test io-6.5 {Tcl_GetsObj: encoding != NULL} { + set f [open test1 w] + fconfigure $f -translation binary + puts $f "\x88\xea\x92\x9a" + close $f + set f [open test1] + fconfigure $f -encoding shiftjis + set x [list [gets $f line] $line] + close $f + set x +} [list 2 "\u4e00\u4e01"] +set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" +append a $a +append a $a +test io-6.6 {Tcl_GetsObj: loop test} { + # if (dst >= dstEnd) + + set f [open test1 w] + puts $f $a + puts $f hi + close $f + set f [open test1] + set x [list [gets $f line] $line] + close $f + set x +} [list 256 $a] +test io-6.7 {Tcl_GetsObj: error in input} {stdio} { + # if (FilterInputBytes(chanPtr, &gs) != 0) + + set f [open "|[list $tcltest cat]" w+] + puts -nonewline $f "hi\nwould" + flush $f + gets $f + fconfigure $f -blocking 0 + set x [gets $f line] + close $f + set x +} {-1} +test io-6.8 {Tcl_GetsObj: remember if EOF is seen} { + set f [open test1 w] + puts $f "abcdef\x1aghijk\nwombat" + close $f + set f [open test1] + fconfigure $f -eofchar \x1a + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {6 abcdef -1 {}} +test io-6.9 {Tcl_GetsObj: remember if EOF is seen} { + set f [open test1 w] + puts $f "abcdefghijk\nwom\u001abat" + close $f + set f [open test1] + fconfigure $f -eofchar \x1a + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {11 abcdefghijk 3 wom} + +# Comprehensive tests + +test io-6.10 {Tcl_GetsObj: lf mode: no chars} { + set f [open test1 w] + close $f + set f [open test1] + fconfigure $f -translation lf + set x [list [gets $f line] $line] + close $f + set x +} {-1 {}} +test io-6.11 {Tcl_GetsObj: lf mode: lone \n} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\n" + close $f + set f [open test1] + fconfigure $f -translation lf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {0 {} -1 {}} +test io-6.12 {Tcl_GetsObj: lf mode: lone \r} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r" + close $f + set f [open test1] + fconfigure $f -translation lf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 1 "\r" -1 ""] +test io-6.13 {Tcl_GetsObj: lf mode: 1 char} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f a + close $f + set f [open test1] + fconfigure $f -translation lf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\n" + close $f + set f [open test1] + fconfigure $f -translation lf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.15 {Tcl_GetsObj: lf mode: several chars} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" + close $f + set f [open test1] + fconfigure $f -translation lf + set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""] +test io-6.16 {Tcl_GetsObj: cr mode: no chars} { + set f [open test1 w] + close $f + set f [open test1] + fconfigure $f -translation cr + set x [list [gets $f line] $line] + close $f + set x +} {-1 {}} +test io-6.17 {Tcl_GetsObj: cr mode: lone \n} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\n" + close $f + set f [open test1] + fconfigure $f -translation cr + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 1 "\n" -1 ""] +test io-6.18 {Tcl_GetsObj: cr mode: lone \r} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r" + close $f + set f [open test1] + fconfigure $f -translation cr + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {0 {} -1 {}} +test io-6.19 {Tcl_GetsObj: cr mode: 1 char} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f a + close $f + set f [open test1] + fconfigure $f -translation cr + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\r" + close $f + set f [open test1] + fconfigure $f -translation cr + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.21 {Tcl_GetsObj: cr mode: several chars} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" + close $f + set f [open test1] + fconfigure $f -translation cr + set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""] +test io-6.22 {Tcl_GetsObj: crlf mode: no chars} { + set f [open test1 w] + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line] + close $f + set x +} {-1 {}} +test io-6.23 {Tcl_GetsObj: crlf mode: lone \n} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\n" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 1 "\n" -1 ""] +test io-6.24 {Tcl_GetsObj: crlf mode: lone \r} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 1 "\r" -1 ""] +test io-6.25 {Tcl_GetsObj: crlf mode: \r\r} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r\r" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 2 "\r\r" -1 ""] +test io-6.26 {Tcl_GetsObj: crlf mode: \r\n} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r\n" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 0 "" -1 ""] +test io-6.27 {Tcl_GetsObj: crlf mode: 1 char} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f a + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\r\n" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.29 {Tcl_GetsObj: crlf mode: several chars} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""] +test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} { + # if (eol >= dstEnd) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456789012345\r\nabcdefghijklmnoprstuvwxyz" + close $f + set f [open test1] + fconfigure $f -translation crlf -buffersize 16 + set x [list [gets $f line] $line [testchannel inputbuffered $f]] + close $f + set x +} [list 15 "123456789012345" 15] +test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio} { + # (FilterInputBytes() != 0) + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {crlf lf} -buffering none + puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r" + fconfigure $f -buffersize 16 + set x [gets $f] + fconfigure $f -blocking 0 + lappend x [gets $f line] $line [fblocked $f] [testchannel inputbuffered $f] + close $f + set x +} [list "bbbbbbbbbbbbbb" -1 "" 1 16] +test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} { + # not (FilterInputBytes() != 0) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456789012345\r\n123" + close $f + set f [open test1] + fconfigure $f -translation crlf -buffersize 16 + set x [list [gets $f line] $line [tell $f] [testchannel inputbuffered $f]] + close $f + set x +} [list 15 "123456789012345" 17 3] +test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { + # eol still equals dstEnd + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456789012345\r" + close $f + set f [open test1] + fconfigure $f -translation crlf -buffersize 16 + set x [list [gets $f line] $line [eof $f]] + close $f + set x +} [list 16 "123456789012345\r" 1] +test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} { + # not (*eol == '\n') + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456789012345\rabcd\r\nefg" + close $f + set f [open test1] + fconfigure $f -translation crlf -buffersize 16 + set x [list [gets $f line] $line [tell $f]] + close $f + set x +} [list 20 "123456789012345\rabcd" 22] +test io-6.35 {Tcl_GetsObj: auto mode: no chars} { + set f [open test1 w] + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line] + close $f + set x +} {-1 {}} +test io-6.36 {Tcl_GetsObj: auto mode: lone \n} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\n" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 0 "" -1 ""] +test io-6.37 {Tcl_GetsObj: auto mode: lone \r} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 0 "" -1 ""] +test io-6.38 {Tcl_GetsObj: auto mode: \r\r} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r\r" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 0 "" 0 "" -1 ""] +test io-6.39 {Tcl_GetsObj: auto mode: \r\n} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r\n" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 0 "" -1 ""] +test io-6.40 {Tcl_GetsObj: auto mode: 1 char} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f a + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\r\n" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.42 {Tcl_GetsObj: auto mode: several chars} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line [gets $f line] $line] + lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line + close $f + set x +} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""] +test io-6.43 {Tcl_GetsObj: input saw cr} {stdio} { + # if (chanPtr->flags & INPUT_SAW_CR) + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto lf} -buffering none + puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" + fconfigure $f -buffersize 16 + set x [list [gets $f]] + fconfigure $f -blocking 0 + lappend x [gets $f line] $line [testchannel queuedcr $f] + fconfigure $f -blocking 1 + puts -nonewline $f "\nabcd\refg\x1a" + lappend x [gets $f line] $line [testchannel queuedcr $f] + lappend x [gets $f line] $line + close $f + set x +} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] +test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio} { + # not (*eol == '\n') + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto lf} -buffering none + puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" + fconfigure $f -buffersize 16 + set x [list [gets $f]] + fconfigure $f -blocking 0 + lappend x [gets $f line] $line [testchannel queuedcr $f] + fconfigure $f -blocking 1 + puts -nonewline $f "abcd\refg\x1a" + lappend x [gets $f line] $line [testchannel queuedcr $f] + lappend x [gets $f line] $line + close $f + set x +} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] +test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio} { + # Tcl_ExternalToUtf() + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto lf} -buffering none + fconfigure $f -encoding unicode + puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" + fconfigure $f -buffersize 16 + gets $f + fconfigure $f -blocking 0 + set x [list [gets $f line] $line [testchannel queuedcr $f]] + fconfigure $f -blocking 1 + puts -nonewline $f "\nabcd\refg" + lappend x [gets $f line] $line [testchannel queuedcr $f] + close $f + set x +} [list 15 "123456789abcdef" 1 4 "abcd" 0] +test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio} { + # memmove() + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto lf} -buffering none + puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" + fconfigure $f -buffersize 16 + gets $f + fconfigure $f -blocking 0 + set x [list [gets $f line] $line [testchannel queuedcr $f]] + fconfigure $f -blocking 1 + puts -nonewline $f "\n\x1a" + lappend x [gets $f line] $line [testchannel queuedcr $f] + close $f + set x +} [list 15 "123456789abcdef" 1 -1 "" 0] +test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} { + # (eol == dstEnd) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456789012345\r\nabcdefghijklmnopq" + close $f + set f [open test1] + fconfigure $f -translation auto -buffersize 16 + set x [list [gets $f] [testchannel inputbuffered $f]] + close $f + set x +} [list "123456789012345" 15] +test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} { + # PeekAhead() did not get any, so (eol >= dstEnd) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456789012345\r" + close $f + set f [open test1] + fconfigure $f -translation auto -buffersize 16 + set x [list [gets $f] [testchannel queuedcr $f]] + close $f + set x +} [list "123456789012345" 1] +test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} { + # if (*eol == '\n') {skip++} + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456\r\n78901" + close $f + set f [open test1] + set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]] + close $f + set x +} [list "123456" 0 8 "78901"] +test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} { + # not (*eol == '\n') + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456\r78901" + close $f + set f [open test1] + set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]] + close $f + set x +} [list "123456" 0 7 "78901"] +test io-6.51 {Tcl_GetsObj: auto mode: \n} { + # else if (*eol == '\n') {goto gotoeol;} + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456\n78901" + close $f + set f [open test1] + set x [list [gets $f] [tell $f] [gets $f]] + close $f + set x +} [list "123456" 7 "78901"] +test io-6.52 {Tcl_GetsObj: saw EOF character} { + # if (eof != NULL) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456\x1ak9012345\r" + close $f + set f [open test1] + fconfigure $f -eofchar \x1a + set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]] + close $f + set x +} [list "123456" 0 6 ""] +test io-6.53 {Tcl_GetsObj: device EOF} { + # didn't produce any bytes + + set f [open test1 w] + close $f + set f [open test1] + set x [list [gets $f line] $line [eof $f]] + close $f + set x +} {-1 {} 1} +test io-6.54 {Tcl_GetsObj: device EOF} { + # got some bytes before EOF. + + set f [open test1 w] + puts -nonewline $f abc + close $f + set f [open test1] + set x [list [gets $f line] $line [eof $f]] + close $f + set x +} {3 abc 1} +test io-6.55 {Tcl_GetsObj: overconverted} { + # Tcl_ExternalToUtf(), make sure state updated + + set f [open test1 w] + fconfigure $f -encoding iso2022-jp + puts $f "there\u4e00ok\n\u4e01more bytes\nhere" + close $f + set f [open test1] + fconfigure $f -encoding iso2022-jp + set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] +test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio} { + update + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -buffering none + puts -nonewline $f "foobar" + fconfigure $f -blocking 0 + set x {} + after 500 { lappend x timeout } + fileevent $f readable { lappend x [gets $f] } + vwait x + vwait x + fconfigure $f -blocking 1 + puts -nonewline $f "baz\n" + after 500 { lappend x timeout } + fconfigure $f -blocking 0 + vwait x + vwait x + close $f + set x +} {{} timeout foobarbaz timeout} + +test io-7.1 {FilterInputBytes: split up character at end of buffer} { + # (result == TCL_CONVERT_MULTIBYTE) + + set f [open test1 w] + fconfigure $f -encoding shiftjis + puts $f "1234567890123\uff10\uff11\uff12\uff13\uff14\nend" + close $f + set f [open test1] + fconfigure $f -encoding shiftjis -buffersize 16 + set x [gets $f] + close $f + set x +} "1234567890123\uff10\uff11\uff12\uff13\uff14" +test io-7.2 {FilterInputBytes: split up character in middle of buffer} { + # (bufPtr->nextAdded < bufPtr->bufLength) + + set f [open test1 w] + fconfigure $f -encoding binary + puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82" + close $f + set f [open test1] + fconfigure $f -encoding shiftjis + set x [list [gets $f line] $line [eof $f]] + close $f + set x +} [list 10 "1234567890" 0] +test io-7.3 {FilterInputBytes: split up character at EOF} { + set f [open test1 w] + fconfigure $f -encoding binary + puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" + close $f + set f [open test1] + fconfigure $f -encoding shiftjis + set x [list [gets $f line] $line] + lappend x [tell $f] [testchannel inputbuffered $f] [eof $f] + lappend x [gets $f line] $line + close $f + set x +} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] +test io-7.4 {FilterInputBytes: recover from split up character} {stdio} { + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -encoding binary -buffering none + puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" + fconfigure $f -encoding shiftjis -blocking 0 + fileevent $f read "ready $f" + set x {} + proc ready {f} { + lappend ::x [gets $f line] $line [fblocked $f] + } + vwait x + fconfigure $f -encoding binary -blocking 1 + puts $f "\x51\x82\x52" + fconfigure $f -encoding shiftjis -blocking 0 + vwait x + close $f + set x +} [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0] + +test io-8.1 {PeekAhead: only go to device if no more cached data} { + # (bufPtr->nextPtr == NULL) + + set f [open "test1" w] + fconfigure $f -encoding ascii -translation lf + puts -nonewline $f "123456789012345\r\n2345678" + close $f + set f [open "test1"] + fconfigure $f -encoding ascii -translation auto -buffersize 16 + # here + gets $f + set x [testchannel inputbuffered $f] + close $f + set x +} "7" +test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio} { + # not (bufPtr->nextPtr == NULL) + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation lf -encoding ascii -buffering none + puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz" + set x {} + fileevent $f read "ready $f" + proc ready {f} { + lappend ::x [gets $f line] $line [testchannel inputbuffered $f] + } + fconfigure $f -encoding unicode -buffersize 16 -blocking 0 + vwait x + fconfigure $f -translation auto -encoding ascii -blocking 1 + # here + vwait x + close $f + set x +} [list -1 "" 42 15 "123456789012345" 25] +test io-8.3 {PeekAhead: no cached data available} {stdio} { + # (bytesLeft == 0) + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto binary} + puts -nonewline $f "abcdefghijklmno\r" + flush $f + set x [list [gets $f line] $line [testchannel queuedcr $f]] + close $f + set x +} [list 15 "abcdefghijklmno" 1] +set a "123456789012345678901234567890" +append a "123456789012345678901234567890" +append a "1234567890123456789012345678901" +test io-8.4 {PeekAhead: cached data available in this buffer} { + # not (bytesLeft == 0) + + set f [open test1 w+] + fconfigure $f -translation binary + puts $f "${a}\r\nabcdef" + close $f + set f [open test1] + fconfigure $f -encoding binary -translation auto + + # "${a}\r" was converted in one operation (because ENCODING_LINESIZE + # is 30). To check if "\n" follows, calls PeekAhead and determines + # that cached data is available in buffer w/o having to call driver. + + set x [gets $f] + close $f + set x +} $a +unset a +test io-8.5 {PeekAhead: don't peek if last read was short} {stdio} { + # (bufPtr->nextAdded < bufPtr->length) + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto binary} + puts -nonewline $f "abcdefghijklmno\r" + flush $f + # here + set x [list [gets $f line] $line [testchannel queuedcr $f]] + close $f + set x +} {15 abcdefghijklmno 1} +test io-8.6 {PeekAhead: change to non-blocking mode} {stdio} { + # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto binary} -buffersize 16 + puts -nonewline $f "abcdefghijklmno\r" + flush $f + # here + set x [list [gets $f line] $line [testchannel queuedcr $f]] + close $f + set x +} {15 abcdefghijklmno 1} +test io-8.7 {PeekAhead: cleanup} {stdio} { + # Make sure bytes are removed from buffer. + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto binary} -buffering none + puts -nonewline $f "abcdefghijklmno\r" + # here + set x [list [gets $f line] $line [testchannel queuedcr $f]] + puts -nonewline $f "\x1a" + lappend x [gets $f line] $line + close $f + set x +} {15 abcdefghijklmno 1 -1 {}} + + +test io-9.1 {CommonGetsCleanup} { +} {} + +test io-10.1 {Tcl_ReadChars: CheckChannelErrors} { + # no test, need to cause an async error. +} {} +test io-10.2 {Tcl_ReadChars: loop until enough copied} { + # one time + # for (copied = 0; (unsigned) toRead > 0; ) + + set f [open "test1" w] + puts $f abcdefghijklmnop + close $f + + set f [open "test1"] + set x [read $f 5] + close $f + set x +} {abcde} +test io-10.3 {Tcl_ReadChars: loop until enough copied} { + # multiple times + # for (copied = 0; (unsigned) toRead > 0; ) + + set f [open "test1" w] + puts $f abcdefghijklmnopqrstuvwxyz + close $f + + set f [open "test1"] + fconfigure $f -buffersize 16 + # here + set x [read $f 19] + close $f + set x +} {abcdefghijklmnopqrs} +test io-10.4 {Tcl_ReadChars: no more in channel buffer} { + # (copiedNow < 0) + + set f [open "test1" w] + puts -nonewline $f abcdefghijkl + close $f + + set f [open "test1"] + # here + set x [read $f 1000] + close $f + set x +} {abcdefghijkl} +test io-10.5 {Tcl_ReadChars: stop on EOF} { + # (chanPtr->flags & CHANNEL_EOF) + + set f [open "test1" w] + puts -nonewline $f abcdefghijkl + close $f + + set f [open "test1"] + # here + set x [read $f 1000] + close $f + set x +} {abcdefghijkl} + +test io-11.1 {ReadBytes: want to read a lot} { + # ((unsigned) toRead > (unsigned) srcLen) + + set f [open "test1" w] + puts -nonewline $f abcdefghijkl + close $f + set f [open "test1"] + fconfigure $f -encoding binary + # here + set x [read $f 1000] + close $f + set x +} {abcdefghijkl} +test io-11.2 {ReadBytes: want to read all} { + # ((unsigned) toRead > (unsigned) srcLen) + + set f [open "test1" w] + puts -nonewline $f abcdefghijkl + close $f + set f [open "test1"] + fconfigure $f -encoding binary + # here + set x [read $f] + close $f + set x +} {abcdefghijkl} +test io-11.3 {ReadBytes: allocate more space} { + # (toRead > length - offset - 1) + + set f [open "test1" w] + puts -nonewline $f abcdefghijklmnopqrstuvwxyz + close $f + set f [open "test1"] + fconfigure $f -buffersize 16 -encoding binary + # here + set x [read $f] + close $f + set x +} {abcdefghijklmnopqrstuvwxyz} +test io-11.4 {ReadBytes: EOF char found} { + # (TranslateInputEOL() != 0) + + set f [open "test1" w] + puts $f abcdefghijklmnopqrstuvwxyz + close $f + set f [open "test1"] + fconfigure $f -eofchar m -encoding binary + # here + set x [list [read $f] [eof $f] [read $f] [eof $f]] + close $f + set x +} [list "abcdefghijkl" 1 "" 1] + +test io-12.1 {ReadChars: want to read a lot} { + # ((unsigned) toRead > (unsigned) srcLen) + + set f [open "test1" w] + puts -nonewline $f abcdefghijkl + close $f + set f [open "test1"] + # here + set x [read $f 1000] + close $f + set x +} {abcdefghijkl} +test io-12.2 {ReadChars: want to read all} { + # ((unsigned) toRead > (unsigned) srcLen) + + set f [open "test1" w] + puts -nonewline $f abcdefghijkl + close $f + set f [open "test1"] + # here + set x [read $f] + close $f + set x +} {abcdefghijkl} +test io-12.3 {ReadChars: allocate more space} { + # (toRead > length - offset - 1) + + set f [open "test1" w] + puts -nonewline $f abcdefghijklmnopqrstuvwxyz + close $f + set f [open "test1"] + fconfigure $f -buffersize 16 + # here + set x [read $f] + close $f + set x +} {abcdefghijklmnopqrstuvwxyz} +test io-12.4 {ReadChars: split-up char} {stdio} { + # (srcRead == 0) + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -encoding binary -buffering none -buffersize 16 + puts -nonewline $f "123456789012345\x96" + fconfigure $f -encoding shiftjis -blocking 0 + + fileevent $f read "ready $f" + proc ready {f} { + lappend ::x [read $f] [testchannel inputbuffered $f] + } + set x {} + + fconfigure $f -encoding shiftjis + vwait x + fconfigure $f -encoding binary -blocking 1 + puts -nonewline $f "\x7b" + fconfigure $f -encoding shiftjis -blocking 0 + vwait x + close $f + set x +} [list "123456789012345" 1 "\u672c" 0] +test io-12.5 {ReadChars: fileevents on partial characters} {stdio} { + set f [open test1 w] + puts $f { + fconfigure stdout -encoding binary -buffering none + gets stdin; puts -nonewline "\xe7" + gets stdin; puts -nonewline "\x89" + gets stdin; puts -nonewline "\xa6" + } + close $f + set f [open "|[list $tcltest test1]" r+] + fileevent $f readable { + lappend x [read $f] + if {[eof $f]} { + lappend x eof + } + } + puts $f "go1" + flush $f + fconfigure $f -blocking 0 -encoding utf-8 + set x {} + vwait x + after 500 { lappend x timeout } + vwait x + puts $f "go2" + flush $f + vwait x + after 500 { lappend x timeout } + vwait x + puts $f "go3" + flush $f + vwait x + vwait x + lappend x [catch {close $f} msg] $msg + set x +} "{} timeout {} timeout \u7266 {} eof 0 {}" + +test io-13.1 {TranslateInputEOL: cr mode} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\rdef\r" + close $f + set f [open test1] + fconfigure $f -translation cr + set x [read $f] + close $f + set x +} "abcd\ndef\n" +test io-13.2 {TranslateInputEOL: crlf mode} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef\r\n" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "abcd\ndef\n" +test io-13.3 {TranslateInputEOL: crlf mode: naked cr} { + # (src >= srcMax) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef\r" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "abcd\ndef\r" +test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { + # (src >= srcMax) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef\rfgh" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "abcd\ndef\rfgh" +test io-13.5 {TranslateInputEOL: crlf mode: naked lf} { + # (src >= srcMax) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef\nfgh" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "abcd\ndef\nfgh" +test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio} { + # (chanPtr->flags & INPUT_SAW_CR) + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -blocking 0 -buffering none -translation {auto lf} + + fileevent $f read "ready $f" + proc ready {f} { + lappend ::x [read $f] [testchannel queuedcr $f] + } + set x {} + + puts -nonewline $f "abcdefghj\r" + vwait x + + puts -nonewline $f "\n01234" + vwait x + + close $f + set x +} [list "abcdefghj\n" 1 "01234" 0] +test io-13.7 {TranslateInputEOL: auto mode: naked \r} { + # (src >= srcMax) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [read $f] [testchannel queuedcr $f]] + close $f + set x +} [list "abcd\n" 1] +test io-13.8 {TranslateInputEOL: auto mode: \r\n} { + # (*src == '\n') + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [read $f] + close $f + set x +} "abcd\ndef" +test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\rdef" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [read $f] + close $f + set x +} "abcd\ndef" +test io-13.10 {TranslateInputEOL: auto mode: \n} { + # not (*src == '\r') + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\ndef" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [read $f] + close $f + set x +} "abcd\ndef" +test io-13.11 {TranslateInputEOL: EOF char} { + # (*chanPtr->inEofChar != '\0') + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\ndefgh" + close $f + set f [open test1] + fconfigure $f -translation auto -eofchar e + set x [read $f] + close $f + set x +} "abcd\nd" +test io-13.12 {TranslateInputEOL: find EOF char in src} { + # (*chanPtr->inEofChar != '\0') + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r\n\r\n\r\nab\r\n\r\ndef\r\n\r\n\r\n" + close $f + set f [open test1] + fconfigure $f -translation auto -eofchar e + set x [read $f] + close $f + set x +} "\n\n\nab\n\nd" + # Test standard handle management. The functions tested are # Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are # also testing channel table management. @@ -133,7 +1555,7 @@ if {$tcl_platform(platform) == "macintosh"} { } else { set consoleFileNames [lsort [testchannel open]] } -test io-1.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} { +test io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} { set l "" lappend l [fconfigure stdin -buffering] lappend l [fconfigure stdout -buffering] @@ -141,7 +1563,7 @@ test io-1.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} { lappend l [lsort [testchannel open]] set l } [list line line none $consoleFileNames] -test io-1.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { +test io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { interp create x set l "" lappend l [x eval {fconfigure stdin -buffering}] @@ -150,7 +1572,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} {stdio} { +test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {stdio} { set f [open test1 w] puts $f { close stdin @@ -179,7 +1601,7 @@ out } {err }} # This test relies on the fact that the smallest available fd is used first. -test io-1.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOnly} { +test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOnly} { set f [open test1 w] puts $f { close stdin close stdout @@ -207,7 +1629,7 @@ file1 } {file2 }} catch {interp delete z} -test io-1.5 {Tcl_GetChannel: stdio name translation} { +test io-14.5 {Tcl_GetChannel: stdio name translation} { interp create z eof stdin catch {z eval flush stdin} msg1 @@ -217,7 +1639,7 @@ test io-1.5 {Tcl_GetChannel: stdio name translation} { interp delete z set result } {{channel "stdin" wasn't opened for writing} {} {can not find channel named "stdin"}} -test io-1.6 {Tcl_GetChannel: stdio name translation} { +test io-14.6 {Tcl_GetChannel: stdio name translation} { interp create z eof stdout catch {z eval flush stdout} msg1 @@ -227,7 +1649,7 @@ test io-1.6 {Tcl_GetChannel: stdio name translation} { interp delete z set result } {{} {} {can not find channel named "stdout"}} -test io-1.7 {Tcl_GetChannel: stdio name translation} { +test io-14.7 {Tcl_GetChannel: stdio name translation} { interp create z eof stderr catch {z eval flush stderr} msg1 @@ -237,7 +1659,7 @@ test io-1.7 {Tcl_GetChannel: stdio name translation} { interp delete z set result } {{} {} {can not find channel named "stderr"}} -test io-1.8 {reuse of stdio special channels} {unixOnly} { +test io-14.8 {reuse of stdio special channels} {stdio} { removeFile script removeFile test1 set f [open script w] @@ -255,7 +1677,7 @@ test io-1.8 {reuse of stdio special channels} {unixOnly} { close $f set c } hello -test io-1.9 {reuse of stdio special channels} {stdio} { +test io-14.9 {reuse of stdio special channels} {stdio} { removeFile script removeFile test1 set f [open script w] @@ -274,8 +1696,11 @@ test io-1.9 {reuse of stdio special channels} {stdio} { set c } hello -# Must add test function for testing Tcl_CreateCloseHandler and -# Tcl_DeleteCloseHandler. +test io-15.1 {Tcl_CreateCloseHandler} { +} {} + +test io-16.1 {Tcl_DeleteCloseHandler} { +} {} # Test channel table management. The functions tested are # GetChannelTable, DeleteChannelTable, Tcl_RegisterChannel, @@ -284,7 +1709,7 @@ test io-1.9 {reuse of stdio special channels} {stdio} { # These functions use "eof stdin" to ensure that the standard # channels are added to the channel table of the interpreter. -test io-2.1 {GetChannelTable, DeleteChannelTable on std handles} { +test io-17.1 {GetChannelTable, DeleteChannelTable on std handles} { set l1 [testchannel refcount stdin] eof stdin interp create x @@ -296,7 +1721,7 @@ test io-2.1 {GetChannelTable, DeleteChannelTable on std handles} { lappend l [expr [testchannel refcount stdin] - $l1] set l } {0 1 0} -test io-2.2 {GetChannelTable, DeleteChannelTable on std handles} { +test io-17.2 {GetChannelTable, DeleteChannelTable on std handles} { set l1 [testchannel refcount stdout] eof stdin interp create x @@ -308,7 +1733,7 @@ test io-2.2 {GetChannelTable, DeleteChannelTable on std handles} { lappend l [expr [testchannel refcount stdout] - $l1] set l } {0 1 0} -test io-2.3 {GetChannelTable, DeleteChannelTable on std handles} { +test io-17.3 {GetChannelTable, DeleteChannelTable on std handles} { set l1 [testchannel refcount stderr] eof stdin interp create x @@ -320,7 +1745,8 @@ test io-2.3 {GetChannelTable, DeleteChannelTable on std handles} { lappend l [expr [testchannel refcount stderr] - $l1] set l } {0 1 0} -test io-2.4 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { + +test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { removeFile test1 set l "" set f [open test1 w] @@ -334,7 +1760,7 @@ test io-2.4 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { string compare [string tolower $l] \ [list 1 [format "can not find channel named \"%s\"" $f]] } 0 -test io-2.5 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { +test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { removeFile test1 set l "" set f [open test1 w] @@ -355,7 +1781,7 @@ test io-2.5 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { string compare [string tolower $l] \ [list 1 2 1 1 [format "can not find channel named \"%s\"" $f]] } 0 -test io-2.6 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { +test io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { removeFile test1 set l "" set f [open test1 w] @@ -374,20 +1800,21 @@ test io-2.6 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { string compare [string tolower $l] \ [list 1 2 1 [format "can not find channel named \"%s\"" $f]] } 0 -test io-2.7 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} { + +test io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} { eof stdin } 0 -test io-2.8 {testing Tcl_GetChannel, user opened handle} { +test io-19.2 {testing Tcl_GetChannel, user opened handle} { removeFile test1 set f [open test1 w] set x [eof $f] close $f set x } 0 -test io-2.9 {Tcl_GetChannel, channel not found} { +test io-19.3 {Tcl_GetChannel, channel not found} { list [catch {eof file34} msg] $msg } {1 {can not find channel named "file34"}} -test io-2.10 {Tcl_CreateChannel, insertion into channel table} { +test io-19.4 {Tcl_CreateChannel, insertion into channel table} { removeFile test1 set f [open test1 w] set l "" @@ -402,27 +1829,79 @@ test io-2.10 {Tcl_CreateChannel, insertion into channel table} { [list 0 [format "can not find channel named \"%s\"" $f]] } 0 +test io-20.1 {Tcl_CreateChannel: initial settings} { + set a [open test2 w] + set old [testencoding system] + testencoding system ascii + set f [open test1 w] + set x [fconfigure $f -encoding] + close $f + testencoding system $old + close $a + set x +} {ascii} +test io-20.2 {Tcl_CreateChannel: initial settings} {pc} { + set f [open test1 w+] + set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] + close $f + set x +} [list [list \x1a ""] {auto crlf}] +test io-20.3 {Tcl_CreateChannel: initial settings} {unix} { + set f [open test1 w+] + set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] + close $f + set x +} {{{} {}} {auto lf}} +test io-20.4 {Tcl_CreateChannel: initial settings} {mac} { + set f [open test1 w+] + set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] + close $f + set x +} {{{} {}} {auto cr}} +test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio} { + set f [open script w] + puts $f { + close stdout + set f1 [open stdout w] + fconfigure $f1 -buffersize 777 + puts stderr [fconfigure stdout -buffersize] + } + close $f + set f [open "|[list $tcltest script]"] + catch {close $f} msg + set msg +} {777} + +test io-21.1 {CloseChannelsOnExit} { +} {} + # Test management of attributes associated with a channel, such as # its default translation, its name and type, etc. The functions # tested in this group are Tcl_GetChannelName, # Tcl_GetChannelType and Tcl_GetChannelFile. Tcl_GetChannelInstanceData # not tested because files do not use the instance data. -test io-3.1 {Tcl_GetChannelName} { +test io-22.1 {Tcl_GetChannelMode} { + # Not used anywhere in Tcl. +} {} + +test io-23.1 {Tcl_GetChannelName} { removeFile test1 set f [open test1 w] set n [testchannel name $f] close $f string compare $n $f } 0 -test io-3.2 {Tcl_GetChannelType} { + +test io-24.1 {Tcl_GetChannelType} { removeFile test1 set f [open test1 w] set t [testchannel type $f] close $f string compare $t file } 0 -test io-3.3 {Tcl_GetChannelFile, input} { + +test io-25.1 {Tcl_GetChannelHandle, input} { set f [open test1 w] fconfigure $f -translation lf -eofchar {} puts $f "1234567890\n098765432" @@ -435,7 +1914,7 @@ test io-3.3 {Tcl_GetChannelFile, input} { close $f set l } {10 11} -test io-3.4 {Tcl_GetChannelFile, output} { +test io-25.2 {Tcl_GetChannelHandle, output} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -451,9 +1930,18 @@ test io-3.4 {Tcl_GetChannelFile, output} { set l } {6 6 0 6} +test io-26.1 {Tcl_GetChannelInstanceData} {stdio} { + # "pid" command uses Tcl_GetChannelInstanceData + # Don't care what pid is (but must be a number), just want to exercise it. + + set f [open "|[list $tcltest << exit]"] + expr [pid $f] + close $f +} {} + # Test flushing. The functions tested here are FlushChannel. -test io-4.1 {FlushChannel, no output buffered} { +test io-27.1 {FlushChannel, no output buffered} { removeFile test1 set f [open test1 w] flush $f @@ -461,7 +1949,7 @@ test io-4.1 {FlushChannel, no output buffered} { close $f set s } 0 -test io-4.2 {FlushChannel, some output buffered} { +test io-27.2 {FlushChannel, some output buffered} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -474,7 +1962,7 @@ test io-4.2 {FlushChannel, some output buffered} { lappend l [file size test1] set l } {0 6 6} -test io-4.3 {FlushChannel, implicit flush on close} { +test io-27.3 {FlushChannel, implicit flush on close} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -485,7 +1973,7 @@ test io-4.3 {FlushChannel, implicit flush on close} { lappend l [file size test1] set l } {0 6} -test io-4.4 {FlushChannel, implicit flush when buffer fills} { +test io-27.4 {FlushChannel, implicit flush when buffer fills} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -501,7 +1989,7 @@ test io-4.4 {FlushChannel, implicit flush when buffer fills} { close $f set l } {0 60 72} -test io-4.5 {FlushChannel, implicit flush when buffer fills and on close} {unixOrPc} { +test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} {unixOrPc} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffersize 60 -eofchar {} @@ -515,7 +2003,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} {stdio && asyncPipeClose} { +test io-27.6 {FlushChannel, async flushing, async close} {stdio && asyncPipeClose} { removeFile pipe removeFile output set f [open pipe w] @@ -546,7 +2034,7 @@ test io-4.6 {FlushChannel, async flushing, async close} {stdio && asyncPipeClose update } if {$counter == 1000} { - set result probably_broken + set result "file size only [file size output]" } else { set result ok } @@ -554,7 +2042,7 @@ test io-4.6 {FlushChannel, async flushing, async close} {stdio && asyncPipeClose # Tests closing a channel. The functions tested are CloseChannel and Tcl_Close. -test io-5.1 {CloseChannel called when all references are dropped} { +test io-28.1 {CloseChannel called when all references are dropped} { removeFile test1 set f [open test1 w] interp create x @@ -567,7 +2055,7 @@ test io-5.1 {CloseChannel called when all references are dropped} { close $f set l } {2 1} -test io-5.2 {CloseChannel called when all references are dropped} { +test io-28.2 {CloseChannel called when all references are dropped} { removeFile test1 set f [open test1 w] interp create x @@ -582,7 +2070,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 nonPortable tempNotPc} { +test io-28.3 {CloseChannel, not called before output queue is empty} {stdio asyncPipeClose nonPortable} { removeFile pipe removeFile output set f [open pipe w] @@ -613,9 +2101,6 @@ test io-5.3 {CloseChannel, not called before output queue is empty} {unixOrPc as 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 @@ -630,7 +2115,7 @@ test io-5.3 {CloseChannel, not called before output queue is empty} {unixOrPc as set result ok } } ok -test io-5.4 {Tcl_Close} { +test io-28.4 {Tcl_Close} { removeFile test1 set l "" lappend l [lsort [testchannel open]] @@ -643,7 +2128,7 @@ test io-5.4 {Tcl_Close} { $consoleFileNames] string compare $l $x } 0 -test io-5.5 {Tcl_Close vs standard handles} {unixOnly} { +test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly} { removeFile script set f [open script w] puts $f { @@ -657,13 +2142,10 @@ test io-5.5 {Tcl_Close vs standard handles} {unixOnly} { set l } {file1 file2} -# Test output on channels. The functions tested are Tcl_Write -# and Tcl_Flush. - -test io-6.1 {Tcl_Write, channel not writable} { +test io-29.1 {Tcl_WriteChars, channel not writable} { list [catch {puts stdin hello} msg] $msg } {1 {channel "stdin" wasn't opened for writing}} -test io-6.2 {Tcl_Write, empty string} { +test io-29.2 {Tcl_WriteChars, empty string} { removeFile test1 set f [open test1 w] fconfigure $f -eofchar {} @@ -671,7 +2153,7 @@ test io-6.2 {Tcl_Write, empty string} { close $f file size test1 } 0 -test io-6.3 {Tcl_Write, nonempty string} { +test io-29.3 {Tcl_WriteChars, nonempty string} { removeFile test1 set f [open test1 w] fconfigure $f -eofchar {} @@ -679,7 +2161,7 @@ test io-6.3 {Tcl_Write, nonempty string} { close $f file size test1 } 5 -test io-6.4 {Tcl_Write, buffering in full buffering mode} { +test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering full -eofchar {} @@ -693,7 +2175,7 @@ test io-6.4 {Tcl_Write, buffering in full buffering mode} { close $f set l } {6 0 0 6} -test io-6.5 {Tcl_Write, buffering in line buffering mode} { +test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering line -eofchar {} @@ -707,7 +2189,7 @@ test io-6.5 {Tcl_Write, buffering in line buffering mode} { close $f set l } {5 0 0 11} -test io-6.6 {Tcl_Write, buffering in no buffering mode} { +test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering none -eofchar {} @@ -721,7 +2203,8 @@ test io-6.6 {Tcl_Write, buffering in no buffering mode} { close $f set l } {0 5 0 11} -test io-6.7 {Tcl_Flush, full buffering} { + +test io-29.7 {Tcl_Flush, full buffering} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering full -eofchar {} @@ -738,7 +2221,7 @@ test io-6.7 {Tcl_Flush, full buffering} { close $f set l } {5 0 11 0 0 11} -test io-6.8 {Tcl_Flush, full buffering} { +test io-29.8 {Tcl_Flush, full buffering} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering line @@ -758,34 +2241,34 @@ test io-6.8 {Tcl_Flush, full buffering} { close $f set l } {5 0 0 5 0 11 0 11} -test io-6.9 {Tcl_Flush, channel not writable} { +test io-29.9 {Tcl_Flush, channel not writable} { list [catch {flush stdin} msg] $msg } {1 {channel "stdin" wasn't opened for writing}} -test io-6.10 {Tcl_Write, looping and buffering} { +test io-29.10 {Tcl_WriteChars, looping and buffering} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} set f2 [open longfile r] for {set x 0} {$x < 10} {incr x} { - puts $f1 [gets $f2] + puts $f1 [gets $f2] } close $f2 close $f1 file size test1 } 387 -test io-6.11 {Tcl_Write, no newline, implicit flush} { +test io-29.11 {Tcl_WriteChars, no newline, implicit flush} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -eofchar {} set f2 [open longfile r] for {set x 0} {$x < 10} {incr x} { - puts -nonewline $f1 [gets $f2] + puts -nonewline $f1 [gets $f2] } close $f1 close $f2 file size test1 } 377 -test io-6.12 {Tcl_Write on a pipe} {stdio} { +test io-29.12 {Tcl_WriteChars on a pipe} {stdio} { removeFile test1 removeFile pipe set f1 [open pipe w] @@ -800,17 +2283,17 @@ test io-6.12 {Tcl_Write on a pipe} {stdio} { set f2 [open longfile r] set y ok for {set x 0} {$x < 10} {incr x} { - set l1 [gets $f1] - set l2 [gets $f2] - if {"$l1" != "$l2"} { - set y broken - } + set l1 [gets $f1] + set l2 [gets $f2] + if {"$l1" != "$l2"} { + set y broken + } } close $f1 close $f2 set y } ok -test io-6.13 {Tcl_Write to a pipe, line buffered} {stdio} { +test io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio} { removeFile test1 removeFile pipe set f1 [open pipe w] @@ -827,19 +2310,19 @@ test io-6.13 {Tcl_Write to a pipe, line buffered} {stdio} { puts $f1 $line set backline [gets $f1] if {"$line" != "$backline"} { - set y broken + set y broken } set line [gets $f2] puts $f1 $line set backline [gets $f1] if {"$line" != "$backline"} { - set y broken + set y broken } close $f1 close $f2 set y } ok -test io-6.14 {Tcl_Write, buffering and implicit flush at close} { +test io-29.14 {Tcl_WriteChars, buffering and implicit flush at close} { removeFile test3 set f [open test3 w] puts -nonewline $f "Text1" @@ -851,7 +2334,7 @@ test io-6.14 {Tcl_Write, buffering and implicit flush at close} { close $f set x } {Text1 Text 2 Text 3} -test io-6.15 {Tcl_Flush, channel not open for writing} { +test io-29.15 {Tcl_Flush, channel not open for writing} { removeFile test1 set fd [open test1 w] close $fd @@ -861,14 +2344,14 @@ 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} {stdio} { +test io-29.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 \ [list 1 "channel \"$fd\" wasn't opened for writing"] } 0 -test io-6.17 {Tcl_Write buffers, then Tcl_Flush flushes} { +test io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf @@ -880,7 +2363,7 @@ test io-6.17 {Tcl_Write buffers, then Tcl_Flush flushes} { close $f1 set x } 18 -test io-6.18 {Tcl_Write and Tcl_Flush intermixed} { +test io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} { removeFile test1 set x "" set f1 [open test1 w] @@ -899,7 +2382,7 @@ test io-6.18 {Tcl_Write and Tcl_Flush intermixed} { close $f1 set x } {18 24 30} -test io-6.19 {Explicit and implicit flushes} { +test io-29.19 {Explicit and implicit flushes} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -917,7 +2400,7 @@ test io-6.19 {Explicit and implicit flushes} { lappend x [file size test1] set x } {18 24 30} -test io-6.20 {Implicit flush when buffer is full} { +test io-29.20 {Implicit flush when buffer is full} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -928,14 +2411,14 @@ test io-6.20 {Implicit flush when buffer is full} { set z "" lappend z [file size test1] for {set x 0} {$x < 100} {incr x} { - puts $f1 $line + puts $f1 $line } lappend z [file size test1] close $f1 lappend z [file size test1] set z } {4096 12288 12600} -test io-6.21 {Tcl_Flush to pipe} {stdio} { +test io-29.21 {Tcl_Flush to pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 {set x [read stdin 6]} @@ -949,7 +2432,7 @@ test io-6.21 {Tcl_Flush to pipe} {stdio} { catch {close $f1} set x } "read 6 characters" -test io-6.22 {Tcl_Flush called at other end of pipe} {stdio} { +test io-29.22 {Tcl_Flush called at other end of pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 { @@ -972,7 +2455,7 @@ test io-6.22 {Tcl_Flush called at other end of pipe} {stdio} { close $f1 set x } {hello hello bye} -test io-6.23 {Tcl_Flush and line buffering at end of pipe} {stdio} { +test io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 { @@ -992,7 +2475,7 @@ test io-6.23 {Tcl_Flush and line buffering at end of pipe} {stdio} { close $f1 set x } {hello hello bye} -test io-6.24 {Tcl_Write and Tcl_Flush move end of file} { +test io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} { set f [open test3 w] puts $f "Line 1" puts $f "Line 2" @@ -1006,9 +2489,8 @@ test io-6.24 {Tcl_Write and Tcl_Flush move end of file} { close $f2 close $f set x -} {{} {Line 1 -Line 2}} -test io-6.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio} { +} "{} {Line 1\nLine 2}" +test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio} { removeFile test3 set f [open "|[list $tcltest cat | $tcltest cat > test3]" w] puts $f "Line 1" @@ -1019,10 +2501,8 @@ test io-6.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio} { set x [read $f] close $f set x -} {Line 1 -Line 2 -} -test io-6.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {unixOrPc && unixExecs && tempNotPc} { +} "Line 1\nLine 2\n" +test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio && unixExecs} { set f [open "|[list cat -u]" r+] puts $f "Line1" flush $f @@ -1030,7 +2510,7 @@ test io-6.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {unixOrPc && unix close $f set x } {Line1} -test io-6.27 {Tcl_Flush on closed pipeline} {stdio && tempNotPc} { +test io-29.27 {Tcl_Flush on closed pipeline} {stdio} { removeFile pipe set f [open pipe w] puts $f {exit} @@ -1058,7 +2538,7 @@ test io-6.27 {Tcl_Flush on closed pipeline} {stdio && tempNotPc} { regsub {".*":} $x {"":} x string tolower $x } {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}} -test io-6.28 {Tcl_Write, lf mode} { +test io-29.28 {Tcl_WriteChars, lf mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -1068,7 +2548,7 @@ test io-6.28 {Tcl_Write, lf mode} { close $f set s } 21 -test io-6.29 {Tcl_Write, cr mode} { +test io-29.29 {Tcl_WriteChars, cr mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -1076,7 +2556,7 @@ test io-6.29 {Tcl_Write, cr mode} { close $f file size test1 } 21 -test io-6.30 {Tcl_Write, crlf mode} { +test io-29.30 {Tcl_WriteChars, crlf mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -1084,7 +2564,7 @@ test io-6.30 {Tcl_Write, crlf mode} { close $f file size test1 } 25 -test io-6.31 {Tcl_Write, background flush} {stdio} { +test io-29.31 {Tcl_WriteChars, background flush} {stdio} { removeFile pipe removeFile output set f [open pipe w] @@ -1100,7 +2580,7 @@ test io-6.31 {Tcl_Write, background flush} {stdio} { close $f set x 01234567890123456789012345678901 for {set i 0} {$i < 11} {incr i} { - set x "$x$x" + set x "$x$x" } set f [open output w] close $f @@ -1110,17 +2590,17 @@ test io-6.31 {Tcl_Write, background flush} {stdio} { close $f set counter 0 while {([file size output] < 65536) && ($counter < 1000)} { - incr counter - after 5 - update + incr counter + after 5 + update } if {$counter == 1000} { - set result probably_broken + set result "file size only [file size output]" } else { - set result ok + set result ok } } ok -test io-6.32 {Tcl_Write, background flush to slow reader} {stdio && asyncPipeClose} { +test io-29.32 {Tcl_WriteChars, background flush to slow reader} {stdio && asyncPipeClose} { removeFile pipe removeFile output set f [open pipe w] @@ -1137,7 +2617,7 @@ test io-6.32 {Tcl_Write, background flush to slow reader} {stdio && asyncPipeClo close $f set x 01234567890123456789012345678901 for {set i 0} {$i < 11} {incr i} { - set x "$x$x" + set x "$x$x" } set f [open output w] close $f @@ -1147,17 +2627,17 @@ test io-6.32 {Tcl_Write, background flush to slow reader} {stdio && asyncPipeClo close $f set counter 0 while {([file size output] < 65536) && ($counter < 1000)} { - incr counter - after 20 - update + incr counter + after 20 + update } if {$counter == 1000} { - set result probably_broken + set result "file size only [file size output]" } else { - set result ok + set result ok } } ok -test io-6.33 {Tcl_Flush, implicit flush on exit} {stdio} { +test io-29.33 {Tcl_Flush, implicit flush on exit} {stdio} { set f [open script w] puts $f { set f [open test1 w] @@ -1172,12 +2652,8 @@ test io-6.33 {Tcl_Flush, implicit flush on exit} {stdio} { set r [read $f] close $f set r -} {hello -bye -strange -} - -test io-6.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac} { +} "hello\nbye\nstrange\n" +test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac} { set c 0 set x running set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz @@ -1213,7 +2689,10 @@ test io-6.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac vwait x set c } 2000 -test io-6.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket} { +test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac} { + # On Mac, this test screws up sockets such that subsequent tests using port 2828 + # either cause errors or panic(). + catch {interp delete x} catch {interp delete y} interp create x @@ -1254,7 +2733,7 @@ test io-6.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket} { # Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read. -test io-7.1 {Tcl_Write lf, Tcl_Read lf} { +test io-30.1 {Tcl_Write lf, Tcl_Read lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1266,7 +2745,7 @@ test io-7.1 {Tcl_Write lf, Tcl_Read lf} { close $f set x } "hello\nthere\nand\nhere\n" -test io-7.2 {Tcl_Write lf, Tcl_Read cr} { +test io-30.2 {Tcl_Write lf, Tcl_Read cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1278,7 +2757,7 @@ test io-7.2 {Tcl_Write lf, Tcl_Read cr} { close $f set x } "hello\nthere\nand\nhere\n" -test io-7.3 {Tcl_Write lf, Tcl_Read crlf} { +test io-30.3 {Tcl_Write lf, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1290,7 +2769,7 @@ test io-7.3 {Tcl_Write lf, Tcl_Read crlf} { close $f set x } "hello\nthere\nand\nhere\n" -test io-7.4 {Tcl_Write cr, Tcl_Read cr} { +test io-30.4 {Tcl_Write cr, Tcl_Read cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1302,7 +2781,7 @@ test io-7.4 {Tcl_Write cr, Tcl_Read cr} { close $f set x } "hello\nthere\nand\nhere\n" -test io-7.5 {Tcl_Write cr, Tcl_Read lf} { +test io-30.5 {Tcl_Write cr, Tcl_Read lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1314,7 +2793,7 @@ test io-7.5 {Tcl_Write cr, Tcl_Read lf} { close $f set x } "hello\rthere\rand\rhere\r" -test io-7.6 {Tcl_Write cr, Tcl_Read crlf} { +test io-30.6 {Tcl_Write cr, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1326,7 +2805,7 @@ test io-7.6 {Tcl_Write cr, Tcl_Read crlf} { close $f set x } "hello\rthere\rand\rhere\r" -test io-7.7 {Tcl_Write crlf, Tcl_Read crlf} { +test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1338,7 +2817,7 @@ test io-7.7 {Tcl_Write crlf, Tcl_Read crlf} { close $f set x } "hello\nthere\nand\nhere\n" -test io-7.8 {Tcl_Write crlf, Tcl_Read lf} { +test io-30.8 {Tcl_Write crlf, Tcl_Read lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1350,7 +2829,7 @@ test io-7.8 {Tcl_Write crlf, Tcl_Read lf} { close $f set x } "hello\r\nthere\r\nand\r\nhere\r\n" -test io-7.9 {Tcl_Write crlf, Tcl_Read cr} { +test io-30.9 {Tcl_Write crlf, Tcl_Read cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1362,7 +2841,7 @@ test io-7.9 {Tcl_Write crlf, Tcl_Read cr} { close $f set x } "hello\n\nthere\n\nand\n\nhere\n\n" -test io-7.10 {Tcl_Write lf, Tcl_Read auto} { +test io-30.10 {Tcl_Write lf, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1378,7 +2857,7 @@ there and here } auto} -test io-7.11 {Tcl_Write cr, Tcl_Read auto} { +test io-30.11 {Tcl_Write cr, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1394,7 +2873,7 @@ there and here } auto} -test io-7.12 {Tcl_Write crlf, Tcl_Read auto} { +test io-30.12 {Tcl_Write crlf, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1411,7 +2890,7 @@ and here } auto} -test io-7.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { +test io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1428,7 +2907,7 @@ test io-7.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { string length $c } [expr 700*15+1] -test io-7.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { +test io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1445,7 +2924,7 @@ test io-7.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { string length $c } [expr 700*15+1] -test io-7.15 {Tcl_Write mixed, Tcl_Read auto} { +test io-30.15 {Tcl_Write mixed, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1461,7 +2940,7 @@ there and here } -test io-7.16 {Tcl_Write ^Z at end, Tcl_Read auto} { +test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1477,7 +2956,7 @@ there and here } -test io-7.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} { +test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} { removeFile test1 set f [open test1 w] fconfigure $f -eofchar \x1a -translation lf @@ -1493,7 +2972,7 @@ there and here } -test io-7.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { +test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1513,7 +2992,7 @@ test io-7.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { close $f set l } {abc def 0 {} 1 {} 1} -test io-7.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { +test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1533,7 +3012,7 @@ test io-7.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { close $f set l } {abc def 0 {} 1 {} 1} -test io-7.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { +test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -1555,7 +3034,7 @@ test io-7.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { close $f set l } "abc def 0 \x1aghi 0 qrs 0 {} 1" -test io-7.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { +test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -1566,14 +3045,14 @@ test io-7.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { fconfigure $f -translation cr -eofchar {} set l "" set x [gets $f] - lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs"] + lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] lappend l [eof $f] lappend l [gets $f] lappend l [eof $f] close $f set l } {0 1 {} 1} -test io-7.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { +test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -1584,14 +3063,14 @@ test io-7.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { fconfigure $f -translation crlf -eofchar {} set l "" set x [gets $f] - lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs"] + lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] lappend l [eof $f] lappend l [gets $f] lappend l [eof $f] close $f set l } {0 1 {} 1} -test io-7.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { +test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1605,7 +3084,7 @@ test io-7.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { close $f list $c $e } {8 1} -test io-7.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { +test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1619,7 +3098,7 @@ test io-7.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { close $f list $c $e } {8 1} -test io-7.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { +test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1633,7 +3112,7 @@ test io-7.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { close $f list $c $e } {8 1} -test io-7.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { +test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1647,7 +3126,7 @@ test io-7.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { close $f list $c $e } {8 1} -test io-7.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { +test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1661,7 +3140,7 @@ test io-7.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { close $f list $c $e } {8 1} -test io-7.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { +test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1678,7 +3157,7 @@ test io-7.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { # Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets. -test io-8.1 {Tcl_Write lf, Tcl_Gets auto} { +test io-31.1 {Tcl_Write lf, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1695,7 +3174,7 @@ test io-8.1 {Tcl_Write lf, Tcl_Gets auto} { close $f set l } {hello 6 auto there 12 auto} -test io-8.2 {Tcl_Write cr, Tcl_Gets auto} { +test io-31.2 {Tcl_Write cr, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1712,7 +3191,7 @@ test io-8.2 {Tcl_Write cr, Tcl_Gets auto} { close $f set l } {hello 6 auto there 12 auto} -test io-8.3 {Tcl_Write crlf, Tcl_Gets auto} { +test io-31.3 {Tcl_Write crlf, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1729,7 +3208,7 @@ test io-8.3 {Tcl_Write crlf, Tcl_Gets auto} { close $f set l } {hello 7 auto there 14 auto} -test io-8.4 {Tcl_Write lf, Tcl_Gets lf} { +test io-31.4 {Tcl_Write lf, Tcl_Gets lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1747,7 +3226,7 @@ test io-8.4 {Tcl_Write lf, Tcl_Gets lf} { close $f set l } {hello 6 lf there 12 lf} -test io-8.5 {Tcl_Write lf, Tcl_Gets cr} { +test io-31.5 {Tcl_Write lf, Tcl_Gets cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1766,8 +3245,8 @@ test io-8.5 {Tcl_Write lf, Tcl_Gets cr} { lappend l [eof $f] close $f set l -} {20 21 cr 1 {} 21 cr 1} -test io-8.6 {Tcl_Write lf, Tcl_Gets crlf} { +} {21 21 cr 1 {} 21 cr 1} +test io-31.6 {Tcl_Write lf, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1786,8 +3265,8 @@ test io-8.6 {Tcl_Write lf, Tcl_Gets crlf} { lappend l [eof $f] close $f set l -} {20 21 crlf 1 {} 21 crlf 1} -test io-8.7 {Tcl_Write cr, Tcl_Gets cr} { +} {21 21 crlf 1 {} 21 crlf 1} +test io-31.7 {Tcl_Write cr, Tcl_Gets cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1807,7 +3286,7 @@ test io-8.7 {Tcl_Write cr, Tcl_Gets cr} { close $f set l } {hello 6 cr 0 there 12 cr 0} -test io-8.8 {Tcl_Write cr, Tcl_Gets lf} { +test io-31.8 {Tcl_Write cr, Tcl_Gets lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1827,7 +3306,7 @@ test io-8.8 {Tcl_Write cr, Tcl_Gets lf} { close $f set l } {21 21 lf 1 {} 21 lf 1} -test io-8.9 {Tcl_Write cr, Tcl_Gets crlf} { +test io-31.9 {Tcl_Write cr, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1847,7 +3326,7 @@ test io-8.9 {Tcl_Write cr, Tcl_Gets crlf} { close $f set l } {21 21 crlf 1 {} 21 crlf 1} -test io-8.10 {Tcl_Write crlf, Tcl_Gets crlf} { +test io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1867,7 +3346,7 @@ test io-8.10 {Tcl_Write crlf, Tcl_Gets crlf} { close $f set l } {hello 7 crlf 0 there 14 crlf 0} -test io-8.11 {Tcl_Write crlf, Tcl_Gets cr} { +test io-31.11 {Tcl_Write crlf, Tcl_Gets cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1887,7 +3366,7 @@ test io-8.11 {Tcl_Write crlf, Tcl_Gets cr} { close $f set l } {hello 6 cr 0 6 13 cr 0} -test io-8.12 {Tcl_Write crlf, Tcl_Gets lf} { +test io-31.12 {Tcl_Write crlf, Tcl_Gets lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1907,7 +3386,7 @@ test io-8.12 {Tcl_Write crlf, Tcl_Gets lf} { close $f set l } {6 7 lf 0 6 14 lf 0} -test io-8.13 {binary mode is synonym of lf mode} { +test io-31.13 {binary mode is synonym of lf mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation binary @@ -1919,7 +3398,7 @@ test io-8.13 {binary mode is synonym of lf mode} { # Test io-9.14 has been removed because "auto" output translation mode is # not supoprted. # -test io-8.14 {Tcl_Write mixed, Tcl_Gets auto} { +test io-31.14 {Tcl_Write mixed, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1938,7 +3417,7 @@ test io-8.14 {Tcl_Write mixed, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-8.15 {Tcl_Write mixed, Tcl_Gets auto} { +test io-31.15 {Tcl_Write mixed, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1957,7 +3436,7 @@ test io-8.15 {Tcl_Write mixed, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-8.16 {Tcl_Write mixed, Tcl_Gets auto} { +test io-31.16 {Tcl_Write mixed, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1975,7 +3454,7 @@ test io-8.16 {Tcl_Write mixed, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-8.17 {Tcl_Write mixed, Tcl_Gets auto} { +test io-31.17 {Tcl_Write mixed, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1994,7 +3473,7 @@ test io-8.17 {Tcl_Write mixed, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-8.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { +test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -2014,7 +3493,7 @@ test io-8.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-8.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { +test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -eofchar \x1a -translation lf @@ -2033,7 +3512,7 @@ test io-8.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-8.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { +test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -2052,7 +3531,7 @@ test io-8.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { close $f set l } {abc def 0 {} 1} -test io-8.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { +test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -2070,7 +3549,7 @@ test io-8.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { close $f set l } {abc def 0 {} 1} -test io-8.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { +test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -2092,7 +3571,7 @@ test io-8.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { close $f set l } "abc def 0 \x1aqrs 0 tuv 0 {} 1" -test io-8.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { +test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -2114,7 +3593,7 @@ test io-8.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { close $f set l } "abc def 0 \x1aqrs 0 tuv 0 {} 1" -test io-8.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { +test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -2136,7 +3615,7 @@ test io-8.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { close $f set l } "abc def 0 \x1aqrs 0 tuv 0 {} 1" -test io-8.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { +test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -2154,7 +3633,7 @@ test io-8.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { close $f set l } {abc def 0 {} 1} -test io-8.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { +test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -2172,7 +3651,7 @@ test io-8.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { close $f set l } {abc def 0 {} 1} -test io-8.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { +test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -2190,7 +3669,7 @@ test io-8.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { close $f set l } {abc def 0 {} 1} -test io-8.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { +test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -2208,7 +3687,7 @@ test io-8.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { close $f set l } {abc def 0 {} 1} -test io-8.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { +test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -2226,7 +3705,7 @@ test io-8.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { close $f set l } {abc def 0 {} 1} -test io-8.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { +test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -2244,7 +3723,7 @@ test io-8.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { close $f set l } {abc def 0 {} 1} -test io-8.31 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { +test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -2255,7 +3734,7 @@ test io-8.31 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { } close $f set f [open test1 r] - fconfigure $f -translation auto + fconfigure $f -translation crlf set c "" while {[gets $f line] >= 0} { append c $line\n @@ -2263,13 +3742,13 @@ test io-8.31 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { close $f string length $c } [expr 700*15+1] -test io-8.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { +test io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf puts -nonewline $f x ;# shift crlf across block boundary - for {set i 0} {$i < 256} {incr i} { + for {set i 0} {$i < 700} {incr i} { puts $f $line } close $f @@ -2281,24 +3760,24 @@ test io-8.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { } close $f string length $c -} [expr 256*15+1] +} [expr 700*15+1] # Test Tcl_Read and buffering. -test io-9.1 {Tcl_Read, channel not readable} { +test io-32.1 {Tcl_Read, channel not readable} { list [catch {read stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} -test io-9.2 {Tcl_Read, zero byte count} { +test io-32.2 {Tcl_Read, zero byte count} { read stdin 0 } "" -test io-9.3 {Tcl_Read, negative byte count} { +test io-32.3 {Tcl_Read, negative byte count} { set f [open longfile r] set l [list [catch {read $f -1} msg] $msg] close $f set l } {1 {bad argument "-1": should be "nonewline"}} -test io-9.4 {Tcl_Read, positive byte count} { +test io-32.4 {Tcl_Read, positive byte count} { set f [open longfile r] set x [read $f 1024] set s [string length $x] @@ -2306,7 +3785,7 @@ test io-9.4 {Tcl_Read, positive byte count} { close $f set s } 1024 -test io-9.5 {Tcl_Read, multiple buffers} { +test io-32.5 {Tcl_Read, multiple buffers} { set f [open longfile r] fconfigure $f -buffersize 100 set x [read $f 1024] @@ -2315,7 +3794,7 @@ test io-9.5 {Tcl_Read, multiple buffers} { close $f set s } 1024 -test io-9.6 {Tcl_Read, very large read} { +test io-32.6 {Tcl_Read, very large read} { set f1 [open longfile r] set z [read $f1 1000000] close $f1 @@ -2323,11 +3802,11 @@ test io-9.6 {Tcl_Read, very large read} { set x ok set z [file size longfile] if {$z != $l} { - set x broken + set x broken } set x } ok -test io-9.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { +test io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set f1 [open longfile r] fconfigure $f1 -blocking off set z [read $f1 20] @@ -2335,11 +3814,11 @@ test io-9.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set l [string length $z] set x ok if {$l != 20} { - set x broken + set x broken } set x } ok -test io-9.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { +test io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set f1 [open longfile r] fconfigure $f1 -blocking off set z [read $f1 1000000] @@ -2348,11 +3827,11 @@ test io-9.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set l [string length $z]] set z [file size longfile]] if {$z != $l} { - set x broken + set x broken } set x } ok -test io-9.9 {Tcl_Read, read to end of file} { +test io-32.9 {Tcl_Read, read to end of file} { set f1 [open longfile r] set z [read $f1] close $f1 @@ -2360,11 +3839,11 @@ test io-9.9 {Tcl_Read, read to end of file} { set x ok set z [file size longfile] if {$z != $l} { - set x broken + set x broken } set x } ok -test io-9.10 {Tcl_Read from a pipe} {stdio} { +test io-32.10 {Tcl_Read from a pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 {puts [gets stdin]} @@ -2376,7 +3855,7 @@ test io-9.10 {Tcl_Read from a pipe} {stdio} { close $f1 set x } "hello\n" -test io-9.11 {Tcl_Read from a pipe} {stdio} { +test io-32.11 {Tcl_Read from a pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 {puts [gets stdin]} @@ -2395,7 +3874,7 @@ test io-9.11 {Tcl_Read from a pipe} {stdio} { } {{hello } {hello }} -test io-9.12 {Tcl_Read, -nonewline} { +test io-32.12 {Tcl_Read, -nonewline} { removeFile test1 set f1 [open test1 w] puts $f1 hello @@ -2407,7 +3886,7 @@ test io-9.12 {Tcl_Read, -nonewline} { set c } {hello bye} -test io-9.13 {Tcl_Read, -nonewline} { +test io-32.13 {Tcl_Read, -nonewline} { removeFile test1 set f1 [open test1 w] puts $f1 hello @@ -2419,7 +3898,7 @@ test io-9.13 {Tcl_Read, -nonewline} { list [string length $c] $c } {9 {hello bye}} -test io-9.14 {Tcl_Read, reading in small chunks} { +test io-32.14 {Tcl_Read, reading in small chunks} { removeFile test1 set f [open test1 w] puts $f "Two lines: this one" @@ -2432,7 +3911,7 @@ test io-9.14 {Tcl_Read, reading in small chunks} { } {T wo { lines: this one and this one }} -test io-9.15 {Tcl_Read, asking for more input than available} { +test io-32.15 {Tcl_Read, asking for more input than available} { removeFile test1 set f [open test1 w] puts $f "Two lines: this one" @@ -2445,7 +3924,7 @@ test io-9.15 {Tcl_Read, asking for more input than available} { } {Two lines: this one and this one } -test io-9.16 {Tcl_Read, read to end of file with -nonewline} { +test io-32.16 {Tcl_Read, read to end of file with -nonewline} { removeFile test1 set f [open test1 w] puts $f "Two lines: this one" @@ -2460,7 +3939,7 @@ and this one} # Test Tcl_Gets. -test io-10.1 {Tcl_Gets, reading what was written} { +test io-33.1 {Tcl_Gets, reading what was written} { removeFile test1 set f1 [open test1 w] set y "first line" @@ -2470,23 +3949,23 @@ test io-10.1 {Tcl_Gets, reading what was written} { set x [gets $f1] set z ok if {"$x" != "$y"} { - set z broken + set z broken } close $f1 set z } ok -test io-10.2 {Tcl_Gets into variable} { +test io-33.2 {Tcl_Gets into variable} { set f1 [open longfile r] set c [gets $f1 x] set l [string length x] set z ok if {$l != $l} { - set z broken + set z broken } close $f1 set z } ok -test io-10.3 {Tcl_Gets from pipe} {stdio} { +test io-33.3 {Tcl_Gets from pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 {puts [gets stdin]} @@ -2498,11 +3977,11 @@ test io-10.3 {Tcl_Gets from pipe} {stdio} { close $f1 set z ok if {"$x" != "hello"} { - set z broken + set z broken } set z } ok -test io-10.4 {Tcl_Gets with long line} { +test io-33.4 {Tcl_Gets with long line} { removeFile test3 set f [open test3 w] puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" @@ -2516,13 +3995,13 @@ test io-10.4 {Tcl_Gets with long line} { close $f set x } {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} -test io-10.5 {Tcl_Gets with long line} { +test io-33.5 {Tcl_Gets with long line} { set f [open test3] set x [gets $f y] close $f list $x $y } {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} -test io-10.6 {Tcl_Gets and end of file} { +test io-33.6 {Tcl_Gets and end of file} { removeFile test3 set f [open test3 w] puts -nonewline $f "Test1\nTest2" @@ -2538,7 +4017,7 @@ test io-10.6 {Tcl_Gets and end of file} { close $f set x } {5 Test1 5 Test2 -1 {}} -test io-10.7 {Tcl_Gets and bad variable} { +test io-33.7 {Tcl_Gets and bad variable} { set f [open test3 w] puts $f "Line 1" puts $f "Line 2" @@ -2550,7 +4029,7 @@ test io-10.7 {Tcl_Gets and bad variable} { close $f set result } {1 {can't set "x(0)": variable isn't array}} -test io-10.8 {Tcl_Gets, exercising double buffering} { +test io-33.8 {Tcl_Gets, exercising double buffering} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} set x "" @@ -2563,7 +4042,7 @@ test io-10.8 {Tcl_Gets, exercising double buffering} { close $f set y } 100 -test io-10.9 {Tcl_Gets, exercising double buffering} { +test io-33.9 {Tcl_Gets, exercising double buffering} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} set x "" @@ -2576,7 +4055,7 @@ test io-10.9 {Tcl_Gets, exercising double buffering} { close $f set y } 200 -test io-10.10 {Tcl_Gets, exercising double buffering} { +test io-33.10 {Tcl_Gets, exercising double buffering} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} set x "" @@ -2592,14 +4071,14 @@ test io-10.10 {Tcl_Gets, exercising double buffering} { # Test Tcl_Seek and Tcl_Tell. -test io-11.1 {Tcl_Seek to current position at start of file} { +test io-34.1 {Tcl_Seek to current position at start of file} { set f1 [open longfile r] seek $f1 0 current set c [tell $f1] close $f1 set c } 0 -test io-11.2 {Tcl_Seek to offset from start} { +test io-34.2 {Tcl_Seek to offset from start} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2612,7 +4091,7 @@ test io-11.2 {Tcl_Seek to offset from start} { close $f1 set c } 10 -test io-11.3 {Tcl_Seek to end of file} { +test io-34.3 {Tcl_Seek to end of file} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2625,7 +4104,7 @@ test io-11.3 {Tcl_Seek to end of file} { close $f1 set c } 54 -test io-11.4 {Tcl_Seek to offset from end of file} { +test io-34.4 {Tcl_Seek to offset from end of file} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2638,7 +4117,7 @@ test io-11.4 {Tcl_Seek to offset from end of file} { close $f1 set c } 44 -test io-11.5 {Tcl_Seek to offset from current position} { +test io-34.5 {Tcl_Seek to offset from current position} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2652,7 +4131,7 @@ test io-11.5 {Tcl_Seek to offset from current position} { close $f1 set c } 20 -test io-11.6 {Tcl_Seek to offset from end of file} { +test io-34.6 {Tcl_Seek to offset from end of file} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2667,7 +4146,7 @@ test io-11.6 {Tcl_Seek to offset from end of file} { list $c $r } {44 {rstuvwxyz }} -test io-11.7 {Tcl_Seek to offset from end of file, then to current position} { +test io-34.7 {Tcl_Seek to offset from end of file, then to current position} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2683,14 +4162,14 @@ 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} {stdio} { +test io-34.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 string tolower $x } {1 {error during seek on "": invalid argument}} -test io-11.9 {Tcl_Seek, testing buffered input flushing} { +test io-34.9 {Tcl_Seek, testing buffered input flushing} { removeFile test3 set f [open test3 w] fconfigure $f -eofchar {} @@ -2713,7 +4192,7 @@ test io-11.9 {Tcl_Seek, testing buffered input flushing} { close $f set x } {a d a l Y {} b} -test io-11.10 {Tcl_Seek testing flushing of buffered input} { +test io-34.10 {Tcl_Seek testing flushing of buffered input} { set f [open test3 w] fconfigure $f -translation lf puts $f xyz\n123 @@ -2727,7 +4206,7 @@ test io-11.10 {Tcl_Seek testing flushing of buffered input} { list $x [viewFile test3] } "xyz {xyz 456}" -test io-11.11 {Tcl_Seek testing flushing of buffered output} { +test io-34.11 {Tcl_Seek testing flushing of buffered output} { set f [open test3 w] puts $f xyz\n123 close $f @@ -2738,7 +4217,7 @@ test io-11.11 {Tcl_Seek testing flushing of buffered output} { close $f list $x [viewFile test3] } "zzy xyzzy" -test io-11.12 {Tcl_Seek testing combination of write, seek back and read} { +test io-34.12 {Tcl_Seek testing combination of write, seek back and read} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} puts $f xyz\n123 @@ -2755,14 +4234,14 @@ test io-11.12 {Tcl_Seek testing combination of write, seek back and read} { } {14 {xyz 123 xyzzy} zzy} -test io-11.13 {Tcl_Tell at start of file} { +test io-34.13 {Tcl_Tell at start of file} { removeFile test1 set f1 [open test1 w] set p [tell $f1] close $f1 set p } 0 -test io-11.14 {Tcl_Tell after seek to end of file} { +test io-34.14 {Tcl_Tell after seek to end of file} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2775,7 +4254,7 @@ test io-11.14 {Tcl_Tell after seek to end of file} { close $f1 set c1 } 54 -test io-11.15 {Tcl_Tell combined with seeking} { +test io-34.15 {Tcl_Tell combined with seeking} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2790,13 +4269,13 @@ 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} {stdio} { +test io-34.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} {stdio} { +test io-34.17 {Tcl_Tell on pipe: always -1} {stdio} { set f1 [open "|[list $tcltest]" r+] puts $f1 {puts hello} flush $f1 @@ -2805,7 +4284,7 @@ test io-11.17 {Tcl_Tell on pipe: always -1} {stdio} { close $f1 set c } -1 -test io-11.18 {Tcl_Tell combined with seeking and reading} { +test io-34.18 {Tcl_Tell combined with seeking and reading} { removeFile test2 set f [open test2 w] fconfigure $f -translation lf -eofchar {} @@ -2825,7 +4304,7 @@ test io-11.18 {Tcl_Tell combined with seeking and reading} { close $f set x } {0 3 2 12 30} -test io-11.19 {Tcl_Tell combined with opening in append mode} { +test io-34.19 {Tcl_Tell combined with opening in append mode} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} puts $f "abcdefghijklmnopqrstuvwxyz" @@ -2836,7 +4315,7 @@ test io-11.19 {Tcl_Tell combined with opening in append mode} { close $f set c } 54 -test io-11.20 {Tcl_Tell combined with writing} { +test io-34.20 {Tcl_Tell combined with writing} { set f [open test3 w] set l "" seek $f 29 start @@ -2854,7 +4333,7 @@ test io-11.20 {Tcl_Tell combined with writing} { # Test Tcl_Eof -test io-12.1 {Tcl_Eof} { +test io-35.1 {Tcl_Eof} { removeFile test1 set f [open test1 w] puts $f hello @@ -2873,7 +4352,7 @@ test io-12.1 {Tcl_Eof} { close $f set x } {0 0 0 0 1 1} -test io-12.2 {Tcl_Eof with pipe} {stdio} { +test io-35.2 {Tcl_Eof with pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 {gets stdin} @@ -2891,7 +4370,7 @@ test io-12.2 {Tcl_Eof with pipe} {stdio} { close $f1 set x } {0 0 0 1} -test io-12.3 {Tcl_Eof with pipe} {stdio} { +test io-35.3 {Tcl_Eof with pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 {gets stdin} @@ -2913,7 +4392,7 @@ test io-12.3 {Tcl_Eof with pipe} {stdio} { close $f1 set x } {0 0 0 1 1 1} -test io-12.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { +test io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { removeFile test1 set f [open test1 w] close $f @@ -2925,7 +4404,7 @@ 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} {stdio} { +test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio} { removeFile pipe set f [open pipe w] puts $f { @@ -2939,7 +4418,7 @@ test io-12.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio} { close $f set l } {{} 1} -test io-12.6 {Tcl_Eof, eof char, lf write, auto read} { +test io-35.6 {Tcl_Eof, eof char, lf write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar \x1a @@ -2953,7 +4432,7 @@ test io-12.6 {Tcl_Eof, eof char, lf write, auto read} { close $f list $s $l $e } {9 8 1} -test io-12.7 {Tcl_Eof, eof char, lf write, lf read} { +test io-35.7 {Tcl_Eof, eof char, lf write, lf read} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar \x1a @@ -2967,7 +4446,7 @@ test io-12.7 {Tcl_Eof, eof char, lf write, lf read} { close $f list $s $l $e } {9 8 1} -test io-12.8 {Tcl_Eof, eof char, cr write, auto read} { +test io-35.8 {Tcl_Eof, eof char, cr write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar \x1a @@ -2981,7 +4460,7 @@ test io-12.8 {Tcl_Eof, eof char, cr write, auto read} { close $f list $s $l $e } {9 8 1} -test io-12.9 {Tcl_Eof, eof char, cr write, cr read} { +test io-35.9 {Tcl_Eof, eof char, cr write, cr read} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar \x1a @@ -2995,7 +4474,7 @@ test io-12.9 {Tcl_Eof, eof char, cr write, cr read} { close $f list $s $l $e } {9 8 1} -test io-12.10 {Tcl_Eof, eof char, crlf write, auto read} { +test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar \x1a @@ -3009,7 +4488,7 @@ test io-12.10 {Tcl_Eof, eof char, crlf write, auto read} { close $f list $s $l $e } {11 8 1} -test io-12.11 {Tcl_Eof, eof char, crlf write, crlf read} { +test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar \x1a @@ -3023,7 +4502,7 @@ test io-12.11 {Tcl_Eof, eof char, crlf write, crlf read} { close $f list $s $l $e } {11 8 1} -test io-12.12 {Tcl_Eof, eof char in middle, lf write, auto read} { +test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -3038,7 +4517,7 @@ test io-12.12 {Tcl_Eof, eof char in middle, lf write, auto read} { close $f list $c $l $e } {17 8 1} -test io-12.13 {Tcl_Eof, eof char in middle, lf write, lf read} { +test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -3053,7 +4532,7 @@ test io-12.13 {Tcl_Eof, eof char in middle, lf write, lf read} { close $f list $c $l $e } {17 8 1} -test io-12.14 {Tcl_Eof, eof char in middle, cr write, auto read} { +test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -3068,7 +4547,7 @@ test io-12.14 {Tcl_Eof, eof char in middle, cr write, auto read} { close $f list $c $l $e } {17 8 1} -test io-12.15 {Tcl_Eof, eof char in middle, cr write, cr read} { +test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -3083,7 +4562,7 @@ test io-12.15 {Tcl_Eof, eof char in middle, cr write, cr read} { close $f list $c $l $e } {17 8 1} -test io-12.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { +test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -3098,7 +4577,7 @@ test io-12.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { close $f list $c $l $e } {21 8 1} -test io-12.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { +test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -3116,7 +4595,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} { +test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio} { set f1 [open "|[list $tcltest]" r+] puts $f1 {puts hello_from_pipe} flush $f1 @@ -3135,7 +4614,7 @@ test io-13.1 {Tcl_InputBlocked on nonblocking pipe} {unixOrPc tempNotPc} { close $f1 set x } {{} 1 hello 0 {} 1} -test io-13.2 {Tcl_InputBlocked on blocking pipe} {unixOrPc tempNotPc} { +test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio} { set f1 [open "|[list $tcltest]" r+] fconfigure $f1 -buffering line puts $f1 {puts hello_from_pipe} @@ -3149,7 +4628,7 @@ test io-13.2 {Tcl_InputBlocked on blocking pipe} {unixOrPc tempNotPc} { close $f1 set x } {hello_from_pipe 0 {} 0 1} -test io-13.3 {Tcl_InputBlocked vs files, short read} { +test io-36.3 {Tcl_InputBlocked vs files, short read} { removeFile test1 set f [open test1 w] puts $f abcdefghijklmnop @@ -3165,7 +4644,7 @@ test io-13.3 {Tcl_InputBlocked vs files, short read} { close $f set l } {0 abc 0 defghijklmnop 0 1} -test io-13.4 {Tcl_InputBlocked vs files, event driven read} { +test io-36.4 {Tcl_InputBlocked vs files, event driven read} { proc in {f} { global l x lappend l [read $f 3] @@ -3182,7 +4661,7 @@ test io-13.4 {Tcl_InputBlocked vs files, event driven read} { set l } {abc def ghi jkl mno {p } eof} -test io-13.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} { +test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} { removeFile test1 set f [open test1 w] puts $f abcdefghijklmnop @@ -3199,7 +4678,7 @@ test io-13.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles close $f set l } {0 abc 0 defghijklmnop 0 1} -test io-13.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} { +test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} { proc in {f} { global l x lappend l [read $f 3] @@ -3220,7 +4699,7 @@ test io-13.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} { # Test Tcl_InputBuffered -test io-14.1 {Tcl_InputBuffered} { +test io-37.1 {Tcl_InputBuffered} { set f [open longfile r] fconfigure $f -buffersize 4096 read $f 3 @@ -3230,7 +4709,7 @@ test io-14.1 {Tcl_InputBuffered} { close $f set l } {4093 3} -test io-14.2 {Tcl_InputBuffered, test input flushing on seek} { +test io-37.2 {Tcl_InputBuffered, test input flushing on seek} { set f [open longfile r] fconfigure $f -buffersize 4096 read $f 3 @@ -3246,13 +4725,13 @@ test io-14.2 {Tcl_InputBuffered, test input flushing on seek} { # Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize -test io-15.1 {Tcl_GetChannelBufferSize, default buffer size} { +test io-38.1 {Tcl_GetChannelBufferSize, default buffer size} { set f [open longfile r] set s [fconfigure $f -buffersize] close $f set s } 4096 -test io-15.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { +test io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { set f [open longfile r] set l "" lappend l [fconfigure $f -buffersize] @@ -3274,7 +4753,7 @@ test io-15.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { # Test Tcl_SetChannelOption, Tcl_GetChannelOption -test io-16.1 {Tcl_GetChannelOption} { +test io-39.1 {Tcl_GetChannelOption} { removeFile test1 set f1 [open test1 w] set x [fconfigure $f1 -blocking] @@ -3284,14 +4763,14 @@ test io-16.1 {Tcl_GetChannelOption} { # # Test 17.2 was removed. # -test io-16.2 {Tcl_GetChannelOption} { +test io-39.2 {Tcl_GetChannelOption} { removeFile test1 set f1 [open test1 w] set x [fconfigure $f1 -buffering] close $f1 set x } full -test io-16.3 {Tcl_GetChannelOption} { +test io-39.3 {Tcl_GetChannelOption} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -buffering line @@ -3299,7 +4778,7 @@ test io-16.3 {Tcl_GetChannelOption} { close $f1 set x } line -test io-16.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} { +test io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} { removeFile test1 set f1 [open test1 w] set l "" @@ -3315,7 +4794,7 @@ test io-16.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} { close $f1 set l } {full line none line full} -test io-16.5 {Tcl_GetChannelOption, invariance} { +test io-39.5 {Tcl_GetChannelOption, invariance} { removeFile test1 set f1 [open test1 w] set l "" @@ -3325,7 +4804,7 @@ test io-16.5 {Tcl_GetChannelOption, invariance} { close $f1 set l } {full {1 {bad value for -buffering: must be one of full, line, or none}} full} -test io-16.6 {Tcl_SetChannelOption, multiple options} { +test io-39.6 {Tcl_SetChannelOption, multiple options} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -buffering line @@ -3335,7 +4814,7 @@ test io-16.6 {Tcl_SetChannelOption, multiple options} { close $f1 set x } 10 -test io-16.7 {Tcl_SetChannelOption, buffering, translation} { +test io-39.7 {Tcl_SetChannelOption, buffering, translation} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf @@ -3349,7 +4828,7 @@ test io-16.7 {Tcl_SetChannelOption, buffering, translation} { close $f1 set x } {0 21} -test io-16.8 {Tcl_SetChannelOption, different buffering options} { +test io-39.8 {Tcl_SetChannelOption, different buffering options} { removeFile test1 set f1 [open test1 w] set l "" @@ -3369,7 +4848,7 @@ test io-16.8 {Tcl_SetChannelOption, different buffering options} { lappend l [file size test1] set l } {5 10 10 10 20 20} -test io-16.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { +test io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { removeFile test1 set f1 [open test1 w] close $f1 @@ -3385,13 +4864,15 @@ test io-16.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { close $f1 set x } {1 0 {} {} 0 1} -test io-16.10 {Tcl_SetChannelOption, blocking mode} {unixOrPc tempNotPc} { +test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio} { removeFile pipe set f1 [open pipe w] - puts $f1 {gets stdin} - puts $f1 {after 100} - puts $f1 {puts hi} - puts $f1 {gets stdin} + puts $f1 { + gets stdin + after 100 + puts hi + gets stdin + } close $f1 set x "" set f1 [open "|[list $tcltest pipe]" r+] @@ -3399,10 +4880,14 @@ test io-16.10 {Tcl_SetChannelOption, blocking mode} {unixOrPc tempNotPc} { lappend x [fconfigure $f1 -blocking] lappend x [gets $f1] lappend x [fblocked $f1] + fconfigure $f1 -blocking on puts $f1 hello + fconfigure $f1 -blocking off lappend x [gets $f1] lappend x [fblocked $f1] + fconfigure $f1 -blocking on puts $f1 bye + fconfigure $f1 -blocking off lappend x [gets $f1] lappend x [fblocked $f1] fconfigure $f1 -blocking on @@ -3415,7 +4900,7 @@ test io-16.10 {Tcl_SetChannelOption, blocking mode} {unixOrPc tempNotPc} { close $f1 set x } {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1} -test io-16.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { +test io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { removeFile test1 set f [open test1 w] fconfigure $f -buffersize -10 @@ -3423,7 +4908,7 @@ test io-16.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { close $f set x } 4096 -test io-16.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} { +test io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} { removeFile test1 set f [open test1 w] fconfigure $f -buffersize 10000000 @@ -3431,7 +4916,7 @@ test io-16.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} { close $f set x } 4096 -test io-16.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { +test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { removeFile test1 set f [open test1 w] fconfigure $f -buffersize 40000 @@ -3439,7 +4924,61 @@ test io-16.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { close $f set x } 40000 -test io-16.14 {Tcl_SetChannelOption, setting read mode independently} \ +test io-39.13 {Tcl_SetChannelOption: -encoding, binary & utf-8} { + removeFile test1 + set f [open test1 w] + fconfigure $f -encoding {} + puts -nonewline $f \xe7\x89\xa6 + close $f + set f [open test1 r] + fconfigure $f -encoding utf-8 + set x [read $f] + close $f + set x +} \u7266 +test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { + removeFile test1 + set f [open test1 w] + fconfigure $f -encoding binary + puts -nonewline $f \xe7\x89\xa6 + close $f + set f [open test1 r] + fconfigure $f -encoding utf-8 + set x [read $f] + close $f + set x +} \u7266 +test io-39.14 {Tcl_SetChannelOption: -encoding, errors} { + removeFile test1 + set f [open test1 w] + set result [list [catch {fconfigure $f -encoding foobar} msg] $msg] + close $f + set result +} {1 {unknown encoding "foobar"}} +test io-39.14 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio} { + set f [open "|[list $tcltest cat]" r+] + fconfigure $f -encoding binary + puts -nonewline $f "\xe7" + flush $f + fconfigure $f -encoding utf-8 -blocking 0 + set x {} + fileevent $f readable { lappend x [read $f] } + vwait x + after 300 { lappend x timeout } + vwait x + fconfigure $f -encoding utf-8 + vwait x + after 300 { lappend x timeout } + vwait x + fconfigure $f -encoding binary + vwait x + after 300 { lappend x timeout } + vwait x + close $f + set x +} "{} timeout {} timeout \xe7 timeout" + +test io-39.14 {Tcl_SetChannelOption, setting read mode independently} \ {socket} { proc accept {s a p} {close $s} set s1 [socket -server accept 0] @@ -3452,7 +4991,7 @@ test io-16.14 {Tcl_SetChannelOption, setting read mode independently} \ close $s2 set modes } {auto lf} -test io-16.15 {Tcl_SetChannelOption, setting read mode independently} \ +test io-39.15 {Tcl_SetChannelOption, setting read mode independently} \ {socket} { proc accept {s a p} {close $s} set s1 [socket -server accept 0] @@ -3465,7 +5004,7 @@ test io-16.15 {Tcl_SetChannelOption, setting read mode independently} \ close $s2 set modes } {auto crlf} -test io-16.16 {Tcl_SetChannelOption, setting read mode independently} \ +test io-39.16 {Tcl_SetChannelOption, setting read mode independently} \ {socket} { proc accept {s a p} {close $s} set s1 [socket -server accept 0] @@ -3478,7 +5017,7 @@ test io-16.16 {Tcl_SetChannelOption, setting read mode independently} \ close $s2 set modes } {auto cr} -test io-16.17 {Tcl_SetChannelOption, setting read mode independently} \ +test io-39.17 {Tcl_SetChannelOption, setting read mode independently} \ {socket} { proc accept {s a p} {close $s} set s1 [socket -server accept 0] @@ -3492,7 +5031,7 @@ test io-16.17 {Tcl_SetChannelOption, setting read mode independently} \ set modes } {auto crlf} -test io-17.1 {POSIX open access modes: RDWR} { +test io-40.1 {POSIX open access modes: RDWR} { removeFile test3 set f [open test3 w] puts $f xyzzy @@ -3507,7 +5046,7 @@ test io-17.1 {POSIX open access modes: RDWR} { close $f set x } {zzy abzzy} -test io-17.2 {POSIX open access modes: CREAT} {unixOnly} { +test io-40.2 {POSIX open access modes: CREAT} {unixOnly} { removeFile test3 set f [open test3 {WRONLY CREAT} 0600] file stat test3 stats @@ -3519,7 +5058,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} {$testConfig(unix) && ([exec umask] == 2)} { +test io-40.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}] @@ -3527,7 +5066,7 @@ test io-17.3 {POSIX open access modes: CREAT} {$testConfig(unix) && ([exec umask file stat test3 stats format "0%o" [expr $stats(mode)&0777] } 0664 -test io-17.4 {POSIX open access modes: CREAT} { +test io-40.4 {POSIX open access modes: CREAT} { removeFile test3 set f [open test3 w] fconfigure $f -eofchar {} @@ -3542,7 +5081,7 @@ test io-17.4 {POSIX open access modes: CREAT} { close $f set x } abzzy -test io-17.5 {POSIX open access modes: APPEND} { +test io-40.5 {POSIX open access modes: APPEND} { removeFile test3 set f [open test3 w] fconfigure $f -translation lf -eofchar {} @@ -3563,7 +5102,7 @@ test io-17.5 {POSIX open access modes: APPEND} { close $f set x } {{new line} abc} -test io-17.6 {POSIX open access modes: EXCL} { +test io-40.6 {POSIX open access modes: EXCL} { removeFile test3 set f [open test3 w] puts $f xyzzy @@ -3572,7 +5111,7 @@ test io-17.6 {POSIX open access modes: EXCL} { regsub " already " $msg " " msg string tolower $msg } {1 {couldn't open "test3": file exists}} -test io-17.7 {POSIX open access modes: EXCL} { +test io-40.7 {POSIX open access modes: EXCL} { removeFile test3 set f [open test3 {WRONLY CREAT EXCL}] fconfigure $f -eofchar {} @@ -3580,7 +5119,7 @@ test io-17.7 {POSIX open access modes: EXCL} { close $f viewFile test3 } {A test line} -test io-17.8 {POSIX open access modes: TRUNC} { +test io-40.8 {POSIX open access modes: TRUNC} { removeFile test3 set f [open test3 w] puts $f xyzzy @@ -3593,7 +5132,7 @@ test io-17.8 {POSIX open access modes: TRUNC} { close $f set x } abc -test io-17.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} { +test io-40.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} { removeFile test3 set f [open test3 {WRONLY NONBLOCK CREAT}] puts $f "NONBLOCK test" @@ -3603,7 +5142,7 @@ test io-17.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} { close $f set x } {NONBLOCK test} -test io-17.10 {POSIX open access modes: RDONLY} { +test io-40.10 {POSIX open access modes: RDONLY} { set f [open test1 w] puts $f "two lines: this one" puts $f "and this" @@ -3615,15 +5154,15 @@ test io-17.10 {POSIX open access modes: RDONLY} { [list {two lines: this one} 1 \ [format "channel \"%s\" wasn't opened for writing" $f]] } 0 -test io-17.11 {POSIX open access modes: RDONLY} { +test io-40.11 {POSIX open access modes: RDONLY} { removeFile test3 string tolower [list [catch {open test3 RDONLY} msg] $msg] } {1 {couldn't open "test3": no such file or directory}} -test io-17.12 {POSIX open access modes: WRONLY} { +test io-40.12 {POSIX open access modes: WRONLY} { removeFile test3 string tolower [list [catch {open test3 WRONLY} msg] $msg] } {1 {couldn't open "test3": no such file or directory}} -test io-17.13 {POSIX open access modes: WRONLY} { +test io-40.13 {POSIX open access modes: WRONLY} { makeFile xyzzy test3 set f [open test3 WRONLY] fconfigure $f -eofchar {} @@ -3635,11 +5174,11 @@ test io-17.13 {POSIX open access modes: WRONLY} { string compare [string tolower $x] \ [list 1 "channel \"$f\" wasn't opened for reading" abzzy] } 0 -test io-17.14 {POSIX open access modes: RDWR} { +test io-40.14 {POSIX open access modes: RDWR} { removeFile test3 string tolower [list [catch {open test3 RDWR} msg] $msg] } {1 {couldn't open "test3": no such file or directory}} -test io-17.15 {POSIX open access modes: RDWR} { +test io-40.15 {POSIX open access modes: RDWR} { makeFile xyzzy test3 set f [open test3 RDWR] puts -nonewline $f "ab" @@ -3649,7 +5188,7 @@ test io-17.15 {POSIX open access modes: RDWR} { lappend x [viewFile test3] } {zzy abzzy} if {![file exists ~/_test_] && [file writable ~]} { - test io-17.16 {tilde substitution in open} { + test io-40.16 {tilde substitution in open} { set f [open ~/_test_ w] puts $f "Some text" close $f @@ -3658,7 +5197,7 @@ if {![file exists ~/_test_] && [file writable ~]} { set x } 1 } -test io-17.17 {tilde substitution in open} { +test io-40.17 {tilde substitution in open} { set home $env(HOME) unset env(HOME) set x [list [catch {open ~/foo} msg] $msg] @@ -3666,19 +5205,19 @@ test io-17.17 {tilde substitution in open} { set x } {1 {couldn't find HOME environment variable to expand path}} -test io-18.1 {Tcl_FileeventCmd: errors} { +test io-41.1 {Tcl_FileeventCmd: errors} { list [catch {fileevent foo} msg] $msg -} {1 {wrong # args: must be "fileevent channelId event ?script?}} -test io-18.2 {Tcl_FileeventCmd: errors} { +} {1 {wrong # args: should be "fileevent channelId event ?script?"}} +test io-41.2 {Tcl_FileeventCmd: errors} { list [catch {fileevent foo bar baz q} msg] $msg -} {1 {wrong # args: must be "fileevent channelId event ?script?}} -test io-18.3 {Tcl_FileeventCmd: errors} { +} {1 {wrong # args: should be "fileevent channelId event ?script?"}} +test io-41.3 {Tcl_FileeventCmd: errors} { list [catch {fileevent gorp readable} msg] $msg } {1 {can not find channel named "gorp"}} -test io-18.4 {Tcl_FileeventCmd: errors} { +test io-41.4 {Tcl_FileeventCmd: errors} { list [catch {fileevent gorp writable} msg] $msg } {1 {can not find channel named "gorp"}} -test io-18.5 {Tcl_FileeventCmd: errors} { +test io-41.5 {Tcl_FileeventCmd: errors} { list [catch {fileevent gorp who-knows} msg] $msg } {1 {bad event name "who-knows": must be readable or writable}} @@ -3688,10 +5227,10 @@ test io-18.5 {Tcl_FileeventCmd: errors} { set f [open foo w+] -test io-19.1 {Tcl_FileeventCmd: creating, deleting, querying} { +test io-42.1 {Tcl_FileeventCmd: creating, deleting, querying} { list [fileevent $f readable] [fileevent $f writable] } {{} {}} -test io-19.2 {Tcl_FileeventCmd: replacing} { +test io-42.2 {Tcl_FileeventCmd: replacing} { set result {} fileevent $f r "first script" lappend result [fileevent $f readable] @@ -3702,18 +5241,27 @@ test io-19.2 {Tcl_FileeventCmd: replacing} { fileevent $f r "" lappend result [fileevent $f readable] } {{first script} {new script} {yet another} {}} - +test io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} { + set result {} + fileevent $f r "first scr\0ipt" + lappend result [string length [fileevent $f readable]] + fileevent $f r "new scr\0ipt" + lappend result [string length [fileevent $f readable]] + fileevent $f r "yet ano\0ther" + lappend result [string length [fileevent $f readable]] + fileevent $f r "" + lappend result [fileevent $f readable] +} {13 11 12 {}} # # Test fileevent on a pipe # -if {($tcl_platform(platform) != "macintosh") && \ - ($testConfig(unixExecs) == 1)} { +if {$testConfig(stdio) && $testConfig(unixExecs)} { 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} { +test io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} { set result {} fileevent $f readable "script 1" lappend result [fileevent $f readable] [fileevent $f writable] @@ -3724,7 +5272,7 @@ test io-20.1 {Tcl_FileeventCmd: creating, deleting, querying} { fileevent $f writable {} lappend result [fileevent $f readable] [fileevent $f writable] } {{script 1} {} {script 1} {write script} {} {write script} {} {}} -test io-20.2 {Tcl_FileeventCmd: deleting when many present} { +test io-43.2 {Tcl_FileeventCmd: deleting when many present} { set result {} lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] fileevent $f r "read f" @@ -3739,7 +5287,7 @@ test io-20.2 {Tcl_FileeventCmd: deleting when many present} { lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] } {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}} -test io-21.1 {FileEventProc procedure: normal read event} { +test io-44.1 {FileEventProc procedure: normal read event} { fileevent $f2 readable { set x [gets $f2]; fileevent $f2 readable {} } @@ -3748,7 +5296,7 @@ test io-21.1 {FileEventProc procedure: normal read event} { vwait x set x } {text} -test io-21.2 {FileEventProc procedure: error in read event} { +test io-44.2 {FileEventProc procedure: error in read event} { proc bgerror args { global x set x $args @@ -3760,7 +5308,7 @@ test io-21.2 {FileEventProc procedure: error in read event} { rename bgerror {} list $x [fileevent $f2 readable] } {bogus {}} -test io-21.3 {FileEventProc procedure: normal write event} { +test io-44.3 {FileEventProc procedure: normal write event} { fileevent $f2 writable { lappend x "triggered" incr count -1 @@ -3775,7 +5323,7 @@ test io-21.3 {FileEventProc procedure: normal write event} { vwait x set x } {initial triggered triggered triggered} -test io-21.4 {FileEventProc procedure: eror in write event} { +test io-44.4 {FileEventProc procedure: eror in write event} { proc bgerror args { global x set x $args @@ -3786,7 +5334,7 @@ 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} { +test io-44.5 {FileEventProc procedure: end of file} { set f4 [open "|[list $tcltest cat << foo]" r] fileevent $f4 readable { if {[gets $f4 line] < 0} { @@ -3812,7 +5360,7 @@ catch {close $f3} close $f makeFile "foo bar" foo -test io-22.1 {DeleteFileEvent, cleanup on close} { +test io-45.1 {DeleteFileEvent, cleanup on close} { set f [open foo r] fileevent $f readable { lappend x "binding triggered: \"[gets $f]\"" @@ -3824,7 +5372,7 @@ test io-22.1 {DeleteFileEvent, cleanup on close} { vwait y set x } {initial} -test io-22.2 {DeleteFileEvent, cleanup on close} { +test io-45.2 {DeleteFileEvent, cleanup on close} { set f [open foo r] set f2 [open foo r] fileevent $f readable { @@ -3841,7 +5389,7 @@ test io-22.2 {DeleteFileEvent, cleanup on close} { close $f2 set x } {initial {f2 triggered: "foo bar"}} -test io-22.3 {DeleteFileEvent, cleanup on close} { +test io-45.3 {DeleteFileEvent, cleanup on close} { set f [open foo r] set f2 [open foo r] set f3 [open foo r] @@ -3867,7 +5415,7 @@ test io-22.3 {DeleteFileEvent, cleanup on close} { if {[info commands testfevent] == "testfevent"} { -test io-23.1 {Tcl event loop vs multiple interpreters} { +test io-46.1 {Tcl event loop vs multiple interpreters} { testfevent create testfevent cmd { set f [open foo r] @@ -3882,7 +5430,7 @@ test io-23.1 {Tcl event loop vs multiple interpreters} { testfevent cmd {close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} -test io-23.2 {Tcl event loop vs multiple interpreters} { +test io-46.2 {Tcl event loop vs multiple interpreters} { testfevent create testfevent cmd { set x 0 @@ -3891,7 +5439,7 @@ test io-23.2 {Tcl event loop vs multiple interpreters} { set x } } {triggered} -test io-23.3 {Tcl event loop vs multiple interpreters} { +test io-46.3 {Tcl event loop vs multiple interpreters} { testfevent create testfevent cmd { set x 0 @@ -3905,7 +5453,7 @@ test io-23.3 {Tcl event loop vs multiple interpreters} { } } {0 0 {0 timer}} -test io-24.1 {fileevent vs multiple interpreters} { +test io-47.1 {fileevent vs multiple interpreters} { set f [open foo r] set f2 [open foo r] set f3 [open foo r] @@ -3924,7 +5472,7 @@ test io-24.1 {fileevent vs multiple interpreters} { close $f3 set x } {{} {script 1} {} {sript 3}} -test io-24.2 {deleting fileevent on interpreter delete} { +test io-47.2 {deleting fileevent on interpreter delete} { set f [open foo r] set f2 [open foo r] set f3 [open foo r] @@ -3945,7 +5493,7 @@ test io-24.2 {deleting fileevent on interpreter delete} { close $f4 set x } {{script 1} {} {} {script 4}} -test io-24.3 {deleting fileevent on interpreter delete} { +test io-47.3 {deleting fileevent on interpreter delete} { set f [open foo r] set f2 [open foo r] set f3 [open foo r] @@ -3966,7 +5514,7 @@ test io-24.3 {deleting fileevent on interpreter delete} { close $f4 set x } {{script 1} {script 2} {} {}} -test io-24.4 {file events on shared files and multiple interpreters} { +test io-47.4 {file events on shared files and multiple interpreters} { set f [open foo r] set f2 [open foo r] testfevent create @@ -3982,7 +5530,7 @@ test io-24.4 {file events on shared files and multiple interpreters} { close $f2 set x } {{script 3} {script 1} {script 2}} -test io-24.5 {file events on shared files, deleting file events} { +test io-47.5 {file events on shared files, deleting file events} { set f [open foo r] testfevent create testfevent share $f @@ -3995,7 +5543,7 @@ test io-24.5 {file events on shared files, deleting file events} { close $f set x } {{} {script 2}} -test io-24.6 {file events on shared files, deleting file events} { +test io-47.6 {file events on shared files, deleting file events} { set f [open foo r] testfevent create testfevent share $f @@ -4013,7 +5561,7 @@ test io-24.6 {file events on shared files, deleting file events} { # The above curly closes the test for presence of the "testfevent" command. -test io-25.1 {testing readability conditions} { +test io-48.1 {testing readability conditions} { set f [open bar w] puts $f abcdefg puts $f abcdefg @@ -4038,7 +5586,7 @@ test io-25.1 {testing readability conditions} { vwait x list $x $l } {done {called called called called called called called}} -test io-25.2 {testing readability conditions} {nonBlockFiles} { +test io-48.2 {testing readability conditions} {nonBlockFiles} { set f [open bar w] puts $f abcdefg puts $f abcdefg @@ -4064,7 +5612,7 @@ test io-25.2 {testing readability conditions} {nonBlockFiles} { vwait x list $x $l } {done {called called called called called called called}} -test io-25.3 {testing readability conditions} {unixOnly nonBlockFiles} { +test io-48.3 {testing readability conditions} {unixOnly nonBlockFiles} { set f [open bar w] puts $f abcdefg puts $f abcdefg @@ -4108,7 +5656,7 @@ test io-25.3 {testing readability conditions} {unixOnly nonBlockFiles} { close $f list $x $l } {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} -test io-25.4 {lf write, testing readability, ^Z termination, auto read mode} { +test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4133,7 +5681,7 @@ test io-25.4 {lf write, testing readability, ^Z termination, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.5 {lf write, testing readability, ^Z in middle, auto read mode} { +test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4158,7 +5706,7 @@ test io-25.5 {lf write, testing readability, ^Z in middle, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.6 {cr write, testing readability, ^Z termination, auto read mode} { +test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -4183,7 +5731,7 @@ test io-25.6 {cr write, testing readability, ^Z termination, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.7 {cr write, testing readability, ^Z in middle, auto read mode} { +test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -4208,7 +5756,7 @@ test io-25.7 {cr write, testing readability, ^Z in middle, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.8 {crlf write, testing readability, ^Z termination, auto read mode} { +test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -4233,7 +5781,7 @@ test io-25.8 {crlf write, testing readability, ^Z termination, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.9 {crlf write, testing readability, ^Z in middle, auto read mode} { +test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -4258,7 +5806,7 @@ test io-25.9 {crlf write, testing readability, ^Z in middle, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.10 {lf write, testing readability, ^Z in middle, lf read mode} { +test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4283,7 +5831,7 @@ test io-25.10 {lf write, testing readability, ^Z in middle, lf read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.11 {lf write, testing readability, ^Z termination, lf read mode} { +test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4308,7 +5856,7 @@ test io-25.11 {lf write, testing readability, ^Z termination, lf read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.12 {cr write, testing readability, ^Z in middle, cr read mode} { +test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -4333,7 +5881,7 @@ test io-25.12 {cr write, testing readability, ^Z in middle, cr read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.13 {cr write, testing readability, ^Z termination, cr read mode} { +test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -4358,7 +5906,7 @@ test io-25.13 {cr write, testing readability, ^Z termination, cr read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.14 {crlf write, testing readability, ^Z in middle, crlf read mode} { +test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -4383,7 +5931,7 @@ test io-25.14 {crlf write, testing readability, ^Z in middle, crlf read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.15 {crlf write, testing readability, ^Z termi, crlf read mode} { +test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -4409,7 +5957,7 @@ test io-25.15 {crlf write, testing readability, ^Z termi, crlf read mode} { list $c $l } {3 {abc def {}}} -test io-26.1 {testing crlf reading, leftover cr disgorgment} { +test io-49.1 {testing crlf reading, leftover cr disgorgment} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4438,7 +5986,7 @@ test io-26.1 {testing crlf reading, leftover cr disgorgment} { set l } "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 { } 7 0 {} 1" -test io-26.2 {testing crlf reading, leftover cr disgorgment} { +test io-49.2 {testing crlf reading, leftover cr disgorgment} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4461,7 +6009,7 @@ test io-26.2 {testing crlf reading, leftover cr disgorgment} { close $f set l } "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1" -test io-26.3 {testing crlf reading, leftover cr disgorgment} { +test io-49.3 {testing crlf reading, leftover cr disgorgment} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4482,7 +6030,7 @@ test io-26.3 {testing crlf reading, leftover cr disgorgment} { close $f set l } "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1" -test io-26.4 {testing crlf reading, leftover cr disgorgment} { +test io-49.4 {testing crlf reading, leftover cr disgorgment} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4503,7 +6051,7 @@ test io-26.4 {testing crlf reading, leftover cr disgorgment} { close $f set l } "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1" -test io-26.5 {testing crlf reading, leftover cr disgorgment} { +test io-49.5 {testing crlf reading, leftover cr disgorgment} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4522,7 +6070,7 @@ test io-26.5 {testing crlf reading, leftover cr disgorgment} { set l } [list 7 a\rb\rc 7 {} 7 1] -test io-27.1 {testing handler deletion} { +test io-50.1 {testing handler deletion} { removeFile test1 set f [open test1 w] close $f @@ -4538,7 +6086,7 @@ test io-27.1 {testing handler deletion} { close $f set z } called -test io-27.2 {testing handler deletion with multiple handlers} { +test io-50.2 {testing handler deletion with multiple handlers} { removeFile test1 set f [open test1 w] close $f @@ -4556,7 +6104,7 @@ test io-27.2 {testing handler deletion with multiple handlers} { string compare [string tolower $z] \ [list [list called delhandler $f 0] [list called delhandler $f 1]] } 0 -test io-27.3 {testing handler deletion with multiple handlers} { +test io-50.3 {testing handler deletion with multiple handlers} { removeFile test1 set f [open test1 w] close $f @@ -4582,7 +6130,7 @@ test io-27.3 {testing handler deletion with multiple handlers} { [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] } 0 -test io-27.4 {testing handler deletion vs reentrant calls} { +test io-50.4 {testing handler deletion vs reentrant calls} { removeFile test1 set f [open test1 w] close $f @@ -4606,7 +6154,7 @@ test io-27.4 {testing handler deletion vs reentrant calls} { string compare [string tolower $z] \ {{delrecursive calling recursive} {delrecursive deleting recursive}} } 0 -test io-27.5 {testing handler deletion vs reentrant calls} { +test io-50.5 {testing handler deletion vs reentrant calls} { removeFile test1 set f [open test1 w] close $f @@ -4639,7 +6187,7 @@ test io-27.5 {testing handler deletion vs reentrant calls} { [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] } 0 -test io-27.6 {testing handler deletion vs reentrant calls} { +test io-50.6 {testing handler deletion vs reentrant calls} { removeFile test1 set f [open test1 w] close $f @@ -4681,7 +6229,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} {socket} { +test io-51.1 {Test old socket deletion on Macintosh} {socket} { set x 0 set result "" proc accept {s a p} { @@ -4719,7 +6267,7 @@ test io-28.1 {Test old socket deletion on Macintosh} {socket} { set result } {sock1 sock2 sock3 sock4} -test io-29.1 {TclCopyChannel} { +test io-52.1 {TclCopyChannel} { removeFile test1 set f1 [open [info script]] set f2 [open test1 w] @@ -4729,7 +6277,7 @@ test io-29.1 {TclCopyChannel} { close $f2 string compare $msg "channel \"$f1\" is busy" } {0} -test io-29.2 {TclCopyChannel} { +test io-52.2 {TclCopyChannel} { removeFile test1 set f1 [open [info script]] set f2 [open test1 w] @@ -4741,7 +6289,7 @@ test io-29.2 {TclCopyChannel} { close $f3 string compare $msg "channel \"$f2\" is busy" } {0} -test io-29.3 {TclCopyChannel} { +test io-52.3 {TclCopyChannel} { removeFile test1 set f1 [open [info script]] set f2 [open test1 w] @@ -4758,7 +6306,7 @@ test io-29.3 {TclCopyChannel} { } set result } {0 0 ok} -test io-29.4 {TclCopyChannel} { +test io-52.4 {TclCopyChannel} { removeFile test1 set f1 [open [info script]] set f2 [open test1 w] @@ -4770,7 +6318,7 @@ test io-29.4 {TclCopyChannel} { close $f2 lappend result [file size test1] } {0 0 40} -test io-29.5 {TclCopyChannel} { +test io-52.5 {TclCopyChannel} { removeFile test1 set f1 [open [info script]] set f2 [open test1 w] @@ -4787,7 +6335,7 @@ test io-29.5 {TclCopyChannel} { } set result } {0 0 ok} -test io-29.6 {TclCopyChannel} { +test io-52.6 {TclCopyChannel} { removeFile test1 set f1 [open [info script]] set f2 [open test1 w] @@ -4804,7 +6352,7 @@ test io-29.6 {TclCopyChannel} { } set result } {0 0 ok} -test io-29.7 {TclCopyChannel} { +test io-52.7 {TclCopyChannel} { removeFile test1 set f1 [open [info script]] set f2 [open test1 w] @@ -4821,7 +6369,7 @@ test io-29.7 {TclCopyChannel} { } set result } {0 0 ok} -test io-29.8 {TclCopyChannel} {stdio} { +test io-52.8 {TclCopyChannel} {stdio} { removeFile test1 removeFile pipe set f1 [open pipe w] @@ -4848,7 +6396,7 @@ test io-29.8 {TclCopyChannel} {stdio} { list $s0 [file size test1] } {40 40} -test io-30.1 {CopyData} { +test io-53.1 {CopyData} { removeFile test1 set f1 [open [info script]] set f2 [open test1 w] @@ -4860,7 +6408,7 @@ test io-30.1 {CopyData} { close $f2 lappend result [file size test1] } {0 0 0} -test io-30.2 {CopyData} { +test io-53.2 {CopyData} { removeFile test1 set f1 [open [info script]] set f2 [open test1 w] @@ -4878,7 +6426,7 @@ test io-30.2 {CopyData} { } set result } {0 0 ok} -test io-30.3 {CopyData: background read underflow} {unixOnly} { +test io-53.3 {CopyData: background read underflow} {unixOnly} { removeFile test1 removeFile pipe set f1 [open pipe w] @@ -4908,8 +6456,8 @@ test io-30.3 {CopyData: background read underflow} {unixOnly} { close $f set result } "ready line1 line2 {done\n}" -test io-30.4 {CopyData: background write overflow} {unixOnly} { - set big aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n +test io-53.4 {CopyData: background write overflow} {unixOnly} { + set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n for {set x 0} {$x < 12} {incr x} { append big $big } @@ -4944,6 +6492,7 @@ test io-30.4 {CopyData: background write overflow} {unixOnly} { set big {} set x } done +set result {} proc FcopyTestAccept {sock args} { after 1000 "close $sock" @@ -4956,24 +6505,22 @@ proc FcopyTestDone {bytes {error {}}} { set fcopyTestDone 0 } } -if [catch {socket -server FcopyTestAccept 2828} listen] { - puts stderr "Skipping fcopy error test" -} else { - test io-30.5 {CopyData: error during fcopy} { - set in [open [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 ;# The error occurs here in the b.g. - } - close $in - close $out - set fcopyTestDone ;# 1 for error condition - } 1 -} -test io-30.6 {CopyData: error during fcopy} {stdio} { + +test io-53.5 {CopyData: error during fcopy} {socket} { + set listen [socket -server FcopyTestAccept 2828] + 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 ;# The error occurs here in the b.g. + } + close $in + close $out + set fcopyTestDone ;# 1 for error condition +} 1 +test io-53.6 {CopyData: error during fcopy} {stdio} { removeFile pipe removeFile test1 catch {unset fcopyTestDone} @@ -4991,7 +6538,7 @@ test io-30.6 {CopyData: error during fcopy} {stdio} { set fcopyTestDone ;# 0 for plain end of file } {0} -test io-31.1 {Recursive channel events} {socket} { +test io-54.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. @@ -5043,31 +6590,35 @@ test io-31.1 {Recursive channel events} {socket} { close $cs list $result $x } {{{line 1} 1 2} 2} -test io-31.2 {Testing for busy-wait in recursive channel events} {socket} { +test io-54.2 {Testing for busy-wait in recursive channel events} {socket} { + set accept {} + set after {} set s [socket -server accept 3939] proc accept {s a p} { - global counter + global counter accept + set accept $s set counter 0 fconfigure $s -blocking off -buffering line -translation lf fileevent $s readable "doit $s" } proc doit {s} { - global counter + global counter after incr counter set l [gets $s] if {"$l" == ""} { fileevent $s readable "doit1 $s" - after 1000 newline + set after [after 1000 newline] } } proc doit1 {s} { - global counter + global counter accept incr counter set l [gets $s] close $s + set accept {} } proc producer {} { global writer @@ -5088,9 +6639,12 @@ test io-31.2 {Testing for busy-wait in recursive channel events} {socket} { vwait done close $writer close $s + after cancel $after + if {$accept != {}} {close $accept} set counter } 1 -test io-32.1 {ChannelEventScriptInvoker: deletion} { + +test io-55.1 {ChannelEventScriptInvoker: deletion} { proc eventScript {fd} { close $fd error "planned error" @@ -5106,7 +6660,7 @@ test io-32.1 {ChannelEventScriptInvoker: deletion} { set x } {got_error} -test io-33.1 {ChannelTimerProc} { +test io-56.1 {ChannelTimerProc} { set f [open fooBar w] puts $f "this is a test" close $f @@ -5122,6 +6676,7 @@ test io-33.1 {ChannelTimerProc} { testchannelevent $f set 0 none after idle {set y done} vwait y + close $f lappend result $y } {2 done} @@ -5139,5 +6694,5 @@ removeFile test3 file delete cat -set x "" -unset x +restoreState +return diff --git a/tests/ioCmd.test b/tests/ioCmd.test index fd39263..e8eb96c 100644 --- a/tests/ioCmd.test +++ b/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.49 97/10/31 17:23:22" +# "@(#) ioCmd.test 1.53 98/01/07 16:23:34" if {[string compare test [info procs test]] == 1} then {source defs} @@ -158,7 +158,7 @@ test iocmd-5.3 {seek command} { } {1 {expected integer but got "gugu"}} test iocmd-5.4 {seek command} { list [catch {seek stdin 100 gugu} msg] $msg -} {1 {bad origin "gugu": should be start, current, or end}} +} {1 {bad origin "gugu": must be start, current, or end}} test iocmd-6.1 {tell command} { list [catch {tell} msg] $msg @@ -205,31 +205,31 @@ test iocmd-8.6 {fconfigure command} { test iocmd-8.7 {fconfigure command} { removeFile test1 set f1 [open test1 w] - fconfigure $f1 -translation lf -eofchar {} + fconfigure $f1 -translation lf -eofchar {} -encoding unicode set x [fconfigure $f1] close $f1 set x -} {-blocking 1 -buffering full -buffersize 4096 -eofchar {} -translation lf} +} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} test iocmd-8.8 {fconfigure command} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ - -eofchar {} + -eofchar {} -encoding unicode set x "" lappend x [fconfigure $f1 -buffering] lappend x [fconfigure $f1] close $f1 set x -} {line {-blocking 1 -buffering line -buffersize 3030 -eofchar {} -translation lf}} +} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} test iocmd-8.9 {fconfigure command} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ - -eofchar {} + -eofchar {} -encoding binary set x [fconfigure $f1] close $f1 set x -} {-blocking 1 -buffering none -buffersize 4040 -eofchar {} -translation lf} +} {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} test iocmd-8.10 {fconfigure command} { list [catch {fconfigure a b} msg] $msg } {1 {can not find channel named "a"}} @@ -313,6 +313,8 @@ test iocmd-9.3 {eof command} { list [catch {eof file100} msg] $msg $errorCode } {1 {can not find channel named "file100"} NONE} +# The tests for Tcl_ExecObjCmd are in exec.test + test iocmd-10.1 {fblocked command} { list [catch {fblocked} msg] $msg } {1 {wrong # args: should be "fblocked channelId"}} @@ -488,7 +490,7 @@ test iocmd-15.9 {Tcl_FcopyObjCmd} { } "1 {channel \"$rfile\" wasn't opened for writing}" test iocmd-15.10 {Tcl_FcopyObjCmd} { list [catch {fcopy $rfile $wfile foo bar} msg] $msg -} {1 {bad switch "foo": must be -size, or -command}} +} {1 {bad switch "foo": must be -size or -command}} test iocmd-15.11 {Tcl_FcopyObjCmd} { list [catch {fcopy $rfile $wfile -size foo} msg] $msg } {1 {expected integer but got "foo"}} @@ -508,5 +510,4 @@ after 500 removeFile test5 removeFile pipe removeFile output -set x "" -set x +return diff --git a/tests/join.test b/tests/join.test index 62af644..770f53a 100644 --- a/tests/join.test +++ b/tests/join.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) join.test 1.7 97/10/06 13:04:59 +# SCCS: @(#) join.test 1.8 97/12/08 15:03:20 if {[string compare test [info procs test]] == 1} then {source defs} @@ -46,3 +46,4 @@ test join-3.2 {join is binary ok} { } 11 +return diff --git a/tests/lindex.test b/tests/lindex.test index fa2c1c6..46023ca 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) lindex.test 1.7 97/02/27 16:53:56 +# SCCS: @(#) lindex.test 1.8 97/12/08 15:03:23 if {[string compare test [info procs test]] == 1} then {source defs} @@ -72,3 +72,5 @@ test lindex-3.3 {quoted elements} { test lindex-3.4 {quoted elements} { lindex {a b {c d "e} {f g"}} 2 } {c d "e} + +return diff --git a/tests/link.test b/tests/link.test index 25eefb1..4e405a0 100644 --- a/tests/link.test +++ b/tests/link.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) link.test 1.12 97/01/21 21:16:04 +# SCCS: @(#) link.test 1.14 98/02/18 11:59:28 if {[info commands testlink] == {}} { puts "This application hasn't been compiled with the \"testlink\"" @@ -228,7 +228,10 @@ test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} { list [catch {testlink update 47 {} {} {}} msg] $msg $int } {0 {} 47} +testlink set 0 0 0 - testlink delete foreach i {int real bool string} { catch {unset $i} } + +return diff --git a/tests/linsert.test b/tests/linsert.test index 86a47f5..9111afb 100644 --- a/tests/linsert.test +++ b/tests/linsert.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) linsert.test 1.14 97/11/18 13:54:18 +# SCCS: @(#) linsert.test 1.15 97/12/08 15:03:29 if {[string compare test [info procs test]] == 1} then {source defs} @@ -103,3 +103,5 @@ test linsert-3.2 {linsert won't modify shared argument objects} { catch {unset lis} catch {rename p ""} + +return diff --git a/tests/list.test b/tests/list.test index 6c59f20..f2bd5e5 100644 --- a/tests/list.test +++ b/tests/list.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) list.test 1.22 97/06/23 18:19:17 +# SCCS: @(#) list.test 1.23 97/12/08 15:03:32 if {[string compare test [info procs test]] == 1} then {source defs} @@ -105,3 +105,5 @@ proc slowsort list { test list-3.1 {SetListFromAny and lrange/concat results} { slowsort {fred julie alex carol bill annie} } {alex annie bill carol fred julie} + +return diff --git a/tests/listObj.test b/tests/listObj.test index 00eb7c6..db4a7aa 100644 --- a/tests/listObj.test +++ b/tests/listObj.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: @(#) listObj.test 1.9 97/06/10 15:28:11 +# SCCS: @(#) listObj.test 1.11 97/12/16 13:34:13 if {[info commands testobj] == {}} { puts "This application hasn't been compiled with the \"testobj\"" @@ -27,16 +27,19 @@ test listobj-1.1 {Tcl_GetListObjType} { set result [expr {$first != -1}] } {1} -test listobj-2.1 {Tcl_ListObjForObjArray, use in lappend} { +test listobj-2.1 {Tcl_SetListObj, use in lappend} { catch {unset x} list [lappend x 1 abc def] [lappend x 1 ghi jkl] $x } {{1 abc def} {1 abc def 1 ghi jkl} {1 abc def 1 ghi jkl}} -test listobj-2.2 {Tcl_ListObjForObjArray, use in ObjInterpProc} { +test listobj-2.2 {Tcl_SetListObj, use in ObjInterpProc} { proc return_args {args} { return $args } list [return_args] [return_args x] [return_args x y] } {{} x {x y}} +test listobj-2.3 {Tcl_SetListObj, zero element count} { + list +} {} test listobj-3.1 {Tcl_ListObjAppend, list conversion} { catch {unset x} @@ -174,3 +177,5 @@ test listobj-8.1 {SetListFromAny} { test listobj-9.1 {UpdateStringOfList} { string length [list foo\x00help] } 8 + +return diff --git a/tests/llength.test b/tests/llength.test index badfd17..119c3da 100644 --- a/tests/llength.test +++ b/tests/llength.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: @(#) llength.test 1.4 96/02/16 08:56:11 +# SCCS: @(#) llength.test 1.5 97/12/08 15:03:34 if {[string compare test [info procs test]] == 1} then {source defs} @@ -33,3 +33,5 @@ test llength-2.2 {error conditions} { test llength-2.3 {error conditions} { list [catch {llength "a b c \{"} msg] $msg } {1 {unmatched open brace in list}} + +return diff --git a/tests/load.test b/tests/load.test index 5c33677..4e8d29c 100644 --- a/tests/load.test +++ b/tests/load.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) load.test 1.19 96/11/30 16:05:18 +# SCCS: @(#) load.test 1.22 98/02/11 19:45:38 if {[string compare test [info procs test]] == 1} then {source defs} @@ -42,7 +42,7 @@ test load-1.2 {basic errors} { } {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}} test load-1.3 {basic errors} { list [catch {load a b foobar} msg] $msg -} {1 {couldn't find slave interpreter named "foobar"}} +} {1 {could not find interpreter "foobar"}} test load-1.4 {basic errors} { list [catch {load {}} msg] $msg } {1 {must specify either file name or package name}} @@ -76,6 +76,8 @@ test load-3.1 {error in _Init procedure, same interpreter} { while executing "open non_existent" invoked from within +"if 44 {open non_existent}" + invoked from within "load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} test load-3.2 {error in _Init procedure, slave interpreter} { catch {interp delete x} @@ -90,6 +92,8 @@ test load-3.2 {error in _Init procedure, slave interpreter} { while executing "open non_existent" invoked from within +"if 44 {open non_existent}" + invoked from within "load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}} test load-4.1 {reloading package into same interpreter} { @@ -148,7 +152,7 @@ if {[info command teststaticpkg] != ""} { } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded" test load-8.2 {TclGetLoadedPackages procedure} { list [catch {info loaded gorp} msg] $msg - } {1 {couldn't find slave interpreter named "gorp"}} + } {1 {could not find interpreter "gorp"}} test load-8.3 {TclGetLoadedPackages procedure} { list [info loaded {}] [info loaded child] } "{{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyLoaded} {{{} Test} {[file join $testDir pkgb$ext] Pkgb}}" @@ -158,3 +162,5 @@ if {[info command teststaticpkg] != ""} { } "{{[file join $testDir pkgb$ext] Pkgb} {{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyLoaded} {pkgb_sub pkgb_unsafe}" interp delete child } + +return diff --git a/tests/lrange.test b/tests/lrange.test index 32fbbaa..973c94e 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) lrange.test 1.12 97/06/23 18:19:25 +# SCCS: @(#) lrange.test 1.13 97/12/08 15:03:37 if {[string compare test [info procs test]] == 1} then {source defs} @@ -81,3 +81,5 @@ test lrange-2.5 {error conditions} { test lrange-2.6 {error conditions} { list [catch {lrange "a b c \{ d e" 1 4} msg] $msg } {1 {unmatched open brace in list}} + +return diff --git a/tests/lreplace.test b/tests/lreplace.test index 44e8ee1..faca206 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) lreplace.test 1.16 97/10/29 16:32:39 +# SCCS: @(#) lreplace.test 1.17 97/12/08 15:03:40 if {[string compare test [info procs test]] == 1} then {source defs} @@ -129,3 +129,5 @@ test lreplace-3.1 {lreplace won't modify shared argument objects} { } "a b c" catch {unset foo} + +return diff --git a/tests/lsearch.test b/tests/lsearch.test index 4eda84b..d0a1ba2 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) lsearch.test 1.7 97/04/30 13:23:53 +# SCCS: @(#) lsearch.test 1.8 97/12/08 15:03:42 if {[string compare test [info procs test]] == 1} then {source defs} @@ -84,3 +84,5 @@ test lsearch-4.2 {binary data} { append x two lsearch -exact [list foo one\000two bar] $x } 1 + +return diff --git a/tests/macFCmd.test b/tests/macFCmd.test index a06004c..5290d05 100644 --- a/tests/macFCmd.test +++ b/tests/macFCmd.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: @(#) macFCmd.test 1.3 97/06/23 18:24:10 +# SCCS: @(#) macFCmd.test 1.4 97/12/08 15:06:36 # if {$tcl_platform(platform) != "macintosh"} { @@ -166,3 +166,5 @@ test macFCmd-4.7 {SetFileReadOnly - directory readonly} {notFileSharing} { file mkdir foo.dir list [catch {file attributes foo.dir -readonly 1} msg] $msg [file delete -force foo.dir] } {1 {cannot set a directory to read-only when File Sharing is turned off} {}} + +return diff --git a/tests/misc.test b/tests/misc.test index b2168c1..5faa63e 100644 --- a/tests/misc.test +++ b/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.12 97/07/02 16:41:34 +# SCCS: @(#) misc.test 1.14 97/12/16 13:34:35 if {[string compare test [info procs test]] == 1} then {source defs} @@ -48,4 +48,11 @@ test misc-1.2 {error in variable ref. in command in array reference} { " set msg {} list [catch tstProc msg] $msg $errorInfo -} {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\"} +} {1 {missing close-brace for variable name} {missing close-brace for variable name + while compiling +"set tst $a([winfo name " + (compiling body of proc "tstProc", line 4) + invoked from within +"tstProc"}} + +return diff --git a/tests/namespace-old.test b/tests/namespace-old.test index f743722..df2c822 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-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: @(#) namespace-old.test 1.5 97/06/20 14:51:17 +# SCCS: @(#) namespace-old.test 1.6 97/12/08 15:07:16 if {[string compare test [info procs test]] == 1} then {source defs} @@ -842,3 +842,5 @@ catch {unset x} catch {unset test_ns_var_global} catch {unset cmd} eval namespace delete [namespace children :: test_ns_*] + +return diff --git a/tests/namespace.test b/tests/namespace.test index e876391..2c186e1 100644 --- a/tests/namespace.test +++ b/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.15 97/07/30 15:26:42 +# SCCS: @(#) namespace.test 1.18 97/12/16 13:34:44 if {[string compare test [info procs test]] == 1} then {source defs} @@ -1078,3 +1078,5 @@ catch {unset l} catch {unset msg} catch {unset trigger} eval namespace delete [namespace children :: test_ns_*] + +return diff --git a/tests/obj.test b/tests/obj.test index 08f230b..0a854af 100644 --- a/tests/obj.test +++ b/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.12 97/10/31 17:23:23 +# @(#) obj.test 1.15 98/01/06 11:12:00 if {[info commands testobj] == {}} { puts "This application hasn't been compiled with the \"testobj\"" @@ -83,31 +83,55 @@ test obj-6.2 {Tcl_DuplicateObj, "empty string" object} { lappend result [testobj refcount 2] } {{} {} {} {} 2 3} -test obj-7.1 {Tcl_GetStringFromObj, return existing string rep} { +test obj-7.1 {Tcl_GetString, return existing string rep} { + set result "" + lappend result [testintobj set 1 47] + lappend result [testintobj get2 1] +} {47 47} +test obj-7.2 {Tcl_GetString, "empty string" object} { + set result "" + lappend result [testobj newobj 1] + lappend result [teststringobj append 1 abc -1] + lappend result [teststringobj get2 1] +} {{} abc abc} +test obj-7.3 {Tcl_GetString, returns string internal rep (DString)} { + set result "" + lappend result [teststringobj set 1 xyz] + lappend result [teststringobj append 1 abc -1] + lappend result [teststringobj get2 1] +} {xyz xyzabc xyzabc} +test obj-7.4 {Tcl_GetString, recompute string rep from internal rep} { + set result "" + lappend result [testintobj set 1 77] + lappend result [testintobj mult10 1] + lappend result [teststringobj get2 1] +} {77 770 770} + +test obj-8.1 {Tcl_GetStringFromObj, return existing string rep} { set result "" lappend result [testintobj set 1 47] lappend result [testintobj get 1] } {47 47} -test obj-7.2 {Tcl_GetStringFromObj, "empty string" object} { +test obj-8.2 {Tcl_GetStringFromObj, "empty string" object} { set result "" lappend result [testobj newobj 1] lappend result [teststringobj append 1 abc -1] lappend result [teststringobj get 1] } {{} abc abc} -test obj-7.3 {Tcl_GetStringFromObj, returns string internal rep (DString)} { +test obj-8.3 {Tcl_GetStringFromObj, returns string internal rep (DString)} { set result "" lappend result [teststringobj set 1 xyz] lappend result [teststringobj append 1 abc -1] lappend result [teststringobj get 1] } {xyz xyzabc xyzabc} -test obj-7.4 {Tcl_GetStringFromObj, recompute string rep from internal rep} { +test obj-8.4 {Tcl_GetStringFromObj, recompute string rep from internal rep} { set result "" lappend result [testintobj set 1 77] lappend result [testintobj mult10 1] lappend result [teststringobj get 1] } {77 770 770} -test obj-8.1 {Tcl_NewBooleanObj} { +test obj-9.1 {Tcl_NewBooleanObj} { set result "" lappend result [testobj freeallvars] lappend result [testbooleanobj set 1 0] @@ -115,7 +139,7 @@ test obj-8.1 {Tcl_NewBooleanObj} { lappend result [testobj refcount 1] } {{} 0 boolean 2} -test obj-9.1 {Tcl_SetBooleanObj, existing "empty string" object} { +test obj-10.1 {Tcl_SetBooleanObj, existing "empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -123,7 +147,7 @@ test obj-9.1 {Tcl_SetBooleanObj, existing "empty string" object} { lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 0 boolean 2} -test obj-9.2 {Tcl_SetBooleanObj, existing non-"empty string" object} { +test obj-10.2 {Tcl_SetBooleanObj, existing non-"empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 98765] @@ -132,50 +156,50 @@ test obj-9.2 {Tcl_SetBooleanObj, existing non-"empty string" object} { lappend result [testobj refcount 1] } {{} 98765 1 boolean 2} -test obj-10.1 {Tcl_GetBooleanFromObj, existing boolean object} { +test obj-11.1 {Tcl_GetBooleanFromObj, existing boolean object} { set result "" lappend result [testbooleanobj set 1 1] lappend result [testbooleanobj not 1] ;# gets existing boolean rep } {1 0} -test obj-10.2 {Tcl_GetBooleanFromObj, convert to boolean} { +test obj-11.2 {Tcl_GetBooleanFromObj, convert to boolean} { set result "" lappend result [testintobj set 1 47] lappend result [testbooleanobj not 1] ;# must convert to bool lappend result [testobj type 1] } {47 0 boolean} -test obj-10.3 {Tcl_GetBooleanFromObj, error converting to boolean} { +test obj-11.3 {Tcl_GetBooleanFromObj, error converting to boolean} { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {abc 1 {expected boolean value but got "abc"}} -test obj-10.4 {Tcl_GetBooleanFromObj, error converting from "empty string"} { +test obj-11.4 {Tcl_GetBooleanFromObj, error converting from "empty string"} { set result "" lappend result [testobj newobj 1] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {{} 1 {expected boolean value but got ""}} -test obj-11.1 {DupBooleanInternalRep} { +test obj-12.1 {DupBooleanInternalRep} { set result "" lappend result [testbooleanobj set 1 1] lappend result [testobj duplicate 1 2] ;# uses DupBooleanInternalRep lappend result [testbooleanobj get 2] } {1 1 1} -test obj-12.1 {SetBooleanFromAny, int to boolean special case} { +test obj-13.1 {SetBooleanFromAny, int to boolean special case} { set result "" lappend result [testintobj set 1 1234] lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny lappend result [testobj type 1] } {1234 0 boolean} -test obj-12.2 {SetBooleanFromAny, double to boolean special case} { +test obj-13.2 {SetBooleanFromAny, double to boolean special case} { set result "" lappend result [testdoubleobj set 1 3.14159] lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny lappend result [testobj type 1] } {3.14159 0 boolean} -test obj-12.3 {SetBooleanFromAny, special case strings representing booleans} { +test obj-13.3 {SetBooleanFromAny, special case strings representing booleans} { set result "" foreach s {yes no true false on off} { teststringobj set 1 $s @@ -183,40 +207,46 @@ test obj-12.3 {SetBooleanFromAny, special case strings representing booleans} { } lappend result [testobj type 1] } {0 1 0 1 0 1 boolean} -test obj-12.4 {SetBooleanFromAny, recompute string rep then parse it} { +test obj-13.4 {SetBooleanFromAny, recompute string rep then parse it} { set result "" lappend result [testintobj set 1 456] lappend result [testintobj div10 1] lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny lappend result [testobj type 1] } {456 45 0 boolean} -test obj-12.5 {SetBooleanFromAny, error parsing string} { +test obj-13.5 {SetBooleanFromAny, error parsing string} { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {abc 1 {expected boolean value but got "abc"}} -test obj-12.6 {SetBooleanFromAny, error parsing string} { +test obj-13.6 {SetBooleanFromAny, error parsing string} { set result "" lappend result [teststringobj set 1 x1.0] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {x1.0 1 {expected boolean value but got "x1.0"}} -test obj-12.7 {SetBooleanFromAny, error converting from "empty string"} { +test obj-13.7 {SetBooleanFromAny, error converting from "empty string"} { set result "" lappend result [testobj newobj 1] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {{} 1 {expected boolean value but got ""}} +test obj-13.8 {SetBooleanFromAny, unicode strings} { + set result "" + lappend result [teststringobj set 1 1\u7777] + lappend result [catch {testbooleanobj not 1} msg] + lappend result $msg +} "1\u7777 1 {expected boolean value but got \"1\u7777\"}" -test obj-13.1 {UpdateStringOfBoolean} { +test obj-14.1 {UpdateStringOfBoolean} { set result "" lappend result [testbooleanobj set 1 0] lappend result [testbooleanobj not 1] lappend result [testbooleanobj get 1] ;# must update string rep } {0 1 1} -test obj-14.1 {Tcl_NewDoubleObj} { +test obj-15.1 {Tcl_NewDoubleObj} { set result "" lappend result [testobj freeallvars] lappend result [testdoubleobj set 1 3.1459] @@ -224,7 +254,7 @@ test obj-14.1 {Tcl_NewDoubleObj} { lappend result [testobj refcount 1] } {{} 3.1459 double 2} -test obj-15.1 {Tcl_SetDoubleObj, existing "empty string" object} { +test obj-16.1 {Tcl_SetDoubleObj, existing "empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -232,7 +262,7 @@ test obj-15.1 {Tcl_SetDoubleObj, existing "empty string" object} { lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 0.123 double 2} -test obj-15.2 {Tcl_SetDoubleObj, existing non-"empty string" object} { +test obj-16.2 {Tcl_SetDoubleObj, existing non-"empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 98765] @@ -241,83 +271,83 @@ test obj-15.2 {Tcl_SetDoubleObj, existing non-"empty string" object} { lappend result [testobj refcount 1] } {{} 98765 27.56 double 2} -test obj-16.1 {Tcl_GetDoubleFromObj, existing double object} { +test obj-17.1 {Tcl_GetDoubleFromObj, existing double object} { set result "" 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} { +test obj-17.2 {Tcl_GetDoubleFromObj, convert to double} { set result "" lappend result [testintobj set 1 477] 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} { +test obj-17.3 {Tcl_GetDoubleFromObj, error converting to double} { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testdoubleobj mult10 1} msg] lappend result $msg } {abc 1 {expected floating-point number but got "abc"}} -test obj-16.4 {Tcl_GetDoubleFromObj, error converting from "empty string"} { +test obj-17.4 {Tcl_GetDoubleFromObj, error converting from "empty string"} { set result "" lappend result [testobj newobj 1] lappend result [catch {testdoubleobj div10 1} msg] lappend result $msg } {{} 1 {expected floating-point number but got ""}} -test obj-17.1 {DupDoubleInternalRep} { +test obj-18.1 {DupDoubleInternalRep} { set result "" 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} { +test obj-19.1 {SetDoubleFromAny, int to double special case} { set result "" lappend result [testintobj set 1 1234] lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny lappend result [testobj type 1] } {1234 12340.0 double} -test obj-18.2 {SetDoubleFromAny, boolean to double special case} { +test obj-19.2 {SetDoubleFromAny, boolean to double special case} { set result "" lappend result [testbooleanobj set 1 1] lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny lappend result [testobj type 1] } {1 10.0 double} -test obj-18.3 {SetDoubleFromAny, recompute string rep then parse it} { +test obj-19.3 {SetDoubleFromAny, recompute string rep then parse it} { set result "" lappend result [testintobj set 1 456] lappend result [testintobj div10 1] lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny lappend result [testobj type 1] } {456 45 450.0 double} -test obj-18.4 {SetDoubleFromAny, error parsing string} { +test obj-19.4 {SetDoubleFromAny, error parsing string} { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testdoubleobj mult10 1} msg] lappend result $msg } {abc 1 {expected floating-point number but got "abc"}} -test obj-18.5 {SetDoubleFromAny, error parsing string} { +test obj-19.5 {SetDoubleFromAny, error parsing string} { set result "" lappend result [teststringobj set 1 x1.0] lappend result [catch {testdoubleobj mult10 1} msg] lappend result $msg } {x1.0 1 {expected floating-point number but got "x1.0"}} -test obj-18.6 {SetDoubleFromAny, error converting from "empty string"} { +test obj-19.6 {SetDoubleFromAny, error converting from "empty string"} { set result "" lappend result [testobj newobj 1] lappend result [catch {testdoubleobj div10 1} msg] lappend result $msg } {{} 1 {expected floating-point number but got ""}} -test obj-19.1 {UpdateStringOfDouble} { +test obj-20.1 {UpdateStringOfDouble} { set result "" 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} { +test obj-21.1 {Tcl_NewIntObj} { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 55] @@ -325,7 +355,7 @@ test obj-20.1 {Tcl_NewIntObj} { lappend result [testobj refcount 1] } {{} 55 int 2} -test obj-21.1 {Tcl_SetIntObj, existing "empty string" object} { +test obj-22.1 {Tcl_SetIntObj, existing "empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -333,7 +363,7 @@ test obj-21.1 {Tcl_SetIntObj, existing "empty string" object} { lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 77 int 2} -test obj-21.2 {Tcl_SetIntObj, existing non-"empty string" object} { +test obj-22.2 {Tcl_SetIntObj, existing non-"empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testdoubleobj set 1 12.34] @@ -342,94 +372,94 @@ test obj-21.2 {Tcl_SetIntObj, existing non-"empty string" object} { lappend result [testobj refcount 1] } {{} 12.34 77 int 2} -test obj-22.1 {Tcl_GetIntFromObj, existing int object} { +test obj-23.1 {Tcl_GetIntFromObj, existing int object} { set result "" lappend result [testintobj set 1 22] lappend result [testintobj mult10 1] ;# gets existing int rep } {22 220} -test obj-22.2 {Tcl_GetIntFromObj, convert to int} { +test obj-23.2 {Tcl_GetIntFromObj, convert to int} { set result "" lappend result [testintobj set 1 477] lappend result [testintobj div10 1] ;# must convert to bool lappend result [testobj type 1] } {477 47 int} -test obj-22.3 {Tcl_GetIntFromObj, error converting to int} { +test obj-23.3 {Tcl_GetIntFromObj, error converting to int} { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {abc 1 {expected integer but got "abc"}} -test obj-22.4 {Tcl_GetIntFromObj, error converting from "empty string"} { +test obj-23.4 {Tcl_GetIntFromObj, error converting from "empty string"} { set result "" lappend result [testobj newobj 1] lappend result [catch {testintobj div10 1} msg] lappend result $msg } {{} 1 {expected integer but got ""}} -test obj-22.5 {Tcl_GetIntFromObj, integer too large to represent as non-long error} {nonPortable} { +test obj-23.5 {Tcl_GetIntFromObj, integer too large to represent as non-long error} {nonPortable} { set result "" lappend result [testobj newobj 1] lappend result [testintobj inttoobigtest 1] } {{} 1} -test obj-23.1 {DupIntInternalRep} { +test obj-24.1 {DupIntInternalRep} { set result "" lappend result [testintobj set 1 23] lappend result [testobj duplicate 1 2] ;# uses DupIntInternalRep lappend result [testintobj get 2] } {23 23 23} -test obj-24.1 {SetIntFromAny, int to int special case} { +test obj-25.1 {SetIntFromAny, int to int special case} { set result "" lappend result [testintobj set 1 1234] lappend result [testintobj mult10 1] ;# converts with SetIntFromAny lappend result [testobj type 1] } {1234 12340 int} -test obj-24.2 {SetIntFromAny, boolean to int special case} { +test obj-25.2 {SetIntFromAny, boolean to int special case} { set result "" lappend result [testbooleanobj set 1 1] lappend result [testintobj mult10 1] ;# converts with SetIntFromAny lappend result [testobj type 1] } {1 10 int} -test obj-24.3 {SetIntFromAny, recompute string rep then parse it} { +test obj-25.3 {SetIntFromAny, recompute string rep then parse it} { set result "" lappend result [testintobj set 1 456] lappend result [testintobj div10 1] lappend result [testintobj mult10 1] ;# converts with SetIntFromAny lappend result [testobj type 1] } {456 45 450 int} -test obj-24.4 {SetIntFromAny, error parsing string} { +test obj-25.4 {SetIntFromAny, error parsing string} { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {abc 1 {expected integer but got "abc"}} -test obj-24.5 {SetIntFromAny, error parsing string} { +test obj-25.5 {SetIntFromAny, error parsing string} { set result "" lappend result [teststringobj set 1 x17] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {x17 1 {expected integer but got "x17"}} -test obj-24.6 {SetIntFromAny, integer too large} {nonPortable} { +test obj-25.6 {SetIntFromAny, integer too large} {nonPortable} { set result "" lappend result [teststringobj set 1 123456789012345678901] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {123456789012345678901 1 {integer value too large to represent}} -test obj-24.7 {SetIntFromAny, error converting from "empty string"} { +test obj-25.7 {SetIntFromAny, error converting from "empty string"} { set result "" lappend result [testobj newobj 1] lappend result [catch {testintobj div10 1} msg] lappend result $msg } {{} 1 {expected integer but got ""}} -test obj-25.1 {UpdateStringOfInt} { +test obj-26.1 {UpdateStringOfInt} { set result "" lappend result [testintobj set 1 512] lappend result [testintobj mult10 1] lappend result [testintobj get 1] ;# must update string rep } {512 5120 5120} -test obj-26.1 {Tcl_NewLongObj} { +test obj-27.1 {Tcl_NewLongObj} { set result "" lappend result [testobj freeallvars] testintobj setmaxlong 1 @@ -438,7 +468,7 @@ test obj-26.1 {Tcl_NewLongObj} { lappend result [testobj refcount 1] } {{} 1 int 1} -test obj-27.1 {Tcl_SetLongObj, existing "empty string" object} { +test obj-28.1 {Tcl_SetLongObj, existing "empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -446,7 +476,7 @@ test obj-27.1 {Tcl_SetLongObj, existing "empty string" object} { lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 77 int 2} -test obj-27.2 {Tcl_SetLongObj, existing non-"empty string" object} { +test obj-28.2 {Tcl_SetLongObj, existing non-"empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testdoubleobj set 1 12.34] @@ -455,31 +485,31 @@ test obj-27.2 {Tcl_SetLongObj, existing non-"empty string" object} { lappend result [testobj refcount 1] } {{} 12.34 77 int 2} -test obj-28.1 {Tcl_GetLongFromObj, existing long integer object} { +test obj-29.1 {Tcl_GetLongFromObj, existing long integer object} { set result "" lappend result [testintobj setlong 1 22] lappend result [testintobj mult10 1] ;# gets existing long int rep } {22 220} -test obj-28.2 {Tcl_GetLongFromObj, convert to long} { +test obj-29.2 {Tcl_GetLongFromObj, convert to long} { set result "" lappend result [testintobj setlong 1 477] lappend result [testintobj div10 1] ;# must convert to bool lappend result [testobj type 1] } {477 47 int} -test obj-28.3 {Tcl_GetLongFromObj, error converting to long integer} { +test obj-29.3 {Tcl_GetLongFromObj, error converting to long integer} { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int lappend result $msg } {abc 1 {expected integer but got "abc"}} -test obj-28.4 {Tcl_GetLongFromObj, error converting from "empty string"} { +test obj-29.4 {Tcl_GetLongFromObj, error converting from "empty string"} { set result "" lappend result [testobj newobj 1] lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int lappend result $msg } {{} 1 {expected integer but got ""}} -test obj-29.1 {Ref counting and object deletion, simple types} { +test obj-30.1 {Ref counting and object deletion, simple types} { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 1024] @@ -494,3 +524,5 @@ test obj-29.1 {Ref counting and object deletion, simple types} { } {{} 1024 1024 int 4 4 0 boolean 3 2} testobj freeallvars + +return diff --git a/tests/opt.test b/tests/opt.test index 0b35b76..72efead 100644 --- a/tests/opt.test +++ b/tests/opt.test @@ -1,4 +1,4 @@ -# Package covered: opt0.1/optparse.tcl +# Package covered: opt1.0/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 @@ -10,12 +10,12 @@ # 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.2 97/08/20 15:57:18 +# SCCS: @(#) opt.test 1.7 98/01/07 17:07:52 if {[string compare test [info procs test]] == 1} then {source defs} # the package we are going to test -package require opt 0.1 +package require opt 0.4.1 # we are using implementation specifics to test the package @@ -253,3 +253,26 @@ test opt-10.10 {medium size overall test} { list [catch {optTest save tst foo} msg] [lindex [split $msg "\n"] 0] } {1 {too many arguments (unexpected argument(s): foo), usage:}} + +test opt-11.1 {too many args test 2} { + set key [::tcl::OptKeyRegister {-foo}] + list [catch {::tcl::OptKeyParse $key {-foo blah}} msg] $msg\ + [::tcl::OptKeyDelete $key] +} {1 {too many arguments (unexpected argument(s): blah), usage: + Var/FlagName Type Value Help + ------------ ---- ----- ---- + ( -help gives this help ) + -foo boolflag (false) } {}} + + + +test opt-11.2 {default value for args} { + set args {} + set key [::tcl::OptKeyRegister {{args -list {a b c} "args..."}}] + ::tcl::OptKeyParse $key {} + ::tcl::OptKeyDelete $key + set args +} {a b c} + + +return diff --git a/tests/osa.test b/tests/osa.test index 0e94838..3392128 100644 --- a/tests/osa.test +++ b/tests/osa.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: @(#) osa.test 1.4 97/06/23 18:24:24 +# SCCS: @(#) osa.test 1.5 97/12/08 15:06:02 if {[string compare test [info procs test]] == 1} then {source defs} @@ -34,3 +34,5 @@ test osa-1.2 {Tcl_OSAComponentCmd} { test osa-1.3 {TclOSACompileCmd} { list [catch {AppleScript compile} msg] $msg } {1 {wrong # args: should be "AppleScript compile ?options? code"}} + +return diff --git a/tests/parse.test b/tests/parse.test index 514ed2a..e14449d 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -1,556 +1,705 @@ -# Commands covered: set (plus basic command syntax). Also tests -# the procedures in the file tclParse.c. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and +# This file contains a collection of tests for the procedures in the +# file tclParse.c. 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. +# Copyright (c) 1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) parse.test 1.42 97/08/04 11:05:53 - -if {[string compare test [info procs test]] == 1} then {source defs} +# SCCS: @(#) parse.test 1.14 97/12/22 19:41:39 -proc fourArgs {a b c d} { - global arg1 arg2 arg3 arg4 - set arg1 $a - set arg2 $b - set arg3 $c - set arg4 $d +if {[info commands testparser] == {}} { + puts "This application hasn't been compiled with the \"testparser\"" + puts "command, so I can't test the Tcl parser." + return } -proc getArgs args { - global argv - set argv $args -} - -# Basic argument parsing. - -test parse-1.1 {basic argument parsing} { - set arg1 {} - fourArgs a b c d - list $arg1 $arg2 $arg3 $arg4 -} {a b c d} -test parse-1.2 {basic argument parsing} { - set arg1 {} - eval "fourArgs 123\v4\f56\r7890" - list $arg1 $arg2 $arg3 $arg4 -} {123 4 56 7890} - -# Quotes. +if {[string compare test [info procs test]] == 1} then {source defs} -test parse-2.1 {quotes and variable-substitution} { - getArgs "a b c" d - set argv -} {{a b c} d} -test parse-2.2 {quotes and variable-substitution} { - set a 101 - getArgs "a$a b c" - set argv -} {{a101 b c}} -test parse-2.3 {quotes and variable-substitution} { - set argv "xy[format xabc]" - set argv -} {xyxabc} -test parse-2.4 {quotes and variable-substitution} { - set argv "xy\t" - set argv -} xy\t -test parse-2.5 {quotes and variable-substitution} { - set argv "a b c -d e f" - set argv -} a\ b\tc\nd\ e\ f -test parse-2.6 {quotes and variable-substitution} { - set argv a"bcd"e - set argv -} {a"bcd"e} +test parse-1.1 {Tcl_ParseCommand procedure, computing string length} { + testparser [bytestring "foo\0 bar"] -1 +} {- foo 1 simple foo 1 text foo 0 {}} +test parse-1.2 {Tcl_ParseCommand procedure, computing string length} { + testparser "foo bar" -1 +} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}} +test parse-1.3 {Tcl_ParseCommand procedure, leading space} { + testparser " \n\t foo" 0 +} {- foo 1 simple foo 1 text foo 0 {}} +test parse-1.4 {Tcl_ParseCommand procedure, leading space} { + testparser "\f\r\vfoo" 0 +} {- foo 1 simple foo 1 text foo 0 {}} +test parse-1.5 {Tcl_ParseCommand procedure, backslash-newline in leading space} { + testparser " \\\n foo" 0 +} {- foo 1 simple foo 1 text foo 0 {}} +test parse-1.6 {Tcl_ParseCommand procedure, backslash-newline in leading space} { + testparser { \a foo} 0 +} {- {\a foo} 2 word {\a} 1 backslash {\a} 0 simple foo 1 text foo 0 {}} +test parse-1.7 {Tcl_ParseCommand procedure, missing continuation line in leading space} { + testparser " \\\n" 0 +} {- {} 0 {}} +test parse-1.8 {Tcl_ParseCommand procedure, eof in leading space} { + testparser " foo" 3 +} {- {} 0 { foo}} -# Braces. +test parse-2.1 {Tcl_ParseCommand procedure, comments} { + testparser "# foo bar\n foo" 0 +} {{# foo bar +} foo 1 simple foo 1 text foo 0 {}} +test parse-2.2 {Tcl_ParseCommand procedure, several comments} { + testparser " # foo bar\n # another comment\n\n foo" 0 +} {{# foo bar + # another comment +} foo 1 simple foo 1 text foo 0 {}} +test parse-2.3 {Tcl_ParseCommand procedure, backslash-newline in comments} { + testparser " # foo bar\\\ncomment on continuation line\nfoo" 0 +} {#\ foo\ bar\\\ncomment\ on\ continuation\ line\n foo 1 simple foo 1 text foo 0 {}} +test parse-2.4 {Tcl_ParseCommand procedure, missing continuation line in comment} { + testparser "# \\\n" 0 +} {#\ \ \ \\\n {} 0 {}} +test parse-2.5 {Tcl_ParseCommand procedure, eof in comment} { + testparser " # foo bar\nfoo" 8 +} {{# foo b} {} 0 {ar +foo}} -test parse-3.1 {braces} { - getArgs {a b c} d - set argv -} "{a b c} d" -test parse-3.2 {braces} { - set a 101 - set argv {a$a b c} - set b [string index $argv 1] - set b -} {$} -test parse-3.3 {braces} { - set argv {a[format xyz] b} - string length $argv -} 15 -test parse-3.4 {braces} { - set argv {a\nb\}} - string length $argv -} 6 -test parse-3.5 {braces} { - set argv {{{{}}}} - set argv -} "{{{}}}" -test parse-3.6 {braces} { - set argv a{{}}b - set argv -} "a{{}}b" -test parse-3.7 {braces} { - set a [format "last]"] - set a -} {last]} +test parse-3.1 {Tcl_ParseCommand procedure, parsing words, skipping space} { + testparser "foo bar\t\tx" 0 +} {- {foo bar x} 3 simple foo 1 text foo 0 simple bar 1 text bar 0 simple x 1 text x 0 {}} +test parse-3.2 {Tcl_ParseCommand procedure, missing continuation line in leading space} { + testparser "abc \\\n" 0 +} {- abc\ \ \\\n 1 simple abc 1 text abc 0 {}} +test parse-3.3 {Tcl_ParseCommand procedure, parsing words, command ends in space} { + testparser "foo ; bar x" 0 +} {- {foo ;} 1 simple foo 1 text foo 0 { bar x}} +test parse-3.4 {Tcl_ParseCommand procedure, parsing words, command ends in space} { + testparser "foo " 5 +} {- {foo } 1 simple foo 1 text foo 0 { }} +test parse-3.5 {Tcl_ParseCommand procedure, quoted words} { + testparser {foo "a b c" d "efg";} 0 +} {- {foo "a b c" d "efg";} 4 simple foo 1 text foo 0 simple {"a b c"} 1 text {a b c} 0 simple d 1 text d 0 simple {"efg"} 1 text efg 0 {}} +test parse-3.6 {Tcl_ParseCommand procedure, words in braces} { + testparser {foo {a $b [concat foo]} {c d}} 0 +} {- {foo {a $b [concat foo]} {c d}} 3 simple foo 1 text foo 0 simple {{a $b [concat foo]}} 1 text {a $b [concat foo]} 0 simple {{c d}} 1 text {c d} 0 {}} +test parse-3.7 {Tcl_ParseCommand procedure, error in unquoted word} { + list [catch {testparser "foo \$\{abc" 0} msg] $msg $errorInfo +} {1 {missing close-brace for variable name} missing\ close-brace\ for\ variable\ name\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\$\\\{abc\"\ 0\"} -# Command substitution. +test parse-4.1 {Tcl_ParseCommand procedure, simple words} { + testparser {foo} 0 +} {- foo 1 simple foo 1 text foo 0 {}} +test parse-4.2 {Tcl_ParseCommand procedure, simple words} { + testparser {{abc}} 0 +} {- {{abc}} 1 simple {{abc}} 1 text abc 0 {}} +test parse-4.3 {Tcl_ParseCommand procedure, simple words} { + testparser {"c d"} 0 +} {- {"c d"} 1 simple {"c d"} 1 text {c d} 0 {}} +test parse-4.4 {Tcl_ParseCommand procedure, simple words} { + testparser {x$d} 0 +} {- {x$d} 1 word {x$d} 3 text x 0 variable {$d} 1 text d 0 {}} +test parse-4.5 {Tcl_ParseCommand procedure, simple words} { + testparser {"a [foo] b"} 0 +} {- {"a [foo] b"} 1 word {"a [foo] b"} 3 text {a } 0 command {[foo]} 0 text { b} 0 {}} +test parse-4.6 {Tcl_ParseCommand procedure, simple words} { + testparser {$x} 0 +} {- {$x} 1 word {$x} 2 variable {$x} 1 text x 0 {}} -test parse-4.1 {command substitution} { - set a [format xyz] - set a -} xyz -test parse-4.2 {command substitution} { - set a a[format xyz]b[format q] - set a -} axyzbq -test parse-4.3 {command substitution} { - set a a[ -set b 22; -format %s $b +test parse-5.1 {Tcl_ParseCommand procedure, backslash-newline terminates word} { + testparser "{abc}\\\n" 0 +} {- \{abc\}\\\n 1 simple {{abc}} 1 text abc 0 {}} +test parse-5.2 {Tcl_ParseCommand procedure, backslash-newline terminates word} { + testparser "foo\\\nbar" 0 +} {- foo\\\nbar 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}} +test parse-5.3 {Tcl_ParseCommand procedure, word terminator is command terminator} { + testparser "foo\n bar" 0 +} {- {foo +} 1 simple foo 1 text foo 0 { bar}} +test parse-5.4 {Tcl_ParseCommand procedure, word terminator is command terminator} { + testparser "foo; bar" 0 +} {- {foo;} 1 simple foo 1 text foo 0 { bar}} +test parse-5.5 {Tcl_ParseCommand procedure, word terminator is end of string} { + testparser "\"foo\" bar" 5 +} {- {"foo"} 1 simple {"foo"} 1 text foo 0 { bar}} +test parse-5.6 {Tcl_ParseCommand procedure, junk after close quote} { + list [catch {testparser {foo "bar"x} 0} msg] $msg $errorInfo +} {1 {extra characters after close-quote} {extra characters after close-quote + (remainder of script: "x") + invoked from within +"testparser {foo "bar"x} 0"}} +test parse-5.7 {Tcl_ParseCommand procedure, backslash-newline after close quote} { + testparser "foo \"bar\"\\\nx" 0 +} {- foo\ \"bar\"\\\nx 3 simple foo 1 text foo 0 simple {"bar"} 1 text bar 0 simple x 1 text x 0 {}} +test parse-5.8 {Tcl_ParseCommand procedure, junk after close brace} { + list [catch {testparser {foo {bar}x} 0} msg] $msg $errorInfo +} {1 {extra characters after close-brace} {extra characters after close-brace + (remainder of script: "x") + invoked from within +"testparser {foo {bar}x} 0"}} +test parse-5.9 {Tcl_ParseCommand procedure, backslash-newline after close brace} { + testparser "foo {bar}\\\nx" 0 +} {- foo\ \{bar\}\\\nx 3 simple foo 1 text foo 0 simple {{bar}} 1 text bar 0 simple x 1 text x 0 {}} -]b - set a -} a22b -test parse-4.4 {command substitution} { - set a 7.7 - if [catch {expr int($a)}] {set a foo} - set a -} 7.7 +test parse-6.1 {ParseTokens procedure, empty word} { + testparser {""} 0 +} {- {""} 1 simple {""} 1 text {} 0 {}} +test parse-6.2 {ParseTokens procedure, simple range} { + testparser {"abc$x.e"} 0 +} {- {"abc$x.e"} 1 word {"abc$x.e"} 4 text abc 0 variable {$x} 1 text x 0 text .e 0 {}} +test parse-6.3 {ParseTokens procedure, variable reference} { + testparser {abc$x.e $y(z)} 0 +} {- {abc$x.e $y(z)} 2 word {abc$x.e} 4 text abc 0 variable {$x} 1 text x 0 text .e 0 word {$y(z)} 3 variable {$y(z)} 2 text y 0 text z 0 {}} +test parse-6.4 {ParseTokens procedure, variable reference} { + list [catch {testparser {$x([a )} 0} msg] $msg +} {1 {missing close-bracket}} +test parse-6.5 {ParseTokens procedure, command substitution} { + testparser {[foo $x bar]z} 0 +} {- {[foo $x bar]z} 1 word {[foo $x bar]z} 2 command {[foo $x bar]} 0 text z 0 {}} +test parse-6.6 {ParseTokens procedure, command substitution} { + testparser {[foo \] [a b]]} 0 +} {- {[foo \] [a b]]} 1 word {[foo \] [a b]]} 1 command {[foo \] [a b]]} 0 {}} +test parse-6.7 {ParseTokens procedure, error in command substitution} { + list [catch {testparser {a [b {}c d] e} 0} msg] $msg $errorInfo +} {1 {extra characters after close-brace} {extra characters after close-brace + (remainder of script: "c d] e") + invoked from within +"testparser {a [b {}c d] e} 0"}} +test parse-6.8 {ParseTokens procedure, error in command substitution} { + info complete {a [b {}c d]} +} {1} +test parse-6.9 {ParseTokens procedure, error in command substitution} { + info complete {a [b "c d} +} {0} +test parse-6.10 {ParseTokens procedure, incomplete sub-command} { + info complete {puts [ + expr 1+1 + #this is a comment ]} +} {0} +test parse-6.11 {ParseTokens procedure, memory allocation for big nested command} { + testparser {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 0 +} {- {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 1 word {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 1 command {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 0 {}} +test parse-6.12 {ParseTokens procedure, missing close bracket} { + list [catch {testparser {[foo $x bar} 0} msg] $msg $errorInfo +} {1 {missing close-bracket} {missing close-bracket + (remainder of script: "[foo $x bar") + invoked from within +"testparser {[foo $x bar} 0"}} +test parse-6.13 {ParseTokens procedure, backslash-newline without continuation line} { + list [catch {testparser "\"a b\\\n" 0} msg] $msg $errorInfo +} {1 {missing "} missing\ \"\n\ \ \ \ (remainder\ of\ script:\ \"\"a\ b\\\n\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\\\"a\ b\\\\\\n\"\ 0\"} +test parse-6.14 {ParseTokens procedure, backslash-newline} { + testparser "b\\\nc" 0 +} {- b\\\nc 2 simple b 1 text b 0 simple c 1 text c 0 {}} +test parse-6.15 {ParseTokens procedure, backslash-newline} { + testparser "\"b\\\nc\"" 0 +} {- \"b\\\nc\" 1 word \"b\\\nc\" 3 text b 0 backslash \\\n 0 text c 0 {}} +test parse-6.16 {ParseTokens procedure, backslash substitution} { + testparser {\n\a\x7f} 0 +} {- {\n\a\x7f} 1 word {\n\a\x7f} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7f} 0 {}} +test parse-6.17 {ParseTokens procedure, null characters} { + testparser [bytestring "foo\0zz"] 0 +} "- [bytestring foo\0zz] 1 word [bytestring foo\0zz] 3 text foo 0 text [bytestring \0] 0 text zz 0 {}" -# Variable substitution. +test parse-7.1 {Tcl_FreeParse and ExpandTokenArray procedures} { + testparser {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 0 +} {- {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 16 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 {}} -test parse-5.1 {variable substitution} { - set a 123 - set b $a - set b -} 123 -test parse-5.2 {variable substitution} { - set a 345 - set b x$a.b - set b -} x345.b -test parse-5.3 {variable substitution} { - set _123z xx - set b $_123z^ - set b -} xx^ -test parse-5.4 {variable substitution} { - set a 78 - set b a${a}b - set b -} a78b -test parse-5.5 {variable substitution} {catch {$_non_existent_} msg} 1 -test parse-5.6 {variable substitution} { - catch {$_non_existent_} msg - set msg -} {can't read "_non_existent_": no such variable} -test parse-5.7 {array variable substitution} { - catch {unset a} - set a(xyz) 123 - set b $a(xyz)foo - set b -} 123foo -test parse-5.8 {array variable substitution} { - catch {unset a} - set "a(x y z)" 123 - set b $a(x y z)foo - set b -} 123foo -test parse-5.9 {array variable substitution} { - catch {unset a}; catch {unset qqq} - set "a(x y z)" qqq - set $a([format x]\ y [format z]) foo - set qqq -} foo -test parse-5.10 {array variable substitution} { - catch {unset a} - list [catch {set b $a(22)} msg] $msg -} {1 {can't read "a(22)": no such variable}} -test parse-5.11 {array variable substitution} { - set b a$! - set b -} {a$!} -test parse-5.12 {array variable substitution} { - set b a$() - set b -} {a$()} -catch {unset a} -test parse-5.13 {array variable substitution} { - catch {unset a} - set long {This is a very long variable, long enough to cause storage \ - allocation to occur in Tcl_ParseVar. If that storage isn't getting \ - freed up correctly, then a core leak will occur when this test is \ - run. This text is probably beginning to sound like drivel, but I've \ - run out of things to say and I need more characters still.} - set a($long) 777 - set b $a($long) - list $b [array names a] -} {777 {{This is a very long variable, long enough to cause storage \ - allocation to occur in Tcl_ParseVar. If that storage isn't getting \ - freed up correctly, then a core leak will occur when this test is \ - run. This text is probably beginning to sound like drivel, but I've \ - run out of things to say and I need more characters still.}}} -test parse-5.14 {array variable substitution} { - catch {unset a}; catch {unset b}; catch {unset a1} - set a1(22) foo - set a(foo) bar - set b $a($a1(22)) - set b -} bar -catch {unset a}; catch {unset a1} +test parse-8.1 {Tcl_EvalObjv procedure} { + testevalobjv "test command" 20 0 concat this is a test +} {this is a test} +test parse-8.2 {Tcl_EvalObjv procedure, unknown commands} { + rename unknown unknown.old + set x [catch {testevalobjv "test command" 0 10 asdf poiu} msg] + rename unknown.old unknown + list $x $msg +} {1 {invalid command name "asdf"}} +test parse-8.3 {Tcl_EvalObjv procedure, unknown commands} { + rename unknown unknown.old + proc unknown args { + return "unknown $args" + } + set x [catch {testevalobjv "test command" 10 0 asdf poiu} msg] + rename unknown {} + rename unknown.old unknown + list $x $msg +} {0 {unknown asdf poiu}} +test parse-8.4 {Tcl_EvalObjv procedure, unknown commands} { + rename unknown unknown.old + proc unknown args { + error "I don't like that command" + } + set x [catch {testevalobjv "test command" 10 0 asdf poiu} msg] + rename unknown {} + rename unknown.old unknown + list $x $msg +} {1 {I don't like that command}} +test parse-8.5 {Tcl_EvalObjv procedure, command traces} { + testcmdtrace tracetest {testevalobjv "test command" 10 0 set x 123} +} {{testevalobjv "test command" 10 0 set x 123} {testevalobjv {test command} 10 0 set x 123} {test comma} {set x 123}} +test parse-8.6 {Tcl_EvalObjv procedure, command traces} { + testcmdtrace tracetest {testevalobjv "" 0 0 set x 123} +} {{testevalobjv "" 0 0 set x 123} {testevalobjv {} 0 0 set x 123} {} {set x 123}} +test parse-8.7 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL flag} { + proc x {} { + set y 23 + set z [testevalobjv "test command" 10 1 set y] + return [list $z $y] + } + catch {unset y} + set y 16 + x +} {16 23} +test parse-8.8 {Tcl_EvalObjv procedure, async handlers} { + proc async1 {result code} { + global aresult acode + set aresult $result + set acode $code + return "new result" + } + set handler1 [testasync create async1] + set aresult xxx + set acode yyy + set x [list [catch [list testevalobjv "test command" 10 0 testasync mark $handler1 original 0] msg] $msg $acode $aresult] + testasync delete + set x +} {0 {new result} 0 original} +test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} { + list [catch {testevalobjv "test command" 10 0 error message} msg] $msg +} {1 message} -# Backslash substitution. +test parse-9.1 {Tcl_LogCommandInfo, line numbers} { + catch {unset x} + list [catch {testeval2 {for {} 1 {} { -set errNum 1 -proc bsCheck {char num} { - global errNum -; test parse-6.$errNum {backslash substitution} { - scan $char %c value - set value - } $num - set errNum [expr $errNum+1] -} -bsCheck \b 8 -bsCheck \e 101 -bsCheck \f 12 -bsCheck \n 10 -bsCheck \r 13 -bsCheck \t 9 -bsCheck \v 11 -bsCheck \{ 123 -bsCheck \} 125 -bsCheck \[ 91 -bsCheck \] 93 -bsCheck \$ 36 -bsCheck \ 32 -bsCheck \; 59 -bsCheck \\ 92 -bsCheck \Ca 67 -bsCheck \Ma 77 -bsCheck \CMa 67 -bsCheck \8a 8 -bsCheck \14 12 -bsCheck \141 97 -bsCheck \340 224 -bsCheck b\0 98 -bsCheck \x 120 -bsCheck \xa 10 -bsCheck \x41 65 -bsCheck \x541 65 + # asdf + set x + }}}] $errorInfo +} {1 {can't read "x": no such variable + while executing +"set x" + ("for" body line 5) + invoked from within +"for {} 1 {} { -test parse-6.1 {backslash substitution} { - set a "\a\c\n\]\}" - string length $a -} 5 -test parse-6.2 {backslash substitution} { - set a {\a\c\n\]\}} - string length $a -} 10 -test parse-6.3 {backslash substitution} { - set a "abc\ -def" - set a -} {abc def} -test parse-6.4 {backslash substitution} { - set a {abc\ -def} - set a -} {abc def} -test parse-6.5 {backslash substitution} { - set msg {} - set a xxx - set error [catch {if {24 < \ - 35} {set a 22} {set \ - a 33}} msg] - list $error $msg $a -} {0 22 22} -test parse-6.6 {backslash substitution} { - eval "concat abc\\" -} "abc\\" -test parse-6.7 {backslash substitution} { - eval "concat \\\na" -} "a" -test parse-6.8 {backslash substitution} { - eval "concat x\\\n a" -} "x a" -test parse-6.9 {backslash substitution} { - eval "concat \\x" -} "x" -test parse-6.10 {backslash substitution} { - eval "list a b\\\nc d" -} {a b c d} -test parse-6.11 {backslash substitution} { - eval "list a \"b c\"\\\nd e" -} {a {b c} d e} -# Semi-colon. + # asdf + set x + }" + invoked from within +"testeval2 {for {} 1 {} { -test parse-7.1 {semi-colons} { - set b 0 - getArgs a;set b 2 - set argv -} a -test parse-7.2 {semi-colons} { - set b 0 - getArgs a;set b 2 - set b -} 2 -test parse-7.3 {semi-colons} { - getArgs a b ; set b 1 - set argv -} {a b} -test parse-7.4 {semi-colons} { - getArgs a b ; set b 1 - set b -} 1 -# The following checks are to ensure that the interpreter's result -# gets re-initialized by Tcl_Eval in all the right places. + # asdf + set x + }}"}} +test parse-9.2 {Tcl_LogCommandInfo, truncating long commands} { + list [testeval2 {catch {set a b 111111111 222222222 333333333 444444444 555555555 666666666 777777777 888888888 999999999 000000000 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee fffffffff ggggggggg}}] $errorInfo +} {1 {wrong # args: should be "set varName ?newValue?" + while executing +"set a b 111111111 222222222 333333333 444444444 555555555 666666666 777777777 888888888 999999999 000000000 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd ee..."}} -test parse-8.1 {result initialization} {concat abc} abc -test parse-8.2 {result initialization} {concat abc; proc foo {} {}} {} -test parse-8.3 {result initialization} {concat abc; proc foo {} $a} {} -test parse-8.4 {result initialization} {proc foo {} [concat abc]} {} -test parse-8.5 {result initialization} {concat abc; } abc -test parse-8.6 {result initialization} { - eval { - concat abc -}} abc -test parse-8.7 {result initialization} {} {} -test parse-8.8 {result initialization} {concat abc; ; ;} abc +test parse-10.1 {Tcl_EvalTokens, simple text} { + testeval2 {concat test} +} {test} +test parse-10.2 {Tcl_EvalTokens, backslash sequences} { + testeval2 {concat test\063\062test} +} {test32test} +test parse-10.3 {Tcl_EvalTokens, nested commands} { + testeval2 {concat [expr 2 + 6]} +} {8} +test parse-10.4 {Tcl_EvalTokens, nested commands} { + catch {unset a} + list [catch {testeval2 {concat xxx[expr $a]}} msg] $msg +} {1 {can't read "a": no such variable}} +test parse-10.5 {Tcl_EvalTokens, simple variables} { + set a hello + testeval2 {concat $a} +} {hello} +test parse-10.6 {Tcl_EvalTokens, array variables} { + catch {unset a} + set a(12) 46 + testeval2 {concat $a(12)} +} {46} +test parse-10.7 {Tcl_EvalTokens, array variables} { + catch {unset a} + set a(12) 46 + testeval2 {concat $a(1[expr 3 - 1])} +} {46} +test parse-10.8 {Tcl_EvalTokens, array variables} { + catch {unset a} + list [catch {testeval2 {concat $x($a)}} msg] $msg +} {1 {can't read "a": no such variable}} +test parse-10.9 {Tcl_EvalTokens, array variables} { + catch {unset a} + list [catch {testeval2 {concat xyz$a(1)}} msg] $msg +} {1 {can't read "a(1)": no such variable}} +test parse-10.10 {Tcl_EvalTokens, object values} { + set a 123 + testeval2 {concat $a} +} {123} +test parse-10.11 {Tcl_EvalTokens, object values} { + set a 123 + testeval2 {concat $a$a$a} +} {123123123} +test parse-10.12 {Tcl_EvalTokens, object values} { + testeval2 {concat [expr 2][expr 4][expr 6]} +} {246} +test parse-10.13 {Tcl_EvalTokens, string values} { + testeval2 {concat {a" b"}} +} {a" b"} +test parse-10.14 {Tcl_EvalTokens, string values} { + set a 111 + testeval2 {concat x$a.$a.$a} +} {x111.111.111} -# Syntax errors. +test parse-11.1 {Tcl_Eval2, TCL_EVAL_GLOBAL flag} { + proc x {} { + set y 777 + set z [testeval2 "set y" global] + return [list $z $y] + } + catch {unset y} + set y 321 + x +} {321 777} +test parse-11.2 {Tcl_Eval2, error while parsing} { + list [catch {testeval2 {concat "abc}} msg] $msg +} {1 {missing "}} +test parse-11.3 {Tcl_Eval2, error while collecting words} { + catch {unset a} + list [catch {testeval2 {concat xyz $a}} msg] $msg +} {1 {can't read "a": no such variable}} +test parse-11.4 {Tcl_Eval2, error in Tcl_EvalObjv call} { + catch {unset a} + list [catch {testeval2 {_bogus_ a b c d}} msg] $msg +} {1 {invalid command name "_bogus_"}} +test parse-11.5 {Tcl_Eval2, exceptional return} { + list [catch {testeval2 {break}} msg] $msg +} {3 {}} +test parse-11.6 {Tcl_Eval2, freeing memory} { + testeval2 {concat 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 parse-11.7 {Tcl_Eval2, multiple commands in script} { + list [testeval2 {set a b; set c d}] $a $c +} {d b d} +test parse-11.8 {Tcl_Eval2, multiple commands in script} { + list [testeval2 { + set a b + set c d + }] $a $c +} {d b d} +test parse-11.9 {Tcl_Eval2, freeing memory after error} { + catch {unset a} + list [catch {testeval2 {concat 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}} msg] $msg +} {1 {can't read "a": no such variable}} +test parse-11.10 {Tcl_EvalTokens, empty commands} { + testeval2 {concat xyz; } +} {xyz} +test parse-11.11 {Tcl_EvalTokens, empty commands} { + testeval2 "concat abc; ; # this is a comment\n" +} {abc} +test parse-11.12 {Tcl_EvalTokens, empty commands} { + testeval2 {} +} {} -test parse-9.1 {syntax errors} {catch "set a \{bcd" msg} 1 -test parse-9.2 {syntax errors} { - catch "set a \{bcd" msg - set msg -} {missing close-brace} -test parse-9.3 {syntax errors} {catch {set a "bcd} msg} 1 -test parse-9.4 {syntax errors} { - catch {set a "bcd} msg - set msg -} {quoted string doesn't terminate properly} -test parse-9.5 {syntax errors} {catch {set a "bcd"xy} msg} 1 -test parse-9.6 {syntax errors} { - catch {set a "bcd"xy} msg - set msg -} {quoted string doesn't terminate properly} -test parse-9.7 {syntax errors} {catch "set a {bcd}xy" msg} 1 -test parse-9.8 {syntax errors} { - catch "set a {bcd}xy" msg - set msg -} {argument word in braces doesn't terminate properly} -test parse-9.9 {syntax errors} {catch {set a [format abc} msg} 1 -test parse-9.10 {syntax errors} { - catch {set a [format abc} msg - set msg -} {missing close-bracket or close-brace} -test parse-9.11 {syntax errors} {catch gorp-a-lot msg} 1 -test parse-9.12 {syntax errors} { - catch gorp-a-lot msg - set msg -} {invalid command name "gorp-a-lot"} -test parse-9.13 {syntax errors} { - set a [concat {a}\ - {b}] - set a -} {a b} -test parse-9.14 {syntax errors} { - list [catch {eval \$x[format "%01000d" 0](} msg] $msg $errorInfo +test parse-12.1 {Tcl_ParseVarName procedure, initialization} { + list [catch {testparsevarname {$a([first second])} 8 0} msg] $msg +} {1 {missing close-bracket}} +test parse-12.2 {Tcl_ParseVarName procedure, initialization} { + testparsevarname {$a([first second])} 0 0 +} {- {} 0 variable {$a([first second])} 2 text a 0 command {[first second]} 0 {}} +test parse-12.3 {Tcl_ParseVarName procedure, initialization} { + list [catch {testparsevarname {$abcd} 3 0} msg] $msg +} {0 {- {} 0 variable {$ab} 1 text ab 0 cd}} +test parse-12.4 {Tcl_ParseVarName procedure, initialization} { + testparsevarname {$abcd} 0 0 +} {- {} 0 variable {$abcd} 1 text abcd 0 {}} +test parse-12.5 {Tcl_ParseVarName procedure, just a dollar sign} { + testparsevarname {$abcd} 1 0 +} {- {} 0 text {$} 0 abcd} +test parse-12.6 {Tcl_ParseVarName procedure, braced variable name} { + testparser {${..[]b}cd} 0 +} {- {${..[]b}cd} 1 word {${..[]b}cd} 3 variable {${..[]b}} 1 text {..[]b} 0 text cd 0 {}} +test parse-12.7 {Tcl_ParseVarName procedure, braced variable name} { + testparser "\$\{\{\} " 0 +} {- \$\{\{\}\ 1 word \$\{\{\} 2 variable \$\{\{\} 1 text \{ 0 {}} +test parse-12.8 {Tcl_ParseVarName procedure, missing close brace} { + list [catch {testparser "$\{abc" 0} msg] $msg $errorInfo +} {1 {missing close-brace for variable name} missing\ close-brace\ for\ variable\ name\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\$\\\{abc\"\ 0\"} +test parse-12.9 {Tcl_ParseVarName procedure, missing close brace} { + list [catch {testparsevarname {${bcd}} 4 0} msg] $msg +} {1 {missing close-brace for variable name}} +test parse-12.10 {Tcl_ParseVarName procedure, missing close brace} { + list [catch {testparsevarname {${bc}} 4 0} msg] $msg +} {1 {missing close-brace for variable name}} +test parse-12.11 {Tcl_ParseVarName procedure, simple variable name} { + testparser {$az_AZ.} 0 +} {- {$az_AZ.} 1 word {$az_AZ.} 3 variable {$az_AZ} 1 text az_AZ 0 text . 0 {}} +test parse-12.12 {Tcl_ParseVarName procedure, simple variable name} { + testparser {$abcdefg} 4 +} {- {$abc} 1 word {$abc} 2 variable {$abc} 1 text abc 0 defg} +test parse-12.13 {Tcl_ParseVarName procedure, simple variable name with ::} { + testparser {$xyz::ab:c} 0 +} {- {$xyz::ab:c} 1 word {$xyz::ab:c} 3 variable {$xyz::ab} 1 text xyz::ab 0 text :c 0 {}} +test parse-12.14 {Tcl_ParseVarName procedure, variable names with many colons} { + testparser {$xyz:::::c} 0 +} {- {$xyz:::::c} 1 word {$xyz:::::c} 2 variable {$xyz:::::c} 1 text xyz:::::c 0 {}} +test parse-12.15 {Tcl_ParseVarName procedure, : vs. ::} { + testparsevarname {$ab:cd} 0 0 +} {- {} 0 variable {$ab} 1 text ab 0 :cd} +test parse-12.16 {Tcl_ParseVarName procedure, eof in ::} { + testparsevarname {$ab::cd} 4 0 +} {- {} 0 variable {$ab} 1 text ab 0 ::cd} +test parse-12.17 {Tcl_ParseVarName procedure, eof in ::} { + testparsevarname {$ab:::cd} 5 0 +} {- {} 0 variable {$ab::} 1 text ab:: 0 :cd} +test parse-12.18 {Tcl_ParseVarName procedure, no variable name} { + testparser {$$ $.} 0 +} {- {$$ $.} 2 word {$$} 2 text {$} 0 text {$} 0 word {$.} 2 text {$} 0 text . 0 {}} +test parse-12.19 {Tcl_ParseVarName procedure, EOF before (} { + testparsevarname {$ab(cd)} 3 0 +} {- {} 0 variable {$ab} 1 text ab 0 (cd)} +test parse-12.20 {Tcl_ParseVarName procedure, array reference} { + testparser {$x(abc)} 0 +} {- {$x(abc)} 1 word {$x(abc)} 3 variable {$x(abc)} 2 text x 0 text abc 0 {}} +test parse-12.21 {Tcl_ParseVarName procedure, array reference} { + testparser {$x(ab$cde[foo bar])} 0 +} {- {$x(ab$cde[foo bar])} 1 word {$x(ab$cde[foo bar])} 6 variable {$x(ab$cde[foo bar])} 5 text x 0 text ab 0 variable {$cde} 1 text cde 0 command {[foo bar]} 0 {}} +test parse-12.22 {Tcl_ParseVarName procedure, array reference} { + testparser {$x([cmd arg]zz)} 0 +} {- {$x([cmd arg]zz)} 1 word {$x([cmd arg]zz)} 4 variable {$x([cmd arg]zz)} 3 text x 0 command {[cmd arg]} 0 text zz 0 {}} +test parse-12.23 {Tcl_ParseVarName procedure, missing close paren in array reference} { + list [catch {testparser {$x(poiu} 0} msg] $msg $errorInfo } {1 {missing )} {missing ) - (parsing index for array "x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000") - while compiling -"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 ..." - ("eval" body line 1) + (remainder of script: "(poiu") invoked from within -"eval \$x[format "%01000d" 0]("}} -test parse-9.15 {syntax errors, missplaced braces} { - catch { - proc misplaced_end_brace {} { - set what foo - set when [expr ${what}size - [set off$what]}] - } msg - set msg -} {wrong # args: should be "proc name args body"} -test parse-9.16 {syntax errors, missplaced braces} { - catch { - set a { - set what foo - set when [expr ${what}size - [set off$what]}] - } msg - set msg -} {argument word in braces doesn't terminate properly} - -# Long values (stressing storage management) +"testparser {$x(poiu} 0"}} +test parse-12.24 {Tcl_ParseVarName procedure, missing close paren in array reference} { + list [catch {testparsevarname {$ab(cd)} 6 0} msg] $msg $errorInfo +} {1 {missing )} {missing ) + (remainder of script: "(cd)") + invoked from within +"testparsevarname {$ab(cd)} 6 0"}} +test parse-12.25 {Tcl_ParseVarName procedure, nested array reference} { + testparser {$x(a$y(b$z))} 0 +} {- {$x(a$y(b$z))} 1 word {$x(a$y(b$z))} 8 variable {$x(a$y(b$z))} 7 text x 0 text a 0 variable {$y(b$z)} 4 text y 0 text b 0 variable {$z} 1 text z 0 {}} -set 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 HHHH} +test parse-13.1 {Tcl_ParseVar procedure} { + set abc 24 + testparsevar {$abc.fg} +} {24 .fg} +test parse-13.2 {Tcl_ParseVar procedure, no variable name} { + testparsevar {$} +} {{$} {}} +test parse-13.3 {Tcl_ParseVar procedure, no variable name} { + testparsevar {$.123} +} {{$} .123} +test parse-13.4 {Tcl_ParseVar procedure, error looking up variable} { + catch {unset abc} + list [catch {testparsevar {$abc}} msg] $msg +} {1 {can't read "abc": no such variable}} +test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} { + catch {unset abc} + list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg +} {1 {invalid command name "bogus"}} -test parse-10.1 {long values} { - string length $a -} 214 -test parse-10.2 {long values} { - llength $a -} 43 -test parse-10.3 {long values} { - set b "1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH" - set b -} $a -test parse-10.4 {long values} { - set b "$a" - set b -} $a -test parse-10.5 {long values} { - set b [set a] - set b -} $a -test parse-10.6 {long values} { - set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] - string length $b -} 214 -test parse-10.7 {long values} { - set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] - llength $b -} 43 -test parse-10.8 {long values} { - set b -} $a -test parse-10.9 {long values} { - set a [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] - llength $a -} 62 -set i 0 -foreach j [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] { - set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i] - set test $test$test$test$test - set i [expr $i+1] - test parse-10.10 {long values} { - set j - } $test -} -test parse-10.11 {test buffer overflow in backslashes in braces} { - expr {"a" == {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101}} -} 0 +test parse-14.1 {Tcl_ParseBraces procedure, computing string length} { + testparser [bytestring "foo\0 bar"] -1 +} {- foo 1 simple foo 1 text foo 0 {}} +test parse-14.2 {Tcl_ParseBraces procedure, computing string length} { + testparser "foo bar" -1 +} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}} +test parse-14.3 {Tcl_ParseBraces procedure, words in braces} { + testparser {foo {a $b [concat foo]} {c d}} 0 +} {- {foo {a $b [concat foo]} {c d}} 3 simple foo 1 text foo 0 simple {{a $b [concat foo]}} 1 text {a $b [concat foo]} 0 simple {{c d}} 1 text {c d} 0 {}} +test parse-14.4 {Tcl_ParseBraces procedure, empty nested braces} { + testparser {foo {{}}} 0 +} {- {foo {{}}} 2 simple foo 1 text foo 0 simple {{{}}} 1 text {{}} 0 {}} +test parse-14.5 {Tcl_ParseBraces procedure, nested braces} { + testparser {foo {{a {b} c} {} {d e}}} 0 +} {- {foo {{a {b} c} {} {d e}}} 2 simple foo 1 text foo 0 simple {{{a {b} c} {} {d e}}} 1 text {{a {b} c} {} {d e}} 0 {}} +test parse-14.6 {Tcl_ParseBraces procedure, backslashes in words in braces} { + testparser "foo {a \\n\\\{}" 0 +} {- {foo {a \n\{}} 2 simple foo 1 text foo 0 simple {{a \n\{}} 1 text {a \n\{} 0 {}} +test parse-14.7 {Tcl_ParseBraces procedure, missing continuation line in braces} { + list [catch {testparser "\{abc\\\n" 0} msg] $msg $errorInfo +} {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\\\n\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\\\{abc\\\\\\n\"\ 0\"} +test parse-14.8 {Tcl_ParseBraces procedure, backslash-newline in braces} { + testparser "foo {\\\nx}" 0 +} {- foo\ \{\\\nx\} 2 simple foo 1 text foo 0 word \{\\\nx\} 2 backslash \\\n 0 text x 0 {}} +test parse-14.9 {Tcl_ParseBraces procedure, backslash-newline in braces} { + testparser "foo {a \\\n b}" 0 +} {- foo\ \{a\ \\\n\ \ \ b\} 2 simple foo 1 text foo 0 word \{a\ \\\n\ \ \ b\} 3 text {a } 0 backslash \\\n\ \ \ 0 text b 0 {}} +test parse-14.10 {Tcl_ParseBraces procedure, backslash-newline in braces} { + testparser "foo {xyz\\\n }" 0 +} {- foo\ \{xyz\\\n\ \} 2 simple foo 1 text foo 0 word \{xyz\\\n\ \} 2 text xyz 0 backslash \\\n\ 0 {}} +test parse-14.11 {Tcl_ParseBraces procedure, empty braced string} { + testparser {foo {}} 0 +} {- {foo {}} 2 simple foo 1 text foo 0 simple {{}} 1 text {} 0 {}} +test parse-14.12 {Tcl_ParseBraces procedure, missing close brace} { + list [catch {testparser "foo \{xy\\\nz" 0} msg] $msg $errorInfo +} {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{xy\\\nz\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\{xy\\\\\\nz\"\ 0\"} -test parse-11.1 {comments} { - set a old - eval { # set a new} - set a -} {old} -test parse-11.2 {comments} { - set a old - eval " # set a new\nset a new" - set a -} {new} -test parse-11.3 {comments} { - set a old - eval " # set a new\\\nset a new" - set a -} {old} -test parse-11.4 {comments} { - set a old - eval " # set a new\\\\\nset a new" - set a -} {new} +test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} { + testparser [bytestring "foo\0 bar"] -1 +} {- foo 1 simple foo 1 text foo 0 {}} +test parse-15.2 {Tcl_ParseQuotedString procedure, computing string length} { + testparser "foo bar" -1 +} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}} +test parse-15.3 {Tcl_ParseQuotedString procedure, word is quoted string} { + testparser {foo "a b c" d "efg";} 0 +} {- {foo "a b c" d "efg";} 4 simple foo 1 text foo 0 simple {"a b c"} 1 text {a b c} 0 simple d 1 text d 0 simple {"efg"} 1 text efg 0 {}} +test parse-15.4 {Tcl_ParseQuotedString procedure, garbage after quoted string} { + list [catch {testparser {foo "a b c"d} 0} msg] $msg $errorInfo +} {1 {extra characters after close-quote} {extra characters after close-quote + (remainder of script: "d") + invoked from within +"testparser {foo "a b c"d} 0"}} -test parse-12.1 {comments at the end of a bracketed script} { - set x "[ -expr 1+1 -# skip this! -]" -} {2} +test parse-15.1 {CommandComplete procedure} { + info complete "" +} 1 +test parse-15.2 {CommandComplete procedure} { + info complete " \n" +} 1 +test parse-15.3 {CommandComplete procedure} { + info complete "abc def" +} 1 +test parse-15.4 {CommandComplete procedure} { + info complete "a b c d e f \t\n" +} 1 +test parse-15.5 {CommandComplete procedure} { + info complete {a b c"d} +} 1 +test parse-15.6 {CommandComplete procedure} { + info complete {a b "c d" e} +} 1 +test parse-15.7 {CommandComplete procedure} { + info complete {a b "c d"} +} 1 +test parse-15.8 {CommandComplete procedure} { + info complete {a b "c d"} +} 1 +test parse-15.9 {CommandComplete procedure} { + info complete {a b "c d} +} 0 +test parse-15.10 {CommandComplete procedure} { + info complete {a b "} +} 0 +test parse-15.11 {CommandComplete procedure} { + info complete {a b "cd"xyz} +} 1 +test parse-15.12 {CommandComplete procedure} { + info complete {a b "c $d() d"} +} 1 +test parse-15.13 {CommandComplete procedure} { + info complete {a b "c $dd("} +} 0 +test parse-15.14 {CommandComplete procedure} { + info complete {a b "c \"} +} 0 +test parse-15.15 {CommandComplete procedure} { + info complete {a b "c [d e f]"} +} 1 +test parse-15.16 {CommandComplete procedure} { + info complete {a b "c [d e f] g"} +} 1 +test parse-15.17 {CommandComplete procedure} { + info complete {a b "c [d e f"} +} 0 +test parse-15.18 {CommandComplete procedure} { + info complete {a {b c d} e} +} 1 +test parse-15.19 {CommandComplete procedure} { + info complete {a {b c d}} +} 1 +test parse-15.20 {CommandComplete procedure} { + info complete "a b\{c d" +} 1 +test parse-15.21 {CommandComplete procedure} { + info complete "a b \{c" +} 0 +test parse-15.22 {CommandComplete procedure} { + info complete "a b \{c{ }" +} 0 +test parse-15.23 {CommandComplete procedure} { + info complete "a b {c d e}xxx" +} 1 +test parse-15.24 {CommandComplete procedure} { + info complete "a b {c \\\{d e}xxx" +} 1 +test parse-15.25 {CommandComplete procedure} { + info complete {a b [ab cd ef]} +} 1 +test parse-15.26 {CommandComplete procedure} { + info complete {a b x[ab][cd][ef] gh} +} 1 +test parse-15.27 {CommandComplete procedure} { + info complete {a b x[ab][cd[ef] gh} +} 0 +test parse-15.28 {CommandComplete procedure} { + info complete {a b x[ gh} +} 0 +test parse-15.29 {CommandComplete procedure} { + info complete {[]]]} +} 1 +test parse-15.30 {CommandComplete procedure} { + info complete {abc x$yyy} +} 1 +test parse-15.31 {CommandComplete procedure} { + info complete "abc x\${abc\[\\d} xyz" +} 1 +test parse-15.32 {CommandComplete procedure} { + info complete "abc x\$\{ xyz" +} 0 +test parse-15.33 {CommandComplete procedure} { + info complete {word $a(xyz)} +} 1 +test parse-15.34 {CommandComplete procedure} { + info complete {word $a(} +} 0 +test parse-15.35 {CommandComplete procedure} { + info complete "set a \\\n" +} 0 +test parse-15.36 {CommandComplete procedure} { + info complete "set a \\\\\n" +} 1 +test parse-15.37 {CommandComplete procedure} { + info complete "set a \\n " +} 1 +test parse-15.38 {CommandComplete procedure} { + info complete "set a \\" +} 1 +test parse-15.39 {CommandComplete procedure} { + info complete "foo \\\n\{" +} 0 +test parse-15.40 {CommandComplete procedure} { + info complete "a\nb\n# \{\n# \{\nc\n" +} 1 +test parse-15.41 {CommandComplete procedure} { + info complete "#Incomplete comment\\\n" +} 0 +test parse-15.42 {CommandComplete procedure} { + info complete "#Incomplete comment\\\nBut now it's complete.\n" +} 1 +test parse-15.43 {CommandComplete procedure} { + info complete "# Complete comment\\\\\n" +} 1 +test parse-15.44 {CommandComplete procedure} { + info complete "abc\\\n def" +} 1 +test parse-15.45 {CommandComplete procedure} { + info complete "abc\\\n " +} 1 +test parse-15.46 {CommandComplete procedure} { + info complete "abc\\\n" +} 0 +test parse-15.47 {CommandComplete procedure} { + info complete "\{abc\}\{" +} 1 +test parse-15.48 {CommandComplete procedure} { + info complete "\"abc\"(" +} 1 -if {[info command testwordend] == "testwordend"} { - test parse-13.1 {TclWordEnd procedure} { - testwordend " \n abc" - } {c} - test parse-13.2 {TclWordEnd procedure} { - testwordend " \\\n" - } {} - test parse-13.3 {TclWordEnd procedure} { - testwordend " \\\n " - } { } - test parse-13.4 {TclWordEnd procedure} { - testwordend {"abc"} - } {"} - test parse-13.5 {TclWordEnd procedure} { - testwordend {{xyz}} - } \} - test parse-13.6 {TclWordEnd procedure} { - testwordend {{a{}b{}\}} xyz} - } "\} xyz" - test parse-13.7 {TclWordEnd procedure} { - testwordend {abc[this is a]def ghi} - } {f ghi} - test parse-13.8 {TclWordEnd procedure} { - testwordend "puts\\\n\n " - } "s\\\n\n " - test parse-13.9 {TclWordEnd procedure} { - testwordend "puts\\\n " - } "s\\\n " - test parse-13.10 {TclWordEnd procedure} { - testwordend "puts\\\n xyz" - } "s\\\n xyz" - test parse-13.11 {TclWordEnd procedure} { - testwordend {a$x.$y(a long index) foo} - } ") foo" - test parse-13.12 {TclWordEnd procedure} { - testwordend {abc; def} - } {; def} - test parse-13.13 {TclWordEnd procedure} { - testwordend {abc def} - } {c def} - test parse-13.14 {TclWordEnd procedure} { - testwordend {abc def} - } {c def} - test parse-13.15 {TclWordEnd procedure} { - testwordend "abc\ndef" - } "c\ndef" - test parse-13.16 {TclWordEnd procedure} { - testwordend "abc" - } {c} - test parse-13.17 {TclWordEnd procedure} { - testwordend "a\000bc" - } {c} - test parse-13.18 {TclWordEnd procedure} { - testwordend \[a\000\] - } {]} - test parse-13.19 {TclWordEnd procedure} { - testwordend \"a\000\" - } {"} - test parse-13.20 {TclWordEnd procedure} { - testwordend a{\000}b - } {b} - test parse-13.21 {TclWordEnd procedure} { - testwordend " \000b" - } {b} -} -test parse-14.1 {TclScriptEnd procedure} { - info complete {puts [ - expr 1+1 - #this is a comment ]} -} {0} -test parse-14.2 {TclScriptEnd procedure} { - info complete "abc\\\n" -} {0} -test parse-14.3 {TclScriptEnd procedure} { - info complete "abc\\\\\n" -} {1} -test parse-14.4 {TclScriptEnd procedure} { - info complete "xyz \[abc \{abc\]" -} {0} -test parse-14.5 {TclScriptEnd procedure} { - info complete "xyz \[abc" -} {0} +catch {unset a} +return diff --git a/tests/parseExpr.test b/tests/parseExpr.test new file mode 100644 index 0000000..7f02d12 --- /dev/null +++ b/tests/parseExpr.test @@ -0,0 +1,619 @@ +# This file contains a collection of tests for the procedures in the +# file tclParseExpr.c. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) parseExpr.test 1.8 98/01/09 09:48:03 + +# Note that the Tcl expression parser (tclParseExpr.c) does not check +# the semantic validity of the expressions it parses. It does not check, +# for example, that a math function actually exists, or that the operands +# of "<<" are integers. + +if {[info commands testexprparser] == {}} { + puts "This application hasn't been compiled with the \"testexprparser\"" + puts "command, so I can't test the Tcl expression parser." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} { + testexprparser [bytestring "1+2\0 +3"] -1 +} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} { + testexprparser "1 + 2" -1 +} {- {} 0 subexpr {1 + 2} 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} {nonPortable} { + list [catch {testexprparser {12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-1.4 {Tcl_ParseExpr procedure, error in conditional expression} { + list [catch {testexprparser {foo+} -1} msg] $msg +} {1 {syntax error in expression "foo+"}} +test parseExpr-1.5 {Tcl_ParseExpr procedure, lexemes after the expression} { + list [catch {testexprparser {1+2 345} -1} msg] $msg +} {1 {syntax error in expression "1+2 345"}} + +test parseExpr-2.1 {ParseCondExpr procedure, valid test subexpr} { + testexprparser {2>3? 1 : 0} -1 +} {- {} 0 subexpr {2>3? 1 : 0} 11 operator ? 0 subexpr 2>3 5 operator > 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-2.2 {ParseCondExpr procedure, error in test subexpr} { + list [catch {testexprparser {0 || foo} -1} msg] $msg +} {1 {syntax error in expression "0 || foo"}} +test parseExpr-2.3 {ParseCondExpr procedure, next lexeme isn't "?"} { + testexprparser {1+2} -1 +} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-2.4 {ParseCondExpr procedure, next lexeme is "?"} { + testexprparser {1+2 ? 3 : 4} -1 +} {- {} 0 subexpr {1+2 ? 3 : 4} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-2.5 {ParseCondExpr procedure, bad lexeme after "?"} {nonPortable} { + list [catch {testexprparser {1+2 ? 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-2.6 {ParseCondExpr procedure, valid "then" subexpression} { + testexprparser {1? 3 : 4} -1 +} {- {} 0 subexpr {1? 3 : 4} 7 operator ? 0 subexpr 1 1 text 1 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-2.7 {ParseCondExpr procedure, error in "then" subexpression} { + list [catch {testexprparser {1? fred : martha} -1} msg] $msg +} {1 {syntax error in expression "1? fred : martha"}} +test parseExpr-2.8 {ParseCondExpr procedure, lexeme after "then" subexpr isn't ":"} { + list [catch {testexprparser {1? 2 martha 3} -1} msg] $msg +} {1 {syntax error in expression "1? 2 martha 3"}} +test parseExpr-2.9 {ParseCondExpr procedure, valid "else" subexpression} { + testexprparser {27||3? 3 : 4&&9} -1 +} {- {} 0 subexpr {27||3? 3 : 4&&9} 15 operator ? 0 subexpr 27||3 5 operator || 0 subexpr 27 1 text 27 0 subexpr 3 1 text 3 0 subexpr 3 1 text 3 0 subexpr 4&&9 5 operator && 0 subexpr 4 1 text 4 0 subexpr 9 1 text 9 0 {}} +test parseExpr-2.10 {ParseCondExpr procedure, error in "else" subexpression} { + list [catch {testexprparser {1? 2 : martha} -1} msg] $msg +} {1 {syntax error in expression "1? 2 : martha"}} + +test parseExpr-3.1 {ParseLorExpr procedure, valid logical and subexpr} { + testexprparser {1&&2 || 3} -1 +} {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-3.2 {ParseLorExpr procedure, error in logical and subexpr} { + list [catch {testexprparser {1&&foo || 3} -1} msg] $msg +} {1 {syntax error in expression "1&&foo || 3"}} +test parseExpr-3.3 {ParseLorExpr procedure, next lexeme isn't "||"} { + testexprparser {1&&2? 1 : 0} -1 +} {- {} 0 subexpr {1&&2? 1 : 0} 11 operator ? 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-3.4 {ParseLorExpr procedure, next lexeme is "||"} { + testexprparser {1&&2 || 3} -1 +} {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-3.5 {ParseLorExpr procedure, bad lexeme after "||"} {nonPortable} { + list [catch {testexprparser {1&&2 || 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-3.6 {ParseLorExpr procedure, valid RHS subexpression} { + testexprparser {1&&2 || 3 || 4} -1 +} {- {} 0 subexpr {1&&2 || 3 || 4} 13 operator || 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-3.7 {ParseLorExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1&&2 || 3 || martha} -1} msg] $msg +} {1 {syntax error in expression "1&&2 || 3 || martha"}} + +test parseExpr-4.1 {ParseLandExpr procedure, valid LHS "|" subexpr} { + testexprparser {1|2 && 3} -1 +} {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-4.2 {ParseLandExpr procedure, error in LHS "|" subexpr} { + list [catch {testexprparser {1&&foo && 3} -1} msg] $msg +} {1 {syntax error in expression "1&&foo && 3"}} +test parseExpr-4.3 {ParseLandExpr procedure, next lexeme isn't "&&"} { + testexprparser {1|2? 1 : 0} -1 +} {- {} 0 subexpr {1|2? 1 : 0} 11 operator ? 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-4.4 {ParseLandExpr procedure, next lexeme is "&&"} { + testexprparser {1|2 && 3} -1 +} {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-4.5 {ParseLandExpr procedure, bad lexeme after "&&"} {nonPortable} { + list [catch {testexprparser {1|2 && 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-4.6 {ParseLandExpr procedure, valid RHS subexpression} { + testexprparser {1|2 && 3 && 4} -1 +} {- {} 0 subexpr {1|2 && 3 && 4} 13 operator && 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-4.7 {ParseLandExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1|2 && 3 && martha} -1} msg] $msg +} {1 {syntax error in expression "1|2 && 3 && martha"}} + +test parseExpr-5.1 {ParseBitOrExpr procedure, valid LHS "^" subexpr} { + testexprparser {1^2 | 3} -1 +} {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-5.2 {ParseBitOrExpr procedure, error in LHS "^" subexpr} { + list [catch {testexprparser {1|foo | 3} -1} msg] $msg +} {1 {syntax error in expression "1|foo | 3"}} +test parseExpr-5.3 {ParseBitOrExpr procedure, next lexeme isn't "|"} { + testexprparser {1^2? 1 : 0} -1 +} {- {} 0 subexpr {1^2? 1 : 0} 11 operator ? 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-5.4 {ParseBitOrExpr procedure, next lexeme is "|"} { + testexprparser {1^2 | 3} -1 +} {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-5.5 {ParseBitOrExpr procedure, bad lexeme after "|"} {nonPortable} { + list [catch {testexprparser {1^2 | 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-5.6 {ParseBitOrExpr procedure, valid RHS subexpression} { + testexprparser {1^2 | 3 | 4} -1 +} {- {} 0 subexpr {1^2 | 3 | 4} 13 operator | 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-5.7 {ParseBitOrExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1^2 | 3 | martha} -1} msg] $msg +} {1 {syntax error in expression "1^2 | 3 | martha"}} + +test parseExpr-6.1 {ParseBitXorExpr procedure, valid LHS "&" subexpr} { + testexprparser {1&2 ^ 3} -1 +} {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-6.2 {ParseBitXorExpr procedure, error in LHS "&" subexpr} { + list [catch {testexprparser {1^foo ^ 3} -1} msg] $msg +} {1 {syntax error in expression "1^foo ^ 3"}} +test parseExpr-6.3 {ParseBitXorExpr procedure, next lexeme isn't "^"} { + testexprparser {1&2? 1 : 0} -1 +} {- {} 0 subexpr {1&2? 1 : 0} 11 operator ? 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-6.4 {ParseBitXorExpr procedure, next lexeme is "^"} { + testexprparser {1&2 ^ 3} -1 +} {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-6.5 {ParseBitXorExpr procedure, bad lexeme after "^"} {nonPortable} { + list [catch {testexprparser {1&2 ^ 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-6.6 {ParseBitXorExpr procedure, valid RHS subexpression} { + testexprparser {1&2 ^ 3 ^ 4} -1 +} {- {} 0 subexpr {1&2 ^ 3 ^ 4} 13 operator ^ 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-6.7 {ParseBitXorExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1&2 ^ 3 ^ martha} -1} msg] $msg +} {1 {syntax error in expression "1&2 ^ 3 ^ martha"}} + +test parseExpr-7.1 {ParseBitAndExpr procedure, valid LHS equality subexpr} { + testexprparser {1==2 & 3} -1 +} {- {} 0 subexpr {1==2 & 3} 9 operator & 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-7.2 {ParseBitAndExpr procedure, error in LHS equality subexpr} { + list [catch {testexprparser {1!=foo & 3} -1} msg] $msg +} {1 {syntax error in expression "1!=foo & 3"}} +test parseExpr-7.3 {ParseBitAndExpr procedure, next lexeme isn't "&"} { + testexprparser {1==2? 1 : 0} -1 +} {- {} 0 subexpr {1==2? 1 : 0} 11 operator ? 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-7.4 {ParseBitAndExpr procedure, next lexeme is "&"} { + testexprparser {1>2 & 3} -1 +} {- {} 0 subexpr {1>2 & 3} 9 operator & 0 subexpr 1>2 5 operator > 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-7.5 {ParseBitAndExpr procedure, bad lexeme after "&"} {nonPortable} { + list [catch {testexprparser {1==2 & 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-7.6 {ParseBitAndExpr procedure, valid RHS subexpression} { + testexprparser {1<2 & 3 & 4} -1 +} {- {} 0 subexpr {1<2 & 3 & 4} 13 operator & 0 subexpr {1<2 & 3} 9 operator & 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-7.7 {ParseBitAndExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1==2 & 3>2 & martha} -1} msg] $msg +} {1 {syntax error in expression "1==2 & 3>2 & martha"}} + +test parseExpr-7.1 {ParseEqualityExpr procedure, valid LHS relational subexpr} { + testexprparser {1<2 == 3} -1 +} {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-7.2 {ParseEqualityExpr procedure, error in LHS relational subexpr} { + list [catch {testexprparser {1>=foo == 3} -1} msg] $msg +} {1 {syntax error in expression "1>=foo == 3"}} +test parseExpr-7.3 {ParseEqualityExpr procedure, next lexeme isn't "==" or "!="} { + testexprparser {1<2? 1 : 0} -1 +} {- {} 0 subexpr {1<2? 1 : 0} 11 operator ? 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-7.4 {ParseEqualityExpr procedure, next lexeme is "==" or "!=} { + testexprparser {1<2 == 3} -1 +} {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-7.5 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} { + testexprparser {1<2 != 3} -1 +} {- {} 0 subexpr {1<2 != 3} 9 operator != 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-7.6 {ParseEqualityExpr procedure, bad lexeme after "==" or "!="} {nonPortable} { + list [catch {testexprparser {1<2 == 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-7.7 {ParseEqualityExpr procedure, valid RHS subexpression} { + testexprparser {1<2 == 3 == 4} -1 +} {- {} 0 subexpr {1<2 == 3 == 4} 13 operator == 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-7.8 {ParseEqualityExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1<2 == 3 != martha} -1} msg] $msg +} {1 {syntax error in expression "1<2 == 3 != martha"}} + +test parseExpr-8.1 {ParseRelationalExpr procedure, valid LHS shift subexpr} { + testexprparser {1<<2 < 3} -1 +} {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-8.2 {ParseRelationalExpr procedure, error in LHS shift subexpr} { + list [catch {testexprparser {1>=foo < 3} -1} msg] $msg +} {1 {syntax error in expression "1>=foo < 3"}} +test parseExpr-8.3 {ParseRelationalExpr procedure, next lexeme isn't relational op} { + testexprparser {1<<2? 1 : 0} -1 +} {- {} 0 subexpr {1<<2? 1 : 0} 11 operator ? 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-8.4 {ParseRelationalExpr procedure, next lexeme is relational op} { + testexprparser {1<<2 < 3} -1 +} {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-8.5 {ParseRelationalExpr procedure, next lexeme is relational op} { + testexprparser {1>>2 > 3} -1 +} {- {} 0 subexpr {1>>2 > 3} 9 operator > 0 subexpr 1>>2 5 operator >> 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-8.6 {ParseRelationalExpr procedure, next lexeme is relational op} { + testexprparser {1<<2 <= 3} -1 +} {- {} 0 subexpr {1<<2 <= 3} 9 operator <= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-8.7 {ParseRelationalExpr procedure, next lexeme is relational op} { + testexprparser {1<<2 >= 3} -1 +} {- {} 0 subexpr {1<<2 >= 3} 9 operator >= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-8.8 {ParseRelationalExpr procedure, bad lexeme after relational op} {nonPortable} { + list [catch {testexprparser {1<<2 < 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-8.9 {ParseRelationalExpr procedure, valid RHS subexpression} { + testexprparser {1<<2 < 3 < 4} -1 +} {- {} 0 subexpr {1<<2 < 3 < 4} 13 operator < 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-8.8 {ParseRelationalExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1<<2 < 3 > martha} -1} msg] $msg +} {1 {syntax error in expression "1<<2 < 3 > martha"}} + +test parseExpr-9.1 {ParseShiftExpr procedure, valid LHS add subexpr} { + testexprparser {1+2 << 3} -1 +} {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-9.2 {ParseShiftExpr procedure, error in LHS add subexpr} { + list [catch {testexprparser {1-foo << 3} -1} msg] $msg +} {1 {syntax error in expression "1-foo << 3"}} +test parseExpr-9.3 {ParseShiftExpr procedure, next lexeme isn't "<<" or ">>"} { + testexprparser {1+2? 1 : 0} -1 +} {- {} 0 subexpr {1+2? 1 : 0} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-9.4 {ParseShiftExpr procedure, next lexeme is "<<" or ">>} { + testexprparser {1+2 << 3} -1 +} {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-9.5 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} { + testexprparser {1+2 >> 3} -1 +} {- {} 0 subexpr {1+2 >> 3} 9 operator >> 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-9.6 {ParseShiftExpr procedure, bad lexeme after "<<" or ">>"} {nonPortable} { + list [catch {testexprparser {1+2 << 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-9.7 {ParseShiftExpr procedure, valid RHS subexpression} { + testexprparser {1+2 << 3 << 4} -1 +} {- {} 0 subexpr {1+2 << 3 << 4} 13 operator << 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-9.8 {ParseShiftExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1+2 << 3 >> martha} -1} msg] $msg +} {1 {syntax error in expression "1+2 << 3 >> martha"}} + +test parseExpr-10.1 {ParseAddExpr procedure, valid LHS multiply subexpr} { + testexprparser {1*2 + 3} -1 +} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-10.2 {ParseAddExpr procedure, error in LHS multiply subexpr} { + list [catch {testexprparser {1/foo + 3} -1} msg] $msg +} {1 {syntax error in expression "1/foo + 3"}} +test parseExpr-10.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} { + testexprparser {1*2? 1 : 0} -1 +} {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-10.4 {ParseAddExpr procedure, next lexeme is "+" or "-} { + testexprparser {1*2 + 3} -1 +} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-10.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} { + testexprparser {1*2 - 3} -1 +} {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-10.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {nonPortable} { + list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-10.7 {ParseAddExpr procedure, valid RHS subexpression} { + testexprparser {1*2 + 3 + 4} -1 +} {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-10.8 {ParseAddExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg +} {1 {syntax error in expression "1*2 + 3 - martha"}} + +test parseExpr-10.1 {ParseAddExpr procedure, valid LHS multiply subexpr} { + testexprparser {1*2 + 3} -1 +} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-10.2 {ParseAddExpr procedure, error in LHS multiply subexpr} { + list [catch {testexprparser {1/foo + 3} -1} msg] $msg +} {1 {syntax error in expression "1/foo + 3"}} +test parseExpr-10.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} { + testexprparser {1*2? 1 : 0} -1 +} {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-10.4 {ParseAddExpr procedure, next lexeme is "+" or "-} { + testexprparser {1*2 + 3} -1 +} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-10.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} { + testexprparser {1*2 - 3} -1 +} {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-10.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {nonPortable} { + list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-10.7 {ParseAddExpr procedure, valid RHS subexpression} { + testexprparser {1*2 + 3 + 4} -1 +} {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-10.8 {ParseAddExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg +} {1 {syntax error in expression "1*2 + 3 - martha"}} + +test parseExpr-11.1 {ParseMultiplyExpr procedure, valid LHS unary subexpr} { + testexprparser {+2 * 3} -1 +} {- {} 0 subexpr {+2 * 3} 7 operator * 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-11.2 {ParseMultiplyExpr procedure, error in LHS unary subexpr} {nonPortable} { + list [catch {testexprparser {-12345678901234567890 * 3} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-11.3 {ParseMultiplyExpr procedure, next lexeme isn't "*", "/", or "%"} { + testexprparser {+2? 1 : 0} -1 +} {- {} 0 subexpr {+2? 1 : 0} 9 operator ? 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-11.4 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} { + testexprparser {-123 * 3} -1 +} {- {} 0 subexpr {-123 * 3} 7 operator * 0 subexpr -123 3 operator - 0 subexpr 123 1 text 123 0 subexpr 3 1 text 3 0 {}} +test parseExpr-11.5 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} { + testexprparser {+-456 / 3} -1 +} {- {} 0 subexpr {+-456 / 3} 9 operator / 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}} +test parseExpr-11.6 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} { + testexprparser {+-456 % 3} -1 +} {- {} 0 subexpr {+-456 % 3} 9 operator % 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}} +test parseExpr-11.7 {ParseMultiplyExpr procedure, bad lexeme after "*", "/", or "%"} {nonPortable} { + list [catch {testexprparser {--++5 / 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-11.8 {ParseMultiplyExpr procedure, valid RHS subexpression} { + testexprparser {-2 / 3 % 4} -1 +} {- {} 0 subexpr {-2 / 3 % 4} 11 operator % 0 subexpr {-2 / 3} 7 operator / 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-11.9 {ParseMultiplyExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {++2 / 3 * martha} -1} msg] $msg +} {1 {syntax error in expression "++2 / 3 * martha"}} + +test parseExpr-12.1 {ParseUnaryExpr procedure, first token is unary operator} { + testexprparser {+2} -1 +} {- {} 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 {}} +test parseExpr-12.2 {ParseUnaryExpr procedure, first token is unary operator} { + testexprparser {-2} -1 +} {- {} 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 {}} +test parseExpr-12.3 {ParseUnaryExpr procedure, first token is unary operator} { + testexprparser {~2} -1 +} {- {} 0 subexpr ~2 3 operator ~ 0 subexpr 2 1 text 2 0 {}} +test parseExpr-12.4 {ParseUnaryExpr procedure, first token is unary operator} { + testexprparser {!2} -1 +} {- {} 0 subexpr !2 3 operator ! 0 subexpr 2 1 text 2 0 {}} +test parseExpr-12.5 {ParseUnaryExpr procedure, error in lexeme after unary op} {nonPortable} { + list [catch {testexprparser {-12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-12.6 {ParseUnaryExpr procedure, simple unary expr after unary op} { + testexprparser {+"1234"} -1 +} {- {} 0 subexpr +\"1234\" 3 operator + 0 subexpr {"1234"} 1 text 1234 0 {}} +test parseExpr-12.7 {ParseUnaryExpr procedure, another unary expr after unary op} { + testexprparser {~!{fred}} -1 +} {- {} 0 subexpr ~!{fred} 5 operator ~ 0 subexpr !{fred} 3 operator ! 0 subexpr {{fred}} 1 text fred 0 {}} +test parseExpr-12.8 {ParseUnaryExpr procedure, error in unary expr after unary op} { + list [catch {testexprparser {+-||27} -1} msg] $msg +} {1 {syntax error in expression "+-||27"}} +test parseExpr-12.9 {ParseUnaryExpr procedure, error in unary expr after unary op} { + list [catch {testexprparser {+-||27} -1} msg] $msg +} {1 {syntax error in expression "+-||27"}} +test parseExpr-12.10 {ParseUnaryExpr procedure, first token is not unary op} { + testexprparser {123} -1 +} {- {} 0 subexpr 123 1 text 123 0 {}} +test parseExpr-12.11 {ParseUnaryExpr procedure, not unary expr, complex primary expr} { + testexprparser {(1+2)} -1 +} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-12.12 {ParseUnaryExpr procedure, not unary expr, error in primary expr} {nonPortable} { + list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg +} {1 {integer value too large to represent}} + +test parseExpr-13.1 {ParsePrimaryExpr procedure, just parenthesized subexpr} { + testexprparser {({abc}/{def})} -1 +} {- {} 0 subexpr {{abc}/{def}} 5 operator / 0 subexpr {{abc}} 1 text abc 0 subexpr {{def}} 1 text def 0 {}} +test parseExpr-13.2 {ParsePrimaryExpr procedure, bad lexeme after "("} {nonPortable} { + list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-13.3 {ParsePrimaryExpr procedure, valid parenthesized subexpr} { + testexprparser {({abc}? 2*4 : -6)} -1 +} {- {} 0 subexpr {{abc}? 2*4 : -6} 13 operator ? 0 subexpr {{abc}} 1 text abc 0 subexpr 2*4 5 operator * 0 subexpr 2 1 text 2 0 subexpr 4 1 text 4 0 subexpr -6 3 operator - 0 subexpr 6 1 text 6 0 {}} +test parseExpr-13.4 {ParsePrimaryExpr procedure, error in parenthesized subexpr} { + list [catch {testexprparser {(? 123 : 456)} -1} msg] $msg +} {1 {syntax error in expression "(? 123 : 456)"}} +test parseExpr-13.5 {ParsePrimaryExpr procedure, missing ")" after in parenthesized subexpr} { + list [catch {testexprparser {({abc}/{def}} -1} msg] $msg +} {1 {syntax error in expression "({abc}/{def}"}} +test parseExpr-13.6 {ParsePrimaryExpr procedure, primary is literal} { + testexprparser {12345} -1 +} {- {} 0 subexpr 12345 1 text 12345 0 {}} +test parseExpr-13.7 {ParsePrimaryExpr procedure, primary is literal} { + testexprparser {12345.6789} -1 +} {- {} 0 subexpr 12345.6789 1 text 12345.6789 0 {}} +test parseExpr-13.8 {ParsePrimaryExpr procedure, primary is var reference} { + testexprparser {$a} -1 +} {- {} 0 subexpr {$a} 2 variable {$a} 1 text a 0 {}} +test parseExpr-13.9 {ParsePrimaryExpr procedure, primary is var reference} { + testexprparser {$a(hello$there)} -1 +} {- {} 0 subexpr {$a(hello$there)} 5 variable {$a(hello$there)} 4 text a 0 text hello 0 variable {$there} 1 text there 0 {}} +test parseExpr-13.10 {ParsePrimaryExpr procedure, primary is var reference} { + testexprparser {$a()} -1 +} {- {} 0 subexpr {$a()} 3 variable {$a()} 2 text a 0 text {} 0 {}} +test parseExpr-13.11 {ParsePrimaryExpr procedure, error in var reference} { + list [catch {testexprparser {$a(} -1} msg] $msg +} {1 {missing )}} +test parseExpr-13.12 {ParsePrimaryExpr procedure, primary is quoted string} { + testexprparser {"abc $xyz def"} -1 +} {- {} 0 subexpr {"abc $xyz def"} 5 word {"abc $xyz def"} 4 text {abc } 0 variable {$xyz} 1 text xyz 0 text { def} 0 {}} +test parseExpr-13.13 {ParsePrimaryExpr procedure, error in quoted string} { + list [catch {testexprparser {"$a(12"} -1} msg] $msg +} {1 {missing )}} +test parseExpr-13.14 {ParsePrimaryExpr procedure, quoted string has multiple tokens} { + testexprparser {"abc [xyz] $def"} -1 +} {- {} 0 subexpr {"abc [xyz] $def"} 6 word {"abc [xyz] $def"} 5 text {abc } 0 command {[xyz]} 0 text { } 0 variable {$def} 1 text def 0 {}} +test parseExpr-13.15 {ParsePrimaryExpr procedure, primary is command} { + testexprparser {[def]} -1 +} {- {} 0 subexpr {[def]} 1 command {[def]} 0 {}} +test parseExpr-13.16 {ParsePrimaryExpr procedure, primary is multiple commands} { + testexprparser {[one; two; three; four;]} -1 +} {- {} 0 subexpr {[one; two; three; four;]} 1 command {[one; two; three; four;]} 0 {}} +test parseExpr-13.17 {ParsePrimaryExpr procedure, primary is multiple commands} { + testexprparser {[one; two; three; four;]} -1 +} {- {} 0 subexpr {[one; two; three; four;]} 1 command {[one; two; three; four;]} 0 {}} +test parseExpr-13.18 {ParsePrimaryExpr procedure, missing close bracket} { + list [catch {testexprparser {[one} -1} msg] $msg +} {1 {missing close-bracket}} +test parseExpr-13.19 {ParsePrimaryExpr procedure, primary is braced string} { + testexprparser {{hello world}} -1 +} {- {} 0 subexpr {{hello world}} 1 text {hello world} 0 {}} +test parseExpr-13.20 {ParsePrimaryExpr procedure, error in primary, which is braced string} { + list [catch {testexprparser "\{abc\\\n" -1} msg] $msg +} {1 {missing close-brace}} +test parseExpr-13.21 {ParsePrimaryExpr procedure, primary is braced string with multiple tokens} { + testexprparser "\{ \\ + +123 \}" -1 +} {- {} 0 subexpr \{\ \ \\\n\ +123\ \} 4 word \{\ \ \\\n\ +123\ \} 3 text { } 0 backslash \\\n\ 0 text {+123 } 0 {}} +test parseExpr-13.22 {ParsePrimaryExpr procedure, primary is function call} { + testexprparser {foo(123)} -1 +} {- {} 0 subexpr foo(123) 3 operator foo 0 subexpr 123 1 text 123 0 {}} +test parseExpr-13.23 {ParsePrimaryExpr procedure, bad lexeme after function name} {nonPortable} { + list [catch {testexprparser {foo 12345678901234567890 123)} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-13.24 {ParsePrimaryExpr procedure, lexeme after function name isn't "("} { + list [catch {testexprparser {foo 27.4 123)} -1} msg] $msg +} {1 {syntax error in expression "foo 27.4 123)"}} +test parseExpr-13.25 {ParsePrimaryExpr procedure, bad lexeme after "("} {nonPortable} { + list [catch {testexprparser {foo(12345678901234567890)} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-13.26 {ParsePrimaryExpr procedure, function call, one arg} { + testexprparser {foo(27*4)} -1 +} {- {} 0 subexpr foo(27*4) 7 operator foo 0 subexpr 27*4 5 operator * 0 subexpr 27 1 text 27 0 subexpr 4 1 text 4 0 {}} +test parseExpr-13.27 {ParsePrimaryExpr procedure, error in function arg} { + list [catch {testexprparser {foo(*1-2)} -1} msg] $msg +} {1 {syntax error in expression "foo(*1-2)"}} +test parseExpr-13.28 {ParsePrimaryExpr procedure, error in function arg} { + list [catch {testexprparser {foo(*1-2)} -1} msg] $msg +} {1 {syntax error in expression "foo(*1-2)"}} +test parseExpr-13.29 {ParsePrimaryExpr procedure, function call, comma after arg} { + testexprparser {foo(27-2, (-2*[foo]))} -1 +} {- {} 0 subexpr {foo(27-2, (-2*[foo]))} 15 operator foo 0 subexpr 27-2 5 operator - 0 subexpr 27 1 text 27 0 subexpr 2 1 text 2 0 subexpr {-2*[foo]} 7 operator * 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr {[foo]} 1 command {[foo]} 0 {}} +test parseExpr-13.30 {ParsePrimaryExpr procedure, bad lexeme after comma} {nonPortable} { + list [catch {testexprparser {foo(123, 12345678901234567890)} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-13.31 {ParsePrimaryExpr procedure, lexeme not "," or ")" after arg} { + list [catch {testexprparser {foo(123 [foo])} -1} msg] $msg +} {1 {syntax error in expression "foo(123 [foo])"}} +test parseExpr-13.32 {ParsePrimaryExpr procedure, bad lexeme after primary} {nonPortable} { + list [catch {testexprparser {123 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} + +test parseExpr-14.1 {GetLexeme procedure, whitespace before lexeme} { + testexprparser { 123} -1 +} {- {} 0 subexpr 123 1 text 123 0 {}} +test parseExpr-14.2 {GetLexeme procedure, whitespace before lexeme} { + testexprparser { \ +456} -1 +} {- {} 0 subexpr 456 1 text 456 0 {}} +test parseExpr-14.3 {GetLexeme procedure, no lexeme after whitespace} { + testexprparser { 123 \ + } -1 +} {- {} 0 subexpr 123 1 text 123 0 {}} +test parseExpr-14.4 {GetLexeme procedure, integer lexeme} { + testexprparser {000} -1 +} {- {} 0 subexpr 000 1 text 000 0 {}} +test parseExpr-14.5 {GetLexeme procedure, integer lexeme too big} {nonPortable} { + list [catch {testexprparser {12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-14.6 {GetLexeme procedure, bad integer lexeme} { + list [catch {testexprparser {0999} -1} msg] $msg +} {1 {syntax error in expression "0999"}} +test parseExpr-14.7 {GetLexeme procedure, double lexeme} { + testexprparser {0.999} -1 +} {- {} 0 subexpr 0.999 1 text 0.999 0 {}} +test parseExpr-14.8 {GetLexeme procedure, double lexeme} { + testexprparser {.123} -1 +} {- {} 0 subexpr .123 1 text .123 0 {}} +test parseExpr-14.9 {GetLexeme procedure, double lexeme} {nonPortable unixOnly} { + testexprparser {nan} -1 +} {- {} 0 subexpr nan 1 text nan 0 {}} +test parseExpr-14.10 {GetLexeme procedure, double lexeme} {nonPortable unixOnly} { + testexprparser {NaN} -1 +} {- {} 0 subexpr NaN 1 text NaN 0 {}} +test parseExpr-14.11 {GetLexeme procedure, bad double lexeme too big} { + list [catch {testexprparser {123.e+99999999999999} -1} msg] $msg +} {1 {floating-point value too large to represent}} +test parseExpr-14.12 {GetLexeme procedure, bad double lexeme} { + list [catch {testexprparser {123.4x56} -1} msg] $msg +} {1 {syntax error in expression "123.4x56"}} +test parseExpr-14.13 {GetLexeme procedure, lexeme is "["} { + testexprparser {[foo]} -1 +} {- {} 0 subexpr {[foo]} 1 command {[foo]} 0 {}} +test parseExpr-14.14 {GetLexeme procedure, lexeme is open brace} { + testexprparser {{bar}} -1 +} {- {} 0 subexpr {{bar}} 1 text bar 0 {}} +test parseExpr-14.15 {GetLexeme procedure, lexeme is "("} { + testexprparser {(123)} -1 +} {- {} 0 subexpr 123 1 text 123 0 {}} +test parseExpr-14.16 {GetLexeme procedure, lexeme is ")"} { + testexprparser {(2*3)} -1 +} {- {} 0 subexpr 2*3 5 operator * 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.17 {GetLexeme procedure, lexeme is "$"} { + testexprparser {$wombat} -1 +} {- {} 0 subexpr {$wombat} 2 variable {$wombat} 1 text wombat 0 {}} +test parseExpr-14.18 {GetLexeme procedure, lexeme is '"'} { + testexprparser {"fred"} -1 +} {- {} 0 subexpr {"fred"} 1 text fred 0 {}} +test parseExpr-14.19 {GetLexeme procedure, lexeme is ","} { + testexprparser {foo(1,2)} -1 +} {- {} 0 subexpr foo(1,2) 5 operator foo 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-14.20 {GetLexeme procedure, lexeme is "*"} { + testexprparser {$a*$b} -1 +} {- {} 0 subexpr {$a*$b} 7 operator * 0 subexpr {$a} 2 variable {$a} 1 text a 0 subexpr {$b} 2 variable {$b} 1 text b 0 {}} +test parseExpr-14.21 {GetLexeme procedure, lexeme is "/"} { + testexprparser {5/6} -1 +} {- {} 0 subexpr 5/6 5 operator / 0 subexpr 5 1 text 5 0 subexpr 6 1 text 6 0 {}} +test parseExpr-14.22 {GetLexeme procedure, lexeme is "%"} { + testexprparser {5%[xxx]} -1 +} {- {} 0 subexpr {5%[xxx]} 5 operator % 0 subexpr 5 1 text 5 0 subexpr {[xxx]} 1 command {[xxx]} 0 {}} +test parseExpr-14.23 {GetLexeme procedure, lexeme is "+"} { + testexprparser {1+2} -1 +} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-14.24 {GetLexeme procedure, lexeme is "-"} { + testexprparser {.12-0e27} -1 +} {- {} 0 subexpr .12-0e27 5 operator - 0 subexpr .12 1 text .12 0 subexpr 0e27 1 text 0e27 0 {}} +test parseExpr-14.25 {GetLexeme procedure, lexeme is "?" or ":"} { + testexprparser {$b? 1 : 0} -1 +} {- {} 0 subexpr {$b? 1 : 0} 8 operator ? 0 subexpr {$b} 2 variable {$b} 1 text b 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-14.26 {GetLexeme procedure, lexeme is "<"} { + testexprparser {2<3} -1 +} {- {} 0 subexpr 2<3 5 operator < 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.27 {GetLexeme procedure, lexeme is "<<"} { + testexprparser {2<<3} -1 +} {- {} 0 subexpr 2<<3 5 operator << 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.28 {GetLexeme procedure, lexeme is "<="} { + testexprparser {2<=3} -1 +} {- {} 0 subexpr 2<=3 5 operator <= 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.29 {GetLexeme procedure, lexeme is ">"} { + testexprparser {2>3} -1 +} {- {} 0 subexpr 2>3 5 operator > 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.30 {GetLexeme procedure, lexeme is ">>"} { + testexprparser {2>>3} -1 +} {- {} 0 subexpr 2>>3 5 operator >> 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.31 {GetLexeme procedure, lexeme is ">="} { + testexprparser {2>=3} -1 +} {- {} 0 subexpr 2>=3 5 operator >= 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.32 {GetLexeme procedure, lexeme is "=="} { + testexprparser {2==3} -1 +} {- {} 0 subexpr 2==3 5 operator == 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.33 {GetLexeme procedure, bad lexeme starting with "="} { + list [catch {testexprparser {2=+3} -1} msg] $msg +} {1 {syntax error in expression "2=+3"}} +test parseExpr-14.34 {GetLexeme procedure, lexeme is "!="} { + testexprparser {2!=3} -1 +} {- {} 0 subexpr 2!=3 5 operator != 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.35 {GetLexeme procedure, lexeme is "!"} { + testexprparser {!2} -1 +} {- {} 0 subexpr !2 3 operator ! 0 subexpr 2 1 text 2 0 {}} +test parseExpr-14.36 {GetLexeme procedure, lexeme is "&&"} { + testexprparser {2&&3} -1 +} {- {} 0 subexpr 2&&3 5 operator && 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.37 {GetLexeme procedure, lexeme is "&"} { + testexprparser {1&2} -1 +} {- {} 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-14.38 {GetLexeme procedure, lexeme is "^"} { + testexprparser {1^2} -1 +} {- {} 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-14.39 {GetLexeme procedure, lexeme is "||"} { + testexprparser {2||3} -1 +} {- {} 0 subexpr 2||3 5 operator || 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.40 {GetLexeme procedure, lexeme is "|"} { + testexprparser {1|2} -1 +} {- {} 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-14.41 {GetLexeme procedure, lexeme is "~"} { + testexprparser {~2} -1 +} {- {} 0 subexpr ~2 3 operator ~ 0 subexpr 2 1 text 2 0 {}} +test parseExpr-14.42 {GetLexeme procedure, lexeme is func name} { + testexprparser {george()} -1 +} {- {} 0 subexpr george() 1 operator george 0 {}} +test parseExpr-14.43 {GetLexeme procedure, lexeme is func name} { + testexprparser {harmonic_ratio(2,3)} -1 +} {- {} 0 subexpr harmonic_ratio(2,3) 5 operator harmonic_ratio 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.44 {GetLexeme procedure, unknown lexeme} { + list [catch {testexprparser {@27} -1} msg] $msg +} {1 {syntax error in expression "@27"}} + +test parseExpr-15.1 {PrependSubExprTokens procedure, expand token array} { + testexprparser {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} -1 +} {- {} 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 13 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 9 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 5 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 {}} + +test parse-16.1 {LogSyntaxError procedure, error in expr longer than 60 chars} { + list [catch {testexprparser {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1} msg] $msg +} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012"}} + +return diff --git a/tests/parseOld.test b/tests/parseOld.test new file mode 100644 index 0000000..47dc1a6 --- /dev/null +++ b/tests/parseOld.test @@ -0,0 +1,529 @@ +# Commands covered: set (plus basic command syntax). Also tests the +# procedures in the file tclOldParse.c. This set of tests is an old +# one that predates the new parser in Tcl 8.1. +# +# 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-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: @(#) parseOld.test 1.52 98/02/11 19:01:03 + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc fourArgs {a b c d} { + global arg1 arg2 arg3 arg4 + set arg1 $a + set arg2 $b + set arg3 $c + set arg4 $d +} + +proc getArgs args { + global argv + set argv $args +} + +# Basic argument parsing. + +test parseOld-1.1 {basic argument parsing} { + set arg1 {} + fourArgs a b c d + list $arg1 $arg2 $arg3 $arg4 +} {a b c d} +test parseOld-1.2 {basic argument parsing} { + set arg1 {} + eval "fourArgs 123\v4\f56\r7890" + list $arg1 $arg2 $arg3 $arg4 +} {123 4 56 7890} + +# Quotes. + +test parseOld-2.1 {quotes and variable-substitution} { + getArgs "a b c" d + set argv +} {{a b c} d} +test parseOld-2.2 {quotes and variable-substitution} { + set a 101 + getArgs "a$a b c" + set argv +} {{a101 b c}} +test parseOld-2.3 {quotes and variable-substitution} { + set argv "xy[format xabc]" + set argv +} {xyxabc} +test parseOld-2.4 {quotes and variable-substitution} { + set argv "xy\t" + set argv +} xy\t +test parseOld-2.5 {quotes and variable-substitution} { + set argv "a b c +d e f" + set argv +} a\ b\tc\nd\ e\ f +test parseOld-2.6 {quotes and variable-substitution} { + set argv a"bcd"e + set argv +} {a"bcd"e} + +# Braces. + +test parseOld-3.1 {braces} { + getArgs {a b c} d + set argv +} "{a b c} d" +test parseOld-3.2 {braces} { + set a 101 + set argv {a$a b c} + set b [string index $argv 1] + set b +} {$} +test parseOld-3.3 {braces} { + set argv {a[format xyz] b} + string length $argv +} 15 +test parseOld-3.4 {braces} { + set argv {a\nb\}} + string length $argv +} 6 +test parseOld-3.5 {braces} { + set argv {{{{}}}} + set argv +} "{{{}}}" +test parseOld-3.6 {braces} { + set argv a{{}}b + set argv +} "a{{}}b" +test parseOld-3.7 {braces} { + set a [format "last]"] + set a +} {last]} + +# Command substitution. + +test parseOld-4.1 {command substitution} { + set a [format xyz] + set a +} xyz +test parseOld-4.2 {command substitution} { + set a a[format xyz]b[format q] + set a +} axyzbq +test parseOld-4.3 {command substitution} { + set a a[ +set b 22; +format %s $b + +]b + set a +} a22b +test parseOld-4.4 {command substitution} { + set a 7.7 + if [catch {expr int($a)}] {set a foo} + set a +} 7.7 + +# Variable substitution. + +test parseOld-5.1 {variable substitution} { + set a 123 + set b $a + set b +} 123 +test parseOld-5.2 {variable substitution} { + set a 345 + set b x$a.b + set b +} x345.b +test parseOld-5.3 {variable substitution} { + set _123z xx + set b $_123z^ + set b +} xx^ +test parseOld-5.4 {variable substitution} { + set a 78 + set b a${a}b + set b +} a78b +test parseOld-5.5 {variable substitution} {catch {$_non_existent_} msg} 1 +test parseOld-5.6 {variable substitution} { + catch {$_non_existent_} msg + set msg +} {can't read "_non_existent_": no such variable} +test parseOld-5.7 {array variable substitution} { + catch {unset a} + set a(xyz) 123 + set b $a(xyz)foo + set b +} 123foo +test parseOld-5.8 {array variable substitution} { + catch {unset a} + set "a(x y z)" 123 + set b $a(x y z)foo + set b +} 123foo +test parseOld-5.9 {array variable substitution} { + catch {unset a}; catch {unset qqq} + set "a(x y z)" qqq + set $a([format x]\ y [format z]) foo + set qqq +} foo +test parseOld-5.10 {array variable substitution} { + catch {unset a} + list [catch {set b $a(22)} msg] $msg +} {1 {can't read "a(22)": no such variable}} +test parseOld-5.11 {array variable substitution} { + set b a$! + set b +} {a$!} +test parseOld-5.12 {array variable substitution} { + set b a$() + set b +} {a$()} +catch {unset a} +test parseOld-5.13 {array variable substitution} { + catch {unset a} + set long {This is a very long variable, long enough to cause storage \ + allocation to occur in Tcl_ParseVar. If that storage isn't getting \ + freed up correctly, then a core leak will occur when this test is \ + run. This text is probably beginning to sound like drivel, but I've \ + run out of things to say and I need more characters still.} + set a($long) 777 + set b $a($long) + list $b [array names a] +} {777 {{This is a very long variable, long enough to cause storage \ + allocation to occur in Tcl_ParseVar. If that storage isn't getting \ + freed up correctly, then a core leak will occur when this test is \ + run. This text is probably beginning to sound like drivel, but I've \ + run out of things to say and I need more characters still.}}} +test parseOld-5.14 {array variable substitution} { + catch {unset a}; catch {unset b}; catch {unset a1} + set a1(22) foo + set a(foo) bar + set b $a($a1(22)) + set b +} bar +catch {unset a}; catch {unset a1} + +test parseOld-7.1 {backslash substitution} { + set a "\a\c\n\]\}" + string length $a +} 5 +test parseOld-7.2 {backslash substitution} { + set a {\a\c\n\]\}} + string length $a +} 10 +test parseOld-7.3 {backslash substitution} { + set a "abc\ +def" + set a +} {abc def} +test parseOld-7.4 {backslash substitution} { + set a {abc\ +def} + set a +} {abc def} +test parseOld-7.5 {backslash substitution} { + set msg {} + set a xxx + set error [catch {if {24 < \ + 35} {set a 22} {set \ + a 33}} msg] + list $error $msg $a +} {0 22 22} +test parseOld-7.6 {backslash substitution} { + eval "concat abc\\" +} "abc\\" +test parseOld-7.7 {backslash substitution} { + eval "concat \\\na" +} "a" +test parseOld-7.8 {backslash substitution} { + eval "concat x\\\n a" +} "x a" +test parseOld-7.9 {backslash substitution} { + eval "concat \\x" +} "x" +test parseOld-7.10 {backslash substitution} { + eval "list a b\\\nc d" +} {a b c d} +test parseOld-7.11 {backslash substitution} { + eval "list a \"b c\"\\\nd e" +} {a {b c} d e} +test parseOld-7.12 {backslash substitution} { + list \ua2 +} [bytestring "\xc2\xa2"] +test parseOld-7.13 {backslash substitution} { + list \u4e21 +} [bytestring "\xe4\xb8\xa1"] +test parseOld-7.14 {backslash substitution} { + list \u4e2k +} [bytestring "\xd3\xa2k"] + +# Semi-colon. + +test parseOld-8.1 {semi-colons} { + set b 0 + getArgs a;set b 2 + set argv +} a +test parseOld-8.2 {semi-colons} { + set b 0 + getArgs a;set b 2 + set b +} 2 +test parseOld-8.3 {semi-colons} { + getArgs a b ; set b 1 + set argv +} {a b} +test parseOld-8.4 {semi-colons} { + getArgs a b ; set b 1 + set b +} 1 + +# The following checks are to ensure that the interpreter's result +# gets re-initialized by Tcl_Eval in all the right places. + +test parseOld-9.1 {result initialization} {concat abc} abc +test parseOld-9.2 {result initialization} {concat abc; proc foo {} {}} {} +test parseOld-9.3 {result initialization} {concat abc; proc foo {} $a} {} +test parseOld-9.4 {result initialization} {proc foo {} [concat abc]} {} +test parseOld-9.5 {result initialization} {concat abc; } abc +test parseOld-9.6 {result initialization} { + eval { + concat abc +}} abc +test parseOld-9.7 {result initialization} {} {} +test parseOld-9.8 {result initialization} {concat abc; ; ;} abc + +# Syntax errors. + +test parseOld-10.1 {syntax errors} {catch "set a \{bcd" msg} 1 +test parseOld-10.2 {syntax errors} { + catch "set a \{bcd" msg + set msg +} {missing close-brace} +test parseOld-10.3 {syntax errors} {catch {set a "bcd} msg} 1 +test parseOld-10.4 {syntax errors} { + catch {set a "bcd} msg + set msg +} {missing "} +test parseOld-10.5 {syntax errors} {catch {set a "bcd"xy} msg} 1 +test parseOld-10.6 {syntax errors} { + catch {set a "bcd"xy} msg + set msg +} {extra characters after close-quote} +test parseOld-10.7 {syntax errors} {catch "set a {bcd}xy" msg} 1 +test parseOld-10.8 {syntax errors} { + catch "set a {bcd}xy" msg + set msg +} {extra characters after close-brace} +test parseOld-10.9 {syntax errors} {catch {set a [format abc} msg} 1 +test parseOld-10.10 {syntax errors} { + catch {set a [format abc} msg + set msg +} {missing close-bracket} +test parseOld-10.11 {syntax errors} {catch gorp-a-lot msg} 1 +test parseOld-10.12 {syntax errors} { + catch gorp-a-lot msg + set msg +} {invalid command name "gorp-a-lot"} +test parseOld-10.13 {syntax errors} { + set a [concat {a}\ + {b}] + set a +} {a b} +test parseOld-10.14 {syntax errors} { + list [catch {eval \$x[format "%01000d" 0](} msg] $msg $errorInfo +} {1 {missing )} {missing ) + while compiling +"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000..." + ("eval" body line 1) + invoked from within +"eval \$x[format "%01000d" 0]("}} +test parseOld-10.15 {syntax errors, missplaced braces} { + catch { + proc misplaced_end_brace {} { + set what foo + set when [expr ${what}size - [set off$what]}] + } msg + set msg +} {extra characters after close-brace} +test parseOld-10.16 {syntax errors, missplaced braces} { + catch { + set a { + set what foo + set when [expr ${what}size - [set off$what]}] + } msg + set msg +} {extra characters after close-brace} +test parseOld-10.17 {syntax errors, unusual spacing} { + list [catch {return [ [1]]} msg] $msg +} {1 {invalid command name "1"}} +# Long values (stressing storage management) + +set 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 HHHH} + +test parseOld-11.1 {long values} { + string length $a +} 214 +test parseOld-11.2 {long values} { + llength $a +} 43 +test parseOld-11.3 {long values} { + set b "1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH" + set b +} $a +test parseOld-11.4 {long values} { + set b "$a" + set b +} $a +test parseOld-11.5 {long values} { + set b [set a] + set b +} $a +test parseOld-11.6 {long values} { + set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] + string length $b +} 214 +test parseOld-11.7 {long values} { + set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] + llength $b +} 43 +test parseOld-11.8 {long values} { + set b +} $a +test parseOld-11.9 {long values} { + set a [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] + llength $a +} 62 +set i 0 +foreach j [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] { + set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i] + set test $test$test$test$test + set i [expr $i+1] + test parseOld-11.10 {long values} { + set j + } $test +} +test parseOld-11.11 {test buffer overflow in backslashes in braces} { + expr {"a" == {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101}} +} 0 + +test parseOld-12.1 {comments} { + set a old + eval { # set a new} + set a +} {old} +test parseOld-12.2 {comments} { + set a old + eval " # set a new\nset a new" + set a +} {new} +test parseOld-12.3 {comments} { + set a old + eval " # set a new\\\nset a new" + set a +} {old} +test parseOld-12.4 {comments} { + set a old + eval " # set a new\\\\\nset a new" + set a +} {new} + +test parseOld-13.1 {comments at the end of a bracketed script} { + set x "[ +expr 1+1 +# skip this! +]" +} {2} + +if {[info command testwordend] == "testwordend"} { + test parseOld-14.1 {TclWordEnd procedure} { + testwordend " \n abc" + } {c} + test parseOld-14.2 {TclWordEnd procedure} { + testwordend " \\\n" + } {} + test parseOld-14.3 {TclWordEnd procedure} { + testwordend " \\\n " + } { } + test parseOld-14.4 {TclWordEnd procedure} { + testwordend {"abc"} + } {"} + test parseOld-14.5 {TclWordEnd procedure} { + testwordend {{xyz}} + } \} + test parseOld-14.6 {TclWordEnd procedure} { + testwordend {{a{}b{}\}} xyz} + } "\} xyz" + test parseOld-14.7 {TclWordEnd procedure} { + testwordend {abc[this is a]def ghi} + } {f ghi} + test parseOld-14.8 {TclWordEnd procedure} { + testwordend "puts\\\n\n " + } "s\\\n\n " + test parseOld-14.9 {TclWordEnd procedure} { + testwordend "puts\\\n " + } "s\\\n " + test parseOld-14.10 {TclWordEnd procedure} { + testwordend "puts\\\n xyz" + } "s\\\n xyz" + test parseOld-14.11 {TclWordEnd procedure} { + testwordend {a$x.$y(a long index) foo} + } ") foo" + test parseOld-14.12 {TclWordEnd procedure} { + testwordend {abc; def} + } {; def} + test parseOld-14.13 {TclWordEnd procedure} { + testwordend {abc def} + } {c def} + test parseOld-14.14 {TclWordEnd procedure} { + testwordend {abc def} + } {c def} + test parseOld-14.15 {TclWordEnd procedure} { + testwordend "abc\ndef" + } "c\ndef" + test parseOld-14.16 {TclWordEnd procedure} { + testwordend "abc" + } {c} + test parseOld-14.17 {TclWordEnd procedure} { + testwordend "a\000bc" + } {c} + test parseOld-14.18 {TclWordEnd procedure} { + testwordend \[a\000\] + } {]} + test parseOld-14.19 {TclWordEnd procedure} { + testwordend \"a\000\" + } {"} + test parseOld-14.20 {TclWordEnd procedure} { + testwordend a{\000}b + } {b} + test parseOld-14.21 {TclWordEnd procedure} { + testwordend " \000b" + } {b} +} + +test parseOld-15.1 {TclScriptEnd procedure} { + info complete {puts [ + expr 1+1 + #this is a comment ]} +} {0} +test parseOld-15.2 {TclScriptEnd procedure} { + info complete "abc\\\n" +} {0} +test parseOld-15.3 {TclScriptEnd procedure} { + info complete "abc\\\\\n" +} {1} +test parseOld-15.4 {TclScriptEnd procedure} { + info complete "xyz \[abc \{abc\]" +} {0} +test parseOld-15.5 {TclScriptEnd procedure} { + info complete "xyz \[abc" +} {0} + +return diff --git a/tests/pid.test b/tests/pid.test index 1f6e039..3b2f30b 100644 --- a/tests/pid.test +++ b/tests/pid.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: @(#) pid.test 1.12 96/04/12 11:14:43 +# SCCS: @(#) pid.test 1.13 97/12/08 15:05:26 # If pid is not defined just return with no error # Some platforms may not have the pid command implemented @@ -49,4 +49,4 @@ test pid-1.5 {pid command} { } {1 {can not find channel named "gorp"}} catch {removeFile test1} -concat {} +return diff --git a/tests/pkg.test b/tests/pkg.test index e6a99c6..63dc05c 100644 --- a/tests/pkg.test +++ b/tests/pkg.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: @(#) pkg.test 1.12 97/08/14 01:33:54 +# SCCS: @(#) pkg.test 1.14 97/12/08 15:03:04 if {[string compare test [info procs test]] == 1} then {source defs} @@ -483,7 +483,7 @@ test pkg-3.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { } {0} test pkg-3.53 {Tcl_PackageCmd procedure, "versions" option} { list [catch {package foo} msg] $msg -} {1 {bad option "foo": should be forget, ifneeded, names, provide, require, unknown, vcompare, versions, or vsatisfies}} +} {1 {bad option "foo": must be forget, ifneeded, names, provide, require, unknown, vcompare, versions, or vsatisfies}} # No tests for FindPackage; can't think up anything detectable # errors. @@ -561,3 +561,4 @@ concat } interp delete $i +return diff --git a/tests/proc-old.test b/tests/proc-old.test index c770edb..4eb956c 100644 --- a/tests/proc-old.test +++ b/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.31 97/07/02 16:41:36 +# SCCS: @(#) proc-old.test 1.32 97/12/08 15:06:46 if {[string compare test [info procs test]] == 1} then {source defs} @@ -503,3 +503,4 @@ test proc-old-10.1 {ByteCode epoch change during recursive proc execution} { catch {rename t1 ""} catch {rename foo ""} +return diff --git a/tests/proc.test b/tests/proc.test index eeace97..7a0081a 100644 --- a/tests/proc.test +++ b/tests/proc.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: @(#) proc.test 1.11 97/08/12 13:31:43 +# SCCS: @(#) proc.test 1.12 97/12/08 15:03:59 if {[string compare test [info procs test]] == 1} then {source defs} @@ -161,3 +161,4 @@ catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename p ""} catch {rename {} ""} catch {unset msg} +return diff --git a/tests/regexp.test b/tests/regexp.test index 5fb785b..e39c96c 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -5,12 +5,12 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998 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: @(#) regexp.test 1.21 96/12/23 13:59:48 +# SCCS: @(#) regexp.test 1.27 98/01/28 18:07:48 if {[string compare test [info procs test]] == 1} then {source defs} @@ -30,6 +30,15 @@ test regexp-1.4 {basic regexp operation} { test regexp-1.5 {basic regexp operation} { regexp {^([^ ]*)[ ]*([^ ]*)} "" a } 1 +test regexp-1.6 {basic regexp operation} { + list [catch {regexp {} abc} msg] $msg +} {0 1} +test regexp-1.7 {regexp utf compliance} { + # if not UTF-8 aware, result is "0 1" + set foo "\u4e4eb q" + regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar + list [string compare $foo $bar] [regexp 4 $bar] +} {0 0} test regexp-2.1 {getting substrings back from regexp} { set foo {} @@ -120,10 +129,10 @@ test regexp-4.3 {-nocase option to regexp} { } 1 set x abcdefghijklmnopqrstuvwxyz1234567890 set x $x$x$x$x$x$x$x$x$x$x$x$x -test regexp-4.4 {case conversion in regsub} { +test regexp-4.4 {case conversion in regexp} { list [regexp -nocase $x $x foo] $foo } "1 $x" -unset x +catch {unset x} test regexp-5.1 {exercise cache of compiled expressions} { regexp .*a b @@ -186,8 +195,9 @@ test regexp-6.6 {regexp errors} { } {0 1} test regexp-6.7 {regexp errors} { list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg -} {1 {couldn't compile regular expression pattern: too many ()}} +} {0 0} test regexp-6.8 {regexp errors} { + catch {unset f1} set f1 44 list [catch {regexp abc abc f1(f2)} msg] $msg } {1 {couldn't set variable "f1(f2)"}} @@ -244,6 +254,12 @@ test regexp-7.16 {basic regsub operation} { set foo xxx list [regsub x "" y foo] $foo } {0 {}} +test regexp-7.17 {regsub utf compliance} { + # if not UTF-8 aware, result is "0 1" + set foo "xyz555ijka\u4e4ebpqr" + regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar + list [string compare $foo $bar] [regexp 4 $bar] +} {0 0} test regexp-8.1 {case conversion in regsub} { list [regsub -nocase a(a+) xaAAaAAay & foo] $foo @@ -314,5 +330,13 @@ test regexp-10.6 {regsub errors} { list [catch {regsub -nocase a( b c d} msg] $msg } {1 {couldn't compile regular expression pattern: unmatched ()}} test regexp-10.7 {regsub errors} { + catch {unset f1} + set f1 44 list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg } {1 {couldn't set variable "f1(f2)"}} + +test regexp-11.1 {Tcl_RegExpExec: large number of subexpressions} { + list [regexp (.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) abcdefghijklmnopqrstuvwxyz all 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] $all $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 +} {1 abcdefghijklmnopqrstuvwxyz 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} + +return diff --git a/tests/regexp2.test b/tests/regexp2.test new file mode 100644 index 0000000..eb99f76 --- /dev/null +++ b/tests/regexp2.test @@ -0,0 +1,3176 @@ +# Commands covered: regexp +# +# This Tcl-generated file contains tests for the regexp tcl command. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. Setting VERBOSE to +# -1 will run tests that are known to fail. +# +# Copyright (c) 1998 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: @(#) regexp2.test 1.4 98/01/22 14:47:42 + +proc print {arg} {puts $arg} + +if {[string compare test [info procs test]] == 1} { + source defs ; set VERBOSE -1 +} + +if {$VERBOSE != -1} { + proc print {arg} {} +} + +# +# The remainder of this file is Tcl tests that have been +# converted from Henry Spencer's regexp test suite. +# + +# This file is a sequence of regression tests, one per line. The first +# field is the RE, the second flags, the third a string to match the RE +# against, the fourth the expected match, and subsequent fields the +# expected substring matches. No fourth field means match not expected; +# no later fields mean no substrings expected. If the "*" flag is set +# (see below), the third field is the name of the compile error expected, +# less the leading "REG_". Any field may be written as "" to signify an +# empty string. Fourth and subsequent fields may have a suffix "@11" +# (any decimal integer) indicating the offset where the match is expected; +# fifth and subsequent fields may be "@" indicating no match is expected +# for that subexpression. + + +# The flag characters are complex and a bit eclectic. Generally speaking, +# lowercase letters are compile options, uppercase are expected re_info +# bits, and nonalphabetics are match options, controls for how the test is +# run, or debugging options. The one small surprise is that AREs are the +# default, and you must explicitly request lesser flavors of RE. The flags +# are as follows. Be warned that a number of them are specific to this +# RE implementation. It is admitted that some are not very mnemonic. +# +# - no-op (placeholder) +# = map characters in all other fields (see below) +# > map characters in later fields (see below) +# * compile error expected (third field is error type) +# / compile only, do not attempt match +# [2 expect 2 (any decimal integer) subexpressions +# + provide fake ch collating element and xy equiv class +# , turn on compile tracing (probably not useful in this file) +# ; turn on automaton tracing (probably not useful in this file) +# : turn on match tracing (probably not useful in this file) +# . force small state-set cache in matcher (to test cache replace) +# ^ beginning of string is not beginning of line +# $ end of string is not end of line +# +# & test as both BRE and ARE +# b BRE +# e ERE +# q literal string, no metacharacters at all +# +# i case-independent matching +# s no subexpression capture +# p newlines are half-magic, excluded from . and [^ only +# w newlines are half-magic, significant to ^ and $ only +# n newlines are fully magic, both effects +# x expanded RE syntax +# +# A backslash-_a_lphanumeric seen +# B ERE/ARE literal-_b_race heuristic used +# E backslash (_e_scape) seen within [] +# H looka_h_ead constraint seen +# L _l_ocale-specific construct seen +# M unportable (_m_achine-specific) construct seen +# N RE can match empty (_n_ull) string +# P non-_P_OSIX construct seen +# Q {} _q_uantifier seen +# R back _r_eference seen +# S POSIX-un_s_pecified syntax seen +# U saw original-POSIX botch: unmatched right paren in ERE (_u_gh) + + +# The character-mapping flag causes some transformations to be done +# before processing. This is mostly to get funny characters into the +# strings. Specifically: +# +# _ becomes space +# A becomes \007 (some compilers lack \a) +# B becomes \b +# E becomes \033 +# F becomes \f +# N becomes \n +# R becomes \r +# T becomes \t +# V becomes \v + + +# The two areas we can't easily test are memory-allocation failures (which +# are hard to provoke on command) and embedded NULs (which the current test +# program can't easily do; that should be fixed). + + + + + + +# basic sanity checks +test regexp-1.81 {converted from line 81} { + catch {unset var} + list [catch { + set match [regexp -- abc abc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + +test regexp-1.82 {converted from line 82} { + catch {unset var} + list [catch { + set match [regexp -- abc def ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.83 {converted from line 83} { + catch {unset var} + list [catch { + set match [regexp -- abc xyabxabce var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + + + +# invalid option combinations +# skipping char mapping test from line 86 +print {... skip test from line 86: a qe* INVARG} +# skipping char mapping test from line 87 +print {... skip test from line 87: a ba* INVARG} + + +# basic syntax +# skipping the empty-re test from line 90 + +test regexp-1.91 {converted from line 91} { + catch {unset var} + list [catch { + set match [regexp -- a| a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.92 {converted from line 92} { + catch {unset var} + list [catch { + set match [regexp -- a|b a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.93 {converted from line 93} { + catch {unset var} + list [catch { + set match [regexp -- a|b b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.94 {converted from line 94} { + catch {unset var} + list [catch { + set match [regexp -- a||b b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.95 {converted from line 95} { + catch {unset var} + list [catch { + set match [regexp -- ab ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + + + +# parentheses +test regexp-1.98 {converted from line 98} { + catch {unset var} + list [catch { + set match [regexp -- (a)e ae var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ae a}} + +test regexp-1.99 {converted from line 99} { + catch {unset var} + list [catch { + set match [regexp -- (a)e ae var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ae}} + +test regexp-1.100 {converted from line 100} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)\(a\)b} ab var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ab a}} + +test regexp-1.101 {converted from line 101} { + catch {unset var} + list [catch { + set match [regexp -- a((b)c) abc var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abc bc b}} + +test regexp-1.102 {converted from line 102} { + catch {unset var} + list [catch { + set match [regexp -- a(b)(c) abc var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abc b c}} + +test regexp-1.103 {converted from line 103} { + catch {unset var} + list [catch { + set match [regexp -- a(b EPAREN ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} + +test regexp-1.104 {converted from line 104} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)a\(b} EPAREN ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} + +# sigh, we blew it on the specs here... someday this will be fixed in POSIX, +# but meanwhile, it's fixed in AREs + +test regexp-1.107 {converted from line 107} { + catch {unset var} + list [catch { + set match [regexp -- (?e)a)b a)b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a)b}} + +test regexp-1.108 {converted from line 108} { + catch {unset var} + list [catch { + set match [regexp -- a)b EPAREN ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} + +test regexp-1.109 {converted from line 109} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)a\)b} EPAREN ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} + +test regexp-1.110 {converted from line 110} { + catch {unset var} + list [catch { + set match [regexp -- a(?:b)c abc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + +test regexp-1.111 {converted from line 111} { + catch {unset var} + list [catch { + set match [regexp -- (?e)a(?:b)c BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.112 {converted from line 112} { + catch {unset var} + list [catch { + set match [regexp -- a()b ab var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ab {}}} + +test regexp-1.113 {converted from line 113} { + catch {unset var} + list [catch { + set match [regexp -- a(?:)b ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.114 {converted from line 114} { + catch {unset var} + list [catch { + set match [regexp -- a(|b)c ac var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ac {}}} + +test regexp-1.115 {converted from line 115} { + catch {unset var} + list [catch { + set match [regexp -- a(b|)c abc var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc b}} + + + +# simple one-char matching (full mess of brackets done later) +test regexp-1.118 {converted from line 118} { + catch {unset var} + list [catch { + set match [regexp -- a.b axb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 axb}} + +test regexp-1.119 {converted from line 119} { + catch {unset var} + list [catch { + set match [regexp -- (?n)a.b {a +b} ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.120 {converted from line 120} { + catch {unset var} + list [catch { + set match [regexp -- {a[bc]d} abd var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abd}} + +test regexp-1.121 {converted from line 121} { + catch {unset var} + list [catch { + set match [regexp -- {a[bc]d} acd var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 acd}} + +test regexp-1.122 {converted from line 122} { + catch {unset var} + list [catch { + set match [regexp -- {a[bc]d} aed ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.123 {converted from line 123} { + catch {unset var} + list [catch { + set match [regexp -- {a[^bc]d} abd ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.124 {converted from line 124} { + catch {unset var} + list [catch { + set match [regexp -- {a[^bc]d} aed var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aed}} + +test regexp-1.125 {converted from line 125} { + catch {unset var} + list [catch { + set match [regexp -- {(?p)a[^bc]d} {a +d} ] + list $match + } msg] $msg +} {0 0} + + + +# some context-dependent syntax (and some not) +test regexp-1.128 {converted from line 128} { + catch {unset var} + list [catch { + set match [regexp -- * BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.129 {converted from line 129} { + catch {unset var} + list [catch { + set match [regexp -- (?b)* * var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 *}} + +test regexp-1.130 {converted from line 130} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)\(*\)} * var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 * *}} + +test regexp-1.131 {converted from line 131} { + catch {unset var} + list [catch { + set match [regexp -- (*) BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.132 {converted from line 132} { + catch {unset var} + list [catch { + set match [regexp -- (?b)^* * var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 *}} + +test regexp-1.133 {converted from line 133} { + catch {unset var} + list [catch { + set match [regexp -- ^* BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.134 {converted from line 134} { + catch {unset var} + list [catch { + set match [regexp -- ^b ^b ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.135 {converted from line 135} { + catch {unset var} + list [catch { + set match [regexp -- (?b)x^ x^ var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 x^}} + +test regexp-1.136 {converted from line 136} { + catch {unset var} + list [catch { + set match [regexp -- x^ IMPOSS ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: can never match}} + +test regexp-1.137 {converted from line 137} { + catch {unset var} + list [catch { + set match [regexp -- {(?n) +^} {x +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 { +}}} + +test regexp-1.138 {converted from line 138} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)\(^b\)} ^b ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.139 {converted from line 139} { + catch {unset var} + list [catch { + set match [regexp -- (^b) b var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 b b}} + +test regexp-1.140 {converted from line 140} { + catch {unset var} + list [catch { + set match [regexp -- {x$} x var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 x}} + +test regexp-1.141 {converted from line 141} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)\(x$\)} x var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 x x}} + +test regexp-1.142 {converted from line 142} { + catch {unset var} + list [catch { + set match [regexp -- {(x$)} x var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 x x}} + +test regexp-1.143 {converted from line 143} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)x$y} {x$y} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {x$y}}} + +test regexp-1.144 {converted from line 144} { + catch {unset var} + list [catch { + set match [regexp -- {x$y} IMPOSS ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: can never match}} + +test regexp-1.145 {converted from line 145} { + catch {unset var} + list [catch { + set match [regexp -- {(?n)x$ +} {x +} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {x +}}} + +test regexp-1.146 {converted from line 146} { + catch {unset var} + list [catch { + set match [regexp -- + BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.147 {converted from line 147} { + catch {unset var} + list [catch { + set match [regexp -- ? BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + + + +# simple quantifiers +test regexp-1.150 {converted from line 150} { + catch {unset var} + list [catch { + set match [regexp -- a* aa var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aa}} + +test regexp-1.151 {converted from line 151} { + catch {unset var} + list [catch { + set match [regexp -- a* b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.152 {converted from line 152} { + catch {unset var} + list [catch { + set match [regexp -- a+ aa var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aa}} + +test regexp-1.153 {converted from line 153} { + catch {unset var} + list [catch { + set match [regexp -- a?b ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.154 {converted from line 154} { + catch {unset var} + list [catch { + set match [regexp -- a?b b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.155 {converted from line 155} { + catch {unset var} + list [catch { + set match [regexp -- ** BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.156 {converted from line 156} { + catch {unset var} + list [catch { + set match [regexp -- (?b)** *** var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ***}} + +test regexp-1.157 {converted from line 157} { + catch {unset var} + list [catch { + set match [regexp -- a** BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.158 {converted from line 158} { + catch {unset var} + list [catch { + set match [regexp -- a**b BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.159 {converted from line 159} { + catch {unset var} + list [catch { + set match [regexp -- *** BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.160 {converted from line 160} { + catch {unset var} + list [catch { + set match [regexp -- a++ BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.161 {converted from line 161} { + catch {unset var} + list [catch { + set match [regexp -- a?+ BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.162 {converted from line 162} { + catch {unset var} + list [catch { + set match [regexp -- a?* BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.163 {converted from line 163} { + catch {unset var} + list [catch { + set match [regexp -- a+* BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.164 {converted from line 164} { + catch {unset var} + list [catch { + set match [regexp -- a*+ BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + + + +# braces are messy +test regexp-1.167 {converted from line 167} { + catch {unset var} + list [catch { + set match [regexp -- a{0,1} {} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.168 {converted from line 168} { + catch {unset var} + list [catch { + set match [regexp -- a{0,1} ac var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.169 {converted from line 169} { + catch {unset var} + list [catch { + set match [regexp -- a{1,0} BADBR ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid repetition count(s)}} + +test regexp-1.170 {converted from line 170} { + catch {unset var} + list [catch { + set match [regexp -- a{1,2,3} BADBR ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid repetition count(s)}} + +test regexp-1.171 {converted from line 171} { + catch {unset var} + list [catch { + set match [regexp -- a{257} BADBR ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid repetition count(s)}} + +test regexp-1.172 {converted from line 172} { + catch {unset var} + list [catch { + set match [regexp -- a{1000} BADBR ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid repetition count(s)}} + +test regexp-1.173 {converted from line 173} { + catch {unset var} + list [catch { + set match [regexp -- a\{1 EBRACE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched {}}} + +test regexp-1.174 {converted from line 174} { + catch {unset var} + list [catch { + set match [regexp -- a{1n} BADBR ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid repetition count(s)}} + +test regexp-1.175 {converted from line 175} { + catch {unset var} + list [catch { + set match [regexp -- a\{b a\{b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a\{b}} + +test regexp-1.176 {converted from line 176} { + catch {unset var} + list [catch { + set match [regexp -- a\{ a\{ var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a\{}} + +test regexp-1.177 {converted from line 177} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)a\{0,1\}b} cb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.178 {converted from line 178} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)a\{0,1} EBRACE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched {}}} + +test regexp-1.179 {converted from line 179} { + catch {unset var} + list [catch { + set match [regexp -- a\{0,1\\ BADBR ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid repetition count(s)}} + +test regexp-1.180 {converted from line 180} { + catch {unset var} + list [catch { + set match [regexp -- a{0}b ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.181 {converted from line 181} { + catch {unset var} + list [catch { + set match [regexp -- a{0,0}b ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.182 {converted from line 182} { + catch {unset var} + list [catch { + set match [regexp -- a{0,1}b ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.183 {converted from line 183} { + catch {unset var} + list [catch { + set match [regexp -- a{0,2}b b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.184 {converted from line 184} { + catch {unset var} + list [catch { + set match [regexp -- a{0,2}b aab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aab}} + +test regexp-1.185 {converted from line 185} { + catch {unset var} + list [catch { + set match [regexp -- a{0,}b aab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aab}} + +test regexp-1.186 {converted from line 186} { + catch {unset var} + list [catch { + set match [regexp -- a{1,1}b aab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.187 {converted from line 187} { + catch {unset var} + list [catch { + set match [regexp -- a{1,3}b aaaab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aaab}} + +test regexp-1.188 {converted from line 188} { + catch {unset var} + list [catch { + set match [regexp -- a{1,3}b b ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.189 {converted from line 189} { + catch {unset var} + list [catch { + set match [regexp -- a{1,}b aab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aab}} + +test regexp-1.190 {converted from line 190} { + catch {unset var} + list [catch { + set match [regexp -- a{2,3}b ab ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.191 {converted from line 191} { + catch {unset var} + list [catch { + set match [regexp -- a{2,3}b aaaab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aaab}} + +test regexp-1.192 {converted from line 192} { + catch {unset var} + list [catch { + set match [regexp -- a{2,}b ab ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.193 {converted from line 193} { + catch {unset var} + list [catch { + set match [regexp -- a{2,}b aaaab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aaaab}} + + + +# brackets are too +test regexp-1.196 {converted from line 196} { + catch {unset var} + list [catch { + set match [regexp -- {a[bc]} ac var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ac}} + +test regexp-1.197 {converted from line 197} { + catch {unset var} + list [catch { + set match [regexp -- {a[-]} a- var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a-}} + +test regexp-1.198 {converted from line 198} { + catch {unset var} + list [catch { + set match [regexp -- {a[[.-.]]} a- var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a-}} + +test regexp-1.199 {converted from line 199} { + catch {unset var} + list [catch { + set match [regexp -- {a[[.zero.]]} a0 var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a0}} + +test regexp-1.200 {converted from line 200} { + catch {unset var} + list [catch { + set match [regexp -- {a[[.zero.]-9]} a2 var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a2}} + +test regexp-1.201 {converted from line 201} { + catch {unset var} + list [catch { + set match [regexp -- {a[0-[.9.]]} a2 var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a2}} + +# skipping char mapping test from line 202 +print {... skip test from line 202: a&&=x=&& &+L ax ax} +# skipping char mapping test from line 203 +print {... skip test from line 203: a&&=x=&& &+L ay ay} +# skipping char mapping test from line 204 +print {... skip test from line 204: a&&=x=&& &+L az} +test regexp-1.205 {converted from line 205} { + catch {unset var} + list [catch { + set match [regexp -- {a[0-[=x=]]} ERANGE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid character range}} + +test regexp-1.206 {converted from line 206} { + catch {unset var} + list [catch { + set match [regexp -- {a[[:digit:]]} a0 var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a0}} + +test regexp-1.207 {converted from line 207} { + catch {unset var} + list [catch { + set match [regexp -- {a[[:woopsie:]]} ECTYPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid character class}} + +test regexp-1.208 {converted from line 208} { + catch {unset var} + list [catch { + set match [regexp -- {a[[:digit:]]} ab ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.209 {converted from line 209} { + catch {unset var} + list [catch { + set match [regexp -- {a[0-[:digit:]]} ERANGE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid character range}} + +test regexp-1.210 {converted from line 210} { + catch {unset var} + list [catch { + set match [regexp -- {[[:<:]]a} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.211 {converted from line 211} { + catch {unset var} + list [catch { + set match [regexp -- {a[[:>:]]} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.212 {converted from line 212} { + catch {unset var} + list [catch { + set match [regexp -- {a[[..]]b} ECOLLATE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid collating element}} + +test regexp-1.213 {converted from line 213} { + catch {unset var} + list [catch { + set match [regexp -- {a[[==]]b} ECOLLATE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid collating element}} + +test regexp-1.214 {converted from line 214} { + catch {unset var} + list [catch { + set match [regexp -- {a[[::]]b} ECTYPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid character class}} + +test regexp-1.215 {converted from line 215} { + catch {unset var} + list [catch { + set match [regexp -- {a[[.a} EBRACK ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched []}} + +test regexp-1.216 {converted from line 216} { + catch {unset var} + list [catch { + set match [regexp -- {a[[=a} EBRACK ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched []}} + +test regexp-1.217 {converted from line 217} { + catch {unset var} + list [catch { + set match [regexp -- {a[[:a} EBRACK ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched []}} + +test regexp-1.218 {converted from line 218} { + catch {unset var} + list [catch { + set match [regexp -- {a[} EBRACK ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched []}} + +test regexp-1.219 {converted from line 219} { + catch {unset var} + list [catch { + set match [regexp -- {a[b} EBRACK ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched []}} + +test regexp-1.220 {converted from line 220} { + catch {unset var} + list [catch { + set match [regexp -- {a[b-} EBRACK ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched []}} + +test regexp-1.221 {converted from line 221} { + catch {unset var} + list [catch { + set match [regexp -- {a[b-c} EBRACK ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched []}} + +test regexp-1.222 {converted from line 222} { + catch {unset var} + list [catch { + set match [regexp -- {a[b-c]} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.223 {converted from line 223} { + catch {unset var} + list [catch { + set match [regexp -- {a[b-b]} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.224 {converted from line 224} { + catch {unset var} + list [catch { + set match [regexp -- {a[1-2]} a2 var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a2}} + +test regexp-1.225 {converted from line 225} { + catch {unset var} + list [catch { + set match [regexp -- {a[c-b]} ERANGE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid character range}} + +test regexp-1.226 {converted from line 226} { + catch {unset var} + list [catch { + set match [regexp -- {a[a-b-c]} ERANGE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid character range}} + +test regexp-1.227 {converted from line 227} { + catch {unset var} + list [catch { + set match [regexp -- {a[--?]b} a?b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a?b}} + +test regexp-1.228 {converted from line 228} { + catch {unset var} + list [catch { + set match [regexp -- {a[---]b} a-b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a-b}} + +test regexp-1.229 {converted from line 229} { + catch {unset var} + list [catch { + set match [regexp -- {a[]b]c} a\]c var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a\]c}} + +test regexp-1.230 {converted from line 230} { + catch {unset var} + list [catch { + set match [regexp -- {a[\]]b} a\]b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a\]b}} + +test regexp-1.231 {converted from line 231} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)a[\]]b} a\]b ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.232 {converted from line 232} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)a[\]]b} {a\]b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a\]b}}} + +test regexp-1.233 {converted from line 233} { + catch {unset var} + list [catch { + set match [regexp -- {(?e)a[\]]b} {a\]b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a\]b}}} + +test regexp-1.234 {converted from line 234} { + catch {unset var} + list [catch { + set match [regexp -- {a[\\]b} {a\b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a\b}}} + +test regexp-1.235 {converted from line 235} { + catch {unset var} + list [catch { + set match [regexp -- {(?e)a[\\]b} {a\b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a\b}}} + +test regexp-1.236 {converted from line 236} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)a[\\]b} {a\b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a\b}}} + +test regexp-1.237 {converted from line 237} { + catch {unset var} + list [catch { + set match [regexp -- {a[\Z]b} EESCAPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid escape sequence}} + +test regexp-1.238 {converted from line 238} { + catch {unset var} + list [catch { + set match [regexp -- {a[[b]c} {a[c} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a[c}}} + + + +# anchors and newlines +test regexp-1.241 {converted from line 241} { + catch {unset var} + list [catch { + set match [regexp -- ^a a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +# skipping char mapping test from line 242 +print {... skip test from line 242: ^a &^ a} +test regexp-1.243 {converted from line 243} { + catch {unset var} + list [catch { + set match [regexp -- ^ a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.244 {converted from line 244} { + catch {unset var} + list [catch { + set match [regexp -- {a$} aba var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +# skipping char mapping test from line 245 +print {... skip test from line 245: a$ &$ a} +test regexp-1.246 {converted from line 246} { + catch {unset var} + list [catch { + set match [regexp -- {$} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.247 {converted from line 247} { + catch {unset var} + list [catch { + set match [regexp -- (?n)^a a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.248 {converted from line 248} { + catch {unset var} + list [catch { + set match [regexp -- (?n)^a {b +a} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.249 {converted from line 249} { + catch {unset var} + list [catch { + set match [regexp -- (?w)^a {a +a} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +# skipping char mapping test from line 250 +print {... skip test from line 250: ^a &=n^ aNa a@2} +test regexp-1.251 {converted from line 251} { + catch {unset var} + list [catch { + set match [regexp -- {(?n)a$} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.252 {converted from line 252} { + catch {unset var} + list [catch { + set match [regexp -- {(?n)a$} {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.253 {converted from line 253} { + catch {unset var} + list [catch { + set match [regexp -- {(?n)a$} {a +a} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.254 {converted from line 254} { + catch {unset var} + list [catch { + set match [regexp -- ^^ a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.255 {converted from line 255} { + catch {unset var} + list [catch { + set match [regexp -- (?b)^^ ^ var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ^}} + +test regexp-1.256 {converted from line 256} { + catch {unset var} + list [catch { + set match [regexp -- {$$} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.257 {converted from line 257} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)$$} {$} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {$}}} + +test regexp-1.258 {converted from line 258} { + catch {unset var} + list [catch { + set match [regexp -- {^$} {} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.259 {converted from line 259} { + catch {unset var} + list [catch { + set match [regexp -- {^$} a ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.260 {converted from line 260} { + catch {unset var} + list [catch { + set match [regexp -- {(?n)^$} {a + +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.261 {converted from line 261} { + catch {unset var} + list [catch { + set match [regexp -- {$^} {} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.262 {converted from line 262} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)$^} {$^} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {$^}}} + +test regexp-1.263 {converted from line 263} { + catch {unset var} + list [catch { + set match [regexp -- {\Aa} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +# skipping char mapping test from line 264 +print {... skip test from line 264: \\Aa ^P a a} +# skipping char mapping test from line 265 +print {... skip test from line 265: \\Aa ^nP> bNa} +test regexp-1.266 {converted from line 266} { + catch {unset var} + list [catch { + set match [regexp -- {a\Z} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +# skipping char mapping test from line 267 +print {... skip test from line 267: a\\Z $P a a} +# skipping char mapping test from line 268 +print {... skip test from line 268: a\\Z $nP> aNb} +test regexp-1.269 {converted from line 269} { + catch {unset var} + list [catch { + set match [regexp -- ^* BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.270 {converted from line 270} { + catch {unset var} + list [catch { + set match [regexp -- {$*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.271 {converted from line 271} { + catch {unset var} + list [catch { + set match [regexp -- {\A*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.272 {converted from line 272} { + catch {unset var} + list [catch { + set match [regexp -- {\Z*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + + + +# boundary constraints +test regexp-1.275 {converted from line 275} { + catch {unset var} + list [catch { + set match [regexp -- {[[:<:]]a} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.276 {converted from line 276} { + catch {unset var} + list [catch { + set match [regexp -- {[[:<:]]a} -a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.277 {converted from line 277} { + catch {unset var} + list [catch { + set match [regexp -- {[[:<:]]a} ba ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.278 {converted from line 278} { + catch {unset var} + list [catch { + set match [regexp -- {a[[:>:]]} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.279 {converted from line 279} { + catch {unset var} + list [catch { + set match [regexp -- {a[[:>:]]} a- var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.280 {converted from line 280} { + catch {unset var} + list [catch { + set match [regexp -- {a[[:>:]]} ab ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.281 {converted from line 281} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)\<a} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.282 {converted from line 282} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)\<a} ba ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.283 {converted from line 283} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)a\>} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.284 {converted from line 284} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)a\>} ab ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.285 {converted from line 285} { + catch {unset var} + list [catch { + set match [regexp -- {\ya} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.286 {converted from line 286} { + catch {unset var} + list [catch { + set match [regexp -- {\ya} ba ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.287 {converted from line 287} { + catch {unset var} + list [catch { + set match [regexp -- {a\y} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.288 {converted from line 288} { + catch {unset var} + list [catch { + set match [regexp -- {a\y} ab ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.289 {converted from line 289} { + catch {unset var} + list [catch { + set match [regexp -- {a\Y} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.290 {converted from line 290} { + catch {unset var} + list [catch { + set match [regexp -- {a\Y} a- ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.291 {converted from line 291} { + catch {unset var} + list [catch { + set match [regexp -- {a\Y} a ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.292 {converted from line 292} { + catch {unset var} + list [catch { + set match [regexp -- {-\Y} -a ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.293 {converted from line 293} { + catch {unset var} + list [catch { + set match [regexp -- {-\Y} -% var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 -}} + +test regexp-1.294 {converted from line 294} { + catch {unset var} + list [catch { + set match [regexp -- {\Y-} a- ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.295 {converted from line 295} { + catch {unset var} + list [catch { + set match [regexp -- {[[:<:]]*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.296 {converted from line 296} { + catch {unset var} + list [catch { + set match [regexp -- {[[:>:]]*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.297 {converted from line 297} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)\<*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.298 {converted from line 298} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)\>*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.299 {converted from line 299} { + catch {unset var} + list [catch { + set match [regexp -- {\y*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.300 {converted from line 300} { + catch {unset var} + list [catch { + set match [regexp -- {\Y*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + + + +# character classes +test regexp-1.303 {converted from line 303} { + catch {unset var} + list [catch { + set match [regexp -- {a\db} a0b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a0b}} + +test regexp-1.304 {converted from line 304} { + catch {unset var} + list [catch { + set match [regexp -- {a\db} axb ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.305 {converted from line 305} { + catch {unset var} + list [catch { + set match [regexp -- {a\Db} a0b ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.306 {converted from line 306} { + catch {unset var} + list [catch { + set match [regexp -- {a\Db} axb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 axb}} + +test regexp-1.307 {converted from line 307} { + catch {unset var} + list [catch { + set match [regexp -- {a\sb} {a b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a b}}} + +test regexp-1.308 {converted from line 308} { + catch {unset var} + list [catch { + set match [regexp -- {a\sb} {a b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a b}}} + +test regexp-1.309 {converted from line 309} { + catch {unset var} + list [catch { + set match [regexp -- {a\sb} {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a +b}}} + +test regexp-1.310 {converted from line 310} { + catch {unset var} + list [catch { + set match [regexp -- {a\sb} axb ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.311 {converted from line 311} { + catch {unset var} + list [catch { + set match [regexp -- {a\Sb} axb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 axb}} + +test regexp-1.312 {converted from line 312} { + catch {unset var} + list [catch { + set match [regexp -- {a\Sb} {a b} ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.313 {converted from line 313} { + catch {unset var} + list [catch { + set match [regexp -- {a\wb} axb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 axb}} + +test regexp-1.314 {converted from line 314} { + catch {unset var} + list [catch { + set match [regexp -- {a\wb} a-b ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.315 {converted from line 315} { + catch {unset var} + list [catch { + set match [regexp -- {a\Wb} axb ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.316 {converted from line 316} { + catch {unset var} + list [catch { + set match [regexp -- {a\Wb} a-b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a-b}} + +test regexp-1.317 {converted from line 317} { + catch {unset var} + list [catch { + set match [regexp -- {\y\w+z\y} adze-guz var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 guz}} + +test regexp-1.318 {converted from line 318} { + catch {unset var} + list [catch { + set match [regexp -- {a[\d]b} a1b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a1b}} + +test regexp-1.319 {converted from line 319} { + catch {unset var} + list [catch { + set match [regexp -- {a[\s]b} {a b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a b}}} + +test regexp-1.320 {converted from line 320} { + catch {unset var} + list [catch { + set match [regexp -- {a[\w]b} axb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 axb}} + + + +# escapes +test regexp-1.323 {converted from line 323} { + catch {unset var} + list [catch { + set match [regexp -- a\\ EESCAPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid escape sequence}} + +test regexp-1.324 {converted from line 324} { + catch {unset var} + list [catch { + set match [regexp -- {a\<b} a<b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a<b}} + +test regexp-1.325 {converted from line 325} { + catch {unset var} + list [catch { + set match [regexp -- {(?e)a\<b} a<b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a<b}} + +test regexp-1.326 {converted from line 326} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)a\wb} awb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 awb}} + +test regexp-1.327 {converted from line 327} { + catch {unset var} + list [catch { + set match [regexp -- {(?e)a\wb} awb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 awb}} + +test regexp-1.328 {converted from line 328} { + catch {unset var} + list [catch { + set match [regexp -- {a\ab} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.329 {converted from line 329} { + catch {unset var} + list [catch { + set match [regexp -- {a\bb} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.330 {converted from line 330} { + catch {unset var} + list [catch { + set match [regexp -- {a\chb} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.331 {converted from line 331} { + catch {unset var} + list [catch { + set match [regexp -- {a\cHb} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.332 {converted from line 332} { + catch {unset var} + list [catch { + set match [regexp -- {a\e} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.333 {converted from line 333} { + catch {unset var} + list [catch { + set match [regexp -- {a\Eb} {a\b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a\b}}} + +test regexp-1.334 {converted from line 334} { + catch {unset var} + list [catch { + set match [regexp -- {a\fb} {a b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a b}}} + +test regexp-1.335 {converted from line 335} { + catch {unset var} + list [catch { + set match [regexp -- {a\nb} {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a +b}}} + +test regexp-1.336 {converted from line 336} { + catch {unset var} + list [catch { + set match [regexp -- a\rb a\u000Db var(0)] + list $match $var(0) + } msg] $msg +} [subst {0 {1 {a\u000Db}}}] + +test regexp-1.337 {converted from line 337} { + catch {unset var} + list [catch { + set match [regexp -- {a\tb} {a b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a b}}} + +test regexp-1.338 {converted from line 338} { + catch {unset var} + list [catch { + set match [regexp -- {a\u0008x} ax var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ax}} + +test regexp-1.339 {converted from line 339} { + catch {unset var} + list [catch { + set match [regexp -- {a\u008x} EESCAPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid escape sequence}} + +test regexp-1.340 {converted from line 340} { + catch {unset var} + list [catch { + set match [regexp -- {a\u00088x} a8x var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a8x}} + +test regexp-1.341 {converted from line 341} { + catch {unset var} + list [catch { + set match [regexp -- {a\U00000008x} ax var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ax}} + +test regexp-1.342 {converted from line 342} { + catch {unset var} + list [catch { + set match [regexp -- {a\U0000008x} EESCAPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid escape sequence}} + +test regexp-1.343 {converted from line 343} { + catch {unset var} + list [catch { + set match [regexp -- {a\vb} {a b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a b}}} + +test regexp-1.344 {converted from line 344} { + catch {unset var} + list [catch { + set match [regexp -- {a\x08x} ax var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ax}} + +test regexp-1.345 {converted from line 345} { + catch {unset var} + list [catch { + set match [regexp -- {a\xx} EESCAPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid escape sequence}} + +test regexp-1.346 {converted from line 346} { + catch {unset var} + list [catch { + set match [regexp -- {a\x0008x} ax var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ax}} + +test regexp-1.347 {converted from line 347} { + catch {unset var} + list [catch { + set match [regexp -- {a\z} EESCAPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid escape sequence}} + +test regexp-1.348 {converted from line 348} { + catch {unset var} + list [catch { + set match [regexp -- {a\010b} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + + + +# back references (ugh) +test regexp-1.351 {converted from line 351} { + catch {unset var} + list [catch { + set match [regexp -- {a(b*)c\1} abbcbb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbcbb bb}} + +test regexp-1.352 {converted from line 352} { + catch {unset var} + list [catch { + set match [regexp -- {a(b*)c\1} ac var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ac {}}} + +test regexp-1.353 {converted from line 353} { + catch {unset var} + list [catch { + set match [regexp -- {a(b*)c\1} abbcb ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.354 {converted from line 354} { + catch {unset var} + list [catch { + set match [regexp -- {a(b*)\1} abbcbb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abb b}} + +test regexp-1.355 {converted from line 355} { + catch {unset var} + list [catch { + set match [regexp -- {a(b|bb)\1} abbcbb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abb b}} + +test regexp-1.356 {converted from line 356} { + catch {unset var} + list [catch { + set match [regexp -- {a([bc])\1} abb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abb b}} + +test regexp-1.357 {converted from line 357} { + catch {unset var} + list [catch { + set match [regexp -- {a([bc])\1} abc ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.358 {converted from line 358} { + catch {unset var} + list [catch { + set match [regexp -- {a([bc])\1} abcabb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abb b}} + +test regexp-1.359 {converted from line 359} { + catch {unset var} + list [catch { + set match [regexp -- {a([bc])*\1} abc ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.360 {converted from line 360} { + catch {unset var} + list [catch { + set match [regexp -- {a([bc])\1} abB ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.361 {converted from line 361} { + catch {unset var} + list [catch { + set match [regexp -- {(?i)a([bc])\1} abB var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abB b}} + +test regexp-1.362 {converted from line 362} { + catch {unset var} + list [catch { + set match [regexp -- {a([bc])\1+} abbb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbb b}} + +test regexp-1.363 {converted from line 363} { + catch {unset var} + list [catch { + set match [regexp -- {a([bc])\1{3,4}} abbbb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbbb b}} + +test regexp-1.364 {converted from line 364} { + catch {unset var} + list [catch { + set match [regexp -- {a([bc])\1{3,4}} abbb ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.365 {converted from line 365} { + catch {unset var} + list [catch { + set match [regexp -- {a([bc])\1*} abbb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbb b}} + +test regexp-1.366 {converted from line 366} { + catch {unset var} + list [catch { + set match [regexp -- {a([bc])\1*} ab var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ab b}} + +test regexp-1.367 {converted from line 367} { + catch {unset var} + list [catch { + set match [regexp -- {a([bc])(\1*)} ab var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 ab b {}}} + +test regexp-1.368 {converted from line 368} { + catch {unset var} + list [catch { + set match [regexp -- {a((b)\1)} ESUBREG ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid backreference number}} + +test regexp-1.369 {converted from line 369} { + catch {unset var} + list [catch { + set match [regexp -- {a(b)c\2} ESUBREG ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid backreference number}} + +test regexp-1.370 {converted from line 370} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)a\(b*\)c\1} abbcbb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbcbb bb}} + + + +# is it an octal escape or a back reference...? +# initial zero is always octal +test regexp-1.374 {converted from line 374} { + catch {unset var} + list [catch { + set match [regexp -- {a\010b} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.375 {converted from line 375} { + catch {unset var} + list [catch { + set match [regexp -- {a\0070b} a0b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a0b}} + +test regexp-1.376 {converted from line 376} { + catch {unset var} + list [catch { + set match [regexp -- {a\07b} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.377 {converted from line 377} { + catch {unset var} + list [catch { + set match [regexp -- {a(b)(b)(b)(b)(b)(b)(b)(b)(b)(b)\07c} abbbbbbbbbbc var(0) var(1) var(2) var(3) var(4) var(5) var(6) var(7) var(8) var(9) var(10)] + list $match $var(0) $var(1) $var(2) $var(3) $var(4) $var(5) $var(6) $var(7) $var(8) $var(9) $var(10) + } msg] $msg +} {0 {1 abbbbbbbbbbc b b b b b b b b b b}} + +# a single digit is always a backref +test regexp-1.381 {converted from line 381} { + catch {unset var} + list [catch { + set match [regexp -- {a\7b} ESUBREG ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid backreference number}} + +# otherwise it's a backref only if within range (barf!) +test regexp-1.383 {converted from line 383} { + catch {unset var} + list [catch { + set match [regexp -- {a\10b} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.384 {converted from line 384} { + catch {unset var} + list [catch { + set match [regexp -- {a\101b} aAb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aAb}} + +test regexp-1.385 {converted from line 385} { + catch {unset var} + list [catch { + set match [regexp -- {a(b)(b)(b)(b)(b)(b)(b)(b)(b)(b)\10c} abbbbbbbbbbbc var(0) var(1) var(2) var(3) var(4) var(5) var(6) var(7) var(8) var(9) var(10)] + list $match $var(0) $var(1) $var(2) $var(3) $var(4) $var(5) $var(6) $var(7) $var(8) $var(9) $var(10) + } msg] $msg +} {0 {1 abbbbbbbbbbbc b b b b b b b b b b}} + +# but we're fussy about border cases -- guys who want octal should use the zero +test regexp-1.389 {converted from line 389} { + catch {unset var} + list [catch { + set match [regexp -- {a((((((((((b\10))))))))))c} ESUBREG ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid backreference number}} + +# BREs don't have octal, EREs don't have backrefs +test regexp-1.391 {converted from line 391} { + catch {unset var} + list [catch { + set match [regexp -- {a\12b} {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a +b}}} + +test regexp-1.392 {converted from line 392} { + catch {unset var} + list [catch { + set match [regexp -- {(?b)a\12b} ESUBREG ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid backreference number}} + +test regexp-1.393 {converted from line 393} { + catch {unset var} + list [catch { + set match [regexp -- {(?e)a\12b} a12b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a12b}} + + + +# expanded syntax +test regexp-1.396 {converted from line 396} { + catch {unset var} + list [catch { + set match [regexp -- {(?x)a b c} abc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + +test regexp-1.397 {converted from line 397} { + catch {unset var} + list [catch { + set match [regexp -- {(?x)a b #oops +c d} abcd var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abcd}} + +test regexp-1.398 {converted from line 398} { + catch {unset var} + list [catch { + set match [regexp -- {(?x)a\ b\ c} {a b c} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a b c}}} + +test regexp-1.399 {converted from line 399} { + catch {unset var} + list [catch { + set match [regexp -- {(?x)a b\#c} ab#c var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab#c}} + +test regexp-1.400 {converted from line 400} { + catch {unset var} + list [catch { + set match [regexp -- {(?x)a b[c d]e} {ab e} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {ab e}}} + +test regexp-1.401 {converted from line 401} { + catch {unset var} + list [catch { + set match [regexp -- {(?x)a b[c#d]e} ab#e var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab#e}} + +test regexp-1.402 {converted from line 402} { + catch {unset var} + list [catch { + set match [regexp -- {(?x)a b[c#d]e} abde var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abde}} + +test regexp-1.403 {converted from line 403} { + catch {unset var} + list [catch { + set match [regexp -- (?x)ab\{\ d ab\{d var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab\{d}} + +test regexp-1.404 {converted from line 404} { + catch {unset var} + list [catch { + set match [regexp -- {(?x)ab{ 1 , 2 }c} abc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + + + +# misc. syntax +test regexp-1.407 {converted from line 407} { + catch {unset var} + list [catch { + set match [regexp -- a(?#comment)b ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + + + +# unmatchable REs +test regexp-1.410 {converted from line 410} { + catch {unset var} + list [catch { + set match [regexp -- a^b IMPOSS ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: can never match}} + + + +# case independence +test regexp-1.413 {converted from line 413} { + catch {unset var} + list [catch { + set match [regexp -- (?i)ab Ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 Ab}} + +test regexp-1.414 {converted from line 414} { + catch {unset var} + list [catch { + set match [regexp -- {(?i)a[bc]} aC var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aC}} + +test regexp-1.415 {converted from line 415} { + catch {unset var} + list [catch { + set match [regexp -- {(?i)a[^bc]} aB ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.416 {converted from line 416} { + catch {unset var} + list [catch { + set match [regexp -- {(?i)a[b-d]} aC var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aC}} + +test regexp-1.417 {converted from line 417} { + catch {unset var} + list [catch { + set match [regexp -- {(?i)a[^b-d]} aC ] + list $match + } msg] $msg +} {0 0} + + + +# inline options +test regexp-1.420 {converted from line 420} { + catch {unset var} + list [catch { + set match [regexp -- ***? BADPAT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid regular expression}} + +# skipping test with metasyntax from line 421 + +test regexp-1.422 {converted from line 422} { + catch {unset var} + list [catch { + set match [regexp -- ***=a*b a*b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a*b}} + +# skipping test with metasyntax from line 423 + +# skipping test with metasyntax from line 424 + +# skipping test with metasyntax from line 425 + +test regexp-1.426 {converted from line 426} { + catch {unset var} + list [catch { + set match [regexp -- (?b)a+b a+b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a+b}} + +# skipping test with metasyntax from line 427 + +# skipping test with metasyntax from line 428 + +# skipping test with metasyntax from line 429 + +# skipping test with metasyntax from line 430 + +test regexp-1.431 {converted from line 431} { + catch {unset var} + list [catch { + set match [regexp -- {(?e)\W+} WW var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 WW}} + +test regexp-1.432 {converted from line 432} { + catch {unset var} + list [catch { + set match [regexp -- (?i)a+ Aa var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 Aa}} + +test regexp-1.433 {converted from line 433} { + catch {unset var} + list [catch { + set match [regexp -- (?m)a.b {a +b} ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.434 {converted from line 434} { + catch {unset var} + list [catch { + set match [regexp -- (?m)^b {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.435 {converted from line 435} { + catch {unset var} + list [catch { + set match [regexp -- (?n)a.b {a +b} ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.436 {converted from line 436} { + catch {unset var} + list [catch { + set match [regexp -- (?n)^b {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.437 {converted from line 437} { + catch {unset var} + list [catch { + set match [regexp -- (?p)a.b {a +b} ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.438 {converted from line 438} { + catch {unset var} + list [catch { + set match [regexp -- (?p)^b {a +b} ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.439 {converted from line 439} { + catch {unset var} + list [catch { + set match [regexp -- (?q)a+b a+b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a+b}} + +# skipping test with metasyntax from line 440 + +# skipping test with metasyntax from line 441 + +test regexp-1.442 {converted from line 442} { + catch {unset var} + list [catch { + set match [regexp -- (?w)a.b {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a +b}}} + +test regexp-1.443 {converted from line 443} { + catch {unset var} + list [catch { + set match [regexp -- (?w)^b {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.444 {converted from line 444} { + catch {unset var} + list [catch { + set match [regexp -- {(?x)a b} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.445 {converted from line 445} { + catch {unset var} + list [catch { + set match [regexp -- (?z)ab BADOPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid embedded option}} + + + +# capturing +test regexp-1.448 {converted from line 448} { + catch {unset var} + list [catch { + set match [regexp -- a(b)c abc var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc b}} + +test regexp-1.449 {converted from line 449} { + catch {unset var} + list [catch { + set match [regexp -- a(?:b)c xabc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + +test regexp-1.450 {converted from line 450} { + catch {unset var} + list [catch { + set match [regexp -- a((b))c xabcy var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abc b b}} + +test regexp-1.451 {converted from line 451} { + catch {unset var} + list [catch { + set match [regexp -- a(?:(b))c abcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc b}} + +test regexp-1.452 {converted from line 452} { + catch {unset var} + list [catch { + set match [regexp -- a((?:b))c abc var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc b}} + +test regexp-1.453 {converted from line 453} { + catch {unset var} + list [catch { + set match [regexp -- a(?:(?:b))c abc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + +test regexp-1.454 {converted from line 454} { + catch {unset var} + list [catch { + set match [regexp -- a(b){0}c ac var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ac}} + +test regexp-1.455 {converted from line 455} { + catch {unset var} + list [catch { + set match [regexp -- a(b)c(d)e abcde var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abcde b d}} + +test regexp-1.456 {converted from line 456} { + catch {unset var} + list [catch { + set match [regexp -- (b)c(d)e bcde var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 bcde b d}} + +test regexp-1.457 {converted from line 457} { + catch {unset var} + list [catch { + set match [regexp -- a(b)(d)e abde var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abde b d}} + +test regexp-1.458 {converted from line 458} { + catch {unset var} + list [catch { + set match [regexp -- a(b)c(d) abcd var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abcd b d}} + +test regexp-1.459 {converted from line 459} { + catch {unset var} + list [catch { + set match [regexp -- (ab)(cd) xabcdy var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abcd ab cd}} + +test regexp-1.460 {converted from line 460} { + catch {unset var} + list [catch { + set match [regexp -- a(b)?c xabcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc b}} + +test regexp-1.461 {converted from line 461} { + catch {unset var} + list [catch { + set match [regexp -- a(b)?c xacy var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ac}} + +test regexp-1.462 {converted from line 462} { + catch {unset var} + list [catch { + set match [regexp -- a(b)?c(d)?e xabcdey var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abcde b d}} + +test regexp-1.463 {converted from line 463} { + catch {unset var} + list [catch { + set match [regexp -- a(b)?c(d)?e xacdey var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 acde {} d}} + +test regexp-1.464 {converted from line 464} { + catch {unset var} + list [catch { + set match [regexp -- a(b)?c(d)?e xabcey var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abce b {}}} + +test regexp-1.465 {converted from line 465} { + catch {unset var} + list [catch { + set match [regexp -- a(b)?c(d)?e xacey var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 ace {} {}}} + +test regexp-1.466 {converted from line 466} { + catch {unset var} + list [catch { + set match [regexp -- a(b)*c xabcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc b}} + +test regexp-1.467 {converted from line 467} { + catch {unset var} + list [catch { + set match [regexp -- a(b)*c xabbbcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbbc b}} + +test regexp-1.468 {converted from line 468} { + catch {unset var} + list [catch { + set match [regexp -- a(b)*c xacy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ac {}}} + +test regexp-1.469 {converted from line 469} { + catch {unset var} + list [catch { + set match [regexp -- a(b*)c xabbbcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbbc bbb}} + +test regexp-1.470 {converted from line 470} { + catch {unset var} + list [catch { + set match [regexp -- a(b*)c xacy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ac {}}} + +test regexp-1.471 {converted from line 471} { + catch {unset var} + list [catch { + set match [regexp -- a(b)+c xacy ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.472 {converted from line 472} { + catch {unset var} + list [catch { + set match [regexp -- a(b)+c xabcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc b}} + +test regexp-1.473 {converted from line 473} { + catch {unset var} + list [catch { + set match [regexp -- a(b)+c xabbbcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbbc b}} + +test regexp-1.474 {converted from line 474} { + catch {unset var} + list [catch { + set match [regexp -- a(b+)c xabbbcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbbc bbb}} + +test regexp-1.475 {converted from line 475} { + catch {unset var} + list [catch { + set match [regexp -- a(b){2,3}c xabbbcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbbc b}} + +test regexp-1.476 {converted from line 476} { + catch {unset var} + list [catch { + set match [regexp -- a(b){2,3}c xabbcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbc b}} + +test regexp-1.477 {converted from line 477} { + catch {unset var} + list [catch { + set match [regexp -- a(b){2,3}c xabcy ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.478 {converted from line 478} { + catch {unset var} + list [catch { + set match [regexp -- {\y(\w+)\y} {-- abc-} var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc abc}} + +test regexp-1.479 {converted from line 479} { + catch {unset var} + list [catch { + set match [regexp -- a((b|c)d+)+ abacdbd var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 acdbd bd b}} + +test regexp-1.480 {converted from line 480} { + catch {unset var} + list [catch { + set match [regexp -- (.*).* abc var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc abc}} + +test regexp-1.481 {converted from line 481} { + catch {unset var} + list [catch { + set match [regexp -- (a*)* bc var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 {} {}}} + + + +# collating elements (ugh) +# skipping char mapping test from line 484 +print {... skip test from line 484: a&c&e &+L ace ace} +# skipping char mapping test from line 485 +print {... skip test from line 485: a&c&h &+* IMPOSS} +# skipping char mapping test from line 486 +print {... skip test from line 486: a&&.ch.&& &+L ach ach} +# skipping char mapping test from line 487 +print {... skip test from line 487: a&&.ch.&& &+L ace} +# skipping char mapping test from line 488 +print {... skip test from line 488: a&c&.ch.&& &+L ac ac} +# skipping char mapping test from line 489 +print {... skip test from line 489: a&c&.ch.&& &+L ace ac} +# skipping char mapping test from line 490 +print {... skip test from line 490: a&c&.ch.&& &+L ache ach} +# skipping char mapping test from line 491 +print {... skip test from line 491: a&^c&e &+L ace} +# skipping char mapping test from line 492 +print {... skip test from line 492: a&^c&e &+L abe abe} +# skipping char mapping test from line 493 +print {... skip test from line 493: a&^c&e &+L ache ache} +# skipping char mapping test from line 494 +print {... skip test from line 494: a&^&.ch.&& &+L ach} +# skipping char mapping test from line 495 +print {... skip test from line 495: a&^&.ch.&& &+L ace ac} +# skipping char mapping test from line 496 +print {... skip test from line 496: a&^&.ch.&& &+L ac ac} +# skipping char mapping test from line 497 +print {... skip test from line 497: a&^&.ch.&& &+L abe ab} +# skipping char mapping test from line 498 +print {... skip test from line 498: a&^c&.ch.&& &+L ach} +# skipping char mapping test from line 499 +print {... skip test from line 499: a&^c&.ch.&& &+L ace} +# skipping char mapping test from line 500 +print {... skip test from line 500: a&^c&.ch.&& &+L ac} +# skipping char mapping test from line 501 +print {... skip test from line 501: a&^c&.ch.&& &+L abe ab} +# skipping char mapping test from line 502 +print {... skip test from line 502: a&^b& &+L ac ac} +# skipping char mapping test from line 503 +print {... skip test from line 503: a&^b& &+L ace ac} +# skipping char mapping test from line 504 +print {... skip test from line 504: a&^b& &+L ach ach} +# skipping char mapping test from line 505 +print {... skip test from line 505: a&^b& &+L abe} + + +# lookahead +test regexp-1.508 {converted from line 508} { + catch {unset var} + list [catch { + set match [regexp -- a(?=b)b* ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.509 {converted from line 509} { + catch {unset var} + list [catch { + set match [regexp -- a(?=b)b* a ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.510 {converted from line 510} { + catch {unset var} + list [catch { + set match [regexp -- a(?!b)b* ab ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.511 {converted from line 511} { + catch {unset var} + list [catch { + set match [regexp -- a(?!b)b* a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + + + +# non-greedy quantifiers +test regexp-1.514 {converted from line 514} { + catch {unset var} + list [catch { + set match [regexp -- ab+? abb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.515 {converted from line 515} { + catch {unset var} + list [catch { + set match [regexp -- ab+?c abbc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abbc}} + +test regexp-1.516 {converted from line 516} { + catch {unset var} + list [catch { + set match [regexp -- ab*? abb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.517 {converted from line 517} { + catch {unset var} + list [catch { + set match [regexp -- ab*?c abbc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abbc}} + +test regexp-1.518 {converted from line 518} { + catch {unset var} + list [catch { + set match [regexp -- ab?? ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.519 {converted from line 519} { + catch {unset var} + list [catch { + set match [regexp -- ab??c abc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + +test regexp-1.520 {converted from line 520} { + catch {unset var} + list [catch { + set match [regexp -- ab{2,4}? abbbb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abb}} + +test regexp-1.521 {converted from line 521} { + catch {unset var} + list [catch { + set match [regexp -- ab{2,4}?c abbbbc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abbbbc}} + + + +# xxx mixed quantifiers (incl |) + + +# attempts to trick the matcher into accepting a short match +test regexp-1.526 {converted from line 526} { + catch {unset var} + list [catch { + set match [regexp -- (week|wee)(night|knights) weeknights var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 weeknights wee knights}} + +test regexp-1.527 {converted from line 527} { + catch {unset var} + list [catch { + set match [regexp -- {a(bc*).*\1} abccbccb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abccbccb b}} + +test regexp-1.528 {converted from line 528} { + catch {unset var} + list [catch { + set match [regexp -- {a(b.[bc]*)+} abcbd var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abcbd bd}} + + + +# implementation misc. +# duplicate arcs are suppressed +test regexp-1.532 {converted from line 532} { + catch {unset var} + list [catch { + set match [regexp -- a(?:b|b)c abc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + + + +# boundary busters +# color-descriptor allocation and arc allocation both change at 10 +test regexp-1.536 {converted from line 536} { + catch {unset var} + list [catch { + set match [regexp -- abcdefghijkl abcdefghijkl var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abcdefghijkl}} + +# subexpression tracking at 10 +test regexp-1.538 {converted from line 538} { + catch {unset var} + list [catch { + set match [regexp -- a(((((((((((((b)))))))))))))c abc var(0) var(1) var(2) var(3) var(4) var(5) var(6) var(7) var(8) var(9) var(10) var(11) var(12) var(13)] + list $match $var(0) $var(1) $var(2) $var(3) $var(4) $var(5) $var(6) $var(7) $var(8) $var(9) $var(10) $var(11) $var(12) $var(13) + } msg] $msg +} {0 {1 abc b b b b b b b b b b b b b}} + +# state-set handling changes slightly at unsigned size (might be 64...) +# (also stresses arc allocation) +test regexp-1.544 {converted from line 544} { + catch {unset var} + list [catch { + set match [regexp -- ab{1,100}c abbc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abbc}} + +test regexp-1.545 {converted from line 545} { + catch {unset var} + list [catch { + set match [regexp -- ab{1,100}c abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc}} + +test regexp-1.548 {converted from line 548} { + catch {unset var} + list [catch { + set match [regexp -- ab{1,100}c abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc}} + +# force small cache and bust it, several ways +test regexp-1.552 {converted from line 552} { + catch {unset var} + list [catch { + set match [regexp -- {\w+abcdefgh} xyzabcdefgh var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 xyzabcdefgh}} + +test regexp-1.553 {converted from line 553} { + catch {unset var} + list [catch { + set match [regexp -- {\w+abcdefgh} xyzabcdefgh var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 xyzabcdefgh}} + +test regexp-1.554 {converted from line 554} { + catch {unset var} + list [catch { + set match [regexp -- {\w+(abcdefgh)?} xyz var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 xyz {}}} + + + +# make color/subcolor relationship go back and forth +test regexp-1.557 {converted from line 557} { + catch {unset var} + list [catch { + set match [regexp -- {[ab][ab][ab]} aba var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aba}} + + + +# misc. +test regexp-1.560 {converted from line 560} { + catch {unset var} + list [catch { + set match [regexp -- *** BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.561 {converted from line 561} { + catch {unset var} + list [catch { + set match [regexp -- a?b* abb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abb}} + +test regexp-1.562 {converted from line 562} { + catch {unset var} + list [catch { + set match [regexp -- a?b* bb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 bb}} + diff --git a/tests/regexp3.test b/tests/regexp3.test new file mode 100644 index 0000000..31f0b11 --- /dev/null +++ b/tests/regexp3.test @@ -0,0 +1,3295 @@ +# Commands covered: testregexp +# +# This Tcl-generated file contains tests for the testregexp tcl command. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. Setting VERBOSE to +# -1 will run tests that are known to fail. +# +# Copyright (c) 1998 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: @(#) regexp3.test 1.4 98/01/22 14:47:51 + +proc print {arg} {puts $arg} + +if {[string compare test [info procs test]] == 1} { + source defs ; set VERBOSE -1 +} + +if {$VERBOSE != -1} { + proc print {arg} {} +} + +# +# The remainder of this file is Tcl tests that have been +# converted from Henry Spencer's regexp test suite. +# + +# This file is a sequence of regression tests, one per line. The first +# field is the RE, the second flags, the third a string to match the RE +# against, the fourth the expected match, and subsequent fields the +# expected substring matches. No fourth field means match not expected; +# no later fields mean no substrings expected. If the "*" flag is set +# (see below), the third field is the name of the compile error expected, +# less the leading "REG_". Any field may be written as "" to signify an +# empty string. Fourth and subsequent fields may have a suffix "@11" +# (any decimal integer) indicating the offset where the match is expected; +# fifth and subsequent fields may be "@" indicating no match is expected +# for that subexpression. + + +# The flag characters are complex and a bit eclectic. Generally speaking, +# lowercase letters are compile options, uppercase are expected re_info +# bits, and nonalphabetics are match options, controls for how the test is +# run, or debugging options. The one small surprise is that AREs are the +# default, and you must explicitly request lesser flavors of RE. The flags +# are as follows. Be warned that a number of them are specific to this +# RE implementation. It is admitted that some are not very mnemonic. +# +# - no-op (placeholder) +# = map characters in all other fields (see below) +# > map characters in later fields (see below) +# * compile error expected (third field is error type) +# / compile only, do not attempt match +# [2 expect 2 (any decimal integer) subexpressions +# + provide fake ch collating element and xy equiv class +# , turn on compile tracing (probably not useful in this file) +# ; turn on automaton tracing (probably not useful in this file) +# : turn on match tracing (probably not useful in this file) +# . force small state-set cache in matcher (to test cache replace) +# ^ beginning of string is not beginning of line +# $ end of string is not end of line +# +# & test as both BRE and ARE +# b BRE +# e ERE +# q literal string, no metacharacters at all +# +# i case-independent matching +# s no subexpression capture +# p newlines are half-magic, excluded from . and [^ only +# w newlines are half-magic, significant to ^ and $ only +# n newlines are fully magic, both effects +# x expanded RE syntax +# +# A backslash-_a_lphanumeric seen +# B ERE/ARE literal-_b_race heuristic used +# E backslash (_e_scape) seen within [] +# H looka_h_ead constraint seen +# L _l_ocale-specific construct seen +# M unportable (_m_achine-specific) construct seen +# N RE can match empty (_n_ull) string +# P non-_P_OSIX construct seen +# Q {} _q_uantifier seen +# R back _r_eference seen +# S POSIX-un_s_pecified syntax seen +# U saw original-POSIX botch: unmatched right paren in ERE (_u_gh) + + +# The character-mapping flag causes some transformations to be done +# before processing. This is mostly to get funny characters into the +# strings. Specifically: +# +# _ becomes space +# A becomes \007 (some compilers lack \a) +# B becomes \b +# E becomes \033 +# F becomes \f +# N becomes \n +# R becomes \r +# T becomes \t +# V becomes \v + + +# The two areas we can't easily test are memory-allocation failures (which +# are hard to provoke on command) and embedded NULs (which the current test +# program can't easily do; that should be fixed). + + + + + + +# basic sanity checks +test regexp-1.81 {converted from line 81} { + catch {unset var} + list [catch { + set match [testregexp & abc abc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + +test regexp-1.82 {converted from line 82} { + catch {unset var} + list [catch { + set match [testregexp & abc def ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.83 {converted from line 83} { + catch {unset var} + list [catch { + set match [testregexp & abc xyabxabce var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + + + +# invalid option combinations +test regexp-1.86 {converted from line 86} { + catch {unset var} + list [catch { + set match [testregexp qe a INVARG ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid argument to regex routine}} + +test regexp-1.87 {converted from line 87} { + catch {unset var} + list [catch { + set match [testregexp ba a INVARG ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid argument to regex routine}} + + + +# basic syntax +# skipping the empty-re test from line 90 + +test regexp-1.91 {converted from line 91} { + catch {unset var} + list [catch { + set match [testregexp {} a| a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.92 {converted from line 92} { + catch {unset var} + list [catch { + set match [testregexp - a|b a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.93 {converted from line 93} { + catch {unset var} + list [catch { + set match [testregexp - a|b b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.94 {converted from line 94} { + catch {unset var} + list [catch { + set match [testregexp {} a||b b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.95 {converted from line 95} { + catch {unset var} + list [catch { + set match [testregexp & ab ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + + + +# parentheses +test regexp-1.98 {converted from line 98} { + catch {unset var} + list [catch { + set match [testregexp {} (a)e ae var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ae a}} + +test regexp-1.99 {converted from line 99} { + catch {unset var} + list [catch { + set match [testregexp s (a)e ae ] + list $match + } msg] $msg +} {0 1} + +test regexp-1.100 {converted from line 100} { + catch {unset var} + list [catch { + set match [testregexp b {\(a\)b} ab var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ab a}} + +test regexp-1.101 {converted from line 101} { + catch {unset var} + list [catch { + set match [testregexp {} a((b)c) abc var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abc bc b}} + +test regexp-1.102 {converted from line 102} { + catch {unset var} + list [catch { + set match [testregexp {} a(b)(c) abc var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abc b c}} + +test regexp-1.103 {converted from line 103} { + catch {unset var} + list [catch { + set match [testregexp {} a(b EPAREN ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} + +test regexp-1.104 {converted from line 104} { + catch {unset var} + list [catch { + set match [testregexp b {a\(b} EPAREN ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} + +# sigh, we blew it on the specs here... someday this will be fixed in POSIX, +# but meanwhile, it's fixed in AREs + +test regexp-1.107 {converted from line 107} { + catch {unset var} + list [catch { + set match [testregexp e a)b a)b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a)b}} + +test regexp-1.108 {converted from line 108} { + catch {unset var} + list [catch { + set match [testregexp {} a)b EPAREN ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} + +test regexp-1.109 {converted from line 109} { + catch {unset var} + list [catch { + set match [testregexp b {a\)b} EPAREN ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} + +test regexp-1.110 {converted from line 110} { + catch {unset var} + list [catch { + set match [testregexp {} a(?:b)c abc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + +test regexp-1.111 {converted from line 111} { + catch {unset var} + list [catch { + set match [testregexp e a(?:b)c BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.112 {converted from line 112} { + catch {unset var} + list [catch { + set match [testregexp {} a()b ab var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ab {}}} + +test regexp-1.113 {converted from line 113} { + catch {unset var} + list [catch { + set match [testregexp {} a(?:)b ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.114 {converted from line 114} { + catch {unset var} + list [catch { + set match [testregexp {} a(|b)c ac var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ac {}}} + +test regexp-1.115 {converted from line 115} { + catch {unset var} + list [catch { + set match [testregexp {} a(b|)c abc var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc b}} + + + +# simple one-char matching (full mess of brackets done later) +test regexp-1.118 {converted from line 118} { + catch {unset var} + list [catch { + set match [testregexp & a.b axb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 axb}} + +test regexp-1.119 {converted from line 119} { + catch {unset var} + list [catch { + set match [testregexp &=n a.b {a +b} ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.120 {converted from line 120} { + catch {unset var} + list [catch { + set match [testregexp & {a[bc]d} abd var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abd}} + +test regexp-1.121 {converted from line 121} { + catch {unset var} + list [catch { + set match [testregexp & {a[bc]d} acd var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 acd}} + +test regexp-1.122 {converted from line 122} { + catch {unset var} + list [catch { + set match [testregexp & {a[bc]d} aed ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.123 {converted from line 123} { + catch {unset var} + list [catch { + set match [testregexp & {a[^bc]d} abd ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.124 {converted from line 124} { + catch {unset var} + list [catch { + set match [testregexp & {a[^bc]d} aed var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aed}} + +test regexp-1.125 {converted from line 125} { + catch {unset var} + list [catch { + set match [testregexp &=p {a[^bc]d} {a +d} ] + list $match + } msg] $msg +} {0 0} + + + +# some context-dependent syntax (and some not) +test regexp-1.128 {converted from line 128} { + catch {unset var} + list [catch { + set match [testregexp {} * BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.129 {converted from line 129} { + catch {unset var} + list [catch { + set match [testregexp b * * var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 *}} + +test regexp-1.130 {converted from line 130} { + catch {unset var} + list [catch { + set match [testregexp b {\(*\)} * var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 * *}} + +test regexp-1.131 {converted from line 131} { + catch {unset var} + list [catch { + set match [testregexp {} (*) BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.132 {converted from line 132} { + catch {unset var} + list [catch { + set match [testregexp b ^* * var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 *}} + +test regexp-1.133 {converted from line 133} { + catch {unset var} + list [catch { + set match [testregexp {} ^* BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.134 {converted from line 134} { + catch {unset var} + list [catch { + set match [testregexp & ^b ^b ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.135 {converted from line 135} { + catch {unset var} + list [catch { + set match [testregexp b x^ x^ var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 x^}} + +test regexp-1.136 {converted from line 136} { + catch {unset var} + list [catch { + set match [testregexp {} x^ IMPOSS ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: can never match}} + +test regexp-1.137 {converted from line 137} { + catch {unset var} + list [catch { + set match [testregexp n= { +^} {x +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 { +}}} + +test regexp-1.138 {converted from line 138} { + catch {unset var} + list [catch { + set match [testregexp b {\(^b\)} ^b ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.139 {converted from line 139} { + catch {unset var} + list [catch { + set match [testregexp - (^b) b var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 b b}} + +test regexp-1.140 {converted from line 140} { + catch {unset var} + list [catch { + set match [testregexp & {x$} x var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 x}} + +test regexp-1.141 {converted from line 141} { + catch {unset var} + list [catch { + set match [testregexp b {\(x$\)} x var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 x x}} + +test regexp-1.142 {converted from line 142} { + catch {unset var} + list [catch { + set match [testregexp - {(x$)} x var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 x x}} + +test regexp-1.143 {converted from line 143} { + catch {unset var} + list [catch { + set match [testregexp b {x$y} {x$y} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {x$y}}} + +test regexp-1.144 {converted from line 144} { + catch {unset var} + list [catch { + set match [testregexp {} {x$y} IMPOSS ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: can never match}} + +test regexp-1.145 {converted from line 145} { + catch {unset var} + list [catch { + set match [testregexp n= {x$ +} {x +} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {x +}}} + +test regexp-1.146 {converted from line 146} { + catch {unset var} + list [catch { + set match [testregexp {} + BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.147 {converted from line 147} { + catch {unset var} + list [catch { + set match [testregexp {} ? BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + + + +# simple quantifiers +test regexp-1.150 {converted from line 150} { + catch {unset var} + list [catch { + set match [testregexp & a* aa var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aa}} + +test regexp-1.151 {converted from line 151} { + catch {unset var} + list [catch { + set match [testregexp & a* b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.152 {converted from line 152} { + catch {unset var} + list [catch { + set match [testregexp - a+ aa var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aa}} + +test regexp-1.153 {converted from line 153} { + catch {unset var} + list [catch { + set match [testregexp - a?b ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.154 {converted from line 154} { + catch {unset var} + list [catch { + set match [testregexp - a?b b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.155 {converted from line 155} { + catch {unset var} + list [catch { + set match [testregexp {} ** BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.156 {converted from line 156} { + catch {unset var} + list [catch { + set match [testregexp b ** *** var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ***}} + +test regexp-1.157 {converted from line 157} { + catch {unset var} + list [catch { + set match [testregexp & a** BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.158 {converted from line 158} { + catch {unset var} + list [catch { + set match [testregexp & a**b BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.159 {converted from line 159} { + catch {unset var} + list [catch { + set match [testregexp & *** BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.160 {converted from line 160} { + catch {unset var} + list [catch { + set match [testregexp - a++ BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.161 {converted from line 161} { + catch {unset var} + list [catch { + set match [testregexp - a?+ BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.162 {converted from line 162} { + catch {unset var} + list [catch { + set match [testregexp - a?* BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.163 {converted from line 163} { + catch {unset var} + list [catch { + set match [testregexp - a+* BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.164 {converted from line 164} { + catch {unset var} + list [catch { + set match [testregexp - a*+ BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + + + +# braces are messy +test regexp-1.167 {converted from line 167} { + catch {unset var} + list [catch { + set match [testregexp {} a{0,1} {} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.168 {converted from line 168} { + catch {unset var} + list [catch { + set match [testregexp {} a{0,1} ac var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.169 {converted from line 169} { + catch {unset var} + list [catch { + set match [testregexp {} a{1,0} BADBR ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid repetition count(s)}} + +test regexp-1.170 {converted from line 170} { + catch {unset var} + list [catch { + set match [testregexp {} a{1,2,3} BADBR ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid repetition count(s)}} + +test regexp-1.171 {converted from line 171} { + catch {unset var} + list [catch { + set match [testregexp {} a{257} BADBR ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid repetition count(s)}} + +test regexp-1.172 {converted from line 172} { + catch {unset var} + list [catch { + set match [testregexp {} a{1000} BADBR ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid repetition count(s)}} + +test regexp-1.173 {converted from line 173} { + catch {unset var} + list [catch { + set match [testregexp {} a\{1 EBRACE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched {}}} + +test regexp-1.174 {converted from line 174} { + catch {unset var} + list [catch { + set match [testregexp {} a{1n} BADBR ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid repetition count(s)}} + +test regexp-1.175 {converted from line 175} { + catch {unset var} + list [catch { + set match [testregexp {} a\{b a\{b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a\{b}} + +test regexp-1.176 {converted from line 176} { + catch {unset var} + list [catch { + set match [testregexp {} a\{ a\{ var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a\{}} + +test regexp-1.177 {converted from line 177} { + catch {unset var} + list [catch { + set match [testregexp b {a\{0,1\}b} cb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.178 {converted from line 178} { + catch {unset var} + list [catch { + set match [testregexp b {a\{0,1} EBRACE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched {}}} + +test regexp-1.179 {converted from line 179} { + catch {unset var} + list [catch { + set match [testregexp {} a\{0,1\\ BADBR ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid repetition count(s)}} + +test regexp-1.180 {converted from line 180} { + catch {unset var} + list [catch { + set match [testregexp {} a{0}b ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.181 {converted from line 181} { + catch {unset var} + list [catch { + set match [testregexp {} a{0,0}b ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.182 {converted from line 182} { + catch {unset var} + list [catch { + set match [testregexp {} a{0,1}b ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.183 {converted from line 183} { + catch {unset var} + list [catch { + set match [testregexp {} a{0,2}b b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.184 {converted from line 184} { + catch {unset var} + list [catch { + set match [testregexp {} a{0,2}b aab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aab}} + +test regexp-1.185 {converted from line 185} { + catch {unset var} + list [catch { + set match [testregexp {} a{0,}b aab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aab}} + +test regexp-1.186 {converted from line 186} { + catch {unset var} + list [catch { + set match [testregexp {} a{1,1}b aab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.187 {converted from line 187} { + catch {unset var} + list [catch { + set match [testregexp {} a{1,3}b aaaab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aaab}} + +test regexp-1.188 {converted from line 188} { + catch {unset var} + list [catch { + set match [testregexp {} a{1,3}b b ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.189 {converted from line 189} { + catch {unset var} + list [catch { + set match [testregexp {} a{1,}b aab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aab}} + +test regexp-1.190 {converted from line 190} { + catch {unset var} + list [catch { + set match [testregexp {} a{2,3}b ab ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.191 {converted from line 191} { + catch {unset var} + list [catch { + set match [testregexp {} a{2,3}b aaaab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aaab}} + +test regexp-1.192 {converted from line 192} { + catch {unset var} + list [catch { + set match [testregexp {} a{2,}b ab ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.193 {converted from line 193} { + catch {unset var} + list [catch { + set match [testregexp {} a{2,}b aaaab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aaaab}} + + + +# brackets are too +test regexp-1.196 {converted from line 196} { + catch {unset var} + list [catch { + set match [testregexp & {a[bc]} ac var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ac}} + +test regexp-1.197 {converted from line 197} { + catch {unset var} + list [catch { + set match [testregexp & {a[-]} a- var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a-}} + +test regexp-1.198 {converted from line 198} { + catch {unset var} + list [catch { + set match [testregexp & {a[[.-.]]} a- var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a-}} + +test regexp-1.199 {converted from line 199} { + catch {unset var} + list [catch { + set match [testregexp & {a[[.zero.]]} a0 var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a0}} + +test regexp-1.200 {converted from line 200} { + catch {unset var} + list [catch { + set match [testregexp & {a[[.zero.]-9]} a2 var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a2}} + +test regexp-1.201 {converted from line 201} { + catch {unset var} + list [catch { + set match [testregexp & {a[0-[.9.]]} a2 var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a2}} + +# skipping char mapping test from line 202 +print {... skip test from line 202: a&&=x=&& &+L ax ax} +# skipping char mapping test from line 203 +print {... skip test from line 203: a&&=x=&& &+L ay ay} +# skipping char mapping test from line 204 +print {... skip test from line 204: a&&=x=&& &+L az} +test regexp-1.205 {converted from line 205} { + catch {unset var} + list [catch { + set match [testregexp & {a[0-[=x=]]} ERANGE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid character range}} + +test regexp-1.206 {converted from line 206} { + catch {unset var} + list [catch { + set match [testregexp & {a[[:digit:]]} a0 var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a0}} + +test regexp-1.207 {converted from line 207} { + catch {unset var} + list [catch { + set match [testregexp & {a[[:woopsie:]]} ECTYPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid character class}} + +test regexp-1.208 {converted from line 208} { + catch {unset var} + list [catch { + set match [testregexp & {a[[:digit:]]} ab ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.209 {converted from line 209} { + catch {unset var} + list [catch { + set match [testregexp & {a[0-[:digit:]]} ERANGE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid character range}} + +test regexp-1.210 {converted from line 210} { + catch {unset var} + list [catch { + set match [testregexp & {[[:<:]]a} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.211 {converted from line 211} { + catch {unset var} + list [catch { + set match [testregexp & {a[[:>:]]} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.212 {converted from line 212} { + catch {unset var} + list [catch { + set match [testregexp & {a[[..]]b} ECOLLATE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid collating element}} + +test regexp-1.213 {converted from line 213} { + catch {unset var} + list [catch { + set match [testregexp & {a[[==]]b} ECOLLATE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid collating element}} + +test regexp-1.214 {converted from line 214} { + catch {unset var} + list [catch { + set match [testregexp & {a[[::]]b} ECTYPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid character class}} + +test regexp-1.215 {converted from line 215} { + catch {unset var} + list [catch { + set match [testregexp & {a[[.a} EBRACK ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched []}} + +test regexp-1.216 {converted from line 216} { + catch {unset var} + list [catch { + set match [testregexp & {a[[=a} EBRACK ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched []}} + +test regexp-1.217 {converted from line 217} { + catch {unset var} + list [catch { + set match [testregexp & {a[[:a} EBRACK ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched []}} + +test regexp-1.218 {converted from line 218} { + catch {unset var} + list [catch { + set match [testregexp & {a[} EBRACK ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched []}} + +test regexp-1.219 {converted from line 219} { + catch {unset var} + list [catch { + set match [testregexp & {a[b} EBRACK ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched []}} + +test regexp-1.220 {converted from line 220} { + catch {unset var} + list [catch { + set match [testregexp & {a[b-} EBRACK ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched []}} + +test regexp-1.221 {converted from line 221} { + catch {unset var} + list [catch { + set match [testregexp & {a[b-c} EBRACK ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched []}} + +test regexp-1.222 {converted from line 222} { + catch {unset var} + list [catch { + set match [testregexp & {a[b-c]} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.223 {converted from line 223} { + catch {unset var} + list [catch { + set match [testregexp & {a[b-b]} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.224 {converted from line 224} { + catch {unset var} + list [catch { + set match [testregexp & {a[1-2]} a2 var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a2}} + +test regexp-1.225 {converted from line 225} { + catch {unset var} + list [catch { + set match [testregexp & {a[c-b]} ERANGE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid character range}} + +test regexp-1.226 {converted from line 226} { + catch {unset var} + list [catch { + set match [testregexp & {a[a-b-c]} ERANGE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid character range}} + +test regexp-1.227 {converted from line 227} { + catch {unset var} + list [catch { + set match [testregexp & {a[--?]b} a?b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a?b}} + +test regexp-1.228 {converted from line 228} { + catch {unset var} + list [catch { + set match [testregexp & {a[---]b} a-b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a-b}} + +test regexp-1.229 {converted from line 229} { + catch {unset var} + list [catch { + set match [testregexp & {a[]b]c} a\]c var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a\]c}} + +test regexp-1.230 {converted from line 230} { + catch {unset var} + list [catch { + set match [testregexp {} {a[\]]b} a\]b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a\]b}} + +test regexp-1.231 {converted from line 231} { + catch {unset var} + list [catch { + set match [testregexp b {a[\]]b} a\]b ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.232 {converted from line 232} { + catch {unset var} + list [catch { + set match [testregexp b {a[\]]b} {a\]b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a\]b}}} + +test regexp-1.233 {converted from line 233} { + catch {unset var} + list [catch { + set match [testregexp e {a[\]]b} {a\]b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a\]b}}} + +test regexp-1.234 {converted from line 234} { + catch {unset var} + list [catch { + set match [testregexp {} {a[\\]b} {a\b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a\b}}} + +test regexp-1.235 {converted from line 235} { + catch {unset var} + list [catch { + set match [testregexp e {a[\\]b} {a\b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a\b}}} + +test regexp-1.236 {converted from line 236} { + catch {unset var} + list [catch { + set match [testregexp b {a[\\]b} {a\b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a\b}}} + +test regexp-1.237 {converted from line 237} { + catch {unset var} + list [catch { + set match [testregexp {} {a[\Z]b} EESCAPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid escape sequence}} + +test regexp-1.238 {converted from line 238} { + catch {unset var} + list [catch { + set match [testregexp & {a[[b]c} {a[c} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a[c}}} + + + +# anchors and newlines +test regexp-1.241 {converted from line 241} { + catch {unset var} + list [catch { + set match [testregexp & ^a a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.242 {converted from line 242} { + catch {unset var} + list [catch { + set match [testregexp &^ ^a a ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.243 {converted from line 243} { + catch {unset var} + list [catch { + set match [testregexp & ^ a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.244 {converted from line 244} { + catch {unset var} + list [catch { + set match [testregexp & {a$} aba var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.245 {converted from line 245} { + catch {unset var} + list [catch { + set match [testregexp {&$} {a$} a ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.246 {converted from line 246} { + catch {unset var} + list [catch { + set match [testregexp & {$} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.247 {converted from line 247} { + catch {unset var} + list [catch { + set match [testregexp &n ^a a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.248 {converted from line 248} { + catch {unset var} + list [catch { + set match [testregexp &=n ^a {b +a} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.249 {converted from line 249} { + catch {unset var} + list [catch { + set match [testregexp &=w ^a {a +a} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.250 {converted from line 250} { + catch {unset var} + list [catch { + set match [testregexp &=n^ ^a {a +a} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.251 {converted from line 251} { + catch {unset var} + list [catch { + set match [testregexp &n {a$} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.252 {converted from line 252} { + catch {unset var} + list [catch { + set match [testregexp &=n {a$} {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.253 {converted from line 253} { + catch {unset var} + list [catch { + set match [testregexp &=n {a$} {a +a} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.254 {converted from line 254} { + catch {unset var} + list [catch { + set match [testregexp - ^^ a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.255 {converted from line 255} { + catch {unset var} + list [catch { + set match [testregexp b ^^ ^ var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ^}} + +test regexp-1.256 {converted from line 256} { + catch {unset var} + list [catch { + set match [testregexp - {$$} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.257 {converted from line 257} { + catch {unset var} + list [catch { + set match [testregexp b {$$} {$} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {$}}} + +test regexp-1.258 {converted from line 258} { + catch {unset var} + list [catch { + set match [testregexp & {^$} {} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.259 {converted from line 259} { + catch {unset var} + list [catch { + set match [testregexp & {^$} a ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.260 {converted from line 260} { + catch {unset var} + list [catch { + set match [testregexp &=n {^$} {a + +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.261 {converted from line 261} { + catch {unset var} + list [catch { + set match [testregexp - {$^} {} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {}}} + +test regexp-1.262 {converted from line 262} { + catch {unset var} + list [catch { + set match [testregexp b {$^} {$^} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {$^}}} + +test regexp-1.263 {converted from line 263} { + catch {unset var} + list [catch { + set match [testregexp - {\Aa} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.264 {converted from line 264} { + catch {unset var} + list [catch { + set match [testregexp ^ {\Aa} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.265 {converted from line 265} { + catch {unset var} + list [catch { + set match [testregexp ^n> {\Aa} {b +a} ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.266 {converted from line 266} { + catch {unset var} + list [catch { + set match [testregexp - {a\Z} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.267 {converted from line 267} { + catch {unset var} + list [catch { + set match [testregexp {$} {a\Z} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.268 {converted from line 268} { + catch {unset var} + list [catch { + set match [testregexp {$n>} {a\Z} {a +b} ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.269 {converted from line 269} { + catch {unset var} + list [catch { + set match [testregexp {} ^* BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.270 {converted from line 270} { + catch {unset var} + list [catch { + set match [testregexp {} {$*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.271 {converted from line 271} { + catch {unset var} + list [catch { + set match [testregexp {} {\A*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.272 {converted from line 272} { + catch {unset var} + list [catch { + set match [testregexp {} {\Z*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + + + +# boundary constraints +test regexp-1.275 {converted from line 275} { + catch {unset var} + list [catch { + set match [testregexp & {[[:<:]]a} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.276 {converted from line 276} { + catch {unset var} + list [catch { + set match [testregexp & {[[:<:]]a} -a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.277 {converted from line 277} { + catch {unset var} + list [catch { + set match [testregexp & {[[:<:]]a} ba ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.278 {converted from line 278} { + catch {unset var} + list [catch { + set match [testregexp & {a[[:>:]]} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.279 {converted from line 279} { + catch {unset var} + list [catch { + set match [testregexp & {a[[:>:]]} a- var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.280 {converted from line 280} { + catch {unset var} + list [catch { + set match [testregexp & {a[[:>:]]} ab ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.281 {converted from line 281} { + catch {unset var} + list [catch { + set match [testregexp b {\<a} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.282 {converted from line 282} { + catch {unset var} + list [catch { + set match [testregexp b {\<a} ba ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.283 {converted from line 283} { + catch {unset var} + list [catch { + set match [testregexp b {a\>} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.284 {converted from line 284} { + catch {unset var} + list [catch { + set match [testregexp b {a\>} ab ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.285 {converted from line 285} { + catch {unset var} + list [catch { + set match [testregexp {} {\ya} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.286 {converted from line 286} { + catch {unset var} + list [catch { + set match [testregexp {} {\ya} ba ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.287 {converted from line 287} { + catch {unset var} + list [catch { + set match [testregexp {} {a\y} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.288 {converted from line 288} { + catch {unset var} + list [catch { + set match [testregexp {} {a\y} ab ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.289 {converted from line 289} { + catch {unset var} + list [catch { + set match [testregexp {} {a\Y} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.290 {converted from line 290} { + catch {unset var} + list [catch { + set match [testregexp {} {a\Y} a- ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.291 {converted from line 291} { + catch {unset var} + list [catch { + set match [testregexp {} {a\Y} a ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.292 {converted from line 292} { + catch {unset var} + list [catch { + set match [testregexp {} {-\Y} -a ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.293 {converted from line 293} { + catch {unset var} + list [catch { + set match [testregexp {} {-\Y} -% var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 -}} + +test regexp-1.294 {converted from line 294} { + catch {unset var} + list [catch { + set match [testregexp {} {\Y-} a- ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.295 {converted from line 295} { + catch {unset var} + list [catch { + set match [testregexp {} {[[:<:]]*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.296 {converted from line 296} { + catch {unset var} + list [catch { + set match [testregexp {} {[[:>:]]*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.297 {converted from line 297} { + catch {unset var} + list [catch { + set match [testregexp b {\<*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.298 {converted from line 298} { + catch {unset var} + list [catch { + set match [testregexp b {\>*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.299 {converted from line 299} { + catch {unset var} + list [catch { + set match [testregexp {} {\y*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.300 {converted from line 300} { + catch {unset var} + list [catch { + set match [testregexp {} {\Y*} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + + + +# character classes +test regexp-1.303 {converted from line 303} { + catch {unset var} + list [catch { + set match [testregexp {} {a\db} a0b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a0b}} + +test regexp-1.304 {converted from line 304} { + catch {unset var} + list [catch { + set match [testregexp {} {a\db} axb ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.305 {converted from line 305} { + catch {unset var} + list [catch { + set match [testregexp {} {a\Db} a0b ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.306 {converted from line 306} { + catch {unset var} + list [catch { + set match [testregexp {} {a\Db} axb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 axb}} + +test regexp-1.307 {converted from line 307} { + catch {unset var} + list [catch { + set match [testregexp = {a\sb} {a b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a b}}} + +test regexp-1.308 {converted from line 308} { + catch {unset var} + list [catch { + set match [testregexp = {a\sb} {a b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a b}}} + +test regexp-1.309 {converted from line 309} { + catch {unset var} + list [catch { + set match [testregexp = {a\sb} {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a +b}}} + +test regexp-1.310 {converted from line 310} { + catch {unset var} + list [catch { + set match [testregexp {} {a\sb} axb ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.311 {converted from line 311} { + catch {unset var} + list [catch { + set match [testregexp {} {a\Sb} axb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 axb}} + +test regexp-1.312 {converted from line 312} { + catch {unset var} + list [catch { + set match [testregexp = {a\Sb} {a b} ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.313 {converted from line 313} { + catch {unset var} + list [catch { + set match [testregexp {} {a\wb} axb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 axb}} + +test regexp-1.314 {converted from line 314} { + catch {unset var} + list [catch { + set match [testregexp {} {a\wb} a-b ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.315 {converted from line 315} { + catch {unset var} + list [catch { + set match [testregexp {} {a\Wb} axb ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.316 {converted from line 316} { + catch {unset var} + list [catch { + set match [testregexp {} {a\Wb} a-b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a-b}} + +test regexp-1.317 {converted from line 317} { + catch {unset var} + list [catch { + set match [testregexp {} {\y\w+z\y} adze-guz var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 guz}} + +test regexp-1.318 {converted from line 318} { + catch {unset var} + list [catch { + set match [testregexp {} {a[\d]b} a1b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a1b}} + +test regexp-1.319 {converted from line 319} { + catch {unset var} + list [catch { + set match [testregexp = {a[\s]b} {a b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a b}}} + +test regexp-1.320 {converted from line 320} { + catch {unset var} + list [catch { + set match [testregexp {} {a[\w]b} axb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 axb}} + + + +# escapes +test regexp-1.323 {converted from line 323} { + catch {unset var} + list [catch { + set match [testregexp & a\\ EESCAPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid escape sequence}} + +test regexp-1.324 {converted from line 324} { + catch {unset var} + list [catch { + set match [testregexp - {a\<b} a<b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a<b}} + +test regexp-1.325 {converted from line 325} { + catch {unset var} + list [catch { + set match [testregexp e {a\<b} a<b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a<b}} + +test regexp-1.326 {converted from line 326} { + catch {unset var} + list [catch { + set match [testregexp b {a\wb} awb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 awb}} + +test regexp-1.327 {converted from line 327} { + catch {unset var} + list [catch { + set match [testregexp e {a\wb} awb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 awb}} + +test regexp-1.328 {converted from line 328} { + catch {unset var} + list [catch { + set match [testregexp = {a\ab} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.329 {converted from line 329} { + catch {unset var} + list [catch { + set match [testregexp = {a\bb} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.330 {converted from line 330} { + catch {unset var} + list [catch { + set match [testregexp = {a\chb} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.331 {converted from line 331} { + catch {unset var} + list [catch { + set match [testregexp = {a\cHb} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.332 {converted from line 332} { + catch {unset var} + list [catch { + set match [testregexp = {a\e} a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.333 {converted from line 333} { + catch {unset var} + list [catch { + set match [testregexp {} {a\Eb} {a\b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a\b}}} + +test regexp-1.334 {converted from line 334} { + catch {unset var} + list [catch { + set match [testregexp = {a\fb} {a b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a b}}} + +test regexp-1.335 {converted from line 335} { + catch {unset var} + list [catch { + set match [testregexp = {a\nb} {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a +b}}} + +test regexp-1.336 {converted from line 336} { + catch {unset var} + list [catch { + set match [testregexp = a\rb a\u000Db var(0)] + list $match $var(0) + } msg] $msg +} [subst {0 {1 {a\u000Db}}}] + +test regexp-1.337 {converted from line 337} { + catch {unset var} + list [catch { + set match [testregexp = {a\tb} {a b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a b}}} + +test regexp-1.338 {converted from line 338} { + catch {unset var} + list [catch { + set match [testregexp = {a\u0008x} ax var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ax}} + +test regexp-1.339 {converted from line 339} { + catch {unset var} + list [catch { + set match [testregexp {} {a\u008x} EESCAPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid escape sequence}} + +test regexp-1.340 {converted from line 340} { + catch {unset var} + list [catch { + set match [testregexp = {a\u00088x} a8x var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a8x}} + +test regexp-1.341 {converted from line 341} { + catch {unset var} + list [catch { + set match [testregexp = {a\U00000008x} ax var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ax}} + +test regexp-1.342 {converted from line 342} { + catch {unset var} + list [catch { + set match [testregexp {} {a\U0000008x} EESCAPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid escape sequence}} + +test regexp-1.343 {converted from line 343} { + catch {unset var} + list [catch { + set match [testregexp = {a\vb} {a b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a b}}} + +test regexp-1.344 {converted from line 344} { + catch {unset var} + list [catch { + set match [testregexp = {a\x08x} ax var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ax}} + +test regexp-1.345 {converted from line 345} { + catch {unset var} + list [catch { + set match [testregexp {} {a\xx} EESCAPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid escape sequence}} + +test regexp-1.346 {converted from line 346} { + catch {unset var} + list [catch { + set match [testregexp = {a\x0008x} ax var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ax}} + +test regexp-1.347 {converted from line 347} { + catch {unset var} + list [catch { + set match [testregexp {} {a\z} EESCAPE ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid escape sequence}} + +test regexp-1.348 {converted from line 348} { + catch {unset var} + list [catch { + set match [testregexp = {a\010b} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + + + +# back references (ugh) +test regexp-1.351 {converted from line 351} { + catch {unset var} + list [catch { + set match [testregexp {} {a(b*)c\1} abbcbb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbcbb bb}} + +test regexp-1.352 {converted from line 352} { + catch {unset var} + list [catch { + set match [testregexp {} {a(b*)c\1} ac var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ac {}}} + +test regexp-1.353 {converted from line 353} { + catch {unset var} + list [catch { + set match [testregexp {} {a(b*)c\1} abbcb ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.354 {converted from line 354} { + catch {unset var} + list [catch { + set match [testregexp {} {a(b*)\1} abbcbb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abb b}} + +test regexp-1.355 {converted from line 355} { + catch {unset var} + list [catch { + set match [testregexp {} {a(b|bb)\1} abbcbb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abb b}} + +test regexp-1.356 {converted from line 356} { + catch {unset var} + list [catch { + set match [testregexp {} {a([bc])\1} abb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abb b}} + +test regexp-1.357 {converted from line 357} { + catch {unset var} + list [catch { + set match [testregexp {} {a([bc])\1} abc ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.358 {converted from line 358} { + catch {unset var} + list [catch { + set match [testregexp {} {a([bc])\1} abcabb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abb b}} + +test regexp-1.359 {converted from line 359} { + catch {unset var} + list [catch { + set match [testregexp {} {a([bc])*\1} abc ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.360 {converted from line 360} { + catch {unset var} + list [catch { + set match [testregexp {} {a([bc])\1} abB ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.361 {converted from line 361} { + catch {unset var} + list [catch { + set match [testregexp i {a([bc])\1} abB var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abB b}} + +test regexp-1.362 {converted from line 362} { + catch {unset var} + list [catch { + set match [testregexp {} {a([bc])\1+} abbb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbb b}} + +test regexp-1.363 {converted from line 363} { + catch {unset var} + list [catch { + set match [testregexp {} {a([bc])\1{3,4}} abbbb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbbb b}} + +test regexp-1.364 {converted from line 364} { + catch {unset var} + list [catch { + set match [testregexp {} {a([bc])\1{3,4}} abbb ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.365 {converted from line 365} { + catch {unset var} + list [catch { + set match [testregexp {} {a([bc])\1*} abbb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbb b}} + +test regexp-1.366 {converted from line 366} { + catch {unset var} + list [catch { + set match [testregexp {} {a([bc])\1*} ab var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ab b}} + +test regexp-1.367 {converted from line 367} { + catch {unset var} + list [catch { + set match [testregexp {} {a([bc])(\1*)} ab var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 ab b {}}} + +test regexp-1.368 {converted from line 368} { + catch {unset var} + list [catch { + set match [testregexp {} {a((b)\1)} ESUBREG ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid backreference number}} + +test regexp-1.369 {converted from line 369} { + catch {unset var} + list [catch { + set match [testregexp {} {a(b)c\2} ESUBREG ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid backreference number}} + +test regexp-1.370 {converted from line 370} { + catch {unset var} + list [catch { + set match [testregexp b {a\(b*\)c\1} abbcbb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbcbb bb}} + + + +# is it an octal escape or a back reference...? +# initial zero is always octal +test regexp-1.374 {converted from line 374} { + catch {unset var} + list [catch { + set match [testregexp = {a\010b} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.375 {converted from line 375} { + catch {unset var} + list [catch { + set match [testregexp = {a\0070b} a0b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a0b}} + +test regexp-1.376 {converted from line 376} { + catch {unset var} + list [catch { + set match [testregexp = {a\07b} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.377 {converted from line 377} { + catch {unset var} + list [catch { + set match [testregexp = {a(b)(b)(b)(b)(b)(b)(b)(b)(b)(b)\07c} abbbbbbbbbbc var(0) var(1) var(2) var(3) var(4) var(5) var(6) var(7) var(8) var(9) var(10)] + list $match $var(0) $var(1) $var(2) $var(3) $var(4) $var(5) $var(6) $var(7) $var(8) $var(9) $var(10) + } msg] $msg +} {0 {1 abbbbbbbbbbc b b b b b b b b b b}} + +# a single digit is always a backref +test regexp-1.381 {converted from line 381} { + catch {unset var} + list [catch { + set match [testregexp {} {a\7b} ESUBREG ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid backreference number}} + +# otherwise it's a backref only if within range (barf!) +test regexp-1.383 {converted from line 383} { + catch {unset var} + list [catch { + set match [testregexp = {a\10b} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.384 {converted from line 384} { + catch {unset var} + list [catch { + set match [testregexp {} {a\101b} aAb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aAb}} + +test regexp-1.385 {converted from line 385} { + catch {unset var} + list [catch { + set match [testregexp {} {a(b)(b)(b)(b)(b)(b)(b)(b)(b)(b)\10c} abbbbbbbbbbbc var(0) var(1) var(2) var(3) var(4) var(5) var(6) var(7) var(8) var(9) var(10)] + list $match $var(0) $var(1) $var(2) $var(3) $var(4) $var(5) $var(6) $var(7) $var(8) $var(9) $var(10) + } msg] $msg +} {0 {1 abbbbbbbbbbbc b b b b b b b b b b}} + +# but we're fussy about border cases -- guys who want octal should use the zero +test regexp-1.389 {converted from line 389} { + catch {unset var} + list [catch { + set match [testregexp {} {a((((((((((b\10))))))))))c} ESUBREG ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid backreference number}} + +# BREs don't have octal, EREs don't have backrefs +test regexp-1.391 {converted from line 391} { + catch {unset var} + list [catch { + set match [testregexp = {a\12b} {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a +b}}} + +test regexp-1.392 {converted from line 392} { + catch {unset var} + list [catch { + set match [testregexp b {a\12b} ESUBREG ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid backreference number}} + +test regexp-1.393 {converted from line 393} { + catch {unset var} + list [catch { + set match [testregexp e {a\12b} a12b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a12b}} + + + +# expanded syntax +test regexp-1.396 {converted from line 396} { + catch {unset var} + list [catch { + set match [testregexp =x {a b c} abc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + +test regexp-1.397 {converted from line 397} { + catch {unset var} + list [catch { + set match [testregexp =x {a b #oops +c d} abcd var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abcd}} + +test regexp-1.398 {converted from line 398} { + catch {unset var} + list [catch { + set match [testregexp =x {a\ b\ c} {a b c} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a b c}}} + +test regexp-1.399 {converted from line 399} { + catch {unset var} + list [catch { + set match [testregexp =x {a b\#c} ab#c var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab#c}} + +test regexp-1.400 {converted from line 400} { + catch {unset var} + list [catch { + set match [testregexp =x {a b[c d]e} {ab e} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {ab e}}} + +test regexp-1.401 {converted from line 401} { + catch {unset var} + list [catch { + set match [testregexp =x {a b[c#d]e} ab#e var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab#e}} + +test regexp-1.402 {converted from line 402} { + catch {unset var} + list [catch { + set match [testregexp =x {a b[c#d]e} abde var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abde}} + +test regexp-1.403 {converted from line 403} { + catch {unset var} + list [catch { + set match [testregexp =x ab\{\ d ab\{d var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab\{d}} + +test regexp-1.404 {converted from line 404} { + catch {unset var} + list [catch { + set match [testregexp =x {ab{ 1 , 2 }c} abc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + + + +# misc. syntax +test regexp-1.407 {converted from line 407} { + catch {unset var} + list [catch { + set match [testregexp {} a(?#comment)b ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + + + +# unmatchable REs +test regexp-1.410 {converted from line 410} { + catch {unset var} + list [catch { + set match [testregexp {} a^b IMPOSS ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: can never match}} + + + +# case independence +test regexp-1.413 {converted from line 413} { + catch {unset var} + list [catch { + set match [testregexp &i ab Ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 Ab}} + +test regexp-1.414 {converted from line 414} { + catch {unset var} + list [catch { + set match [testregexp &i {a[bc]} aC var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aC}} + +test regexp-1.415 {converted from line 415} { + catch {unset var} + list [catch { + set match [testregexp &i {a[^bc]} aB ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.416 {converted from line 416} { + catch {unset var} + list [catch { + set match [testregexp &i {a[b-d]} aC var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aC}} + +test regexp-1.417 {converted from line 417} { + catch {unset var} + list [catch { + set match [testregexp &i {a[^b-d]} aC ] + list $match + } msg] $msg +} {0 0} + + + +# inline options +test regexp-1.420 {converted from line 420} { + catch {unset var} + list [catch { + set match [testregexp & ***? BADPAT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid regular expression}} + +test regexp-1.421 {converted from line 421} { + catch {unset var} + list [catch { + set match [testregexp q ***? ***? var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ***?}} + +test regexp-1.422 {converted from line 422} { + catch {unset var} + list [catch { + set match [testregexp & ***=a*b a*b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a*b}} + +test regexp-1.423 {converted from line 423} { + catch {unset var} + list [catch { + set match [testregexp q ***=a*b ***=a*b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ***=a*b}} + +test regexp-1.424 {converted from line 424} { + catch {unset var} + list [catch { + set match [testregexp b {***:\w+} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.425 {converted from line 425} { + catch {unset var} + list [catch { + set match [testregexp e {***:\w+} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.426 {converted from line 426} { + catch {unset var} + list [catch { + set match [testregexp {} (?b)a+b a+b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a+b}} + +test regexp-1.427 {converted from line 427} { + catch {unset var} + list [catch { + set match [testregexp e {(?b)\w+} BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.428 {converted from line 428} { + catch {unset var} + list [catch { + set match [testregexp b {(?b)\w+} (?b)w+ var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 (?b)w+}} + +test regexp-1.429 {converted from line 429} { + catch {unset var} + list [catch { + set match [testregexp i (?c)a a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.430 {converted from line 430} { + catch {unset var} + list [catch { + set match [testregexp i (?c)a A ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.431 {converted from line 431} { + catch {unset var} + list [catch { + set match [testregexp {} {(?e)\W+} WW var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 WW}} + +test regexp-1.432 {converted from line 432} { + catch {unset var} + list [catch { + set match [testregexp {} (?i)a+ Aa var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 Aa}} + +test regexp-1.433 {converted from line 433} { + catch {unset var} + list [catch { + set match [testregexp = (?m)a.b {a +b} ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.434 {converted from line 434} { + catch {unset var} + list [catch { + set match [testregexp = (?m)^b {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.435 {converted from line 435} { + catch {unset var} + list [catch { + set match [testregexp = (?n)a.b {a +b} ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.436 {converted from line 436} { + catch {unset var} + list [catch { + set match [testregexp = (?n)^b {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.437 {converted from line 437} { + catch {unset var} + list [catch { + set match [testregexp = (?p)a.b {a +b} ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.438 {converted from line 438} { + catch {unset var} + list [catch { + set match [testregexp = (?p)^b {a +b} ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.439 {converted from line 439} { + catch {unset var} + list [catch { + set match [testregexp {} (?q)a+b a+b var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a+b}} + +test regexp-1.440 {converted from line 440} { + catch {unset var} + list [catch { + set match [testregexp n= (?s)a.b {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a +b}}} + +test regexp-1.441 {converted from line 441} { + catch {unset var} + list [catch { + set match [testregexp x= {(?t)a b} {a b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a b}}} + +test regexp-1.442 {converted from line 442} { + catch {unset var} + list [catch { + set match [testregexp = (?w)a.b {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 {a +b}}} + +test regexp-1.443 {converted from line 443} { + catch {unset var} + list [catch { + set match [testregexp = (?w)^b {a +b} var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 b}} + +test regexp-1.444 {converted from line 444} { + catch {unset var} + list [catch { + set match [testregexp = {(?x)a b} ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.445 {converted from line 445} { + catch {unset var} + list [catch { + set match [testregexp {} (?z)ab BADOPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: invalid embedded option}} + + + +# capturing +test regexp-1.448 {converted from line 448} { + catch {unset var} + list [catch { + set match [testregexp - a(b)c abc var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc b}} + +test regexp-1.449 {converted from line 449} { + catch {unset var} + list [catch { + set match [testregexp {} a(?:b)c xabc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + +test regexp-1.450 {converted from line 450} { + catch {unset var} + list [catch { + set match [testregexp - a((b))c xabcy var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abc b b}} + +test regexp-1.451 {converted from line 451} { + catch {unset var} + list [catch { + set match [testregexp {} a(?:(b))c abcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc b}} + +test regexp-1.452 {converted from line 452} { + catch {unset var} + list [catch { + set match [testregexp {} a((?:b))c abc var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc b}} + +test regexp-1.453 {converted from line 453} { + catch {unset var} + list [catch { + set match [testregexp {} a(?:(?:b))c abc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + +test regexp-1.454 {converted from line 454} { + catch {unset var} + list [catch { + set match [testregexp {} a(b){0}c ac var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ac}} + +test regexp-1.455 {converted from line 455} { + catch {unset var} + list [catch { + set match [testregexp - a(b)c(d)e abcde var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abcde b d}} + +test regexp-1.456 {converted from line 456} { + catch {unset var} + list [catch { + set match [testregexp - (b)c(d)e bcde var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 bcde b d}} + +test regexp-1.457 {converted from line 457} { + catch {unset var} + list [catch { + set match [testregexp - a(b)(d)e abde var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abde b d}} + +test regexp-1.458 {converted from line 458} { + catch {unset var} + list [catch { + set match [testregexp - a(b)c(d) abcd var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abcd b d}} + +test regexp-1.459 {converted from line 459} { + catch {unset var} + list [catch { + set match [testregexp - (ab)(cd) xabcdy var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abcd ab cd}} + +test regexp-1.460 {converted from line 460} { + catch {unset var} + list [catch { + set match [testregexp - a(b)?c xabcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc b}} + +test regexp-1.461 {converted from line 461} { + catch {unset var} + list [catch { + set match [testregexp - a(b)?c xacy var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ac}} + +test regexp-1.462 {converted from line 462} { + catch {unset var} + list [catch { + set match [testregexp - a(b)?c(d)?e xabcdey var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abcde b d}} + +test regexp-1.463 {converted from line 463} { + catch {unset var} + list [catch { + set match [testregexp - a(b)?c(d)?e xacdey var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 acde {} d}} + +test regexp-1.464 {converted from line 464} { + catch {unset var} + list [catch { + set match [testregexp - a(b)?c(d)?e xabcey var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 abce b {}}} + +test regexp-1.465 {converted from line 465} { + catch {unset var} + list [catch { + set match [testregexp - a(b)?c(d)?e xacey var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 ace {} {}}} + +test regexp-1.466 {converted from line 466} { + catch {unset var} + list [catch { + set match [testregexp - a(b)*c xabcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc b}} + +test regexp-1.467 {converted from line 467} { + catch {unset var} + list [catch { + set match [testregexp - a(b)*c xabbbcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbbc b}} + +test regexp-1.468 {converted from line 468} { + catch {unset var} + list [catch { + set match [testregexp - a(b)*c xacy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ac {}}} + +test regexp-1.469 {converted from line 469} { + catch {unset var} + list [catch { + set match [testregexp - a(b*)c xabbbcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbbc bbb}} + +test regexp-1.470 {converted from line 470} { + catch {unset var} + list [catch { + set match [testregexp - a(b*)c xacy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 ac {}}} + +test regexp-1.471 {converted from line 471} { + catch {unset var} + list [catch { + set match [testregexp - a(b)+c xacy ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.472 {converted from line 472} { + catch {unset var} + list [catch { + set match [testregexp - a(b)+c xabcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc b}} + +test regexp-1.473 {converted from line 473} { + catch {unset var} + list [catch { + set match [testregexp - a(b)+c xabbbcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbbc b}} + +test regexp-1.474 {converted from line 474} { + catch {unset var} + list [catch { + set match [testregexp - a(b+)c xabbbcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbbc bbb}} + +test regexp-1.475 {converted from line 475} { + catch {unset var} + list [catch { + set match [testregexp {} a(b){2,3}c xabbbcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbbc b}} + +test regexp-1.476 {converted from line 476} { + catch {unset var} + list [catch { + set match [testregexp {} a(b){2,3}c xabbcy var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abbc b}} + +test regexp-1.477 {converted from line 477} { + catch {unset var} + list [catch { + set match [testregexp {} a(b){2,3}c xabcy ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.478 {converted from line 478} { + catch {unset var} + list [catch { + set match [testregexp = {\y(\w+)\y} {-- abc-} var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc abc}} + +test regexp-1.479 {converted from line 479} { + catch {unset var} + list [catch { + set match [testregexp - a((b|c)d+)+ abacdbd var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 acdbd bd b}} + +test regexp-1.480 {converted from line 480} { + catch {unset var} + list [catch { + set match [testregexp {} (.*).* abc var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abc abc}} + +test regexp-1.481 {converted from line 481} { + catch {unset var} + list [catch { + set match [testregexp {} (a*)* bc var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 {} {}}} + + + +# collating elements (ugh) +# skipping char mapping test from line 484 +print {... skip test from line 484: a&c&e &+L ace ace} +# skipping char mapping test from line 485 +print {... skip test from line 485: a&c&h &+* IMPOSS} +# skipping char mapping test from line 486 +print {... skip test from line 486: a&&.ch.&& &+L ach ach} +# skipping char mapping test from line 487 +print {... skip test from line 487: a&&.ch.&& &+L ace} +# skipping char mapping test from line 488 +print {... skip test from line 488: a&c&.ch.&& &+L ac ac} +# skipping char mapping test from line 489 +print {... skip test from line 489: a&c&.ch.&& &+L ace ac} +# skipping char mapping test from line 490 +print {... skip test from line 490: a&c&.ch.&& &+L ache ach} +# skipping char mapping test from line 491 +print {... skip test from line 491: a&^c&e &+L ace} +# skipping char mapping test from line 492 +print {... skip test from line 492: a&^c&e &+L abe abe} +# skipping char mapping test from line 493 +print {... skip test from line 493: a&^c&e &+L ache ache} +# skipping char mapping test from line 494 +print {... skip test from line 494: a&^&.ch.&& &+L ach} +# skipping char mapping test from line 495 +print {... skip test from line 495: a&^&.ch.&& &+L ace ac} +# skipping char mapping test from line 496 +print {... skip test from line 496: a&^&.ch.&& &+L ac ac} +# skipping char mapping test from line 497 +print {... skip test from line 497: a&^&.ch.&& &+L abe ab} +# skipping char mapping test from line 498 +print {... skip test from line 498: a&^c&.ch.&& &+L ach} +# skipping char mapping test from line 499 +print {... skip test from line 499: a&^c&.ch.&& &+L ace} +# skipping char mapping test from line 500 +print {... skip test from line 500: a&^c&.ch.&& &+L ac} +# skipping char mapping test from line 501 +print {... skip test from line 501: a&^c&.ch.&& &+L abe ab} +# skipping char mapping test from line 502 +print {... skip test from line 502: a&^b& &+L ac ac} +# skipping char mapping test from line 503 +print {... skip test from line 503: a&^b& &+L ace ac} +# skipping char mapping test from line 504 +print {... skip test from line 504: a&^b& &+L ach ach} +# skipping char mapping test from line 505 +print {... skip test from line 505: a&^b& &+L abe} + + +# lookahead +test regexp-1.508 {converted from line 508} { + catch {unset var} + list [catch { + set match [testregexp {} a(?=b)b* ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.509 {converted from line 509} { + catch {unset var} + list [catch { + set match [testregexp {} a(?=b)b* a ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.510 {converted from line 510} { + catch {unset var} + list [catch { + set match [testregexp {} a(?!b)b* ab ] + list $match + } msg] $msg +} {0 0} + +test regexp-1.511 {converted from line 511} { + catch {unset var} + list [catch { + set match [testregexp {} a(?!b)b* a var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + + + +# non-greedy quantifiers +test regexp-1.514 {converted from line 514} { + catch {unset var} + list [catch { + set match [testregexp {} ab+? abb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 ab}} + +test regexp-1.515 {converted from line 515} { + catch {unset var} + list [catch { + set match [testregexp {} ab+?c abbc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abbc}} + +test regexp-1.516 {converted from line 516} { + catch {unset var} + list [catch { + set match [testregexp {} ab*? abb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.517 {converted from line 517} { + catch {unset var} + list [catch { + set match [testregexp {} ab*?c abbc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abbc}} + +test regexp-1.518 {converted from line 518} { + catch {unset var} + list [catch { + set match [testregexp {} ab?? ab var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 a}} + +test regexp-1.519 {converted from line 519} { + catch {unset var} + list [catch { + set match [testregexp {} ab??c abc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + +test regexp-1.520 {converted from line 520} { + catch {unset var} + list [catch { + set match [testregexp {} ab{2,4}? abbbb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abb}} + +test regexp-1.521 {converted from line 521} { + catch {unset var} + list [catch { + set match [testregexp {} ab{2,4}?c abbbbc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abbbbc}} + + + +# xxx mixed quantifiers (incl |) + + +# attempts to trick the matcher into accepting a short match +test regexp-1.526 {converted from line 526} { + catch {unset var} + list [catch { + set match [testregexp - (week|wee)(night|knights) weeknights var(0) var(1) var(2)] + list $match $var(0) $var(1) $var(2) + } msg] $msg +} {0 {1 weeknights wee knights}} + +test regexp-1.527 {converted from line 527} { + catch {unset var} + list [catch { + set match [testregexp {} {a(bc*).*\1} abccbccb var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abccbccb b}} + +test regexp-1.528 {converted from line 528} { + catch {unset var} + list [catch { + set match [testregexp - {a(b.[bc]*)+} abcbd var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 abcbd bd}} + + + +# implementation misc. +# duplicate arcs are suppressed +test regexp-1.532 {converted from line 532} { + catch {unset var} + list [catch { + set match [testregexp {} a(?:b|b)c abc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abc}} + + + +# boundary busters +# color-descriptor allocation and arc allocation both change at 10 +test regexp-1.536 {converted from line 536} { + catch {unset var} + list [catch { + set match [testregexp & abcdefghijkl abcdefghijkl var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abcdefghijkl}} + +# subexpression tracking at 10 +test regexp-1.538 {converted from line 538} { + catch {unset var} + list [catch { + set match [testregexp - a(((((((((((((b)))))))))))))c abc var(0) var(1) var(2) var(3) var(4) var(5) var(6) var(7) var(8) var(9) var(10) var(11) var(12) var(13)] + list $match $var(0) $var(1) $var(2) $var(3) $var(4) $var(5) $var(6) $var(7) $var(8) $var(9) $var(10) $var(11) $var(12) $var(13) + } msg] $msg +} {0 {1 abc b b b b b b b b b b b b b}} + +# state-set handling changes slightly at unsigned size (might be 64...) +# (also stresses arc allocation) +test regexp-1.544 {converted from line 544} { + catch {unset var} + list [catch { + set match [testregexp {} ab{1,100}c abbc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abbc}} + +test regexp-1.545 {converted from line 545} { + catch {unset var} + list [catch { + set match [testregexp {} ab{1,100}c abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc}} + +test regexp-1.548 {converted from line 548} { + catch {unset var} + list [catch { + set match [testregexp {} ab{1,100}c abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc}} + +# force small cache and bust it, several ways +test regexp-1.552 {converted from line 552} { + catch {unset var} + list [catch { + set match [testregexp - {\w+abcdefgh} xyzabcdefgh var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 xyzabcdefgh}} + +test regexp-1.553 {converted from line 553} { + catch {unset var} + list [catch { + set match [testregexp . {\w+abcdefgh} xyzabcdefgh var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 xyzabcdefgh}} + +test regexp-1.554 {converted from line 554} { + catch {unset var} + list [catch { + set match [testregexp . {\w+(abcdefgh)?} xyz var(0) var(1)] + list $match $var(0) $var(1) + } msg] $msg +} {0 {1 xyz {}}} + + + +# make color/subcolor relationship go back and forth +test regexp-1.557 {converted from line 557} { + catch {unset var} + list [catch { + set match [testregexp & {[ab][ab][ab]} aba var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 aba}} + + + +# misc. +test regexp-1.560 {converted from line 560} { + catch {unset var} + list [catch { + set match [testregexp & *** BADRPT ] + list $match + } msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test regexp-1.561 {converted from line 561} { + catch {unset var} + list [catch { + set match [testregexp {} a?b* abb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 abb}} + +test regexp-1.562 {converted from line 562} { + catch {unset var} + list [catch { + set match [testregexp {} a?b* bb var(0)] + list $match $var(0) + } msg] $msg +} {0 {1 bb}} + diff --git a/tests/registry.test b/tests/registry.test index 605c84b..b1597d1 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -9,7 +9,7 @@ # # Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. # -# SCCS: @(#) registry.test 1.5 97/08/01 11:14:25 +# SCCS: @(#) registry.test 1.9 98/01/05 16:18:05 if {$tcl_platform(platform) != "windows"} { return @@ -32,6 +32,16 @@ switch $tcl_platform(os) { "Windows 95" {set testConfig(95) 1} } +# determine the current locale +set old [testlocale all] +if {[testlocale all ""] == "English_United States.1252"} { + # error messages from registry package are already localized. + + set testConfig(english) 1 +} +testlocale all $old +unset old + set hostname [info hostname] test registry-1.1 {argument parsing for registry command} { @@ -138,7 +148,7 @@ test registry-2.6 {DeleteKey: recursive delete} { set result [registry keys HKEY_CLASSES_ROOT TclFoobar] set result } {} -test registry-2.7 {DeleteKey: trailing backslashes} { +test registry-2.7 {DeleteKey: trailing backslashes} {english} { registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar\\} msg] $msg } {1 {unable to delete key: The configuration registry key is invalid.}} @@ -157,11 +167,11 @@ test registry-3.1 {DeleteValue} { registry delete HKEY_CLASSES_ROOT\\TclFoobar set result } test2 -test registry-3.2 {DeleteValue: bad key} { +test registry-3.2 {DeleteValue: bad key} {english} { registry delete HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar test} msg] $msg } {1 {unable to open key: The system cannot find the file specified.}} -test registry-3.3 {DeleteValue: bad value} { +test registry-3.3 {DeleteValue: bad value} {english} { registry delete HKEY_CLASSES_ROOT\\TclFoobar registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test2 blort set result [list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar test1} msg] $msg] @@ -170,7 +180,7 @@ test registry-3.3 {DeleteValue: bad value} { } {1 {unable to delete value "test1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}} -test registry-4.1 {GetKeyNames: bad key} { +test registry-4.1 {GetKeyNames: bad key} {english} { registry delete HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg } {1 {unable to open key: The system cannot find the file specified.}} @@ -181,7 +191,7 @@ test registry-4.2 {GetKeyNames} { registry delete HKEY_CLASSES_ROOT\\TclFoobar set result } {baz} -test registry-4.3 {GetKeyNames: remote key} {nonPortable} { +test registry-4.3 {GetKeyNames: remote key} {nonPortable english} { registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar\\baz set result [registry keys \\\\gaspode\\HKEY_CLASSES_ROOT\\TclFoobar] registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar @@ -213,11 +223,11 @@ test registry-4.6 {GetKeyNames: names with spaces} { set result } {{baz bar} blat} -test registry-5.1 {GetType} { +test registry-5.1 {GetType} {english} { registry delete HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg } {1 {unable to open key: The system cannot find the file specified.}} -test registry-5.2 {GetType} { +test registry-5.2 {GetType} {english} { registry set HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg } {1 {unable to get type of value "val1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}} @@ -288,11 +298,11 @@ test registry-5.13 {GetType: unknown types} { set result } 24 -test registry-6.1 {GetValue} { +test registry-6.1 {GetValue} {english} { registry delete HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry get HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg } {1 {unable to open key: The system cannot find the file specified.}} -test registry-6.2 {GetValue} { +test registry-6.2 {GetValue} {english} { registry set HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry get HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg } {1 {unable to get value "val1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}} @@ -381,7 +391,7 @@ test registry-6.16 {GetValue: unknown types} { set result } 1 -test registry-7.1 {GetValueNames: bad key} { +test registry-7.1 {GetValueNames: bad key} {english} { registry delete HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry values HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg } {1 {unable to open key: The system cannot find the file specified.}} @@ -401,9 +411,9 @@ test registry-7.3 {GetValueNames} { registry delete HKEY_CLASSES_ROOT\\TclFoobar set result } {{} baz blat} -test registry-7.4 {GetValueNames: remote key} {nonPortable} { +test registry-7.4 {GetValueNames: remote key} {nonPortable english} { registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar baz blat - set result [registry values \\\\gaspode\\HKEY_CLASSES_ROOT\\TclFoobar] + set result [registry values \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar] registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar set result } baz @@ -433,7 +443,7 @@ test registry-7.7 {GetValueNames: names with spaces} { set result } {{baz bar} blat} -test registry-8.1 {OpenSubKey} {nonPortable} { +test registry-8.1 {OpenSubKey} {nonPortable english} { list [catch {registry keys {\\petrouchka\HKEY_LOCAL_MACHINE}} msg] $msg } {1 {unable to open key: Access is denied.}} test registry-8.2 {OpenSubKey} { @@ -443,7 +453,7 @@ test registry-8.2 {OpenSubKey} { registry delete HKEY_CLASSES_ROOT\\TclFoobar set result } TclFoobar -test registry-8.3 {OpenSubKey} { +test registry-8.3 {OpenSubKey} {english} { registry delete HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg } {1 {unable to open key: The system cannot find the file specified.}} @@ -460,7 +470,7 @@ test registry-9.3 {ParseKeyName: bad keys} { test registry-9.4 {ParseKeyName: bad keys} { list [catch {registry values \\\\\\} msg] $msg } {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} -test registry-9.5 {ParseKeyName: bad keys} { +test registry-9.5 {ParseKeyName: bad keys} {english} { list [catch {registry values \\\\\\HKEY_CLASSES_ROOT} msg] $msg } {1 {unable to open key: The network address is invalid.}} test registry-9.6 {ParseKeyName: bad keys} { @@ -472,7 +482,7 @@ test registry-9.7 {ParseKeyName: bad keys} { test registry-9.8 {ParseKeyName: null keys} { list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg } {1 {bad key: cannot delete root keys}} -test registry-9.9 {ParseKeyName: null keys} { +test registry-9.9 {ParseKeyName: null keys} {english} { list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar\\baz} msg] $msg } {1 {unable to open key: The system cannot find the file specified.}} @@ -504,9 +514,10 @@ test registry-11.2 {SetValue: modification} { registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat frob set result [registry get HKEY_CLASSES_ROOT\\TclFoobar\\baz blat] } frob -test registry-11.3 {SetValue: failure} {nonPortable} { +test registry-11.3 {SetValue: failure} {nonPortable english} { list [catch {registry set {\\petrouchka\HKEY_CLASSES_ROOT\TclFoobar} bar foobar} msg] $msg } {1 {unable to open key: Access is denied.}} unset hostname +return diff --git a/tests/rename.test b/tests/rename.test index 05f5938..0484108 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) rename.test 1.20 97/06/24 17:26:23 +# SCCS: @(#) rename.test 1.21 97/12/08 15:04:05 if {[string compare test [info procs test]] == 1} then {source defs} @@ -166,7 +166,5 @@ test rename-6.1 {old code invalidated (epoch incremented) when cmd with compile catch {rename incr {}} catch {rename incr.old incr} -# Make the file return an empty string (cleaner.). - -set x "" +return diff --git a/tests/result.test b/tests/result.test new file mode 100644 index 0000000..c511423 --- /dev/null +++ b/tests/result.test @@ -0,0 +1,81 @@ +# This file tests the routines in tclResult.c. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) result.test 1.4 97/12/08 15:07:49 + +if {[info procs test] != "test"} { + source defs +} + +test result-1.1 {Tcl_SaveInterpResult} { + testsaveresult small {set x 42} 0 +} {small result} +test result-1.2 {Tcl_SaveInterpResult} { + testsaveresult append {set x 42} 0 +} {append result} +test result-1.3 {Tcl_SaveInterpResult} { + testsaveresult dynamic {set x 42} 0 +} {dynamic result notCalled present} +test result-1.4 {Tcl_SaveInterpResult} { + testsaveresult object {set x 42} 0 +} {object result same} +test result-1.5 {Tcl_SaveInterpResult} { + testsaveresult small {set x 42} 1 +} {42} +test result-1.6 {Tcl_SaveInterpResult} { + testsaveresult append {set x 42} 1 +} {42} +test result-1.7 {Tcl_SaveInterpResult} { + testsaveresult dynamic {set x 42} 1 +} {42 called missing} +test result-1.8 {Tcl_SaveInterpResult} { + testsaveresult object {set x 42} 1 +} {42 different} + + +# Tcl_RestoreInterpResult is mostly tested by the previous tests except +# for the following case + +test result-2.1 {Tcl_RestoreInterpResult} { + testsaveresult append {cd _foobar} 0 +} {append result} + +# Tcl_DiscardInterpResult is mostly tested by the previous tests except +# for the following cases + +test result-3.1 {Tcl_DiscardInterpResult} { + list [catch {testsaveresult append {cd _foobar} 1} msg] $msg +} {1 {couldn't change working directory to "_foobar": no such file or directory}} +test result-3.2 {Tcl_DiscardInterpResult} { + testsaveresult free {set x 42} 1 +} {42} + +test result-4.1 {Tcl_SetObjErrorCode - one arg} { + catch {testsetobjerrorcode 1} + list [set errorCode] +} {1} +test result-4.2 {Tcl_SetObjErrorCode - two args} { + catch {testsetobjerrorcode 1 2} + list [set errorCode] +} {{1 2}} +test result-4.3 {Tcl_SetObjErrorCode - three args} { + catch {testsetobjerrorcode 1 2 3} + list [set errorCode] +} {{1 2 3}} +test result-4.4 {Tcl_SetObjErrorCode - four args} { + catch {testsetobjerrorcode 1 2 3 4} + list [set errorCode] +} {{1 2 3 4}} +test result-4.5 {Tcl_SetObjErrorCode - five args} { + catch {testsetobjerrorcode 1 2 3 4 5} + list [set errorCode] +} {{1 2 3 4 5}} +return diff --git a/tests/safe.test b/tests/safe.test index c23f06a..36fcbd2 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) safe.test 1.34 97/11/19 14:59:13 +# SCCS: @(#) safe.test 1.35 97/12/08 15:06:30 if {[string compare test [info procs test]] == 1} then {source defs} @@ -431,3 +431,5 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} { } + +return diff --git a/tests/scan.test b/tests/scan.test index 50bf876..c9e204c 100644 --- a/tests/scan.test +++ b/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.26 97/08/06 08:56:08 +# SCCS: @(#) scan.test 1.31 98/01/05 15:24:00 if {[string compare test [info procs test]] == 1} then {source defs} @@ -65,7 +65,7 @@ test scan-1.11 {integer scanning} {nonPortable} { list [scan "4294967280 4294967280" "%u %d" a b] $a $b } {2 4294967280 -16} -test scan-2.1 {floating-point scanning} { +test scan-2.1 {floating-point scanning} {eformat} { set a {}; set b {}; set c {}; set d {} list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d } {3 2.1 -300000000.0 0.99962 {}} @@ -89,7 +89,7 @@ test scan-2.5 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d } {4 4.6 99999.7 87.643 118.0} -test scan-2.6 {floating-point scanning} { +test scan-2.6 {floating-point scanning} {eformat} { set a {}; set b {}; set c {}; set d {} list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d } {4 1.2345 0.697 124.0 5e-05} @@ -122,6 +122,14 @@ test scan-3.5 {string and character scanning} { set a {}; set b {}; set c {} list [scan "aaaaaabc aaabcdefg + + XYZQR" {%*4[a] %s %*4[a]%s%*4[ +]%c} a b c] $a $b $c } {3 aabc bcdefg 43} +test scan-3.6 {string and character scanning, unicode} { + set a {}; set b {}; set c {}; set d {} + list [scan "abc d\u00c7fghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d +} "4 abc d\u00c7f ghijk dum" +test scan-3.7 {string and character scanning, unicode} { + set a {}; set b {} + list [scan "ab\u00c7cdef" "ab%c%c" a b] $a $b +} "2 199 99" test scan-4.1 {error conditions} { catch {scan a} @@ -223,6 +231,11 @@ test scan-6.4 {miscellaneous tests} { set a {} list [catch {scan ab%c14 ab%%c%d a} msg] $msg $a } {0 1 14} +test scan-6.5 {miscellaneous tests} { + catch {unset arr} + set arr(2) {} + list [catch {scan ab%c14 ab%%c%d arr(2)} msg] $msg $arr(2) +} {0 1 14} test scan-7.1 {alignment in results array (TCL_ALIGN)} { scan "123 13.6" "%s %f" a b @@ -244,3 +257,5 @@ test scan-7.5 {alignment in results array (TCL_ALIGN)} { scan "1234567890123456789 13.6" "%s %f" a b set b } 13.6 + +return diff --git a/tests/security.test b/tests/security.test new file mode 100644 index 0000000..9f198ba --- /dev/null +++ b/tests/security.test @@ -0,0 +1,36 @@ +# Functionality covered: this file contains a collection of tests for the +# auto loading and namespaces. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) security.test 1.1 97/11/20 16:38:33 + + +if {[string compare test [info procs test]] == 1} then {source defs} + +# If this proc becomes invoked, then there is a bug + +proc BUG {args} { + set ::BUG 1 +} + +# Check and Clear the bug flag (to do before each test) +set ::BUG 0 + +proc CB {} { + set ret $::BUG + set ::BUG 0 + return $ret +} + + +test sec-1.1 {tcl_endOfPreviousWord} { + catch {tcl_startOfPreviousWord x {[BUG]}} + CB +} 0 diff --git a/tests/set-old.test b/tests/set-old.test index a101e7b..f77709b 100644 --- a/tests/set-old.test +++ b/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.22 97/10/29 14:05:07 +# SCCS: @(#) set-old.test 1.25 97/12/16 13:35:36 if {[string compare test [info procs test]] == 1} then {source defs} @@ -768,4 +768,4 @@ catch {unset a} catch {unset b} catch {unset c} catch {unset aVaRnAmE} -return "" +return diff --git a/tests/set.test b/tests/set.test index 4d0f352..1b138d2 100644 --- a/tests/set.test +++ b/tests/set.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: @(#) set.test 1.6 97/06/23 18:18:54 +# SCCS: @(#) set.test 1.9 97/12/16 13:35:44 if {[string compare test [info procs test]] == 1} then {source defs} @@ -27,7 +27,7 @@ test set-1.3 {TclCompileSetCmd: error compiling variable name} { set i 10 catch {set "i"xxx} msg set msg -} {quoted string doesn't terminate properly} +} {extra characters after close-quote} test set-1.4 {TclCompileSetCmd: simple variable name in quotes} { set i 17 list [set "i"] $i @@ -226,8 +226,257 @@ test set-2.6 {set command: runtime error, basic array operations} { list [catch {set a} msg] $msg } {1 {can't read "a": variable is array}} +# Test the uncompiled version of set + +catch {unset a} +catch {unset b} +catch {unset i} +catch {unset x} + +test set-3.1 {uncompiled set command: missing variable name} { + set z set + list [catch {$z} msg] $msg +} {1 {wrong # args: should be "set varName ?newValue?"}} +test set-3.2 {uncompiled set command: simple variable name} { + set z set + $z i 10 + list [$z i] $i +} {10 10} +test set-3.3 {uncompiled set command: error compiling variable name} { + set z set + $z i 10 + catch {$z "i"xxx} msg + $z msg +} {extra characters after close-quote} +test set-3.4 {uncompiled set command: simple variable name in quotes} { + set z set + $z i 17 + list [$z "i"] $i +} {17 17} +test set-3.5 {uncompiled set command: simple variable name in braces} { + set z set + catch {unset {a simple var}} + $z {a simple var} 27 + list [$z {a simple var}] ${a simple var} +} {27 27} +test set-3.6 {uncompiled set command: simple array variable name} { + set z set + catch {unset a} + $z a(foo) 37 + list [$z a(foo)] $a(foo) +} {37 37} +test set-3.7 {uncompiled set command: non-simple (computed) variable name} { + set z set + $z x "i" + $z i 77 + list [$z $x] $i +} {77 77} +test set-3.8 {uncompiled set command: non-simple (computed) variable name} { + set z set + $z x "i" + $z i 77 + list [$z [$z x] 2] $i +} {2 2} + +test set-3.9 {uncompiled set command: 3rd arg => assignment} { + set z set + $z i "abcdef" + list [$z i] $i +} {abcdef abcdef} +test set-3.10 {uncompiled set command: only two args => just getting value} { + set z set + $z i {one two} + $z i +} {one two} + +test set-3.11 {uncompiled set command: simple global name} { + proc p {} { + set z set + global i + $z i 54 + $z i + } + p +} {54} +test set-3.12 {uncompiled set command: simple local name} { + proc p {bar} { + set z set + $z foo $bar + $z foo + } + p 999 +} {999} +test set-3.13 {uncompiled set command: simple but new (unknown) local name} { + set z set + proc p {} { + set z set + $z bar + } + catch {p} msg + $z msg +} {can't read "bar": no such variable} +test set-3.14 {uncompiled set command: simple local name, >255 locals} { + proc 260locals {} { + set z set + # create 260 locals (the last ones with index > 255) + $z a0 0; $z a1 0; $z a2 0; $z a3 0; $z a4 0 + $z a5 0; $z a6 0; $z a7 0; $z a8 0; $z a9 0 + $z b0 0; $z b1 0; $z b2 0; $z b3 0; $z b4 0 + $z b5 0; $z b6 0; $z b7 0; $z b8 0; $z b9 0 + $z c0 0; $z c1 0; $z c2 0; $z c3 0; $z c4 0 + $z c5 0; $z c6 0; $z c7 0; $z c8 0; $z c9 0 + $z d0 0; $z d1 0; $z d2 0; $z d3 0; $z d4 0 + $z d5 0; $z d6 0; $z d7 0; $z d8 0; $z d9 0 + $z e0 0; $z e1 0; $z e2 0; $z e3 0; $z e4 0 + $z e5 0; $z e6 0; $z e7 0; $z e8 0; $z e9 0 + $z f0 0; $z f1 0; $z f2 0; $z f3 0; $z f4 0 + $z f5 0; $z f6 0; $z f7 0; $z f8 0; $z f9 0 + $z g0 0; $z g1 0; $z g2 0; $z g3 0; $z g4 0 + $z g5 0; $z g6 0; $z g7 0; $z g8 0; $z g9 0 + $z h0 0; $z h1 0; $z h2 0; $z h3 0; $z h4 0 + $z h5 0; $z h6 0; $z h7 0; $z h8 0; $z h9 0 + $z i0 0; $z i1 0; $z i2 0; $z i3 0; $z i4 0 + $z i5 0; $z i6 0; $z i7 0; $z i8 0; $z i9 0 + $z j0 0; $z j1 0; $z j2 0; $z j3 0; $z j4 0 + $z j5 0; $z j6 0; $z j7 0; $z j8 0; $z j9 0 + $z k0 0; $z k1 0; $z k2 0; $z k3 0; $z k4 0 + $z k5 0; $z k6 0; $z k7 0; $z k8 0; $z k9 0 + $z l0 0; $z l1 0; $z l2 0; $z l3 0; $z l4 0 + $z l5 0; $z l6 0; $z l7 0; $z l8 0; $z l9 0 + $z m0 0; $z m1 0; $z m2 0; $z m3 0; $z m4 0 + $z m5 0; $z m6 0; $z m7 0; $z m8 0; $z m9 0 + $z n0 0; $z n1 0; $z n2 0; $z n3 0; $z n4 0 + $z n5 0; $z n6 0; $z n7 0; $z n8 0; $z n9 0 + $z o0 0; $z o1 0; $z o2 0; $z o3 0; $z o4 0 + $z o5 0; $z o6 0; $z o7 0; $z o8 0; $z o9 0 + $z p0 0; $z p1 0; $z p2 0; $z p3 0; $z p4 0 + $z p5 0; $z p6 0; $z p7 0; $z p8 0; $z p9 0 + $z q0 0; $z q1 0; $z q2 0; $z q3 0; $z q4 0 + $z q5 0; $z q6 0; $z q7 0; $z q8 0; $z q9 0 + $z r0 0; $z r1 0; $z r2 0; $z r3 0; $z r4 0 + $z r5 0; $z r6 0; $z r7 0; $z r8 0; $z r9 0 + $z s0 0; $z s1 0; $z s2 0; $z s3 0; $z s4 0 + $z s5 0; $z s6 0; $z s7 0; $z s8 0; $z s9 0 + $z t0 0; $z t1 0; $z t2 0; $z t3 0; $z t4 0 + $z t5 0; $z t6 0; $z t7 0; $z t8 0; $z t9 0 + $z u0 0; $z u1 0; $z u2 0; $z u3 0; $z u4 0 + $z u5 0; $z u6 0; $z u7 0; $z u8 0; $z u9 0 + $z v0 0; $z v1 0; $z v2 0; $z v3 0; $z v4 0 + $z v5 0; $z v6 0; $z v7 0; $z v8 0; $z v9 0 + $z w0 0; $z w1 0; $z w2 0; $z w3 0; $z w4 0 + $z w5 0; $z w6 0; $z w7 0; $z w8 0; $z w9 0 + $z x0 0; $z x1 0; $z x2 0; $z x3 0; $z x4 0 + $z x5 0; $z x6 0; $z x7 0; $z x8 0; $z x9 0 + $z y0 0; $z y1 0; $z y2 0; $z y3 0; $z y4 0 + $z y5 0; $z y6 0; $z y7 0; $z y8 0; $z y9 0 + $z z0 0; $z z1 0; $z z2 0; $z z3 0; $z z4 0 + $z z5 0; $z z6 0; $z z7 0; $z z8 0; $z z9 1234 + } + 260locals +} {1234} +test set-3.15 {uncompiled set command: variable is array} { + set z set + catch {unset a} + $z x 27 + $z x [$z a(foo) 11] + catch {unset a} + $z x +} 11 +test set-3.16 {uncompiled set command: variable is array, elem substitutions} { + set z set + catch {unset a} + $z i 5 + $z x 789 + $z a(foo5) 27 + $z x [$z a(foo$i)] + catch {unset a} + $z x +} 27 + +test set-3.17 {uncompiled set command: doing assignment, simple int} { + set z set + $z i 5 + $z i 123 +} 123 +test set-3.18 {uncompiled set command: doing assignment, simple int} { + set z set + $z i 5 + $z i -100 +} -100 +test set-3.19 {uncompiled set command: doing assignment, simple but not int} { + set z set + $z i 5 + $z i 0x12MNOP + $z i +} {0x12MNOP} +test set-3.20 {uncompiled set command: doing assignment, in quotes} { + set z set + $z i 25 + $z i "-100" +} -100 +test set-3.21 {uncompiled set command: doing assignment, in braces} { + set z set + $z i 24 + $z i {126} +} 126 +test set-3.22 {uncompiled set command: doing assignment, large int} { + set z set + $z i 5 + $z i 200000 +} 200000 +test set-3.23 {uncompiled set command: doing assignment, formatted int != int} { + set z set + $z i 25 + $z i 000012345 ;# an octal literal == 5349 decimal + list $i [incr i] +} {000012345 5350} + +test set-3.24 {uncompiled set command: too many arguments} { + set z set + $z i 10 + catch {$z i 20 30} msg + $z msg +} {wrong # args: should be "set varName ?newValue?"} + +test set-4.1 {uncompiled set command: runtime error, bad variable name} { + set z set + list [catch {$z {"foo}} msg] $msg $errorInfo +} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable + while executing +"$z {"foo}"}} +test set-4.2 {uncompiled set command: runtime error, not array variable} { + set z set + catch {unset b} + $z b 44 + list [catch {$z b(123)} msg] $msg +} {1 {can't read "b(123)": variable isn't array}} +test set-4.3 {uncompiled set command: runtime error, errors in reading variables} { + set z set + catch {unset a} + $z a(6) 44 + list [catch {$z a(18)} msg] $msg +} {1 {can't read "a(18)": no such element in array}} +test set-4.4 {uncompiled set command: runtime error, readonly variable} { + set z set + proc readonly args {error "variable is read-only"} + $z x 123 + trace var x w readonly + list [catch {$z x 1} msg] $msg $errorInfo +} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only + while executing +"$z x 1"}} +test set-4.5 {uncompiled set command: runtime error, basic array operations} { + set z set + list [catch {$z a(other)} msg] $msg +} {1 {can't read "a(other)": no such element in array}} +test set-4.6 {set command: runtime error, basic array operations} { + set z set + list [catch {$z a} msg] $msg +} {1 {can't read "a": variable is array}} + catch {unset a} catch {unset b} catch {unset i} catch {unset x} -return "" +catch {unset z} +return diff --git a/tests/socket.test b/tests/socket.test index b2719de..30a3746 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -59,7 +59,7 @@ # listening at port 2048. If all fails, a message is printed and the tests # using the remote server are not performed. # -# SCCS: @(#) socket.test 1.83 97/09/15 16:29:47 +# SCCS: @(#) socket.test 1.86 98/01/02 17:33:48 if {[string compare test [info procs test]] == 1} then {source defs} @@ -221,7 +221,7 @@ socket ?-myaddr addr? ?-myport myport? ?-async? host port socket -server command ?-myaddr addr? port}} test socket-1.8 {arg parsing for socket command} { list [catch {socket -froboz} msg] $msg -} {1 {bad option "-froboz", must be -async, -myaddr, -myport, or -server}} +} {1 {bad option "-froboz": must be -async, -myaddr, -myport, or -server}} test socket-1.9 {arg parsing for socket command} { list [catch {socket -server foo -myport 2521 3333} msg] $msg } {1 {Option -myport is not valid for servers}} @@ -484,12 +484,14 @@ test socket-2.8 {echo server, loop 50 times, single connection} {stdio} { gets $f set s [socket localhost 2828] fconfigure $s -buffering line - for {set x 0} {$x < 50} {incr x} { - puts $s "hello abcdefghijklmnop" - gets $s + catch { + for {set x 0} {$x < 50} {incr x} { + puts $s "hello abcdefghijklmnop" + gets $s + } } close $s - set x [gets $f] + catch {set x [gets $f]} close $f set x } {done 50} @@ -497,7 +499,7 @@ 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]} + puts -nonewline $f {socket -server accept 2828} close $f set f [open "|[list $tcltest script]" r] gets $f @@ -795,7 +797,7 @@ test socket-7.3 {testing socket specific options} { close $s update llength $l -} 10 +} 12 test socket-7.4 {testing socket specific options} { set s [socket -server accept 2823] proc accept {s a p} { @@ -981,6 +983,18 @@ test socket-9.3 {testing EOF stickyness} { removeFile script +test socket-10.1 {testing socket accept callback error handling} { + set goterror 0 + proc bgerror args {global goterror; set goterror 1} + set s [socket -server accept 2898] + proc accept {s a p} {close $s; error} + set c [socket localhost 2898] + vwait goterror + close $s + close $c + set goterror +} 1 + # # The rest of the tests are run only if we are doing testing against # a remote server. @@ -990,7 +1004,7 @@ if {$doTestsWithRemoteServer == 0} { return } -test socket-10.1 {tcp connection} { +test socket-11.1 {tcp connection} { sendCommand { set socket9_1_test_server [socket -server accept 2834] proc accept {s a p} { @@ -1004,7 +1018,7 @@ test socket-10.1 {tcp connection} { sendCommand {close $socket9_1_test_server} set r } done -test socket-10.2 {client specifies its port} { +test socket-11.2 {client specifies its port} { if {[info exists port]} { incr port } else { @@ -1028,10 +1042,7 @@ test socket-10.2 {client specifies its port} { } set result } ok -# -# Tests io-10.3, io-10.4 have been removed. -# -test socket-10.3 {trying to connect, no server} { +test socket-11.3 {trying to connect, no server} { set status ok if {![catch {set s [socket $remoteServerIp 2836]}]} { if {![catch {gets $s}]} { @@ -1041,7 +1052,7 @@ test socket-10.3 {trying to connect, no server} { } set status } ok -test socket-10.4 {remote echo, one line} { +test socket-11.4 {remote echo, one line} { sendCommand { set socket10_6_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1065,7 +1076,7 @@ test socket-10.4 {remote echo, one line} { sendCommand {close $socket10_6_test_server} set r } hello -test socket-10.5 {remote echo, 50 lines} { +test socket-11.5 {remote echo, 50 lines} { sendCommand { set socket10_7_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1099,7 +1110,7 @@ if {$tcl_platform(platform) == "macintosh"} { } else { set conflictResult {1 {couldn't open socket: address already in use}} } -test socket-10.6 {socket conflict} { +test socket-11.6 {socket conflict} { set s1 [socket -server accept 2836] if {[catch {set s2 [socket -server accept 2836]} msg]} { set result [list 1 $msg] @@ -1110,7 +1121,7 @@ test socket-10.6 {socket conflict} { close $s1 set result } $conflictResult -test socket-10.7 {server with several clients} { +test socket-11.7 {server with several clients} { sendCommand { set socket10_9_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1146,7 +1157,7 @@ test socket-10.7 {server with several clients} { sendCommand {close $socket10_9_test_server} set i } 100 -test socket-10.8 {client with several servers} { +test socket-11.8 {client with several servers} { sendCommand { set s1 [socket -server "accept 4003" 4003] set s2 [socket -server "accept 4004" 4004] @@ -1172,7 +1183,7 @@ test socket-10.8 {client with several servers} { } set l } {4003 {} 1 4004 {} 1 4005 {} 1} -test socket-10.9 {accept callback error} { +test socket-11.9 {accept callback error} { set s [socket -server accept 2836] proc accept {s a p} {expr 10 / 0} proc bgerror args { @@ -1194,7 +1205,7 @@ test socket-10.9 {accept callback error} { rename bgerror {} set x } {{divide by zero}} -test socket-10.10 {testing socket specific options} { +test socket-11.10 {testing socket specific options} { sendCommand { set socket10_12_test_server [socket -server accept 2836] proc accept {s a p} {close $s} @@ -1208,7 +1219,7 @@ test socket-10.10 {testing socket specific options} { sendCommand {close $socket10_12_test_server} set l } {2836 3 3} -test socket-10.11 {testing spurious events} { +test socket-11.11 {testing spurious events} { sendCommand { set socket10_13_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1247,7 +1258,7 @@ test socket-10.11 {testing spurious events} { sendCommand {close $socket10_13_test_server} list $spurious $len } {0 2690} -test socket-10.12 {testing EOF stickyness} { +test socket-11.12 {testing EOF stickyness} { set counter 0 set done 0 proc count_up {s} { @@ -1280,7 +1291,7 @@ test socket-10.12 {testing EOF stickyness} { sendCommand {close $socket10_14_test_server} set done } {EOF is sticky} -test socket-10.13 {testing async write, async flush, async close} { +test socket-11.13 {testing async write, async flush, async close} { proc readit {s} { global count done set l [read $s] @@ -1340,5 +1351,4 @@ if {[string match sock* $commandSocket] == 1} { catch {close $commandSocket} catch {close $remoteProcChan} -set x "" -unset x +return diff --git a/tests/source.test b/tests/source.test index 9a7e230..c2ed57a 100644 --- a/tests/source.test +++ b/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.26 97/09/24 16:33:37 +# SCCS: @(#) source.test 1.30 98/01/05 16:17:37 if {[string compare test [info procs test]] == 1} then {source defs} @@ -30,23 +30,19 @@ test source-1.2 {source command} { makeFile {list result} source.file source source.file } result +test source-1.3 {source command} { + set y {\ } -# The mac version of source returns a different result for -# the next two tests. + set fd [open source.file w] + fconfigure $fd -translation lf + puts -nonewline $fd "list a b c " + puts $fd [string index $y 0] + puts $fd "d e f" + close $fd + + source source.file +} {a b c d e f} -if {$tcl_platform(platform) == "macintosh"} { - set retMsg1 {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} - set retMsg2 {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} -} else { - set retMsg1 {1 {wrong # args: should be "source fileName"}} - set retMsg2 {1 {wrong # args: should be "source fileName"}} -} -test source-2.1 {source error conditions} { - list [catch {source} msg] $msg -} $retMsg1 -test source-2.2 {source error conditions} { - list [catch {source a b} msg] $msg -} $retMsg2 test source-2.3 {source error conditions} { makeFile { set x 146 @@ -132,13 +128,13 @@ test source-4.2 {source error conditions} {macOnly} { } [list 1 "expected integer but got \"bad_id\""] test source-4.3 {source error conditions} {macOnly} { list [catch {source -rsrc rsrcName fileName extra} msg] $msg -} $retMsg1 +} {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} test source-4.4 {source error conditions} {macOnly} { list [catch {source non_switch rsrcName} msg] $msg -} $retMsg2 +} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} test source-4.5 {source error conditions} {macOnly} { list [catch {source -bad_switch argument} msg] $msg -} $retMsg2 +} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} test source-5.1 {source resource files} {macOnly} { list [catch {source -rsrc rsrcName bad_file} msg] $msg } [list 1 "Error finding the file: \"bad_file\"."] @@ -182,6 +178,4 @@ test source-6.1 {source is binary ok} { catch {removeFile source.file} -# Generate null final value - -concat {} +return diff --git a/tests/stringObj.test b/tests/stringObj.test index 3d03bad..a4efc8b 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.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. # -# @(#) stringObj.test 1.8 97/04/09 11:29:37 +# @(#) stringObj.test 1.9 97/12/08 15:06:42 if {[info commands testobj] == {}} { puts "This application hasn't been compiled with the \"testobj\"" @@ -187,3 +187,4 @@ test stringObj-8.1 {DupStringInternalRep procedure} { } {5 10 5 5 abcde} testobj freeallvars +return diff --git a/tests/subst.test b/tests/subst.test index 356114d..41afa48 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) subst.test 1.8 97/06/23 18:20:15 +# SCCS: @(#) subst.test 1.10 97/12/08 15:04:29 if {[string compare test [info procs test]] == 1} then {source defs} @@ -84,7 +84,7 @@ test subst-7.1 {switches} { } {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}} test subst-7.2 {switches} { list [catch {subst -no bar} msg] $msg -} {1 {bad switch "-no": must be -nobackslashes, -nocommands, or -novariables}} +} {1 {ambiguous switch "-no": must be -nobackslashes, -nocommands, or -novariables}} test subst-7.3 {switches} { list [catch {subst -bogus bar} msg] $msg } {1 {bad switch "-bogus": must be -nobackslashes, -nocommands, or -novariables}} @@ -104,3 +104,5 @@ test subst-7.7 {switches} { set x 123 subst -nov -nob -noc {abc $x [expr 1+2] \\\x41} } {abc $x [expr 1+2] \\\x41} + +return diff --git a/tests/switch.test b/tests/switch.test index 347e7a5..d272836 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) switch.test 1.7 97/02/10 17:27:13 +# SCCS: @(#) switch.test 1.8 97/12/08 15:04:33 if {[string compare test [info procs test]] == 1} then {source defs} @@ -177,3 +177,5 @@ test switch-8.1 {empty body} { default {set msg 2} } } {} + +return diff --git a/tests/thread.test b/tests/thread.test new file mode 100644 index 0000000..a68f54e --- /dev/null +++ b/tests/thread.test @@ -0,0 +1,217 @@ +# Commands covered: (test)thread +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) thread.test 1.4 98/02/19 11:53:53 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {[info command testthread] == ""} { + return +} + +set mainthread [testthread names] +proc ThreadReap {} { + global mainthread + testthread errorproc ThreadNullError + while {[llength [testthread names]] > 1} { + foreach tid [testthread names] { + if {$tid != $mainthread} { + catch {testthread send -async $tid {testthread exit}} + update + } + } + } + testthread errorproc ThreadError + return [llength [testthread names]] +} +testthread errorproc ThreadError +proc ThreadError {id info} { + global threadError + set threadError $info +} +proc ThreadNullError {id info} { + # ignore +} + +test thread-1.1 {Tcl_ThreadObjCmd: no args} { + list [catch {testthread} msg] $msg +} {1 {wrong # args: should be "testthread option ?args?"}} + +test thread-1.2 {Tcl_ThreadObjCmd: bad option} { + list [catch {testthread foo} msg] $msg +} {1 {bad option "foo": must be create, exit, id, names, send, wait, or errorproc}} + +test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} { + list [catch {testthread names} mainthread] [llength $mainthread] +} {0 1} + +test thread-1.4 {Tcl_ThreadObjCmd: thread create } { + set serverthread [testthread create] + update + set numthreads [llength [testthread names]] +} {2} +ThreadReap + +test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} { + testthread create {set x 5} + foreach try {0 1 2 4 5 6} { + update + set l [llength [testthread names]] + if {$l == 1} { + break + } + } + set l +} {1} +ThreadReap + +test thread-1.6 {Tcl_ThreadObjCmd: thread exit} { + testthread create {testthread exit} + update + llength [testthread names] +} {1} +ThreadReap + +test thread-1.7 {Tcl_ThreadObjCmd: thread id args} { + set x [catch {testthread id x} msg] + list $x $msg +} {1 {wrong # args: should be "testthread id"}} + +test thread-1.8 {Tcl_ThreadObjCmd: thread id} { + string compare [testthread id] $mainthread +} {0} + +test thread-1.9 {Tcl_ThreadObjCmd: thread names args} { + set x [catch {testthread names x} msg] + list $x $msg +} {1 {wrong # args: should be "testthread names"}} + +test thread-1.10 {Tcl_ThreadObjCmd: thread id} { + string compare [testthread names] $mainthread +} {0} + +test thread-1.11 {Tcl_ThreadObjCmd: send args} { + set x [catch {testthread send} msg] + list $x $msg +} {1 {wrong # args: should be "testthread send ?-async? id script"}} + +test thread-1.12 {Tcl_ThreadObjCmd: send nonint} { + set x [catch {testthread send abc command} msg] + list $x $msg +} {1 {expected integer but got "abc"}} + +test thread-1.13 {Tcl_ThreadObjCmd: send args} { + set serverthread [testthread create] + set five [testthread send $serverthread {set x 5}] + ThreadReap + set five +} 5 + +test thread-1.14 {Tcl_ThreadObjCmd: send bad id} { + set tid [expr $mainthread + 10] + set x [catch {testthread send $tid {set x 5}} msg] + list $x $msg +} {1 {invalid thread id}} + +test thread-1.15 {Tcl_ThreadObjCmd: wait} { + set serverthread [testthread create {set z 5 ; testthread wait}] + set five [testthread send $serverthread {set z}] + ThreadReap + set five +} 5 + +test thread-1.16 {Tcl_ThreadObjCmd: errorproc args} { + set x [catch {testthread errorproc foo bar} msg] + list $x $msg +} {1 {wrong # args: should be "testthread errorproc proc"}} + +test thread-1.17 {Tcl_ThreadObjCmd: errorproc change} { + testthread errorproc foo + testthread errorproc ThreadError +} {} + +# The tests above also cover: +# TclCreateThread, except when pthread_create fails +# NewThread, safe and regular +# ThreadErrorProc, except for printing to standard error + +test thread-2.1 {ListUpdateInner and ListRemove} { + catch {unset tid} + foreach t {0 1 2} { + upvar #0 t$t tid + set tid [testthread create] + } + ThreadReap +} 1 + +test thread-3.1 {TclThreadList} { + catch {unset tid} + set mainthread [testthread names] + set l1 {} + foreach t {0 1 2} { + lappend l1 [testthread create] + } + set l2 [testthread names] + list $l1 $l2 + set c [string compare [lsort -integer [concat $mainthread $l1]] [lsort -integer $l2]] + ThreadReap + set c +} 0 + +test thread-4.1 {TclThreadSend to self} { + catch {unset x} + testthread send [testthread id] { + set x 4 + } + set x +} {4} + +test thread-4.1 {TclThreadSend -async} { + set mainthread [testthread names] + set serverthread [testthread create] + testthread send -async $serverthread { + after 1000 + testthread exit + } + set two [llength [testthread names]] + after 1500 {set done 1} + vwait done + list [llength [testthread names]] $two +} {1 2} + +test thread-4.2 {TclThreadSend preserve errorInfo} { + set mainthread [testthread names] + set serverthread [testthread create] + set x [catch {testthread send $serverthread {set undef}} msg] + list $x $msg $errorInfo +} {1 {can't read "undef": no such variable} {can't read "undef": no such variable + while executing +"set undef" + invoked from within +"testthread send $serverthread {set undef}"}} +ThreadReap + +test thread-4.3 {TclThreadSend preserve code} { + set mainthread [testthread names] + set serverthread [testthread create] + set x [catch {testthread send $serverthread {break}} msg] + list $x $msg $errorInfo +} {3 {} {}} +ThreadReap + +test thread-4.4 {TclThreadSend preserve errorCode} { + set mainthread [testthread names] + set serverthread [testthread create] + set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg] + list $x $msg $errorCode +} {1 ERR CODE} +ThreadReap + diff --git a/tests/timer.test b/tests/timer.test index 4671366..1372ffa 100644 --- a/tests/timer.test +++ b/tests/timer.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: @(#) timer.test 1.2 97/04/29 11:59:59 +# SCCS: @(#) timer.test 1.4 97/12/08 15:06:49 if {[string compare test [info procs test]] == 1} then {source defs} @@ -333,12 +333,93 @@ test timer-6.21 {Tcl_AfterCmd, info option} { test timer-6.22 {Tcl_AfterCmd, info option} { list [after info $event1] [after info $event2] } {{{event 1} idle} {{event 2} timer}} + after cancel $event1 after cancel $event2 interp delete x +test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NULL} { + foreach i [after info] { + after cancel $i + } + set x "hello world" + after 1 "set x ab\0cd" + after 10 + update + string length $x +} {5} +test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NULL} { + foreach i [after info] { + after cancel $i + } + set x "hello world" + after 1 set x ab\0cd + after 10 + update + string length $x +} {5} +test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NULL} { + foreach i [after info] { + after cancel $i + } + set x "hello world" + after 1 set x ab\0cd + after cancel "set x ab\0ef" + set x [llength [after info]] + foreach i [after info] { + after cancel $i + } + set x +} {1} +test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NULL} { + foreach i [after info] { + after cancel $i + } + set x "hello world" + after 1 set x ab\0cd + after cancel set x ab\0ef + set y [llength [after info]] + foreach i [after info] { + after cancel $i + } + set y +} {1} +test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NULL} { + foreach i [after info] { + after cancel $i + } + set x "hello world" + after idle "set x ab\0cd" + update + string length $x +} {5} +test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NULL} { + foreach i [after info] { + after cancel $i + } + set x "hello world" + after idle set x ab\0cd + update + string length $x +} {5} +test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NULL} { + foreach i [after info] { + after cancel $i + } + set x "hello world" + set id junk + set id [after 1 set x ab\0cd] + update + set y [string length [lindex [lindex [after info $id] 0] 2]] + foreach i [after info] { + after cancel $i + } + set y +} {5} + set event [after idle foo bar] scan $event after#%d id + test timer-7.1 {GetAfterEvent procedure} { list [catch {after info xfter#$id} msg] $msg } "1 {event \"xfter#$id\" doesn't exist}" @@ -453,3 +534,4 @@ test timer-9.1 {AfterCleanupProc procedure} { set x } {before after2 after4} +return diff --git a/tests/trace.test b/tests/trace.test index b4d02d3..3a80f08 100644 --- a/tests/trace.test +++ b/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.27 97/07/23 17:08:38 +# SCCS: @(#) trace.test 1.29 97/12/08 15:04:36 if {[string compare test [info procs test]] == 1} then {source defs} @@ -610,10 +610,10 @@ test trace-12.1 {delete one trace from another} { test trace-13.1 {trace command (overall)} { list [catch {trace} msg] $msg -} {1 {too few args: should be "trace option [arg arg ...]"}} +} {1 {wrong # args: should be "trace option [arg arg ...]"}} test trace-13.2 {trace command (overall)} { list [catch {trace gorp} msg] $msg -} {1 {bad option "gorp": should be variable, vdelete, or vinfo}} +} {1 {bad option "gorp": must be variable, vdelete, or vinfo}} test trace-13.3 {trace command ("variable" option)} { list [catch {trace variable x y} msg] $msg } {1 {wrong # args: should be "trace variable name ops command"}} @@ -963,4 +963,4 @@ test trace-17.1 {unset traces on procedure returns} { catch {unset x} catch {unset y} -concat {} +return diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 037b5b4..2f3fe9e 100644 --- a/tests/unixFCmd.test +++ b/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.15 97/11/03 15:58:22 +# SCCS: @(#) unixFCmd.test 1.17 97/12/08 15:05:53 if {[string compare test [info procs test]] == 1} then {source defs} @@ -166,7 +166,7 @@ if {[catch {exec {groups}} groupList] == 0} { test unixFCmd-12.1 {GetGroupAttribute - file not found} { catch {file delete -force -- foo.test} list [catch {file attributes foo.test -group} msg] $msg -} {1 {could not stat file "foo.test": no such file or directory}} +} {1 {could not read "foo.test": no such file or directory}} test unixFCmd-12.2 {GetGroupAttribute - file found} { catch {file delete -force -- foo.test} close [open foo.test w] @@ -176,7 +176,7 @@ test unixFCmd-12.2 {GetGroupAttribute - file found} { test unixFCmd-13.1 {GetOwnerAttribute - file not found} { catch {file delete -force -- foo.test} list [catch {file attributes foo.test -group} msg] $msg -} {1 {could not stat file "foo.test": no such file or directory}} +} {1 {could not read "foo.test": no such file or directory}} test unixFCmd-13.2 {GetOwnerAttribute} { catch {file delete -force -- foo.test} close [open foo.test w] @@ -186,7 +186,7 @@ test unixFCmd-13.2 {GetOwnerAttribute} { test unixFCmd-14.1 {GetPermissionsAttribute - file not found} { catch {file delete -force -- foo.test} list [catch {file attributes foo.test -permissions} msg] $msg -} {1 {could not stat file "foo.test": no such file or directory}} +} {1 {could not read "foo.test": no such file or directory}} test unixFCmd-14.2 {GetPermissionsAttribute} { catch {file delete -force -- foo.test} close [open foo.test w] @@ -249,3 +249,4 @@ test unixFCmd-18.1 {Unix pwd} {nonPortable} { } {1 {error getting working directory name:}} cleanup +return diff --git a/tests/unixInit.test b/tests/unixInit.test new file mode 100644 index 0000000..112552d --- /dev/null +++ b/tests/unixInit.test @@ -0,0 +1,155 @@ +# The file tests the functions in the tclUnixInit.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) unixInit.test 1.4 98/01/13 20:03:07 + +if {[info procs test] != "test"} {source defs} + +if {$tcl_platform(platform) != "unix"} { + return +} + +if {[catch {csh -c "setenv LANG japanese"}] == 0} { + set testConfig(japanese) 1 +} + +catch {set oldlibrary $env(TCL_LIBRARY); unset env(TCL_LIBRARY)} +catch {set oldlang $env(LANG)} +set env(LANG) C + +test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} { + set x {} + + set f [open "|[list $tcltest]" w+] + exec kill -PIPE [pid $f] + lappend x [catch {close $f}] + + set f [open "|[list $tcltest]" w+] + exec kill [pid $f] + lappend x [catch {close $f}] + + set x +} {0 1} + +proc getlibpath "{program [list $tcltest]}" { + set f [open "|$program" w+] + fconfigure $f -buffering none + puts $f {puts $tcl_libPath; exit} + set path [gets $f] + close $f + return $path +} +test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} { + set path [getlibpath] + + set installLib lib/tcl[info tclversion] + if {[string match {*[ab]*} [info patchlevel]]} { + set developLib tcl[info patchlevel]/library + } else { + set developLib tcl[info tclversion]/library + } + set prefix [file dirname [file dirname $tcltest]] + + set x {} + lappend x [string compare [lindex $path 1] $prefix/$installLib] + lappend x [string compare [lindex $path 2] [file dirname $prefix]/$developLib] + set x +} {0 0} +test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} { + # ((str != NULL) && (str[0] != '\0')) + + set env(TCL_LIBRARY) sparkly + set path [getlibpath] + unset env(TCL_LIBRARY) + + lindex $path 0 +} "sparkly" +test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} { + # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0)) + + set env(TCL_LIBRARY) /a/b/tcl1.7 + set path [getlibpath] + unset env(TCL_LIBRARY) + + lrange $path 0 1 +} [list /a/b/tcl1.7 /a/b/tcl[info tclversion]] +test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} { + # Child process translates env variable from native encoding. + + set env(TCL_LIBRARY) "\xa7" + set x [lindex [getlibpath] 0] + unset env(TCL_LIBRARY) + unset env(LANG) + + set x +} "\xa7" +test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} { + # cannot test +} {} +test unixInit-2.6 {TclpInitLibraryPath: executable relative} { + file delete -force /tmp/sparkly + file mkdir /tmp/sparkly/bin + file copy $tcltest /tmp/sparkly/bin/tcltest + + file mkdir /tmp/sparkly/lib/tcl[info tclversion] + close [open /tmp/sparkly/lib/tcl[info tclversion]/init.tcl w] + + set x [lrange [getlibpath /tmp/sparkly/bin/tcltest] 1 2] + file delete -force /tmp/sparkly + set x +} [list /tmp/sparkly/lib/tcl[info tclversion] /tmp/tcl[info patchlevel]/library] +test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} { + # would need test command to get defaultLibDir and compare it to + # [lindex $auto_path end] +} {} +test unixInit-3.1 {TclpSetInitialEncodings} { + set env(LANG) C + + set f [open "|[list $tcltest]" w+] + fconfigure $f -buffering none + puts $f {puts [testencoding system]; exit} + set enc [gets $f] + close $f + unset env(LANG) + + set enc +} {iso8859-1} +test unixInit-3.1 {TclpSetInitialEncodings} {japanese nonPortable} { + set env(LANG) japanese + + set f [open "|[list $tcltest]" w+] + fconfigure $f -buffering none + puts $f {puts [testencoding system]; exit} + set enc [gets $f] + close $f + unset env(LANG) + + set enc +} {euc-jp} + +test unixInit-4.1 {TclpSetVariables} { + # just make sure they exist + + set a [list $tcl_library $tcl_pkgPath $tcl_platform(os)] + set a [list $tcl_platform(osVersion) $tcl_platform(machine)] + set tcl_platform(platform) +} "unix" + +test unixInit-5.1 {Tcl_Init} { + # test initScript +} {} + +test unixInit-6.1 {Tcl_SourceRCFile} { +} {} + +catch {unset env(TCL_LIBRARY); set env(TCL_LIBRARY) $oldlibrary} +catch {unset env(LANG); set env(LANG) $oldlang} +return diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 5ed5f12..262131f 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.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: @(#) unixNotfy.test 1.3 97/09/15 15:39:53 +# SCCS: @(#) unixNotfy.test 1.7 98/02/17 23:45:12 if {[string compare test [info procs test]] == 1} then {source defs} @@ -19,9 +19,9 @@ if {$tcl_platform(platform) != "unix"} { # The tests should not be run if you have a notifier which is unable to # detect infinite vwaits, as the tests below will hang. The presence of -# the "testeventloop" command indicates that this is the case. +# the "testthread" command indicates that this is the case. -if {"[info commands testeventloop]" == "testeventloop"} { +if {"[info commands testthread]" == "testthread"} { return } @@ -47,3 +47,4 @@ test unixNotfy-1.2 {Tcl_DeleteFileHandler} { } {1 {can't wait for variable "x": would wait forever}} file delete foo +return diff --git a/tests/unknown.test b/tests/unknown.test index 83ad160..0fbc04a 100644 --- a/tests/unknown.test +++ b/tests/unknown.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: @(#) unknown.test 1.12 96/08/26 11:29:29 +# SCCS: @(#) unknown.test 1.13 97/12/08 15:04:40 if {[string compare test [info procs test]] == 1} then {source defs} @@ -58,4 +58,4 @@ test unknown-4.1 {errors in "unknown" procedure} { catch {rename unknown {}} catch {rename unknown.old unknown} -return {} +return diff --git a/tests/uplevel.test b/tests/uplevel.test index 84daa03..3aedf59 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.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: @(#) uplevel.test 1.13 96/02/16 08:56:35 +# SCCS: @(#) uplevel.test 1.14 97/12/08 15:04:43 if {[string compare test [info procs test]] == 1} then {source defs} @@ -107,3 +107,4 @@ proc a3 {} { a2 test uplevel-5.1 {info level} {set x} 1 test uplevel-5.2 {info level} {set y} a3 +return diff --git a/tests/upvar.test b/tests/upvar.test index d9548b0..8b556d9 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) upvar.test 1.15 97/10/29 18:25:56 +# SCCS: @(#) upvar.test 1.16 97/12/08 15:04:46 if {[string compare test [info procs test]] == 1} then {source defs} @@ -391,4 +391,4 @@ if {[info commands testupvar] != {}} { } catch {unset a} -concat +return diff --git a/tests/utf.test b/tests/utf.test new file mode 100644 index 0000000..234048b --- /dev/null +++ b/tests/utf.test @@ -0,0 +1,197 @@ +# This file contains a collection of tests for tclUtf.c +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) utf.test 1.7 98/01/15 18:41:53 +# + +if {[info procs test] != "test"} { + source defs +} + +test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} { + set x \x01 +} [bytestring "\x01"] +test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} { + set x "\x00" +} [bytestring "\xc0\x80"] +test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} { + set x "\xe0" +} [bytestring "\xc3\xa0"] +test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} { + set x "\u4e4e" +} [bytestring "\xe4\xb9\x8e"] + +test utf-2.1 {Tcl_UtfToUniChar: low ascii} { + string length "abc" +} {3} +test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} { + string length [bytestring "\x82\x83\x84"] +} {3} +test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} { + string length [bytestring "\xC2"] +} {1} +test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} { + string length [bytestring "\xC2\xa2"] +} {1} +test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} { + string length [bytestring "\xE2"] +} {1} +test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} { + string length [bytestring "\xE2\xA2"] +} {2} +test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} { + string length [bytestring "\xE4\xb9\x8e"] +} {1} +test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} { + string length [bytestring "\xF4\xA2\xA2\xA2"] +} {4} + +test utf-3.1 {Tcl_UtfCharComplete} { +} {} + +test utf-4.1 {Tcl_NumUtfChars: zero length} { + string length "" +} {0} +test utf-4.2 {Tcl_NumUtfChars: length 1} { + string length [bytestring "\xC2\xA2"] +} {1} +test utf-4.3 {Tcl_NumUtfChars: long string} { + string length [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] +} {7} + +test utf-5.1 {Tcl_UtfFindFirsts} { +} {} + +test utf-6.1 {Tcl_UtfNext} { +} {} + +test utf-7.1 {Tcl_UtfPrev} { +} {} + +test utf-8.1 {Tcl_UniCharAtIndex: index = 0} { + string index abcd 0 +} {a} +test utf-8.2 {Tcl_UniCharAtIndex: index = 0} { + string index \u4e4e\u25a 0 +} "\u4e4e" +test utf-8.3 {Tcl_UniCharAtIndex: index > 0} { + string index abcd 2 +} {c} +test utf-8.4 {Tcl_UniCharAtIndex: index > 0} { + string index \u4e4e\u25a\xff\u543 2 +} "\uff" + +test utf-9.1 {Tcl_UtfAtIndex: index = 0} { + string range abcd 0 2 +} {abc} +test utf-9.2 {Tcl_UtfAtIndex: index > 0} { + string range \u4e4e\u25a\xff\u543klmnop 1 5 +} "\u25a\xff\u543kl" + + +test utf-10.1 {Tcl_UtfBackslash: dst == NULL} { + set x \n +} { +} +test utf-10.2 {Tcl_UtfBackslash: \u subst} { + set x \ua2 +} [bytestring "\xc2\xa2"] +test utf-10.3 {Tcl_UtfBackslash: longer \u subst} { + set x \u4e21 +} [bytestring "\xe4\xb8\xa1"] +test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} { + set x \u4e2k +} "[bytestring \xd3\xa2]k" +test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} { + set x \u4e216 +} "[bytestring \xe4\xb8\xa1]6" +proc bsCheck {char num} { + global errNum + test utf-10.$errNum {backslash substitution} { + scan $char %c value + set value + } $num + incr errNum +} +set errNum 6 +bsCheck \b 8 +bsCheck \e 101 +bsCheck \f 12 +bsCheck \n 10 +bsCheck \r 13 +bsCheck \t 9 +bsCheck \v 11 +bsCheck \{ 123 +bsCheck \} 125 +bsCheck \[ 91 +bsCheck \] 93 +bsCheck \$ 36 +bsCheck \ 32 +bsCheck \; 59 +bsCheck \\ 92 +bsCheck \Ca 67 +bsCheck \Ma 77 +bsCheck \CMa 67 +bsCheck \8a 8 +bsCheck \14 12 +bsCheck \141 97 +bsCheck b\0 98 +bsCheck \x 120 +bsCheck \xa 10 +bsCheck \xA 10 +bsCheck \x41 65 +bsCheck \x541 65 +bsCheck \u 117 +bsCheck \uk 117 +bsCheck \u41 65 +bsCheck \ua 10 +bsCheck \uA 10 +bsCheck \340 224 +bsCheck \ua1 161 + +# scan only works on iso8859-1 characters, so all others will return +# the "?" character. The expected result will change when scan is fixed. + +bsCheck \u4e21 63 + +test utf-11.1 {Tcl_UtfToUpper} { + string toupper abc +} ABC +test utf-11.2 {Tcl_UtfToUpper} {hasIsoLocale} { + set_iso8859_1_locale + set result [string toupper \u00e3ab] + restore_locale + set result +} \u00c3AB +test utf-11.3 {Tcl_UtfToUpper} {hasIsoLocale} { + set_iso8859_1_locale + set result [string toupper \u01e3ab] + restore_locale + set result +} \u01e3AB + +test utf-12.1 {Tcl_UtfToLower} { + string tolower ABC +} abc +test utf-12.2 {Tcl_UtfToLower} {hasIsoLocale} { + set_iso8859_1_locale + set result [string tolower \u00c3AB] + restore_locale + set result +} \u00e3ab +test utf-12.3 {Tcl_UtfToLower} {hasIsoLocale} { + set_iso8859_1_locale + set result [string tolower \u01c3AB] + restore_locale + set result +} \u01c3ab + + + +return diff --git a/tests/util.test b/tests/util.test index ee37047..c24ada7 100644 --- a/tests/util.test +++ b/tests/util.test @@ -1,12 +1,12 @@ # This file is a Tcl script to test the code in the file tclUtil.c. # This file is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# Copyright (c) 1995-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) util.test 1.8 97/08/12 15:50:02 +# SCCS: @(#) util.test 1.13 98/01/16 23:30:07 if {[info commands testobj] == {}} { puts "This application hasn't been compiled with the \"testobj\"" @@ -58,26 +58,181 @@ 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-5.2 {Tcl_SetObjErrorCode - two args} { - catch {testsetobjerrorcode 1 2} - list [set errorCode] -} {{1 2}} -test util-5.3 {Tcl_SetObjErrorCode - three args} { - catch {testsetobjerrorcode 1 2 3} - list [set errorCode] -} {{1 2 3}} -test util-5.4 {Tcl_SetObjErrorCode - four args} { - catch {testsetobjerrorcode 1 2 3 4} - list [set errorCode] -} {{1 2 3 4}} -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-5.1 {Tcl_StringMatch} { + string match ab*c abc +} 1 +test util-5.2 {Tcl_StringMatch} { + string match ab**c abc +} 1 +test util-5.3 {Tcl_StringMatch} { + string match ab* abcdef +} 1 +test util-5.4 {Tcl_StringMatch} { + string match *c abc +} 1 +test util-5.5 {Tcl_StringMatch} { + string match *3*6*9 0123456789 +} 1 +test util-5.6 {Tcl_StringMatch} { + string match *3*6*9 01234567890 +} 0 +test util-5.7 {Tcl_StringMatch: UTF-8} { + string match *u \u4e4fu +} 1 +test util-5.8 {Tcl_StringMatch} { + string match a?c abc +} 1 +test util-5.9 {Tcl_StringMatch: UTF-8} { + # skip one character in string + + string match a?c a\u4e4fc +} 1 +test util-5.10 {Tcl_StringMatch} { + string match a??c abc +} 0 +test util-5.11 {Tcl_StringMatch} { + string match ?1??4???8? 0123456789 +} 1 +test util-5.12 {Tcl_StringMatch} { + string match {[abc]bc} abc +} 1 +test util-5.13 {Tcl_StringMatch: UTF-8} { + # string += Tcl_UtfToUniChar(string, &ch); + + string match "\[\u4e4fxy\]bc" "\u4e4fbc" +} 1 +test util-5.14 {Tcl_StringMatch} { + # if ((*pattern == ']') || (*pattern == '\0')) + # badly formed pattern + + string match {[]} {[]} +} 0 +test util-5.15 {Tcl_StringMatch} { + # if ((*pattern == ']') || (*pattern == '\0')) + # badly formed pattern + + string match {[} {[} +} 0 +test util-5.16 {Tcl_StringMatch} { + string match {a[abc]c} abc +} 1 +test util-5.17 {Tcl_StringMatch: UTF-8} { + # pattern += Tcl_UtfToUniChar(pattern, &endChar); + # get 1 UTF-8 character + + string match "a\[a\u4e4fc]c" "a\u4e4fc" +} 1 +test util-5.18 {Tcl_StringMatch: UTF-8} { + # pattern += Tcl_UtfToUniChar(pattern, &endChar); + # proper advance: wrong answer would match on UTF trail byte of \u4e4f + + string match {a[a\u4e4fc]c} [bytestring a\u008fc] +} 0 +test util-5.19 {Tcl_StringMatch: UTF-8} { + # pattern += Tcl_UtfToUniChar(pattern, &endChar); + # proper advance. + + string match {a[a\u4e4fc]c} "acc" +} 1 +test util-5.20 {Tcl_StringMatch} { + string match {a[xyz]c} abc +} 0 +test util-5.21 {Tcl_StringMatch} { + string match {12[2-7]45} 12345 +} 1 +test util-5.22 {Tcl_StringMatch: UTF-8 range} { + string match "\[\u4e00-\u4e4f]" "0" +} 0 +test util-5.23 {Tcl_StringMatch: UTF-8 range} { + string match "\[\u4e00-\u4e4f]" "\u4e33" +} 1 +test util-5.24 {Tcl_StringMatch: UTF-8 range} { + string match "\[\u4e00-\u4e4f]" "\uff08" +} 0 +test util-5.25 {Tcl_StringMatch} { + string match {12[ab2-4cd]45} 12345 +} 1 +test util-5.26 {Tcl_StringMatch} { + string match {12[ab2-4cd]45} 12b45 +} 1 +test util-5.27 {Tcl_StringMatch} { + string match {12[ab2-4cd]45} 12d45 +} 1 +test util-5.28 {Tcl_StringMatch} { + string match {12[ab2-4cd]45} 12145 +} 0 +test util-5.29 {Tcl_StringMatch} { + string match {12[ab2-4cd]45} 12545 +} 0 +test util-5.30 {Tcl_StringMatch: forwards range} { + string match {[k-w]} "z" +} 0 +test util-5.31 {Tcl_StringMatch: forwards range} { + string match {[k-w]} "w" +} 1 +test util-5.32 {Tcl_StringMatch: forwards range} { + string match {[k-w]} "r" +} 1 +test util-5.33 {Tcl_StringMatch: forwards range} { + string match {[k-w]} "k" +} 1 +test util-5.34 {Tcl_StringMatch: forwards range} { + string match {[k-w]} "a" +} 0 +test util-5.35 {Tcl_StringMatch: reverse range} { + string match {[w-k]} "z" +} 0 +test util-5.36 {Tcl_StringMatch: reverse range} { + string match {[w-k]} "w" +} 1 +test util-5.37 {Tcl_StringMatch: reverse range} { + string match {[w-k]} "r" +} 1 +test util-5.38 {Tcl_StringMatch: reverse range} { + string match {[w-k]} "k" +} 1 +test util-5.39 {Tcl_StringMatch: reverse range} { + string match {[w-k]} "a" +} 0 +test util-5.40 {Tcl_StringMatch: skip correct number of ']'} { + string match {[A-]x} Ax +} 0 +test util-5.41 {Tcl_StringMatch: skip correct number of ']'} { + string match {[A-]]x} Ax +} 1 +test util-5.42 {Tcl_StringMatch: skip correct number of ']'} { + string match {[A-]]x} \ue1x +} 0 +test util-5.43 {Tcl_StringMatch: skip correct number of ']'} { + string match \[A-]\ue1]x \ue1x +} 1 +test util-5.44 {Tcl_StringMatch: skip correct number of ']'} { + string match {[A-]h]x} hx +} 1 +test util-5.45 {Tcl_StringMatch} { + # if (*pattern == '\0') + # badly formed pattern + + string match {[a} a +} 0 +test util-5.46 {Tcl_StringMatch} { + string match {a\*b} a*b +} 1 +test util-5.47 {Tcl_StringMatch} { + string match {a\*b} ab +} 0 +test util-5.48 {Tcl_StringMatch} { + string match {a\*\?\[\]\\\x} "a*?\[\]\\x" +} 1 +test util-5.49 {Tcl_StringMatch} { + string match ** "" +} 1 +test util-5.50 {Tcl_StringMatch} { + string match *. "" +} 0 +test util-5.51 {Tcl_StringMatch} { + string match "" "" +} 1 test util-6.1 {Tcl_PrintDouble - using tcl_precision} { concat x[expr 1.4] @@ -93,10 +248,10 @@ test util-6.4 {Tcl_PrintDouble - using tcl_precision} { concat x[expr 1.123412341234] } {x1.1234} set tcl_precision 12 -test util-6.4 {Tcl_PrintDouble - make sure there's a decimal point} { +test util-6.5 {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} { +test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} {eformat} { concat x[expr 3.0e98] } {x3e+98} @@ -123,10 +278,11 @@ test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} { 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} { +test util-7.4 {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 "" + +return diff --git a/tests/var.test b/tests/var.test index 6452577..9c10ed7 100644 --- a/tests/var.test +++ b/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.10 97/07/28 18:31:47 +# SCCS: @(#) var.test 1.12 98/02/05 20:22:48 # if {[string compare test [info procs test]] == 1} then {source defs} @@ -27,7 +27,7 @@ catch {unset i} catch {unset a} catch {unset arr} -test var-1.1 {TclLookupVar, TCL_PARSE_PART1 flag set} { +test var-1.1 {TclLookupVar, Array handling} { catch {unset a} set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd set i 10 @@ -450,6 +450,11 @@ test var-9.9 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { list [catch {testsetnoerr v 2} msg] $msg } {1 {before set}} +test var-10.1 {can't nest arrays with array set} { + catch {unset arr} + list [catch {array set arr(x) {a 1 b 2}} res] $res +} {1 {can't set "arr(x)(a)": variable isn't array}} + catch {namespace delete ns} catch {unset arr} catch {unset v} @@ -465,3 +470,4 @@ catch {unset a} catch {unset xxxxx} catch {unset aaaaa} +return diff --git a/tests/while-old.test b/tests/while-old.test index f5e5b05..478aac9 100644 --- a/tests/while-old.test +++ b/tests/while-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: @(#) while-old.test 1.14 97/05/16 10:44:19 +# SCCS: @(#) while-old.test 1.15 97/12/08 15:06:17 if {[string compare test [info procs test]] == 1} then {source defs} @@ -111,3 +111,5 @@ test while-old-5.2 {while return result} { set x 1 while {$x} {set x 0} } {} + +return diff --git a/tests/while.test b/tests/while.test index 8642747..8eba9bd 100644 --- a/tests/while.test +++ b/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.9 97/07/02 16:41:35 +# SCCS: @(#) @(#) while.test 1.12 97/12/16 13:36:19 if {[string compare test [info procs test]] == 1} then {source defs} @@ -26,8 +26,7 @@ test while-1.2 {TclCompileWhileCmd: error in test expression} { set i 0 catch {while {$i<}} msg set errorInfo -} {syntax error in expression "$i<" - ("while" test expression) +} {wrong # args: should be "while test command" while compiling "while {$i<}"} test while-1.3 {TclCompileWhileCmd: error in test expression} { @@ -286,7 +285,7 @@ test while-3.3 {break tests, long command body} { set a } {1 3} -# Check "while", "break", "continue" and computed command names. +# Check "while" with computed command names. test while-4.1 {while and computed command names} { set i 0 @@ -296,6 +295,149 @@ test while-4.1 {while and computed command names} { } set i } 10 +test while-4.2 {while (not compiled): missing test expression} { + set z while + catch {$z } msg + set msg +} {wrong # args: should be "while test command"} +test while-4.3 {while (not compiled): error in test expression} { + set i 0 + set z while + catch {$z {$i<} {set x 1}} msg + set errorInfo +} {syntax error in expression "$i<" + while executing +"$z {$i<} {set x 1}"} +test while-4.4 {while (not compiled): error in test expression} { + set z while + set err [catch {$z {"a"+"b"} {error "loop aborted"}} msg] + list $err $msg +} {1 {can't use non-numeric string as operand of "+"}} +test while-4.5 {while (not compiled): multiline test expr} { + set value 1 + set z while + $z {($tcl_platform(platform) != "foobar1") && \ + ($tcl_platform(platform) != "foobar2")} { + incr value + break + } + set value +} {2} +test while-4.6 {while (not compiled): non-numeric boolean test expr} { + set value 1 + set z while + $z {"true"} { + incr value; + if {$value > 5} { + break; + } + } + set value +} 6 +test while-4.7 {while (not compiled): test expr is enclosed in quotes} { + set i 0 + set z while + $z "$i > 5" {} +} {} +test while-4.8 {while (not compiled): missing command body} { + set i 0 + set z while + catch {$z {$i < 5} } msg + set msg +} {wrong # args: should be "while test command"} +test while-4.9 {while (not compiled): error compiling command body} { + set i 0 + set z while + catch {$z {$i < 5} {set}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("while" body line 1) + invoked from within +"$z {$i < 5} {set}"} +test while-4.10 {while (not compiled): simple command body} { + set a {} + set i 1 + set z while + $z {$i<6} { + if $i==4 break + set a [concat $a $i] + incr i + } + set a +} {1 2 3} +test while-4.11 {while (not compiled): command body in quotes} { + set a {} + set i 1 + set z while + $z {$i<6} "append a x; incr i" + set a +} {xxxxx} +test while-4.12 {while (not compiled): computed command body} { + set z while + catch {unset x1} + catch {unset bb} + catch {unset x2} + set x1 {append a x1; } + set bb {break} + set x2 {; append a x2; incr i} + set a {} + set i 1 + $z {$i<6} $x1$bb$x2 + set a +} {x1} +test while-4.13 {while (not compiled): long command body} { + set a {} + set z while + set i 1 + $z {$i<6} { + if $i==4 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + incr i + } + set a +} {1 2 3} +test while-4.14 {while (not compiled): while command result} { + set i 0 + set z while + set a [$z {$i < 5} {incr i}] + set a +} {} +test while-4.15 {while (not compiled): while command result} { + set i 0 + set z while + set a [$z {$i < 5} {if $i==3 break; incr i}] + set a +} {} + +# Check "break" with computed command names. test while-5.1 {break and computed command names} { set i 0 @@ -306,6 +448,73 @@ test while-5.1 {break and computed command names} { } set i } 11 +test while-5.2 {break tests with computed command names} { + set a {} + set i 1 + set z break + while {$i <= 4} { + if {$i == 3} $z + set a [concat $a $i] + incr i + } + set a +} {1 2} +test while-5.3 {break tests, nested loops with computed command names} { + set msg {} + set i 1 + set z break + while {$i <= 4} { + set a 1 + while {$a <= 2} { + if {$i>=2 && $a>=2} $z + set msg [concat $msg "$i.$a"] + incr a + } + incr i + } + set msg +} {1.1 1.2 2.1 3.1 4.1} +test while-5.4 {break tests, long command body with computed command names} { + set a {} + set i 1 + set z break + while {$i<6} { + if $i==2 {incr i; continue} + if $i==5 $z + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if $i==4 $z + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + incr i + } + set a +} {1 3} + +# Check "continue" with computed command names. test while-6.1 {continue and computed command names} { set i 0 @@ -317,3 +526,80 @@ test while-6.1 {continue and computed command names} { } set i } 10 +test while-6.2 {continue tests} { + set a {} + set i 1 + set z continue + while {$i <= 4} { + incr i + if {$i == 3} $z + set a [concat $a $i] + } + set a +} {2 4 5} +test while-6.3 {continue tests with computed command names} { + set a {} + set i 1 + set z continue + while {$i <= 4} { + incr i + if {$i != 2} $z + set a [concat $a $i] + } + set a +} {2} +test while-6.4 {continue tests, nested loops with computed command names} { + set msg {} + set i 1 + set z continue + while {$i <= 4} { + incr i + set a 1 + while {$a <= 2} { + incr a + if {$i>=3 && $a>=3} $z + set msg [concat $msg "$i.$a"] + } + } + set msg +} {2.2 2.3 3.2 4.2 5.2} +test while-6.5 {continue tests, long command body with computed command names} { + set a {} + set i 1 + set z continue + while {$i<6} { + if $i==2 {incr i; continue} + if $i==4 break + if $i>5 $z + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + incr i + } + set a +} {1 3} + +return diff --git a/tests/winFCmd.test b/tests/winFCmd.test index a38d72f..651ffc0 100644 --- a/tests/winFCmd.test +++ b/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.11 97/10/10 11:50:05 +# SCCS: @(#) winFCmd.test 1.17 98/02/11 17:37:01 # if {[string compare test [info procs test]] == 1} then {source defs} @@ -46,7 +46,6 @@ proc cleanup {args} { set testConfig(cdrom) 0 set testConfig(exdev) 0 -set testConfig(UNCPath} 0 # find a CD-ROM so we can test read-only filesystems. @@ -101,10 +100,6 @@ if {[file exists c:/] && [file exists d:/]} { } } -if {[file exists //bisque/icepick]} { - set testConfig(UNCPath) 1 -} - file delete -force -- td1 set foo [catch {open td1 w} testfile] if {$foo} { @@ -231,91 +226,84 @@ test winFCmd-1.19 {TclpRenameFile: errno == EACCES} { cleanup list [catch {testfile mv nul tf1} msg] $msg } {1 EACCES} -# under 95, this would actually succed and move the current dir out from -# under yourself. test winFCmd-1.20 {TclpRenameFile: src is dir} {!95} { + # under 95, this would actually succeed and move the current dir out from + # under the current process! + cleanup file delete /tf1 list [catch {testfile mv [pwd] /tf1} msg] $msg } {1 EACCES} -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. - +test winFCmd-1.21 {TclpRenameFile: long src} { + cleanup list [catch {testfile mv $longname tf1} msg] $msg } {1 ENAMETOOLONG} -test winFCmd-1.22 {TclpRenameFile: obscenely long dst} {nt} { - # return ENOENT if name is too long! - cleanup - createfile tf1 - list [catch {testfile mv tf1 $longname} msg] $msg -} {1 ENOENT} -test winFCmd-1.23 {TclpRenameFile: obscenely long dst} {95} { +test winFCmd-1.22 {TclpRenameFile: long dst} { cleanup createfile tf1 list [catch {testfile mv tf1 $longname} msg] $msg } {1 ENAMETOOLONG} -test winFCmd-1.24 {TclpRenameFile: move dir into self} { +test winFCmd-1.23 {TclpRenameFile: move dir into self} { cleanup file mkdir td1 list [catch {testfile mv [pwd]/td1 td1/td2} msg] $msg } {1 EINVAL} -test winFCmd-1.25 {TclpRenameFile: move a root dir} {!$testConfig(win32s) || ("[lindex [file split [pwd]] end]" == "C:/")} { +test winFCmd-1.24 {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. + # machine; it causes the NT machine to die! Neat security hole in NT. cleanup list [catch {testfile mv / c:/} msg] $msg } {1 EINVAL} -test winFCmd-1.26 {TclpRenameFile: cross file systems} {cdrom} { +test winFCmd-1.25 {TclpRenameFile: cross file systems} {cdrom} { cleanup file mkdir td1 list [catch {testfile mv td1 $cdrom/td1} msg] $msg } {1 EXDEV} -test winFCmd-1.27 {TclpRenameFile: readonly fs} {cdrom} { +test winFCmd-1.26 {TclpRenameFile: readonly fs} {cdrom} { cleanup list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg } {1 EACCES} -test winFCmd-1.28 {TclpRenameFile: open file} { +test winFCmd-1.27 {TclpRenameFile: open file} { cleanup set fd [open tf1 w] set msg [list [catch {testfile mv tf1 tf2} msg] $msg] close $fd set msg } {1 EACCES} -test winFCmd-1.29 {TclpRenameFile: errno == EEXIST} { +test winFCmd-1.28 {TclpRenameFile: errno == EEXIST} { cleanup createfile tf1 createfile tf2 testfile mv tf1 tf2 list [file exist tf1] [file exist tf2] } {0 1} -test winFCmd-1.30 {TclpRenameFile: src is dir} { +test winFCmd-1.29 {TclpRenameFile: src is dir} { cleanup file mkdir td1 createfile tf1 list [catch {testfile mv td1 tf1} msg] $msg } {1 ENOTDIR} -test winFCmd-1.31 {TclpRenameFile: dst is dir} { +test winFCmd-1.30 {TclpRenameFile: dst is dir} { cleanup file mkdir td1 file mkdir td2/td2 list [catch {testfile mv td1 td2} msg] $msg } {1 EEXIST} -test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory fails} { +test winFCmd-1.31 {TclpRenameFile: TclpRemoveDirectory fails} { cleanup file mkdir td1 file mkdir td2/td2 list [catch {testfile mv td1 td2} msg] $msg } {1 EEXIST} -test winFCmd-1.33 {TclpRenameFile: TclpRemoveDirectory succeeds} { +test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} { cleanup file mkdir td1/td2 file mkdir td2 testfile mv td1 td2 list [file exist td1] [file exist td2] [file exist td2/td2] } {0 1 1} -test winFCmd-1.34 {TclpRenameFile: After removing dst dir, MoveFile fails} {exdev} { +test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} {exdev} { file mkdir d:/td1 testchmod 000 d:/td1 set msg [list [catch {testfile mv c:/windows d:/td1} msg] $msg] @@ -323,23 +311,23 @@ test winFCmd-1.34 {TclpRenameFile: After removing dst dir, MoveFile fails} {exde file delete d:/td1 set msg } {1 EXDEV 0} -test winFCmd-1.35 {TclpRenameFile: src is dir, dst is not} { +test winFCmd-1.34 {TclpRenameFile: src is dir, dst is not} { file mkdir td1 createfile tf1 list [catch {testfile mv td1 tf1} msg] $msg } {1 ENOTDIR} -test winFCmd-1.36 {TclpRenameFile: src is not dir, dst is} { +test winFCmd-1.35 {TclpRenameFile: src is not dir, dst is} { file mkdir td1 createfile tf1 list [catch {testfile mv tf1 td1} msg] $msg } {1 EISDIR} -test winFCmd-1.37 {TclpRenameFile: src and dst not dir} { +test winFCmd-1.36 {TclpRenameFile: src and dst not dir} { createfile tf1 tf1 createfile tf2 tf2 testfile mv tf1 tf2 contents tf2 } {tf1} -test winFCmd-1.38 {TclpRenameFile: need to restore temp file} { +test winFCmd-1.37 {TclpRenameFile: need to restore temp file} { # Can't figure out how to cause this. # Need a file that can't be copied. } {} @@ -803,11 +791,11 @@ test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} { test winFCmd-10.1 {AttributesPosixError - get} { cleanup list [catch {file attributes td1 -archive} msg] $msg -} {1 {cannot get attribute "-archive" for file "td1": no such file or directory}} +} {1 {could not read "td1": no such file or directory}} test winFCmd-10.2 {AttributesPosixError - set} { cleanup list [catch {file attributes td1 -archive 0} msg] $msg -} {1 {cannot set attribute "-archive" for file "td1": no such file or directory}} +} {1 {could not read "td1": no such file or directory}} test winFCmd-11.1 {GetWinFileAttributes} { cleanup @@ -829,6 +817,17 @@ test winFCmd-11.4 {GetWinFileAttributes} { close [open td1 w] list [catch {file attributes td1 -system} msg] $msg [cleanup] } {0 0 {}} +test winfcmd-11.5 {GetWinFileAttributes} { + # attr of relative paths that resolve to root was failing + # don't care about answer, just that test runs. + + set old [pwd] + cd c:/ + file attr c: + file attr c:. + file attr . + cd $old +} {} test winFCmd-12.1 {ConvertFileNameFormat} { cleanup @@ -861,11 +860,9 @@ test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} { close [open c:/td1 w] list [catch {string tolower [file attributes c:/td1 -longname]} msg] $msg [file delete -force -- c:/td1] } {0 c:/td1 {}} -test winFCmd-12.7 {ConvertFileNameFormat} {UNCPath} { - catch {file delete -force -- //bisque/icepick/test/td1} - close [open //bisque/icepick/test/td1 w] - list [catch {string tolower [file attributes //bisque/icepick/test/td1 -longname]} msg] $msg [file delete -force -- //bisque/icepick/test/td1] -} {0 //bisque/icepick/test/td1 {}} +test winFCmd-12.7 {ConvertFileNameFormat} {nonPortable} { + string tolower [file attributes //bisque/tcl/ws -longname] +} {//bisque/tcl/ws} test winFCmd-12.8 {ConvertFileNameFormat} {longFileNames} { cleanup close [open td1 w] @@ -902,7 +899,7 @@ test winFCmd-14.1 {GetWinFileShortName} { test winFCmd-15.1 {SetWinFileAttributes} { cleanup list [catch {file attributes td1 -archive 0} msg] $msg -} {1 {cannot set attribute "-archive" for file "td1": no such file or directory}} +} {1 {could not read "td1": no such file or directory}} test winFCmd-15.2 {SetWinFileAttributes - archive} { cleanup close [open td1 w] @@ -977,3 +974,4 @@ foreach source {tef ted tnf tnd "" nul com1} { } } +return diff --git a/tests/winFile.test b/tests/winFile.test new file mode 100644 index 0000000..82ed2b9 --- /dev/null +++ b/tests/winFile.test @@ -0,0 +1,51 @@ +# This file tests the tclWinFile.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winFile.test 1.3 97/12/08 15:07:46 +# + +if {[info procs test] != "test"} { + source defs +} + +if {$tcl_platform(platform) != "windows"} { + return +} + +test winFile-1.1 {TclpGetUserHome} { + list [catch {glob ~nosuchuser} msg] $msg +} {1 {user "nosuchuser" doesn't exist}} +test winFile-1.2 {TclpGetUserHome} {nt} { + # The administrator account should always exist. + + catch {glob ~administrator} +} {0} +test winFile-1.2 {TclpGetUserHome} {!nt} { + # Find some user in system.ini and then see if they have a home. + + set f [open $::env(windir)/system.ini] + set x 0 + while {![eof $f]} { + set line [gets $f] + if {$line == "\[Password Lists]"} { + gets $f + set name [lindex [split [gets $f] =] 0] + if {$name != ""} { + set x [catch {glob ~$name}] + break + } + } + } + close $f + set x +} {0} + +return diff --git a/tests/winNotify.test b/tests/winNotify.test index 2914a41..2ae6b94 100644 --- a/tests/winNotify.test +++ b/tests/winNotify.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: @(#) winNotify.test 1.2 97/04/14 17:24:56 +# SCCS: @(#) winNotify.test 1.3 97/12/08 15:06:52 if {[string compare test [info procs test]] == 1} then {source defs} @@ -153,3 +153,4 @@ test winNotify-3.8 {NotifierProc: modal idle timer, rescheduled} { } {1 1} # Tcl_DoOneEvent is tested by the timer.test, io.test, and event.test files +return diff --git a/tests/winPipe.test b/tests/winPipe.test index 404251f..a732343 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -2,7 +2,7 @@ # winPipe.test -- # # This file contains a collection of tests for tclWinPipe.c - +# # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # @@ -11,9 +11,9 @@ # 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.11 97/10/09 17:06:16 +# SCCS: @(#) winPipe.test 1.15 97/12/22 18:13:59 -if {$tcl_platform(platform) != "windows"} { +if {($tcl_platform(platform) != "windows") || ($testConfig(stdio) == 0)} { return } @@ -28,7 +28,7 @@ if [catch {puts console1 ""}] { set testConfig(.console) 1 } -set big aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n +set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n append big $big append big $big append big $big @@ -51,108 +51,104 @@ proc contents {file} { set r } +set f [open more w] +puts $f { + while {[eof stdin] == 0} { + puts -nonewline [read stdin] + } +} +close $f + 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] -} "little stderr32" +} {little stderr32} test winpipe-1.2 {32 bit comprehensive tests: from big file} { exec $cat32 < big > stdout 2> stderr list [contents stdout] [contents stderr] } "{$big} stderr32" test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {nt} { - exec more < little | $cat32 > stdout 2> stderr + exec $tcltest more < little | $cat32 > stdout 2> stderr list [contents stdout] [contents stderr] -} "{little\n} stderr32" -test winpipe-1.4 {32 bit comprehensive tests: a little from pipe} {95} { - exec more < little |& $cat32 > stdout 2> stderr - list [contents stdout] [contents stderr] -} "{\nlittle} stderr32" -test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {nt} { - exec more < big | $cat32 > stdout 2> stderr +} {little stderr32} +test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {nt} { + exec $tcltest more < big | $cat32 > stdout 2> stderr list [contents stdout] [contents stderr] } "{$big} stderr32" -test winpipe-1.6 {32 bit comprehensive tests: a lot from pipe} {95} { +test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {95} { exec command /c type big |& $cat32 > stdout 2> stderr list [contents stdout] [contents stderr] } "{$big} stderr32" -test winpipe-1.7 {32 bit comprehensive tests: from console} {AllocConsole} { +test winpipe-1.6 {32 bit comprehensive tests: from console} {AllocConsole} { # would block waiting for human input } {} -test winpipe-1.8 {32 bit comprehensive tests: from NUL} { +test winpipe-1.7 {32 bit comprehensive tests: from NUL} { exec $cat32 < nul > stdout 2> stderr list [contents stdout] [contents stderr] -} "{} stderr32" -test winpipe-1.9 {32 bit comprehensive tests: from socket} { +} {{} stderr32} +test winpipe-1.8 {32 bit comprehensive tests: from socket} { # doesn't work } {} -test winpipe-1.10 {32 bit comprehensive tests: from nowhere} {.console} { +test winpipe-1.9 {32 bit comprehensive tests: from nowhere} {.console} { exec $cat32 > stdout 2> stderr list [contents stdout] [contents stderr] -} "{} stderr32" -test winpipe-1.11 {32 bit comprehensive tests: from file handle} { +} {{} stderr32} +test winpipe-1.10 {32 bit comprehensive tests: from file handle} { set f [open "little" r] exec $cat32 <@$f > stdout 2> stderr close $f list [contents stdout] [contents stderr] -} "little stderr32" -test winpipe-1.12 {32 bit comprehensive tests: read from application} { +} {little stderr32} +test winpipe-1.11 {32 bit comprehensive tests: read from application} { set f [open "|$cat32 < little" r] gets $f line catch {close $f} msg list $line $msg -} "little stderr32" -test winpipe-1.13 {32 bit comprehensive tests: a little to file} { +} {little stderr32} +test winpipe-1.12 {32 bit comprehensive tests: a little to file} { exec $cat32 < little > stdout 2> stderr list [contents stdout] [contents stderr] -} "little stderr32" -test winpipe-1.14 {32 bit comprehensive tests: a lot to file} { +} {little stderr32} +test winpipe-1.13 {32 bit comprehensive tests: a lot to file} { exec $cat32 < big > stdout 2> stderr list [contents stdout] [contents stderr] } "{$big} stderr32" -test winpipe-1.15 {32 bit comprehensive tests: a little to pipe} {nt} { - exec $cat32 < little | more > stdout 2> stderr - list [contents stdout] [contents stderr] -} "{little\n} stderr32" -test winpipe-1.16 {32 bit comprehensive tests: a little to pipe} {95} { - exec $cat32 < little | more > stdout 2> stderr +test winpipe-1.14 {32 bit comprehensive tests: a little to pipe} { + exec $cat32 < little | $tcltest more > stdout 2> stderr list [contents stdout] [contents stderr] -} "{\nlittle} stderr32" -test winpipe-1.17 {32 bit comprehensive tests: a lot to pipe} {nt} { - exec $cat32 < big | more > stdout 2> stderr +} {little stderr32} +test winpipe-1.15 {32 bit comprehensive tests: a lot to pipe} { + exec $cat32 < big | $tcltest more > stdout 2> stderr list [contents stdout] [contents stderr] -} "{$big\n} stderr32" -test winpipe-1.18 {32 bit comprehensive tests: a lot to pipe} {95} { - exec $cat32 < big | more > stdout 2> stderr - list [contents stdout] [contents stderr] -} "{\n$big} stderr32" -test winpipe-1.19 {32 bit comprehensive tests: to console} { +} "{$big} stderr32" +test winpipe-1.16 {32 bit comprehensive tests: to console} { catch {exec $cat32 << "You should see this\n" >@stdout} msg set msg } stderr32 -test winpipe-1.20 {32 bit comprehensive tests: to NUL} { +test winpipe-1.17 {32 bit comprehensive tests: to NUL} { # some apps hang when sending a large amount to NUL. $cat32 isn't one. catch {exec $cat32 < big > nul} msg set msg } stderr32 -test winpipe-1.21 {32 bit comprehensive tests: to nowhere} {.console} { +test winpipe-1.18 {32 bit comprehensive tests: to nowhere} {.console} { exec $cat32 < big >&@stdout } {} -test winpipe-1.22 {32 bit comprehensive tests: to file handle} { +test winpipe-1.19 {32 bit comprehensive tests: to file handle} { set f1 [open "stdout" w] set f2 [open "stderr" w] exec $cat32 < little >@$f1 2>@$f2 close $f1 close $f2 list [contents stdout] [contents stderr] -} "little stderr32" -test winpipe-1.23 {32 bit comprehensive tests: write to application} { +} {little stderr32} +test winpipe-1.20 {32 bit comprehensive tests: write to application} { set f [open "|$cat32 > stdout" w] puts -nonewline $f "foo" catch {close $f} msg list [contents stdout] $msg -} "foo stderr32" -test winpipe-1.24 {32 bit comprehensive tests: read/write application} { +} {foo stderr32} +test winpipe-1.21 {32 bit comprehensive tests: read/write application} { set f [open "|$cat32" r+] puts $f $big puts $f \032 @@ -160,7 +156,7 @@ test winpipe-1.24 {32 bit comprehensive tests: read/write application} { set r [read $f 64] catch {close $f} set r -} "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" +} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" } set stderr16 "stderr16" @@ -176,85 +172,73 @@ test winpipe-2.2 {16 bit comprehensive tests: from big file} { exec $cat16 < big > stdout 2> stderr list [contents stdout] [contents stderr] } "{$big} $stderr16" -test winpipe-2.3 {16 bit comprehensive tests: a little from pipe} {nt} { - exec more < little | $cat16 > stdout 2> stderr +test winpipe-2.3 {16 bit comprehensive tests: a little from pipe} { + exec $tcltest more < little | $cat16 > stdout 2> stderr list [contents stdout] [contents stderr] -} "{little\n} stderr16" -test winpipe-2.4 {16 bit comprehensive tests: a little from pipe} {95} { - exec more < little | $cat16 > stdout 2> stderr - list [contents stdout] [contents stderr] -} "{\nlittle} stderr16" -test winpipe-2.5 {16 bit comprehensive tests: a lot from pipe} {nt} { +} {little stderr16} +test winpipe-2.4 {16 bit comprehensive tests: a lot from pipe} {nt} { exec $cat16 < big | $cat16 > stdout 2> stderr list [contents stdout] [contents stderr] } "{$big} stderr16stderr16" -test winpipe-2.6 {16 bit comprehensive tests: a lot from pipe} {95} { - exec more < big | $cat16 > stdout 2> stderr +test winpipe-2.5 {16 bit comprehensive tests: a lot from pipe} {95} { + exec $tcltest more < big | $cat16 > stdout 2> stderr list [contents stdout] [contents stderr] -} "{\n$big} stderr16" -test winpipe-2.7 {16 bit comprehensive tests: from console} {AllocConsole} { +} "{$big} stderr16" +test winpipe-2.6 {16 bit comprehensive tests: from console} {AllocConsole} { # would block waiting for human input } {} -test winpipe-2.8 {16 bit comprehensive tests: from NUL} {nt} { +test winpipe-2.7 {16 bit comprehensive tests: from NUL} {nt} { exec $cat16 < nul > stdout 2> stderr list [contents stdout] [contents stderr] } "{} stderr16" -test winpipe-2.9 {16 bit comprehensive tests: from socket} { +test winpipe-2.8 {16 bit comprehensive tests: from socket} { # doesn't work } {} -test winpipe-2.10 {16 bit comprehensive tests: from nowhere} {.console} { +test winpipe-2.9 {16 bit comprehensive tests: from nowhere} {.console} { exec $cat16 > stdout 2> stderr list [contents stdout] [contents stderr] } "{} stderr16" -test winpipe-2.11 {16 bit comprehensive tests: from file handle} { +test winpipe-2.10 {16 bit comprehensive tests: from file handle} { set f [open "little" r] exec $cat16 <@$f > stdout 2> stderr close $f list [contents stdout] [contents stderr] } "little $stderr16" -test winpipe-2.12 {16 bit comprehensive tests: read from application} { +test winpipe-2.11 {16 bit comprehensive tests: read from application} { set f [open "|$cat16 < little" r] gets $f line catch {close $f} msg list $line $msg } "little $stderr16" -test winpipe-2.13 {16 bit comprehensive tests: a little to file} { +test winpipe-2.12 {16 bit comprehensive tests: a little to file} { exec $cat16 < little > stdout 2> stderr list [contents stdout] [contents stderr] } "little $stderr16" -test winpipe-2.14 {16 bit comprehensive tests: a lot to file} { +test winpipe-2.13 {16 bit comprehensive tests: a lot to file} { exec $cat16 < big > stdout 2> stderr list [contents stdout] [contents stderr] } "{$big} $stderr16" -test winpipe-2.15 {16 bit comprehensive tests: a little to pipe} {nt} { - catch {exec $cat16 < little | more > stdout 2> stderr} - list [contents stdout] [contents stderr] -} "{little\n} stderr16" -test winpipe-2.16 {16 bit comprehensive tests: a little to pipe} {95} { - exec $cat16 < little | more > stdout 2> stderr +test winpipe-2.14 {16 bit comprehensive tests: a little to pipe} { + exec $cat16 < little | $tcltest more > stdout 2> stderr list [contents stdout] [contents stderr] -} "{\nlittle} stderr16" -test winpipe-2.17 {16 bit comprehensive tests: a lot to pipe} {nt} { - catch {exec $cat16 < big | more > stdout 2> stderr} +} {little stderr16} +test winpipe-2.15 {16 bit comprehensive tests: a lot to pipe} { + exec $cat16 < big | $tcltest more > stdout 2> stderr list [contents stdout] [contents stderr] -} "{$big\n} stderr16" -test winpipe-2.18 {16 bit comprehensive tests: a lot to pipe} {95} { - exec $cat16 < big | more > stdout 2> stderr - list [contents stdout] [contents stderr] -} "{\n$big} stderr16" -test winpipe-2.19 {16 bit comprehensive tests: to console} { +} "{$big} stderr16" +test winpipe-2.16 {16 bit comprehensive tests: to console} { catch {exec $cat16 << "You should see this\n" >@stdout} msg set msg } [lindex $stderr16 0] -test winpipe-2.20 {16 bit comprehensive tests: to NUL} {nt} { +test winpipe-2.17 {16 bit comprehensive tests: to NUL} {nt} { # some apps hang when sending a large amount to NUL. cat16 isn't one. catch {exec $cat16 < big > nul} msg set msg } stderr16 -test winpipe-2.21 {16 bit comprehensive tests: to nowhere} {.console} { +test winpipe-2.18 {16 bit comprehensive tests: to nowhere} {.console} { exec $cat16 < big >&@stdout } {} -test winpipe-2.22 {16 bit comprehensive tests: to file handle} { +test winpipe-2.19 {16 bit comprehensive tests: to file handle} { set f1 [open "stdout" w] set f2 [open "stderr" w] exec $cat16 < little >@$f1 2>@$f2 @@ -262,13 +246,13 @@ test winpipe-2.22 {16 bit comprehensive tests: to file handle} { close $f2 list [contents stdout] [contents stderr] } "little $stderr16" -test winpipe-2.23 {16 bit comprehensive tests: write to application} {!win32s} { +test winpipe-2.20 {16 bit comprehensive tests: write to application} {!win32s} { set f [open "|$cat16 > stdout" w] puts -nonewline $f "foo" catch {close $f} msg list [contents stdout] $msg } "foo stderr16" -test winpipe-2.24 {16 bit comprehensive tests: read/write application} {nt} { +test winpipe-2.21 {16 bit comprehensive tests: read/write application} {nt} { set f [open "|$cat16" r+] puts $f $big puts $f \032 @@ -276,7 +260,7 @@ test winpipe-2.24 {16 bit comprehensive tests: read/write application} {nt} { set r [read $f 64] catch {close $f} set r -} "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" +} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" } test winpipe-3.1 {Tcl_WaitPid} {nt} { @@ -308,18 +292,18 @@ catch {set env_temp $env(TEMP)} set env(TMP) c:/ set env(TEMP) c:/ -test winpipe-3.1 {TclpCreateTempFile: cleanup temp files} { +test winpipe-4.1 {TclpCreateTempFile: cleanup temp files} { set x {} set existing [glob -nocomplain c:/tcl*.tmp] exec $tcltest < nothing foreach p [glob -nocomplain c:/tcl*.tmp] { - if {[lsearch $existing $p] != -1} { + if {[lsearch $existing $p] == -1} { lappend x $p } } set x } {} -test winpipe-3.2 {TclpCreateTempFile: TMP and TEMP not defined} { +test winpipe-4.2 {TclpCreateTempFile: TMP and TEMP not defined} { set tmp $env(TMP) set temp $env(TEMP) unset env(TMP) @@ -329,14 +313,14 @@ test winpipe-3.2 {TclpCreateTempFile: TMP and TEMP not defined} { set env(TEMP) $temp set x {} } {} -test winpipe-3.3 {TclpCreateTempFile: TMP specifies non-existent directory} { +test winpipe-4.3 {TclpCreateTempFile: TMP specifies non-existent directory} { set tmp $env(TMP) set env(TMP) snarky exec $tcltest < nothing set env(TMP) $tmp set x {} } {} -test winpipe-3.3 {TclpCreateTempFile: TEMP specifies non-existent directory} { +test winpipe-4.4 {TclpCreateTempFile: TEMP specifies non-existent directory} { set tmp $env(TMP) set temp $env(TEMP) unset env(TMP) @@ -347,13 +331,49 @@ test winpipe-3.3 {TclpCreateTempFile: TEMP specifies non-existent directory} { set x {} } {} -# restore old values fro env(TMP) and env(TEMP) +if {$testConfig(stdio) && [file exists $cat32]} { +test winpipe-5.1 {PipeSetupProc & PipeCheckProc: read threads} { + set f [open "|$cat32" r+] + fconfigure $f -blocking 0 + fileevent $f writable { set x writable } + set x {} + vwait x + fileevent $f writable {} + fileevent $f readable { lappend x readable } + after 100 { lappend x timeout } + vwait x + puts $f foobar + flush $f + vwait x + lappend x [read $f] + after 100 { lappend x timeout } + vwait x + lappend x [catch {close $f} msg] $msg +} {writable timeout readable {foobar +} timeout 1 stderr32} +test winpipe-5.2 {PipeSetupProc & PipeCheckProc: write threads} { + set f [open "|$cat32" r+] + fconfigure $f -blocking 0 + fileevent $f writable { set x writable } + set x {} + vwait x + puts -nonewline $f $big$big$big$big + flush $f + after 100 { lappend x timeout } + vwait x + lappend x [catch {close $f} msg] $msg +} {writable timeout 0 {}} + +} + +# restore old values for env(TMP) and env(TEMP) if {[catch {set env(TMP) $env_tmp}]} { - unset $env(TMP) + unset env(TMP) } if {[catch {set env(TEMP) $env_temp}]} { - unset $env(TEMP) + unset env(TEMP) } -file delete big little stdout stderr nothing +file delete big little stdout stderr nothing cat +return |