diff options
165 files changed, 69117 insertions, 0 deletions
diff --git a/tests/README b/tests/README new file mode 100644 index 0000000..7dce2a2 --- /dev/null +++ b/tests/README @@ -0,0 +1,96 @@ +Tcl Test Suite +-------------- + +SCCS: @(#) README 1.6 96/04/17 10:51:11 + +This directory contains a set of validation tests for the Tcl +commands. Each of the files whose name ends in ".test" is +intended to fully exercise one or a few Tcl commands. The +commands tested by a given file are listed in the first line +of the file. + +You can run the tests in two ways: + (a) type "make test" in ../unix; this will run all of the tests. + (b) start up tcltest in this directory, then "source" the test + file (for example, type "source parse.test"). To run all + of the tests, type "source all". +In either case no output will be generated if all goes well, except +for a listing of the tests.. If there are errors then additional +messages will appear in the format described below. Note: don't +run the tests as superuser, since this will cause several of the tests +to fail. + +The rest of this file provides additional information on the +features of the testing environment. + +This approach to testing was designed and initially implemented +by Mary Ann May-Pumphrey of Sun Microsystems. Many thanks to +her for donating her work back to the public Tcl release. + +Definitions file: +----------------- + +The file "defs" defines a collection of procedures and variables +used to run the tests. It is read in automatically by each of the +.test files if needed, but once it has been read once it will not +be read again by the .test files. If you change defs while running +tests you'll have to "source" it by hand to load its new contents. + +Test output: +------------ + +Normally, output only appears when there are errors. However, if +the variable VERBOSE is set to 1 then tests will be run in "verbose" +mode and output will be generated for each test regardless of +whether it succeeded or failed. Test output consists of the +following information: + + - the test identifier (which can be used to locate the test code + in the .test file) + - a brief description of the test + - the contents of the test code + - the actual results produced by the tests + - a "PASSED" or "FAILED" message + - the expected results (if the test failed) + +You can set VERBOSE either interactively (after the defs file has been +read in), or you can change the default value in "defs". + +Selecting tests for execution: +------------------------------ + +Normally, all the tests in a file are run whenever the file is +"source"d. However, you can select a specific set of tests using +the global variable TESTS. This variable contains a pattern; any +test whose identifier matches TESTS will be run. For example, +the following interactive command causes all of the "for" tests in +groups 2 and 4 to be executed: + + set TESTS {for-[24]*} + +TESTS defaults to *, but you can change the default in "defs" if +you wish. + +Saving keystrokes: +------------------ + +A convenience procedure named "dotests" is included in file +"defs". It takes two arguments--the name of the test file (such +as "parse.test"), and a pattern selecting the tests you want to +execute. It sets TESTS to the second argument, calls "source" on +the file specified in the first argument, and restores TESTS to +its pre-call value at the end. + +Batch vs. interactive execution: +-------------------------------- + +The tests can be run in either batch or interactive mode. Batch +mode refers to using I/O redirection from a UNIX shell. For example, +the following command causes the tests in the file named "parse.test" +to be executed: + + tclTest < parse.test > parse.test.results + +Users who want to execute the tests in this fashion need to first +ensure that the file "defs" has proper values for the global +variables that control the testing environment (VERBOSE and TESTS). diff --git a/tests/all b/tests/all new file mode 100644 index 0000000..4023e55 --- /dev/null +++ b/tests/all @@ -0,0 +1,22 @@ +# 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 new file mode 100644 index 0000000..f89ade5 --- /dev/null +++ b/tests/append.test @@ -0,0 +1,174 @@ +# Commands covered: append lappend +# +# 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: @(#) append.test 1.17 97/10/28 15:45:52 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset x} +test append-1.1 {append command} { + catch {unset x} + list [append x 1 2 abc "long string"] $x +} {{12abclong string} {12abclong string}} +test append-1.2 {append command} { + set x "" + list [append x first] [append x second] [append x third] $x +} {first firstsecond firstsecondthird firstsecondthird} +test append-1.3 {append command} { + set x "abcd" + append x +} abcd + +test append-2.1 {long appends} { + set x "" + for {set i 0} {$i < 1000} {set i [expr $i+1]} { + append x "foobar " + } + set y "foobar" + set y "$y $y $y $y $y $y $y $y $y $y" + set y "$y $y $y $y $y $y $y $y $y $y" + set y "$y $y $y $y $y $y $y $y $y $y " + expr {$x == $y} +} 1 + +test append-3.1 {append errors} { + list [catch {append} msg] $msg +} {1 {wrong # args: should be "append varName ?value value ...?"}} +test append-3.2 {append errors} { + set x "" + list [catch {append x(0) 44} msg] $msg +} {1 {can't set "x(0)": variable isn't array}} +test append-3.3 {append errors} { + catch {unset x} + list [catch {append x} msg] $msg +} {1 {can't read "x": no such variable}} + +test append-4.1 {lappend command} { + catch {unset x} + list [lappend x 1 2 abc "long string"] $x +} {{1 2 abc {long string}} {1 2 abc {long string}}} +test append-4.2 {lappend command} { + set x "" + list [lappend x first] [lappend x second] [lappend x third] $x +} {first {first second} {first second third} {first second third}} +test append-4.3 {lappend command} { + proc foo {} { + global x + set x old + unset x + lappend x new + } + set result [foo] + rename foo {} + set result +} {new} +test append-4.4 {lappend command} { + set x {} + lappend x \{\ abc +} {\{\ abc} +test append-4.5 {lappend command} { + set x {} + lappend x \{ abc +} {\{ abc} +test append-4.6 {lappend command} { + set x {1 2 3} + lappend x +} {1 2 3} +test append-4.7 {lappend command} { + set x "a\{" + lappend x abc +} "a\\\{ abc" +test append-4.8 {lappend command} { + set x "\\\{" + lappend x abc +} "\\{ abc" +test append-4.9 {lappend command} { + set x " \{" + list [catch {lappend x abc} msg] $msg +} {1 {unmatched open brace in list}} +test append-4.10 {lappend command} { + set x " \{" + list [catch {lappend x abc} msg] $msg +} {1 {unmatched open brace in list}} +test append-4.11 {lappend command} { + set x "\{\{\{" + list [catch {lappend x abc} msg] $msg +} {1 {unmatched open brace in list}} +test append-4.12 {lappend command} { + set x "x \{\{\{" + list [catch {lappend x abc} msg] $msg +} {1 {unmatched open brace in list}} +test append-4.13 {lappend command} { + set x "x\{\{\{" + lappend x abc +} "x\\\{\\\{\\\{ abc" +test append-4.14 {lappend command} { + set x " " + lappend x abc +} "abc" +test append-4.15 {lappend command} { + set x "\\ " + lappend x abc +} "{ } abc" +test append-4.16 {lappend command} { + set x "x " + lappend x abc +} "x abc" +test append-4.17 {lappend command} { + catch {unset x} + lappend x +} {} + +proc check {var size} { + set l [llength $var] + if {$l != $size} { + return "length mismatch: should have been $size, was $l" + } + for {set i 0} {$i < $size} {set i [expr $i+1]} { + set j [lindex $var $i] + if {$j != "item $i"} { + return "element $i should have been \"item $i\", was \"$j\"" + } + } + return ok +} +test append-5.1 {long lappends} { + set x "" + for {set i 0} {$i < 300} {set i [expr $i+1]} { + lappend x "item $i" + } + check $x 300 +} ok + +test append-6.1 {lappend errors} { + list [catch {lappend} msg] $msg +} {1 {wrong # args: should be "lappend varName ?value value ...?"}} +test append-6.2 {lappend errors} { + set x "" + list [catch {lappend x(0) 44} msg] $msg +} {1 {can't set "x(0)": variable isn't array}} + +test append-7.1 {lappend-created var and error in trace on that var} { + catch {rename foo ""} + catch {unset x} + trace variable x w foo + proc foo {} {global x; unset x} + catch {lappend x 1} + proc foo {args} {global x; unset x} + info exists x + set x + lappend x 1 + list [info exists x] [catch {set x} msg] $msg +} {0 1 {can't read "x": no such variable}} + +catch {unset x} +catch {rename foo ""} diff --git a/tests/assocd.test b/tests/assocd.test new file mode 100644 index 0000000..20e8223 --- /dev/null +++ b/tests/assocd.test @@ -0,0 +1,57 @@ +# This file tests the AssocData facility of Tcl +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1994 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. +# +# "@(#) assocd.test 1.5 95/08/02 17:11:37" + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {[string compare testsetassocdata [info commands testsetassocdata]] != 0} { + puts "This application hasn't been compiled with the tests for assocData," + puts "therefore I am skipping all of these tests." + return +} + +test assocd-1.1 {testing setting assoc data} { + testsetassocdata a 1 +} "" +test assocd-1.2 {testing setting assoc data} { + testsetassocdata a 2 +} "" +test assocd-1.3 {testing setting assoc data} { + testsetassocdata 123 456 +} "" +test assocd-1.4 {testing setting assoc data} { + testsetassocdata abc "abc d e f" +} "" + +test assocd-2.1 {testing getting assoc data} { + testgetassocdata a +} 2 +test assocd-2.2 {testing getting assoc data} { + testgetassocdata 123 +} 456 +test assocd-2.3 {testing getting assoc data} { + testgetassocdata abc +} {abc d e f} +test assocd-2.4 {testing getting assoc data} { + testgetassocdata xxx +} "" + +test assocd-3.1 {testing deleting assoc data} { + testdelassocdata a +} "" +test assocd-3.2 {testing deleting assoc data} { + testdelassocdata 123 +} "" +test assocd-3.3 {testing deleting assoc data} { + list [catch {testdelassocdata nonexistent} msg] $msg +} {0 {}} diff --git a/tests/async.test b/tests/async.test new file mode 100644 index 0000000..cfc572c --- /dev/null +++ b/tests/async.test @@ -0,0 +1,131 @@ +# Commands covered: none +# +# This file contains a collection of tests for Tcl_AsyncCreate and related +# library procedures. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 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: @(#) async.test 1.5 96/04/05 15:29:38 + +if {[info commands testasync] == {}} { + puts "This application hasn't been compiled with the \"testasync\"" + puts "command, so I can't test Tcl_AsyncCreate et al." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc async1 {result code} { + global aresult acode + set aresult $result + set acode $code + return "new result" +} +proc async2 {result code} { + global aresult acode + set aresult $result + set acode $code + return -code error "xyzzy" +} +proc async3 {result code} { + global aresult + set aresult "test pattern" + return -code $code $result +} + +set handler1 [testasync create async1] +set handler2 [testasync create async2] +set handler3 [testasync create async3] +test async-1.1 {basic async handlers} { + set aresult xxx + set acode yyy + list [catch {testasync mark $handler1 "original" 0} msg] $msg \ + $acode $aresult +} {0 {new result} 0 original} +test async-1.2 {basic async handlers} { + set aresult xxx + set acode yyy + list [catch {testasync mark $handler1 "original" 1} msg] $msg \ + $acode $aresult +} {0 {new result} 1 original} +test async-1.3 {basic async handlers} { + set aresult xxx + set acode yyy + list [catch {testasync mark $handler2 "old" 0} msg] $msg \ + $acode $aresult +} {1 xyzzy 0 old} +test async-1.4 {basic async handlers} { + set aresult xxx + set acode yyy + list [catch {testasync mark $handler2 "old" 3} msg] $msg \ + $acode $aresult +} {1 xyzzy 3 old} +test async-1.5 {basic async handlers} { + set aresult xxx + list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult +} {0 foobar {test pattern}} +test async-1.6 {basic async handlers} { + set aresult xxx + list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult +} {1 foobar {test pattern}} + +proc mult1 {result code} { + global x + lappend x mult1 + return -code 7 mult1 +} +set hm1 [testasync create mult1] +proc mult2 {result code} { + global x + lappend x mult2 + return -code 9 mult2 +} +set hm2 [testasync create mult2] +proc mult3 {result code} { + global x hm1 hm2 + lappend x [catch {testasync mark $hm2 serial2 0}] + lappend x [catch {testasync mark $hm1 serial1 0}] + lappend x mult3 + return -code 11 mult3 +} +set hm3 [testasync create mult3] + +test async-2.1 {multiple handlers} { + set x {} + list [catch {testasync mark $hm3 "foobar" 5} msg] $msg $x +} {9 mult2 {0 0 mult3 mult1 mult2}} + +proc del1 {result code} { + global x hm1 hm2 hm3 hm4 + lappend x [catch {testasync mark $hm3 serial2 0}] + lappend x [catch {testasync mark $hm1 serial1 0}] + lappend x [catch {testasync mark $hm4 serial1 0}] + testasync delete $hm1 + testasync delete $hm2 + testasync delete $hm3 + lappend x del1 + return -code 13 del1 +} +proc del2 {result code} { + global x + lappend x del2 + return -code 3 del2 +} +testasync delete $handler1 +testasync delete $hm2 +testasync delete $hm3 +set hm2 [testasync create del1] +set hm3 [testasync create mult2] +set hm4 [testasync create del2] + +test async-3.1 {deleting handlers} { + set x {} + list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x +} {3 del2 {0 0 0 del1 del2}} + +testasync delete diff --git a/tests/basic.test b/tests/basic.test new file mode 100644 index 0000000..502e3e5 --- /dev/null +++ b/tests/basic.test @@ -0,0 +1,399 @@ +# This file contains tests for the tclBasic.c source file. Tests appear in +# the same order as the C code that they test. The set of tests is +# currently incomplete since it currently includes only new tests for +# code changed for the addition of Tcl namespaces. Other variable- +# related tests appear in several other test files including +# assocd.test, cmdInfo.test, eval.test, expr.test, interp.test, +# and trace.test. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) basic.test 1.19 97/10/31 16:02:26 +# + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {namespace delete test_ns_basic} +catch {interp delete test_interp} +catch {rename p ""} +catch {rename q ""} +catch {rename cmd ""} +catch {unset x} + +test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} { + catch {interp delete test_interp} + interp create test_interp + interp eval test_interp { + namespace eval test_ns_basic { + proc p {} { + return [namespace current] + } + } + } + list [interp eval test_interp {test_ns_basic::p}] \ + [interp delete test_interp] +} {::test_ns_basic {}} + +test basic-2.1 {DeleteInterpProc, destroys interp's global namespace} { + catch {interp delete test_interp} + interp create test_interp + interp eval test_interp { + namespace eval test_ns_basic { + namespace export p + proc p {} { + return [namespace current] + } + } + namespace eval test_ns_2 { + namespace import ::test_ns_basic::p + variable v 27 + proc q {} { + variable v + return "[p] $v" + } + } + } + list [interp eval test_interp {test_ns_2::q}] \ + [interp eval test_interp {namespace delete ::}] \ + [catch {interp eval test_interp {set a 123}} msg] $msg \ + [interp delete test_interp] +} {{::test_ns_basic 27} {} 1 {invalid command name "set"} {}} + +test basic-3.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} { + catch {interp delete test_interp} + interp create test_interp + interp eval test_interp { + proc p {} { + return 27 + } + } + interp alias {} localP test_interp p + list [interp eval test_interp {p}] \ + [localP] \ + [test_interp hide p] \ + [catch {localP} msg] $msg \ + [interp delete test_interp] \ + [catch {localP} msg] $msg +} {27 27 {} 1 {invalid command name "p"} {} 1 {invalid command name "localP"}} + +# NB: More tests about hide/expose are found in interp.test + +test basic-4.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} { + catch {interp delete test_interp} + interp create test_interp + interp eval test_interp { + namespace eval test_ns_basic { + proc p {} { + return [namespace current] + } + } + } + list [catch {test_interp hide test_ns_basic::p x} msg] $msg \ + [catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \ + [interp delete test_interp] +} {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers as hidden commandtoken (rename)} {}} + +test basic-4.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} { + catch {namespace delete test_ns_basic} + catch {rename cmd ""} + proc cmd {} { ;# note that this is global + return [namespace current] + } + namespace eval test_ns_basic { + proc hideCmd {} { + interp hide {} cmd + } + proc exposeCmd {} { + interp expose {} cmd + } + proc callCmd {} { + cmd + } + } + list [test_ns_basic::callCmd] \ + [test_ns_basic::hideCmd] \ + [catch {cmd} msg] $msg \ + [test_ns_basic::exposeCmd] \ + [test_ns_basic::callCmd] \ + [namespace delete test_ns_basic] +} {:: {} 1 {invalid command name "cmd"} {} :: {}} + +test basic-5.1 {Tcl_ExposeCommand, 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 + return [namespace current] + } + namespace eval test_ns_basic { + proc hideCmd {} { + interp hide {} cmd + } + proc exposeCmdFailing {} { + interp expose {} cmd ::test_ns_basic::newCmd + } + proc exposeCmdWorkAround {} { + interp expose {} cmd; + rename cmd ::test_ns_basic::newCmd; + } + proc callCmd {} { + cmd + } + } + list [test_ns_basic::callCmd] \ + [test_ns_basic::hideCmd] \ + [catch {test_ns_basic::exposeCmdFailing} msg] $msg \ + [test_ns_basic::exposeCmdWorkAround] \ + [test_ns_basic::newCmd] \ + [namespace delete test_ns_basic] +} {:: {} 1 {can not expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}} +test basic-5.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} { + catch {rename p ""} + catch {rename cmd ""} + proc p {} { + cmd + } + proc cmd {} { + return 42 + } + list [p] \ + [interp hide {} cmd] \ + [proc cmd {} {return Hello}] \ + [cmd] \ + [rename cmd ""] \ + [interp expose {} cmd] \ + [p] +} {42 {} {} Hello {} {} 42} + +if {[info commands testcreatecommand] != {}} { + test basic-6.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [testcreatecommand create] \ + [test_ns_basic::createdcommand] \ + [testcreatecommand delete] + } {{} {CreatedCommandProc in ::test_ns_basic} {}} + test basic-6.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename value:at: ""} + list [testcreatecommand create2] \ + [value:at:] \ + [testcreatecommand delete2] + } {{} {CreatedCommandProc2 in ::} {}} +} +test basic-6.3 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_basic {} + proc test_ns_basic::cmd {} { ;# proc requires that ns already exist + return [namespace current] + } + list [test_ns_basic::cmd] \ + [namespace delete test_ns_basic] +} {::test_ns_basic {}} + +test basic-7.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename cmd ""} + namespace eval test_ns_basic { + proc p {} { + return "p in [namespace current]" + } + } + list [test_ns_basic::p] \ + [rename test_ns_basic::p test_ns_basic::q] \ + [test_ns_basic::q] +} {{p in ::test_ns_basic} {} {p in ::test_ns_basic}} +test basic-7.2 {TclRenameCommand, existing cmd must be found} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg +} {1 {can't rename "test_ns_basic::p": command doesn't exist}} +test basic-7.3 {TclRenameCommand, delete cmd if new name is empty} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_basic { + proc p {} { + return "p in [namespace current]" + } + } + list [info commands test_ns_basic::*] \ + [rename test_ns_basic::p ""] \ + [info commands test_ns_basic::*] +} {::test_ns_basic::p {} {}} +test basic-7.4 {TclRenameCommand, bad new name} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_basic { + proc p {} { + return "p in [namespace current]" + } + } + rename test_ns_basic::p :::george::martha +} {} +test basic-7.5 {TclRenameCommand, new name must not already exist} { + namespace eval test_ns_basic { + proc q {} { + return 42 + } + } + list [catch {rename test_ns_basic::q :::george::martha} msg] $msg +} {1 {can't rename to ":::george::martha": command already exists}} +test basic-7.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename p ""} + catch {rename q ""} + proc p {} { + return "p in [namespace current]" + } + proc q {} { + return "q in [namespace current]" + } + namespace eval test_ns_basic { + proc callP {} { + p + } + } + list [test_ns_basic::callP] \ + [rename q test_ns_basic::p] \ + [test_ns_basic::callP] +} {{p in ::} {} {q in ::test_ns_basic}} + +test basic-8.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename p ""} + catch {rename q ""} + catch {unset x} + set x [namespace eval test_ns_basic::test_ns_basic2 { + # the following creates a cmd in the global namespace + testcmdtoken create p + }] + list [testcmdtoken name $x] \ + [rename ::p q] \ + [testcmdtoken name $x] +} {{p ::p} {} {q ::q}} +test basic-8.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} { + catch {rename q ""} + set x [testcmdtoken create test_ns_basic::test_ns_basic2::p] + list [testcmdtoken name $x] \ + [rename test_ns_basic::test_ns_basic2::p q] \ + [testcmdtoken name $x] +} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}} + +test basic-9.1 {Tcl_GetCommandFullName} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_basic1 { + namespace export cmd* + proc cmd1 {} {} + proc cmd2 {} {} + } + namespace eval test_ns_basic2 { + namespace export * + namespace import ::test_ns_basic1::* + proc p {} {} + } + namespace eval test_ns_basic3 { + namespace import ::test_ns_basic2::* + proc q {} {} + list [namespace which -command foreach] \ + [namespace which -command q] \ + [namespace which -command p] \ + [namespace which -command cmd1] \ + [namespace which -command ::test_ns_basic2::cmd2] + } +} {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2} + +test basic-10.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} { + catch {interp delete test_interp} + catch {unset x} + interp create test_interp + interp eval test_interp { + proc useSet {} { + return [set a 123] + } + } + set x [interp eval test_interp {useSet}] + interp eval test_interp { + rename set "" + proc set {args} { + return "set called with $args" + } + } + list $x \ + [interp eval test_interp {useSet}] \ + [interp delete test_interp] +} {123 {set called with a 123} {}} +test basic-10.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename p ""} + proc p {} { + return "global p" + } + namespace eval test_ns_basic { + proc p {} { + return "namespace p" + } + proc callP {} { + p + } + } + list [test_ns_basic::callP] \ + [rename test_ns_basic::p ""] \ + [test_ns_basic::callP] +} {{namespace p} {} {global p}} +test basic-10.3 {Tcl_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 { + namespace export p + proc p {} {return 42} + } + namespace eval test_ns_basic2 { + namespace import ::test_ns_basic::* + proc callP {} { + p + } + } + list [test_ns_basic2::callP] \ + [info commands test_ns_basic2::*] \ + [rename test_ns_basic::p ""] \ + [catch {test_ns_basic2::callP} msg] $msg \ + [info commands test_ns_basic2::*] +} {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP} + +test basic-11.1 {TclObjInvoke, lookup of "unknown" command} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {interp delete test_interp} + interp create test_interp + interp eval test_interp { + proc unknown {args} { + return "global unknown" + } + namespace eval test_ns_basic { + proc unknown {args} { + return "namespace unknown" + } + } + } + list [interp alias test_interp newAlias test_interp doesntExist] \ + [catch {interp eval test_interp {newAlias}} msg] $msg \ + [interp delete test_interp] +} {newAlias 0 {global unknown} {}} + +test basic-12.1 {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} { + testcmdtrace deletetest {set stuff [info tclversion]} +} 8.0 + +catch {eval namespace delete [namespace children :: test_ns_*]} +catch {namespace delete george} +catch {interp delete test_interp} +catch {rename p ""} +catch {rename q ""} +catch {rename cmd ""} +catch {rename value:at: ""} +catch {unset x} +set x 0 +unset x diff --git a/tests/binary.test b/tests/binary.test new file mode 100644 index 0000000..dcc5cf6 --- /dev/null +++ b/tests/binary.test @@ -0,0 +1,1443 @@ +# This file tests the tclBinary.c file and the "binary" Tcl command. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) binary.test 1.13 97/09/11 18:50:30 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test binary-1.1 {Tcl_BinaryObjCmd: bad args} { + list [catch {binary} msg] $msg +} {1 {wrong # args: should be "binary option ?arg arg ...?"}} +test binary-1.2 {Tcl_BinaryObjCmd: bad args} { + list [catch {binary foo} msg] $msg +} {1 {bad option "foo": must be format, or scan}} + +test binary-1.3 {Tcl_BinaryObjCmd: format error} { + list [catch {binary f} msg] $msg +} {1 {wrong # args: should be "binary format formatString ?arg arg ...?"}} +test binary-1.4 {Tcl_BinaryObjCmd: format} { + binary format "" +} {} + + + +test binary-2.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format a } msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-2.2 {Tcl_BinaryObjCmd: format} { + binary format a0 foo +} {} +test binary-2.3 {Tcl_BinaryObjCmd: format} { + binary format a f +} {f} +test binary-2.4 {Tcl_BinaryObjCmd: format} { + binary format a foo +} {f} +test binary-2.5 {Tcl_BinaryObjCmd: format} { + binary format a3 foo +} {foo} +test binary-2.6 {Tcl_BinaryObjCmd: format} { + binary format a5 foo +} foo\x00\x00 +test binary-2.7 {Tcl_BinaryObjCmd: format} { + binary format a*a3 foobarbaz blat +} foobarbazbla +test binary-2.8 {Tcl_BinaryObjCmd: format} { + binary format a*X3a2 foobar x +} foox\x00r + +test binary-3.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format A} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-3.2 {Tcl_BinaryObjCmd: format} { + binary format A0 f +} {} +test binary-3.3 {Tcl_BinaryObjCmd: format} { + binary format A f +} {f} +test binary-3.4 {Tcl_BinaryObjCmd: format} { + binary format A foo +} {f} +test binary-3.5 {Tcl_BinaryObjCmd: format} { + binary format A3 foo +} {foo} +test binary-3.6 {Tcl_BinaryObjCmd: format} { + binary format A5 foo +} {foo } +test binary-3.7 {Tcl_BinaryObjCmd: format} { + binary format A*A3 foobarbaz blat +} foobarbazbla +test binary-3.8 {Tcl_BinaryObjCmd: format} { + binary format A*X3A2 foobar x +} {foox r} + +test binary-4.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format B} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-4.2 {Tcl_BinaryObjCmd: format} { + binary format B0 1 +} {} +test binary-4.3 {Tcl_BinaryObjCmd: format} { + binary format B 1 +} \x80 +test binary-4.4 {Tcl_BinaryObjCmd: format} { + binary format B* 010011 +} \x4c +test binary-4.5 {Tcl_BinaryObjCmd: format} { + binary format B8 01001101 +} \x4d +test binary-4.6 {Tcl_BinaryObjCmd: format} { + binary format A2X2B9 oo 01001101 +} \x4d\x00 +test binary-4.7 {Tcl_BinaryObjCmd: format} { + binary format B9 010011011010 +} \x4d\x80 +test binary-4.8 {Tcl_BinaryObjCmd: format} { + binary format B2B3 10 010 +} \x80\x40 +test binary-4.9 {Tcl_BinaryObjCmd: format} { + list [catch {binary format B1B5 1 foo} msg] $msg +} {1 {expected binary string but got "foo" instead}} + +test binary-5.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format b} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-5.2 {Tcl_BinaryObjCmd: format} { + binary format b0 1 +} {} +test binary-5.3 {Tcl_BinaryObjCmd: format} { + binary format b 1 +} \x01 +test binary-5.4 {Tcl_BinaryObjCmd: format} { + binary format b* 010011 +} 2 +test binary-5.5 {Tcl_BinaryObjCmd: format} { + binary format b8 01001101 +} \xb2 +test binary-5.6 {Tcl_BinaryObjCmd: format} { + binary format A2X2b9 oo 01001101 +} \xb2\x00 +test binary-5.7 {Tcl_BinaryObjCmd: format} { + binary format b9 010011011010 +} \xb2\x01 +test binary-5.8 {Tcl_BinaryObjCmd: format} { + binary format b17 1 +} \x01\00\00 +test binary-5.9 {Tcl_BinaryObjCmd: format} { + binary format b2b3 10 010 +} \x01\x02 +test binary-5.10 {Tcl_BinaryObjCmd: format} { + list [catch {binary format b1b5 1 foo} msg] $msg +} {1 {expected binary string but got "foo" instead}} + +test binary-6.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format h} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-6.2 {Tcl_BinaryObjCmd: format} { + binary format h0 1 +} {} +test binary-6.3 {Tcl_BinaryObjCmd: format} { + binary format h 1 +} \x01 +test binary-6.4 {Tcl_BinaryObjCmd: format} { + binary format h c +} \x0c +test binary-6.5 {Tcl_BinaryObjCmd: format} { + binary format h* baadf00d +} \xab\xda\x0f\xd0 +test binary-6.6 {Tcl_BinaryObjCmd: format} { + binary format h4 c410 +} \x4c\x01 +test binary-6.7 {Tcl_BinaryObjCmd: format} { + binary format h6 c4102 +} \x4c\x01\x02 +test binary-6.8 {Tcl_BinaryObjCmd: format} { + binary format h5 c41020304 +} \x4c\x01\x02 +test binary-6.9 {Tcl_BinaryObjCmd: format} { + binary format a3X3h5 foo 2 +} \x02\x00\x00 +test binary-6.10 {Tcl_BinaryObjCmd: format} { + binary format h2h3 23 456 +} \x32\x54\x06 +test binary-6.11 {Tcl_BinaryObjCmd: format} { + list [catch {binary format h2 foo} msg] $msg +} {1 {expected hexadecimal string but got "foo" instead}} + +test binary-7.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format H} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-7.2 {Tcl_BinaryObjCmd: format} { + binary format H0 1 +} {} +test binary-7.3 {Tcl_BinaryObjCmd: format} { + binary format H 1 +} \x10 +test binary-7.4 {Tcl_BinaryObjCmd: format} { + binary format H c +} \xc0 +test binary-7.5 {Tcl_BinaryObjCmd: format} { + binary format H* baadf00d +} \xba\xad\xf0\x0d +test binary-7.6 {Tcl_BinaryObjCmd: format} { + binary format H4 c410 +} \xc4\x10 +test binary-7.7 {Tcl_BinaryObjCmd: format} { + binary format H6 c4102 +} \xc4\x10\x20 +test binary-7.8 {Tcl_BinaryObjCmd: format} { + binary format H5 c41023304 +} \xc4\x10\x20 +test binary-7.9 {Tcl_BinaryObjCmd: format} { + binary format a3X3H5 foo 2 +} \x20\x00\x00 +test binary-7.10 {Tcl_BinaryObjCmd: format} { + binary format H2H3 23 456 +} \x23\x45\x60 +test binary-7.11 {Tcl_BinaryObjCmd: format} { + list [catch {binary format H2 foo} msg] $msg +} {1 {expected hexadecimal string but got "foo" instead}} + +test binary-8.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format c} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-8.2 {Tcl_BinaryObjCmd: format} { + list [catch {binary format c blat} msg] $msg +} {1 {expected integer but got "blat"}} +test binary-8.3 {Tcl_BinaryObjCmd: format} { + binary format c0 0x50 +} {} +test binary-8.4 {Tcl_BinaryObjCmd: format} { + binary format c 0x50 +} P +test binary-8.5 {Tcl_BinaryObjCmd: format} { + binary format c 0x5052 +} R +test binary-8.6 {Tcl_BinaryObjCmd: format} { + binary format c2 {0x50 0x52} +} PR +test binary-8.7 {Tcl_BinaryObjCmd: format} { + binary format c2 {0x50 0x52 0x53} +} PR +test binary-8.8 {Tcl_BinaryObjCmd: format} { + binary format c* {0x50 0x52} +} PR +test binary-8.9 {Tcl_BinaryObjCmd: format} { + list [catch {binary format c2 {0x50}} msg] $msg +} {1 {number of elements in list does not match count}} +test binary-8.10 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + list [catch {binary format c $a} msg] $msg +} [list 1 "expected integer but got \"0x50 0x51\""] +test binary-8.11 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + binary format c1 $a +} P + +test binary-9.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format s} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-9.2 {Tcl_BinaryObjCmd: format} { + list [catch {binary format s blat} msg] $msg +} {1 {expected integer but got "blat"}} +test binary-9.3 {Tcl_BinaryObjCmd: format} { + binary format s0 0x50 +} {} +test binary-9.4 {Tcl_BinaryObjCmd: format} { + binary format s 0x50 +} P\x00 +test binary-9.5 {Tcl_BinaryObjCmd: format} { + binary format s 0x5052 +} RP +test binary-9.6 {Tcl_BinaryObjCmd: format} { + binary format s 0x505251 0x53 +} QR +test binary-9.7 {Tcl_BinaryObjCmd: format} { + binary format s2 {0x50 0x52} +} P\x00R\x00 +test binary-9.8 {Tcl_BinaryObjCmd: format} { + binary format s* {0x5051 0x52} +} QPR\x00 +test binary-9.9 {Tcl_BinaryObjCmd: format} { + binary format s2 {0x50 0x52 0x53} 0x54 +} P\x00R\x00 +test binary-9.10 {Tcl_BinaryObjCmd: format} { + list [catch {binary format s2 {0x50}} msg] $msg +} {1 {number of elements in list does not match count}} +test binary-9.11 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + list [catch {binary format s $a} msg] $msg +} [list 1 "expected integer but got \"0x50 0x51\""] +test binary-9.12 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + binary format s1 $a +} P\x00 + +test binary-10.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format S} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-10.2 {Tcl_BinaryObjCmd: format} { + list [catch {binary format S blat} msg] $msg +} {1 {expected integer but got "blat"}} +test binary-10.3 {Tcl_BinaryObjCmd: format} { + binary format S0 0x50 +} {} +test binary-10.4 {Tcl_BinaryObjCmd: format} { + binary format S 0x50 +} \x00P +test binary-10.5 {Tcl_BinaryObjCmd: format} { + binary format S 0x5052 +} PR +test binary-10.6 {Tcl_BinaryObjCmd: format} { + binary format S 0x505251 0x53 +} RQ +test binary-10.7 {Tcl_BinaryObjCmd: format} { + binary format S2 {0x50 0x52} +} \x00P\x00R +test binary-10.8 {Tcl_BinaryObjCmd: format} { + binary format S* {0x5051 0x52} +} PQ\x00R +test binary-10.9 {Tcl_BinaryObjCmd: format} { + binary format S2 {0x50 0x52 0x53} 0x54 +} \x00P\x00R +test binary-10.10 {Tcl_BinaryObjCmd: format} { + list [catch {binary format S2 {0x50}} msg] $msg +} {1 {number of elements in list does not match count}} +test binary-10.11 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + list [catch {binary format S $a} msg] $msg +} [list 1 "expected integer but got \"0x50 0x51\""] +test binary-10.12 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + binary format S1 $a +} \x00P + +test binary-11.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format i} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-11.2 {Tcl_BinaryObjCmd: format} { + list [catch {binary format i blat} msg] $msg +} {1 {expected integer but got "blat"}} +test binary-11.3 {Tcl_BinaryObjCmd: format} { + binary format i0 0x50 +} {} +test binary-11.4 {Tcl_BinaryObjCmd: format} { + binary format i 0x50 +} P\x00\x00\x00 +test binary-11.5 {Tcl_BinaryObjCmd: format} { + binary format i 0x5052 +} RP\x00\x00 +test binary-11.6 {Tcl_BinaryObjCmd: format} { + binary format i 0x505251 0x53 +} QRP\x00 +test binary-11.7 {Tcl_BinaryObjCmd: format} { + binary format i1 {0x505251 0x53} +} QRP\x00 +test binary-11.8 {Tcl_BinaryObjCmd: format} { + binary format i 0x53525150 +} PQRS +test binary-11.9 {Tcl_BinaryObjCmd: format} { + binary format i2 {0x50 0x52} +} P\x00\x00\x00R\x00\x00\x00 +test binary-11.10 {Tcl_BinaryObjCmd: format} { + binary format i* {0x50515253 0x52} +} SRQPR\x00\x00\x00 +test binary-11.11 {Tcl_BinaryObjCmd: format} { + list [catch {binary format i2 {0x50}} msg] $msg +} {1 {number of elements in list does not match count}} +test binary-11.12 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + list [catch {binary format i $a} msg] $msg +} [list 1 "expected integer but got \"0x50 0x51\""] +test binary-11.13 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + binary format i1 $a +} P\x00\x00\x00 + +test binary-12.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format I} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-12.2 {Tcl_BinaryObjCmd: format} { + list [catch {binary format I blat} msg] $msg +} {1 {expected integer but got "blat"}} +test binary-12.3 {Tcl_BinaryObjCmd: format} { + binary format I0 0x50 +} {} +test binary-12.4 {Tcl_BinaryObjCmd: format} { + binary format I 0x50 +} \x00\x00\x00P +test binary-12.5 {Tcl_BinaryObjCmd: format} { + binary format I 0x5052 +} \x00\x00PR +test binary-12.6 {Tcl_BinaryObjCmd: format} { + binary format I 0x505251 0x53 +} \x00PRQ +test binary-12.7 {Tcl_BinaryObjCmd: format} { + binary format I1 {0x505251 0x53} +} \x00PRQ +test binary-12.8 {Tcl_BinaryObjCmd: format} { + binary format I 0x53525150 +} SRQP +test binary-12.9 {Tcl_BinaryObjCmd: format} { + binary format I2 {0x50 0x52} +} \x00\x00\x00P\x00\x00\x00R +test binary-12.10 {Tcl_BinaryObjCmd: format} { + binary format I* {0x50515253 0x52} +} PQRS\x00\x00\x00R +test binary-12.11 {Tcl_BinaryObjCmd: format} { + list [catch {binary format i2 {0x50}} msg] $msg +} {1 {number of elements in list does not match count}} +test binary-12.12 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + list [catch {binary format I $a} msg] $msg +} [list 1 "expected integer but got \"0x50 0x51\""] +test binary-12.13 {Tcl_BinaryObjCmd: format} { + set a {0x50 0x51} + binary format I1 $a +} \x00\x00\x00P + +test binary-13.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format f} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-13.2 {Tcl_BinaryObjCmd: format} { + list [catch {binary format f blat} msg] $msg +} {1 {expected floating-point number but got "blat"}} +test binary-13.3 {Tcl_BinaryObjCmd: format} { + binary format f0 1.6 +} {} +test binary-13.4 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format f 1.6 +} \x3f\xcc\xcc\xcd +test binary-13.5 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format f 1.6 +} \xcd\xcc\xcc\x3f +test binary-13.6 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format f* {1.6 3.4} +} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +test binary-13.7 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format f* {1.6 3.4} +} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +test binary-13.8 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format f2 {1.6 3.4} +} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +test binary-13.9 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format f2 {1.6 3.4} +} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +test binary-13.10 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format f2 {1.6 3.4 5.6} +} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +test binary-13.11 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format f2 {1.6 3.4 5.6} +} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +test binary-13.12 {Tcl_BinaryObjCmd: float overflow} {nonPortable macOrUnix} { + binary format f -3.402825e+38 +} \xff\x7f\xff\xff +test binary-13.13 {Tcl_BinaryObjCmd: float overflow} {nonPortable pcOnly} { + binary format f -3.402825e+38 +} \xff\xff\x7f\xff +test binary-13.14 {Tcl_BinaryObjCmd: float underflow} {nonPortable macOrUnix} { + binary format f -3.402825e-100 +} \x80\x00\x00\x00 +test binary-13.15 {Tcl_BinaryObjCmd: float underflow} {nonPortable pcOnly} { + binary format f -3.402825e-100 +} \x00\x00\x00\x80 +test binary-13.16 {Tcl_BinaryObjCmd: format} { + list [catch {binary format f2 {1.6}} msg] $msg +} {1 {number of elements in list does not match count}} +test binary-13.17 {Tcl_BinaryObjCmd: format} { + set a {1.6 3.4} + list [catch {binary format f $a} msg] $msg +} [list 1 "expected floating-point number but got \"1.6 3.4\""] +test binary-13.18 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + set a {1.6 3.4} + binary format f1 $a +} \x3f\xcc\xcc\xcd +test binary-13.19 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + set a {1.6 3.4} + binary format f1 $a +} \xcd\xcc\xcc\x3f + +test binary-14.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format d} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-14.2 {Tcl_BinaryObjCmd: format} { + list [catch {binary format d blat} msg] $msg +} {1 {expected floating-point number but got "blat"}} +test binary-14.3 {Tcl_BinaryObjCmd: format} { + binary format d0 1.6 +} {} +test binary-14.4 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format d 1.6 +} \x3f\xf9\x99\x99\x99\x99\x99\x9a +test binary-14.5 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format d 1.6 +} \x9a\x99\x99\x99\x99\x99\xf9\x3f +test binary-14.6 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format d* {1.6 3.4} +} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +test binary-14.7 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format d* {1.6 3.4} +} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +test binary-14.8 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format d2 {1.6 3.4} +} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +test binary-14.9 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format d2 {1.6 3.4} +} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +test binary-14.10 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + binary format d2 {1.6 3.4 5.6} +} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +test binary-14.11 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + binary format d2 {1.6 3.4 5.6} +} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +test binary-14.12 {Tcl_BinaryObjCmd: float overflow} {nonPortable unixOnly} { + binary format d NaN +} \x7f\xff\xff\xff\xff\xff\xff\xff +test binary-14.13 {Tcl_BinaryObjCmd: float overflow} {nonPortable macOnly} { + binary format d NaN +} \x7f\xf8\x02\xa0\x00\x00\x00\x00 +test binary-14.14 {Tcl_BinaryObjCmd: format} { + list [catch {binary format d2 {1.6}} msg] $msg +} {1 {number of elements in list does not match count}} +test binary-14.15 {Tcl_BinaryObjCmd: format} { + set a {1.6 3.4} + list [catch {binary format d $a} msg] $msg +} [list 1 "expected floating-point number but got \"1.6 3.4\""] +test binary-14.16 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} { + set a {1.6 3.4} + binary format d1 $a +} \x3f\xf9\x99\x99\x99\x99\x99\x9a +test binary-14.17 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} { + set a {1.6 3.4} + binary format d1 $a +} \x9a\x99\x99\x99\x99\x99\xf9\x3f + +test binary-15.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format ax*a "y" "z"} msg] $msg +} {1 {cannot use "*" in format string with "x"}} +test binary-15.2 {Tcl_BinaryObjCmd: format} { + binary format axa "y" "z" +} y\x00z +test binary-15.3 {Tcl_BinaryObjCmd: format} { + binary format ax3a "y" "z" +} y\x00\x00\x00z +test binary-15.4 {Tcl_BinaryObjCmd: format} { + binary format a*X3x3a* "foo" "z" +} \x00\x00\x00z + +test binary-16.1 {Tcl_BinaryObjCmd: format} { + binary format a*X*a "foo" "z" +} zoo +test binary-16.2 {Tcl_BinaryObjCmd: format} { + binary format aX3a "y" "z" +} z +test binary-16.3 {Tcl_BinaryObjCmd: format} { + binary format a*Xa* "foo" "zy" +} fozy +test binary-16.4 {Tcl_BinaryObjCmd: format} { + binary format a*X3a "foobar" "z" +} foozar +test binary-16.5 {Tcl_BinaryObjCmd: format} { + binary format a*X3aX2a "foobar" "z" "b" +} fobzar + +test binary-17.1 {Tcl_BinaryObjCmd: format} { + binary format @1 +} \x00 +test binary-17.2 {Tcl_BinaryObjCmd: format} { + binary format @5a2 "ab" +} \x00\x00\x00\x00\x00\x61\x62 +test binary-17.3 {Tcl_BinaryObjCmd: format} { + binary format {a* @0 a2 @* a*} "foobar" "ab" "blat" +} abobarblat + +test binary-18.1 {Tcl_BinaryObjCmd: format} { + list [catch {binary format u0a3 abc abd} msg] $msg +} {1 {bad field specifier "u"}} + + +test binary-19.1 {Tcl_BinaryObjCmd: errors} { + list [catch {binary s} msg] $msg +} {1 {wrong # args: should be "binary scan value formatString ?varName varName ...?"}} +test binary-19.2 {Tcl_BinaryObjCmd: errors} { + list [catch {binary scan foo} msg] $msg +} {1 {wrong # args: should be "binary scan value formatString ?varName varName ...?"}} +test binary-19.3 {Tcl_BinaryObjCmd: scan} { + binary scan {} {} +} 0 + +test binary-20.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc a} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-20.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan abc a arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-20.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 abc + list [binary scan abc a0 arg1] $arg1 +} {1 {}} +test binary-20.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc a* arg1] $arg1 +} {1 abc} +test binary-20.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc a5 arg1] [info exist arg1] +} {0 0} +test binary-20.6 {Tcl_BinaryObjCmd: scan} { + set arg1 foo + list [binary scan abc a2 arg1] $arg1 +} {1 ab} +test binary-20.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + list [binary scan abcdef a2a2 arg1 arg2] $arg1 $arg2 +} {2 ab cd} +test binary-20.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc a2 arg1(a)] $arg1(a) +} {1 ab} +test binary-20.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc a arg1(a)] $arg1(a) +} {1 a} + +test binary-21.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc A} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-21.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan abc A arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-21.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 abc + list [binary scan abc A0 arg1] $arg1 +} {1 {}} +test binary-21.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc A* arg1] $arg1 +} {1 abc} +test binary-21.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc A5 arg1] [info exist arg1] +} {0 0} +test binary-21.6 {Tcl_BinaryObjCmd: scan} { + set arg1 foo + list [binary scan abc A2 arg1] $arg1 +} {1 ab} +test binary-21.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + list [binary scan abcdef A2A2 arg1 arg2] $arg1 $arg2 +} {2 ab cd} +test binary-21.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc A2 arg1(a)] $arg1(a) +} {1 ab} +test binary-21.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc A2 arg1(a)] $arg1(a) +} {1 ab} +test binary-21.10 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc A arg1(a)] $arg1(a) +} {1 a} +test binary-21.11 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan "abc def \x00 " A* arg1] $arg1 +} {1 {abc def}} +test binary-21.12 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan "abc def \x00ghi " A* arg1] $arg1 +} [list 1 "abc def \x00ghi"] + +test binary-22.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc b} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-22.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 b* arg1] $arg1 +} {1 0100101011001010} +test binary-22.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x82\x53 b arg1] $arg1 +} {1 0} +test binary-22.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x82\x53 b1 arg1] $arg1 +} {1 0} +test binary-22.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x82\x53 b0 arg1] $arg1 +} {1 {}} +test binary-22.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 b5 arg1] $arg1 +} {1 01001} +test binary-22.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 b8 arg1] $arg1 +} {1 01001010} +test binary-22.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 b14 arg1] $arg1 +} {1 01001010110010} +test binary-22.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 b14 arg1] $arg1 +} {0 foo} +test binary-22.10 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53 b1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-22.11 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x07\x87\x05 b5b* arg1 arg2] $arg1 $arg2 +} {2 11100 1110000110100000} + + +test binary-23.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc B} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-23.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 B* arg1] $arg1 +} {1 0101001001010011} +test binary-23.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x82\x53 B arg1] $arg1 +} {1 1} +test binary-23.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x82\x53 B1 arg1] $arg1 +} {1 1} +test binary-23.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 B0 arg1] $arg1 +} {1 {}} +test binary-23.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 B5 arg1] $arg1 +} {1 01010} +test binary-23.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 B8 arg1] $arg1 +} {1 01010010} +test binary-23.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 B14 arg1] $arg1 +} {1 01010010010100} +test binary-23.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 B14 arg1] $arg1 +} {0 foo} +test binary-23.10 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53 B1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-23.11 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x70\x87\x05 B5B* arg1 arg2] $arg1 $arg2 +} {2 01110 1000011100000101} + +test binary-24.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc h} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-24.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 h* arg1] $arg1 +} {1 253a} +test binary-24.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \xc2\xa3 h arg1] $arg1 +} {1 2} +test binary-24.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x82\x53 h1 arg1] $arg1 +} {1 2} +test binary-24.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 h0 arg1] $arg1 +} {1 {}} +test binary-24.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \xf2\x53 h2 arg1] $arg1 +} {1 2f} +test binary-24.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 h3 arg1] $arg1 +} {1 253} +test binary-24.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 h3 arg1] $arg1 +} {0 foo} +test binary-24.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53 h1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-24.10 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x70\x87\x05 h2h* arg1 arg2] $arg1 $arg2 +} {2 07 7850} + +test binary-25.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc H} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-25.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 H* arg1] $arg1 +} {1 52a3} +test binary-25.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \xc2\xa3 H arg1] $arg1 +} {1 c} +test binary-25.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x82\x53 H1 arg1] $arg1 +} {1 8} +test binary-25.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 H0 arg1] $arg1 +} {1 {}} +test binary-25.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \xf2\x53 H2 arg1] $arg1 +} {1 f2} +test binary-25.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\x53 H3 arg1] $arg1 +} {1 525} +test binary-25.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 H3 arg1] $arg1 +} {0 foo} +test binary-25.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53 H1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-25.10 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x70\x87\x05 H2H* arg1 arg2] $arg1 $arg2 +} {2 70 8705} + +test binary-26.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc c} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-26.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 c* arg1] $arg1 +} {1 {82 -93}} +test binary-26.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 c arg1] $arg1 +} {1 82} +test binary-26.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 c1 arg1] $arg1 +} {1 82} +test binary-26.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 c0 arg1] $arg1 +} {1 {}} +test binary-26.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 c2 arg1] $arg1 +} {1 {82 -93}} +test binary-26.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \xff c arg1] $arg1 +} {1 -1} +test binary-26.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 c3 arg1] $arg1 +} {0 foo} +test binary-26.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53 c1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-26.10 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x70\x87\x05 c2c* arg1 arg2] $arg1 $arg2 +} {2 {112 -121} 5} + +test binary-27.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc s} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-27.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 s* arg1] $arg1 +} {1 {-23726 21587}} +test binary-27.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 s arg1] $arg1 +} {1 -23726} +test binary-27.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 s1 arg1] $arg1 +} {1 -23726} +test binary-27.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 s0 arg1] $arg1 +} {1 {}} +test binary-27.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 s2 arg1] $arg1 +} {1 {-23726 21587}} +test binary-27.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 s1 arg1] $arg1 +} {0 foo} +test binary-27.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53 s1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-27.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x52\xa3\x53\x54\x05 s2c* arg1 arg2] $arg1 $arg2 +} {2 {-23726 21587} 5} + +test binary-28.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc S} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-28.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 S* arg1] $arg1 +} {1 {21155 21332}} +test binary-28.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 S arg1] $arg1 +} {1 21155} +test binary-28.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 S1 arg1] $arg1 +} {1 21155} +test binary-28.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3 S0 arg1] $arg1 +} {1 {}} +test binary-28.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 S2 arg1] $arg1 +} {1 {21155 21332}} +test binary-28.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 S1 arg1] $arg1 +} {0 foo} +test binary-28.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53 S1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-28.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x52\xa3\x53\x54\x05 S2c* arg1 arg2] $arg1 $arg2 +} {2 {21155 21332} 5} + +test binary-29.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc i} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-29.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i* arg1] $arg1 +} {1 {1414767442 67305985}} +test binary-29.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i arg1] $arg1 +} {1 1414767442} +test binary-29.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 i1 arg1] $arg1 +} {1 1414767442} +test binary-29.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53 i0 arg1] $arg1 +} {1 {}} +test binary-29.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i2 arg1] $arg1 +} {1 {1414767442 67305985}} +test binary-29.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 i1 arg1] $arg1 +} {0 foo} +test binary-29.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53\x53\x54 i1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-29.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 i2c* arg1 arg2] $arg1 $arg2 +} {2 {1414767442 67305985} 5} + +test binary-30.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc I} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-30.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I* arg1] $arg1 +} {1 {1386435412 16909060}} +test binary-30.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I arg1] $arg1 +} {1 1386435412} +test binary-30.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54 I1 arg1] $arg1 +} {1 1386435412} +test binary-30.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53 I0 arg1] $arg1 +} {1 {}} +test binary-30.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I2 arg1] $arg1 +} {1 {1386435412 16909060}} +test binary-30.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 I1 arg1] $arg1 +} {0 foo} +test binary-30.8 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x52\x53\x53\x54 I1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-30.9 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 I2c* arg1 arg2] $arg1 $arg2 +} {2 {1386435412 16909060} 5} + +test binary-31.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc f} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-31.2 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1 +} {1 {1.60000002384 3.40000009537}} +test binary-31.3 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f* arg1] $arg1 +} {1 {1.60000002384 3.40000009537}} +test binary-31.4 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f arg1] $arg1 +} {1 1.60000002384} +test binary-31.5 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f arg1] $arg1 +} {1 1.60000002384} +test binary-31.6 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xcc\xcc\xcd f1 arg1] $arg1 +} {1 1.60000002384} +test binary-31.7 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \xcd\xcc\xcc\x3f f1 arg1] $arg1 +} {1 1.60000002384} +test binary-31.8 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xcc\xcc\xcd f0 arg1] $arg1 +} {1 {}} +test binary-31.9 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \xcd\xcc\xcc\x3f f0 arg1] $arg1 +} {1 {}} +test binary-31.10 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f2 arg1] $arg1 +} {1 {1.60000002384 3.40000009537}} +test binary-31.11 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f2 arg1] $arg1 +} {1 {1.60000002384 3.40000009537}} +test binary-31.12 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 f1 arg1] $arg1 +} {0 foo} +test binary-31.13 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x3f\xcc\xcc\xcd f1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-31.14 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 f2c* arg1 arg2] $arg1 $arg2 +} {2 {1.60000002384 3.40000009537} 5} +test binary-31.15 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2 +} {2 {1.60000002384 3.40000009537} 5} + +test binary-32.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abc d} msg] $msg +} {1 {not enough arguments for all format specifiers}} +test binary-32.2 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d* arg1] $arg1 +} {1 {1.6 3.4}} +test binary-32.3 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d* arg1] $arg1 +} {1 {1.6 3.4}} +test binary-32.4 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d arg1] $arg1 +} {1 1.6} +test binary-32.5 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d arg1] $arg1 +} {1 1.6} +test binary-32.6 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1] $arg1 +} {1 1.6} +test binary-32.7 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d1 arg1] $arg1 +} {1 1.6} +test binary-32.8 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d0 arg1] $arg1 +} {1 {}} +test binary-32.9 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d0 arg1] $arg1 +} {1 {}} +test binary-32.10 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1} + list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d2 arg1] $arg1 +} {1 {1.6 3.4}} +test binary-32.11 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1} + list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d2 arg1] $arg1 +} {1 {1.6 3.4}} +test binary-32.12 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 foo + list [binary scan \x52 d1 arg1] $arg1 +} {0 foo} +test binary-32.13 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + set arg1 1 + list [catch {binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1(a)} msg] $msg +} {1 {can't set "arg1(a)": variable isn't array}} +test binary-32.14 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33\x05 d2c* arg1 arg2] $arg1 $arg2 +} {2 {1.6 3.4} 5} +test binary-32.15 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} { + catch {unset arg1 arg2} + set arg1 foo + set arg2 bar + list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40\x05 d2c* arg1 arg2] $arg1 $arg2 +} {2 {1.6 3.4} 5} + +test binary-33.1 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + list [binary scan abcdefg a2xa3 arg1 arg2] $arg1 $arg2 +} {2 ab def} +test binary-33.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + set arg2 foo + list [binary scan abcdefg a3x*a3 arg1 arg2] $arg1 $arg2 +} {1 abc foo} +test binary-33.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + set arg2 foo + list [binary scan abcdefg a3x20a3 arg1 arg2] $arg1 $arg2 +} {1 abc foo} +test binary-33.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + set arg2 foo + list [binary scan abc a3x20a3 arg1 arg2] $arg1 $arg2 +} {1 abc foo} +test binary-33.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x1a1 arg1] $arg1 +} {1 b} +test binary-33.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x5a1 arg1] $arg1 +} {1 f} +test binary-33.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x0a1 arg1] $arg1 +} {1 a} + +test binary-34.1 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + list [binary scan abcdefg a2Xa3 arg1 arg2] $arg1 $arg2 +} {2 ab bcd} +test binary-34.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + set arg2 foo + list [binary scan abcdefg a3X*a3 arg1 arg2] $arg1 $arg2 +} {2 abc abc} +test binary-34.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + set arg2 foo + list [binary scan abcdefg a3X20a3 arg1 arg2] $arg1 $arg2 +} {2 abc abc} +test binary-34.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abc X20a3 arg1] $arg1 +} {1 abc} +test binary-34.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x*X1a1 arg1] $arg1 +} {1 f} +test binary-34.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x*X5a1 arg1] $arg1 +} {1 b} +test binary-34.7 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x3X0a1 arg1] $arg1 +} {1 d} + +test binary-35.1 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + list [catch {binary scan abcdefg a2@a3 arg1 arg2} msg] $msg +} {1 {missing count for "@" field specifier}} +test binary-35.2 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + set arg2 foo + list [binary scan abcdefg a3@*a3 arg1 arg2] $arg1 $arg2 +} {1 abc foo} +test binary-35.3 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + catch {unset arg2} + set arg2 foo + list [binary scan abcdefg a3@20a3 arg1 arg2] $arg1 $arg2 +} {1 abc foo} +test binary-35.4 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef @2a3 arg1] $arg1 +} {1 cde} +test binary-35.5 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x*@1a1 arg1] $arg1 +} {1 b} +test binary-35.6 {Tcl_BinaryObjCmd: scan} { + catch {unset arg1} + list [binary scan abcdef x*@0a1 arg1] $arg1 +} {1 a} + +test binary-36.1 {Tcl_BinaryObjCmd: scan} { + list [catch {binary scan abcdef u0a3} msg] $msg +} {1 {bad field specifier "u"}} + +# GetFormatSpec is pretty thoroughly tested above, but there are a few +# cases we should text explicitly + +test binary-37.1 {GetFormatSpec: whitespace} { + binary format "a3 a5 a3" foo barblat baz +} foobarblbaz +test binary-37.2 {GetFormatSpec: whitespace} { + binary format " " foo +} {} +test binary-37.3 {GetFormatSpec: whitespace} { + binary format " a3" foo +} foo +test binary-37.4 {GetFormatSpec: whitespace} { + binary format "" foo +} {} +test binary-37.5 {GetFormatSpec: whitespace} { + binary format "" foo +} {} +test binary-37.6 {GetFormatSpec: whitespace} { + binary format " a3 " foo +} foo +test binary-37.7 {GetFormatSpec: numbers} { + list [catch {binary scan abcdef "x-1" foo} msg] $msg +} {1 {bad field specifier "-"}} +test binary-37.8 {GetFormatSpec: numbers} { + catch {unset arg1} + set arg1 foo + list [binary scan abcdef "a0x3" arg1] $arg1 +} {1 {}} +test binary-37.9 {GetFormatSpec: numbers} { + # test format of neg numbers + # bug report/fix provided by Harald Kirsch + set x [binary format f* {1 -1 2 -2 0}] + binary scan $x f* bla + set bla +} {1.0 -1.0 2.0 -2.0 0.0} + +test binary-38.1 {FormatNumber: word alignment} { + set x [binary format c1s1 1 1] +} \x01\x01\x00 +test binary-38.2 {FormatNumber: word alignment} { + set x [binary format c1S1 1 1] +} \x01\x00\x01 +test binary-38.3 {FormatNumber: word alignment} { + set x [binary format c1i1 1 1] +} \x01\x01\x00\x00\x00 +test binary-38.4 {FormatNumber: word alignment} { + set x [binary format c1I1 1 1] +} \x01\x00\x00\x00\x01 +test binary-38.5 {FormatNumber: word alignment} {nonPortable macOrUnix} { + set x [binary format c1d1 1 1.6] +} \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a +test binary-38.6 {FormatNumber: word alignment} {nonPortable pcOnly} { + set x [binary format c1d1 1 1.6] +} \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f +test binary-38.7 {FormatNumber: word alignment} {nonPortable macOrUnix} { + set x [binary format c1f1 1 1.6] +} \x01\x3f\xcc\xcc\xcd +test binary-38.8 {FormatNumber: word alignment} {nonPortable pcOnly} { + set x [binary format c1f1 1 1.6] +} \x01\xcd\xcc\xcc\x3f + +test binary-39.1 {ScanNumber: sign extension} { + catch {unset arg1} + list [binary scan \x52\xa3 c2 arg1] $arg1 +} {1 {82 -93}} +test binary-39.2 {ScanNumber: sign extension} { + catch {unset arg1} + list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 s4 arg1] $arg1 +} {1 {513 -32511 386 -32127}} +test binary-39.3 {ScanNumber: sign extension} { + catch {unset arg1} + list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 S4 arg1] $arg1 +} {1 {258 385 -32255 -32382}} +test binary-39.4 {ScanNumber: sign extension} { + catch {unset arg1} + list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 i5 arg1] $arg1 +} {1 {33620225 16843137 16876033 25297153 -2130640639}} +test binary-39.5 {ScanNumber: sign extension} { + catch {unset arg1} + list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 I5 arg1] $arg1 +} {1 {16843010 -2130640639 25297153 16876033 16843137}} + +test binary-40.1 {ScanNumber: floating point overflow} {nonPortable unixOnly} { + catch {unset arg1} + list [binary scan \xff\xff\xff\xff f1 arg1] $arg1 +} {1 -NaN} +test binary-40.2 {ScanNumber: floating point overflow} {nonPortable macOnly} { + catch {unset arg1} + list [binary scan \xff\xff\xff\xff f1 arg1] $arg1 +} {1 -NAN(255)} +test binary-40.3 {ScanNumber: floating point overflow} {nonPortable pcOnly} { + catch {unset arg1} + set result [binary scan \xff\xff\xff\xff f1 arg1] + if {([string compare $arg1 -1.\#QNAN] == 0) + || ([string compare $arg1 -NAN] == 0)} { + lappend result success + } else { + lappend result failure + } +} {1 success} +test binary-40.4 {ScanNumber: floating point overflow} {nonPortable unixOnly} { + catch {unset arg1} + list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1] $arg1 +} {1 -NaN} +test binary-40.5 {ScanNumber: floating point overflow} {nonPortable macOnly} { + catch {unset arg1} + list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1] $arg1 +} {1 -NAN(255)} +test binary-40.6 {ScanNumber: floating point overflow} {nonPortable pcOnly} { + catch {unset arg1} + set result [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1] + if {([string compare $arg1 -1.\#QNAN] == 0) + || ([string compare $arg1 -NAN] == 0)} { + lappend result success + } else { + lappend result failure + } +} {1 success} + +test binary-41.1 {ScanNumber: word alignment} { + catch {unset arg1; unset arg2} + list [binary scan \x01\x01\x00 c1s1 arg1 arg2] $arg1 $arg2 +} {2 1 1} +test binary-41.2 {ScanNumber: word alignment} { + catch {unset arg1; unset arg2} + list [binary scan \x01\x00\x01 c1S1 arg1 arg2] $arg1 $arg2 +} {2 1 1} +test binary-41.3 {ScanNumber: word alignment} { + catch {unset arg1; unset arg2} + list [binary scan \x01\x01\x00\x00\x00 c1i1 arg1 arg2] $arg1 $arg2 +} {2 1 1} +test binary-41.4 {ScanNumber: word alignment} { + catch {unset arg1; unset arg2} + list [binary scan \x01\x00\x00\x00\x01 c1I1 arg1 arg2] $arg1 $arg2 +} {2 1 1} +test binary-41.5 {ScanNumber: word alignment} {nonPortable macOrUnix} { + catch {unset arg1; unset arg2} + list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2 +} {2 1 1.60000002384} +test binary-41.6 {ScanNumber: word alignment} {nonPortable pcOnly} { + catch {unset arg1; unset arg2} + list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2 +} {2 1 1.60000002384} +test binary-41.7 {ScanNumber: word alignment} {nonPortable macOrUnix} { + catch {unset arg1; unset arg2} + list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2 +} {2 1 1.6} +test binary-41.8 {ScanNumber: word alignment} {nonPortable pcOnly} { + catch {unset arg1; unset arg2} + list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2 +} {2 1 1.6} diff --git a/tests/case.test b/tests/case.test new file mode 100644 index 0000000..9224372 --- /dev/null +++ b/tests/case.test @@ -0,0 +1,83 @@ +# Commands covered: case +# +# 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: @(#) case.test 1.13 96/02/16 08:55:41 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test case-1.1 {simple pattern} { + case a in a {format 1} b {format 2} c {format 3} default {format 4} +} 1 +test case-1.2 {simple pattern} { + case b a {format 1} b {format 2} c {format 3} default {format 4} +} 2 +test case-1.3 {simple pattern} { + case x in a {format 1} b {format 2} c {format 3} default {format 4} +} 4 +test case-1.4 {simple pattern} { + case x a {format 1} b {format 2} c {format 3} +} {} +test case-1.5 {simple pattern matches many times} { + case b a {format 1} b {format 2} b {format 3} b {format 4} +} 2 +test case-1.6 {fancier pattern} { + case cx a {format 1} *c {format 2} *x {format 3} default {format 4} +} 3 +test case-1.7 {list of patterns} { + case abc in {a b c} {format 1} {def abc ghi} {format 2} +} 2 + +test case-2.1 {error in executed command} { + list [catch {case a in a {error "Just a test"} default {format 1}} msg] \ + $msg $errorInfo +} {1 {Just a test} {Just a test + while executing +"error "Just a test"" + ("a" arm line 1) + invoked from within +"case a in a {error "Just a test"} default {format 1}"}} +test case-2.2 {error: not enough args} { + list [catch {case} msg] $msg +} {1 {wrong # args: should be "case string ?in? patList body ... ?default body?"}} +test case-2.3 {error: pattern with no body} { + list [catch {case a b} msg] $msg +} {1 {extra case pattern with no body}} +test case-2.4 {error: pattern with no body} { + list [catch {case a in b {format 1} c} msg] $msg +} {1 {extra case pattern with no body}} +test case-2.5 {error in default command} { + list [catch {case foo in a {error case1} default {error case2} \ + b {error case 3}} msg] $msg $errorInfo +} {1 case2 {case2 + while executing +"error case2" + ("default" arm line 1) + invoked from within +"case foo in a {error case1} default {error case2} b {error case 3}"}} + +test case-3.1 {single-argument form for pattern/command pairs} { + case b in { + a {format 1} + b {format 2} + default {format 6} + } +} {2} +test case-3.2 {single-argument form for pattern/command pairs} { + case b { + a {format 1} + b {format 2} + default {format 6} + } +} {2} +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}} diff --git a/tests/clock.test b/tests/clock.test new file mode 100644 index 0000000..95f73ac --- /dev/null +++ b/tests/clock.test @@ -0,0 +1,175 @@ +# Commands covered: clock +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) clock.test 1.17 97/11/24 15:05:38 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test clock-1.1 {clock tests} { + list [catch {clock} msg] $msg +} {1 {wrong # args: should be "clock option ?arg ...?"}} +test clock-1.2 {clock tests} { + list [catch {clock foo} msg] $msg +} {1 {bad option "foo": must be clicks, format, scan, or seconds}} + +# clock clicks +test clock-2.1 {clock clicks tests} { + expr [clock clicks]+1 + concat {} +} {} +test clock-2.2 {clock clicks tests} { + list [catch {clock clicks foo} msg] $msg +} {1 {wrong # args: should be "clock clicks"}} +test clock-2.3 {clock clicks tests} { + set start [clock clicks] + after 10 + set end [clock clicks] + expr "$end > $start" +} {1} + +# clock format +test clock-3.1 {clock format tests} {unixOnly} { + 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.2 {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} { + list [catch {clock format foo} msg] $msg +} {1 {expected integer but got "foo"}} +test clock-3.4 {clock format tests} {unixOrPc} { + set clockval 657687766 + clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true +} "Sun Nov 04 03:02:46 AM 1990" +test clock-3.5 {clock format tests} { + list [catch {clock format a b c d e g} msg] $msg +} {1 {wrong # args: should be "clock format clockval ?-format string? ?-gmt boolean?"}} +test clock-3.6 {clock format tests} {unixOrPc nonPortable} { + set clockval -1 + clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true +} "Wed Dec 31 11:59:59 PM 1969" +test clock-3.7 {clock format tests} { + list [catch {clock format 123 -bad arg} msg] $msg +} {1 {bad switch "-bad": must be -format, or -gmt}} +test clock-3.8 {clock format tests} { + clock format 123 -format "x" +} x +test clock-3.9 {clock format tests} { + clock format 123 -format "" +} "" + +# clock scan +test clock-4.1 {clock scan tests} { + list [catch {clock scan} msg] $msg +} {1 {wrong # args: should be "clock scan dateString ?-base clockValue? ?-gmt boolean?"}} +test clock-4.2 {clock scan tests} { + list [catch {clock scan "bad-string"} msg] $msg +} {1 {unable to convert date-time string "bad-string"}} +test clock-4.3 {clock scan tests} { + clock format [clock scan "14 Feb 92" -gmt true] \ + -format {%m/%d/%y %I:%M:%S %p} -gmt true +} {02/14/92 12:00:00 AM} +test clock-4.4 {clock scan tests} { + clock format [clock scan "Feb 14, 1992 12:20 PM" -gmt true] \ + -format {%m/%d/%y %I:%M:%S %p} -gmt true +} {02/14/92 12:20:00 PM} +test clock-4.5 {clock scan tests} { + clock format \ + [clock scan "Feb 14, 1992 12:20 PM" -base 319363200 -gmt true] \ + -format {%m/%d/%y %I:%M:%S %p} -gmt true +} {02/14/92 12:20:00 PM} +test clock-4.6 {clock scan tests} { + set time [clock scan "Oct 23,1992 15:00"] + clock format $time -format {%b %d,%Y %H:%M} +} {Oct 23,1992 15:00} +test clock-4.7 {clock scan tests} { + set time [clock scan "Oct 23,1992 15:00 GMT"] + clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true +} {Oct 23,1992 15:00 GMT} +test clock-4.8 {clock scan tests} { + set time [clock scan "Oct 23,1992 15:00" -gmt true] + clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true +} {Oct 23,1992 15:00 GMT} +test clock-4.9 {clock scan tests} { + list [catch {clock scan "Jan 12" -bad arg} msg] $msg +} {1 {bad switch "-bad": must be -base, or -gmt}} +# The following two two tests test the two year date policy +test clock-4.10 {clock scan tests} { + set time [clock scan "1/1/71" -gmt true] + clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true +} {Jan 01,1971 00:00 GMT} +test clock-4.11 {clock scan tests} { + set time [clock scan "1/1/37" -gmt true] + clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true +} {Jan 01,2037 00:00 GMT} + +# clock seconds +test clock-5.1 {clock seconds tests} { + expr [clock seconds]+1 + concat {} +} {} +test clock-5.2 {clock seconds tests} { + list [catch {clock seconds foo} msg] $msg +} {1 {wrong # args: should be "clock seconds"}} +test clock-5.3 {clock seconds tests} { + set start [clock seconds] + after 2000 + set end [clock seconds] + expr "$end > $start" +} {1} + +# The following dates check certain roll over dates +set day [expr 24 * 60 * 60] +test clock-6.1 {clock roll over dates} { + set time [clock scan "12/31/1998" -gmt true] + clock format [expr $time + $day] -format {%b %d,%Y %H:%M GMT} -gmt true +} {Jan 01,1999 00:00 GMT} +test clock-6.2 {clock roll over dates} { + set time [clock scan "12/31/1999" -gmt true] + clock format [expr $time + $day] -format {%b %d,%Y %H:%M GMT} -gmt true +} {Jan 01,2000 00:00 GMT} +test clock-6.3 {clock roll over dates} { + set time [clock scan "2/28/2000" -gmt true] + clock format [expr $time + $day] -format {%b %d,%Y %H:%M GMT} -gmt true +} {Feb 29,2000 00:00 GMT} +test clock-6.4 {clock roll over dates} { + set time [clock scan "2/29/2000" -gmt true] + clock format [expr $time + $day] -format {%b %d,%Y %H:%M GMT} -gmt true +} {Mar 01,2000 00:00 GMT} +test clock-6.5 {clock roll over dates} { + set time [clock scan "January 1, 2000" -gmt true] + clock format $time -format %A -gmt true +} {Saturday} +test clock-6.6 {clock roll over dates} { + set time [clock scan "January 1, 2000" -gmt true] + clock format $time -format %j -gmt true +} {001} +test clock-6.7 {clock roll over dates} { + set time [clock scan "February 29, 2000" -gmt true] + clock format $time -format %A -gmt true +} {Tuesday} +test clock-6.8 {clock roll over dates} { + set time [clock scan "February 29, 2000" -gmt true] + clock format $time -format %j -gmt true +} {060} +test clock-6.9 {clock roll over dates} { + set time [clock scan "March 1, 2000" -gmt true] + clock format $time -format %A -gmt true +} {Wednesday} +test clock-6.10 {clock roll over dates} { + set time [clock scan "March 1, 2000" -gmt true] + clock format $time -format %j -gmt true +} {061} +test clock-6.11 {clock roll over dates} { + set time [clock scan "March 1, 2001" -gmt true] + clock format $time -format %j -gmt true +} {060} diff --git a/tests/cmdAH.test b/tests/cmdAH.test new file mode 100644 index 0000000..351008e --- /dev/null +++ b/tests/cmdAH.test @@ -0,0 +1,1256 @@ +# The file tests the tclCmdAH.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996-1997 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 + +if {[string compare test [info procs test]] == 1} then {source defs} + +global env +set platform [testgetplatform] + +test cmdAH-1.1 {Tcl_FileObjCmd} { + list [catch file msg] $msg +} {1 {wrong # args: should be "file option ?arg ...?"}} +test cmdAH-1.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} { + list [catch {file atime} msg] $msg +} {1 {wrong # args: should be "file atime name ?arg ...?"}} + + +#volume + +test cmdAH-2.1 {Tcl_FileObjCmd: volumes} { + list [catch {file volumes x} msg] $msg +} {1 {wrong # args: should be "file volumes"}} +test cmdAH-2.2 {Tcl_FileObjCmd: volumes} { + set volumeList [file volumes] + if { [llength $volumeList] == 0 } { + set result 0 + } else { + set result 1 + } +} {1} +test cmdAH-2.3 {Tcl_FileObjCmd: volumes} {macOrUnix} { + set volumeList [file volumes] + catch [list glob -nocomplain [lindex $volumeList 0]*] +} {0} +test cmdAH-2.4 {Tcl_FileObjCmd: volumes} {pcOnly} { + set volumeList [file volumes] + list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}] +} {0 1 0} + +# attributes + +test cmdAH-3.1 {Tcl_FileObjCmd - file attrs} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file}] [file delete -force foo.file] +} {0 {}} + +# dirname + +test cmdAH-4.1 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + list [catch {file dirname a b} msg] $msg +} {1 {wrong # args: should be "file dirname name"}} +test cmdAH-4.2 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + file dirname /a/b +} /a +test cmdAH-4.3 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + file dirname {} +} . +test cmdAH-4.4 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + file dirname {} +} : +test cmdAH-4.5 {Tcl_FileObjCmd: dirname} { + testsetplatform win + file dirname {} +} . +test cmdAH-4.6 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + file dirname .def +} . +test cmdAH-4.7 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + file dirname a +} : +test cmdAH-4.8 {Tcl_FileObjCmd: dirname} { + testsetplatform win + file dirname a +} . +test cmdAH-4.9 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + file dirname a/b/c.d +} a/b +test cmdAH-4.10 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + file dirname a/b.c/d +} a/b.c +test cmdAH-4.11 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + file dirname /. +} / +test cmdAH-4.12 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + list [catch {file dirname /} msg] $msg +} {0 /} +test cmdAH-4.13 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + list [catch {file dirname /foo} msg] $msg +} {0 /} +test cmdAH-4.14 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + list [catch {file dirname //foo} msg] $msg +} {0 /} +test cmdAH-4.15 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + list [catch {file dirname //foo/bar} msg] $msg +} {0 /foo} +test cmdAH-4.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} { + testsetplatform unix + list [catch {file dirname {//foo\/bar/baz/blat}} msg] $msg +} {0 {/foo\/bar/baz}} +test cmdAH-4.18 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + list [catch {file dirname /foo//} msg] $msg +} {0 /} +test cmdAH-4.19 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + list [catch {file dirname ./a} msg] $msg +} {0 .} +test cmdAH-4.20 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + list [catch {file dirname a/.a} msg] $msg +} {0 a} +test cmdAH-4.21 {Tcl_FileObjCmd: dirname} { + testsetplatform windows + list [catch {file dirname c:foo} msg] $msg +} {0 c:} +test cmdAH-4.22 {Tcl_FileObjCmd: dirname} { + testsetplatform windows + list [catch {file dirname c:} msg] $msg +} {0 c:} +test cmdAH-4.23 {Tcl_FileObjCmd: dirname} { + testsetplatform windows + list [catch {file dirname c:/} msg] $msg +} {0 c:/} +test cmdAH-4.24 {Tcl_FileObjCmd: dirname} { + testsetplatform windows + list [catch {file dirname {c:\foo}} msg] $msg +} {0 c:/} +test cmdAH-4.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} { + testsetplatform windows + list [catch {file dirname {//foo/bar}} msg] $msg +} {0 //foo/bar} +test cmdAH-4.27 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + list [catch {file dirname :} msg] $msg +} {0 :} +test cmdAH-4.28 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + list [catch {file dirname :Foo} msg] $msg +} {0 :} +test cmdAH-4.29 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + list [catch {file dirname Foo:} msg] $msg +} {0 Foo:} +test cmdAH-4.30 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + list [catch {file dirname Foo:bar} msg] $msg +} {0 Foo:} +test cmdAH-4.31 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + list [catch {file dirname :Foo:bar} msg] $msg +} {0 :Foo} +test cmdAH-4.32 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + list [catch {file dirname ::} msg] $msg +} {0 :} +test cmdAH-4.33 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + list [catch {file dirname :::} msg] $msg +} {0 ::} +test cmdAH-4.34 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + list [catch {file dirname /foo/bar/} msg] $msg +} {0 foo:} +test cmdAH-4.35 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + list [catch {file dirname /foo/bar} msg] $msg +} {0 foo:} +test cmdAH-4.36 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + list [catch {file dirname /foo} msg] $msg +} {0 foo:} +test cmdAH-4.37 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + list [catch {file dirname foo} msg] $msg +} {0 :} +test cmdAH-4.38 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + list [catch {file dirname ~/foo} msg] $msg +} {0 ~} +test cmdAH-4.39 {Tcl_FileObjCmd: dirname} { + testsetplatform unix + list [catch {file dirname ~bar/foo} msg] $msg +} {0 ~bar} +test cmdAH-4.40 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + list [catch {file dirname ~bar/foo} msg] $msg +} {0 ~bar:} +test cmdAH-4.41 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + list [catch {file dirname ~/foo} msg] $msg +} {0 ~:} +test cmdAH-4.42 {Tcl_FileObjCmd: dirname} { + testsetplatform mac + list [catch {file dirname ~:baz} msg] $msg +} {0 ~:} +test cmdAH-4.43 {Tcl_FileObjCmd: dirname} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform unix + set result [list [catch {file dirname ~} msg] $msg] + set env(HOME) $temp + set result +} {0 /home} +test cmdAH-4.44 {Tcl_FileObjCmd: dirname} { + global env + set temp $env(HOME) + set env(HOME) "~" + testsetplatform unix + set result [list [catch {file dirname ~} msg] $msg] + set env(HOME) $temp + set result +} {0 ~} +test cmdAH-4.45 {Tcl_FileObjCmd: dirname} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform windows + set result [list [catch {file dirname ~} msg] $msg] + set env(HOME) $temp + set result +} {0 /home} +test cmdAH-4.46 {Tcl_FileObjCmd: dirname} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform mac + set result [list [catch {file dirname ~} msg] $msg] + set env(HOME) $temp + set result +} {0 home:} + +# tail + +test cmdAH-5.1 {Tcl_FileObjCmd: tail} { + testsetplatform unix + list [catch {file tail a b} msg] $msg +} {1 {wrong # args: should be "file tail name"}} +test cmdAH-5.2 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file tail /a/b +} b +test cmdAH-5.3 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file tail {} +} {} +test cmdAH-5.4 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail {} +} {} +test cmdAH-5.5 {Tcl_FileObjCmd: tail} { + testsetplatform win + file tail {} +} {} +test cmdAH-5.6 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file tail .def +} .def +test cmdAH-5.7 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail a +} a +test cmdAH-5.8 {Tcl_FileObjCmd: tail} { + testsetplatform win + file tail a +} a +test cmdAH-5.9 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file ta a/b/c.d +} c.d +test cmdAH-5.10 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file tail a/b.c/d +} d +test cmdAH-5.11 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file tail /. +} . +test cmdAH-5.12 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file tail / +} {} +test cmdAH-5.13 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file tail /foo +} foo +test cmdAH-5.14 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file tail //foo +} foo +test cmdAH-5.15 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file tail //foo/bar +} bar +test cmdAH-5.16 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file tail {//foo\/bar/baz} +} baz +test cmdAH-5.17 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file tail {//foo\/bar/baz/blat} +} blat +test cmdAH-5.18 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file tail /foo// +} foo +test cmdAH-5.19 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file tail ./a +} a +test cmdAH-5.20 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file tail a/.a +} .a +test cmdAH-5.21 {Tcl_FileObjCmd: tail} { + testsetplatform windows + file tail c:foo +} foo +test cmdAH-5.22 {Tcl_FileObjCmd: tail} { + testsetplatform windows + file tail c: +} {} +test cmdAH-5.23 {Tcl_FileObjCmd: tail} { + testsetplatform windows + file tail c:/ +} {} +test cmdAH-5.24 {Tcl_FileObjCmd: tail} { + testsetplatform windows + file tail {c:\foo} +} foo +test cmdAH-5.25 {Tcl_FileObjCmd: tail} { + testsetplatform windows + file tail {//foo/bar/baz} +} baz +test cmdAH-5.26 {Tcl_FileObjCmd: tail} { + testsetplatform windows + file tail {//foo/bar} +} {} +test cmdAH-5.27 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail : +} : +test cmdAH-5.28 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail :Foo +} Foo +test cmdAH-5.29 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail Foo: +} {} +test cmdAH-5.30 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail Foo:bar +} bar +test cmdAH-5.31 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail :Foo:bar +} bar +test cmdAH-5.32 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail :: +} :: +test cmdAH-5.33 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail ::: +} :: +test cmdAH-5.34 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail /foo/bar/ +} bar +test cmdAH-5.35 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail /foo/bar +} bar +test cmdAH-5.36 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail /foo +} {} +test cmdAH-5.37 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail foo +} foo +test cmdAH-5.38 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail ~:foo +} foo +test cmdAH-5.39 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail ~bar:foo +} foo +test cmdAH-5.40 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail ~bar/foo +} foo +test cmdAH-5.41 {Tcl_FileObjCmd: tail} { + testsetplatform mac + file tail ~/foo +} foo +test cmdAH-5.42 {Tcl_FileObjCmd: tail} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform unix + set result [file tail ~] + set env(HOME) $temp + set result +} test +test cmdAH-5.43 {Tcl_FileObjCmd: tail} { + global env + set temp $env(HOME) + set env(HOME) "~" + testsetplatform unix + set result [file tail ~] + set env(HOME) $temp + set result +} {} +test cmdAH-5.44 {Tcl_FileObjCmd: tail} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform windows + set result [file tail ~] + set env(HOME) $temp + set result +} test +test cmdAH-5.45 {Tcl_FileObjCmd: tail} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform mac + set result [file tail ~] + set env(HOME) $temp + set result +} test +test cmdAH-5.46 {Tcl_FileObjCmd: tail} { + testsetplatform unix + file tail {f.oo\bar/baz.bat} +} baz.bat +test cmdAH-5.47 {Tcl_FileObjCmd: tail} { + testsetplatform windows + file tail c:foo +} foo +test cmdAH-5.48 {Tcl_FileObjCmd: tail} { + testsetplatform windows + file tail c: +} {} +test cmdAH-5.49 {Tcl_FileObjCmd: tail} { + testsetplatform windows + file tail c:/foo +} foo +test cmdAH-5.50 {Tcl_FileObjCmd: tail} { + testsetplatform windows + file tail {c:/foo\bar} +} bar +test cmdAH-5.51 {Tcl_FileObjCmd: tail} { + testsetplatform windows + file tail {foo\bar} +} bar + +# rootname + +test cmdAH-6.1 {Tcl_FileObjCmd: rootname} { + testsetplatform unix + list [catch {file rootname a b} msg] $msg +} {1 {wrong # args: should be "file rootname name"}} +test cmdAH-6.2 {Tcl_FileObjCmd: rootname} { + testsetplatform unix + file rootname {} +} {} +test cmdAH-6.3 {Tcl_FileObjCmd: rootname} { + testsetplatform unix + file ro foo +} foo +test cmdAH-6.4 {Tcl_FileObjCmd: rootname} { + testsetplatform unix + file rootname foo. +} foo +test cmdAH-6.5 {Tcl_FileObjCmd: rootname} { + testsetplatform unix + file rootname .foo +} {} +test cmdAH-6.6 {Tcl_FileObjCmd: rootname} { + testsetplatform unix + file rootname abc.def +} abc +test cmdAH-6.7 {Tcl_FileObjCmd: rootname} { + testsetplatform unix + file rootname abc.def.ghi +} abc.def +test cmdAH-6.8 {Tcl_FileObjCmd: rootname} { + testsetplatform unix + file rootname a/b/c.d +} a/b/c +test cmdAH-6.9 {Tcl_FileObjCmd: rootname} { + testsetplatform unix + file rootname a/b.c/d +} a/b.c/d +test cmdAH-6.10 {Tcl_FileObjCmd: rootname} { + testsetplatform unix + file rootname a/b.c/ +} a/b.c/ +test cmdAH-6.11 {Tcl_FileObjCmd: rootname} { + testsetplatform mac + file ro foo +} foo +test cmdAH-6.12 {Tcl_FileObjCmd: rootname} { + testsetplatform mac + file rootname {} +} {} +test cmdAH-6.13 {Tcl_FileObjCmd: rootname} { + testsetplatform mac + file rootname foo. +} foo +test cmdAH-6.14 {Tcl_FileObjCmd: rootname} { + testsetplatform mac + file rootname .foo +} {} +test cmdAH-6.15 {Tcl_FileObjCmd: rootname} { + testsetplatform mac + file rootname abc.def +} abc +test cmdAH-6.16 {Tcl_FileObjCmd: rootname} { + testsetplatform mac + file rootname abc.def.ghi +} abc.def +test cmdAH-6.17 {Tcl_FileObjCmd: rootname} { + testsetplatform mac + file rootname a:b:c.d +} a:b:c +test cmdAH-6.18 {Tcl_FileObjCmd: rootname} { + testsetplatform mac + file rootname a:b.c:d +} a:b.c:d +test cmdAH-6.19 {Tcl_FileObjCmd: rootname} { + testsetplatform mac + file rootname a/b/c.d +} a/b/c +test cmdAH-6.20 {Tcl_FileObjCmd: rootname} { + testsetplatform mac + file rootname a/b.c/d +} a/b.c/d +test cmdAH-6.21 {Tcl_FileObjCmd: rootname} { + testsetplatform mac + file rootname /a.b +} /a +test cmdAH-6.22 {Tcl_FileObjCmd: rootname} { + testsetplatform mac + file rootname foo.c: +} foo.c: +test cmdAH-6.23 {Tcl_FileObjCmd: rootname} { + testsetplatform windows + file rootname {} +} {} +test cmdAH-6.24 {Tcl_FileObjCmd: rootname} { + testsetplatform windows + file ro foo +} foo +test cmdAH-6.25 {Tcl_FileObjCmd: rootname} { + testsetplatform windows + file rootname foo. +} foo +test cmdAH-6.26 {Tcl_FileObjCmd: rootname} { + testsetplatform windows + file rootname .foo +} {} +test cmdAH-6.27 {Tcl_FileObjCmd: rootname} { + testsetplatform windows + file rootname abc.def +} abc +test cmdAH-6.28 {Tcl_FileObjCmd: rootname} { + testsetplatform windows + file rootname abc.def.ghi +} abc.def +test cmdAH-6.29 {Tcl_FileObjCmd: rootname} { + testsetplatform windows + file rootname a/b/c.d +} a/b/c +test cmdAH-6.30 {Tcl_FileObjCmd: rootname} { + testsetplatform windows + file rootname a/b.c/d +} a/b.c/d +test cmdAH-6.31 {Tcl_FileObjCmd: rootname} { + testsetplatform windows + file rootname a\\b.c\\ +} a\\b.c\\ +test cmdAH-6.32 {Tcl_FileObjCmd: rootname} { + testsetplatform windows + file rootname a\\b\\c.d +} a\\b\\c +test cmdAH-6.33 {Tcl_FileObjCmd: rootname} { + testsetplatform windows + file rootname a\\b.c\\d +} a\\b.c\\d +test cmdAH-6.34 {Tcl_FileObjCmd: rootname} { + testsetplatform windows + file rootname a\\b.c\\ +} a\\b.c\\ +set num 35 +foreach outer { {} a .a a. a.a } { + foreach inner { {} a .a a. a.a } { + set thing [format %s/%s $outer $inner] +; test cmdAH-6.$num {Tcl_FileObjCmd: rootname and extension options} { + testsetplatform unix + format %s%s [file rootname $thing] [file ext $thing] + } $thing + set num [expr $num+1] + } +} + +# extension + +test cmdAH-7.1 {Tcl_FileObjCmd: extension} { + testsetplatform unix + list [catch {file extension a b} msg] $msg +} {1 {wrong # args: should be "file extension name"}} +test cmdAH-7.2 {Tcl_FileObjCmd: extension} { + testsetplatform unix + file extension {} +} {} +test cmdAH-7.3 {Tcl_FileObjCmd: extension} { + testsetplatform unix + file ext foo +} {} +test cmdAH-7.4 {Tcl_FileObjCmd: extension} { + testsetplatform unix + file extension foo. +} . +test cmdAH-7.5 {Tcl_FileObjCmd: extension} { + testsetplatform unix + file extension .foo +} .foo +test cmdAH-7.6 {Tcl_FileObjCmd: extension} { + testsetplatform unix + file extension abc.def +} .def +test cmdAH-7.7 {Tcl_FileObjCmd: extension} { + testsetplatform unix + file extension abc.def.ghi +} .ghi +test cmdAH-7.8 {Tcl_FileObjCmd: extension} { + testsetplatform unix + file extension a/b/c.d +} .d +test cmdAH-7.9 {Tcl_FileObjCmd: extension} { + testsetplatform unix + file extension a/b.c/d +} {} +test cmdAH-7.10 {Tcl_FileObjCmd: extension} { + testsetplatform unix + file extension a/b.c/ +} {} +test cmdAH-7.11 {Tcl_FileObjCmd: extension} { + testsetplatform mac + file ext foo +} {} +test cmdAH-7.12 {Tcl_FileObjCmd: extension} { + testsetplatform mac + file extension {} +} {} +test cmdAH-7.13 {Tcl_FileObjCmd: extension} { + testsetplatform mac + file extension foo. +} . +test cmdAH-7.14 {Tcl_FileObjCmd: extension} { + testsetplatform mac + file extension .foo +} .foo +test cmdAH-7.15 {Tcl_FileObjCmd: extension} { + testsetplatform mac + file extension abc.def +} .def +test cmdAH-7.16 {Tcl_FileObjCmd: extension} { + testsetplatform mac + file extension abc.def.ghi +} .ghi +test cmdAH-7.17 {Tcl_FileObjCmd: extension} { + testsetplatform mac + file extension a:b:c.d +} .d +test cmdAH-7.18 {Tcl_FileObjCmd: extension} { + testsetplatform mac + file extension a:b.c:d +} {} +test cmdAH-7.19 {Tcl_FileObjCmd: extension} { + testsetplatform mac + file extension a/b/c.d +} .d +test cmdAH-7.20 {Tcl_FileObjCmd: extension} { + testsetplatform mac + file extension a/b.c/d +} {} +test cmdAH-7.21 {Tcl_FileObjCmd: extension} { + testsetplatform mac + file extension /a.b +} .b +test cmdAH-7.22 {Tcl_FileObjCmd: extension} { + testsetplatform mac + file extension foo.c: +} {} +test cmdAH-7.23 {Tcl_FileObjCmd: extension} { + testsetplatform windows + file extension {} +} {} +test cmdAH-7.24 {Tcl_FileObjCmd: extension} { + testsetplatform windows + file ext foo +} {} +test cmdAH-7.25 {Tcl_FileObjCmd: extension} { + testsetplatform windows + file extension foo. +} . +test cmdAH-7.26 {Tcl_FileObjCmd: extension} { + testsetplatform windows + file extension .foo +} .foo +test cmdAH-7.27 {Tcl_FileObjCmd: extension} { + testsetplatform windows + file extension abc.def +} .def +test cmdAH-7.28 {Tcl_FileObjCmd: extension} { + testsetplatform windows + file extension abc.def.ghi +} .ghi +test cmdAH-7.29 {Tcl_FileObjCmd: extension} { + testsetplatform windows + file extension a/b/c.d +} .d +test cmdAH-7.30 {Tcl_FileObjCmd: extension} { + testsetplatform windows + file extension a/b.c/d +} {} +test cmdAH-7.31 {Tcl_FileObjCmd: extension} { + testsetplatform windows + file extension a\\b.c\\ +} {} +test cmdAH-7.32 {Tcl_FileObjCmd: extension} { + testsetplatform windows + file extension a\\b\\c.d +} .d +test cmdAH-7.33 {Tcl_FileObjCmd: extension} { + testsetplatform windows + file extension a\\b.c\\d +} {} +test cmdAH-7.34 {Tcl_FileObjCmd: extension} { + testsetplatform windows + file extension a\\b.c\\ +} {} +set num 35 +foreach value {a..b a...b a.c..b ..b} result {..b ...b ..b ..b} { + foreach p {unix mac windows} { +; test cmdAH-7.$num {Tcl_FileObjCmd: extension} " + testsetplatform $p + file extension $value + " $result + incr num + } +} + +# pathtype + +test cmdAH-8.1 {Tcl_FileObjCmd: pathtype} { + testsetplatform unix + list [catch {file pathtype a b} msg] $msg +} {1 {wrong # args: should be "file pathtype name"}} +test cmdAH-8.2 {Tcl_FileObjCmd: pathtype} { + testsetplatform unix + file pathtype /a +} absolute +test cmdAH-8.3 {Tcl_FileObjCmd: pathtype} { + testsetplatform unix + file p a +} relative +test cmdAH-8.4 {Tcl_FileObjCmd: pathtype} { + testsetplatform windows + file pathtype c:a +} volumerelative + +# split + +test cmdAH-9.1 {Tcl_FileObjCmd: split} { + testsetplatform unix + list [catch {file split a b} msg] $msg +} {1 {wrong # args: should be "file split name"}} +test cmdAH-9.2 {Tcl_FileObjCmd: split} { + testsetplatform unix + file split a +} a +test cmdAH-9.3 {Tcl_FileObjCmd: split} { + testsetplatform unix + file split a/b +} {a b} + +# join + +test cmdAH-10.1 {Tcl_FileObjCmd: join} { + testsetplatform unix + file join a +} a +test cmdAH-10.2 {Tcl_FileObjCmd: join} { + testsetplatform unix + file join a b +} a/b +test cmdAH-10.3 {Tcl_FileObjCmd: join} { + testsetplatform unix + file join a b c d +} a/b/c/d + +# error handling of Tcl_TranslateFileName + +test cmdAH-11.1 {Tcl_FileObjCmd} { + testsetplatform unix + list [catch {file atime ~_bad_user} msg] $msg +} {1 {user "_bad_user" doesn't exist}} + +testsetplatform $platform +makeFile abcde gorp.file +makeDirectory dir.file + +# readable + +test cmdAH-12.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} { + file readable gorp.file +} 1 +testchmod 333 gorp.file +test cmdAH-12.3 {Tcl_FileObjCmd: readable} {unixOnly && !root} { + file reada gorp.file +} 0 + +# writable + +test cmdAH-13.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} { + file writable gorp.file +} 0 +testchmod 222 gorp.file +test cmdAH-13.3 {Tcl_FileObjCmd: writable} { + file writable gorp.file +} 1 + +# executable + +file delete -force dir.file gorp.file +file mkdir dir.file +makeFile abcde gorp.file + +test cmdAH-14.1 {Tcl_FileObjCmd: executable} { + list [catch {file executable a b} msg] $msg +} {1 {wrong # args: should be "file executable name"}} +test cmdAH-14.2 {Tcl_FileObjCmd: executable} { + file executable gorp.file +} 0 +test cmdAH-14.3 {Tcl_FileObjCmd: executable} {unix} { + # Only on unix will setting the execute bit on a regular file + # cause that file to be executable. + + testchmod 775 gorp.file + file exe gorp.file +} 1 + +test cmdAH-14.4 {Tcl_FileObjCmd: executable} {mac} { + # On mac, the only executable files are of type APPL. + + set x [file exe gorp.file] + file attrib gorp.file -type APPL + lappend x [file exe gorp.file] +} {0 1} +test cmdAH-14.5 {Tcl_FileObjCmd: executable} {pc} { + # On pc, must be a .exe, .com, etc. + + set x [file exe gorp.file] + makeFile foo gorp.exe + lappend x [file exe gorp.exe] + file delete gorp.exe + set x +} {0 1} +test cmdAH-14.6 {Tcl_FileObjCmd: executable} { + # Directories are always executable. + + file exe dir.file +} 1 + +file delete -force dir.file +file delete gorp.file +file delete link.file +# exists + +test cmdAH-15.1 {Tcl_FileObjCmd: exists} { + list [catch {file exists a b} msg] $msg +} {1 {wrong # args: should be "file exists name"}} +test cmdAH-15.2 {Tcl_FileObjCmd: exists} {file exists gorp.file} 0 +test cmdAH-15.3 {Tcl_FileObjCmd: exists} { + file exists [file join dir.file gorp.file] +} 0 +catch { + makeFile abcde gorp.file + makeDirectory dir.file + makeFile 12345 [file join dir.file gorp.file] +} +test cmdAH-15.4 {Tcl_FileObjCmd: exists} { + file exists gorp.file +} 1 +test cmdAH-15.5 {Tcl_FileObjCmd: exists} { + file exists [file join dir.file gorp.file] +} 1 + +# nativename +test cmdAH-15.6 {Tcl_FileObjCmd: nativename} { + testsetplatform unix + list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] +} {0 a/b {}} +test cmdAH-15.7 {Tcl_FileObjCmd: nativename} { + testsetplatform windows + list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] +} {0 {a\b} {}} +test cmdAH-15.8 {Tcl_FileObjCmd: nativename} { + testsetplatform mac + list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] +} {0 :a:b {}} + +test cmdAH-15.9 {Tcl_FileObjCmd: ~ : exists} { + file exists ~nOsUcHuSeR +} 0 +test cmdAH-15.10 {Tcl_FileObjCmd: ~ : nativename} { + # should probably be 0 in fact... + catch {file nativename ~nOsUcHuSeR} +} 1 + +# The test below has to be done in /tmp rather than the current +# directory in order to guarantee (?) a local file system: some +# NFS file systems won't do the stuff below correctly. + +if {$tcl_platform(platform) == "unix"} { + file delete /tmp/tcl.foo.dir/file + removeDirectory /tmp/tcl.foo.dir + makeDirectory /tmp/tcl.foo.dir + makeFile 12345 /tmp/tcl.foo.dir/file + exec chmod 000 /tmp/tcl.foo.dir + if {$user != "root"} { + test cmdAH-15.9 {Tcl_FileObjCmd: exists} { + file exists /tmp/tcl.foo.dir/file + } 0 + } + exec chmod 775 /tmp/tcl.foo.dir + file delete /tmp/tcl.foo.dir/file + removeDirectory /tmp/tcl.foo.dir +} + +# Stat related commands + +testsetplatform $platform +file delete gorp.file +makeFile "Test string" gorp.file +catch {exec chmod 765 gorp.file} + +# atime + +test cmdAH-16.1 {Tcl_FileObjCmd: atime} { + list [catch {file atime a b} msg] $msg +} {1 {wrong # args: should be "file atime name"}} +test cmdAH-16.2 {Tcl_FileObjCmd: atime} { + catch {unset stat} + file stat gorp.file stat + list [expr {[file mtime gorp.file] == $stat(mtime)}] \ + [expr {[file atime gorp.file] == $stat(atime)}] +} {1 1} +test cmdAH-16.3 {Tcl_FileObjCmd: atime} { + string tolower [list [catch {file atime _bogus_} msg] \ + $msg $errorCode] +} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} + +# isdirectory + +test cmdAH-17.1 {Tcl_FileObjCmd: isdirectory} { + list [catch {file isdirectory a b} msg] $msg +} {1 {wrong # args: should be "file isdirectory name"}} +test cmdAH-17.2 {Tcl_FileObjCmd: isdirectory} { + file isdirectory gorp.file +} 0 +test cmdAH-17.3 {Tcl_FileObjCmd: isdirectory} { + file isd dir.file +} 1 + +# isfile + +test cmdAH-18.1 {Tcl_FileObjCmd: isfile} { + list [catch {file isfile a b} msg] $msg +} {1 {wrong # args: should be "file isfile name"}} +test cmdAH-18.2 {Tcl_FileObjCmd: isfile} {file isfile gorp.file} 1 +test cmdAH-18.3 {Tcl_FileObjCmd: isfile} {file isfile dir.file} 0 + +# lstat and readlink: don't run these tests everywhere, since not all +# sites will have symbolic links + +catch {exec ln -s gorp.file link.file} +test cmdAH-19.1 {Tcl_FileObjCmd: lstat} { + list [catch {file lstat a} msg] $msg +} {1 {wrong # args: should be "file lstat name varName"}} +test cmdAH-19.2 {Tcl_FileObjCmd: lstat} { + 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} { + 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} { + 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} { + 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} { + catch {unset x} + set x 44 + list [catch {file lstat gorp.file x} msg] $msg $errorCode +} {1 {can't set "x(dev)": variable isn't array} NONE} +catch {unset stat} + +# mtime + +test cmdAH-20.1 {Tcl_FileObjCmd: mtime} { + list [catch {file mtime a b} msg] $msg +} {1 {wrong # args: should be "file mtime name"}} +test cmdAH-20.2 {Tcl_FileObjCmd: mtime} { + set old [file mtime gorp.file] + after 2000 + set f [open gorp.file w] + puts $f "More text" + close $f + set new [file mtime gorp.file] + expr {($new > $old) && ($new <= ($old+5))} +} {1} +test cmdAH-20.3 {Tcl_FileObjCmd: mtime} { + catch {unset stat} + file stat gorp.file stat + list [expr {[file mtime gorp.file] == $stat(mtime)}] \ + [expr {[file atime gorp.file] == $stat(atime)}] +} {1 1} +test cmdAH-20.4 {Tcl_FileObjCmd: mtime} { + string tolower [list [catch {file mtime _bogus_} msg] $msg \ + $errorCode] +} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdAH-20.5 {Tcl_FileObjCmd: mtime} { + # Under Unix, use a file in /tmp to avoid clock skew due to NFS. + # On other platforms, just use a file in the local directory. + + if {$tcl_platform(platform) == "unix"} { + set name /tmp/tcl.test + } else { + set name tf + } + + # Borland file times were off by timezone. Make sure that a new file's + # time is correct. 10 seconds variance is allowed used due to slow + # networks or clock skew on a network drive. + + file delete -force $name + close [open $name w] + set a [expr abs([clock seconds]-[file mtime $name])<10] + file delete $name + set a +} {1} + + +# owned + +test cmdAH-21.1 {Tcl_FileObjCmd: owned} { + list [catch {file owned a b} msg] $msg +} {1 {wrong # args: should be "file owned name"}} +test cmdAH-21.2 {Tcl_FileObjCmd: owned} { + file owned gorp.file +} 1 +test cmdAH-21.3 {Tcl_FileObjCmd: owned} {unixOnly && !root} { + file owned / +} 0 + +# readlink + +test cmdAH-22.1 {Tcl_FileObjCmd: readlink} { + list [catch {file readlink a b} msg] $msg +} {1 {wrong # args: should be "file readlink name"}} +test cmdAH-22.2 {Tcl_FileObjCmd: readlink} {unixOnly nonPortable} { + file readlink link.file +} gorp.file +test cmdAH-22.3 {Tcl_FileObjCmd: readlink errors} {unixOnly nonPortable} { + list [catch {file readlink _bogus_} msg] [string tolower $msg] \ + [string tolower $errorCode] +} {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdAH-22.4 {Tcl_FileObjCmd: readlink errors} {macOnly nonPortable} { + list [catch {file readlink _bogus_} msg] [string tolower $msg] \ + [string tolower $errorCode] +} {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdAH-22.5 {Tcl_FileObjCmd: readlink errors} {pcOnly nonPortable} { + list [catch {file readlink _bogus_} msg] [string tolower $msg] \ + [string tolower $errorCode] +} {1 {couldn't readlink "_bogus_": invalid argument} {posix einval {invalid argument}}} + +# size + +test cmdAH-23.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} { + set oldsize [file size gorp.file] + set f [open gorp.file a] + fconfigure $f -translation lf -eofchar {} + puts $f "More text" + close $f + expr {[file size gorp.file] - $oldsize} +} {10} +test cmdAH-23.3 {Tcl_FileObjCmd: size} { + string tolower [list [catch {file size _bogus_} msg] $msg \ + $errorCode] +} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} + +# stat + +testsetplatform $platform +makeFile "Test string" gorp.file +catch {exec chmod 765 gorp.file} + +test cmdAH-24.1 {Tcl_FileObjCmd: stat} { + list [catch {file stat _bogus_} msg] $msg $errorCode +} {1 {wrong # args: should be "file stat name varName"} NONE} +test cmdAH-24.2 {Tcl_FileObjCmd: stat} { + list [catch {file stat _bogus_ a b} msg] $msg $errorCode +} {1 {wrong # args: should be "file stat name varName"} NONE} +test cmdAH-24.3 {Tcl_FileObjCmd: stat} { + catch {unset stat} + file stat gorp.file stat + lsort [array names stat] +} {atime ctime dev gid ino mode mtime nlink size type uid} +test cmdAH-24.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} { + catch {unset stat} + file stat gorp.file stat + expr $stat(mode)&0777 +} {501} +test cmdAH-24.6 {Tcl_FileObjCmd: stat} { + string tolower [list [catch {file stat _bogus_ stat} msg] \ + $msg $errorCode] +} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdAH-24.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} +catch {unset stat} + +# type + +file delete link.file + +test cmdAH-25.1 {Tcl_FileObjCmd: type} { + list [catch {file size a b} msg] $msg +} {1 {wrong # args: should be "file size name"}} +test cmdAH-25.2 {Tcl_FileObjCmd: type} { + file type dir.file +} directory +test cmdAH-25.3 {Tcl_FileObjCmd: type} { + file type gorp.file +} file +test cmdAH-25.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} { + string tolower [list [catch {file type _bogus_} msg] $msg $errorCode] +} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} + +# Error conditions + +test cmdAH-26.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} { + 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} { + 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} { + list [catch {file z x} msg] $msg +} {1 {bad option "z": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +test cmdAH-26.5 {error conditions} { + list [catch {file read x} msg] $msg +} {1 {ambiguous option "read": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +test cmdAH-26.6 {error conditions} { + list [catch {file s x} msg] $msg +} {1 {ambiguous option "s": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +test cmdAH-26.7 {error conditions} { + list [catch {file t x} msg] $msg +} {1 {ambiguous option "t": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +test cmdAH-26.8 {error conditions} { + list [catch {file dirname ~woohgy} msg] $msg +} {1 {user "woohgy" doesn't exist}} + +testsetplatform $platform +catch {unset platform} + +catch {exec chmod 777 dir.file} +file delete -force dir.file +file delete gorp.file +file delete link.file + +concat "" diff --git a/tests/cmdIL.test b/tests/cmdIL.test new file mode 100644 index 0000000..5b56105 --- /dev/null +++ b/tests/cmdIL.test @@ -0,0 +1,253 @@ +# This file contains a collection of tests for the procedures in the +# file tclCmdIL.c. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) cmdIL.test 1.18 97/09/18 11:42:12 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test cmdIL-1.1 {Tcl_LsortObjCmd procedure} { + list [catch {lsort} msg] $msg +} {1 {wrong # args: should be "lsort ?options? list"}} +test cmdIL-1.2 {Tcl_LsortObjCmd procedure} { + list [catch {lsort -foo {1 3 2 5}} msg] $msg +} {1 {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -integer, or -real}} +test cmdIL-1.3 {Tcl_LsortObjCmd procedure, default options} { + lsort {d e c b a \{ d35 d300} +} {a b c d d300 d35 e \{} +test cmdIL-1.4 {Tcl_LsortObjCmd procedure, -ascii option} { + lsort -integer -ascii {d e c b a d35 d300} +} {a b c d d300 d35 e} +test cmdIL-1.5 {Tcl_LsortObjCmd procedure, -command option} { + list [catch {lsort -command {1 3 2 5}} msg] $msg +} {1 {"-command" option must be followed by comparison command}} +test cmdIL-1.6 {Tcl_LsortObjCmd procedure, -command option} { + proc cmp {a b} { + expr {[string match x* $b] - [string match x* $a]} + } + lsort -command cmp {x1 abc x2 def x3 x4} +} {x1 x2 x3 x4 abc def} +test cmdIL-1.7 {Tcl_LsortObjCmd procedure, -decreasing option} { + lsort -decreasing {d e c b a d35 d300} +} {e d35 d300 d c b a} +test cmdIL-1.8 {Tcl_LsortObjCmd procedure, -dictionary option} { + lsort -dictionary {d e c b a d35 d300} +} {a b c d d35 d300 e} +test cmdIL-1.9 {Tcl_LsortObjCmd procedure, -increasing option} { + lsort -decreasing -increasing {d e c b a d35 d300} +} {a b c d d300 d35 e} +test cmdIL-1.10 {Tcl_LsortObjCmd procedure, -index option} { + list [catch {lsort -index {1 3 2 5}} msg] $msg +} {1 {"-index" option must be followed by list index}} +test cmdIL-1.11 {Tcl_LsortObjCmd procedure, -index option} { + list [catch {lsort -index foo {1 3 2 5}} msg] $msg +} {1 {bad index "foo": must be integer or "end"}} +test cmdIL-1.12 {Tcl_LsortObjCmd procedure, -index option} { + lsort -index end -integer {{2 25} {10 20 50 100} {3 16 42} 1} +} {1 {2 25} {3 16 42} {10 20 50 100}} +test cmdIL-1.13 {Tcl_LsortObjCmd procedure, -index option} { + lsort -index 1 -integer {{1 25 100} {3 16 42} {10 20 50}} +} {{3 16 42} {10 20 50} {1 25 100}} +test cmdIL-1.14 {Tcl_LsortObjCmd procedure, -integer option} { + lsort -integer {24 6 300 18} +} {6 18 24 300} +test cmdIL-1.15 {Tcl_LsortObjCmd procedure, -integer option} { + list [catch {lsort -integer {1 3 2.4}} msg] $msg +} {1 {expected integer but got "2.4"}} +test cmdIL-1.16 {Tcl_LsortObjCmd procedure, -real option} { + lsort -real {24.2 6e3 150e-1} +} {150e-1 24.2 6e3} +test cmdIL-1.17 {Tcl_LsortObjCmd procedure, bogus list} { + list [catch {lsort "1 2 3 \{ 4"} msg] $msg +} {1 {unmatched open brace in list}} +test cmdIL-1.18 {Tcl_LsortObjCmd procedure, empty list} { + lsort {} +} {} + +# Can't think of any good tests for the MergeSort and MergeLists +# procedures, except a bunch of random lists to sort. + +test cmdIL-2.1 {MergeSort and MergeLists procedures} { + set result {} + set r 1435753299 + proc rand {} { + global r + set r [expr (16807 * $r) % (0x7fffffff)] + } + for {set i 0} {$i < 150} {incr i} { + set x {} + for {set j 0} {$j < $i} {incr j} { + lappend x [expr [rand] & 0xfff] + } + set y [lsort -integer $x] + set old -1 + foreach el $y { + if {$el < $old} { + append result "list {$x} sorted to {$y}, element $el out of order\n" + break + } + set old $el + } + } + set result +} {} + +test cmdIL-3.1 {SortCompare procedure, skip comparisons after error} { + set x 0 + proc cmp {a b} { + global x + incr x + error "error #$x" + } + list [catch {lsort -integer -command cmp {48 6 28 190 16 2 3 6 1}} msg] \ + $msg $x +} {1 {error #1} 1} +test cmdIL-3.2 {SortCompare procedure, -index option} { + list [catch {lsort -integer -index 2 "\\\{ {30 40 50}"} msg] $msg +} {1 {unmatched open brace in list}} +test cmdIL-3.3 {SortCompare procedure, -index option} { + list [catch {lsort -integer -index 2 {{20 10} {15 30 40}}} msg] $msg +} {1 {element 2 missing from sublist "20 10"}} +test cmdIL-3.4 {SortCompare procedure, -index option} { + list [catch {lsort -integer -index 2 "{a b c} \\\{"} msg] $msg +} {1 {unmatched open brace in list}} +test cmdIL-3.5 {SortCompare procedure, -index option} { + list [catch {lsort -integer -index 2 {{20 10 13} {15}}} msg] $msg +} {1 {element 2 missing from sublist "15"}} +test cmdIL-3.6 {SortCompare procedure, -index option} { + lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}} +} {{3 25 20} {2 5 25} {1 15 30}} +test cmdIL-3.7 {SortCompare procedure, -ascii option} { + lsort -ascii {d e c b a d35 d300 100 20} +} {100 20 a b c d d300 d35 e} +test cmdIL-3.8 {SortCompare procedure, -dictionary option} { + lsort -dictionary {d e c b a d35 d300 100 20} +} {20 100 a b c d d35 d300 e} +test cmdIL-3.9 {SortCompare procedure, -integer option} { + list [catch {lsort -integer {x 3}} msg] $msg +} {1 {expected integer but got "x"}} +test cmdIL-3.10 {SortCompare procedure, -integer option} { + list [catch {lsort -integer {3 q}} msg] $msg +} {1 {expected integer but got "q"}} +test cmdIL-3.11 {SortCompare procedure, -integer option} { + lsort -integer {35 21 0x20 30 023 100 8} +} {8 023 21 30 0x20 35 100} +test cmdIL-3.12 {SortCompare procedure, -real option} { + list [catch {lsort -real {6...4 3}} msg] $msg +} {1 {expected floating-point number but got "6...4"}} +test cmdIL-3.13 {SortCompare procedure, -real option} { + list [catch {lsort -real {3 1x7}} msg] $msg +} {1 {expected floating-point number but got "1x7"}} +test cmdIL-3.14 {SortCompare procedure, -real option} { + lsort -real {24 2.5e01 16.7 85e-1 10.004} +} {85e-1 10.004 16.7 24 2.5e01} +test cmdIL-3.15 {SortCompare procedure, -command option} { + proc cmp {a b} { + error "comparison error" + } + list [catch {lsort -command cmp {48 6}} msg] $msg $errorInfo +} {1 {comparison error} {comparison error + while executing +"error "comparison error"" + (procedure "cmp" line 2) + invoked from within +"cmp 48 6" + (-compare command) + invoked from within +"lsort -command cmp {48 6}"}} +test cmdIL-3.16 {SortCompare procedure, -command option, long command} { + proc cmp {dummy a b} { + string compare $a $b + } + lsort -command {cmp {this argument is very very long in order to make the dstring overflow its statically allocated space}} {{this first element is also long in order to help expand the dstring} {the second element, last but not least, is quite long also, in order to make absolutely sure that space is allocated dynamically for the dstring}} +} {{the second element, last but not least, is quite long also, in order to make absolutely sure that space is allocated dynamically for the dstring} {this first element is also long in order to help expand the dstring}} +test cmdIL-3.17 {SortCompare procedure, -command option, non-integer result} { + proc cmp {a b} { + return foow + } + list [catch {lsort -command cmp {48 6}} msg] $msg +} {1 {-compare command returned non-numeric result}} +test cmdIL-3.18 {SortCompare procedure, -command option} { + proc cmp {a b} { + expr $b - $a + } + lsort -command cmp {48 6 18 22 21 35 36} +} {48 36 35 22 21 18 6} +test cmdIL-3.19 {SortCompare procedure, -decreasing option} { + lsort -decreasing -integer {35 21 0x20 30 023 100 8} +} {100 35 0x20 30 21 023 8} + +test cmdIL-4.1 {DictionaryCompare procedure, numerics, leading zeros} { + lsort -dictionary {a003b a03b} +} {a03b a003b} +test cmdIL-4.2 {DictionaryCompare procedure, numerics, leading zeros} { + lsort -dictionary {a3b a03b} +} {a3b a03b} +test cmdIL-4.3 {DictionaryCompare procedure, numerics, leading zeros} { + lsort -dictionary {a3b A03b} +} {A03b a3b} +test cmdIL-4.4 {DictionaryCompare procedure, numerics, leading zeros} { + lsort -dictionary {a3b a03B} +} {a3b a03B} +test cmdIL-4.5 {DictionaryCompare procedure, numerics, leading zeros} { + lsort -dictionary {00000 000} +} {000 00000} +test cmdIL-4.6 {DictionaryCompare procedure, numerics, different lengths} { + lsort -dictionary {a321b a03210b} +} {a321b a03210b} +test cmdIL-4.7 {DictionaryCompare procedure, numerics, different lengths} { + lsort -dictionary {a03210b a321b} +} {a321b a03210b} +test cmdIL-4.8 {DictionaryCompare procedure, numerics} { + lsort -dictionary {48 6a 18b 22a 21aa 35 36} +} {6a 18b 21aa 22a 35 36 48} +test cmdIL-4.9 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a123x a123b} +} {a123b a123x} +test cmdIL-4.10 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a123b a123x} +} {a123b a123x} +test cmdIL-4.11 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a1b aab} +} {a1b aab} +test cmdIL-4.12 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a1b a!b} +} {a!b a1b} +test cmdIL-4.13 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a1b2c a1b1c} +} {a1b1c a1b2c} +test cmdIL-4.14 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a1b2c a1b3c} +} {a1b2c a1b3c} +test cmdIL-4.15 {DictionaryCompare procedure, long numbers} { + lsort -dictionary {a7654884321988762b a7654884321988761b} +} {a7654884321988761b a7654884321988762b} +test cmdIL-4.16 {DictionaryCompare procedure, long numbers} { + lsort -dictionary {a8765488432198876b a7654884321988761b} +} {a7654884321988761b a8765488432198876b} +test cmdIL-4.17 {DictionaryCompare procedure, case} { + lsort -dictionary {aBCd abcc} +} {abcc aBCd} +test cmdIL-4.18 {DictionaryCompare procedure, case} { + lsort -dictionary {aBCd abce} +} {aBCd abce} +test cmdIL-4.19 {DictionaryCompare procedure, case} { + lsort -dictionary {abcd ABcc} +} {ABcc abcd} +test cmdIL-4.20 {DictionaryCompare procedure, case} { + lsort -dictionary {abcd ABce} +} {abcd ABce} +test cmdIL-4.21 {DictionaryCompare procedure, case} { + lsort -dictionary {abCD ABcd} +} {ABcd abCD} +test cmdIL-4.22 {DictionaryCompare procedure, case} { + lsort -dictionary {ABcd aBCd} +} {ABcd aBCd} +test cmdIL-4.23 {DictionaryCompare procedure, case} { + lsort -dictionary {ABcd AbCd} +} {ABcd AbCd} diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test new file mode 100644 index 0000000..14267ac --- /dev/null +++ b/tests/cmdInfo.test @@ -0,0 +1,98 @@ +# Commands covered: none +# +# This file contains a collection of tests for Tcl_GetCommandInfo, +# Tcl_SetCommandInfo, Tcl_CreateCommand, Tcl_DeleteCommand, and +# Tcl_NameOfCommand. Sourcing this file into Tcl runs the tests +# and generates output for errors. No output means no errors were +# found. +# +# Copyright (c) 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: @(#) cmdInfo.test 1.10 97/06/20 14:51:12 + +if {[info commands testcmdinfo] == {}} { + puts "This application hasn't been compiled with the \"testcmdinfo\"" + puts "command, so I can't test Tcl_GetCommandInfo etc." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test cmdinfo-1.1 {command procedure and clientData} { + testcmdinfo create x1 + testcmdinfo get x1 +} {CmdProc1 original CmdDelProc1 original :: stringProc} +test cmdinfo-1.2 {command procedure and clientData} { + testcmdinfo create x1 + x1 +} {CmdProc1 original} +test cmdinfo-1.3 {command procedure and clientData} { + testcmdinfo create x1 + testcmdinfo modify x1 + testcmdinfo get x1 +} {CmdProc2 new_command_data CmdDelProc2 new_delete_data :: stringProc} +test cmdinfo-1.4 {command procedure and clientData} { + testcmdinfo create x1 + testcmdinfo modify x1 + x1 +} {CmdProc2 new_command_data} + +test cmdinfo-2.1 {command deletion callbacks} { + testcmdinfo create x1 + testcmdinfo delete x1 +} {CmdDelProc1 original} +test cmdinfo-2.2 {command deletion callbacks} { + testcmdinfo create x1 + testcmdinfo modify x1 + testcmdinfo delete x1 +} {CmdDelProc2 new_delete_data} + +test cmdinfo-3.1 {Tcl_Get/SetCommandInfo return values} { + testcmdinfo get non_existent +} {??} +test cmdinfo-3.2 {Tcl_Get/SetCommandInfo return values} { + testcmdinfo create x1 + testcmdinfo modify x1 +} 1 +test cmdinfo-3.3 {Tcl_Get/SetCommandInfo return values} { + testcmdinfo modify non_existent +} 0 + +test cmdinfo-4.1 {Tcl_GetCommandName/Tcl_GetCommandFullName procedures} { + set x [testcmdtoken create x1] + rename x1 newName + set y [testcmdtoken name $x] + rename newName x1 + eval lappend y [testcmdtoken name $x] +} {newName ::newName x1 ::x1} + +catch {rename newTestCmd {}} +catch {rename newTestCmd2 {}} + +test cmdinfo-5.1 {Names for commands created when inside namespaces} { + # create namespace cmdInfoNs1 + namespace eval cmdInfoNs1 {} ;# creates namespace cmdInfoNs1 + # create namespace cmdInfoNs1::cmdInfoNs2 and execute a script in it + set x [namespace eval cmdInfoNs1::cmdInfoNs2 { + # the following creates a cmd in the global namespace + testcmdtoken create testCmd + }] + set y [testcmdtoken name $x] + rename ::testCmd newTestCmd + eval lappend y [testcmdtoken name $x] +} {testCmd ::testCmd newTestCmd ::newTestCmd} + +test cmdinfo-6.1 {Names for commands created when outside namespaces} { + set x [testcmdtoken create cmdInfoNs1::cmdInfoNs2::testCmd] + set y [testcmdtoken name $x] + rename cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 + eval lappend y [testcmdtoken name $x] +} {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2} + +catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1} +catch {rename x1 ""} +concat {} diff --git a/tests/compile.test b/tests/compile.test new file mode 100644 index 0000000..9e30fb3 --- /dev/null +++ b/tests/compile.test @@ -0,0 +1,128 @@ +# This file contains tests for the file tclCompile.c. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) compile.test 1.7 97/08/12 13:34:13 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# The following tests are very incomplete, although the rest of the +# test suite covers this file fairly well. + +catch {rename p ""} +catch {namespace delete test_ns_compile} +catch {unset x} +catch {unset y} +catch {unset a} + +test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} { + catch {namespace delete test_ns_compile} + catch {unset x} + set x 123 + namespace eval test_ns_compile { + proc set {args} { + global x + lappend x test_ns_compile::set + } + proc p {} { + set 0 + } + } + list [test_ns_compile::p] [set x] +} {{123 test_ns_compile::set} {123 test_ns_compile::set}} +test compile-1.2 {TclCompileString, error result is reset if TclGetLong determines word isn't an integer} { + proc p {x} {info commands 3m} + list [catch {p} msg] $msg +} {1 {no value given for parameter "x" to "p"}} + +test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} { + catch {unset x} + set x 123 + list $::x [expr {[lsearch -exact [info globals] x] != 0}] +} {123 1} +test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} { + catch {unset y} + proc p {} { + set ::y 789 + return $::y + } + list [p] $::y [expr {[lsearch -exact [info globals] y] != 0}] +} {789 789 1} +test compile-2.3 {TclCompileDollarVar: global array name with ::s} { + catch {unset a} + set ::a(1) 2 + list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {[lsearch -exact [info globals] a] != 0}] +} {2 3 3 1} +test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} { + catch {unset a} + proc p {} { + set ::a(1) 1 + return $::a($::a(1)) + } + list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] +} {1 1 1} + +test compile-3.1 {TclCompileSetCmd: global scalar names with ::s} { + catch {unset x} + catch {unset y} + set x 123 + proc p {} { + set ::y 789 + return $::y + } + list $::x [expr {[lsearch -exact [info globals] x] != 0}] \ + [p] $::y [expr {[lsearch -exact [info globals] y] != 0}] +} {123 1 789 789 1} +test compile-3.2 {TclCompileSetCmd: global array names with ::s} { + catch {unset a} + set ::a(1) 2 + proc p {} { + set ::a(1) 1 + return $::a($::a(1)) + } + list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] +} {2 1 3 3 1} +test compile-3.3 {TclCompileSetCmd: namespace var names with ::s} { + catch {namespace delete test_ns_compile} + catch {unset x} + namespace eval test_ns_compile { + variable v hello + variable arr + set ::x $::test_ns_compile::v + set ::test_ns_compile::arr(1) 123 + } + list $::x $::test_ns_compile::arr(1) +} {hello 123} + +test compile-4.1 {CollectArgInfo: binary data} { + list [catch "string length \000foo" msg] $msg +} {0 4} +test compile-4.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} { + set x ] +} {]} + +test compile-5.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} { + proc p {} { + set x {} + eval $x + append x { } + eval $x + } + p +} {} + +catch {rename p ""} +catch {namespace delete test_ns_compile} +catch {unset x} +catch {unset y} +catch {unset a} diff --git a/tests/concat.test b/tests/concat.test new file mode 100644 index 0000000..d0222e9 --- /dev/null +++ b/tests/concat.test @@ -0,0 +1,46 @@ +# Commands covered: concat +# +# 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: @(#) concat.test 1.10 96/12/20 18:53:31 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test concat-1.1 {simple concatenation} { + concat a b c d e f g +} {a b c d e f g} +test concat-1.2 {merging lists together} { + concat a {b c d} {e f g h} +} {a b c d e f g h} +test concat-1.3 {merge lists, retain sub-lists} { + concat a {b {c d}} {{e f}} g h +} {a b {c d} {e f} g h} +test concat-1.4 {special characters} { + concat a\{ {b \{c d} \{d +} "a{ b \\{c d {d" + +test concat-2.1 {error: one empty argument} { + concat {} +} {} + +test concat-3.1 {error: no arguments} { + list [catch concat msg] $msg +} {0 {}} + +test concat-4.1 {pruning off extra white space} { + concat {} {a b c} +} {a b c} +test concat-4.2 {pruning off extra white space} { + concat x y " a b c \n\t " " " " def " +} {x y a b c def} +test concat-4.3 {pruning off extra white space sets length correctly} { + llength [concat { {{a}} }] +} 1 diff --git a/tests/dcall.test b/tests/dcall.test new file mode 100644 index 0000000..c7ad1c6 --- /dev/null +++ b/tests/dcall.test @@ -0,0 +1,40 @@ +# Commands covered: none +# +# This file contains a collection of tests for Tcl_CallWhenDeleted. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 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: @(#) dcall.test 1.6 96/02/16 08:55:44 + +if {[info commands testdcall] == {}} { + puts "This application hasn't been compiled with the \"testdcall\"" + puts "command, so I can't test Tcl_CallWhenDeleted." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test dcall-1.1 {deletion callbacks} { + lsort -increasing [testdcall 1 2 3] +} {1 2 3} +test dcall-1.2 {deletion callbacks} { + testdcall +} {} +test dcall-1.3 {deletion callbacks} { + lsort -increasing [testdcall 20 21 22 -22] +} {20 21} +test dcall-1.4 {deletion callbacks} { + lsort -increasing [testdcall 20 21 22 -20] +} {21 22} +test dcall-1.5 {deletion callbacks} { + lsort -increasing [testdcall 20 21 22 -21] +} {20 22} +test dcall-1.6 {deletion callbacks} { + lsort -increasing [testdcall 20 21 22 -21 -22 -20] +} {} diff --git a/tests/defs b/tests/defs new file mode 100644 index 0000000..61f90ec --- /dev/null +++ b/tests/defs @@ -0,0 +1,447 @@ +# This file contains support code for the Tcl test suite. It is +# normally sourced by the individual files in the test suite before +# they run their tests. This improved approach to testing was designed +# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. +# +# Copyright (c) 1990-1994 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: @(#) defs 1.60 97/08/13 18:10:19 + +if ![info exists VERBOSE] { + set VERBOSE 0 +} +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. + +if {[info commands memory] == ""} { + proc memory args {} +} + +# Check configuration information that will determine which tests +# to run. To do this, create an array testConfig. Each element +# has a 0 or 1 value, and the following elements are defined: +# unixOnly - 1 means this is a UNIX platform, so it's OK +# to run tests that only work under UNIX. +# macOnly - 1 means this is a Mac platform, so it's OK +# to run tests that only work on Macs. +# pcOnly - 1 means this is a PC platform, so it's OK to +# run tests that only work on PCs. +# unixOrPc - 1 means this is a UNIX or PC platform. +# macOrPc - 1 means this is a Mac or PC platform. +# macOrUnix - 1 means this is a Mac or UNIX platform. +# nonPortable - 1 means this the tests are being running in +# the master Tcl/Tk development environment; +# Some tests are inherently non-portable because +# they depend on things like word length, file system +# configuration, window manager, etc. These tests +# are only run in the main Tcl development directory +# where the configuration is well known. The presence +# of the file "doAllTests" in this directory indicates +# that it is safe to run non-portable tests. +# knownBug - The test is known to fail and the bug is not yet +# fixed. The test will be run only if the file +# "doBuggyTests" exists (intended for Tcl dev. group +# internal use only). +# tempNotPc - The inverse of pcOnly. This flag is used to +# temporarily disable a test. +# tempNotMac - The inverse of macOnly. This flag is used to +# temporarily disable a test. +# nonBlockFiles - 1 means this platform supports setting files into +# nonblocking mode. +# asyncPipeClose- 1 means this platform supports async flush and +# async close on a pipe. +# unixExecs - 1 means this machine has commands such as 'cat', +# 'echo' etc available. +# notIfCompiled - 1 means this that it is safe to run tests that +# might fail if the bytecode compiler is used. This +# element is set 1 if the file "doAllTests" exists in +# this directory. Normally, this element is 0 so that +# tests that fail with the bytecode compiler are +# skipped. As of 11/2/96 these are the history tests +# since they depend on accurate source location +# information. + +catch {unset testConfig} +if {$tcl_platform(platform) == "unix"} { + set testConfig(unixOnly) 1 + set testConfig(tempNotPc) 1 + set testConfig(tempNotMac) 1 +} else { + set testConfig(unixOnly) 0 +} +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 +} +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(nt) [expr {$tcl_platform(os) == "Windows NT"}] +set testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}] +set testConfig(win32s) [expr {$tcl_platform(os) == "Win32s"}] + +# The following config switches are used to mark tests that crash on +# certain platforms, so that they can be reactivated again when the +# underlying problem is fixed. + +set testConfig(pcCrash) $testConfig(macOrUnix) +set testConfig(macCrash) $testConfig(unixOrPc) +set testConfig(unixCrash) $testConfig(macOrPc) + +if {[catch {set f [open defs r]}]} { + set testConfig(nonBlockFiles) 1 +} else { + if {[expr [catch {fconfigure $f -blocking off}]] == 0} { + set testConfig(nonBlockFiles) 1 + } else { + set testConfig(nonBlockFiles) 0 + } + close $f +} + +trace variable testConfig r safeFetch + +proc safeFetch {n1 n2 op} { + global testConfig + + if {($n2 != {}) && ([info exists testConfig($n2)] == 0)} { + set testConfig($n2) 0 + } +} + +# Test for SCO Unix - cannot run async flushing tests because a potential +# problem with select is apparently interfering. (Mark Diekhans). + +if {$tcl_platform(platform) == "unix"} { + if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { + set testConfig(asyncPipeClose) 0 + } else { + set testConfig(asyncPipeClose) 1 + } +} else { + set testConfig(asyncPipeClose) 1 +} + +# Test to see if execed commands such as cat, echo, rm and so forth are +# present on this machine. + +set testConfig(unixExecs) 1 +if {$tcl_platform(platform) == "macintosh"} { + set testConfig(unixExecs) 0 +} +if {($testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} { + if {[catch {exec cat defs}] == 1} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && ([catch {exec echo hello}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec sh -c echo hello}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && ([catch {exec wc defs}] == 1)} { + set testConfig(unixExecs) 0 + } + if {$testConfig(unixExecs) == 1} { + exec echo hello > removeMe + if {[catch {exec rm removeMe}] == 1} { + set testConfig(unixExecs) 0 + } + } + if {($testConfig(unixExecs) == 1) && ([catch {exec sleep 1}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec fgrep unixExecs defs}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && ([catch {exec ps}] == 1)} { + set testConfig(unixExecs) 0 + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec echo abc > removeMe}] == 0) && \ + ([catch {exec chmod 644 removeMe}] == 1) && \ + ([catch {exec rm removeMe}] == 0)} { + set testConfig(unixExecs) 0 + } else { + catch {exec rm -f removeMe} + } + if {($testConfig(unixExecs) == 1) && \ + ([catch {exec mkdir removeMe}] == 1)} { + set testConfig(unixExecs) 0 + } else { + catch {exec rm -r removeMe} + } + if {$testConfig(unixExecs) == 0} { + puts stdout "Warning: Unix-style executables are not available, so" + puts stdout "some tests will be skipped." + } +} + +proc print_verbose {name description constraints script code answer} { + puts stdout "\n" + if {[string length $constraints]} { + puts stdout "==== $name $description\t--- ($constraints) ---" + } else { + puts stdout "==== $name $description" + } + puts stdout "==== Contents of test case:" + puts stdout "$script" + if {$code != 0} { + if {$code == 1} { + puts stdout "==== Test generated error:" + puts stdout $answer + } elseif {$code == 2} { + puts stdout "==== Test generated return exception; result was:" + puts stdout $answer + } elseif {$code == 3} { + puts stdout "==== Test generated break exception" + } elseif {$code == 4} { + puts stdout "==== Test generated continue exception" + } else { + puts stdout "==== Test generated exception $code; message was:" + puts stdout $answer + } + } else { + puts stdout "==== Result was:" + puts stdout "$answer" + } +} + +# test -- +# This procedure runs a test and prints an error message if the +# test fails. If VERBOSE has been set, it also prints a message +# even if the test succeeds. The test will be skipped if it +# doesn't match the TESTS variable, or if one of the elements +# of "constraints" turns out not to be true. +# +# Arguments: +# name - Name of test, in the form foo-1.2. +# description - Short textual description of the test, to +# help humans understand what it does. +# constraints - A list of one or more keywords, each of +# which must be the name of an element in +# the array "testConfig". If any of these +# elements is zero, the test is skipped. +# This argument may be omitted. +# script - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. +# answer - Expected result from script. + +proc test {name description script answer args} { + global VERBOSE TESTS testConfig + if {[string compare $TESTS ""] != 0} then { + set ok 0 + foreach test $TESTS { + if [string match $test $name] then { + set ok 1 + break + } + } + if !$ok then return + } + set i [llength $args] + if {$i == 0} { + set constraints {} + } elseif {$i == 1} { + # "constraints" argument exists; shuffle arguments down, then + # make sure that the constraints are satisfied. + + set constraints $script + set script $answer + set answer [lindex $args 0] + set doTest 0 + if {[string match {*[$\[]*} $constraints] != 0} { + # full expression, e.g. {$foo > [info tclversion]} + + catch {set doTest [uplevel #0 expr [list $constraints]]} msg + } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { + # something like {a || b} should be turned into + # $testConfig(a) || $testConfig(b). + + regsub -all {[.a-zA-Z0-9]+} $constraints {$testConfig(&)} c + catch {set doTest [eval expr $c]} + } else { + # just simple constraints such as {unixOnly fonts}. + + set doTest 1 + foreach constraint $constraints { + if {![info exists testConfig($constraint)] + || !$testConfig($constraint)} { + set doTest 0 + break + } + } + } + if {$doTest == 0} { + if $VERBOSE then { + puts stdout "++++ $name SKIPPED: $constraints" + } + return + } + } else { + error "wrong # args: must be \"test name description ?constraints? script answer\"" + } + memory tag $name + set code [catch {uplevel $script} result] + if {$code != 0} { + print_verbose $name $description $constraints $script \ + $code $result + } elseif {[string compare $result $answer] == 0} then { + if $VERBOSE then { + if {$VERBOSE > 0} { + print_verbose $name $description $constraints $script \ + $code $result + } + if {$VERBOSE != -2} { + puts stdout "++++ $name PASSED" + } + } + } else { + print_verbose $name $description $constraints $script \ + $code $result + puts stdout "---- Result should have been:" + puts stdout "$answer" + puts stdout "---- $name FAILED" + } +} + +proc dotests {file args} { + global TESTS + set savedTests $TESTS + set TESTS $args + source $file + set TESTS $savedTests +} + +proc normalizeMsg {msg} { + regsub "\n$" [string tolower $msg] "" msg + regsub -all "\n\n" $msg "\n" msg + regsub -all "\n\}" $msg "\}" msg + return $msg +} + +proc makeFile {contents name} { + set fd [open $name w] + fconfigure $fd -translation lf + if {[string index $contents [expr [string length $contents] - 1]] == "\n"} { + puts -nonewline $fd $contents + } else { + puts $fd $contents + } + close $fd +} + +proc removeFile {name} { + file delete $name +} + +proc makeDirectory {name} { + file mkdir $name +} + +proc removeDirectory {name} { + file delete -force $name +} + +proc viewFile {name} { + global tcl_platform testConfig + if {($tcl_platform(platform) == "macintosh") || \ + ($testConfig(unixExecs) == 0)} { + set f [open $name] + set data [read -nonewline $f] + close $f + return $data + } else { + exec cat $name + } +} + +# Locate tcltest executable + +set tcltest [info nameofexecutable] + +if {$tcltest == "{}"} { + set tcltest {} + puts "Unable to find tcltest executable, multiple process tests will fail." +} + +if {$tcl_platform(os) != "Win32s"} { + # Don't even try running another copy of tcltest under win32s, or you + # get an error dialog about multiple instances. + + catch { + file delete -force tmp + set f [open tmp w] + puts $f { + exit + } + close $f + set f [open "|[list $tcltest tmp]" r] + close $f + set testConfig(stdio) 1 + } +} + +if {($tcl_platform(platform) == "windows") && ($testConfig(stdio) == 0)} { + puts "(will skip tests that redirect stdio of exec'd 32-bit applications)" +} + +catch {socket} msg +set testConfig(socket) [expr {$msg != "sockets are not available on this system"}] + +if {$testConfig(socket) == 0} { + puts "(will skip tests that use sockets)" +} + + diff --git a/tests/dstring.test b/tests/dstring.test new file mode 100644 index 0000000..93a84d4 --- /dev/null +++ b/tests/dstring.test @@ -0,0 +1,248 @@ +# Commands covered: none +# +# This file contains a collection of tests for Tcl's dynamic string +# library procedures. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 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: @(#) dstring.test 1.10 96/10/08 17:40:02 + +if {[info commands testdstring] == {}} { + puts "This application hasn't been compiled with the \"testdstring\"" + puts "command, so I can't test Tcl_DStringAppend et al." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test dstring-1.1 {appending and retrieving} { + testdstring free + testdstring append "abc" -1 + list [testdstring get] [testdstring length] +} {abc 3} +test dstring-1.2 {appending and retrieving} { + testdstring free + testdstring append "abc" -1 + testdstring append " xyzzy" 3 + testdstring append " 12345" -1 + list [testdstring get] [testdstring length] +} {{abc xy 12345} 12} +test dstring-1.3 {appending and retrieving} { + testdstring free + foreach l {a b c d e f g h i j k l m n o p} { + testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 + } + list [testdstring get] [testdstring length] +} {{aaaaaaaaaaaaaaaaaaaaa +bbbbbbbbbbbbbbbbbbbbb +ccccccccccccccccccccc +ddddddddddddddddddddd +eeeeeeeeeeeeeeeeeeeee +fffffffffffffffffffff +ggggggggggggggggggggg +hhhhhhhhhhhhhhhhhhhhh +iiiiiiiiiiiiiiiiiiiii +jjjjjjjjjjjjjjjjjjjjj +kkkkkkkkkkkkkkkkkkkkk +lllllllllllllllllllll +mmmmmmmmmmmmmmmmmmmmm +nnnnnnnnnnnnnnnnnnnnn +ooooooooooooooooooooo +ppppppppppppppppppppp +} 352} + +test dstring-2.1 {appending list elements} { + testdstring free + testdstring element "abc" + testdstring element "d e f" + list [testdstring get] [testdstring length] +} {{abc {d e f}} 11} +test dstring-2.2 {appending list elements} { + testdstring free + testdstring element "x" + testdstring element "\{" + testdstring element "ab\}" + testdstring get +} {x \{ ab\}} +test dstring-2.3 {appending list elements} { + testdstring free + foreach l {a b c d e f g h i j k l m n o p} { + testdstring element $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l + } + testdstring get +} {aaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccc ddddddddddddddddddddd eeeeeeeeeeeeeeeeeeeee fffffffffffffffffffff ggggggggggggggggggggg hhhhhhhhhhhhhhhhhhhhh iiiiiiiiiiiiiiiiiiiii jjjjjjjjjjjjjjjjjjjjj kkkkkkkkkkkkkkkkkkkkk lllllllllllllllllllll mmmmmmmmmmmmmmmmmmmmm nnnnnnnnnnnnnnnnnnnnn ooooooooooooooooooooo ppppppppppppppppppppp} +test dstring-2.4 {appending list elements} { + testdstring free + testdstring append "a\{" -1 + testdstring element abc + testdstring append " \{" -1 + testdstring element xyzzy + testdstring get +} "a{ abc {xyzzy" +test dstring-2.5 {appending list elements} { + testdstring free + testdstring append " \{" -1 + testdstring element abc + testdstring get +} " {abc" +test dstring-2.6 {appending list elements} { + testdstring free + testdstring append " " -1 + testdstring element abc + testdstring get +} { abc} +test dstring-2.7 {appending list elements} { + testdstring free + testdstring append "\\ " -1 + testdstring element abc + testdstring get +} "\\ abc" +test dstring-2.8 {appending list elements} { + testdstring free + testdstring append "x " -1 + testdstring element abc + testdstring get +} {x abc} + +test dstring-3.1 {nested sublists} { + testdstring free + testdstring start + testdstring element foo + testdstring element bar + testdstring end + testdstring element another + testdstring get +} {{foo bar} another} +test dstring-3.2 {nested sublists} { + testdstring free + testdstring start + testdstring start + testdstring element abc + testdstring element def + testdstring end + testdstring end + testdstring element ghi + testdstring get +} {{{abc def}} ghi} +test dstring-3.3 {nested sublists} { + testdstring free + testdstring start + testdstring start + testdstring start + testdstring element foo + testdstring element foo2 + testdstring end + testdstring end + testdstring element foo3 + testdstring end + testdstring element foo4 + testdstring get +} {{{{foo foo2}} foo3} foo4} +test dstring-3.4 {nested sublists} { + testdstring free + testdstring element before + testdstring start + testdstring element during + testdstring element more + testdstring end + testdstring element last + testdstring get +} {before {during more} last} +test dstring-3.5 {nested sublists} { + testdstring free + testdstring element "\{" + testdstring start + testdstring element first + testdstring element second + testdstring end + testdstring get +} {\{ {first second}} + +test dstring-4.1 {truncation} { + testdstring free + testdstring append "abcdefg" -1 + testdstring trunc 3 + list [testdstring get] [testdstring length] +} {abc 3} +test dstring-4.2 {truncation} { + testdstring free + testdstring append "xyzzy" -1 + testdstring trunc 0 + list [testdstring get] [testdstring length] +} {{} 0} + +test dstring-5.1 {copying to result} { + testdstring free + testdstring append xyz -1 + testdstring result +} xyz +test dstring-5.2 {copying to result} { + testdstring free + catch {unset a} + foreach l {a b c d e f g h i j k l m n o p} { + testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 + } + set a [testdstring result] + testdstring append abc -1 + list $a [testdstring get] +} {{aaaaaaaaaaaaaaaaaaaaa +bbbbbbbbbbbbbbbbbbbbb +ccccccccccccccccccccc +ddddddddddddddddddddd +eeeeeeeeeeeeeeeeeeeee +fffffffffffffffffffff +ggggggggggggggggggggg +hhhhhhhhhhhhhhhhhhhhh +iiiiiiiiiiiiiiiiiiiii +jjjjjjjjjjjjjjjjjjjjj +kkkkkkkkkkkkkkkkkkkkk +lllllllllllllllllllll +mmmmmmmmmmmmmmmmmmmmm +nnnnnnnnnnnnnnnnnnnnn +ooooooooooooooooooooo +ppppppppppppppppppppp +} abc} + +test dstring-6.1 {Tcl_DStringGetResult} { + testdstring free + list [testdstring gresult staticsmall] [testdstring get] +} {{} short} +test dstring-6.2 {Tcl_DStringGetResult} { + testdstring free + foreach l {a b c d e f g h i j k l m n o p} { + testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 + } + list [testdstring gresult staticsmall] [testdstring get] +} {{} short} +test dstring-6.3 {Tcl_DStringGetResult} { + set result {} + lappend result [testdstring gresult staticlarge] + testdstring append x 1 + lappend result [testdstring get] +} {{} {first0 first1 first2 first3 first4 first5 first6 first7 first8 first9 +second0 second1 second2 second3 second4 second5 second6 second7 second8 second9 +third0 third1 third2 third3 third4 third5 third6 third7 third8 third9 +fourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9 +fifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9 +sixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9 +seventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9 +x}} +test dstring-6.4 {Tcl_DStringGetResult} { + set result {} + lappend result [testdstring gresult free] + testdstring append y 1 + lappend result [testdstring get] +} {{} {This is a malloc-ed stringy}} +test dstring-6.5 {Tcl_DStringGetResult} { + set result {} + lappend result [testdstring gresult special] + testdstring append z 1 + lappend result [testdstring get] +} {{} {This is a specially-allocated stringz}} + +testdstring free diff --git a/tests/env.test b/tests/env.test new file mode 100644 index 0000000..1bfc8dd --- /dev/null +++ b/tests/env.test @@ -0,0 +1,152 @@ +# Commands covered: none (tests environment variable implementation) +# +# 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: @(#) env.test 1.14 97/10/31 17:00:03 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# +# These tests will run on any platform (and indeed crashed +# on the Mac). So put them before you test for the existance +# of exec. +# +test env-1.1 {propagation of env values to child interpreters} { + catch {interp delete child} + catch {unset env(test)} + interp create child + set env(test) garbage + set return [child eval {set env(test)}] + interp delete child + unset env(test) + set return +} {garbage} +# +# This one crashed on Solaris under Tcl8.0, so we only +# want to make sure it runs. +# +test env-1.2 {lappend to env value} { + catch {unset env(test)} + set env(test) aaaaaaaaaaaaaaaa + append env(test) bbbbbbbbbbbbbb + unset env(test) +} {} +if {[info commands exec] == ""} { + puts "exec not implemented for this machine" + return +} + +if {$tcl_platform(os) == "Win32s"} { + puts "Cannot run multiple copies of tcl at the same time under Win32s" + return +} + +set f [open printenv w] +puts $f { + proc lrem {listname name} { + upvar $listname list + set i [lsearch $list $name] + if {$i >= 0} { + set list [lreplace $list $i $i] + } + return $list + } + + set names [lsort [array names env]] + if {$tcl_platform(platform) == "windows"} { + lrem names HOME + lrem names COMSPEC + lrem names ComSpec + lrem names "" + } + foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH} { + lrem names $name + } + foreach p $names { + puts "$p=$env($p)" + } +} +close $f + +proc getenv {} { + global printenv tcltest + catch {exec $tcltest printenv} out + if {$out == "child process exited abnormally"} { + set out {} + } + return $out +} + +# Save the current environment variables at the start of the test. + +foreach name [array names env] { + set env2($name) $env($name) + unset env($name) +} + +# Added the following lines so that child tcltest can actually find its +# library if the initial tcltest is run from a non-standard place. +# ('saved' env vars) +foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH} { + if {[info exists env2($name)]} { + set env($name) $env2($name); + } +} + +test env-2.1 {adding environment variables} { + getenv +} {} + +set env(NAME1) "test string" +test env-2.2 {adding environment variables} { + getenv +} {NAME1=test string} + +set env(NAME2) "more" +test env-2.3 {adding environment variables} { + getenv +} {NAME1=test string +NAME2=more} + +set env(XYZZY) "garbage" +test env-2.4 {adding environment variables} { + getenv +} {NAME1=test string +NAME2=more +XYZZY=garbage} + +set env(NAME2) "new value" +test env-3.1 {changing environment variables} { + getenv +} {NAME1=test string +NAME2=new value +XYZZY=garbage} + +unset env(NAME2) +test env-4.1 {unsetting environment variables} { + getenv +} {NAME1=test string +XYZZY=garbage} +unset env(NAME1) +test env-4.2 {unsetting environment variables} { + getenv +} {XYZZY=garbage} + +# Restore the environment variables at the end of the test. + +foreach name [array names env] { + unset env($name) +} +foreach name [array names env2] { + set env($name) $env2($name) +} + +file delete printenv diff --git a/tests/error.test b/tests/error.test new file mode 100644 index 0000000..1421e9b --- /dev/null +++ b/tests/error.test @@ -0,0 +1,175 @@ +# Commands covered: error, catch +# +# 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: @(#) error.test 1.22 97/08/12 17:02:43 + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc foo {} { + global errorInfo + set a [catch {format [error glorp2]} b] + error {Human-generated} +} + +proc foo2 {} { + global errorInfo + set a [catch {format [error glorp2]} b] + error {Human-generated} $errorInfo +} + +# Catch errors occurring in commands and errors from "error" command + +test error-1.1 {simple errors from commands} { + catch {format [string compare]} b +} 1 + +test error-1.2 {simple errors from commands} { + catch {format [string compare]} b + set b +} {wrong # args: should be "string compare string1 string2"} + +test error-1.3 {simple errors from commands} { + catch {format [string compare]} b + set errorInfo +} {wrong # args: should be "string compare string1 string2" + while executing +"string compare"} + +test error-1.4 {simple errors from commands} { + catch {error glorp} b +} 1 + +test error-1.5 {simple errors from commands} { + catch {error glorp} b + set b +} glorp + +test error-1.6 {simple errors from commands} { + catch {catch a b c} b +} 1 + +test error-1.7 {simple errors from commands} { + catch {catch a b c} b + set b +} {wrong # args: should be "catch command ?varName?"} + +test error-1.8 {simple errors from commands} {nonPortable} { + # This test is non-portable: it generates a memory fault on + # machines like DEC Alphas (infinite recursion overflows + # stack?) + + proc p {} { + uplevel 1 catch p error + } + p +} 0 + +# Check errors nested in procedures. Also check the optional argument +# to "error" to generate a new error trace. + +test error-2.1 {errors in nested procedures} { + catch foo b +} 1 + +test error-2.2 {errors in nested procedures} { + catch foo b + set b +} {Human-generated} + +test error-2.3 {errors in nested procedures} { + catch foo b + set errorInfo +} {Human-generated + while executing +"error {Human-generated}" + (procedure "foo" line 4) + invoked from within +"foo"} + +test error-2.4 {errors in nested procedures} { + catch foo2 b +} 1 + +test error-2.5 {errors in nested procedures} { + catch foo2 b + set b +} {Human-generated} + +test error-2.6 {errors in nested procedures} { + catch foo2 b + set errorInfo +} {glorp2 + while executing +"error glorp2" + (procedure "foo2" line 3) + invoked from within +"foo2"} + +# Error conditions related to "catch". + +test error-3.1 {errors in catch command} { + list [catch {catch} msg] $msg +} {1 {wrong # args: should be "catch command ?varName?"}} +test error-3.2 {errors in catch command} { + list [catch {catch a b c} msg] $msg +} {1 {wrong # args: should be "catch command ?varName?"}} +test error-3.3 {errors in catch command} { + catch {unset a} + set a(0) 22 + list [catch {catch {format 44} a} msg] $msg +} {1 {couldn't save command result in variable}} +catch {unset a} + +# More tests related to errorInfo and errorCode + +test error-4.1 {errorInfo and errorCode variables} { + list [catch {error msg1 msg2 msg3} msg] $msg $errorInfo $errorCode +} {1 msg1 msg2 msg3} +test error-4.2 {errorInfo and errorCode variables} { + list [catch {error msg1 {} msg3} msg] $msg $errorInfo $errorCode +} {1 msg1 {msg1 + while executing +"error msg1 {} msg3"} msg3} +test error-4.3 {errorInfo and errorCode variables} { + list [catch {error msg1 {}} msg] $msg $errorInfo $errorCode +} {1 msg1 {msg1 + while executing +"error msg1 {}"} NONE} +test error-4.4 {errorInfo and errorCode variables} { + set errorCode bogus + list [catch {error msg1} msg] $msg $errorInfo $errorCode +} {1 msg1 {msg1 + while executing +"error msg1"} NONE} +test error-4.5 {errorInfo and errorCode variables} { + set errorCode bogus + list [catch {error msg1 msg2 {}} msg] $msg $errorInfo $errorCode +} {1 msg1 msg2 {}} + +# Errors in error command itself + +test error-5.1 {errors in error command} { + list [catch {error} msg] $msg +} {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}} +test error-5.2 {errors in error command} { + list [catch {error a b c d} msg] $msg +} {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}} + +# Make sure that catch resets error information + +test error-6.1 {catch must reset error state} { + catch {error outer [catch {error inner inner.errorInfo inner.errorCode}]} + list $errorCode $errorInfo +} {NONE 1} + +catch {rename p ""} +return "" diff --git a/tests/eval.test b/tests/eval.test new file mode 100644 index 0000000..07f610c --- /dev/null +++ b/tests/eval.test @@ -0,0 +1,55 @@ +# Commands covered: eval +# +# 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: @(#) eval.test 1.10 97/07/02 16:40:56 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test eval-1.1 {single argument} { + eval {format 22} +} 22 +test eval-1.2 {multiple arguments} { + set a {$b} + set b xyzzy + eval format $a +} xyzzy +test eval-1.3 {single argument} { + eval concat a b c d e f g +} {a b c d e f g} + +test eval-2.1 {error: not enough arguments} {catch eval} 1 +test eval-2.2 {error: not enough arguments} { + catch eval msg + set msg +} {wrong # args: should be "eval arg ?arg ...?"} +test eval-2.3 {error in eval'ed command} { + catch {eval {error "test error"}} +} 1 +test eval-2.4 {error in eval'ed command} { + catch {eval {error "test error"}} msg + set msg +} {test error} +test eval-2.5 {error in eval'ed command: setting errorInfo} { + catch {eval { + set a 1 + error "test error" + }} msg + set errorInfo +} "test error + while executing +\"error \"test error\"\" + (\"eval\" body line 3) + invoked from within +\"eval { + set a 1 + error \"test error\" + }\"" diff --git a/tests/event.test b/tests/event.test new file mode 100644 index 0000000..027f7e0 --- /dev/null +++ b/tests/event.test @@ -0,0 +1,567 @@ +# This file contains a collection of tests for the procedures in the file +# tclEvent.c, which includes the "update", and "vwait" Tcl +# commands. Sourcing this file into Tcl runs the tests and generates +# output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# "@(#) event.test 1.35 97/08/11 11:58:38" + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {[catch {testfilehandler create 0 off off}] == 0 } { + test event-1.1 {Tcl_CreateFileHandler, reading} { + testfilehandler close + testfilehandler create 0 readable off + testfilehandler clear 0 + testfilehandler oneevent + set result "" + lappend result [testfilehandler counts 0] + testfilehandler fillpartial 0 + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler close + set result + } {{0 0} {1 0} {2 0}} + test event-1.2 {Tcl_CreateFileHandler, writing} {nonPortable} { + # This test is non-portable because on some systems (e.g. + # SunOS 4.1.3) pipes seem to be writable always. + testfilehandler close + testfilehandler create 0 off writable + testfilehandler clear 0 + testfilehandler oneevent + set result "" + lappend result [testfilehandler counts 0] + testfilehandler fillpartial 0 + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler fill 0 + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler close + set result + } {{0 1} {0 2} {0 2}} + test event-1.3 {Tcl_DeleteFileHandler} {nonPortable} { + testfilehandler close + testfilehandler create 2 disabled disabled + testfilehandler create 1 readable writable + testfilehandler create 0 disabled disabled + testfilehandler fillpartial 1 + set result "" + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler create 1 off off + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler close + set result + } {{0 1} {1 1} {1 2} {0 0}} + + test event-2.1 {Tcl_DeleteFileHandler} {nonPortable} { + testfilehandler close + testfilehandler create 2 disabled disabled + testfilehandler create 1 readable writable + testfilehandler fillpartial 1 + set result "" + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler create 1 off off + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler close + set result + } {{0 1} {1 1} {1 2} {0 0}} + test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} {nonPortable} { + testfilehandler close + testfilehandler create 0 readable writable + testfilehandler fillpartial 0 + set result "" + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler close + testfilehandler create 0 readable writable + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler close + set result + } {{0 1} {0 0}} + + test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off } { + testfilehandler close + testfilehandler create 1 readable writable + testfilehandler fillpartial 1 + testfilehandler windowevent + set result [testfilehandler counts 1] + testfilehandler close + set result + } {0 0} + + test event-4.1 {FileHandlerEventProc, race between event and disabling} {nonPortable} { + update + testfilehandler close + testfilehandler create 2 disabled disabled + testfilehandler create 1 readable writable + testfilehandler fillpartial 1 + set result "" + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler create 1 disabled disabled + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler close + set result + } {{0 1} {1 1} {1 2} {0 0}} + test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} {nonPortable} { + update + testfilehandler close + testfilehandler create 1 readable writable + testfilehandler create 2 readable writable + testfilehandler fillpartial 1 + testfilehandler fillpartial 2 + testfilehandler oneevent + set result "" + lappend result [testfilehandler counts 1] [testfilehandler counts 2] + testfilehandler windowevent + lappend result [testfilehandler counts 1] [testfilehandler counts 2] + testfilehandler close + set result + } {{0 0} {0 1} {0 0} {0 1}} + testfilehandler close + update +} + +test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} { + catch {rename bgerror {}} + proc bgerror msg { + global errorInfo errorCode x + lappend x [list $msg $errorInfo $errorCode] + } + after idle {error "a simple error"} + after idle {open non_existent} + after idle {set errorInfo foobar; set errorCode xyzzy} + set x {} + update idletasks + rename bgerror {} + set x +} {{{a simple error} {a simple error + while executing +"error "a simple error"" + ("after" script)} NONE} {{couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory + while executing +"open non_existent" + ("after" script)} {POSIX ENOENT {no such file or directory}}}} +test event-5.2 {Tcl_BackgroundError, HandleBgErrors procedures} { + catch {rename bgerror {}} + proc bgerror msg { + global x + lappend x $msg + return -code break + } + after idle {error "a simple error"} + after idle {open non_existent} + set x {} + update idletasks + rename bgerror {} + set x +} {{a simple error}} + +test event-6.1 {BgErrorDeleteProc procedure} { + catch {interp delete foo} + interp create foo + foo eval { + proc bgerror args { + global errorInfo + set f [open err.out r+] + seek $f 0 end + puts $f "$args $errorInfo" + close $f + } + after 100 {error "first error"} + after 100 {error "second error"} + } + makeFile Unmodified err.out + after 100 {interp delete foo} + after 200 + update + set f [open err.out r] + set result [read $f] + close $f + removeFile err.out + set result +} {Unmodified +} + +test event-7.1 {bgerror / regular} { + set errRes {} + proc bgerror {err} { + global errRes; + set errRes $err; + } + after 0 {error err1} + vwait errRes; + set errRes; +} err1 + +test event-7.2 {bgerror / accumulation} { + set errRes {} + proc bgerror {err} { + global errRes; + lappend errRes $err; + } + after 0 {error err1} + after 0 {error err2} + after 0 {error err3} + update + set errRes; +} {err1 err2 err3} + +test event-7.3 {bgerror / accumulation / break} { + set errRes {} + proc bgerror {err} { + global errRes; + lappend errRes $err; + return -code break "skip!"; + } + after 0 {error err1} + after 0 {error err2} + after 0 {error err3} + update + set errRes; +} err1 + +test event-7.4 {tkerror is nothing special anymore to tcl} { + set errRes {} + # we don't just rename bgerror to empty because it could then + # be autoloaded... + proc bgerror {err} { + global errRes; + lappend errRes "bg:$err"; + } + proc tkerror {err} { + global errRes; + lappend errRes "tk:$err"; + } + after 0 {error err1} + update + rename tkerror {} + set errRes +} bg:err1 + +# someday : add a test checking that +# when there is no bgerror, an error msg goes to stderr +# ideally one would use sub interp and transfer a fake stderr +# to it, unfortunatly the current interp tcl API does not allow +# that. the other option would be to use fork a test but it +# then becomes more a file/exec test than a bgerror test. + +# end of bgerror tests +catch {rename bgerror {}} + + +if {[info commands testexithandler] != ""} { + test event-8.1 {Tcl_CreateExitHandler procedure} {stdio} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "testexithandler create 41; testexithandler create 4" + puts $child "testexithandler create 6; exit" + flush $child + set result [read $child] + close $child + set result + } {even 6 +even 4 +odd 41 +} + + test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "testexithandler create 41; testexithandler create 4" + puts $child "testexithandler create 6; testexithandler delete 41" + puts $child "testexithandler create 16; exit" + flush $child + set result [read $child] + close $child + set result + } {even 16 +even 6 +even 4 +} + test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "testexithandler create 41; testexithandler create 4" + puts $child "testexithandler create 6; testexithandler delete 4" + puts $child "testexithandler create 16; exit" + flush $child + set result [read $child] + close $child + set result + } {even 16 +even 6 +odd 41 +} + test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "testexithandler create 41; testexithandler create 4" + puts $child "testexithandler create 6; testexithandler delete 6" + puts $child "testexithandler create 16; exit" + flush $child + set result [read $child] + close $child + set result + } {even 16 +even 4 +odd 41 +} + test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "testexithandler create 41; testexithandler delete 41" + puts $child "testexithandler create 16; exit" + flush $child + set result [read $child] + close $child + set result + } {even 16 +} +} + +test event-10.1 {Tcl_Exit procedure} {stdio} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "exit 3" + list [catch {close $child} msg] $msg [lindex $errorCode 0] \ + [lindex $errorCode 2] +} {1 {child process exited abnormally} CHILDSTATUS 3} + +test event-11.1 {Tcl_VwaitCmd procedure} { + list [catch {vwait} msg] $msg +} {1 {wrong # args: should be "vwait name"}} +test event-11.2 {Tcl_VwaitCmd procedure} { + list [catch {vwait a b} msg] $msg +} {1 {wrong # args: should be "vwait name"}} +test event-11.3 {Tcl_VwaitCmd procedure} { + catch {unset x} + set x 1 + list [catch {vwait x(1)} msg] $msg +} {1 {can't trace "x(1)": variable isn't array}} +test event-11.4 {Tcl_VwaitCmd procedure} { + foreach i [after info] { + after cancel $i + } + after 10; update; # On Mac make sure update won't take long + after 100 {set x x-done} + after 200 {set y y-done} + after 300 {set z z-done} + after idle {set q q-done} + set x before + set y before + set z before + set q before + list [vwait y] $x $y $z $q +} {{} x-done y-done before q-done} + +foreach i [after info] { + after cancel $i +} + +test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} { + set f1 [open test1 w] + proc accept {s args} { + puts $s foobar + close $s + } + set s1 [socket -server accept 5000] + set s2 [socket 127.0.0.1 5000] + close $s1 + set x 0 + set y 0 + set z 0 + fileevent $s2 readable { incr z } + vwait z + fileevent $f1 writable { incr x; if { $y == 3 } { set z done } } + fileevent $s2 readable { incr y; if { $x == 3 } { set z done } } + vwait z + close $f1 + close $s2 + file delete test1 test2 + list $x $y $z +} {3 3 done} +test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} { + file delete test1 test2 + set f1 [open test1 w] + set f2 [open test2 w] + set x 0 + set y 0 + set z 0 + update + fileevent $f1 writable { incr x; if { $y == 3 } { set z done } } + fileevent $f2 writable { incr y; if { $x == 3 } { set z done } } + vwait z + close $f1 + close $f2 + file delete test1 test2 + list $x $y $z +} {3 3 done} + + +test event-12.1 {Tcl_UpdateCmd procedure} { + list [catch {update a b} msg] $msg +} {1 {wrong # args: should be "update ?idletasks?"}} +test event-12.2 {Tcl_UpdateCmd procedure} { + list [catch {update bogus} msg] $msg +} {1 {bad option "bogus": must be idletasks}} +test event-12.3 {Tcl_UpdateCmd procedure} { + foreach i [after info] { + after cancel $i + } + after 500 {set x after} + after idle {set y after} + after idle {set z "after, y = $y"} + set x before + set y before + set z before + update idletasks + list $x $y $z +} {before after {after, y = after}} +test event-12.4 {Tcl_UpdateCmd procedure} { + foreach i [after info] { + after cancel $i + } + after 10; update; # On Mac make sure update won't take long + after 200 {set x x-done} + after 600 {set y y-done} + after idle {set z z-done} + set x before + set y before + set z before + after 300 + update + list $x $y $z +} {x-done before z-done} + +if {[info commands testfilehandler] != ""} { + test event-13.1 {Tcl_WaitForFile procedure, readable} unixOnly { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + set x "no timeout" + set result [testfilehandler wait 1 readable 0] + update + testfilehandler close + list $result $x + } {{} {no timeout}} + test event-13.2 {Tcl_WaitForFile procedure, readable} unixOnly { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + set x "no timeout" + set result [testfilehandler wait 1 readable 100] + update + testfilehandler close + list $result $x + } {{} timeout} + test event-13.3 {Tcl_WaitForFile procedure, readable} unixOnly { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + testfilehandler fillpartial 1 + set x "no timeout" + set result [testfilehandler wait 1 readable 100] + update + testfilehandler close + list $result $x + } {readable {no timeout}} + test event-13.4 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + testfilehandler fill 1 + set x "no timeout" + set result [testfilehandler wait 1 writable 0] + update + testfilehandler close + list $result $x + } {{} {no timeout}} + test event-13.5 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + testfilehandler fill 1 + set x "no timeout" + set result [testfilehandler wait 1 writable 100] + update + testfilehandler close + list $result $x + } {{} timeout} + test event-13.6 {Tcl_WaitForFile procedure, writable} unixOnly { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + set x "no timeout" + set result [testfilehandler wait 1 writable 100] + update + testfilehandler close + list $result $x + } {writable {no timeout}} + test event-13.7 {Tcl_WaitForFile procedure, don't call other event handlers} unixOnly { + foreach i [after info] { + after cancel $i + } + after 100 lappend x timeout + after idle lappend x idle + testfilehandler close + testfilehandler create 1 off off + set x "" + set result [list [testfilehandler wait 1 readable 200] $x] + update + testfilehandler close + lappend result $x + } {{} {} {timeout idle}} +} + +if {[info commands testfilewait] != ""} { + test event-13.8 {Tcl_WaitForFile procedure, waiting indefinitely} unixOnly { + set f [open "|sleep 2" r] + set result "" + lappend result [testfilewait $f readable 100] + lappend result [testfilewait $f readable -1] + close $f + set result + } {{} readable} +} + +foreach i [after info] { + after cancel $i +} diff --git a/tests/exec.test b/tests/exec.test new file mode 100644 index 0000000..169885a --- /dev/null +++ b/tests/exec.test @@ -0,0 +1,557 @@ +# Commands covered: exec +# +# 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-1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) exec.test 1.58 97/08/01 11:10:00 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# If exec is not defined just return with no error +# Some platforms like the Macintosh do not have the exec command +if {[info commands exec] == ""} { + puts "exec not implemented for this machine" + return +} +if {$testConfig(stdio) == 0} { + return +} + +set f [open echo w] +puts $f { + puts -nonewline [lindex $argv 0] + foreach str [lrange $argv 1 end] { + puts -nonewline " $str" + } + puts {} +} +close $f + +set f [open cat w] +puts $f { + if {$argv == {}} { + set argv - + } + foreach name $argv { + if {$name == "-"} { + set f stdin + } elseif {[catch {open $name r} f] != 0} { + puts stderr $f + continue + } + while {[eof $f] == 0} { + puts -nonewline [read $f] + } + if {$f != "stdin"} { + close $f + } + } +} +close $f + +set f [open wc w] +puts $f { + set data [read stdin] + set lines [regsub -all "\n" $data {} dummy] + set words [regsub -all "\[^ \t\n]+" $data {} dummy] + set chars [string length $data] + puts [format "%8.d%8.d%8.d" $lines $words $chars] +} +close $f + +set f [open sh w] +puts $f { + if {[lindex $argv 0] != "-c"} { + error "sh: unexpected arguments $argv" + } + set cmd [lindex $argv 1] + lappend cmd ";" + + set newcmd {} + + foreach arg $cmd { + if {$arg == ";"} { + eval exec >@stdout 2>@stderr [list [info nameofexecutable]] $newcmd + set newcmd {} + continue + } + if {$arg == "1>&2"} { + set arg >@stderr + } + lappend newcmd $arg + } +} +close $f + +set f [open sleep w] +puts $f { + after [expr $argv*1000] +} +close $f + +set f [open exit w] +puts $f { + exit $argv +} +close $f + +# Basic operations. + +test exec-1.1 {basic exec operation} { + exec $tcltest echo a b c +} "a b c" +test exec-1.2 {pipelining} { + exec $tcltest echo a b c d | $tcltest cat | $tcltest cat +} "a b c d" +test exec-1.3 {pipelining} { + set a [exec $tcltest echo a b c d | $tcltest cat | $tcltest wc] + list [scan $a "%d %d %d" b c d] $b $c +} {3 1 4} +set arg {12345678901234567890123456789012345678901234567890} +set arg "$arg$arg$arg$arg$arg$arg" +test exec-1.4 {long command lines} { + exec $tcltest echo $arg +} $arg +set arg {} + +# I/O redirection: input from Tcl command. + +test exec-2.1 {redirecting input from immediate source} { + exec $tcltest cat << "Sample text" +} {Sample text} +test exec-2.2 {redirecting input from immediate source} { + exec << "Sample text" $tcltest cat | $tcltest cat +} {Sample text} +test exec-2.3 {redirecting input from immediate source} { + exec $tcltest cat << "Sample text" | $tcltest cat +} {Sample text} +test exec-2.4 {redirecting input from immediate source} { + exec $tcltest cat | $tcltest cat << "Sample text" +} {Sample text} +test exec-2.5 {redirecting input from immediate source} { + exec $tcltest cat "<<Joined to arrows" +} {Joined to arrows} + +# I/O redirection: output to file. + +file delete gorp.file +test exec-3.1 {redirecting output to file} { + exec $tcltest echo "Some simple words" > gorp.file + exec $tcltest cat gorp.file +} "Some simple words" +test exec-3.2 {redirecting output to file} { + exec $tcltest echo "More simple words" | >gorp.file $tcltest cat | $tcltest cat + exec $tcltest cat gorp.file +} "More simple words" +test exec-3.3 {redirecting output to file} { + exec > gorp.file $tcltest echo "Different simple words" | $tcltest cat | $tcltest cat + exec $tcltest cat gorp.file +} "Different simple words" +test exec-3.4 {redirecting output to file} { + exec $tcltest echo "Some simple words" >gorp.file + exec $tcltest cat gorp.file +} "Some simple words" +test exec-3.5 {redirecting output to file} { + exec $tcltest echo "First line" >gorp.file + exec $tcltest echo "Second line" >> gorp.file + exec $tcltest cat gorp.file +} "First line\nSecond line" +test exec-3.6 {redirecting output to file} { + exec $tcltest echo "First line" >gorp.file + exec $tcltest echo "Second line" >>gorp.file + exec $tcltest cat gorp.file +} "First line\nSecond line" +test exec-3.7 {redirecting output to file} { + set f [open gorp.file w] + puts $f "Line 1" + flush $f + exec $tcltest echo "More text" >@ $f + exec $tcltest echo >@$f "Even more" + puts $f "Line 3" + close $f + exec $tcltest cat gorp.file +} "Line 1\nMore text\nEven more\nLine 3" + +# I/O redirection: output and stderr to file. + +file delete gorp.file +test exec-4.1 {redirecting output and stderr to file} { + exec $tcltest echo "test output" >& gorp.file + exec $tcltest cat gorp.file +} "test output" +test exec-4.2 {redirecting output and stderr to file} { + list [exec $tcltest sh -c "echo foo bar 1>&2" >&gorp.file] \ + [exec $tcltest cat gorp.file] +} {{} {foo bar}} +test exec-4.3 {redirecting output and stderr to file} { + exec $tcltest echo "first line" > gorp.file + list [exec $tcltest sh -c "echo foo bar 1>&2" >>&gorp.file] \ + [exec $tcltest cat gorp.file] +} "{} {first line\nfoo bar}" +test exec-4.4 {redirecting output and stderr to file} { + set f [open gorp.file w] + puts $f "Line 1" + flush $f + exec $tcltest echo "More text" >&@ $f + exec $tcltest echo >&@$f "Even more" + puts $f "Line 3" + close $f + exec $tcltest cat gorp.file +} "Line 1\nMore text\nEven more\nLine 3" +test exec-4.5 {redirecting output and stderr to file} { + set f [open gorp.file w] + puts $f "Line 1" + flush $f + exec >&@ $f $tcltest sh -c "echo foo bar 1>&2" + exec >&@$f $tcltest sh -c "echo xyzzy 1>&2" + puts $f "Line 3" + close $f + exec $tcltest cat gorp.file +} "Line 1\nfoo bar\nxyzzy\nLine 3" + +# I/O redirection: input from file. + +exec $tcltest echo "Just a few thoughts" > gorp.file +test exec-5.1 {redirecting input from file} { + exec $tcltest cat < gorp.file +} {Just a few thoughts} +test exec-5.2 {redirecting input from file} { + exec $tcltest cat | $tcltest cat < gorp.file +} {Just a few thoughts} +test exec-5.3 {redirecting input from file} { + exec $tcltest cat < gorp.file | $tcltest cat +} {Just a few thoughts} +test exec-5.4 {redirecting input from file} { + exec < gorp.file $tcltest cat | $tcltest cat +} {Just a few thoughts} +test exec-5.5 {redirecting input from file} { + exec $tcltest cat <gorp.file +} {Just a few thoughts} +test exec-5.6 {redirecting input from file} { + set f [open gorp.file r] + set result [exec $tcltest cat <@ $f] + close $f + set result +} {Just a few thoughts} +test exec-5.7 {redirecting input from file} { + set f [open gorp.file r] + set result [exec <@$f $tcltest cat] + close $f + set result +} {Just a few thoughts} + +# I/O redirection: standard error through a pipeline. + +test exec-6.1 {redirecting stderr through a pipeline} { + exec $tcltest sh -c "echo foo bar" |& $tcltest cat +} "foo bar" +test exec-6.2 {redirecting stderr through a pipeline} { + exec $tcltest sh -c "echo foo bar 1>&2" |& $tcltest cat +} "foo bar" +test exec-6.3 {redirecting stderr through a pipeline} { + exec $tcltest sh -c "echo foo bar 1>&2" \ + |& $tcltest sh -c "echo second msg 1>&2 ; cat" |& $tcltest cat +} "second msg\nfoo bar" + +# I/O redirection: combinations. + +catch {exec rm -f gorp.file2} +test exec-7.1 {multiple I/O redirections} { + exec << "command input" > gorp.file2 $tcltest cat < gorp.file + exec $tcltest cat gorp.file2 +} {Just a few thoughts} +test exec-7.2 {multiple I/O redirections} { + exec < gorp.file << "command input" $tcltest cat +} {command input} + +# Long input to command and output from command. + +set a "0123456789 xxxxxxxxx abcdefghi ABCDEFGHIJK\n" +set a [concat $a $a $a $a] +set a [concat $a $a $a $a] +set a [concat $a $a $a $a] +set a [concat $a $a $a $a] +test exec-8.1 {long input and output} { + exec $tcltest cat << $a +} $a + +# Commands that return errors. + +test exec-9.1 {commands returning errors} { + set x [catch {exec gorp456} msg] + list $x [string tolower $msg] [string tolower $errorCode] +} {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}} +test exec-9.2 {commands returning errors} { + string tolower [list [catch {exec $tcltest echo foo | foo123} msg] $msg $errorCode] +} {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}} +test exec-9.3 {commands returning errors} { + list [catch {exec $tcltest sleep 1 | $tcltest exit 43 | $tcltest sleep 1} msg] $msg +} {1 {child process exited abnormally}} +test exec-9.4 {commands returning errors} { + list [catch {exec $tcltest exit 43 | $tcltest echo "foo bar"} msg] $msg +} {1 {foo bar +child process exited abnormally}} +test exec-9.5 {commands returning errors} { + list [catch {exec gorp456 | $tcltest echo a b c} msg] [string tolower $msg] +} {1 {couldn't execute "gorp456": no such file or directory}} +test exec-9.6 {commands returning errors} { + list [catch {exec $tcltest sh -c "echo error msg 1>&2"} msg] $msg +} {1 {error msg}} +test exec-9.7 {commands returning errors} { + list [catch {exec $tcltest sh -c "echo error msg 1>&2" \ + | $tcltest sh -c "echo error msg 1>&2"} msg] $msg +} {1 {error msg +error msg}} + +# Errors in executing the Tcl command, as opposed to errors in the +# processes that are invoked. + +test exec-10.1 {errors in exec invocation} { + list [catch {exec} msg] $msg +} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}} +test exec-10.2 {errors in exec invocation} { + list [catch {exec | cat} msg] $msg +} {1 {illegal use of | or |& in command}} +test exec-10.3 {errors in exec invocation} { + list [catch {exec cat |} msg] $msg +} {1 {illegal use of | or |& in command}} +test exec-10.4 {errors in exec invocation} { + list [catch {exec cat | | cat} msg] $msg +} {1 {illegal use of | or |& in command}} +test exec-10.5 {errors in exec invocation} { + list [catch {exec cat | |& cat} msg] $msg +} {1 {illegal use of | or |& in command}} +test exec-10.6 {errors in exec invocation} { + list [catch {exec cat |&} msg] $msg +} {1 {illegal use of | or |& in command}} +test exec-10.7 {errors in exec invocation} { + list [catch {exec cat <} msg] $msg +} {1 {can't specify "<" as last word in command}} +test exec-10.8 {errors in exec invocation} { + list [catch {exec cat >} msg] $msg +} {1 {can't specify ">" as last word in command}} +test exec-10.9 {errors in exec invocation} { + list [catch {exec cat <<} msg] $msg +} {1 {can't specify "<<" as last word in command}} +test exec-10.10 {errors in exec invocation} { + list [catch {exec cat >>} msg] $msg +} {1 {can't specify ">>" as last word in command}} +test exec-10.11 {errors in exec invocation} { + list [catch {exec cat >&} msg] $msg +} {1 {can't specify ">&" as last word in command}} +test exec-10.12 {errors in exec invocation} { + list [catch {exec cat >>&} msg] $msg +} {1 {can't specify ">>&" as last word in command}} +test exec-10.13 {errors in exec invocation} { + list [catch {exec cat >@} msg] $msg +} {1 {can't specify ">@" as last word in command}} +test exec-10.14 {errors in exec invocation} { + list [catch {exec cat <@} msg] $msg +} {1 {can't specify "<@" as last word in command}} +test exec-10.15 {errors in exec invocation} { + list [catch {exec cat < a/b/c} msg] [string tolower $msg] +} {1 {couldn't read file "a/b/c": no such file or directory}} +test exec-10.16 {errors in exec invocation} { + list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg] +} {1 {couldn't write file "a/b/c": no such file or directory}} +test exec-10.17 {errors in exec invocation} { + list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg] +} {1 {couldn't write file "a/b/c": no such file or directory}} +set f [open gorp.file w] +test exec-10.18 {errors in exec invocation} { + list [catch {exec cat <@ $f} msg] $msg +} "1 {channel \"$f\" wasn't opened for reading}" +close $f +set f [open gorp.file r] +test exec-10.19 {errors in exec invocation} { + list [catch {exec cat >@ $f} msg] $msg +} "1 {channel \"$f\" wasn't opened for writing}" +close $f +test exec-10.20 {errors in exec invocation} { + list [catch {exec ~non_existent_user/foo/bar} msg] $msg +} {1 {user "non_existent_user" doesn't exist}} +test exec-10.21 {errors in exec invocation} { + list [catch {exec $tcltest true | ~xyzzy_bad_user/x | false} msg] $msg +} {1 {user "xyzzy_bad_user" doesn't exist}} + +# Commands in background. + +test exec-11.1 {commands in background} { + set x [lindex [time {exec $tcltest sleep 2 &}] 0] + expr $x<1000000 +} 1 +test exec-11.2 {commands in background} { + list [catch {exec $tcltest echo a &b} msg] $msg +} {0 {a &b}} +test exec-11.3 {commands in background} { + llength [exec $tcltest sleep 1 &] +} 1 +test exec-11.4 {commands in background} { + llength [exec $tcltest sleep 1 | $tcltest sleep 1 | $tcltest sleep 1 &] +} 3 +test exec-11.5 {commands in background} { + set f [open gorp.file w] + puts $f { catch { exec [info nameofexecutable] echo foo & } } + close $f + string compare "foo" [exec $tcltest gorp.file] +} 0 + +# Make sure that background commands are properly reaped when +# they eventually die. + +exec $tcltest sleep 3 +test exec-12.1 {reaping background processes} {unixOnly nonPortable} { + for {set i 0} {$i < 20} {incr i} { + exec echo foo > /dev/null & + } + exec sleep 1 + catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg + lindex $msg 0 +} 0 +test exec-12.2 {reaping background processes} {unixOnly nonPortable} { + exec sleep 2 | sleep 2 | sleep 2 & + catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg + set x [lindex $msg 0] + exec sleep 3 + catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg + list $x [lindex $msg 0] +} {3 0} +test exec-12.3 {reaping background processes} {unixOnly nonPortable} { + exec sleep 1000 & + exec sleep 1000 & + set x [exec ps | fgrep "sleep" | fgrep -v fgrep] + set pids {} + foreach i [split $x \n] { + lappend pids [lindex $i 0] + } + foreach i $pids { + catch {exec kill -STOP $i} + } + catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg + set x [lindex $msg 0] + + foreach i $pids { + catch {exec kill -KILL $i} + } + catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg + list $x [lindex $msg 0] +} {2 0} + +# Make sure "errorCode" is set correctly. + +test exec-13.1 {setting errorCode variable} { + list [catch {exec $tcltest cat < a/b/c} msg] [string tolower $errorCode] +} {1 {posix enoent {no such file or directory}}} +test exec-13.2 {setting errorCode variable} { + list [catch {exec $tcltest cat > a/b/c} msg] [string tolower $errorCode] +} {1 {posix enoent {no such file or directory}}} +test exec-13.3 {setting errorCode variable} { + set x [catch {exec _weird_cmd_} msg] + list $x [string tolower $msg] [lindex $errorCode 0] \ + [string tolower [lrange $errorCode 2 end]] +} {1 {couldn't execute "_weird_cmd_": no such file or directory} POSIX {{no such file or directory}}} + +# Switches before the first argument + +test exec-14.1 {-keepnewline switch} { + exec -keepnewline $tcltest echo foo +} "foo\n" +test exec-14.2 {-keepnewline switch} { + list [catch {exec -keepnewline} msg] $msg +} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}} +test exec-14.3 {unknown switch} { + list [catch {exec -gorp} msg] $msg +} {1 {bad switch "-gorp": must be -keepnewline or --}} +test exec-14.4 {-- switch} { + list [catch {exec -- -gorp} msg] [string tolower $msg] +} {1 {couldn't execute "-gorp": no such file or directory}} + +# Redirecting standard error separately from standard output + +test exec-15.1 {standard error redirection} { + exec $tcltest echo "First line" > gorp.file + list [exec $tcltest sh -c "echo foo bar 1>&2" 2> gorp.file] \ + [exec $tcltest cat gorp.file] +} {{} {foo bar}} +test exec-15.2 {standard error redirection} { + list [exec $tcltest sh -c "echo foo bar 1>&2" \ + | $tcltest echo biz baz >gorp.file 2> gorp.file2] \ + [exec $tcltest cat gorp.file] \ + [exec $tcltest cat gorp.file2] +} {{} {biz baz} {foo bar}} +test exec-15.3 {standard error redirection} { + list [exec $tcltest sh -c "echo foo bar 1>&2" \ + | $tcltest echo biz baz 2>gorp.file > gorp.file2] \ + [exec $tcltest cat gorp.file] \ + [exec $tcltest cat gorp.file2] +} {{} {foo bar} {biz baz}} +test exec-15.4 {standard error redirection} { + set f [open gorp.file w] + puts $f "Line 1" + flush $f + exec $tcltest sh -c "echo foo bar 1>&2" 2>@ $f + puts $f "Line 3" + close $f + exec $tcltest cat gorp.file +} {Line 1 +foo bar +Line 3} +test exec-15.5 {standard error redirection} { + exec $tcltest echo "First line" > gorp.file + exec $tcltest sh -c "echo foo bar 1>&2" 2>> gorp.file + exec $tcltest cat gorp.file +} {First line +foo bar} +test exec-15.6 {standard error redirection} { + exec $tcltest sh -c "echo foo bar 1>&2" > gorp.file2 2> gorp.file \ + >& gorp.file 2> gorp.file2 | $tcltest echo biz baz + list [exec $tcltest cat gorp.file] [exec $tcltest cat gorp.file2] +} {{biz baz} {foo bar}} + +test exec-16.1 {flush output before exec} { + set f [open gorp.file w] + puts $f "First line" + exec $tcltest echo "Second line" >@ $f + puts $f "Third line" + close $f + exec $tcltest cat gorp.file +} {First line +Second line +Third line} +test exec-16.2 {flush output before exec} {} { + set f [open gorp.file w] + puts $f "First line" + exec $tcltest << {puts stderr {Second line}} >&@ $f > gorp.file2 + puts $f "Third line" + close $f + exec $tcltest cat gorp.file +} {First line +Second line +Third line} + +test exec-17.1 { inheriting standard I/O } { + set f [open script w] + puts $f {close stdout + set f [open gorp.file w] + catch {exec [info nameofexecutable] echo foobar &} + exec [info nameofexecutable] sleep 2 + close $f + } + close $f + catch {exec $tcltest script} result + set f [open gorp.file r] + lappend result [read $f] + close $f + set result +} {{foobar +}} + +file delete script gorp.file gorp.file2 +file delete echo cat wc sh sleep exit diff --git a/tests/execute.test b/tests/execute.test new file mode 100644 index 0000000..81fde45 --- /dev/null +++ b/tests/execute.test @@ -0,0 +1,114 @@ +# This file contains tests for the tclExecute.c source file. Tests appear +# in the same order as the C code that they test. The set of tests is +# currently incomplete since it currently includes only new tests for +# code changed for the addition of Tcl namespaces. Other execution- +# related tests appear in several other test files including +# namespace.test, basic.test, eval.test, for.test, etc. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) execute.test 1.5 97/08/12 11:16:31 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {eval namespace delete [namespace children :: test_ns_*]} +catch {rename foo ""} +catch {unset x} +catch {unset y} +catch {unset msg} + +test execute-1.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {unset x} + catch {unset y} + namespace eval test_ns_1 { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_1::test_ns_2 { + namespace import ::test_ns_1::* + } + set x "test_ns_1::" + set y "test_ns_2::" + list [namespace which -command ${x}${y}cmd1] \ + [catch {namespace which -command ${x}${y}cmd2} msg] $msg \ + [catch {namespace which -command ${x}${y}:cmd2} msg] $msg +} {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}} +test execute-1.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename foo ""} + catch {unset l} + proc foo {} { + return "global foo" + } + namespace eval test_ns_1 { + proc whichFoo {} { + return [namespace which -command foo] + } + } + set l "" + lappend l [test_ns_1::whichFoo] + namespace eval test_ns_1 { + proc foo {} { + return "namespace foo" + } + } + lappend l [test_ns_1::whichFoo] + set l +} {::foo ::test_ns_1::foo} +test execute-1.3 {Tcl_GetCommandFromObj, command never found} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename foo ""} + namespace eval test_ns_1 { + proc foo {} { + return "namespace foo" + } + } + namespace eval test_ns_1 { + proc foo {} { + return "namespace foo" + } + } + list [namespace eval test_ns_1 {namespace which -command foo}] \ + [rename test_ns_1::foo ""] \ + [catch {namespace eval test_ns_1 {namespace which -command foo}} msg] $msg +} {::test_ns_1::foo {} 0 {}} + +test execute-2.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {unset l} + proc {} {} {return {}} + {} + set l {} + lindex {} 0 + {} +} {} + +test execute-3.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} { + proc {} {} {} + proc { } {} {} + proc p {} { + set x {} + $x + append x { } + $x + } + p +} {} + +catch {eval namespace delete [namespace children :: test_ns_*]} +catch {rename foo ""} +catch {rename p ""} +catch {rename {} ""} +catch {rename { } ""} +catch {unset x} +catch {unset y} +catch {unset msg} +concat {} diff --git a/tests/expr-old.test b/tests/expr-old.test new file mode 100644 index 0000000..8fb8ad9 --- /dev/null +++ b/tests/expr-old.test @@ -0,0 +1,920 @@ +# Commands covered: expr +# +# This file contains the original set of tests for Tcl's expr command. +# Since the expr command is now compiled, a new set of tests covering +# the new implementation is in the file "expr.test". Sourcing this file +# into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1991-1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) expr-old.test 1.63 97/10/31 17:23:24 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { + set gotT1 0 + puts "This application hasn't been compiled with the \"T1\" and" + puts "\"T2\" math functions, so I'll skip some of the expr tests." +} else { + set gotT1 1 +} + +# First, test all of the integer operators individually. + +test expr-old-1.1 {integer operators} {expr -4} -4 +test expr-old-1.2 {integer operators} {expr -(1+4)} -5 +test expr-old-1.3 {integer operators} {expr ~3} -4 +test expr-old-1.4 {integer operators} {expr !2} 0 +test expr-old-1.5 {integer operators} {expr !0} 1 +test expr-old-1.6 {integer operators} {expr 4*6} 24 +test expr-old-1.7 {integer operators} {expr 36/12} 3 +test expr-old-1.8 {integer operators} {expr 27/4} 6 +test expr-old-1.9 {integer operators} {expr 27%4} 3 +test expr-old-1.10 {integer operators} {expr 2+2} 4 +test expr-old-1.11 {integer operators} {expr 2-6} -4 +test expr-old-1.12 {integer operators} {expr 1<<3} 8 +test expr-old-1.13 {integer operators} {expr 0xff>>2} 63 +test expr-old-1.14 {integer operators} {expr -1>>2} -1 +test expr-old-1.15 {integer operators} {expr 3>2} 1 +test expr-old-1.16 {integer operators} {expr 2>2} 0 +test expr-old-1.17 {integer operators} {expr 1>2} 0 +test expr-old-1.18 {integer operators} {expr 3<2} 0 +test expr-old-1.19 {integer operators} {expr 2<2} 0 +test expr-old-1.20 {integer operators} {expr 1<2} 1 +test expr-old-1.21 {integer operators} {expr 3>=2} 1 +test expr-old-1.22 {integer operators} {expr 2>=2} 1 +test expr-old-1.23 {integer operators} {expr 1>=2} 0 +test expr-old-1.24 {integer operators} {expr 3<=2} 0 +test expr-old-1.25 {integer operators} {expr 2<=2} 1 +test expr-old-1.26 {integer operators} {expr 1<=2} 1 +test expr-old-1.27 {integer operators} {expr 3==2} 0 +test expr-old-1.28 {integer operators} {expr 2==2} 1 +test expr-old-1.29 {integer operators} {expr 3!=2} 1 +test expr-old-1.30 {integer operators} {expr 2!=2} 0 +test expr-old-1.31 {integer operators} {expr 7&0x13} 3 +test expr-old-1.32 {integer operators} {expr 7^0x13} 20 +test expr-old-1.33 {integer operators} {expr 7|0x13} 23 +test expr-old-1.34 {integer operators} {expr 0&&1} 0 +test expr-old-1.35 {integer operators} {expr 0&&0} 0 +test expr-old-1.36 {integer operators} {expr 1&&3} 1 +test expr-old-1.37 {integer operators} {expr 0||1} 1 +test expr-old-1.38 {integer operators} {expr 3||0} 1 +test expr-old-1.39 {integer operators} {expr 0||0} 0 +test expr-old-1.40 {integer operators} {expr 3>2?44:66} 44 +test expr-old-1.41 {integer operators} {expr 2>3?44:66} 66 +test expr-old-1.42 {integer operators} {expr 36/5} 7 +test expr-old-1.43 {integer operators} {expr 36%5} 1 +test expr-old-1.44 {integer operators} {expr -36/5} -8 +test expr-old-1.45 {integer operators} {expr -36%5} 4 +test expr-old-1.46 {integer operators} {expr 36/-5} -8 +test expr-old-1.47 {integer operators} {expr 36%-5} -4 +test expr-old-1.48 {integer operators} {expr -36/-5} 7 +test expr-old-1.49 {integer operators} {expr -36%-5} -1 +test expr-old-1.50 {integer operators} {expr +36} 36 +test expr-old-1.51 {integer operators} {expr +--++36} 36 +test expr-old-1.52 {integer operators} {expr +36%+5} 1 +test expr-old-1.53 {integer operators} { + catch {unset x} + set x yes + list [expr {1 && $x}] [expr {$x && 1}] \ + [expr {0 || $x}] [expr {$x || 0}] +} {1 1 1 1} + +# Check the floating-point operators individually, along with +# automatic conversion to integers where needed. + +test expr-old-2.1 {floating-point operators} {expr -4.2} -4.2 +test expr-old-2.2 {floating-point operators} {expr -(1.1+4.2)} -5.3 +test expr-old-2.3 {floating-point operators} {expr +5.7} 5.7 +test expr-old-2.4 {floating-point operators} {expr +--+-62.0} -62.0 +test expr-old-2.5 {floating-point operators} {expr !2.1} 0 +test expr-old-2.6 {floating-point operators} {expr !0.0} 1 +test expr-old-2.7 {floating-point operators} {expr 4.2*6.3} 26.46 +test expr-old-2.8 {floating-point operators} {expr 36.0/12.0} 3.0 +test expr-old-2.9 {floating-point operators} {expr 27/4.0} 6.75 +test expr-old-2.10 {floating-point operators} {expr 2.3+2.1} 4.4 +test expr-old-2.11 {floating-point operators} {expr 2.3-6.5} -4.2 +test expr-old-2.12 {floating-point operators} {expr 3.1>2.1} 1 +test expr-old-2.13 {floating-point operators} {expr {2.1 > 2.1}} 0 +test expr-old-2.14 {floating-point operators} {expr 1.23>2.34e+1} 0 +test expr-old-2.15 {floating-point operators} {expr 3.45<2.34} 0 +test expr-old-2.16 {floating-point operators} {expr 0.002e3<--200e-2} 0 +test expr-old-2.17 {floating-point operators} {expr 1.1<2.1} 1 +test expr-old-2.18 {floating-point operators} {expr 3.1>=2.2} 1 +test expr-old-2.19 {floating-point operators} {expr 2.345>=2.345} 1 +test expr-old-2.20 {floating-point operators} {expr 1.1>=2.2} 0 +test expr-old-2.21 {floating-point operators} {expr 3.0<=2.0} 0 +test expr-old-2.22 {floating-point operators} {expr 2.2<=2.2} 1 +test expr-old-2.23 {floating-point operators} {expr 2.2<=2.2001} 1 +test expr-old-2.24 {floating-point operators} {expr 3.2==2.2} 0 +test expr-old-2.25 {floating-point operators} {expr 2.2==2.2} 1 +test expr-old-2.26 {floating-point operators} {expr 3.2!=2.2} 1 +test expr-old-2.27 {floating-point operators} {expr 2.2!=2.2} 0 +test expr-old-2.28 {floating-point operators} {expr 0.0&&0.0} 0 +test expr-old-2.29 {floating-point operators} {expr 0.0&&1.3} 0 +test expr-old-2.30 {floating-point operators} {expr 1.3&&0.0} 0 +test expr-old-2.31 {floating-point operators} {expr 1.3&&3.3} 1 +test expr-old-2.32 {floating-point operators} {expr 0.0||0.0} 0 +test expr-old-2.33 {floating-point operators} {expr 0.0||1.3} 1 +test expr-old-2.34 {floating-point operators} {expr 1.3||0.0} 1 +test expr-old-2.35 {floating-point operators} {expr 3.3||0.0} 1 +test expr-old-2.36 {floating-point operators} {expr 3.3>2.3?44.3:66.3} 44.3 +test expr-old-2.37 {floating-point operators} {expr 2.3>3.3?44.3:66.3} 66.3 +test expr-old-2.38 {floating-point operators} { + list [catch {expr 028.1 + 09.2} msg] $msg +} {0 37.3} + +# Operators that aren't legal on floating-point numbers + +test expr-old-3.1 {illegal floating-point operations} { + list [catch {expr ~4.0} msg] $msg +} {1 {can't use floating-point value as operand of "~"}} +test expr-old-3.2 {illegal floating-point operations} { + list [catch {expr 27%4.0} msg] $msg +} {1 {can't use floating-point value as operand of "%"}} +test expr-old-3.3 {illegal floating-point operations} { + list [catch {expr 27.0%4} msg] $msg +} {1 {can't use floating-point value as operand of "%"}} +test expr-old-3.4 {illegal floating-point operations} { + list [catch {expr 1.0<<3} msg] $msg +} {1 {can't use floating-point value as operand of "<<"}} +test expr-old-3.5 {illegal floating-point operations} { + list [catch {expr 3<<1.0} msg] $msg +} {1 {can't use floating-point value as operand of "<<"}} +test expr-old-3.6 {illegal floating-point operations} { + list [catch {expr 24.0>>3} msg] $msg +} {1 {can't use floating-point value as operand of ">>"}} +test expr-old-3.7 {illegal floating-point operations} { + list [catch {expr 24>>3.0} msg] $msg +} {1 {can't use floating-point value as operand of ">>"}} +test expr-old-3.8 {illegal floating-point operations} { + list [catch {expr 24&3.0} msg] $msg +} {1 {can't use floating-point value as operand of "&"}} +test expr-old-3.9 {illegal floating-point operations} { + list [catch {expr 24.0|3} msg] $msg +} {1 {can't use floating-point value as operand of "|"}} +test expr-old-3.10 {illegal floating-point operations} { + list [catch {expr 24.0^3} msg] $msg +} {1 {can't use floating-point value as operand of "^"}} + +# Check the string operators individually. + +test expr-old-4.1 {string operators} {expr {"abc" > "def"}} 0 +test expr-old-4.2 {string operators} {expr {"def" > "def"}} 0 +test expr-old-4.3 {string operators} {expr {"g" > "def"}} 1 +test expr-old-4.4 {string operators} {expr {"abc" < "abd"}} 1 +test expr-old-4.5 {string operators} {expr {"abd" < "abd"}} 0 +test expr-old-4.6 {string operators} {expr {"abe" < "abd"}} 0 +test expr-old-4.7 {string operators} {expr {"abc" >= "def"}} 0 +test expr-old-4.8 {string operators} {expr {"def" >= "def"}} 1 +test expr-old-4.9 {string operators} {expr {"g" >= "def"}} 1 +test expr-old-4.10 {string operators} {expr {"abc" <= "abd"}} 1 +test expr-old-4.11 {string operators} {expr {"abd" <= "abd"}} 1 +test expr-old-4.12 {string operators} {expr {"abe" <= "abd"}} 0 +test expr-old-4.13 {string operators} {expr {"abc" == "abd"}} 0 +test expr-old-4.14 {string operators} {expr {"abd" == "abd"}} 1 +test expr-old-4.15 {string operators} {expr {"abc" != "abd"}} 1 +test expr-old-4.16 {string operators} {expr {"abd" != "abd"}} 0 +test expr-old-4.17 {string operators} {expr {"0y" < "0x12"}} 0 +test expr-old-4.18 {string operators} {expr {"." < " "}} 0 + +# The following tests are non-portable because on some systems "+" +# and "-" can be parsed as numbers. + +test expr-old-4.19 {string operators} {nonPortable} {expr {"0" == "+"}} 0 +test expr-old-4.20 {string operators} {nonPortable} {expr {"0" == "-"}} 0 +test expr-old-4.21 {string operators} {expr {1?"foo":"bar"}} foo +test expr-old-4.22 {string operators} {expr {0?"foo":"bar"}} bar + +# Operators that aren't legal on string operands. + +test expr-old-5.1 {illegal string operations} { + list [catch {expr {-"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "-"}} +test expr-old-5.2 {illegal string operations} { + list [catch {expr {+"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-old-5.3 {illegal string operations} { + list [catch {expr {~"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "~"}} +test expr-old-5.4 {illegal string operations} { + list [catch {expr {!"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "!"}} +test expr-old-5.5 {illegal string operations} { + list [catch {expr {"a"*"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "*"}} +test expr-old-5.6 {illegal string operations} { + list [catch {expr {"a"/"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "/"}} +test expr-old-5.7 {illegal string operations} { + list [catch {expr {"a"%"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "%"}} +test expr-old-5.8 {illegal string operations} { + list [catch {expr {"a"+"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-old-5.9 {illegal string operations} { + list [catch {expr {"a"-"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "-"}} +test expr-old-5.10 {illegal string operations} { + list [catch {expr {"a"<<"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "<<"}} +test expr-old-5.11 {illegal string operations} { + list [catch {expr {"a">>"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of ">>"}} +test expr-old-5.12 {illegal string operations} { + list [catch {expr {"a"&"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "&"}} +test expr-old-5.13 {illegal string operations} { + list [catch {expr {"a"^"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "^"}} +test expr-old-5.14 {illegal string operations} { + list [catch {expr {"a"|"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "|"}} +test expr-old-5.15 {illegal string operations} { + list [catch {expr {"a"&&"b"}} msg] $msg +} {1 {expected boolean value but got "a"}} +test expr-old-5.16 {illegal string operations} { + list [catch {expr {"a"||"b"}} msg] $msg +} {1 {expected boolean value but got "a"}} +test expr-old-5.17 {illegal string operations} { + list [catch {expr {"a"?4:2}} msg] $msg +} {1 {expected boolean value but got "a"}} + +# Check precedence pairwise. + +test expr-old-6.1 {precedence checks} {expr -~3} 4 +test expr-old-6.2 {precedence checks} {expr -!3} 0 +test expr-old-6.3 {precedence checks} {expr -~0} 1 + +test expr-old-7.1 {precedence checks} {expr 2*4/6} 1 +test expr-old-7.2 {precedence checks} {expr 24/6*3} 12 +test expr-old-7.3 {precedence checks} {expr 24/6/2} 2 + +test expr-old-8.1 {precedence checks} {expr -2+4} 2 +test expr-old-8.2 {precedence checks} {expr -2-4} -6 +test expr-old-8.3 {precedence checks} {expr +2-4} -2 + +test expr-old-9.1 {precedence checks} {expr 2*3+4} 10 +test expr-old-9.2 {precedence checks} {expr 8/2+4} 8 +test expr-old-9.3 {precedence checks} {expr 8%3+4} 6 +test expr-old-9.4 {precedence checks} {expr 2*3-1} 5 +test expr-old-9.5 {precedence checks} {expr 8/2-1} 3 +test expr-old-9.6 {precedence checks} {expr 8%3-1} 1 + +test expr-old-10.1 {precedence checks} {expr 6-3-2} 1 + +test expr-old-11.1 {precedence checks} {expr 7+1>>2} 2 +test expr-old-11.2 {precedence checks} {expr 7+1<<2} 32 +test expr-old-11.3 {precedence checks} {expr 7>>3-2} 3 +test expr-old-11.4 {precedence checks} {expr 7<<3-2} 14 + +test expr-old-12.1 {precedence checks} {expr 6>>1>4} 0 +test expr-old-12.2 {precedence checks} {expr 6>>1<2} 0 +test expr-old-12.3 {precedence checks} {expr 6>>1>=3} 1 +test expr-old-12.4 {precedence checks} {expr 6>>1<=2} 0 +test expr-old-12.5 {precedence checks} {expr 6<<1>5} 1 +test expr-old-12.6 {precedence checks} {expr 6<<1<5} 0 +test expr-old-12.7 {precedence checks} {expr 5<=6<<1} 1 +test expr-old-12.8 {precedence checks} {expr 5>=6<<1} 0 + +test expr-old-13.1 {precedence checks} {expr 2<3<4} 1 +test expr-old-13.2 {precedence checks} {expr 0<4>2} 0 +test expr-old-13.3 {precedence checks} {expr 4>2<1} 0 +test expr-old-13.4 {precedence checks} {expr 4>3>2} 0 +test expr-old-13.5 {precedence checks} {expr 4>3>=2} 0 +test expr-old-13.6 {precedence checks} {expr 4>=3>2} 0 +test expr-old-13.7 {precedence checks} {expr 4>=3>=2} 0 +test expr-old-13.8 {precedence checks} {expr 0<=4>=2} 0 +test expr-old-13.9 {precedence checks} {expr 4>=2<=0} 0 +test expr-old-13.10 {precedence checks} {expr 2<=3<=4} 1 + +test expr-old-14.1 {precedence checks} {expr 1==4>3} 1 +test expr-old-14.2 {precedence checks} {expr 0!=4>3} 1 +test expr-old-14.3 {precedence checks} {expr 1==3<4} 1 +test expr-old-14.4 {precedence checks} {expr 0!=3<4} 1 +test expr-old-14.5 {precedence checks} {expr 1==4>=3} 1 +test expr-old-14.6 {precedence checks} {expr 0!=4>=3} 1 +test expr-old-14.7 {precedence checks} {expr 1==3<=4} 1 +test expr-old-14.8 {precedence checks} {expr 0!=3<=4} 1 + +test expr-old-15.1 {precedence checks} {expr 1==3==3} 0 +test expr-old-15.2 {precedence checks} {expr 3==3!=2} 1 +test expr-old-15.3 {precedence checks} {expr 2!=3==3} 0 +test expr-old-15.4 {precedence checks} {expr 2!=1!=1} 0 + +test expr-old-16.1 {precedence checks} {expr 2&3==2} 0 +test expr-old-16.2 {precedence checks} {expr 1&3!=3} 0 + +test expr-old-17.1 {precedence checks} {expr 7&3^0x10} 19 +test expr-old-17.2 {precedence checks} {expr 7^0x10&3} 7 + +test expr-old-18.1 {precedence checks} {expr 7^0x10|3} 23 +test expr-old-18.2 {precedence checks} {expr 7|0x10^3} 23 + +test expr-old-19.1 {precedence checks} {expr 7|3&&1} 1 +test expr-old-19.2 {precedence checks} {expr 1&&3|7} 1 +test expr-old-19.3 {precedence checks} {expr 0&&1||1} 1 +test expr-old-19.4 {precedence checks} {expr 1||1&&0} 1 + +test expr-old-20.1 {precedence checks} {expr 1||0?3:4} 3 +test expr-old-20.2 {precedence checks} {expr 1?0:4||1} 0 +test expr-old-20.3 {precedence checks} {expr 1?2:0?3:4} 2 +test expr-old-20.4 {precedence checks} {expr 0?2:0?3:4} 4 +test expr-old-20.5 {precedence checks} {expr 1?2?3:4:0} 3 +test expr-old-20.6 {precedence checks} {expr 0?2?3:4:0} 0 + +# Parentheses. + +test expr-old-21.1 {parenthesization} {expr (2+4)*6} 36 +test expr-old-21.2 {parenthesization} {expr (1?0:4)||1} 1 +test expr-old-21.3 {parenthesization} {expr +(3-4)} -1 + +# Embedded commands and variable names. + +set a 16 +test expr-old-22.1 {embedded variables} {expr {2*$a}} 32 +test expr-old-22.2 {embedded variables} { + set x -5 + set y 10 + expr {$x + $y} +} {5} +test expr-old-22.3 {embedded variables} { + set x " -5" + set y " +10" + expr {$x + $y} +} {5} +test expr-old-22.4 {embedded commands and variables} {expr {[set a] - 14}} 2 +test expr-old-22.5 {embedded commands and variables} { + list [catch {expr {12 - [bad_command_name]}} msg] $msg +} {1 {invalid command name "bad_command_name"}} + +# Double-quotes and things inside them. + +test expr-old-23.1 {double quotes} {expr {"abc"}} abc +test expr-old-23.2 {double quotes} { + set a 189 + expr {"$a.bc"} +} 189.bc +test expr-old-23.3 {double quotes} { + set b2 xyx + expr {"$b2$b2$b2.[set b2].[set b2]"} +} xyxxyxxyx.xyx.xyx +test expr-old-23.4 {double quotes} {expr {"11\}\}22"}} 11}}22 +test expr-old-23.5 {double quotes} {expr {"\*bc"}} {*bc} +test expr-old-23.6 {double quotes} { + catch {unset bogus__} + list [catch {expr {"$bogus__"}} msg] $msg +} {1 {can't read "bogus__": no such variable}} +test expr-old-23.7 {double quotes} { + list [catch {expr {"a[error Testing]bc"}} msg] $msg +} {1 Testing} +test expr-old-23.8 {double quotes} { + list [catch {expr {"12398712938788234-1298379" != ""}} msg] $msg +} {0 1} + +# Numbers in various bases. + +test expr-old-24.1 {numbers in different bases} {expr 0x20} 32 +test expr-old-24.2 {numbers in different bases} {expr 015} 13 + +# Conversions between various data types. + +test expr-old-25.1 {type conversions} {expr 2+2.5} 4.5 +test expr-old-25.2 {type conversions} {expr 2.5+2} 4.5 +test expr-old-25.3 {type conversions} {expr 2-2.5} -0.5 +test expr-old-25.4 {type conversions} {expr 2/2.5} 0.8 +test expr-old-25.5 {type conversions} {expr 2>2.5} 0 +test expr-old-25.6 {type conversions} {expr 2.5>2} 1 +test expr-old-25.7 {type conversions} {expr 2<2.5} 1 +test expr-old-25.8 {type conversions} {expr 2>=2.5} 0 +test expr-old-25.9 {type conversions} {expr 2<=2.5} 1 +test expr-old-25.10 {type conversions} {expr 2==2.5} 0 +test expr-old-25.11 {type conversions} {expr 2!=2.5} 1 +test expr-old-25.12 {type conversions} {expr 2>"ab"} 0 +test expr-old-25.13 {type conversions} {expr {2>" "}} 1 +test expr-old-25.14 {type conversions} {expr {"24.1a" > 24.1}} 1 +test expr-old-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0 +test expr-old-25.16 {type conversions} {expr 2+2.5} 4.5 +test expr-old-25.17 {type conversions} {expr 2+2.5} 4.5 +test expr-old-25.18 {type conversions} {expr 2.0e2} 200.0 +test expr-old-25.19 {type conversions} {expr 2.0e15} 2e+15 +test expr-old-25.20 {type conversions} {expr 10.0} 10.0 + +# Various error conditions. + +test expr-old-26.1 {error conditions} { + list [catch {expr 2+"a"} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-old-26.2 {error conditions} { + list [catch {expr 2+4*} msg] $msg +} {1 {syntax error in expression "2+4*"}} +test expr-old-26.3 {error conditions} { + list [catch {expr 2+4*(} msg] $msg +} {1 {syntax error in expression "2+4*("}} +catch {unset _non_existent_} +test expr-old-26.4 {error conditions} { + list [catch {expr 2+$_non_existent_} msg] $msg +} {1 {can't read "_non_existent_": no such variable}} +set a xx +test expr-old-26.5 {error conditions} { + list [catch {expr {2+$a}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-old-26.6 {error conditions} { + list [catch {expr {2+[set a]}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-old-26.7 {error conditions} { + list [catch {expr {2+(4}} msg] $msg +} {1 {syntax error in expression "2+(4"}} +test expr-old-26.8 {error conditions} { + list [catch {expr 2/0} msg] $msg $errorCode +} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} +test expr-old-26.9 {error conditions} { + list [catch {expr 2%0} msg] $msg $errorCode +} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} +test expr-old-26.10 {error conditions} { + list [catch {expr 2.0/0.0} msg] $msg $errorCode +} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} +test expr-old-26.11 {error conditions} { + list [catch {expr 2#} msg] $msg +} {1 {syntax error in expression "2#"}} +test expr-old-26.12 {error conditions} { + list [catch {expr a.b} msg] $msg +} {1 {syntax error in expression "a.b"}} +test expr-old-26.13 {error conditions} { + list [catch {expr {"a"/"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "/"}} +test expr-old-26.14 {error conditions} { + list [catch {expr 2:3} msg] $msg +} {1 {syntax error in expression "2:3"}} +test expr-old-26.15 {error conditions} { + list [catch {expr a@b} msg] $msg +} {1 {syntax error in expression "a@b"}} +test expr-old-26.16 {error conditions} { + list [catch {expr a[b} msg] $msg +} {1 {missing close-bracket or close-brace}} +test expr-old-26.17 {error conditions} { + list [catch {expr a`b} msg] $msg +} {1 {syntax error in expression "a`b"}} +test expr-old-26.18 {error conditions} { + list [catch {expr \"a\"\{b} msg] $msg +} {1 {missing close-brace}} +test expr-old-26.19 {error conditions} { + list [catch {expr a} msg] $msg +} {1 {syntax error in expression "a"}} +test expr-old-26.20 {error conditions} { + list [catch expr msg] $msg +} {1 {wrong # args: should be "expr arg ?arg ...?"}} + +# Cancelled evaluation. + +test expr-old-27.1 {cancelled evaluation} { + set a 1 + expr {0&&[set a 2]} + set a +} 1 +test expr-old-27.2 {cancelled evaluation} { + set a 1 + expr {1||[set a 2]} + set a +} 1 +test expr-old-27.3 {cancelled evaluation} { + set a 1 + expr {0?[set a 2]:1} + set a +} 1 +test expr-old-27.4 {cancelled evaluation} { + set a 1 + expr {1?2:[set a 2]} + set a +} 1 +catch {unset x} +test expr-old-27.5 {cancelled evaluation} { + list [catch {expr {[info exists x] && $x}} msg] $msg +} {0 0} +test expr-old-27.6 {cancelled evaluation} { + list [catch {expr {0 && [concat $x]}} msg] $msg +} {0 0} +test expr-old-27.7 {cancelled evaluation} { + set one 1 + list [catch {expr {1 || 1/$one}} msg] $msg +} {0 1} +test expr-old-27.8 {cancelled evaluation} { + list [catch {expr {1 || -"string"}} msg] $msg +} {0 1} +test expr-old-27.9 {cancelled evaluation} { + list [catch {expr {1 || ("string" * ("x" && "y"))}} msg] $msg +} {0 1} +test expr-old-27.10 {cancelled evaluation} { + set x -1.0 + list [catch {expr {($x > 0) ? round(log($x)) : 0}} msg] $msg +} {0 0} +test expr-old-27.11 {cancelled evaluation} { + list [catch {expr {0 && foo}} msg] $msg +} {1 {syntax error in expression "0 && foo"}} +test expr-old-27.12 {cancelled evaluation} { + list [catch {expr {0 ? 1 : foo}} msg] $msg +} {1 {syntax error in expression "0 ? 1 : foo"}} + +# Tcl_ExprBool as used in "if" statements + +test expr-old-28.1 {Tcl_ExprBoolean usage} { + set a 1 + if {2} {set a 2} + set a +} 2 +test expr-old-28.2 {Tcl_ExprBoolean usage} { + set a 1 + if {0} {set a 2} + set a +} 1 +test expr-old-28.3 {Tcl_ExprBoolean usage} { + set a 1 + if {1.2} {set a 2} + set a +} 2 +test expr-old-28.4 {Tcl_ExprBoolean usage} { + set a 1 + if {-1.1} {set a 2} + set a +} 2 +test expr-old-28.5 {Tcl_ExprBoolean usage} { + set a 1 + if {0.0} {set a 2} + set a +} 1 +test expr-old-28.6 {Tcl_ExprBoolean usage} { + set a 1 + if {"YES"} {set a 2} + set a +} 2 +test expr-old-28.7 {Tcl_ExprBoolean usage} { + set a 1 + if {"no"} {set a 2} + set a +} 1 +test expr-old-28.8 {Tcl_ExprBoolean usage} { + set a 1 + if {"true"} {set a 2} + set a +} 2 +test expr-old-28.9 {Tcl_ExprBoolean usage} { + set a 1 + if {"fAlse"} {set a 2} + set a +} 1 +test expr-old-28.10 {Tcl_ExprBoolean usage} { + set a 1 + if {"on"} {set a 2} + set a +} 2 +test expr-old-28.11 {Tcl_ExprBoolean usage} { + set a 1 + if {"Off"} {set a 2} + set a +} 1 +test expr-old-28.12 {Tcl_ExprBool usage} { + list [catch {if {"abc"} {}} msg] $msg +} {1 {expected boolean value but got "abc"}} +test expr-old-28.13 {Tcl_ExprBool usage} { + list [catch {if {"ogle"} {}} msg] $msg +} {1 {expected boolean value but got "ogle"}} +test expr-old-28.14 {Tcl_ExprBool usage} { + list [catch {if {"o"} {}} msg] $msg +} {1 {expected boolean value but got "o"}} + +# Operands enclosed in braces + +test expr-old-29.1 {braces} {expr {{abc}}} abc +test expr-old-29.2 {braces} {expr {{00010}}} 8 +test expr-old-29.3 {braces} {expr {{3.1200000}}} 3.12 +test expr-old-29.4 {braces} {expr {{a{b}{1 {2 3}}c}}} "a{b}{1 {2 3}}c" +test expr-old-29.5 {braces} { + list [catch {expr "\{abc"} msg] $msg +} {1 {missing close-brace}} + +# Very long values + +test expr-old-30.1 {long values} { + set a "0000 1111 2222 3333 4444" + set a "$a | $a | $a | $a | $a" + set a "$a || $a || $a || $a || $a" + expr {$a} +} {0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444} +test expr-old-30.2 {long values} { + set a "000000000000000000000000000000" + set a "$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a${a}5" + expr $a +} 5 + +# Expressions spanning multiple arguments + +test expr-old-31.1 {multiple arguments to expr command} { + expr 4 + ( 6 *12) -3 +} 73 +test expr-old-31.2 {multiple arguments to expr command} { + list [catch {expr 2 + (3 + 4} msg] $msg +} {1 {syntax error in expression "2 + (3 + 4"}} +test expr-old-31.3 {multiple arguments to expr command} { + list [catch {expr 2 + 3 +} msg] $msg +} {1 {syntax error in expression "2 + 3 +"}} +test expr-old-31.4 {multiple arguments to expr command} { + list [catch {expr 2 + 3 )} msg] $msg +} {1 {syntax error in expression "2 + 3 )"}} + +# Math functions + +test expr-old-32.1 {math functions in expressions} { + format %.6g [expr acos(0.5)] +} {1.0472} +test expr-old-32.2 {math functions in expressions} { + format %.6g [expr asin(0.5)] +} {0.523599} +test expr-old-32.3 {math functions in expressions} { + format %.6g [expr atan(1.0)] +} {0.785398} +test expr-old-32.4 {math functions in expressions} { + format %.6g [expr atan2(2.0, 2.0)] +} {0.785398} +test expr-old-32.5 {math functions in expressions} { + format %.6g [expr ceil(1.999)] +} {2} +test expr-old-32.6 {math functions in expressions} { + format %.6g [expr cos(.1)] +} {0.995004} +test expr-old-32.7 {math functions in expressions} { + format %.6g [expr cosh(.1)] +} {1.005} +test expr-old-32.8 {math functions in expressions} { + format %.6g [expr exp(1.0)] +} {2.71828} +test expr-old-32.9 {math functions in expressions} { + format %.6g [expr floor(2.000)] +} {2} +test expr-old-32.10 {math functions in expressions} { + format %.6g [expr floor(2.001)] +} {2} +test expr-old-32.11 {math functions in expressions} { + format %.6g [expr fmod(7.3, 3.2)] +} {0.9} +test expr-old-32.12 {math functions in expressions} { + format %.6g [expr hypot(3.0, 4.0)] +} {5} +test expr-old-32.13 {math functions in expressions} { + format %.6g [expr log(2.8)] +} {1.02962} +test expr-old-32.14 {math functions in expressions} { + format %.6g [expr log10(2.8)] +} {0.447158} +test expr-old-32.15 {math functions in expressions} { + format %.6g [expr pow(2.1, 3.1)] +} {9.97424} +test expr-old-32.16 {math functions in expressions} { + format %.6g [expr sin(.1)] +} {0.0998334} +test expr-old-32.17 {math functions in expressions} { + format %.6g [expr sinh(.1)] +} {0.100167} +test expr-old-32.18 {math functions in expressions} { + format %.6g [expr sqrt(2.0)] +} {1.41421} +test expr-old-32.19 {math functions in expressions} { + format %.6g [expr tan(0.8)] +} {1.02964} +test expr-old-32.20 {math functions in expressions} { + format %.6g [expr tanh(0.8)] +} {0.664037} +test expr-old-32.21 {math functions in expressions} { + format %.6g [expr abs(-1.8)] +} {1.8} +test expr-old-32.22 {math functions in expressions} { + expr abs(10.0) +} {10.0} +test expr-old-32.23 {math functions in expressions} { + format %.6g [expr abs(-4)] +} {4} +test expr-old-32.24 {math functions in expressions} { + format %.6g [expr abs(66)] +} {66} + +# The following test is different for 32-bit versus 64-bit architectures. + +if {0x80000000 > 0} { + test expr-old-32.25 {math functions in expressions} {nonPortable} { + list [catch {expr abs(0x8000000000000000)} msg] $msg + } {1 {integer value too large to represent}} +} else { + test expr-old-32.25 {math functions in expressions} {nonPortable} { + list [catch {expr abs(0x80000000)} msg] $msg + } {1 {integer value too large to represent}} +} + +test expr-old-32.26 {math functions in expressions} { + expr double(1) +} {1.0} +test expr-old-32.27 {math functions in expressions} { + expr double(1.1) +} {1.1} +test expr-old-32.28 {math functions in expressions} { + expr int(1) +} {1} +test expr-old-32.29 {math functions in expressions} { + expr int(1.4) +} {1} +test expr-old-32.30 {math functions in expressions} { + expr int(1.6) +} {1} +test expr-old-32.31 {math functions in expressions} { + expr int(-1.4) +} {-1} +test expr-old-32.32 {math functions in expressions} { + expr int(-1.6) +} {-1} +test expr-old-32.33 {math functions in expressions} { + list [catch {expr int(1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-old-32.34 {math functions in expressions} { + list [catch {expr int(-1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-old-32.35 {math functions in expressions} { + expr round(1.49) +} {1} +test expr-old-32.36 {math functions in expressions} { + expr round(1.51) +} {2} +test expr-old-32.37 {math functions in expressions} { + expr round(-1.49) +} {-1} +test expr-old-32.38 {math functions in expressions} { + expr round(-1.51) +} {-2} +test expr-old-32.39 {math functions in expressions} { + list [catch {expr round(1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-old-32.40 {math functions in expressions} { + list [catch {expr round(-1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-old-32.41 {math functions in expressions} { + list [catch {expr pow(1.0 + 3.0 - 2, .8 * 5)} msg] $msg +} {0 16.0} +test expr-old-32.42 {math functions in expressions} { + list [catch {expr hypot(5*.8,3)} msg] $msg +} {0 5.0} +if $gotT1 { + test expr-old-32.43 {math functions in expressions} { + expr 2*T1() + } 246 + test expr-old-32.44 {math functions in expressions} { + expr T2()*3 + } 1035 +} +test expr-old-32.45 {math functions in expressions} { + expr (0 <= rand()) && (rand() < 1) +} {1} +test expr-old-32.46 {math functions in expressions} { + list [catch {expr rand(24)} msg] $msg +} {1 {syntax error in expression "rand(24)"}} +test expr-old-32.47 {math functions in expressions} { + list [catch {expr srand()} msg] $msg +} {1 {syntax error in expression "srand()"}} +test expr-old-32.48 {math functions in expressions} { + list [catch {expr srand(3.79)} msg] $msg +} {1 {can't use floating-point value as argument to srand}} +test expr-old-32.49 {math functions in expressions} { + list [catch {expr srand("")} msg] $msg +} {1 {can't use non-numeric string as argument to srand}} +test expr-old-32.50 {math functions in expressions} { + set result [expr round(srand(12345) * 1000)] + for {set i 0} {$i < 10} {incr i} { + lappend result [expr round(rand() * 1000)] + } + set result +} {97 834 948 36 12 51 766 585 914 784 333} +test expr-old-32.51 {math functions in expressions} { + list [catch {expr {srand([lindex "6ty" 0])}} msg] $msg +} {1 {can't use non-numeric string as argument to srand}} + +test expr-old-33.1 {conversions and fancy args to math functions} { + expr hypot ( 3 , 4 ) +} 5.0 +test expr-old-33.2 {conversions and fancy args to math functions} { + expr hypot ( (2.0+1.0) , 4 ) +} 5.0 +test expr-old-33.3 {conversions and fancy args to math functions} { + expr hypot ( 3 , (3.0 + 1.0) ) +} 5.0 +test expr-old-33.4 {conversions and fancy args to math functions} { + format %.6g [expr cos(acos(0.1))] +} 0.1 + +test expr-old-34.1 {errors in math functions} { + list [catch {expr func_2(1.0)} msg] $msg +} {1 {unknown math function "func_2"}} +test expr-old-34.2 {errors in math functions} { + list [catch {expr func|(1.0)} msg] $msg +} {1 {syntax error in expression "func|(1.0)"}} +test expr-old-34.3 {errors in math functions} { + list [catch {expr {hypot("a b", 2.0)}} msg] $msg +} {1 {argument to math function didn't have numeric value}} +test expr-old-34.4 {errors in math functions} { + list [catch {expr hypot(1.0 2.0)} msg] $msg +} {1 {syntax error in expression "hypot(1.0 2.0)"}} +test expr-old-34.5 {errors in math functions} { + list [catch {expr hypot(1.0, 2.0} msg] $msg +} {1 {syntax error in expression "hypot(1.0, 2.0"}} +test expr-old-34.6 {errors in math functions} { + list [catch {expr hypot(1.0 ,} msg] $msg +} {1 {syntax error in expression "hypot(1.0 ,"}} +test expr-old-34.7 {errors in math functions} { + list [catch {expr hypot(1.0)} msg] $msg +} {1 {too few arguments for math function}} +test expr-old-34.8 {errors in math functions} { + list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg +} {1 {too many arguments for math function}} +test expr-old-34.9 {errors in math functions} { + list [catch {expr acos(-2.0)} msg] $msg $errorCode +} {1 {domain error: argument not in valid range} {ARITH DOMAIN {domain error: argument not in valid range}}} +test expr-old-34.10 {errors in math functions} {nonPortable} { + list [catch {expr pow(-3, 1000001)} msg] $msg $errorCode +} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} +test expr-old-34.11 {errors in math functions} { + list [catch {expr pow(3, 1000001)} msg] $msg $errorCode +} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} +test expr-old-34.12 {errors in math functions} { + list [catch {expr -14.0*exp(100000)} msg] $msg $errorCode +} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} +test expr-old-34.13 {errors in math functions} { + list [catch {expr int(1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test expr-old-34.14 {errors in math functions} { + list [catch {expr int(-1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test expr-old-34.15 {errors in math functions} { + list [catch {expr round(1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test expr-old-34.16 {errors in math functions} { + list [catch {expr round(-1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +if $gotT1 { + test expr-old-34.17 {errors in math functions} { + list [catch {expr T1(4)} msg] $msg + } {1 {syntax error in expression "T1(4)"}} +} + +test expr-old-36.1 {ExprLooksLikeInt procedure} { + list [catch {expr 0289} msg] $msg +} {1 {syntax error in expression "0289"}} +test expr-old-36.2 {ExprLooksLikeInt procedure} { + set x 0289 + list [catch {expr {$x+1}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-old-36.3 {ExprLooksLikeInt procedure} { + list [catch {expr 0289.1} msg] $msg +} {0 289.1} +test expr-old-36.4 {ExprLooksLikeInt procedure} { + set x 0289.1 + list [catch {expr {$x+1}} msg] $msg +} {0 290.1} +test expr-old-36.5 {ExprLooksLikeInt procedure} { + set x { +22} + list [catch {expr {$x+1}} msg] $msg +} {0 23} +test expr-old-36.6 {ExprLooksLikeInt procedure} { + set x { -22} + list [catch {expr {$x+1}} msg] $msg +} {0 -21} +test expr-old-36.7 {ExprLooksLikeInt procedure} {nonPortable unixOnly} { + list [catch {expr nan} msg] $msg +} {1 {domain error: argument not in valid range}} +test expr-old-36.8 {ExprLooksLikeInt procedure} { + list [catch {expr 78e1} msg] $msg +} {0 780.0} +test expr-old-36.9 {ExprLooksLikeInt procedure} { + list [catch {expr 24E1} msg] $msg +} {0 240.0} +test expr-old-36.10 {ExprLooksLikeInt procedure} {nonPortable unixOnly} { + list [catch {expr 78e} msg] $msg +} {1 {syntax error in expression "78e"}} + +test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if no error} { + testexprlong +} {This is a result: 5} + +test expr-old-38.1 {Verify Tcl_ExprString's basic operation} { + list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \ + [catch {testexprstring "1+"} msg] $msg +} {5 10.2 1 {syntax error in expression "1+"}} + + +# Special test for Pentium arithmetic bug of 1994: + +if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} { + puts "Warning: this machine contains a defective Pentium processor" + puts "that performs arithmetic incorrectly. I recommend that you" + puts "call Intel customer service immediately at 1-800-628-8686" + puts "to request a replacement processor." +} diff --git a/tests/expr.test b/tests/expr.test new file mode 100644 index 0000000..3c4779f --- /dev/null +++ b/tests/expr.test @@ -0,0 +1,670 @@ +# Commands covered: expr +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# 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: @(#) expr.test 1.39 97/11/03 16:04:47 + +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 +} {quoted string doesn't terminate properly} +test expr-1.7 {TclCompileExprCmd: expression word in braces} { + expr {-0005} +} -5 +test expr-1.8 {TclCompileExprCmd: expression word in braces} { + expr {{-0x1234}} +} -4660 +test expr-1.9 {TclCompileExprCmd: expression word in braces} { + catch {expr {-0005}foo} msg + set msg +} {argument word in braces doesn't terminate properly} +test expr-1.10 {TclCompileExprCmd: other expression word in braces} { + expr 4*[llength "6 2"] +} 8 +test expr-1.11 {TclCompileExprCmd: expression word terminated by ;} { + expr 4*[llength "6 2"]; +} 8 +test expr-1.12 {TclCompileExprCmd: inlined expr (in "catch") inside other catch} { + set a xxx + catch { + # Might not be a number + set a [expr 10*$a] + } +} 1 +test expr-1.13 {TclCompileExprCmd: second level of substitutions in expr not in braces with single var reference} { + set a xxx + set x 27; set bool {$x}; if $bool {set a foo} + set a +} foo +test expr-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} {unixOnly nonPortable} { + puts "Note: doing test expr-3.7 which can take several minutes to run" + hello_world +} {Hello world} +catch {unset xxx} +test expr-3.8 {CompileCondExpr: long arms & nested cond exprs} {unixOnly nonPortable} { + puts "Note: doing test expr-3.8 which can take several minutes to run" + do_twelve_days +} 2358 +catch {unset xxx} + +test expr-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1 +test expr-4.2 {CompileLorExpr: error in land expr} { + catch {expr x&&3} msg + set msg +} {syntax error in expression "x&&3"} +test expr-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1 +test expr-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1 +test expr-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1 +test expr-4.6 {CompileLorExpr: error compiling lor arm} { + catch {expr 2**3||4.0} msg + set msg +} {syntax error in expression "2**3||4.0"} +test expr-4.7 {CompileLorExpr: error compiling lor arm} { + catch {expr 1.3||2**3} msg + set msg +} {syntax error in expression "1.3||2**3"} +test expr-4.8 {CompileLorExpr: error compiling lor arms} { + list [catch {expr {"a"||"b"}} msg] $msg +} {1 {expected boolean value but got "a"}} +test expr-4.9 {CompileLorExpr: long lor arm} { + set a "abcdefghijkl" + set i 7 + expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} +} 1 + +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 ) + (parsing index for array "a") + 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 or close-brace + while compiling +"set i" + 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 executing +"expr sinh::(2.0)"} +test expr-14.28 {CompilePrimaryExpr: subexpression primary} { + expr 2+(3*4) +} 14 +test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} { + catch {expr 2+(3*[set])} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + while compiling +"expr 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 executing +"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 executing +"expr @"} + +test expr-15.1 {CompileMathFuncCall: missing parenthesis} { + catch {expr sinh2.0)} msg + set errorInfo +} {syntax error in expression "sinh2.0)" + while executing +"expr sinh2.0)"} +test expr-15.2 {CompileMathFuncCall: unknown math function} { + catch {expr whazzathuh(1)} msg + set errorInfo +} {unknown math function "whazzathuh" + while executing +"expr whazzathuh(1)"} +test expr-15.3 {CompileMathFuncCall: too many arguments} { + catch {expr sin(1,2,3)} msg + set errorInfo +} {too many arguments for math function + while executing +"expr sin(1,2,3)"} +test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} { + catch {expr sin()} msg + set errorInfo +} {syntax error in expression "sin()" + while executing +"expr sin()"} +test expr-15.5 {CompileMathFuncCall: too few arguments} { + catch {expr pow(1)} msg + set errorInfo +} {too few arguments for math function + while executing +"expr pow(1)"} +test expr-15.6 {CompileMathFuncCall: missing ')'} { + catch {expr sin(1} msg + set errorInfo +} {syntax error in expression "sin(1" + while executing +"expr sin(1"} +if $gotT1 { + test expr-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 diff --git a/tests/fCmd.test b/tests/fCmd.test new file mode 100644 index 0000000..ae2b8b0 --- /dev/null +++ b/tests/fCmd.test @@ -0,0 +1,2102 @@ +# This file tests the tclFCmd.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) fCmd.test 1.33 97/11/03 15:58:08 +# + +if {[string compare test [info procs test]] == 1} then {source defs} + +set platform [testgetplatform] + +if {$user == "root"} { + puts "Skipping fCmd tests. They depend on not being able to write to" + puts "certain directories. It would be too dangerous to run them as root." + return +} + +if {"[info commands testchmod]" != "testchmod"} { + puts "Skipping fCmd tests. This application does not seem to have the" + puts "testchmod command that is needed to run these tests." + return +} + +proc createfile {file {string a}} { + set f [open $file w] + puts -nonewline $f $string + close $f + return $string +} + +# +# checkcontent -- +# +# Ensures that file "file" contains only the string "matchString" +# returns 0 if the file does not exist, or has a different content +# +proc checkcontent {file matchString} { + if {[catch { + set f [open $file] + set fileString [read $f] + close $f + }]} { + return 0 + } + return [string match $matchString $fileString] +} + +proc openup {path} { + testchmod 777 $path + if {[file isdirectory $path]} { + catch { + foreach p [glob [file join $path *]] { + openup $p + } + } + } +} + +proc cleanup {args} { + foreach p ". $args" { + set x "" + catch { + set x [glob [file join $p tf*] [file join $p td*]] + } + foreach file $x { + if {[catch {file delete -force -- $file}]} { + openup $file + file delete -force -- $file + } + } + } +} + +proc contents {file} { + set f [open $file r] + set r [read $f] + close $f + set r +} + +set testConfig(NT) 0 +set testConfig(95) 0 + +switch $tcl_platform(os) { + "Windows NT" {set testConfig(NT) 1} + "Windows 95" {set testConfig(95) 1} +} + +set testConfig(fileSharing) 0 +set testConfig(notFileSharing) 1 + +if {$tcl_platform(platform) == "macintosh"} { + catch {file delete -force foo.dir} + file mkdir foo.dir + if {[catch {file attributes foo.dir -readonly 1}] == 0} { + set testConfig(fileSharing) 1 + set testConfig(notFileSharing) 0 + } + file delete -force foo.dir +} + +set testConfig(xdev) 0 + +if {$tcl_platform(platform) == "unix"} { + if {[catch {set m1 [exec df .]; set m2 [exec df /tmp]}] == 0} { + set m1 [string range $m1 0 [expr [string first " " $m1]-1]] + set m2 [string range $m2 0 [expr [string first " " $m2]-1]] + if {$m1 != "" && $m2 != "" && $m1 != $m2 && [file exists $m1] && [file exists $m2]} { + set testConfig(xdev) 1 + } + } +} + +set root [lindex [file split [pwd]] 0] + +# A really long file name +# length of long is 1216 chars, which should be greater than any static +# buffer or allowable filename. + +set long "abcdefghihjllmnopqrstuvwxyz01234567890" +append long $long +append long $long +append long $long +append long $long +append long $long + +test fCmd-1.1 {TclFileRenameCmd} { + cleanup + createfile tf1 + file rename tf1 tf2 + glob tf* +} {tf2} + +test fCmd-2.1 {TclFileCopyCmd} { + cleanup + createfile tf1 + file copy tf1 tf2 + lsort [glob tf*] +} {tf1 tf2} + +test fCmd-3.1 {FileCopyRename: FileForceOption fails} { + list [catch {file rename -xyz} msg] $msg +} {1 {bad option "-xyz": should be -force or --}} +test fCmd-3.2 {FileCopyRename: not enough args} { + list [catch {file rename xyz} msg] $msg +} {1 {wrong # args: should be "file rename ?options? source ?source ...? target"}} +test fCmd-3.3 {FileCopyRename: Tcl_TranslateFileName fails} { + list [catch {file rename xyz ~nonexistantuser} msg] $msg +} {1 {user "nonexistantuser" doesn't exist}} +test fCmd-3.4 {FileCopyRename: Tcl_TranslateFileName passes} { + cleanup + list [catch {file copy tf1 ~} msg] $msg +} {1 {error copying "tf1": no such file or directory}} +test fCmd-3.5 {FileCopyRename: target doesn't exist: stat(target) != 0} { + cleanup + list [catch {file rename tf1 tf2 tf3} msg] $msg +} {1 {error renaming: target "tf3" is not a directory}} +test fCmd-3.6 {FileCopyRename: target tf3 is not a directory: !S_ISDIR(target)} { + cleanup + createfile tf3 + list [catch {file rename tf1 tf2 tf3} msg] $msg +} {1 {error renaming: target "tf3" is not a directory}} +test fCmd-3.7 {FileCopyRename: target exists & is directory} { + cleanup + file mkdir td1 + createfile tf1 tf1 + file rename tf1 td1 + contents [file join td1 tf1] +} {tf1} +test fCmd-3.8 {FileCopyRename: too many arguments: argc - i > 2} { + cleanup + list [catch {file rename tf1 tf2 tf3} msg] $msg +} {1 {error renaming: target "tf3" is not a directory}} +test fCmd-3.9 {FileCopyRename: too many arguments: argc - i > 2} { + cleanup + list [catch {file copy -force -- tf1 tf2 tf3} msg] $msg +} {1 {error copying: target "tf3" is not a directory}} +test fCmd-3.10 {FileCopyRename: just 2 arguments} { + cleanup + createfile tf1 tf1 + file rename tf1 tf2 + contents tf2 +} {tf1} +test fCmd-3.11 {FileCopyRename: just 2 arguments} { + cleanup + createfile tf1 tf1 + file rename -force -force -- tf1 tf2 + contents tf2 +} {tf1} +test fCmd-3.12 {FileCopyRename: move each source: 1 source} { + cleanup + createfile tf1 tf1 + file mkdir td1 + file rename tf1 td1 + contents [file join td1 tf1] +} {tf1} +test fCmd-3.13 {FileCopyRename: move each source: multiple sources} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + createfile tf3 tf3 + createfile tf4 tf4 + file mkdir td1 + file rename tf1 tf2 tf3 tf4 td1 + list [contents [file join td1 tf1]] [contents [file join td1 tf2]] \ + [contents [file join td1 tf3]] [contents [file join td1 tf4]] +} {tf1 tf2 tf3 tf4} +test fCmd-3.14 {FileCopyRename: FileBasename fails} { + cleanup + file mkdir td1 + list [catch {file rename ~nonexistantuser td1} msg] $msg +} {1 {user "nonexistantuser" doesn't exist}} +test fCmd-3.15 {FileCopyRename: source[0] == '\0'} {unixOrPc} { + cleanup + file mkdir td1 + list [catch {file rename / td1} msg] $msg +} {1 {error renaming "/" to "td1": file already exists}} +test fCmd-3.16 {FileCopyRename: break on first error} { + cleanup + createfile tf1 + createfile tf2 + createfile tf3 + createfile tf4 + file mkdir td1 + createfile [file join td1 tf3] + list [catch {file rename tf1 tf2 tf3 tf4 td1} msg] $msg +} [subst {1 {error renaming "tf3" to "[file join td1 tf3]": file already exists}}] + +test fCmd-4.1 {TclFileMakeDirsCmd: make each dir: 1 dir} { + cleanup + file mkdir td1 + glob td* +} {td1} +test fCmd-4.2 {TclFileMakeDirsCmd: make each dir: multiple dirs} { + cleanup + file mkdir td1 td2 td3 + lsort [glob td*] +} {td1 td2 td3} +test fCmd-4.3 {TclFileMakeDirsCmd: stops on first error} { + cleanup + createfile tf1 + catch {file mkdir td1 td2 tf1 td3 td4} + glob td1 td2 tf1 td3 td4 +} {td1 td2 tf1} +test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName fails} { + cleanup + list [catch {file mkdir ~nonexistantuser} msg] $msg +} {1 {user "nonexistantuser" doesn't exist}} +test fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\0'} { + cleanup + list [catch {file mkdir ""} msg] $msg +} {1 {can't create directory "": no such file or directory}} +test fCmd-4.6 {TclFileMakeDirsCmd: one level deep} { + cleanup + file mkdir td1 + glob td1 +} {td1} +test fCmd-4.7 {TclFileMakeDirsCmd: multi levels deep} { + cleanup + file mkdir [file join td1 td2 td3 td4] + glob td1 [file join td1 td2] +} "td1 [file join td1 td2]" +test fCmd-4.8 {TclFileMakeDirsCmd: already exist: lstat(target) == 0} { + cleanup + file mkdir td1 + set x [file exist td1] + file mkdir td1 + list $x [file exist td1] +} {1 1} +test fCmd-4.9 {TclFileMakeDirsCmd: exists, not dir} { + cleanup + createfile tf1 + list [catch {file mkdir tf1} msg] $msg +} [subst {1 {can't create directory "[file join tf1]": file already exists}}] +test fCmd-4.10 {TclFileMakeDirsCmd: exists, is dir} { + cleanup + file mkdir td1 + set x [file exist td1] + file mkdir td1 + list $x [file exist td1] +} {1 1} +test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {unixOnly} { + cleanup + file mkdir td1/td2/td3 + testchmod 000 td1/td2 + set msg [list [catch {file mkdir td1/td2/td3/td4} msg] $msg] + testchmod 755 td1/td2 + set msg +} {1 {can't create directory "td1/td2/td3": permission denied}} +test fCmd-4.12 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {macOnly} { + cleanup + list [catch {file mkdir nonexistantvolume:} msg] $msg +} {1 {can't create directory "nonexistantvolume:": invalid argument}} +test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} { + cleanup + set x [file exist td1] + file mkdir td1 + list $x [file exist td1] +} {0 1} +test fCmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {unixOnly} { + cleanup + file delete -force foo + file mkdir foo + file attr foo -perm 040000 + set result [list [catch {file mkdir foo/tf1} msg] $msg] + file delete -force foo + set result +} {1 {can't create directory "foo/tf1": permission denied}} +test fCmd-4.15 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {macOnly} { + list [catch {file mkdir ${root}:} msg] $msg +} [subst {1 {can't create directory "${root}:": no such file or directory}}] +test fCmd-4.16 {TclFileMakeDirsCmd: TclpCreateDirectory succeeds} { + cleanup + file mkdir tf1 + file exists tf1 +} {1} + +test fCmd-5.1 {TclFileDeleteCmd: FileForceOption fails} { + list [catch {file delete -xyz} msg] $msg +} {1 {bad option "-xyz": should be -force or --}} +test fCmd-5.2 {TclFileDeleteCmd: not enough args} { + list [catch {file delete -force -force} msg] $msg +} {1 {wrong # args: should be "file delete ?options? file ?file ...?"}} +test fCmd-5.3 {TclFileDeleteCmd: 1 file} { + cleanup + createfile tf1 + createfile tf2 + file mkdir td1 + file delete tf2 + glob tf* td* +} {tf1 td1} +test fCmd-5.4 {TclFileDeleteCmd: multiple files} { + cleanup + createfile tf1 + createfile tf2 + file mkdir td1 + set x [list [file exist tf1] [file exist tf2] [file exist td1]] + file delete tf1 td1 tf2 + lappend x [file exist tf1] [file exist tf2] [file exist tf3] +} {1 1 1 0 0 0} +test fCmd-5.5 {TclFileDeleteCmd: stop at first error} {unixOrPc} { + cleanup + createfile tf1 + createfile tf2 + file mkdir td1 + catch {file delete tf1 td1 $root tf2} + list [file exist tf1] [file exist tf2] [file exist td1] +} {0 1 0} +test fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} { + list [catch {file delete ~nonexistantuser} msg] $msg +} {1 {user "nonexistantuser" doesn't exist}} +test fCmd-5.7 {TclFileDeleteCmd: Tcl_TranslateFileName succeeds} { + catch {file delete ~/tf1} + createfile ~/tf1 + file delete ~/tf1 +} {} +test fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} { + cleanup + set x [file exist tf1] + file delete tf1 + list $x [file exist tf1] +} {0 0} +test fCmd-5.9 {TclFileDeleteCmd: is directory} { + cleanup + file mkdir td1 + file delete td1 + file exist td1 +} {0} +test fCmd-5.10 {TclFileDeleteCmd: TclpRemoveDirectory fails} { + cleanup + file mkdir td1/td2 + list [catch {file delete td1} msg] $msg +} {1 {error deleting "td1": directory not empty}} + +test fCmd-6.1 {CopyRenameOneFile: bad source} { + # can't test this, because it's caught by FileCopyRename +} {} +test fCmd-6.2 {CopyRenameOneFile: bad target} { + # can't test this, because it's caught by FileCopyRename +} {} +test fCmd-6.3 {CopyRenameOneFile: lstat(source) != 0} { + cleanup + list [catch {file rename tf1 tf2} msg] $msg +} {1 {error renaming "tf1": no such file or directory}} +test fCmd-6.4 {CopyRenameOneFile: lstat(source) == 0} { + cleanup + createfile tf1 + file rename tf1 tf2 + glob tf* +} {tf2} +test fCmd-6.5 {CopyRenameOneFile: lstat(target) != 0} { + cleanup + createfile tf1 + file rename tf1 tf2 + glob tf* +} {tf2} +test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly} { + cleanup + file mkdir td1 + testchmod 000 td1 + createfile tf1 + set msg [list [catch {file rename tf1 td1} msg] $msg] + testchmod 755 td1 + set msg +} {1 {error renaming "tf1" to "td1/tf1": permission denied}} +test fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} {95} { + cleanup + createfile tf1 + list [catch {file rename tf1 $long} msg] $msg +} [subst {1 {error renaming "tf1" to "$long": file name too long}}] +test fCmd-6.8 {CopyRenameOneFile: errno != ENOENT} {macOnly} { + cleanup + createfile tf1 + list [catch {file rename tf1 $long} msg] $msg +} [subst {1 {error renaming "tf1" to "$long": file name too long}}] +test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} {unixOnly} { + cleanup + createfile tf1 + file rename tf1 tf2 + glob tf* +} {tf2} +test fCmd-6.10 {CopyRenameOneFile: lstat(target) == 0} { + cleanup + createfile tf1 + createfile tf2 + list [catch {file rename tf1 tf2} msg] $msg +} {1 {error renaming "tf1" to "tf2": file already exists}} +test fCmd-6.11 {CopyRenameOneFile: force == 0} { + cleanup + createfile tf1 + createfile tf2 + list [catch {file rename tf1 tf2} msg] $msg +} {1 {error renaming "tf1" to "tf2": file already exists}} +test fCmd-6.12 {CopyRenameOneFile: force != 0} { + cleanup + createfile tf1 + createfile tf2 + file rename -force tf1 tf2 + glob tf* +} {tf2} +test fCmd-6.13 {CopyRenameOneFile: source is dir, target is file} { + cleanup + file mkdir td1 + file mkdir td2 + createfile [file join td2 td1] + list [catch {file rename -force td1 td2} msg] $msg +} [subst {1 {can't overwrite file "[file join td2 td1]" with directory "td1"}}] +test fCmd-6.14 {CopyRenameOneFile: source is file, target is dir} { + cleanup + createfile tf1 + file mkdir [file join td1 tf1] + list [catch {file rename -force tf1 td1} msg] $msg +} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}] +test fCmd-6.15 {CopyRenameOneFile: TclpRenameFile succeeds} { + cleanup + file mkdir [file join td1 td2] + file mkdir td2 + createfile [file join td2 tf1] + file rename -force td2 td1 + file exists [file join td1 td2 tf1] +} {1} +test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} { + cleanup + file mkdir [file join td1 td2] + createfile [file join td1 td2 tf1] + file mkdir td2 + list [catch {file rename -force td2 td1} msg] $msg +} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}] +test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} {!$testConfig(win32s) || ($root == "C:/")} { + # Don't run this test under Win32s on a drive mounted from an NT + # machine; it causes the NT machine to die. + + cleanup + list [catch {file rename -force $root tf1} msg] $msg +} [subst {1 {error renaming "$root" to "tf1": trying to rename a volume or move a directory into itself}}] +test fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} { + cleanup + file mkdir [file join td1 td2] + createfile [file join td1 td2 tf1] + file mkdir td2 + list [catch {file rename -force td2 td1} msg] $msg +} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}] +test fCmd-6.19 {CopyRenameOneFile: errno == EXDEV} {unixOnly} { + cleanup /tmp + createfile tf1 + file rename tf1 /tmp + glob tf* /tmp/tf1 +} {/tmp/tf1} +test fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} {pcOnly} { + catch {file delete -force c:/tcl8975@ d:/tcl8975@} + file mkdir c:/tcl8975@ + if [catch {file rename c:/tcl8975@ d:/}] { + list d:/tcl8975@ + } else { + set msg [glob c:/tcl8975@ d:/tcl8975@] + file delete -force d:/tcl8975@ + set msg + } +} {d:/tcl8975@} +test fCmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} {unixOnly} { + cleanup /tmp + file mkdir td1 + file rename td1 /tmp + glob td* /tmp/td* +} {/tmp/td1} +test fCmd-6.22 {CopyRenameOneFile: copy/rename: !S_ISDIR(source)} {unixOnly} { + cleanup /tmp + createfile tf1 + file rename tf1 /tmp + glob tf* /tmp/tf* +} {/tmp/tf1} +test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly xdev} { + cleanup /tmp + file mkdir td1/td2/td3 + exec chmod 000 td1 + set msg [list [catch {file rename td1 /tmp} msg] $msg] + exec chmod 755 td1 + set msg +} {1 {error renaming "td1": permission denied}} +test fCmd-6.24 {CopyRenameOneFile: error uses original name} {unixOnly} { + cleanup + file mkdir ~/td1/td2 + exec chmod 000 [file join [file dirname ~] [file tail ~] td1] + set msg [list [catch {file copy ~/td1 td1} msg] $msg] + exec chmod 755 [file join [file dirname ~] [file tail ~] td1] + file delete -force ~/td1 + set msg +} {1 {error copying "~/td1": permission denied}} +test fCmd-6.25 {CopyRenameOneFile: error uses original name} {unixOnly} { + cleanup + file mkdir td2 + file mkdir ~/td1 + exec chmod 000 [file join [file dirname ~] [file tail ~] td1] + set msg [list [catch {file copy td2 ~/td1} msg] $msg] + exec chmod 755 [file join [file dirname ~] [file tail ~] td1] + file delete -force ~/td1 + set msg +} {1 {error copying "td2" to "~/td1/td2": permission denied}} +test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} {unixOnly} { + cleanup + file mkdir ~/td1/td2 + exec chmod 000 [file join [file dirname ~] [file tail ~] td1 td2] + set msg [list [catch {file copy ~/td1 td1} msg] $msg] + exec chmod 755 [file join [file dirname ~] [file tail ~] td1 td2] + file delete -force ~/td1 + set msg +} "1 {error copying \"~/td1\" to \"td1\": \"[file join [file dirname ~] [file tail ~] td1 td2]\": permission denied}" +test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly xdev} { + cleanup /tmp + file mkdir td1/td2/td3 + file mkdir /tmp/td1 + createfile /tmp/td1/tf1 + list [catch {file rename -force td1 /tmp} msg] $msg +} {1 {error renaming "td1" to "/tmp/td1": file already exists}} +test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly xdev} { + cleanup /tmp + file mkdir td1/td2/td3 + exec chmod 000 td1/td2/td3 + set msg [list [catch {file rename td1 /tmp} msg] $msg] + exec chmod 755 td1/td2/td3 + set msg +} {1 {error renaming "td1" to "/tmp/td1": "td1/td2/td3": permission denied}} +test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} {unixOnly xdev} { + cleanup /tmp + file mkdir td1/td2/td3 + file rename td1 /tmp + glob td* /tmp/td1/t* +} {/tmp/td1/td2} +test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} {unixOnly} { + cleanup + file mkdir foo/bar + file attr foo -perm 040555 + set msg [list [catch {file rename foo/bar /tmp} msg] $msg] + set a1 {1 {can't unlink "foo/bar": permission denied}} + set result [expr {$msg == $a1}] + catch {file delete /tmp/bar} + catch {file attr foo -perm 040777} + catch {file delete -force foo} + set result +} {1} +test fCmd-6.31 {CopyRenameOneFile: TclpDeleteFile passed} {unixOnly xdev} { + catch {cleanup /tmp} + file mkdir /tmp/td1 + createfile /tmp/td1/tf1 + file rename /tmp/td1/tf1 tf1 + list [file exists /tmp/td1/tf1] [file exists tf1] +} {0 1} +test fCmd-6.32 {CopyRenameOneFile: copy} { + cleanup + list [catch {file copy tf1 tf2} msg] $msg +} {1 {error copying "tf1": no such file or directory}} +catch {cleanup /tmp} + +test fCmd-7.1 {FileForceOption: none} { + cleanup + file mkdir [file join tf1 tf2] + list [catch {file delete tf1} msg] $msg +} {1 {error deleting "tf1": directory not empty}} +test fCmd-7.2 {FileForceOption: -force} { + cleanup + file mkdir [file join tf1 tf2] + file delete -force tf1 +} {} +test fCmd-7.3 {FileForceOption: --} { + createfile -tf1 + file delete -- -tf1 +} {} +test fCmd-7.4 {FileForceOption: bad option} { + createfile -tf1 + set msg [list [catch {file delete -tf1} msg] $msg] + file delete -- -tf1 + set msg +} {1 {bad option "-tf1": should be -force or --}} +test fCmd-7.5 {FileForceOption: multiple times through loop} { + createfile -- + createfile -force + file delete -force -force -- -- -force + list [catch {glob -- -- -force} msg] $msg +} {1 {no files matched glob patterns "-- -force"}} + +test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} {unixOnly} { + file mkdir td1 + file attr td1 -perm 040000 + set result [list [catch {file rename ~$user td1} msg] $msg] + file delete -force td1 + set result +} "1 {error renaming \"~$user\" to \"td1/[file tail ~$user]\": permission denied}" + +test fCmd-9.1 {file rename: comprehensive: EACCES} {unixOnly} { + cleanup + file mkdir td1 + file mkdir td2 + file attr td2 -perm 040000 + set result [list [catch {file rename td1 td2/} msg] $msg] + file delete -force td2 + file delete -force td1 + set result +} {1 {error renaming "td1" to "td2/td1": permission denied}} +test fCmd-9.2 {file rename: comprehensive: source doesn't exist} { + cleanup + list [catch {file rename tf1 tf2} msg] $msg +} {1 {error renaming "tf1": no such file or directory}} +test fCmd-9.3 {file rename: comprehensive: file to new name} { + cleanup + createfile tf1 + createfile tf2 + testchmod 444 tf2 + file rename tf1 tf3 + file rename tf2 tf4 + list [lsort [glob tf*]] [file writable tf3] [file writable tf4] +} {{tf3 tf4} 1 0} +test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc} { + cleanup + file mkdir td1 td2 + testchmod 555 td2 + file rename td1 td3 + file rename td2 td4 + list [lsort [glob td*]] [file writable td3] [file writable td4] +} {{td3 td4} 1 0} +test fCmd-9.5 {file rename: comprehensive: file to self} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + testchmod 444 tf2 + file rename -force tf1 tf1 + file rename -force tf2 tf2 + list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2] +} {tf1 tf2 1 0} +test fCmd-9.6 {file rename: comprehensive: dir to self} {unixOrPc} { + cleanup + file mkdir td1 + file mkdir td2 + testchmod 555 td2 + file rename -force td1 . + file rename -force td2 . + list [lsort [glob td*]] [file writable td1] [file writable td2] +} {{td1 td2} 1 0} +test fCmd-9.7 {file rename: comprehensive: file to existing file} { + cleanup + createfile tf1 + createfile tf2 + createfile tfs1 + createfile tfs2 + createfile tfs3 + createfile tfs4 + createfile tfd1 + createfile tfd2 + createfile tfd3 + createfile tfd4 + testchmod 444 tfs3 + testchmod 444 tfs4 + testchmod 444 tfd2 + testchmod 444 tfd4 + set msg [list [catch {file rename tf1 tf2} msg] $msg] + file rename -force tfs1 tfd1 + file rename -force tfs2 tfd2 + file rename -force tfs3 tfd3 + file rename -force tfs4 tfd4 + list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] +} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0} +test fCmd-9.8 {file rename: comprehensive: dir to empty dir} { + # Under unix, you can rename a read-only directory, but you can't + # move it into another directory. + + cleanup + file mkdir td1 + file mkdir [file join td2 td1] + file mkdir tds1 + file mkdir tds2 + file mkdir tds3 + file mkdir tds4 + file mkdir [file join tdd1 tds1] + file mkdir [file join tdd2 tds2] + file mkdir [file join tdd3 tds3] + file mkdir [file join tdd4 tds4] + if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { + testchmod 555 tds3 + testchmod 555 tds4 + } + if {$tcl_platform(platform) != "macintosh"} { + testchmod 555 [file join tdd2 tds2] + testchmod 555 [file join tdd4 tds4] + } + set msg [list [catch {file rename td1 td2} msg] $msg] + file rename -force tds1 tdd1 + file rename -force tds2 tdd2 + file rename -force tds3 tdd3 + file rename -force tds4 tdd4 + if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { + set w3 [file writable [file join tdd3 tds3]] + set w4 [file writable [file join tdd4 tds4]] + } else { + set w3 0 + set w4 0 + } + list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \ + [file writable [file join tdd2 tds2]] $w3 $w4 +} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}] +test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} { + cleanup + file mkdir tds1 + file mkdir tds2 + file mkdir [file join tdd1 tds1 xxx] + file mkdir [file join tdd2 tds2 xxx] + if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { + testchmod 555 tds2 + } + set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg] + set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg] + if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { + set w2 [file writable tds2] + } else { + set w2 0 + } + list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2 +} [subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}] +test fCmd-9.10 {file rename: comprehensive: file to new name and dir} { + cleanup + createfile tf1 + createfile tf2 + file mkdir td1 + testchmod 444 tf2 + file rename tf1 [file join td1 tf3] + file rename tf2 [file join td1 tf4] + list [catch {glob tf*}] [lsort [glob [file join td1 t*]]] \ + [file writable [file join td1 tf3]] [file writable [file join td1 tf4]] +} [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}] +test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} { + cleanup + file mkdir td1 + file mkdir td2 + file mkdir td3 + if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { + testchmod 555 td2 + } + file rename td1 [file join td3 td3] + file rename td2 [file join td3 td4] + if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { + set w4 [file writable [file join td3 td4]] + } else { + set w4 0 + } + list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \ + [file writable [file join td3 td3]] $w4 +} [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}] +test fCmd-9.12 {file rename: comprehensive: target exists} { + cleanup + file mkdir [file join td1 td2] [file join td2 td1] + if {$tcl_platform(platform) != "macintosh"} { + testchmod 555 [file join td2 td1] + } + file mkdir [file join td3 td4] [file join td4 td3] + file rename -force td3 td4 + set msg [list [file exists td3] [file exists [file join td4 td3 td4]] \ + [catch {file rename td1 td2} msg] $msg] + if {$tcl_platform(platform) != "macintosh"} { + testchmod 755 [file join td2 td1] + } + set msg +} [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}] +test fCmd-9.13 {file rename: comprehensive: can't overwrite target} { + cleanup + file mkdir [file join td1 td2] [file join td2 td1 td4] + list [catch {file rename -force td1 td2} msg] $msg +} [subst {1 {error renaming "td1" to "[file join td2 td1]": file already exists}}] +test fCmd-9.14 {file rename: comprehensive: dir into self} { + cleanup + file mkdir td1 + list [glob td*] [list [catch {file rename td1 td1} msg] $msg] +} [subst {td1 {1 {error renaming "td1" to "[file join td1 td1]": trying to rename a volume or move a directory into itself}}}] +test fCmd-9.15 {file rename: comprehensive: source and target incompatible} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {file rename -force td1 tf1} msg] $msg +} {1 {can't overwrite file "tf1" with directory "td1"}} +test fCmd-9.16 {file rename: comprehensive: source and target incompatible} { + cleanup + file mkdir td1/tf1 + createfile tf1 + list [catch {file rename -force tf1 td1} msg] $msg +} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}] + +test fCmd-10.1 {file copy: comprehensive: source doesn't exist} { + cleanup + list [catch {file copy tf1 tf2} msg] $msg +} {1 {error copying "tf1": no such file or directory}} +test fCmd-10.2 {file copy: comprehensive: file to new name} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + testchmod 444 tf2 + file copy tf1 tf3 + file copy tf2 tf4 + list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4] +} {{tf1 tf2 tf3 tf4} tf1 tf2 1 0} +test fCmd-10.3 {file copy: comprehensive: dir to new name} {unixOrPc} { + cleanup + file mkdir [file join td1 tdx] + file mkdir [file join td2 tdy] + testchmod 555 td2 + file copy td1 td3 + file copy td2 td4 + set msg [list [lsort [glob td*]] [glob [file join td3 t*]] \ + [glob [file join td4 t*]] [file writable td3] [file writable td4]] + if {$tcl_platform(platform) != "macintosh"} { + testchmod 755 td2 + testchmod 755 td4 + } + set msg +} [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0}] +test fCmd-10.4 {file copy: comprehensive: file to existing file} { + cleanup + createfile tf1 + createfile tf2 + createfile tfs1 + createfile tfs2 + createfile tfs3 + createfile tfs4 + createfile tfd1 + createfile tfd2 + createfile tfd3 + createfile tfd4 + testchmod 444 tfs3 + testchmod 444 tfs4 + testchmod 444 tfd2 + testchmod 444 tfd4 + set msg [list [catch {file copy tf1 tf2} msg] $msg] + file copy -force tfs1 tfd1 + file copy -force tfs2 tfd2 + file copy -force tfs3 tfd3 + file copy -force tfs4 tfd4 + list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] +} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0} +test fCmd-10.5 {file copy: comprehensive: dir to empty dir} { + cleanup + file mkdir td1 + file mkdir [file join td2 td1] + file mkdir tds1 + file mkdir tds2 + file mkdir tds3 + file mkdir tds4 + file mkdir [file join tdd1 tds1] + file mkdir [file join tdd2 tds2] + file mkdir [file join tdd3 tds3] + file mkdir [file join tdd4 tds4] + if {$tcl_platform(platform) != "macintosh"} { + testchmod 555 tds3 + testchmod 555 tds4 + testchmod 555 [file join tdd2 tds2] + testchmod 555 [file join tdd4 tds4] + } + set a1 [list [catch {file copy td1 td2} msg] $msg] + set a2 [list [catch {file copy -force tds1 tdd1} msg] $msg] + set a3 [catch {file copy -force tds2 tdd2}] + set a4 [catch {file copy -force tds3 tdd3}] + set a5 [catch {file copy -force tds4 tdd4}] + list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 +} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}] +test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} {unixOrPc} { + cleanup + file mkdir tds1 + file mkdir tds2 + file mkdir [file join tdd1 tds1 xxx] + file mkdir [file join tdd2 tds2 xxx] + testchmod 555 tds2 + set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg] + set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg] + list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2] +} [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}] +test fCmd-10.7 {file rename: comprehensive: file to new name and dir} { + cleanup + createfile tf1 + createfile tf2 + file mkdir td1 + testchmod 444 tf2 + file copy tf1 [file join td1 tf3] + file copy tf2 [file join td1 tf4] + list [lsort [glob tf*]] [lsort [glob [file join td1 t*]]] \ + [file writable [file join td1 tf3]] [file writable [file join td1 tf4]] +} [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}] +test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} {unixOrPc} { + cleanup + file mkdir td1 + file mkdir td2 + file mkdir td3 + testchmod 555 td2 + file copy td1 [file join td3 td3] + file copy td2 [file join td3 td4] + list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \ + [file writable [file join td3 td3]] [file writable [file join td3 td4]] +} [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}] +test fCmd-10.9 {file copy: comprehensive: source and target incompatible} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {file copy -force td1 tf1} msg] $msg +} {1 {can't overwrite file "tf1" with directory "td1"}} +test fCmd-10.10 {file copy: comprehensive: source and target incompatible} { + cleanup + file mkdir [file join td1 tf1] + createfile tf1 + list [catch {file copy -force tf1 td1} msg] $msg +} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}] +cleanup + +# old tests + +test fCmd-11.1 {TclFileRenameCmd: -- option } { + catch {file delete -force -- -tfa1} + set s [createfile -tfa1] + file rename -- -tfa1 tfa2 + set result [expr [checkcontent tfa2 $s] && ![file exists -tfa1]] + file delete tfa2 + set result +} {1} + +test fCmd-11.2 {TclFileRenameCmd: bad option } { + catch {file delete -force -- tfa1} + set s [createfile tfa1] + set r1 [catch {file rename -x tfa1 tfa2}] + set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]] + file delete tfa1 + set result +} {1} + +test fCmd-11.3 {TclFileRenameCmd: bad \# args} { + catch {file rename -- } +} {1} + +test fCmd-11.4 {TclFileRenameCmd: target filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file rename tfa ~/foobar }] + set env(HOME) $temp + set result + } {1} + +test fCmd-11.5 {TclFileRenameCmd: more than one source and target is not a directory} { + catch {file delete -force -- tfa1 tfa2 tfa3} + createfile tfa1 + createfile tfa2 + createfile tfa3 + set result [catch {file rename tfa1 tfa2 tfa3}] + file delete tfa1 tfa2 tfa3 + set result +} {1} + +test fCmd-11.6 {TclFileRenameCmd: : single file into directory } { + catch {file delete -force -- tfa1 tfad} + set s [createfile tfa1] + file mkdir tfad + file rename tfa1 tfad + set result [expr [checkcontent tfad/tfa1 $s] && ![file exists tfa1]] + file delete -force tfad + set result +} {1} + +test fCmd-11.7 {TclFileRenameCmd: : multiple files into directory } { + catch {file delete -force -- tfa1 tfa2 tfad} + set s1 [createfile tfa1 ] + set s2 [createfile tfa2 ] + file mkdir tfad + file rename tfa1 tfa2 tfad + set r1 [checkcontent tfad/tfa1 $s1] + set r2 [checkcontent tfad/tfa2 $s2] + + set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfa2]] + + file delete -force tfad + set result +} {1} + +test fCmd-11.8 {TclFileRenameCmd: error renaming file to directory } { + catch {file delete -force -- tfa tfad} + set s [createfile tfa ] + file mkdir tfad + file mkdir tfad/tfa + set r1 [catch {file rename tfa tfad}] + set r2 [checkcontent tfa $s] + set r3 [file isdir tfad] + set result [expr $r1 && $r2 && $r3 ] + file delete -force tfa tfad + set result +} {1} + +# +# Coverage tests for renamefile() ; +# +test fCmd-12.1 {renamefile: source filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file rename ~/tfa1 tfa2}] + set env(HOME) $temp + set result +} {1} + +test fCmd-12.2 {renamefile: src filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set s [createfile tfa1] + file mkdir tfad + set result [catch {file rename tfa1 ~/tfa2 tfad}] + set env(HOME) $temp + file delete -force tfad + set result +} {1} + +test fCmd-12.3 {renamefile: stat failing on source} { + catch {file delete -force -- tfa1 tfa2} + set r1 [catch {file rename tfa1 tfa2}] + expr {$r1 && ![file exists tfa1] && ![file exists tfa2]} +} {1} + +test fCmd-12.4 {renamefile: error renaming file to directory } { + catch {file delete -force -- tfa tfad} + set s1 [createfile tfa ] + file mkdir tfad + file mkdir tfad/tfa + set r1 [catch {file rename tfa tfad}] + set r2 [checkcontent tfa $s1] + set r3 [file isdir tfad/tfa] + set result [expr $r1 && $r2 && $r3] + file delete -force tfa tfad + set result +} {1} + +test fCmd-12.5 {renamefile: error renaming directory to file } { + catch {file delete -force -- tfa tfad} + file mkdir tfa + file mkdir tfad + set s [createfile tfad/tfa] + set r1 [catch {file rename tfa tfad}] + set r2 [checkcontent tfad/tfa $s] + set r3 [file isdir tfad] + set r4 [file isdir tfa] + set result [expr $r1 && $r2 && $r3 && $r4 ] + file delete -force tfa tfad + set result +} {1} + +test fCmd-12.6 {renamefile: TclRenameFile succeeding } { + catch {file delete -force -- tfa1 tfa2} + set s [createfile tfa1] + file rename tfa1 tfa2 + set result [expr [checkcontent tfa2 $s] && ![file exists tfa1]] + file delete tfa2 + set result +} {1} + +test fCmd-12.7 {renamefile: renaming directory into offspring} { + catch {file delete -force -- tfad} + file mkdir tfad + file mkdir tfad/dir + set result [catch {file rename tfad tfad/dir}] + file delete -force tfad + set result +} {1} + +test fCmd-12.8 {renamefile: generic error } {unixOnly} { + catch {file delete -force -- tfa} + file mkdir tfa + file mkdir tfa/dir + exec chmod 555 tfa + set result [catch {file rename tfa/dir tfa2}] + exec chmod 777 tfa + file delete -force tfa + set result +} {1} + + +test fCmd-12.9 {renamefile: moving a file across volumes } {unixOnly} { + catch {file delete -force -- tfa /tmp/tfa} + set s [createfile tfa ] + file rename tfa /tmp + set result [expr [checkcontent /tmp/tfa $s] && ![file exists tfa]] + file delete /tmp/tfa + set result +} {1} + +test fCmd-12.10 {renamefile: moving a directory across volumes } {unixOnly} { + catch {file delete -force -- tfad /tmp/tfad} + file mkdir tfad + set s [createfile tfad/a ] + file rename tfad /tmp + set restul [expr [checkcontent /tmp/tfad/a $s] && ![file exists tfad]] + file delete -force /tmp/tfad + set result +} {1} + +# +# Coverage tests for TclCopyFilesCmd() +# +test fCmd-13.1 {TclCopyFilesCmd: -force option } { + catch {file delete -force -- tfa1} + set s [createfile tfa1] + file copy -force tfa1 tfa2 + set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]] + file delete tfa1 tfa2 + set result +} {1} + +test fCmd-13.2 {TclCopyFilesCmd: -- option } { + catch {file delete -force -- tfa1} + set s [createfile -tfa1] + file copy -- -tfa1 tfa2 + set result [expr [checkcontent tfa2 $s] && [checkcontent -tfa1 $s]] + file delete -- -tfa1 tfa2 + set result +} {1} + +test fCmd-13.3 {TclCopyFilesCmd: bad option } { + catch {file delete -force -- tfa1} + set s [createfile tfa1] + set r1 [catch {file copy -x tfa1 tfa2}] + set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]] + file delete tfa1 + set result +} {1} + +test fCmd-13.4 {TclCopyFilesCmd: bad \# args} { + catch {file copy -- } +} {1} + +test fCmd-13.5 {TclCopyFilesCmd: target filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file copy tfa ~/foobar }] + set env(HOME) $temp + set result + } {1} + +test fCmd-13.6 {TclCopyFilesCmd: more than one source and target is not a directory} { + catch {file delete -force -- tfa1 tfa2 tfa3} + createfile tfa1 + createfile tfa2 + createfile tfa3 + set result [catch {file copy tfa1 tfa2 tfa3}] + file delete tfa1 tfa2 tfa3 + set result +} {1} + +test fCmd-13.7 {TclCopyFilesCmd: : single file into directory } { + catch {file delete -force -- tfa1 tfad} + set s [createfile tfa1] + file mkdir tfad + file copy tfa1 tfad + set result [expr [checkcontent tfad/tfa1 $s] && [checkcontent tfa1 $s]] + file delete -force tfad tfa1 + set result +} {1} + +test fCmd-13.8 {TclCopyFilesCmd: : multiple files into directory } { + catch {file delete -force -- tfa1 tfa2 tfad} + set s1 [createfile tfa1 ] + set s2 [createfile tfa2 ] + file mkdir tfad + file copy tfa1 tfa2 tfad + set r1 [checkcontent tfad/tfa1 $s1] + set r2 [checkcontent tfad/tfa2 $s2] + set r3 [checkcontent tfa1 $s1] + set r4 [checkcontent tfa2 $s2] + set result [expr $r1 && $r2 && $r3 && $r4 ] + + file delete -force tfad tfa1 tfa2 + set result +} {1} + +test fCmd-13.9 {TclCopyFilesCmd: error copying file to directory } { + catch {file delete -force -- tfa tfad} + set s [createfile tfa ] + file mkdir tfad + file mkdir tfad/tfa + set r1 [catch {file copy tfa tfad}] + set r2 [expr [checkcontent tfa $s] && [file isdir tfad/tfa]] + set r3 [file isdir tfad] + set result [expr $r1 && $r2 && $r3 ] + file delete -force tfa tfad + set result +} {1} + +# +# Coverage tests for copyfile() +# +test fCmd-14.1 {copyfile: source filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file copy ~/tfa1 tfa2}] + set env(HOME) $temp + set result +} {1} + +test fCmd-14.2 {copyfile: dst filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set s [createfile tfa1] + file mkdir tfad + set r1 [catch {file copy tfa1 ~/tfa2 tfad}] + set result [expr $r1 && [checkcontent tfad/tfa1 $s]] + set env(HOME) $temp + file delete -force tfa1 tfad + set result +} {1} + +test fCmd-14.3 {copyfile: stat failing on source} { + catch {file delete -force -- tfa1 tfa2} + set r1 [catch {file copy tfa1 tfa2}] + expr $r1 && ![file exists tfa1] && ![file exists tfa2] +} {1} + +test fCmd-14.4 {copyfile: error copying file to directory } { + catch {file delete -force -- tfa tfad} + set s1 [createfile tfa ] + file mkdir tfad + file mkdir tfad/tfa + set r1 [catch {file copy tfa tfad}] + set r2 [checkcontent tfa $s1] + set r3 [file isdir tfad] + set r4 [file isdir tfad/tfa] + set result [expr $r1 && $r2 && $r3 && $r4 ] + file delete -force tfa tfad + set result +} {1} + + test fCmd-14.5 {copyfile: error copying directory to file } { + catch {file delete -force -- tfa tfad} + file mkdir tfa + file mkdir tfad + set s [createfile tfad/tfa] + set r1 [catch {file copy tfa tfad}] + set r2 [checkcontent tfad/tfa $s] + set r3 [file isdir tfad] + set r4 [file isdir tfa] + set result [expr $r1 && $r2 && $r3 && $r4 ] + file delete -force tfa tfad + set result +} {1} + +test fCmd-14.6 {copyfile: copy file succeeding } { + catch {file delete -force -- tfa tfa2} + set s [createfile tfa] + file copy tfa tfa2 + set result [expr [checkcontent tfa $s] && [checkcontent tfa2 $s]] + file delete tfa tfa2 + set result +} {1} + +test fCmd-14.7 {copyfile: copy directory succeeding } { + catch {file delete -force -- tfa tfa2} + file mkdir tfa + set s [createfile tfa/file] + file copy tfa tfa2 + set result [expr [checkcontent tfa/file $s] && [checkcontent tfa2/file $s]] + file delete -force tfa tfa2 + set result +} {1} + +test fCmd-14.8 {copyfile: copy directory failing } {unixOnly} { + catch {file delete -force -- tfa} + file mkdir tfa/dir/a/b/c + exec chmod 000 tfa/dir + set r1 [catch {file copy tfa tfa2}] + exec chmod 777 tfa/dir + set result $r1 + file delete -force tfa tfa2 + set result +} {1} + +# +# Coverage tests for TclMkdirCmd() +# +test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file mkdir ~/tfa}] + set env(HOME) $temp + set result +} {1} +# +# Can Tcl_SplitPath return argc == 0? If so them we need a +# test for that code. +# +test fCmd-15.2 {TclMakeDirsCmd - one directory } { + catch {file delete -force -- tfa} + file mkdir tfa + set result [file isdirectory tfa] + file delete tfa + set result +} {1} + +test fCmd-15.3 {TclMakeDirsCmd: - two directories } { + catch {file delete -force -- tfa1 tfa2} + file mkdir tfa1 tfa2 + set result [expr [file isdirectory tfa1] && [file isdirectory tfa2]] + file delete tfa1 tfa2 + set result +} {1} + +test fCmd-15.4 {TclMakeDirsCmd - stat failing } {unixOnly} { + catch {file delete -force -- tfa} + file mkdir tfa + createfile tfa/file + exec chmod 000 tfa + set result [catch {file mkdir tfa/file}] + exec chmod 777 tfa + file delete -force tfa + set result +} {1} + +test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep } { + catch {file delete -force -- tfa} + file mkdir tfa/a/b/c + set result [file isdir tfa/a/b/c] + file delete -force tfa + set result +} {1} + + +test fCmd-15.6 {TclMakeDirsCmd: - trying to overwrite a file } { + catch {file delete -force -- tfa} + set s [createfile tfa] + set r1 [catch {file mkdir tfa}] + set r2 [file isdir tfa] + set r3 [file exists tfa] + set result [expr $r1 && !$r2 && $r3 && [checkcontent tfa $s]] + file delete tfa + set result +} {1} + +test fCmd-15.7 {TclMakeDirsCmd - making several directories } { + catch {file delete -force -- tfa1 tfa2} + file mkdir tfa1 tfa2/a/b/c + set result [expr [file isdir tfa1] && [file isdir tfa2/a/b/c]] + file delete -force tfa1 tfa2 + set result +} {1} + +test fCmd-15.8 {TclFileMakeDirsCmd: trying to create an existing dir} { + file mkdir tfa + file mkdir tfa + set result [file isdir tfa] + file delete tfa + set result +} {1} + + +# Coverage tests for TclDeleteFilesCommand() +test fCmd-16.1 { test the -- argument } { + catch {file delete -force -- tfa} + createfile tfa + file delete -- tfa + file exists tfa +} {0} + +test fCmd-16.2 { test the -force and -- arguments } { + catch {file delete -force -- tfa} + createfile tfa + file delete -force -- tfa + file exists tfa +} {0} + +test fCmd-16.3 { test bad option } { + catch {file delete -force -- tfa} + createfile tfa + set result [catch {file delete -dog tfa}] + file delete tfa + set result +} {1} + +test fCmd-16.4 { test not enough args } { + catch {file delete} +} {1} + +test fCmd-16.5 { test not enough args with options } { + catch {file delete --} +} {1} + +test fCmd-16.6 {delete: source filename translation failing} { + global env + set temp $env(HOME) + unset env(HOME) + set result [catch {file delete ~/tfa}] + set env(HOME) $temp + set result +} {1} + +test fCmd-16.7 {remove a non-empty directory without -force } { + catch {file delete -force -- tfa} + file mkdir tfa + createfile tfa/a + set result [catch {file delete tfa }] + file delete -force tfa + set result +} {1} + +test fCmd-16.8 {remove a normal file } { + catch {file delete -force -- tfa} + file mkdir tfa + createfile tfa/a + set result [catch {file delete tfa }] + file delete -force tfa + set result +} {1} + +test fCmd-16.9 {error while deleting file } {unixOnly} { + catch {file delete -force -- tfa} + file mkdir tfa + createfile tfa/a + exec chmod 555 tfa + set result [catch {file delete tfa/a }] + ####### + ####### If any directory in a tree that is being removed does not + ####### have write permission, the process will fail! + ####### This is also the case with "rm -rf" + ####### + exec chmod 777 tfa + file delete -force tfa + set result +} {1} + +test fCmd-16.10 {deleting multiple files } { + catch {file delete -force -- tfa1 tfa2} + createfile tfa1 + createfile tfa2 + file delete tfa1 tfa2 + expr ![file exists tfa1] && ![file exists tfa2] +} {1} + +test fCmd-16.11 { TclFileDeleteCmd: removing a nonexistant file} { + catch {file delete -force -- tfa} + file delete tfa + set result 1 +} {1} + +# More coverage tests for mkpath() + test fCmd-17.1 {mkdir stat failing on target but not ENOENT } {unixOnly} { + catch {file delete -force -- tfa1} + file mkdir tfa1 + exec chmod 555 tfa1 + set result [catch {file mkdir tfa1/tfa2}] + exec chmod 777 tfa1 + file delete -force tfa1 + set result +} {1} + +test fCmd-17.2 {mkdir several levels deep - relative } { + catch {file delete -force -- tfa} + file mkdir tfa/a/b + set result [file isdir tfa/a/b ] + file delete tfa/a/b tfa/a tfa + set result +} {1} + +test fCmd-17.3 {mkdir several levels deep - absolute } { + catch {file delete -force -- tfa} + set f [file join [pwd] tfa a ] + file mkdir $f + set result [file isdir $f ] + file delete $f [file join [pwd] tfa] + set result +} {1} + +# +# Functionality tests for TclFileRenameCmd() +# + +test fCmd-18.1 {TclFileRenameCmd: rename (first form) in the same directory} { + catch {file delete -force -- tfad} + file mkdir tfad/dir + cd tfad/dir + set s [createfile foo ] + file rename foo bar + file rename bar ./foo + file rename ./foo bar + file rename ./bar ./foo + file rename foo ../dir/bar + file rename ../dir/bar ./foo + file rename ../../tfad/dir/foo ../../tfad/dir/bar + file rename [file join [pwd] bar] foo + file rename foo [file join [pwd] bar] + set result [expr [checkcontent bar $s] && ![file exists foo]] + cd ../.. + file delete -force tfad + set result +} {1} + +test fCmd-18.2 {TclFileRenameCmd: single dir to nonexistant } { + catch {file delete -force -- tfa1 tfa2} + file mkdir tfa1 + file rename tfa1 tfa2 + set result [expr [file exists tfa2] && ![file exists tfa1]] + file delete tfa2 + set result +} {1} + +test fCmd-18.3 {TclFileRenameCmd: mixed dirs and files into directory } { + catch {file delete -force -- tfa1 tfad1 tfad2} + set s [createfile tfa1 ] + file mkdir tfad1 tfad2 + file rename tfa1 tfad1 tfad2 + set r1 [checkcontent tfad2/tfa1 $s] + set r2 [file isdir tfad2/tfad1] + set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfad1]] + file delete tfad2/tfa1 + file delete -force tfad2 + set result +} {1} + +test fCmd-18.4 {TclFileRenameCmd: attempt to replace non-dir with dir } { + catch {file delete -force -- tfa tfad} + set s [createfile tfa ] + file mkdir tfad + set r1 [catch {file rename tfad tfa}] + set r2 [checkcontent tfa $s] + set r3 [file isdir tfad] + set result [expr $r1 && $r2 && $r3 ] + file delete tfa tfad + set result +} {1} + +test fCmd-18.5 {TclFileRenameCmd: attempt to replace dir with non-dir } { + catch {file delete -force -- tfa tfad} + set s [createfile tfa ] + file mkdir tfad/tfa + set r1 [catch {file rename tfa tfad}] + set r2 [checkcontent tfa $s] + set r3 [file isdir tfad/tfa] + set result [expr $r1 && $r2 && $r3 ] + file delete -force tfa tfad + set result +} {1} + +# +# On Windows there is no easy way to determine if two files are the same +# +test fCmd-18.6 {TclFileRenameCmd: rename a file to itself} {macOrUnix} { + catch {file delete -force -- tfa} + set s [createfile tfa] + set r1 [catch {file rename tfa tfa}] + set result [expr $r1 && [checkcontent tfa $s]] + file delete tfa + set result +} {1} + +test fCmd-18.7 {TclFileRenameCmd: rename dir on top of another empty dir w/o -force} { + catch {file delete -force -- tfa tfad} + file mkdir tfa tfad/tfa + set r1 [catch {file rename tfa tfad}] + set result [expr $r1 && [file isdir tfa]] + file delete -force tfa tfad + set result +} {1} + +test fCmd-18.8 {TclFileRenameCmd: rename dir on top of another empty dir w/ -force} { + catch {file delete -force -- tfa tfad} + file mkdir tfa tfad/tfa + file rename -force tfa tfad + set result [expr ![file isdir tfa]] + file delete -force tfad + set result +} {1} + +test fCmd-18.9 {TclFileRenameCmd: rename dir on top of a non-empty dir w/o -force} { + catch {file delete -force -- tfa tfad} + file mkdir tfa tfad/tfa/file + set r1 [catch {file rename tfa tfad}] + set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]] + file delete -force tfa tfad + set result +} {1} + +test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} { + catch {file delete -force -- tfa tfad} + file mkdir tfa tfad/tfa/file + set r1 [catch {file rename -force tfa tfad}] + set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]] + file delete -force tfa tfad + set result +} {1} + +test fCmd-18.11 {TclFileRenameCmd: rename a non-existant file} { + catch {file delete -force -- tfa1} + set r1 [catch {file rename tfa1 tfa2}] + set result [expr $r1 && ![file exists tfa1] && ![file exists tfa2]] +} {1} + +test fCmd-18.12 {TclFileRenameCmd : rename a symbolic link to file} {unixOnly} { + catch {file delete -force -- tfa1 tfa2 tfa3} + + set s [createfile tfa1] + exec ln -s tfa1 tfa2 + file rename tfa2 tfa3 + set t [file type tfa3] + set result [expr { $t == "link" }] + file delete tfa1 tfa3 + set result +} {1} + +test fCmd-18.13 {TclFileRenameCmd : rename a symbolic link to dir} {unixOnly} { + catch {file delete -force -- tfa1 tfa2 tfa3} + + file mkdir tfa1 + exec ln -s tfa1 tfa2 + file rename tfa2 tfa3 + set t [file type tfa3] + set result [expr { $t == "link" }] + file delete tfa1 tfa3 + set result +} {1} + +test fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} {unixOnly} { + catch {file delete -force -- tfa1 tfa2 tfa3} + + file mkdir tfa1/a/b/c/d + file mkdir tfa2 + set f [file join [pwd] tfa1/a/b] + set f2 [file join [pwd] {tfa2/b alias}] + exec ln -s $f $f2 + file rename {tfa2/b alias/c} tfa3 + set r1 [file isdir tfa3] + set r2 [file exists tfa1/a/b/c] + set result [expr $r1 && !$r2] + file delete -force tfa1 tfa2 tfa3 + set result +} {1} + +test fCmd-18.15 {TclFileRenameCmd : rename a file to a symlink dir} {unixOnly} { + catch {file delete -force -- tfa1 tfa2 tfalink} + + file mkdir tfa1 + set s [createfile tfa2] + exec ln -s tfa1 tfalink + + file rename tfa2 tfalink + set result [checkcontent tfa1/tfa2 $s ] + file delete -force tfa1 tfalink + set result +} {1} + +test fCmd-18.16 {TclFileRenameCmd : rename a dangling symlink} {unixOnly} { + catch {file delete -force -- tfa1 tfalink} + + file mkdir tfa1 + exec ln -s tfa1 tfalink + file delete tfa1 + file rename tfalink tfa2 + set result [expr [string compare [file type tfa2] "link"] == 0] + file delete tfa2 + set result +} {1} + + +# +# Coverage tests for TclUnixRmdir +# +test fCmd-19.1 { remove empty directory } { + catch {file delete -force -- tfa} + file mkdir tfa + file delete tfa + file exists tfa +} {0} + +test fCmd-19.2 { rmdir error besides EEXIST} {unixOnly} { + catch {file delete -force -- tfa} + file mkdir tfa + file mkdir tfa/a + exec chmod 555 tfa + set result [catch {file delete tfa/a}] + exec chmod 777 tfa + file delete -force tfa + set result +} {1} + +test fCmd-19.3 { recursive remove } { + catch {file delete -force -- tfa} + file mkdir tfa + file mkdir tfa/a + file delete -force tfa + file exists tfa +} {0} + +# +# TclUnixDeleteFile and TraversalDelete are covered by tests from the +# TclDeleteFilesCmd suite +# +# + +# +# Coverage tests for TraverseUnixTree(), called from TclDeleteFilesCmd +# + +test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } {unixOnly} { + catch {file delete -force -- tfa} + file mkdir tfa + file mkdir tfa/a + exec chmod 000 tfa/a + set result [catch {file delete -force tfa}] + exec chmod 777 tfa/a + file delete -force tfa + set result +} {1} + + +# +# Feature testing for TclCopyFilesCmd +# +test fCmd-21.1 {copy : single file to nonexistant } { + catch {file delete -force -- tfa1 tfa2} + set s [createfile tfa1] + file copy tfa1 tfa2 + set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]] + file delete tfa1 tfa2 + set result +} {1} + +test fCmd-21.2 {copy : single dir to nonexistant } { + catch {file delete -force -- tfa1 tfa2} + file mkdir tfa1 + file copy tfa1 tfa2 + set result [expr [file isdir tfa2] && [file isdir tfa1]] + file delete tfa1 tfa2 + set result +} {1} + +test fCmd-21.3 {copy : single file into directory } { + catch {file delete -force -- tfa1 tfad} + set s [createfile tfa1] + file mkdir tfad + file copy tfa1 tfad + set result [expr [checkcontent tfad/tfa1 $s] && [checkcontent tfa1 $s]] + file delete -force tfa1 tfad + set result +} {1} + +test fCmd-21.4 {copy : more than one source and target is not a directory} { + catch {file delete -force -- tfa1 tfa2 tfa3} + createfile tfa1 + createfile tfa2 + createfile tfa3 + set result [catch {file copy tfa1 tfa2 tfa3}] + file delete tfa1 tfa2 tfa3 + set result +} {1} + +test fCmd-21.5 {copy : multiple files into directory } { + catch {file delete -force -- tfa1 tfa2 tfad} + set s1 [createfile tfa1 ] + set s2 [createfile tfa2 ] + file mkdir tfad + file copy tfa1 tfa2 tfad + set r1 [checkcontent tfad/tfa1 $s1] + set r2 [checkcontent tfad/tfa2 $s2] + set r3 [checkcontent tfa1 $s1] + set r4 [checkcontent tfa2 $s2] + set result [expr $r1 && $r2 && $r3 && $r4] + file delete -force tfa1 tfa2 tfad + set result +} {1} + +test fCmd-21.6 {copy : mixed dirs and files into directory } {notFileSharing} { + catch {file delete -force -- tfa1 tfad1 tfad2} + set s [createfile tfa1 ] + file mkdir tfad1 tfad2 + file copy tfa1 tfad1 tfad2 + set r1 [checkcontent [file join tfad2 tfa1] $s] + set r2 [file isdir [file join tfad2 tfad1]] + set r3 [checkcontent tfa1 $s] + set result [expr $r1 && $r2 && $r3 && [file isdir tfad1]] + file delete -force tfa1 tfad1 tfad2 + set result +} {1} + +test fCmd-21.7 {TclCopyFilesCmd : copy a dangling link } {unixOnly} { + file mkdir tfad1 + exec ln -s tfad1 tfalink + file delete tfad1 + file copy tfalink tfalink2 + set result [string match [file type tfalink2] link] + file delete tfalink tfalink2 + set result +} {1} + +test fCmd-21.8 {TclCopyFilesCmd : copy a link } {unixOnly} { + file mkdir tfad1 + exec ln -s tfad1 tfalink + file copy tfalink tfalink2 + set r1 [file type tfalink] + set r2 [file type tfalink2] + set r3 [file isdir tfad1] + set result [expr {("$r1" == "link" ) && ("$r2" == "link" ) && $r3}] + file delete tfad1 tfalink tfalink2 + set result +} {1} + +test fCmd-21.9 {TclCopyFilesCmd : copy dir with a link in it } {unixOnly} { + file mkdir tfad1 + exec ln -s "[pwd]/tfad1" tfad1/tfalink + file copy tfad1 tfad2 + set result [string match [file type tfad2/tfalink] link] + file delete -force tfad1 tfad2 + set result +} {1} + +test fCmd-21.10 {TclFileCopyCmd: copy dir on top of another empty dir w/o -force} { + catch {file delete -force -- tfa tfad} + file mkdir tfa [file join tfad tfa] + set r1 [catch {file copy tfa tfad}] + set result [expr $r1 && [file isdir tfa]] + file delete -force tfa tfad + set result +} {1} + +test fCmd-21.11 {TclFileCopyCmd: copy dir on top of a dir w/o -force} { + catch {file delete -force -- tfa tfad} + file mkdir tfa [file join tfad tfa file] + set r1 [catch {file copy tfa tfad}] + set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]] + file delete -force tfa tfad + set result +} {1} + +test fCmd-21.12 {TclFileCopyCmd: copy dir on top of a non-empty dir w/ -force} { + catch {file delete -force -- tfa tfad} + file mkdir tfa [file join tfad tfa file] + set r1 [catch {file copy -force tfa tfad}] + set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]] + file delete -force tfa tfad + set result +} {1} + +# +# Coverage testing for TclpRenameFile +# +test fCmd-22.1 { TclpRenameFile : rename and overwrite in a single dir } { + catch {file delete -force -- tfa1 tfa2} + set s [createfile tfa1] + set s2 [createfile tfa2 q] + + set r1 [catch {rename tfa1 tfa2}] + file rename -force tfa1 tfa2 + set result [expr $r1 && [checkcontent tfa2 $s]] + file delete [glob tfa1 tfa2] + set result +} {1} + +test fCmd-22.2 { TclpRenameFile : attempt to overwrite itself } {macOrUnix} { + catch {file delete -force -- tfa1} + set s [createfile tfa1] + file rename -force tfa1 tfa1 + set result [checkcontent tfa1 $s] + file delete tfa1 + set result +} {1} + +test fCmd-22.3 { TclpRenameFile : rename dir to existing dir } { + catch {file delete -force -- d1 tfad} + file mkdir d1 [file join tfad d1] + set r1 [catch {file rename d1 tfad}] + set result [expr $r1 && [file isdir d1] && [file isdir [file join tfad d1]]] + file delete -force d1 tfad + set result +} {1} + +test fCmd-22.4 { TclpRenameFile : rename dir to dir several levels deep } { + catch {file delete -force -- d1 tfad} + file mkdir d1 [file join tfad a b c] + file rename d1 [file join tfad a b c d1] + set result [expr ![file isdir d1] && [file isdir [file join tfad a b c d1]]] + file delete -force [glob d1 tfad] + set result +} {1} + + +# +# TclMacCopyFile needs to be redone. +# +test fCmd-22.5 { TclMacCopyFile : copy and overwrite in a single dir } { + catch {file delete -force -- tfa1 tfa2} + set s [createfile tfa1] + set s2 [createfile tfa2 q] + + set r1 [catch {file copy tfa1 tfa2}] + file copy -force tfa1 tfa2 + set result [expr $r1 && [checkcontent tfa2 $s] && [checkcontent tfa1 $s]] + file delete tfa1 tfa2 + set result +} {1} + +# +# TclMacMkdir - basic cases are covered elsewhere. +# Error cases are not covered. +# + +# +# TclMacRmdir +# Error cases are not covered. +# + +test fCmd-23.1 { TclMacRmdir : trying to remove a nonempty directory } { + catch {file delete -force -- tfad} + + file mkdir [file join tfad dir] + + set result [catch {file delete tfad}] + file delete -force tfad + set result +} {1} + +# +# TclMacDeleteFile +# Error cases are not covered. +# +test fCmd-24.1 { TclMacDeleteFile : deleting a normal file } { + catch {file delete -force -- tfa1} + + createfile tfa1 + file delete tfa1 + file exists tfa1 +} {0} + +# +# TclMacCopyDirectory +# Error cases are not covered. +# +test fCmd-25.1 { TclMacCopyDirectory : copying a normal directory} {notFileSharing} { + catch {file delete -force -- tfad1 tfad2} + + file mkdir [file join tfad1 a b c] + file copy tfad1 tfad2 + set result [expr [file isdir [file join tfad1 a b c]] && [file isdir [file join tfad2 a b c]]] + file delete -force tfad1 tfad2 + set result +} {1} + +test fCmd-25.2 { TclMacCopyDirectory : copying a short path normal directory} {notFileSharing} { + catch {file delete -force -- tfad1 tfad2} + + file mkdir tfad1 + file copy tfad1 tfad2 + set result [expr [file isdir tfad1] && [file isdir tfad2]] + file delete tfad1 tfad2 + set result +} {1} + +test fCmd-25.3 { TclMacCopyDirectory : copying dirs between different dirs} {notFileSharing} { + catch {file delete -force -- tfad1 tfad2} + + file mkdir [file join tfad1 x y z] + file mkdir [file join tfad2 dir] + file copy tfad1 [file join tfad2 dir] + set result [expr [file isdir [file join tfad1 x y z]] && [file isdir [file join tfad2 dir tfad1 x y z]]] + file delete -force tfad1 tfad2 + set result +} {1} + +# +# Functionality tests for TclDeleteFilesCmd +# + +test fCmd-26.1 { TclDeleteFilesCmd : delete symlink} {unixOnly} { + catch {file delete -force -- tfad1 tfad2} + + file mkdir tfad1 + exec ln -s tfad1 tfalink + file delete tfalink + + set r1 [file isdir tfad1] + set r2 [file exists tfalink] + + set result [expr $r1 && !$r2] + file delete tfad1 + set result +} {1} + +test fCmd-26.2 { TclDeleteFilesCmd : delete dir with symlink} {unixOnly} { + catch {file delete -force -- tfad1 tfad2} + + file mkdir tfad1 + file mkdir tfad2 + exec ln -s tfad1 [file join tfad2 link] + file delete -force tfad2 + + set r1 [file isdir tfad1] + set r2 [file exists tfad2] + + set result [expr $r1 && !$r2] + file delete tfad1 + set result +} {1} + +test fCmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly} { + catch {file delete -force -- tfad1 tfad2} + + file mkdir tfad1 + exec ln -s tfad1 tfad2 + file delete tfad1 + file delete tfad2 + + set r1 [file exists tfad1] + set r2 [file exists tfad2] + + set result [expr !$r1 && !$r2] + set result +} {1} + +test fCmd-27.1 {TclFileAttrsCmd - wrong # args} { + list [catch {file attributes a b c d} msg] $msg +} {1 {wrong # args: must be "file attributes name ?option? ?value? ?option value? ..."}} +test fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} { + testsetplatform unix + list [catch {file attributes ~_bad_user} msg] $msg [testsetplatform $platform] +} {1 {user "_bad_user" doesn't exist} {}} +test fCmd-27.3 {TclFileAttrsCmd - all attributes} { + catch {file delete -force -- foo.tmp} + createfile foo.tmp + list [catch {file attributes foo.tmp} msg] [expr {[llength $msg] > 0}] [file delete -force -- foo.tmp] +} {0 1 {}} +test fCmd-27.4 {TclFileAttrsCmd - getting one option} { + catch {file delete -force -- foo.tmp} + createfile foo.tmp + set attrs [file attributes foo.tmp] + list [catch {eval file attributes foo.tmp [lindex $attrs 0]}] [file delete -force -- foo.tmp] +} {0 {}} + +set testConfig(tclGroup) 0 +if {($tcl_platform(platform) == "macintosh") \ + || ($tcl_platform(platform) == "windows")} { + set testConfig(tclGroup) 1 +} elseif {[catch {exec {groups}} groupList] == 0} { + if {[lsearch $groupList tcl] != -1} { + set testConfig(tclGroup) 1 + } +} + +test fCmd-27.5 {TclFileAttrsCmd - setting one option} {tclGroup} { + catch {file delete -force -- foo.tmp} + createfile foo.tmp + set attrs [file attributes foo.tmp] + list [catch {eval file attributes foo.tmp [lrange $attrs 0 1]} msg] $msg [file delete -force -- foo.tmp] +} {0 {} {}} +test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {tclGroup} { + catch {file delete -force -- foo.tmp} + createfile foo.tmp + set attrs [file attributes foo.tmp] + list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp] +} {0 {} {}} + +cleanup diff --git a/tests/fileName.test b/tests/fileName.test new file mode 100644 index 0000000..e0f7260 --- /dev/null +++ b/tests/fileName.test @@ -0,0 +1,1449 @@ +# This file tests the filename manipulation routines. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) fileName.test 1.31 97/08/19 18:45:07 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {[info commands testsetplatform] == {}} { + puts "This application hasn't been compiled with the \"testsetplatform\"" + puts "command, so I can't test the filename conversion procedures." + return +} + +global env +set platform [testgetplatform] + +test filename-1.1 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype / +} absolute +test filename-1.2 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype /foo +} absolute +test filename-1.3 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype foo +} relative +test filename-1.4 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype c:/foo +} relative +test filename-1.5 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype ~ +} absolute +test filename-1.6 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype ~/foo +} absolute +test filename-1.7 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype ~foo +} absolute +test filename-1.8 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype ./~foo +} relative + +test filename-2.1 {Tcl_GetPathType: mac, denerate names} { + testsetplatform mac + file pathtype / +} relative +test filename-2.2 {Tcl_GetPathType: mac, denerate names} { + testsetplatform mac + file pathtype /. +} relative +test filename-2.3 {Tcl_GetPathType: mac, denerate names} { + testsetplatform mac + file pathtype /.. +} relative +test filename-2.4 {Tcl_GetPathType: mac, denerate names} { + testsetplatform mac + file pathtype //.// +} relative +test filename-2.5 {Tcl_GetPathType: mac, denerate names} { + testsetplatform mac + file pathtype //.//../. +} relative +test filename-2.6 {Tcl_GetPathType: mac, tilde names} { + testsetplatform mac + file pathtype ~ +} absolute +test filename-2.7 {Tcl_GetPathType: mac, tilde names} { + testsetplatform mac + file pathtype ~: +} absolute +test filename-2.8 {Tcl_GetPathType: mac, tilde names} { + testsetplatform mac + file pathtype ~:foo +} absolute +test filename-2.9 {Tcl_GetPathType: mac, tilde names} { + testsetplatform mac + file pathtype ~/ +} absolute +test filename-2.10 {Tcl_GetPathType: mac, tilde names} { + testsetplatform mac + file pathtype ~/foo +} absolute +test filename-2.11 {Tcl_GetPathType: mac, unix-style names} { + testsetplatform mac + file pathtype /foo +} absolute +test filename-2.12 {Tcl_GetPathType: mac, unix-style names} { + testsetplatform mac + file pathtype /./foo +} absolute +test filename-2.13 {Tcl_GetPathType: mac, unix-style names} { + testsetplatform mac + file pathtype /..//./foo +} absolute +test filename-2.14 {Tcl_GetPathType: mac, unix-style names} { + testsetplatform mac + file pathtype /foo/bar +} absolute +test filename-2.15 {Tcl_GetPathType: mac, unix-style names} { + testsetplatform mac + file pathtype foo/bar +} relative +test filename-2.16 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype : +} relative +test filename-2.17 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype :foo +} relative +test filename-2.18 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype foo: +} absolute +test filename-2.19 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype foo:bar +} absolute +test filename-2.20 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype :foo:bar +} relative +test filename-2.21 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype ::foo:bar +} relative +test filename-2.22 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype ~foo +} absolute +test filename-2.23 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype :~foo +} relative +test filename-2.24 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype ~foo: +} absolute +test filename-2.25 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype foo/bar: +} absolute +test filename-2.26 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype /foo: +} absolute +test filename-2.27 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype foo +} relative + +test filename-3.1 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype / +} volumerelative +test filename-3.2 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype \\ +} volumerelative +test filename-3.3 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype /foo +} volumerelative +test filename-3.4 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype \\foo +} volumerelative +test filename-3.5 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c:/ +} absolute +test filename-3.6 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c:\\ +} absolute +test filename-3.7 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c:/foo +} absolute +test filename-3.8 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c:\\foo +} absolute +test filename-3.9 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c: +} volumerelative +test filename-3.10 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c:foo +} volumerelative +test filename-3.11 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype foo +} relative +test filename-3.12 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype //foo/bar +} absolute +test filename-3.13 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype ~foo +} absolute +test filename-3.14 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype ~ +} absolute +test filename-3.15 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype ~/foo +} absolute +test filename-3.16 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype ./~foo +} relative + +test filename-4.1 {Tcl_SplitPath: unix} { + testsetplatform unix + file split / +} {/} +test filename-4.2 {Tcl_SplitPath: unix} { + testsetplatform unix + file split /foo +} {/ foo} +test filename-4.3 {Tcl_SplitPath: unix} { + testsetplatform unix + file split /foo/bar +} {/ foo bar} +test filename-4.4 {Tcl_SplitPath: unix} { + testsetplatform unix + file split /foo/bar/baz +} {/ foo bar baz} +test filename-4.5 {Tcl_SplitPath: unix} { + testsetplatform unix + file split foo/bar +} {foo bar} +test filename-4.6 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ./foo/bar +} {. foo bar} +test filename-4.7 {Tcl_SplitPath: unix} { + testsetplatform unix + file split /foo/../././foo/bar +} {/ foo .. . . foo bar} +test filename-4.8 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ../foo/bar +} {.. foo bar} +test filename-4.9 {Tcl_SplitPath: unix} { + testsetplatform unix + file split {} +} {} +test filename-4.10 {Tcl_SplitPath: unix} { + testsetplatform unix + file split . +} {.} +test filename-4.11 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ../ +} {..} +test filename-4.12 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ../.. +} {.. ..} +test filename-4.13 {Tcl_SplitPath: unix} { + testsetplatform unix + file split //foo +} {/ foo} +test filename-4.14 {Tcl_SplitPath: unix} { + testsetplatform unix + file split foo//bar +} {foo bar} +test filename-4.15 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ~foo +} {~foo} +test filename-4.16 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ~foo/~bar +} {~foo ./~bar} +test filename-4.17 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ~foo/~bar/~baz +} {~foo ./~bar ./~baz} +test filename-4.18 {Tcl_SplitPath: unix} { + testsetplatform unix + file split foo/bar~/baz +} {foo bar~ baz} + +test filename-5.1 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:b +} {a: b} +test filename-5.2 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:b:c +} {a: b c} +test filename-5.3 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:b:c: +} {a: b c} +test filename-5.4 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a: +} {a:} +test filename-5.5 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:: +} {a: ::} +test filename-5.6 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a::: +} {a: :: ::} +test filename-5.7 {Tcl_SplitPath: mac} { + testsetplatform mac + file split :a +} {a} +test filename-5.8 {Tcl_SplitPath: mac} { + testsetplatform mac + file split :a:: +} {a ::} +test filename-5.9 {Tcl_SplitPath: mac} { + testsetplatform mac + file split : +} {:} +test filename-5.10 {Tcl_SplitPath: mac} { + testsetplatform mac + file split :: +} {::} +test filename-5.11 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ::: +} {:: ::} +test filename-5.12 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:::b +} {a: :: :: b} +test filename-5.13 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /a:b +} {/a: b} +test filename-5.14 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~: +} {~:} +test filename-5.15 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~/: +} {~/:} +test filename-5.16 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~:foo +} {~: foo} +test filename-5.17 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~/foo +} {~: foo} +test filename-5.18 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~foo: +} {~foo:} +test filename-5.19 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:~foo +} {a: :~foo} +test filename-5.20 {Tcl_SplitPath: mac} { + testsetplatform mac + file split / +} {:/} +test filename-5.21 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:b/c +} {a: :b/c} +test filename-5.22 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /foo +} {foo:} +test filename-5.23 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /a/b +} {a: b} +test filename-5.24 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /a/b/foo +} {a: b foo} +test filename-5.25 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a/b +} {a b} +test filename-5.26 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ./foo/bar +} {: foo bar} +test filename-5.27 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ../foo/bar +} {:: foo bar} +test filename-5.28 {Tcl_SplitPath: mac} { + testsetplatform mac + file split {} +} {} +test filename-5.29 {Tcl_SplitPath: mac} { + testsetplatform mac + file split . +} {:} +test filename-5.30 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ././ +} {: :} +test filename-5.31 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ././. +} {: : :} +test filename-5.32 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ../ +} {::} +test filename-5.33 {Tcl_SplitPath: mac} { + testsetplatform mac + file split .. +} {::} +test filename-5.34 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ../.. +} {:: ::} +test filename-5.35 {Tcl_SplitPath: mac} { + testsetplatform mac + file split //foo +} {foo:} +test filename-5.36 {Tcl_SplitPath: mac} { + testsetplatform mac + file split foo//bar +} {foo bar} +test filename-5.37 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~foo +} {~foo:} +test filename-5.38 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~ +} {~:} +test filename-5.39 {Tcl_SplitPath: mac} { + testsetplatform mac + file split foo +} {foo} +test filename-5.40 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~/ +} {~:} +test filename-5.41 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~foo/~bar +} {~foo: :~bar} +test filename-5.42 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~foo/~bar/~baz +} {~foo: :~bar :~baz} +test filename-5.43 {Tcl_SplitPath: mac} { + testsetplatform mac + file split foo/bar~/baz +} {foo bar~ baz} +test filename-5.44 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a/../b +} {a :: b} +test filename-5.45 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a/../../b +} {a :: :: b} +test filename-5.46 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a/.././../b +} {a :: : :: b} +test filename-5.47 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /../bar +} {bar:} +test filename-5.48 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /./bar +} {bar:} +test filename-5.49 {Tcl_SplitPath: mac} { + testsetplatform mac + file split //.//.././bar +} {bar:} +test filename-5.50 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /.. +} {:/..} +test filename-5.51 {Tcl_SplitPath: mac} { + testsetplatform mac + file split //.//.././ +} {://.//.././} + +test filename-6.1 {Tcl_SplitPath: win} { + testsetplatform win + file split / +} {/} +test filename-6.2 {Tcl_SplitPath: win} { + testsetplatform win + file split /foo +} {/ foo} +test filename-6.3 {Tcl_SplitPath: win} { + testsetplatform win + file split /foo/bar +} {/ foo bar} +test filename-6.4 {Tcl_SplitPath: win} { + testsetplatform win + file split /foo/bar/baz +} {/ foo bar baz} +test filename-6.5 {Tcl_SplitPath: win} { + testsetplatform win + file split foo/bar +} {foo bar} +test filename-6.6 {Tcl_SplitPath: win} { + testsetplatform win + file split ./foo/bar +} {. foo bar} +test filename-6.7 {Tcl_SplitPath: win} { + testsetplatform win + file split /foo/../././foo/bar +} {/ foo .. . . foo bar} +test filename-6.8 {Tcl_SplitPath: win} { + testsetplatform win + file split ../foo/bar +} {.. foo bar} +test filename-6.9 {Tcl_SplitPath: win} { + testsetplatform win + file split {} +} {} +test filename-6.10 {Tcl_SplitPath: win} { + testsetplatform win + file split . +} {.} +test filename-6.11 {Tcl_SplitPath: win} { + testsetplatform win + file split ../ +} {..} +test filename-6.12 {Tcl_SplitPath: win} { + testsetplatform win + file split ../.. +} {.. ..} +test filename-6.13 {Tcl_SplitPath: win} { + testsetplatform win + file split //foo +} {/ foo} +test filename-6.14 {Tcl_SplitPath: win} { + testsetplatform win + file split foo//bar +} {foo bar} +test filename-6.15 {Tcl_SplitPath: win} { + testsetplatform win + file split /\\/foo//bar +} {//foo/bar} +test filename-6.16 {Tcl_SplitPath: win} { + testsetplatform win + file split /\\/foo//bar +} {//foo/bar} +test filename-6.17 {Tcl_SplitPath: win} { + testsetplatform win + file split /\\/foo//bar +} {//foo/bar} +test filename-6.18 {Tcl_SplitPath: win} { + testsetplatform win + file split \\\\foo\\bar +} {//foo/bar} +test filename-6.19 {Tcl_SplitPath: win} { + testsetplatform win + file split \\\\foo\\bar/baz +} {//foo/bar baz} +test filename-6.20 {Tcl_SplitPath: win} { + testsetplatform win + file split c:/foo +} {c:/ foo} +test filename-6.21 {Tcl_SplitPath: win} { + testsetplatform win + file split c:foo +} {c: foo} +test filename-6.22 {Tcl_SplitPath: win} { + testsetplatform win + file split c: +} {c:} +test filename-6.23 {Tcl_SplitPath: win} { + testsetplatform win + file split c:\\ +} {c:/} +test filename-6.24 {Tcl_SplitPath: win} { + testsetplatform win + file split c:/ +} {c:/} +test filename-6.25 {Tcl_SplitPath: win} { + testsetplatform win + file split c:/./.. +} {c:/ . ..} +test filename-6.26 {Tcl_SplitPath: win} { + testsetplatform win + file split ~foo +} {~foo} +test filename-6.27 {Tcl_SplitPath: win} { + testsetplatform win + file split ~foo/~bar +} {~foo ./~bar} +test filename-6.28 {Tcl_SplitPath: win} { + testsetplatform win + file split ~foo/~bar/~baz +} {~foo ./~bar ./~baz} +test filename-6.29 {Tcl_SplitPath: win} { + testsetplatform win + file split foo/bar~/baz +} {foo bar~ baz} +test filename-6.30 {Tcl_SplitPath: win} { + testsetplatform win + file split c:~foo +} {c: ./~foo} + +test filename-7.1 {Tcl_JoinPath: unix} { + testsetplatform unix + file join / a +} {/a} +test filename-7.2 {Tcl_JoinPath: unix} { + testsetplatform unix + file join a b +} {a/b} +test filename-7.3 {Tcl_JoinPath: unix} { + testsetplatform unix + file join /a c /b d +} {/b/d} +test filename-7.4 {Tcl_JoinPath: unix} { + testsetplatform unix + file join / +} {/} +test filename-7.5 {Tcl_JoinPath: unix} { + testsetplatform unix + file join a +} {a} +test filename-7.6 {Tcl_JoinPath: unix} { + testsetplatform unix + file join {} +} {} +test filename-7.7 {Tcl_JoinPath: unix} { + testsetplatform unix + file join /a/ b +} {/a/b} +test filename-7.8 {Tcl_JoinPath: unix} { + testsetplatform unix + file join /a// b +} {/a/b} +test filename-7.9 {Tcl_JoinPath: unix} { + testsetplatform unix + file join /a/./../. b +} {/a/./.././b} +test filename-7.10 {Tcl_JoinPath: unix} { + testsetplatform unix + file join ~ a +} {~/a} +test filename-7.11 {Tcl_JoinPath: unix} { + testsetplatform unix + file join ~a ~b +} {~b} +test filename-7.12 {Tcl_JoinPath: unix} { + testsetplatform unix + file join ./~a b +} {./~a/b} +test filename-7.13 {Tcl_JoinPath: unix} { + testsetplatform unix + file join ./~a ~b +} {~b} +test filename-7.14 {Tcl_JoinPath: unix} { + testsetplatform unix + file join ./~a ./~b +} {./~a/~b} +test filename-7.15 {Tcl_JoinPath: unix} { + testsetplatform unix + file join a . b +} {a/./b} +test filename-7.16 {Tcl_JoinPath: unix} { + testsetplatform unix + file join a . ./~b +} {a/./~b} +test filename-7.17 {Tcl_JoinPath: unix} { + testsetplatform unix + file join //a b +} {/a/b} +test filename-7.18 {Tcl_JoinPath: unix} { + testsetplatform unix + file join /// a b +} {/a/b} + +test filename-8.1 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a b +} {:a:b} +test filename-8.2 {Tcl_JoinPath: mac} { + testsetplatform mac + file join :a b +} {:a:b} +test filename-8.3 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a b: +} {b:} +test filename-8.4 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a: :b +} {a:b} +test filename-8.5 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a: :b: +} {a:b} +test filename-8.6 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a :: b +} {:a::b} +test filename-8.7 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a :: :: b +} {:a:::b} +test filename-8.8 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a ::: b +} {:a:::b} +test filename-8.9 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a: b: +} {b:} +test filename-8.10 {Tcl_JoinPath: mac} { + testsetplatform mac + file join /a/b +} {a:b} +test filename-8.11 {Tcl_JoinPath: mac} { + testsetplatform mac + file join /a/b c/d +} {a:b:c:d} +test filename-8.12 {Tcl_JoinPath: mac} { + testsetplatform mac + file join /a/b :c:d +} {a:b:c:d} +test filename-8.13 {Tcl_JoinPath: mac} { + testsetplatform mac + file join ~ foo +} {~:foo} +test filename-8.14 {Tcl_JoinPath: mac} { + testsetplatform mac + file join :: :: +} {:::} +test filename-8.15 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a: :: +} {a::} +test filename-8.16 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a {} b +} {:a:b} +test filename-8.17 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a::: b +} {a:::b} +test filename-8.18 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a : : : +} {:a} +test filename-8.19 {Tcl_JoinPath: mac} { + testsetplatform mac + file join : +} {:} +test filename-8.20 {Tcl_JoinPath: mac} { + testsetplatform mac + file join : a +} {:a} +test filename-8.21 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a: :b/c +} {a:b/c} +test filename-8.22 {Tcl_JoinPath: mac} { + testsetplatform mac + file join :a :b/c +} {:a:b/c} + +test filename-9.1 {Tcl_JoinPath: win} { + testsetplatform win + file join a b +} {a/b} +test filename-9.2 {Tcl_JoinPath: win} { + testsetplatform win + file join /a b +} {/a/b} +test filename-9.3 {Tcl_JoinPath: win} { + testsetplatform win + file join /a /b +} {/b} +test filename-9.4 {Tcl_JoinPath: win} { + testsetplatform win + file join c: foo +} {c:foo} +test filename-9.5 {Tcl_JoinPath: win} { + testsetplatform win + file join c:/ foo +} {c:/foo} +test filename-9.6 {Tcl_JoinPath: win} { + testsetplatform win + file join c:\\bar foo +} {c:/bar/foo} +test filename-9.7 {Tcl_JoinPath: win} { + testsetplatform win + file join /foo c:bar +} {c:bar} +test filename-9.8 {Tcl_JoinPath: win} { + testsetplatform win + file join ///host//share dir +} {//host/share/dir} +test filename-9.9 {Tcl_JoinPath: win} { + testsetplatform win + file join ~ foo +} {~/foo} +test filename-9.10 {Tcl_JoinPath: win} { + testsetplatform win + file join ~/~foo +} {~/~foo} +test filename-9.11 {Tcl_JoinPath: win} { + testsetplatform win + file join ~ ./~foo +} {~/~foo} +test filename-9.12 {Tcl_JoinPath: win} { + testsetplatform win + file join / ~foo +} {~foo} +test filename-9.13 {Tcl_JoinPath: win} { + testsetplatform win + file join ./a/ b c +} {./a/b/c} +test filename-9.14 {Tcl_JoinPath: win} { + testsetplatform win + file join ./~a/ b c +} {./~a/b/c} +test filename-9.15 {Tcl_JoinPath: win} { + testsetplatform win + file join // host share path +} {/host/share/path} +test filename-9.16 {Tcl_JoinPath: win} { + testsetplatform win + file join foo . bar +} {foo/./bar} +test filename-9.17 {Tcl_JoinPath: win} { + testsetplatform win + file join foo .. bar +} {foo/../bar} +test filename-9.18 {Tcl_JoinPath: win} { + testsetplatform win + file join foo/./bar +} {foo/./bar} + +test filename-10.1 {Tcl_TranslateFileName} { + testsetplatform unix + list [catch {testtranslatefilename foo} msg] $msg +} {0 foo} +test filename-10.2 {Tcl_TranslateFileName} { + testsetplatform windows + list [catch {testtranslatefilename {c:/foo}} msg] $msg +} {0 {c:\foo}} +test filename-10.3 {Tcl_TranslateFileName} { + testsetplatform windows + list [catch {testtranslatefilename {c:/\\foo/}} msg] $msg +} {0 {c:\foo}} +test filename-10.4 {Tcl_TranslateFileName} { + testsetplatform mac + list [catch {testtranslatefilename foo} msg] $msg +} {0 :foo} +test filename-10.5 {Tcl_TranslateFileName} { + testsetplatform mac + list [catch {testtranslatefilename :~foo} msg] $msg +} {0 :~foo} +test filename-10.6 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform unix + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test/foo} +test filename-10.7 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + unset env(HOME) + testsetplatform unix + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {1 {couldn't find HOME environment variable to expand path}} +test filename-10.8 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform unix + set result [list [catch {testtranslatefilename ~} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test} +test filename-10.9 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "/home/test/" + testsetplatform unix + set result [list [catch {testtranslatefilename ~} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test} +test filename-10.10 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "/home/test/" + testsetplatform unix + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test/foo} +test filename-10.11 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:" + testsetplatform mac + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:foo} +test filename-10.12 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:home" + testsetplatform mac + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home:foo} +test filename-10.13 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:home" + testsetplatform mac + set result [list [catch {testtranslatefilename ~::foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home::foo} +test filename-10.14 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:home" + testsetplatform mac + set result [list [catch {testtranslatefilename ~} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home} +test filename-10.15 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:home:" + testsetplatform mac + set result [list [catch {testtranslatefilename ~::foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home::foo} +test filename-10.16 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:home::" + testsetplatform mac + set result [list [catch {testtranslatefilename ~::foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home:::foo} +test filename-10.17 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "\\home\\" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 {\home\foo}} +test filename-10.18 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "\\home\\" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo\\bar} msg] $msg] + set env(HOME) $temp + set result +} {0 {\home\foo\bar}} +test filename-10.19 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "c:" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 c:foo} +test filename-10.20 {Tcl_TranslateFileName} { + list [catch {testtranslatefilename ~blorp/foo} msg] $msg +} {1 {user "blorp" doesn't exist}} +test filename-10.21 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "c:\\" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 {c:\foo}} +test filename-10.22 {Tcl_TranslateFileName} { + testsetplatform windows + list [catch {testtranslatefilename foo//bar} msg] $msg +} {0 {foo\bar}} + +testsetplatform $platform + +test filename-10.23 {Tcl_TranslateFileName} {nonPortable unixOnly} { + # this test fails if ~ouster is not /home/ouster + list [catch {testtranslatefilename ~ouster} msg] $msg +} {0 /home/ouster} +test filename-10.24 {Tcl_TranslateFileName} {nonPortable unixOnly} { + # this test fails if ~ouster is not /home/ouster + list [catch {testtranslatefilename ~ouster/foo} msg] $msg +} {0 /home/ouster/foo} + + +test filename-11.1 {Tcl_GlobCmd} { + list [catch {glob} msg] $msg +} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} +test filename-11.2 {Tcl_GlobCmd} { + list [catch {glob -gorp} msg] $msg +} {1 {bad switch "-gorp": must be -nocomplain or --}} +test filename-11.3 {Tcl_GlobCmd} { + list [catch {glob -nocomplai} msg] $msg +} {1 {bad switch "-nocomplai": must be -nocomplain or --}} +test filename-11.4 {Tcl_GlobCmd} { + list [catch {glob -nocomplain} msg] $msg +} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} +test filename-11.5 {Tcl_GlobCmd} { + list [catch {glob -nocomplain ~xyqrszzz} msg] $msg +} {0 {}} +test filename-11.6 {Tcl_GlobCmd} { + list [catch {glob ~xyqrszzz} msg] $msg +} {1 {user "xyqrszzz" doesn't exist}} +test filename-11.7 {Tcl_GlobCmd} { + list [catch {glob -- -nocomplain} msg] $msg +} {1 {no files matched glob patterns "-nocomplain"}} +test filename-11.8 {Tcl_GlobCmd} { + list [catch {glob -nocomplain -- -nocomplain} msg] $msg +} {0 {}} +test filename-11.9 {Tcl_GlobCmd} { + testsetplatform unix + list [catch {glob ~\\xyqrszzz/bar} msg] $msg +} {1 {globbing characters not supported in user names}} +test filename-11.10 {Tcl_GlobCmd} { + testsetplatform unix + list [catch {glob -nocomplain ~\\xyqrszzz/bar} msg] $msg +} {0 {}} +test filename-11.11 {Tcl_GlobCmd} { + testsetplatform unix + list [catch {glob ~xyqrszzz\\/\\bar} msg] $msg +} {1 {user "xyqrszzz" doesn't exist}} +test filename-11.12 {Tcl_GlobCmd} { + testsetplatform unix + set home $env(HOME) + unset env(HOME) + set x [list [catch {glob ~/*} msg] $msg] + set env(HOME) $home + set x +} {1 {couldn't find HOME environment variable to expand path}} + +testsetplatform $platform + +test filename-11.13 {Tcl_GlobCmd} { + list [catch {file join [lindex [glob ~] 0]} msg] $msg +} [list 0 [file join $env(HOME)]] + +set oldhome $env(HOME) +set env(HOME) [pwd] +file delete -force globTest +file mkdir globTest/a1/b1 +file mkdir globTest/a1/b2 +file mkdir globTest/a2/b3 +file mkdir globTest/a3 +close [open globTest/x1.c w] +close [open globTest/y1.c w] +close [open globTest/z1.c w] +close [open "globTest/weird name.c" w] +close [open globTest/a1/b1/x2.c w] +close [open globTest/a1/b2/y2.c w] + +# Cannot create a file with the following names under Win32s. We have to +# skip the tests that are checking the difference between a "." or "," in +# the file name vs. a "." or "," in the glob pattern. + +catch {close [open globTest/.1 w]} +catch {close [open globTest/x,z1.c w]} + +test filename-11.14 {Tcl_GlobCmd} { + list [catch {glob ~/globTest} msg] $msg +} [list 0 [list [file join $env(HOME) globTest]]] +test filename-11.15 {Tcl_GlobCmd} { + list [catch {glob ~\\/globTest} msg] $msg +} [list 0 [list [file join $env(HOME) globTest]]] +test filename-11.16 {Tcl_GlobCmd} { + list [catch {glob globTest} msg] $msg +} {0 globTest} + +test filename-12.1 {simple globbing} {unixOrPc} { + list [catch {glob {}} msg] $msg +} {0 .} +test filename-12.2 {simple globbing} {macOnly} { + list [catch {glob {}} msg] $msg +} {0 :} +test filename-12.3 {simple globbing} { + list [catch {glob -nocomplain \{a1,a2\}} msg] $msg +} {0 {}} + +if {$tcl_platform(platform) == "macintosh"} { + set globPreResult :globTest: +} else { + set globPreResult globTest/ +} +set x1 x1.c +set y1 y1.c +test filename-12.4 {simple globbing} {unixOrPc} { + lsort [glob globTest/x1.c globTest/y1.c globTest/foo] +} "$globPreResult$x1 $globPreResult$y1" +test filename-12.5 {simple globbing} { + list [catch {glob globTest\\/x1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-12.6 {simple globbing} { + list [catch {glob globTest\\/\\x1.c} msg] $msg +} "0 $globPreResult$x1" + +test filename-13.1 {globbing with brace substitution} { + list [catch {glob globTest/\{\}} msg] $msg +} "0 $globPreResult" +test filename-13.2 {globbing with brace substitution} { + list [catch {glob globTest/\{} msg] $msg +} {1 {unmatched open-brace in file name}} +test filename-13.3 {globbing with brace substitution} { + list [catch {glob globTest/\{\\\}} msg] $msg +} {1 {unmatched open-brace in file name}} +test filename-13.4 {globbing with brace substitution} { + list [catch {glob globTest/\{\\} msg] $msg +} {1 {unmatched open-brace in file name}} +test filename-13.5 {globbing with brace substitution} { + list [catch {glob globTest/\}} msg] $msg +} {1 {unmatched close-brace in file name}} +test filename-13.6 {globbing with brace substitution} { + list [catch {glob globTest/\{\}x1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-13.7 {globbing with brace substitution} { + list [catch {glob globTest/\{x\}1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-13.8 {globbing with brace substitution} { + list [catch {glob globTest/\{x\{\}\}1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-13.9 {globbing with brace substitution} {!win32s} { + list [lsort [catch {glob globTest/\{x,y\}1.c} msg]] $msg +} [list 0 [list $globPreResult$x1 $globPreResult$y1]] +test filename-13.10 {globbing with brace substitution} {!win32s} { + list [lsort [catch {glob globTest/\{x,,y\}1.c} msg]] $msg +} [list 0 [list $globPreResult$x1 $globPreResult$y1]] +test filename-13.11 {globbing with brace substitution} {unixOrPc && !win32s} { + list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg +} {0 {globTest/x1.c globTest/x,z1.c globTest/z1.c}} +test filename-13.12 {globbing with brace substitution} {macOnly} { + list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg +} {0 {:globTest:x1.c :globTest:x,z1.c :globTest:z1.c}} +test filename-13.13 {globbing with brace substitution} { + lsort [glob globTest/{a,b,x,y}1.c] +} [list $globPreResult$x1 $globPreResult$y1] +test filename-13.14 {globbing with brace substitution} {unixOrPc} { + lsort [glob {globTest/{x1,y2,weird name}.c}] +} {{globTest/weird name.c} globTest/x1.c} +test filename-13.15 {globbing with brace substitution} {macOnly} { + lsort [glob {globTest/{x1,y2,weird name}.c}] +} {{:globTest:weird name.c} :globTest:x1.c} +test filename-13.16 {globbing with brace substitution} {unixOrPc} { + lsort [glob globTest/{x1.c,a1/*}] +} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} +test filename-13.17 {globbing with brace substitution} {macOnly} { + lsort [glob globTest/{x1.c,a1/*}] +} {:globTest:a1:b1 :globTest:a1:b2 :globTest:x1.c} +test filename-13.18 {globbing with brace substitution} {unixOrPc} { + lsort [glob globTest/{x1.c,{a},a1/*}] +} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} +test filename-13.19 {globbing with brace substitution} {macOnly} { + lsort [glob globTest/{x1.c,{a},a1/*}] +} {:globTest:a1:b1 :globTest:a1:b2 :globTest:x1.c} +test filename-13.20 {globbing with brace substitution} {unixOrPc} { + lsort [glob globTest/{a,x}1/*/{x,y}*] +} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c} +test filename-13.21 {globbing with brace substitution} {macOnly} { + lsort [glob globTest/{a,x}1/*/{x,y}*] +} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c} +test filename-13.22 {globbing with brace substitution} { + list [catch {glob globTest/\{a,x\}1/*/\{} msg] $msg +} {1 {unmatched open-brace in file name}} + +test filename-14.1 {asterisks, question marks, and brackets} {unixOrPc && !win32s} { + lsort [glob g*/*.c] +} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} +test filename-14.1 {asterisks, question marks, and brackets} {win32s} { + lsort [glob g*/*.c] +} {globtest/weirdn~1.c globtest/x1.c globtest/y1.c globtest/z1.c} +test filename-14.2 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob g*/*.c] +} {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c} +test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} { + lsort [glob globTest/?1.c] +} {globTest/x1.c globTest/y1.c globTest/z1.c} +test filename-14.4 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/?1.c] +} {:globTest:x1.c :globTest:y1.c :globTest:z1.c} +test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc && !win32s} { + lsort [glob */*/*/*.c] +} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c} +test filename-14.5 {asterisks, question marks, and brackets} {win32s} { + lsort [glob */*/*/*.c] +} {globtest/a1/b1/x2.c globtest/a1/b2/y2.c} +test filename-14.6 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob */*/*/*.c] +} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c} +test filename-14.7 {asterisks, question marks, and brackets} {unixOrPc && !win32s} { + lsort [glob globTest/*] +} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} +test filename-14.7 {asterisks, question marks, and brackets} {win32s} { + lsort [glob globTest/*] +} {globTest/a1 globTest/a2 globTest/a3 globTest/weirdn~1.c globTest/x1.c globTest/y1.c globTest/z1.c} +test filename-14.8 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/*] +} {:globTest:.1 :globTest:a1 :globTest:a2 :globTest:a3 {:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c} +test filename-14.9 {asterisks, question marks, and brackets} {unixOrPc && !win32s} { + lsort [glob globTest/.*] +} {globTest/. globTest/.. globTest/.1} +test filename-14.9 {asterisks, question marks, and brackets} {win32s} { + lsort [glob globTest/.*] +} {globTest/. globTest/..} +test filename-14.10 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/.*] +} {:globTest:.1} +test filename-14.11 {asterisks, question marks, and brackets} {unixOrPc} { + lsort [glob globTest/*/*] +} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3} +test filename-14.12 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/*/*] +} {:globTest:a1:b1 :globTest:a1:b2 :globTest:a2:b3} +test filename-14.13 {asterisks, question marks, and brackets} {unixOrPc} { + lsort [glob {globTest/[xyab]1.*}] +} {globTest/x1.c globTest/y1.c} +test filename-14.14 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob {globTest/[xyab]1.*}] +} {:globTest:x1.c :globTest:y1.c} +test filename-14.15 {asterisks, question marks, and brackets} {unixOrPc} { + lsort [glob globTest/*/] +} {globTest/a1/ globTest/a2/ globTest/a3/} +test filename-14.16 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/*/] +} {:globTest:a1: :globTest:a2: :globTest:a3:} +test filename-14.17 {asterisks, question marks, and brackets} { + global env + set temp $env(HOME) + set env(HOME) [file join $env(HOME) globTest] + set result [list [catch {glob ~/z*} msg] $msg] + set env(HOME) $temp + set result +} [list 0 [list [file join $env(HOME) globTest z1.c]]] +test filename-14.18 {asterisks, question marks, and brackets} {unixOrPc && !win32s} { + list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg +} {0 {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}} +test filename-14.18 {asterisks, question marks, and brackets} {win32s} { + list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg +} {0 {globTest/weirdn~1.c globTest/x1.c globTest/y1.c globTest/z1.c}} +test filename-14.19 {asterisks, question marks, and brackets} {macOnly} { + list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg +} {0 {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}} +test filename-14.20 {asterisks, question marks, and brackets} { + list [catch {glob -nocomplain goo/*} msg] $msg +} {0 {}} +test filename-14.21 {asterisks, question marks, and brackets} { + list [catch {glob globTest/*/gorp} msg] $msg +} {1 {no files matched glob pattern "globTest/*/gorp"}} +test filename-14.22 {asterisks, question marks, and brackets} { + list [catch {glob goo/* x*z foo?q} msg] $msg +} {1 {no files matched glob patterns "goo/* x*z foo?q"}} +test filename-14.23 {slash globbing} {unixOrPc} { + glob / +} / +test filename-14.24 {slash globbing} {pcOnly} { + glob {\\} +} / + +# The following tests are only valid for Unix systems. + +if {$tcl_platform(platform) == "unix"} { + # On some systems, like AFS, "000" protection doesn't prevent + # access by owner, so the following test is not portable. + + exec chmod 000 globTest/a1 + test filename-15.1 {unix specific globbing} {nonPortable} { + string tolower [list [catch {glob globTest/a1/*} msg] $msg $errorCode] + } {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}} + test filename-15.2 {unix specific no complain: no errors} {nonPortable} { + glob -nocomplain globTest/a1/* + } {} + test filename-15.3 {unix specific no complain: no errors, good result} {nonPortable knownBug} { + # test fails because if an error occur , the interp's result + # is reset... + glob -nocomplain globTest/a2 globTest/a1/* globTest/a3 + } {globTest/a2 globTest/a3} + exec chmod 755 globTest/a1 + test filename-15.4 {unix specific no complain: no errors, good result} {nonPortable knownBug} { + # test fails because if an error occur , the interp's result + # is reset... (or you don't run at sunscript where the + # outser and demailly's users exists + glob -nocomplain ~ouster ~foo ~demailly + } {/home/ouster /home/demailly} + test filename-15.5 {unix specific globbing} {nonPortable} { + glob ~ouster/.csh* + } "/home/ouster/.cshrc" + close [open globTest/odd\\\[\]*?\{\}name w] + test filename-15.6 {unix specific globbing} { + global env + set temp $env(HOME) + set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name + set result [list [catch {glob ~} msg] $msg] + set env(HOME) $temp + set result + } [list 0 [list [glob ~]/globTest/odd\\\[\]*?\{\}name]] + exec rm -f globTest/odd\\\[\]*?\{\}name +} + +# The following tests are only valid for Windows systems. + +if {$tcl_platform(platform) == "windows"} { + set temp [pwd] + cd c:/ + catch { + removeDirectory globTest + makeDirectory globTest + close [open globTest/x1.BAT w] + close [open globTest/y1.Bat w] + close [open globTest/z1.bat w] + } + + test filename-16.1 {windows specific globbing} {!win32s} { + lsort [glob globTest/*.bat] + } {globTest/x1.BAT globTest/y1.Bat globTest/z1.bat} + test filename-16.1 {windows specific globbing} {win32s} { + lsort [glob globTest/*.bat] + } {globTest/x1.bat globTest/y1.bat globTest/z1.bat} + test filename-16.2 {windows specific globbing} { + glob c: + } c: + test filename-16.3 {windows specific globbing} { + glob c:\\\\ + } c:/ + test filename-16.4 {windows specific globbing} { + glob c:/ + } c:/ + test filename-16.5 {windows specific globbing} {!win32s} { + glob c:*Test + } c:globTest + test filename-16.5 {windows specific globbing} {win32s} { + glob c:*Test + } c:globtest + test filename-16.6 {windows specific globbing} {!win32s} { + glob c:\\\\*Test + } c:/globTest + test filename-16.6 {windows specific globbing} {win32s} { + glob c:\\\\*Test + } c:/globtest + test filename-16.7 {windows specific globbing} {!win32s} { + glob c:/*Test + } c:/globTest + test filename-16.7 {windows specific globbing} {win32s} { + glob c:/*Test + } c:/globtest + test filename-16.8 {windows specific globbing} {!win32s} { + lsort [glob c:globTest/*.bat] + } {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat} + test filename-16.8 {windows specific globbing} {win32s} { + lsort [glob c:globTest/*.bat] + } {c:globTest/x1.bat c:globTest/y1.bat c:globTest/z1.bat} + test filename-16.9 {windows specific globbing} {!win32s} { + lsort [glob c:/globTest/*.bat] + } {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat} + test filename-16.9 {windows specific globbing} {win32s} { + lsort [glob c:/globTest/*.bat] + } {c:/globTest/x1.bat c:/globTest/y1.bat c:/globTest/z1.bat} + test filename-16.10 {windows specific globbing} {!win32s} { + lsort [glob c:globTest\\\\*.bat] + } {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat} + test filename-16.10 {windows specific globbing} {win32s} { + lsort [glob c:globTest\\\\*.bat] + } {c:globTest/x1.bat c:globTest/y1.bat c:globTest/z1.bat} + test filename-16.11 {windows specific globbing} {!win32s} { + lsort [glob c:\\\\globTest\\\\*.bat] + } {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat} + test filename-16.11 {windows specific globbing} {win32s} { + lsort [glob c:\\\\globTest\\\\*.bat] + } {c:/globTest/x1.bat c:/globTest/y1.bat c:/globTest/z1.bat} + + removeDirectory globTest + + if {($testConfig(nonPortable) != 0) && [catch {cd //gaspode/d}] == 0} { + removeDirectory globTest + makeDirectory globTest + + close [open globTest/x1.BAT w] + close [open globTest/y1.Bat w] + close [open globTest/z1.bat w] + + test filename-16.12 {windows specific globbing} { + glob //gaspode/d/*Test + } //gaspode/d/globTest + test filename-16.13 {windows specific globbing} { + glob {\\\\gaspode\\d\\*Test} + } //gaspode/d/globTest + + removeDirectory globTest + } + + cd $temp +} + +removeDirectory globTest +set env(HOME) $oldhome + +testsetplatform $platform +catch {unset oldhome platform temp result} +concat "" diff --git a/tests/for-old.test b/tests/for-old.test new file mode 100644 index 0000000..354f3d68 --- /dev/null +++ b/tests/for-old.test @@ -0,0 +1,66 @@ +# Commands covered: for, continue, break +# +# This file contains the original set of tests for Tcl's for command. +# Since the for command is now compiled, a new set of tests covering +# the new implementation is in the file "for.test". Sourcing this file +# into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) for-old.test 1.14 97/01/13 13:42:18 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Check "for" and its use of continue and break. + +catch {unset a i} +test for-old-1.1 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + set a [concat $a $i] + } + set a +} {1 2 3 4 5} +test for-old-1.2 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 continue + set a [concat $a $i] + } + set a +} {1 2 3 5} +test for-old-1.3 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 break + set a [concat $a $i] + } + set a +} {1 2 3} +test for-old-1.4 {for tests} {catch {for 1 2 3} msg} 1 +test for-old-1.5 {for tests} { + catch {for 1 2 3} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-old-1.6 {for tests} {catch {for 1 2 3 4 5} msg} 1 +test for-old-1.7 {for tests} { + catch {for 1 2 3 4 5} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-old-1.8 {for tests} { + set a {xyz} + for {set i 1} {$i<6} {set i [expr $i+1]} {} + set a +} xyz +test for-old-1.9 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} { + set a [concat $a $i] + } + set a +} {1 2 3} diff --git a/tests/for.test b/tests/for.test new file mode 100644 index 0000000..aa918ec --- /dev/null +++ b/tests/for.test @@ -0,0 +1,592 @@ +# Commands covered: for, continue, break +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) for.test 1.10 97/07/02 16:40:59 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Basic "for" operation. + +test for-1.1 {TclCompileForCmd: missing initial command} { + list [catch {for} msg] $msg +} {1 {wrong # args: should be "for start test next command"}} +test for-1.2 {TclCompileForCmd: error in initial command} { + list [catch {for {set}} msg] $msg $errorInfo +} {1 {wrong # args: should be "for start test next command"} {wrong # args: should be "for start test next command" + while compiling +"for {set}"}} +catch {unset i} +test for-1.3 {TclCompileForCmd: missing test expression} { + catch {for {set i 0}} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-1.4 {TclCompileForCmd: error in test expression} { + catch {for {set i 0} {$i<}} msg + set errorInfo +} {wrong # args: should be "for start test next command" + while compiling +"for {set i 0} {$i<}"} +test for-1.5 {TclCompileForCmd: test expression is enclosed in quotes} { + set i 0 + for {} "$i > 5" {incr i} {} +} {} +test for-1.6 {TclCompileForCmd: missing "next" command} { + catch {for {set i 0} {$i < 5}} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-1.7 {TclCompileForCmd: missing command body} { + catch {for {set i 0} {$i < 5} {incr i}} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-1.8 {TclCompileForCmd: error compiling command body} { + catch {for {set i 0} {$i < 5} {incr i} {set}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("for" body line 1) + while compiling +"for {set i 0} {$i < 5} {incr i} {set}"} +catch {unset a} +test for-1.9 {TclCompileForCmd: simple command body} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 break + set a [concat $a $i] + } + set a +} {1 2 3} +test for-1.10 {TclCompileForCmd: command body in quotes} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} "append a x" + set a +} {xxxxx} +test for-1.11 {TclCompileForCmd: computed command body} { + catch {unset x1} + catch {unset bb} + catch {unset x2} + set x1 {append a x1; } + set bb {break} + set x2 {; append a x2} + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2 + set a +} {x1} +test for-1.12 {TclCompileForCmd: error in "next" command} { + catch {for {set i 0} {$i < 5} {set} {puts $i}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("for" loop-end command) + while compiling +"for {set i 0} {$i < 5} {set} {puts $i}"} +test for-1.13 {TclCompileForCmd: long command body} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + } + set a +} {1 2 3} +test for-1.14 {TclCompileForCmd: for command result} { + set a [for {set i 0} {$i < 5} {incr i} {}] + set a +} {} +test for-1.15 {TclCompileForCmd: for command result} { + set a [for {set i 0} {$i < 5} {incr i} {if $i==3 break}] + set a +} {} + +# Check "for" and "continue". + +test for-2.1 {TclCompileContinueCmd: arguments after "continue"} { + catch {continue foo} msg + set msg +} {wrong # args: should be "continue"} +test for-2.2 {TclCompileContinueCmd: continue result} { + catch continue +} 4 +test for-2.3 {continue tests} { + set a {} + for {set i 1} {$i <= 4} {set i [expr $i+1]} { + if {$i == 2} continue + set a [concat $a $i] + } + set a +} {1 3 4} +test for-2.4 {continue tests} { + set a {} + for {set i 1} {$i <= 4} {set i [expr $i+1]} { + if {$i != 2} continue + set a [concat $a $i] + } + set a +} {2} +test for-2.5 {continue tests, nested loops} { + set msg {} + for {set i 1} {$i <= 4} {incr i} { + for {set a 1} {$a <= 2} {incr a} { + if {$i>=2 && $a>=2} continue + set msg [concat $msg "$i.$a"] + } + } + set msg +} {1.1 1.2 2.1 3.1 4.1} +test for-2.6 {continue tests, long command body} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==2 continue + if $i==4 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + } + set a +} {1 3} + +# Check "for" and "break". + +test for-3.1 {TclCompileBreakCmd: arguments after "break"} { + catch {break foo} msg + set msg +} {wrong # args: should be "break"} +test for-3.2 {TclCompileBreakCmd: break result} { + catch break +} 3 +test for-3.3 {break tests} { + set a {} + for {set i 1} {$i <= 4} {incr i} { + if {$i == 3} break + set a [concat $a $i] + } + set a +} {1 2} +test for-3.4 {break tests, nested loops} { + set msg {} + for {set i 1} {$i <= 4} {incr i} { + for {set a 1} {$a <= 2} {incr a} { + if {$i>=2 && $a>=2} break + set msg [concat $msg "$i.$a"] + } + } + set msg +} {1.1 1.2 2.1 3.1 4.1} +test for-3.5 {break tests, long command body} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==2 continue + if $i==5 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if $i==4 break + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + } + set a +} {1 3} +# A simplified version of exmh's mail formatting routine to stress "for", +# "break", "while", and "if". +proc formatMail {} { + array set lines { + 0 {Return-path: george@tcl} \ + 1 {Return-path: <george@tcl>} \ + 2 {Received: from tcl by tcl.Somewhere.COM (SMI-8.6/SMI-SVR4)} \ + 3 { id LAA10027; Wed, 11 Sep 1996 11:14:53 -0700} \ + 4 {Message-id: <199609111814.LAA10027@tcl.Somewhere.COM>} \ + 5 {X-mailer: exmh version 1.6.9 8/22/96} \ + 6 {Mime-version: 1.0} \ + 7 {Content-type: text/plain; charset=iso-8859-1} \ + 8 {Content-transfer-encoding: quoted-printable} \ + 9 {Content-length: 2162} \ + 10 {To: fred} \ + 11 {Subject: tcl7.6} \ + 12 {Date: Wed, 11 Sep 1996 11:14:53 -0700} \ + 13 {From: George <george@tcl>} \ + 14 {The Tcl 7.6 and Tk 4.2 releases} \ + 15 {} \ + 16 {This page contains information about Tcl 7.6 and Tk4.2, which are the most recent} \ + 17 {releases of the Tcl scripting language and the Tk toolkit. The first beta versions of these} \ + 18 {releases were released on August 30, 1996. These releases contain only minor changes,} \ + 19 {so we hope to have only a single beta release and to go final in early October, 1996. } \ + 20 {} \ + 21 {} \ + 22 {What's new } \ + 23 {} \ + 24 {The most important changes in the releases are summarized below. See the README} \ + 25 {and changes files in the distributions for more complete information on what has} \ + 26 {changed, including both feature changes and bug fixes. } \ + 27 {} \ + 28 { There are new options to the file command for copying files (file copy),} \ + 29 { deleting files and directories (file delete), creating directories (file} \ + 30 { mkdir), and renaming files (file rename). } \ + 31 { The implementation of exec has been improved greatly for Windows 95 and} \ + 32 { Windows NT. } \ + 33 { There is a new memory allocator for the Macintosh version, which should be} \ + 34 { more efficient than the old one. } \ + 35 { Tk's grid geometry manager has been completely rewritten. The layout} \ + 36 { algorithm produces much better layouts than before, especially where rows or} \ + 37 { columns were stretchable. } \ + 38 { There are new commands for creating common dialog boxes:} \ + 39 { tk_chooseColor, tk_getOpenFile, tk_getSaveFile and} \ + 40 { tk_messageBox. These use native dialog boxes if they are available. } \ + 41 { There is a new virtual event mechanism for handling events in a more portable} \ + 42 { way. See the new command event. It also allows events (both physical and} \ + 43 { virtual) to be generated dynamically. } \ + 44 {} \ + 45 {Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl 7.5 and Tk 4.1 except for} \ + 46 {changes in the C APIs for custom channel drivers. Scripts written for earlier releases} \ + 47 {should work on these new releases as well. } \ + 48 {} \ + 49 {Obtaining The Releases} \ + 50 {} \ + 51 {Binary Releases} \ + 52 {} \ + 53 {Pre-compiled releases are available for the following platforms: } \ + 54 {} \ + 55 { Windows 3.1, Windows 95, and Windows NT: Fetch} \ + 56 { ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then execute it. The file is a} \ + 57 { self-extracting executable. It will install the Tcl and Tk libraries, the wish and} \ + 58 { tclsh programs, and documentation. } \ + 59 { Macintosh (both 68K and PowerPC): Fetch} \ + 60 { ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. The file is in binhex format,} \ + 61 { which is understood by Fetch, StuffIt, and many other Mac utilities. The} \ + 62 { unpacked file is a self-installing executable: double-click on it and it will create a} \ + 63 { folder containing all that you need to run Tcl and Tk. } \ + 64 { UNIX (Solaris 2.* and SunOS, other systems soon to follow). Easy to install} \ + 65 { binary packages are now for sale at the Sun Labs Tcl/Tk Shop. Check it out!} \ + } + + set result "" + set NL " +" + set tag {level= type=text/plain part=0 sel Charset} + set ix [lsearch -regexp $tag text/enriched] + if {$ix < 0} { + set ranges {} + set quote 0 + } + set breakrange {6.42 78.0} + set F1 [lindex $breakrange 0] + set F2 [lindex $breakrange 1] + set breakrange [lrange $breakrange 2 end] + if {[string length $F1] == 0} { + set F1 -1 + set break 0 + } else { + set break 1 + } + + set xmailer 0 + set inheaders 1 + set last [array size lines] + set plen 2 + for {set L 1} {$L < $last} {incr L} { + set line $lines($L) + if {$inheaders} { + # Blank or empty line terminates headers + # Leading --- terminates headers + if {[regexp {^[ ]*$} $line] || [regexp {^--+} $line]} { + set inheaders 0 + } + if {[regexp -nocase {^x-mailer:} $line]} { + continue + } + } + if $inheaders { + set limit 55 + } else { + set limit 55 + + # Decide whether or not to break the body line + + if {$plen > 0} { + if {[string first {> } $line] == 0} { + # This is quoted text from previous message, don't reformat + append result $line $NL + if {$quote && !$inheaders} { + # Fix from <sarr@umich.edu> to handle text/enriched + if {$L > $L1 && $L < $L2 && $line != {}} { + # enriched requires two newlines for each one. + append result $NL + } elseif {$L > $L2} { + set L1 [lindex $ranges 0] + set L2 [lindex $ranges 1] + set ranges [lrange $ranges 2 end] + set quote [llength $L1] + } + } + continue + } + } + if {$F1 < 0} { + # Nothing left to format + append result $line $NL + continue + } elseif {$L < $F1} { + # Not yet to formatted block + append result $line $NL + continue + } elseif {$L > $F2} { + # Past formatted block + set F1 [lindex $breakrange 0] + set F2 [lindex $breakrange 1] + set breakrange [lrange $breakrange 2 end] + append result $line $NL + if {[string length $F1] == 0} { + set F1 -1 + } + continue + } + } + set climit [expr $limit-1] + set cutoff 50 + set continuation 0 + + while {[string length $line] > $limit} { + for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} { + set char [string index $line $c] + if {$char == " " || $char == "\t"} { + break + } + if {$char == ">"} { ;# Hack for enriched formatting + break + } + } + if {$c < $cutoff} { + if {! $inheaders} { + set c [expr $limit-1] + } else { + set c [string length $line] + } + } + set newline [string range $line 0 $c] + if {! $continuation} { + append result $newline $NL + } else { + append result \ $newline $NL + } + incr c + set line [string trimright [string range $line $c end]] + if {$inheaders} { + set continuation 1 + set limit $climit + } + } + if {$continuation} { + if {[string length $line] != 0} { + append result \ $line $NL + } + } else { + append result $line $NL + if {$quote && !$inheaders} { + if {$L > $L1 && $L < $L2 && $line != {}} { + # enriched requires two newlines for each one. + append result "" $NL + } elseif {$L > $L2} { + set L1 [lindex $ranges 0] + set L2 [lindex $ranges 1] + set ranges [lrange $ranges 2 end] + set quote [llength $L1] + } + } + } + } + return $result +} +test for-3.6 {break tests} { + formatMail +} {Return-path: <george@tcl> +Received: from tcl by tcl.Somewhere.COM (SMI-8.6/SMI-SVR4) + id LAA10027; Wed, 11 Sep 1996 11:14:53 -0700 +Message-id: <199609111814.LAA10027@tcl.Somewhere.COM> +Mime-version: 1.0 +Content-type: text/plain; charset=iso-8859-1 +Content-transfer-encoding: quoted-printable +Content-length: 2162 +To: fred +Subject: tcl7.6 +Date: Wed, 11 Sep 1996 11:14:53 -0700 +From: George <george@tcl> +The Tcl 7.6 and Tk 4.2 releases + +This page contains information about Tcl 7.6 and Tk4.2, + which are the most recent +releases of the Tcl scripting language and the Tk toolk +it. The first beta versions of these +releases were released on August 30, 1996. These releas +es contain only minor changes, +so we hope to have only a single beta release and to +go final in early October, 1996. + + +What's new + +The most important changes in the releases are summariz +ed below. See the README +and changes files in the distributions for more complet +e information on what has +changed, including both feature changes and bug fixes. + + There are new options to the file command for +copying files (file copy), + deleting files and directories (file delete), +creating directories (file + mkdir), and renaming files (file rename). + The implementation of exec has been improved great +ly for Windows 95 and + Windows NT. + There is a new memory allocator for the Macintosh +version, which should be + more efficient than the old one. + Tk's grid geometry manager has been completely +rewritten. The layout + algorithm produces much better layouts than before +, especially where rows or + columns were stretchable. + There are new commands for creating common dialog +boxes: + tk_chooseColor, tk_getOpenFile, tk_getSaveFile and + tk_messageBox. These use native dialog boxes if +they are available. + There is a new virtual event mechanism for handlin +g events in a more portable + way. See the new command event. It also allows +events (both physical and + virtual) to be generated dynamically. + +Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl +7.5 and Tk 4.1 except for +changes in the C APIs for custom channel drivers. Scrip +ts written for earlier releases +should work on these new releases as well. + +Obtaining The Releases + +Binary Releases + +Pre-compiled releases are available for the following +platforms: + + Windows 3.1, Windows 95, and Windows NT: Fetch + ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then +execute it. The file is a + self-extracting executable. It will install the +Tcl and Tk libraries, the wish and + tclsh programs, and documentation. + Macintosh (both 68K and PowerPC): Fetch + ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. +The file is in binhex format, + which is understood by Fetch, StuffIt, and many +other Mac utilities. The + unpacked file is a self-installing executable: +double-click on it and it will create a + folder containing all that you need to run Tcl +and Tk. + UNIX (Solaris 2.* and SunOS, other systems +soon to follow). Easy to install + binary packages are now for sale at the Sun Labs +Tcl/Tk Shop. Check it out! +} + +# Check that "break" resets the interpreter's result + +test for-4.1 {break must reset the interp result} { + catch { + set z GLOBTESTDIR/dir2/file2.c + if [string match GLOBTESTDIR/dir2/* $z] { + break + } + } j + set j +} {} + +# Check "for" and computed command names. + +test for-5.1 {for and computed command names} { + set j 0 + set z for + $z {set i 0} {$i<10} {incr i} {set j $i} + set j +} 9 diff --git a/tests/foreach.test b/tests/foreach.test new file mode 100644 index 0000000..f87dd39 --- /dev/null +++ b/tests/foreach.test @@ -0,0 +1,212 @@ +# Commands covered: foreach, continue, break +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) foreach.test 1.8 97/08/12 18:19:27 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset a} +catch {unset x} + +# Basic "foreach" operation. + +test foreach-1.1 {basic foreach tests} { + set a {} + foreach i {a b c d} { + set a [concat $a $i] + } + set a +} {a b c d} +test foreach-1.2 {basic foreach tests} { + set a {} + foreach i {a b {{c d} e} {123 {{x}}}} { + set a [concat $a $i] + } + set a +} {a b {c d} e 123 {{x}}} +test foreach-1.3 {basic foreach tests} {catch {foreach} msg} 1 +test foreach-1.4 {basic foreach tests} { + catch {foreach} msg + set msg +} {wrong # args: should be "foreach varList list ?varList list ...? command"} +test foreach-1.5 {basic foreach tests} {catch {foreach i} msg} 1 +test foreach-1.6 {basic foreach tests} { + catch {foreach i} msg + set msg +} {wrong # args: should be "foreach varList list ?varList list ...? command"} +test foreach-1.7 {basic foreach tests} {catch {foreach i j} msg} 1 +test foreach-1.8 {basic foreach tests} { + catch {foreach i j} msg + set msg +} {wrong # args: should be "foreach varList list ?varList list ...? command"} +test foreach-1.9 {basic foreach tests} {catch {foreach i j k l} msg} 1 +test foreach-1.10 {basic foreach tests} { + catch {foreach i j k l} msg + set msg +} {wrong # args: should be "foreach varList list ?varList list ...? command"} +test foreach-1.11 {basic foreach tests} { + set a {} + foreach i {} { + set a [concat $a $i] + } + set a +} {} +test foreach-1.12 {foreach errors} { + list [catch {foreach {{a}{b}} {1 2 3} {}} msg] $msg +} {1 {list element in braces followed by "{b}" instead of space}} +test foreach-1.13 {foreach errors} { + list [catch {foreach a {{1 2}3} {}} msg] $msg +} {1 {list element in braces followed by "3" instead of space}} +catch {unset a} +test foreach-1.14 {foreach errors} { + catch {unset a} + set a(0) 44 + list [catch {foreach a {1 2 3} {}} msg] $msg +} {1 {couldn't set loop variable: "a"}} +test foreach-1.15 {foreach errors} { + list [catch {foreach {} {} {}} msg] $msg +} {1 {foreach varlist is empty}} +catch {unset a} + +test foreach-2.1 {parallel foreach tests} { + set x {} + foreach {a b} {1 2 3 4} { + append x $b $a + } + set x +} {2143} +test foreach-2.2 {parallel foreach tests} { + set x {} + foreach {a b} {1 2 3 4 5} { + append x $b $a + } + set x +} {21435} +test foreach-2.3 {parallel foreach tests} { + set x {} + foreach a {1 2 3} b {4 5 6} { + append x $b $a + } + set x +} {415263} +test foreach-2.4 {parallel foreach tests} { + set x {} + foreach a {1 2 3} b {4 5 6 7 8} { + append x $b $a + } + set x +} {41526378} +test foreach-2.5 {parallel foreach tests} { + set x {} + foreach {a b} {a b A B aa bb} c {c C cc CC} { + append x $a $b $c + } + set x +} {abcABCaabbccCC} +test foreach-2.6 {parallel foreach tests} { + set x {} + foreach a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + append x $a $b $c $d $e + } + set x +} {111112222233333} +test foreach-2.7 {parallel foreach tests} { + set x {} + foreach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + append x $a $b $c $d $e + } + set x +} {1111 2222334} +test foreach-2.8 {foreach only sets vars if repeating loop} { + proc foo {} { + set rgb {65535 0 0} + foreach {r g b} [set rgb] {} + return "r=$r, g=$g, b=$b" + } + foo +} {r=65535, g=0, b=0} +test foreach-2.9 {foreach only supports local scalar variables} { + proc foo {} { + set x {} + foreach {a(3)} {1 2 3 4} {lappend x [set {a(3)}]} + set x + } + foo +} {1 2 3 4} + +test foreach-3.1 {compiled foreach backward jump works correctly} { + catch {unset x} + proc foo {arrayName} { + upvar 1 $arrayName a + set l {} + foreach member [array names a] { + lappend l [list $member [set a($member)]] + } + return $l + } + array set x {0 zero 1 one 2 two 3 three} + foo x +} {{0 zero} {1 one} {2 two} {3 three}} + +test foreach-4.1 {noncompiled foreach and shared variable or value list objects that are converted to another type} { + catch {unset x} + foreach {12.0} {a b c} { + set x 12.0 + set x [expr $x + 1] + } + set x +} 13.0 + +# Check "continue". + +test foreach-4.1 {continue tests} {catch continue} 4 +test foreach-4.2 {continue tests} { + set a {} + foreach i {a b c d} { + if {[string compare $i "b"] == 0} continue + set a [concat $a $i] + } + set a +} {a c d} +test foreach-4.3 {continue tests} { + set a {} + foreach i {a b c d} { + if {[string compare $i "b"] != 0} continue + set a [concat $a $i] + } + set a +} {b} +test foreach-4.4 {continue tests} {catch {continue foo} msg} 1 +test foreach-4.5 {continue tests} { + catch {continue foo} msg + set msg +} {wrong # args: should be "continue"} + +# Check "break". + +test foreach-5.1 {break tests} {catch break} 3 +test foreach-5.2 {break tests} { + set a {} + foreach i {a b c d} { + if {[string compare $i "c"] == 0} break + set a [concat $a $i] + } + set a +} {a b} +test foreach-5.3 {break tests} {catch {break foo} msg} 1 +test foreach-5.4 {break tests} { + catch {break foo} msg + set msg +} {wrong # args: should be "break"} + +catch {unset a} +catch {unset x} diff --git a/tests/format.test b/tests/format.test new file mode 100644 index 0000000..758825b --- /dev/null +++ b/tests/format.test @@ -0,0 +1,438 @@ +# Commands covered: format +# +# 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-1994 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: @(#) format.test 1.29 97/09/03 15:51:02 + +if {[string compare test [info procs test]] == 1} then {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 +# fail. Someday I hope this code shouldn't be necessary (code added +# 9/9/91). + +set roundOffBug 0 +if {"[format %7.1e 68.514]" == "6.8e+01"} { + puts stdout "Note: this system has a sprintf round-off bug, some tests skipped\n" + set roundOffBug 1 +} + +test format-1.1 {integer formatting} { + format "%*d %d %d %d" 6 34 16923 -12 -1 +} { 34 16923 -12 -1} +test format-1.2 {integer formatting} {nonPortable} { + format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12 +} { 6 34 16923 -12 -1 0xe 0XC} + +# %u output depends on word length, so this test is not portable. + +test format-1.3 {integer formatting} {nonPortable} { + format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 +} { 6 34 16923 4294967284 -1 0} +test format-1.4 {integer formatting} { + format "%-4d %-4i %-4d %-4ld" 6 34 16923 -12 -1 +} {6 34 16923 -12 } +test format-1.5 {integer formatting} { + format "%04d %04d %04d %04i" 6 34 16923 -12 -1 +} {0006 0034 16923 -012} +test format-1.6 {integer formatting} { + format "%00*d" 6 34 +} {000034} + +# Printing negative numbers in hex or octal format depends on word +# length, so these tests are not portable. + +test format-1.7 {integer formatting} {nonPortable} { + format "%4x %4x %4x %4x" 6 34 16923 -12 -1 +} { 6 22 421b fffffff4} +test format-1.8 {integer formatting} {nonPortable} { + format "%#x %#X %#X %#x" 6 34 16923 -12 -1 +} {0x6 0X22 0X421B 0xfffffff4} +test format-1.9 {integer formatting} {nonPortable} { + format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1 +} { 0x6 0x22 0x421b 0xfffffff4} +test format-1.10 {integer formatting} {nonPortable} { + format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1 +} {0x6 0x22 0x421b 0xfffffff4 } +test format-1.11 {integer formatting} {nonPortable} { + format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1 +} {06 042 041033 037777777764 } + +test format-2.1 {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-2.2 {string formatting} { + format "%20s %20s %20c %20s" abcd {This is a very long test string.} 120 x +} { abcd This is a very long test string. x x} +test format-2.3 {string formatting} { + format "%.10s %.10s %c %.10s" abcd {This is a very long test string.} 120 x +} {abcd This is a x x} +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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996 +} {-10.0000 -9.99996 9.999960} +test format-3.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} { + format "%-020f %020f" -9.99996 -9.99996 9.99996 +} {-9.999960 -000000000009.999960} +test format-3.12 {e and f formats} { + format "%.0e %#.0e" -9.99996 -9.99996 9.99996 +} {-1e+01 -1.e+01} +test format-3.13 {e and f formats} { + format "%.0f %#.0f" -9.99996 -9.99996 9.99996 +} {-10 -10.} +test format-3.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} { + 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} { + 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} { + format "%.3g" 12341.0 +} {1.23e+04} +test format-4.2 {g-format} { + format "%.3G" 1234.12345 +} {1.23E+03} +test format-4.3 {g-format} { + format "%.3g" 123.412345 +} {123} +test format-4.4 {g-format} { + format "%.3g" 12.3412345 +} {12.3} +test format-4.5 {g-format} { + format "%.3g" 1.23412345 +} {1.23} +test format-4.6 {g-format} { + format "%.3g" 1.23412345 +} {1.23} +test format-4.7 {g-format} { + format "%.3g" .123412345 +} {0.123} +test format-4.8 {g-format} { + format "%.3g" .012341 +} {0.0123} +test format-4.9 {g-format} { + format "%.3g" .0012341 +} {0.00123} +test format-4.10 {g-format} { + format "%.3g" .00012341 +} {0.000123} +test format-4.11 {g-format} { + format "%.3g" .00001234 +} {1.23e-05} +test format-4.12 {g-format} { + format "%.4g" 9999.6 +} {1e+04} +test format-4.13 {g-format} { + format "%.4g" 999.96 +} {1000} +test format-4.14 {g-format} { + format "%.3g" 1.0 +} {1} +test format-4.15 {g-format} { + format "%.3g" .1 +} {0.1} +test format-4.16 {g-format} { + format "%.3g" .01 +} {0.01} +test format-4.17 {g-format} { + format "%.3g" .001 +} {0.001} +test format-4.18 {g-format} { + format "%.3g" .00001 +} {1e-05} +test format-4.19 {g-format} { + format "%#.3g" 1234.0 +} {1.23e+03} +test format-4.20 {g-format} { + format "%#.3G" 9999.5 +} {1.00E+04} + +test format-5.1 {floating-point zeroes} { + 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} { + 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} { + 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} { + format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0 +} {0e+00 0 0} +test format-5.5 {floating-point zeroes} { + format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0 +} {0.e+00 0. 0.} +test format-5.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} { + 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} { + 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} { + format "%*.*f" 12 3 12.345678901 +} { 12.346} +test format-6.2 {various syntax features} { + format "%0*.*f" 12 3 12.345678901 +} {00000012.346} +test format-6.3 {various syntax features} { + format "\*\t\\n" +} {* \n} + +test format-7.1 {error conditions} { + catch format +} 1 +test format-7.2 {error conditions} { + catch format msg + set msg +} {wrong # args: should be "format formatString ?arg arg ...?"} +test format-7.3 {error conditions} { + catch {format %*d} +} 1 +test format-7.4 {error conditions} { + catch {format %*d} msg + set msg +} {not enough arguments for all format specifiers} +test format-7.5 {error conditions} { + catch {format %*.*f 12} +} 1 +test format-7.6 {error conditions} { + catch {format %*.*f 12} msg + set msg +} {not enough arguments for all format specifiers} +test format-7.7 {error conditions} { + catch {format %*.*f 12 3} +} 1 +test format-7.8 {error conditions} { + catch {format %*.*f 12 3} msg + set msg +} {not enough arguments for all format specifiers} +test format-7.9 {error conditions} { + list [catch {format %*d x 3} msg] $msg +} {1 {expected integer but got "x"}} +test format-7.10 {error conditions} { + list [catch {format %*.*f 2 xyz 3} msg] $msg +} {1 {expected integer but got "xyz"}} +test format-7.11 {error conditions} { + catch {format %d 2a} +} 1 +test format-7.12 {error conditions} { + catch {format %d 2a} msg + set msg +} {expected integer but got "2a"} +test format-7.13 {error conditions} { + catch {format %c 2x} +} 1 +test format-7.14 {error conditions} { + catch {format %c 2x} msg + set msg +} {expected integer but got "2x"} +test format-7.15 {error conditions} { + catch {format %f 2.1z} +} 1 +test format-7.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} { + catch {format ab%} +} 1 +test format-7.18 {error conditions} { + catch {format ab% 12} msg + set msg +} {format string ended in middle of field specifier} +test format-7.19 {error conditions} { + catch {format %q x} +} 1 +test format-7.20 {error conditions} { + catch {format %q x} msg + set msg +} {bad field specifier "q"} +test format-7.21 {error conditions} { + catch {format %d} +} 1 +test format-7.22 {error conditions} { + catch {format %d} msg + set msg +} {not enough arguments for all format specifiers} +test format-7.23 {error conditions} { + catch {format "%d %d" 24 xyz} msg + set msg +} {expected integer but got "xyz"} + +test format-8.1 {long result} { + set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} + format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s} $a $a +} {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} + +test format-9.1 {"h" format specifier} {nonPortable} { + format %hd 0xffff +} -1 +test format-9.2 {"h" format specifier} {nonPortable} { + format %hx 0x10fff +} fff +test format-9.3 {"h" format specifier} {nonPortable} { + format %hd 0x10000 +} 0 + +test format-10.1 {XPG3 %$n specifiers} { + format {%2$d %1$d} 4 5 +} {5 4} +test format-10.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} { + 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} { + 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} { + 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} { + 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} { + 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} { + format {%2$*d %3$d} 1 10 4 +} { 4 4} +test format-10.9 {XPG3 %$n specifiers} { + format {%2$.*s %4$d} 1 5 abcdefghijklmnop 44 +} {abcde 44} +test format-10.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} { + list [catch {format {%2$*d} 4 5} msg] $msg +} {1 {"%n$" argument index out of range}} +test format-10.12 {XPG3 %$n specifiers} { + list [catch {format {%2$*d} 4 5 6} msg] $msg +} {0 { 6}} + +test format-11.1 {negative width specifiers} { + format "%*d" -47 25 +} {25} +test format-12.1 {tcl_precision fuzzy comparison} { + catch {unset a} + catch {unset b} + catch {unset c} + catch {unset d} + set a 0.0000000000001 + set b 0.00000000000001 + set c 0.00000000000000001 + set d [expr $a + $b + $c] + format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d +} {0.0000000000 0.000000000000 0.000000000000110 0.00000000000011001} +test format-12.2 {tcl_precision fuzzy comparison} { + catch {unset a} + catch {unset b} + catch {unset c} + catch {unset d} + set a 0.000000000001 + set b 0.000000000000005 + set c 0.0000000000000008 + set d [expr $a + $b + $c] + format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d +} {0.0000000000 0.000000000001 0.000000000001006 0.00000000000100580} +test format-12.3 {tcl_precision fuzzy comparison} { + catch {unset a} + catch {unset b} + catch {unset c} + set a 0.00000000000099 + set b 0.000000000000011 + set c [expr $a + $b] + format {%0.10f %0.12f %0.15f %0.17f} $c $c $c $c +} {0.0000000000 0.000000000001 0.000000000001001 0.00000000000100100} +test format-12.4 {tcl_precision fuzzy comparison} { + catch {unset a} + catch {unset b} + catch {unset c} + set a 0.444444444444 + set b 0.33333333333333 + set c [expr $a + $b] + format {%0.10f %0.12f %0.15f %0.16f} $c $c $c $c +} {0.7777777778 0.777777777777 0.777777777777330 0.7777777777773300} +test format-12.5 {tcl_precision fuzzy comparison} { + catch {unset a} + catch {unset b} + catch {unset c} + set a 0.444444444444 + set b 0.99999999999999 + set c [expr $a + $b] + format {%0.10f %0.12f %0.15f} $c $c $c +} {1.4444444444 1.444444444444 1.444444444443990} +test format-13.1 {testing MAX_FLOAT_SIZE for 0 and 1} { + format {%s} "" +} {} +test format-13.2 {testing MAX_FLOAT_SIZE for 0 and 1} { + format {%s} "a" +} {a} + +set a "0123456789" +set b "" +for {set i 0} {$i < 290} {incr i} { + append b $a +} +for {set i 290} {$i < 400} {incr i} { + test format-14.[expr $i -290] {testing MAX_FLOAT_SIZE} { + format {%s} $b + } $b + append b "x" +} + + +catch {unset a} +catch {unset b} +catch {unset c} +catch {unset d} +return diff --git a/tests/get.test b/tests/get.test new file mode 100644 index 0000000..5155b95 --- /dev/null +++ b/tests/get.test @@ -0,0 +1,91 @@ +# Commands covered: none +# +# This file contains a collection of tests for the procedures in the +# file tclGet.c. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) get.test 1.7 97/10/31 17:23:00 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test get-1.1 {Tcl_GetInt procedure} { + set x 44 + incr x { 22} +} {66} +test get-1.2 {Tcl_GetInt procedure} { + set x 44 + incr x -3 +} {41} +test get-1.3 {Tcl_GetInt procedure} { + set x 44 + incr x +8 +} {52} +test get-1.4 {Tcl_GetInt procedure} { + set x 44 + list [catch {incr x foo} msg] $msg +} {1 {expected integer but got "foo"}} +test get-1.5 {Tcl_GetInt procedure} { + set x 44 + list [catch {incr x {16 }} msg] $msg +} {0 60} +test get-1.6 {Tcl_GetInt procedure} { + set x 44 + list [catch {incr x {16 x}} msg] $msg +} {1 {expected integer but got "16 x"}} + +# The following tests are non-portable because they depend on +# word size. 18446744073709551614 + +if {0x80000000 > 0} { + test get-1.7 {Tcl_GetInt procedure} {nonPortable unixOnly} { + set x 44 + list [catch {incr x 18446744073709551616} msg] $msg $errorCode + } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} + test get-1.8 {Tcl_GetInt procedure} {nonPortable} { + set x 0 + list [catch {incr x 18446744073709551614} msg] $msg + } {0 -2} + test get-1.9 {Tcl_GetInt procedure} {nonPortable} { + set x 0 + list [catch {incr x +18446744073709551614} msg] $msg + } {0 -2} + test get-1.10 {Tcl_GetInt procedure} {nonPortable} { + set x 0 + list [catch {incr x -18446744073709551614} msg] $msg + } {0 2} +} else { + test get-1.7 {Tcl_GetInt procedure} {nonPortable unixOnly} { + set x 44 + list [catch {incr x 4294967296} msg] $msg $errorCode + } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} + test get-1.8 {Tcl_GetInt procedure} {nonPortable} { + set x 0 + list [catch {incr x 4294967294} msg] $msg + } {0 -2} + test get-1.9 {Tcl_GetInt procedure} {nonPortable} { + set x 0 + list [catch {incr x +4294967294} msg] $msg + } {0 -2} + test get-1.10 {Tcl_GetInt procedure} {nonPortable} { + set x 0 + list [catch {incr x -4294967294} msg] $msg + } {0 2} +} + +test get-2.1 {Tcl_GetInt procedure} { + format %g 1.23 +} {1.23} +test get-2.2 {Tcl_GetInt procedure} { + format %g { 1.23 } +} {1.23} +test get-2.3 {Tcl_GetInt procedure} { + list [catch {format %g clip} msg] $msg +} {1 {expected floating-point number but got "clip"}} +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}}} diff --git a/tests/history.test b/tests/history.test new file mode 100644 index 0000000..498fb2e --- /dev/null +++ b/tests/history.test @@ -0,0 +1,211 @@ +# Commands covered: history +# +# 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: @(#) history.test 1.15 97/08/13 14:37:10 + +if {[catch {history}]} { + puts stdout "This version of Tcl was built without the history command;\n" + puts stdout "history tests will be skipped.\n" + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +set num [history nextid] +history keep 3 +history add {set a 12345} +history add {set b [format {A test %s} string]} +history add {Another test} + +# "history event" + +test history-1.1 {event option} {history event -1} \ + {set b [format {A test %s} string]} +test history-1.2 {event option} {history event $num} \ + {set a 12345} +test history-1.3 {event option} {history event [expr $num+2]} \ + {Another test} +test history-1.4 {event option} {history event set} \ + {set b [format {A test %s} string]} +test history-1.5 {event option} {history e "* a*"} \ + {set a 12345} +test history-1.6 {event option} {catch {history event *gorp} msg} 1 +test history-1.7 {event option} { + catch {history event *gorp} msg + set msg +} {no event matches "*gorp"} +test history-1.8 {event option} {history event} \ + {set b [format {A test %s} string]} +test history-1.9 {event option} {catch {history event 123 456} msg} 1 +test history-1.10 {event option} { + catch {history event 123 456} msg + set msg +} {wrong # args: should be "history event ?event?"} + +# "history redo" + +set a 0 +history redo -2 +test history-2.1 {redo option} {set a} 12345 +set b 0 +history redo +test history-2.2 {redo option} {set b} {A test string} +test history-2.3 {redo option} {catch {history redo -3 -4}} 1 +test history-2.4 {redo option} { + catch {history redo -3 -4} msg + set msg +} {wrong # args: should be "history redo ?event?"} + +# "history add" + +history add "set a 444" exec +test history-3.1 {add option} {set a} 444 +test history-3.2 {add option} {catch {history add "set a 444" execGorp}} 1 +test history-3.3 {add option} { + catch {history add "set a 444" execGorp} msg + set msg +} {bad argument "execGorp": should be "exec"} +test history-3.4 {add option} {catch {history add "set a 444" a} msg} 1 +test history-3.5 {add option} { + catch {history add "set a 444" a} msg + set msg +} {bad argument "a": should be "exec"} +history add "set a 555" e +test history-3.6 {add option} {set a} 555 +history add "set a 666" +test history-3.7 {add option} {set a} 555 +test history-3.8 {add option} {catch {history add "set a 666" e f} msg} 1 +test history-3.9 {add option} { + catch {history add "set a 666" e f} msg + set msg +} {wrong # args: should be "history add event ?exec?"} + +# "history change" + +history change "A test value" +test history-4.1 {change option} {history event [expr {[history n]-1}]} \ + "A test value" +history ch "Another test" -1 +test history-4.2 {change option} {history e} "Another test" +test history-4.3 {change option} {history event [expr {[history n]-1}]} \ + "A test value" +test history-4.4 {change option} {catch {history change Foo 4 10}} 1 +test history-4.5 {change option} { + catch {history change Foo 4 10} msg + set msg +} {wrong # args: should be "history change newValue ?event?"} +test history-4.6 {change option} { + catch {history change Foo [expr {[history n]-4}]} +} 1 +set num [expr {[history n]-4}] +test history-4.7 {change option} { + catch {history change Foo $num} msg + set msg +} "event \"$num\" is too far in the past" + +# "history info" + +set num [history n] +history add set\ a\ {b\nc\ d\ e} +history add {set b 1234} +history add set\ c\ {a\nb\nc} +test history-5.1 {info option} {history info} [format {%6d set a {b + c d e} +%6d set b 1234 +%6d set c {a + b + c}} $num [expr $num+1] [expr $num+2]] +test history-5.2 {info option} {history i 2} [format {%6d set b 1234 +%6d set c {a + b + c}} [expr $num+1] [expr $num+2]] +test history-5.3 {info option} {catch {history i 2 3}} 1 +test history-5.4 {info option} { + catch {history i 2 3} msg + set msg +} {wrong # args: should be "history info ?count?"} +test history-5.5 {info option} {history} [format {%6d set a {b + c d e} +%6d set b 1234 +%6d set c {a + b + c}} $num [expr $num+1] [expr $num+2]] + +# "history keep" + +history add "foo1" +history add "foo2" +history add "foo3" +history keep 2 +test history-6.1 {keep option} {history event [expr [history n]-1]} foo3 +test history-6.2 {keep option} {history event -1} foo2 +test history-6.3 {keep option} {catch {history event -3}} 1 +test history-6.4 {keep option} { + catch {history event -3} msg + set msg +} {event "-3" is too far in the past} +history k 5 +test history-6.5 {keep option} {history event -1} foo2 +test history-6.6 {keep option} {history event -2} {} +test history-6.7 {keep option} {history event -3} {} +test history-6.8 {keep option} {history event -4} {} +test history-6.9 {keep option} {catch {history event -5}} 1 +test history-6.10 {keep option} {catch {history keep 4 6}} 1 +test history-6.11 {keep option} { + catch {history keep 4 6} msg + set msg +} {wrong # args: should be "history keep ?count?"} +test history-6.12 {keep option} {catch {history keep}} 0 +test history-6.13 {keep option} { + history keep +} {5} +test history-6.14 {keep option} {catch {history keep -3}} 1 +test history-6.15 {keep option} { + catch {history keep -3} msg + set msg +} {illegal keep count "-3"} +test history-6.16 {keep option} { + catch {history keep butter} msg + set msg +} {illegal keep count "butter"} + +# "history nextid" + +set num [history n] +history add "Testing" +history add "Testing2" +test history-7.1 {nextid option} {history event} "Testing" +test history-7.2 {nextid option} {history next} [expr $num+2] +test history-7.3 {nextid option} {catch {history nextid garbage}} 1 +test history-7.4 {nextid option} { + catch {history nextid garbage} msg + set msg +} {wrong # args: should be "history nextid"} + +# "history clear" + +set num [history n] +history add "Testing" +history add "Testing2" +test history-8.1 {clear option} {catch {history clear junk}} 1 +test history-8.2 {clear option} {history clear} {} +history add "Testing" +test history-8.3 {clear option} {history} { 1 Testing} + +# miscellaneous + +test history-9.1 {miscellaneous} {catch {history gorp} msg} 1 +test history-9.2 {miscellaneous} { + catch {history gorp} msg + set msg +} {bad option "gorp": must be add, change, clear, event, info, keep, nextid, or redo} + diff --git a/tests/http.test b/tests/http.test new file mode 100644 index 0000000..2770e13 --- /dev/null +++ b/tests/http.test @@ -0,0 +1,409 @@ +# Commands covered: http::config, http::geturl, http::wait, http::reset +# +# This file contains a collection of tests for the http script library. +# Sourcing this file into Tcl runs the tests and +# 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: @(#) http2.test 1.8 97/08/13 11:16:50 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {[catch {package require http 2.0}]} { + if {[info exist http2]} { + catch {puts stderr "Cannot load http 2.0 package"} + return + } else { + catch {puts stderr "Running http 2.0 tests in slave interp"} + set interp [interp create http2] + $interp eval [list set http2 "running"] + $interp eval [list source [info script]] + interp delete $interp + return + } +} + +############### The httpd_ procedures implement a stub http server. ######## +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 bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" +proc httpdRespond { sock } { + global httpd bindata port + upvar #0 httpd$sock data + + if {[string match *binary* $data(url)]} { + set html "$bindata[info hostname]:$port$data(url)" + set type application/octet-stream + } else { + set type text/html + + set html "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>$data(proto) $data(url)</h2> +" + if {[info exists data(query)] && [string length $data(query)]} { + append html "<h2>Query</h2>\n<dl>\n" + foreach {key value} [split $data(query) &=] { + append html "<dt>$key<dd>$value\n" + } + append html </dl>\n + } + append html </body></html> + } + + if {$data(proto) == "HEAD"} { + puts $sock "HTTP/1.0 200 OK" + } else { + puts $sock "HTTP/1.0 200 Data follows" + } + puts $sock "Date: [clock format [clock clicks]]" + puts $sock "Content-Type: $type" + puts $sock "Content-Length: [string length $html]" + puts $sock "" + if {$data(proto) != "HEAD"} { + fconfigure $sock -translation binary + puts -nonewline $sock $html + } + httpd_log $sock Done "" + httpdSockDone $sock +} +##################### end server ########################### + +set port 8010 +if [catch {httpd_init $port} listen] { + puts stderr "Cannot start http server, http test skipped" + unset port + return +} + +test http-1.1 {http::config} { + http::config +} {-accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 2.0}} + +test http-1.2 {http::config} { + http::config -proxyfilter +} http::ProxyRequired + +test http-1.3 {http::config} { + catch {http::config -junk} +} 1 + +test http-1.4 {http::config} { + set savedconf [http::config] + http::config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite" + set x [http::config] + eval http::config $savedconf + set x +} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}} + +test http-1.5 {http::config} { + catch {http::config -proxyhost {} -junk 8080} +} 1 + +test http-2.1 {http::reset} { + catch {http::reset http#1} +} 0 + +test http-3.1 {http::geturl} { + catch {http::geturl -bogus flag} +} 1 +test http-3.2 {http::geturl} { + catch {http::geturl http:junk} err + set err +} {Unsupported URL: http:junk} + +set url [info hostname]:$port +test http-3.3 {http::geturl} { + set token [http::geturl $url] + http::data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET /</h2> +</body></html>" + +set tail /a/b/c +set url [info hostname]:$port/a/b/c +set binurl [info hostname]:$port/binary + +test http-3.4 {http::geturl} { + set token [http::geturl $url] + http::data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET $tail</h2> +</body></html>" + +proc selfproxy {host} { + global port + return [list [info hostname] $port] +} +test http-3.5 {http::geturl} { + http::config -proxyfilter selfproxy + set token [http::geturl $url] + http::config -proxyfilter http::ProxyRequired + http::data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET http://$url</h2> +</body></html>" + +test http-3.6 {http::geturl} { + http::config -proxyfilter bogus + set token [http::geturl $url] + http::config -proxyfilter http::ProxyRequired + http::data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET $tail</h2> +</body></html>" + +test http-3.7 {http::geturl} { + set token [http::geturl $url -headers {Pragma no-cache}] + http::data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET $tail</h2> +</body></html>" + +test http-3.8 {http::geturl} { + set token [http::geturl $url -query Name=Value&Foo=Bar] + http::data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>POST $tail</h2> +<h2>Query</h2> +<dl> +<dt>Name<dd>Value +<dt>Foo<dd>Bar +</dl> +</body></html>" + +test http-3.9 {http::geturl} { + set token [http::geturl $url -validate 1] + http::code $token +} "HTTP/1.0 200 OK" + + +test http-4.1 {http::Event} { + set token [http::geturl $url] + upvar #0 $token data + array set meta $data(meta) + expr ($data(totalsize) == $meta(Content-Length)) +} 1 + +test http-4.2 {http::Event} { + set token [http::geturl $url] + upvar #0 $token data + array set meta $data(meta) + string compare $data(type) [string trim $meta(Content-Type)] +} 0 + +test http-4.3 {http::Event} { + set token [http::geturl $url] + http::code $token +} {HTTP/1.0 200 Data follows} + +test http-4.4 {http::Event} { + set out [open testfile w] + set token [http::geturl $url -channel $out] + close $out + set in [open testfile] + set x [read $in] + close $in + file delete testfile + set x +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET $tail</h2> +</body></html>" + +test http-4.5 {http::Event} { + set out [open testfile w] + set token [http::geturl $url -channel $out] + close $out + upvar #0 $token data + file delete testfile + expr $data(currentsize) == $data(totalsize) +} 1 + +test http-4.6 {http::Event} { + set out [open testfile w] + set token [http::geturl $binurl -channel $out] + close $out + set in [open testfile] + fconfigure $in -translation binary + set x [read $in] + close $in + file delete testfile + set x +} "$bindata$binurl" + +proc myProgress {token total current} { + global progress httpLog + if {[info exists httpLog] && $httpLog} { + puts "progress $total $current" + } + set progress [list $total $current] +} +if 0 { + # This test hangs on Windows95 because the client never gets EOF + set httpLog 1 + test http-4.6 {http::Event} { + set token [http::geturl $url -blocksize 50 -progress myProgress] + set progress + } {111 111} +} +test http-4.7 {http::Event} { + set token [http::geturl $url -progress myProgress] + set progress +} {111 111} +test http-4.8 {http::Event} { + set token [http::geturl $url] + http::status $token +} {ok} +test http-4.9 {http::Event} { + set token [http::geturl $url -progress myProgress] + http::code $token +} {HTTP/1.0 200 Data follows} +test http-4.10 {http::Event} { + set token [http::geturl $url -progress myProgress] + http::size $token +} {111} +test http-4.11 {http::Event} { + set token [http::geturl $url -timeout 1 -command {#}] + http::reset $token + http::status $token +} {reset} +test http-4.12 {http::Event} { + set token [http::geturl $url -timeout 1 -command {#}] + http::wait $token + http::status $token +} {timeout} + +test http-5.1 {http::formatQuery} { + http::formatQuery name1 value1 name2 "value two" +} {name1=value1&name2=value+two} + +test http-5.2 {http::formatQuery} { + http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 +} {name1=%7ebwelch&name2=%a1%a2%a2} + +test http-5.3 {http::formatQuery} { + http::formatQuery lines "line1\nline2\nline3" +} {lines=line1%0d%0aline2%0d%0aline3} + +test http-6.1 {http::ProxyRequired} { + http::config -proxyhost [info hostname] -proxyport $port + set token [http::geturl $url] + http::wait $token + http::config -proxyhost {} -proxyport {} + upvar #0 $token data + set data(body) +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET http://$url</h2> +</body></html>" + +unset url +unset port +close $listen diff --git a/tests/httpold.test b/tests/httpold.test new file mode 100644 index 0000000..5e9ba0c --- /dev/null +++ b/tests/httpold.test @@ -0,0 +1,411 @@ +# Commands covered: http_config, http_get, http_wait, http_reset +# +# This file contains a collection of tests for the http script library. +# Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) http.test 1.12 97/07/29 17:04:12 + +if {[string compare test [info procs test]] == 1} then {source defs} + + +if {[catch {package require http 1.0}]} { + if {[info exist httpold]} { + catch {puts stderr "Cannot load http 1.0 package"} + return + } else { + catch {puts stderr "Running http 1.0 tests in slave interp"} + set interp [interp create httpold] + $interp eval [list set httpold "running"] + $interp eval [list source [info script]] + interp delete $interp + return + } +} + +############### The httpd_ procedures implement a stub http server. ######## +proc httpd_init {{port 8015}} { + socket -server httpdAccept $port +} +proc httpd_log {args} { + global httpLog + if {[info exists httpLog] && $httpLog} { + puts stderr "httpd: [join $args { }]" + } +} +array set httpdErrors { + 204 {No Content} + 400 {Bad Request} + 404 {Not Found} + 503 {Service Unavailable} + 504 {Service Temporarily Unavailable} + } + +proc httpdError {sock code args} { + global httpdErrors + puts $sock "$code $httpdErrors($code)" + httpd_log "error: [join $args { }]" +} +proc httpdAccept {newsock ipaddr port} { + global httpd + upvar #0 httpd$newsock data + + fconfigure $newsock -blocking 0 -translation {auto crlf} + httpd_log $newsock Connect $ipaddr $port + set data(ipaddr) $ipaddr + fileevent $newsock readable [list httpdRead $newsock] +} + +# read data from a client request + +proc httpdRead { sock } { + upvar #0 httpd$sock data + + set readCount [gets $sock line] + if {![info exists data(state)]} { + if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \ + $line x data(proto) data(url) data(query)] { + set data(state) mime + httpd_log $sock Query $line + } else { + httpdError $sock 400 + httpd_log $sock Error "bad first line:$line" + httpdSockDone $sock + } + return + } + + # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1 + + set state [string compare $readCount 0],$data(state),$data(proto) + httpd_log $sock $state + switch -- $state { + -1,mime,HEAD - + -1,mime,GET - + -1,mime,POST { + # gets would block + return + } + 0,mime,HEAD - + 0,mime,GET - + 0,query,POST { httpdRespond $sock } + 0,mime,POST { set data(state) query } + 1,mime,HEAD - + 1,mime,POST - + 1,mime,GET { + if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] { + set data(mime,[string tolower $key]) $value + } + } + 1,query,POST { + append data(query) $line + httpdRespond $sock + } + default { + if [eof $sock] { + httpd_log $sock Error "unexpected eof on <$data(url)> request" + } else { + httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>" + } + httpdError $sock 404 + httpdSockDone $sock + } + } +} +proc httpdSockDone { sock } { +upvar #0 httpd$sock data + unset data + catch {close $sock} +} + +# Respond to the query. + +set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" +proc httpdRespond { sock } { + global httpd bindata port + upvar #0 httpd$sock data + + if {[string match *binary* $data(url)]} { + set html "$bindata[info hostname]:$port$data(url)" + set type application/octet-stream + } else { + set type text/html + + set html "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>$data(proto) $data(url)</h2> +" + if {[info exists data(query)] && [string length $data(query)]} { + append html "<h2>Query</h2>\n<dl>\n" + foreach {key value} [split $data(query) &=] { + append html "<dt>$key<dd>$value\n" + } + append html </dl>\n + } + append html </body></html> + } + + if {$data(proto) == "HEAD"} { + puts $sock "HTTP/1.0 200 OK" + } else { + puts $sock "HTTP/1.0 200 Data follows" + } + puts $sock "Date: [clock format [clock clicks]]" + puts $sock "Content-Type: $type" + puts $sock "Content-Length: [string length $html]" + puts $sock "" + if {$data(proto) != "HEAD"} { + fconfigure $sock -translation binary + puts -nonewline $sock $html + } + httpd_log $sock Done "" + httpdSockDone $sock +} +##################### end server ########################### + +set port 8010 +if [catch {httpd_init $port} listen] { + puts stderr "Cannot start http server, http test skipped" + unset port + return +} + +test http-1.1 {http_config} { + http_config +} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}} + +test http-1.2 {http_config} { + http_config -proxyfilter +} httpProxyRequired + +test http-1.3 {http_config} { + catch {http_config -junk} +} 1 + +test http-1.4 {http_config} { + http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite" + set x [http_config] + http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \ + -useragent "Tcl http client package 1.0" + set x +} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}} + +test http-1.5 {http_config} { + catch {http_config -proxyhost {} -junk 8080} +} 1 + +test http-2.1 {http_reset} { + catch {http_reset http#1} +} 0 + +test http-3.1 {http_get} { + catch {http_get -bogus flag} +} 1 +test http-3.2 {http_get} { + catch {http_get http:junk} err + set err +} {Unsupported URL: http:junk} + +set url [info hostname]:$port +test http-3.3 {http_get} { + set token [http_get $url] + http_data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET /</h2> +</body></html>" + +set tail /a/b/c +set url [info hostname]:$port/a/b/c +set binurl [info hostname]:$port/binary + +test http-3.4 {http_get} { + set token [http_get $url] + http_data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET $tail</h2> +</body></html>" + +proc selfproxy {host} { + global port + return [list [info hostname] $port] +} +test http-3.5 {http_get} { + http_config -proxyfilter selfproxy + set token [http_get $url] + http_config -proxyfilter httpProxyRequired + http_data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET http://$url</h2> +</body></html>" + +test http-3.6 {http_get} { + http_config -proxyfilter bogus + set token [http_get $url] + http_config -proxyfilter httpProxyRequired + http_data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET $tail</h2> +</body></html>" + +test http-3.7 {http_get} { + set token [http_get $url -headers {Pragma no-cache}] + http_data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET $tail</h2> +</body></html>" + +test http-3.8 {http_get} { + set token [http_get $url -query Name=Value&Foo=Bar] + http_data $token +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>POST $tail</h2> +<h2>Query</h2> +<dl> +<dt>Name<dd>Value +<dt>Foo<dd>Bar +</dl> +</body></html>" + +test http-3.9 {http_get} { + set token [http_get $url -validate 1] + http_code $token +} "HTTP/1.0 200 OK" + + +test http-4.1 {httpEvent} { + set token [http_get $url] + upvar #0 $token data + array set meta $data(meta) + expr ($data(totalsize) == $meta(Content-Length)) +} 1 + +test http-4.2 {httpEvent} { + set token [http_get $url] + upvar #0 $token data + array set meta $data(meta) + string compare $data(type) [string trim $meta(Content-Type)] +} 0 + +test http-4.3 {httpEvent} { + set token [http_get $url] + http_code $token +} {HTTP/1.0 200 Data follows} + +test http-4.4 {httpEvent} { + set out [open testfile w] + set token [http_get $url -channel $out] + close $out + set in [open testfile] + set x [read $in] + close $in + file delete testfile + set x +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET $tail</h2> +</body></html>" + +test http-4.5 {httpEvent} { + set out [open testfile w] + set token [http_get $url -channel $out] + close $out + upvar #0 $token data + file delete testfile + expr $data(currentsize) == $data(totalsize) +} 1 + +test http-4.6 {httpEvent} { + set out [open testfile w] + set token [http_get $binurl -channel $out] + close $out + set in [open testfile] + fconfigure $in -translation binary + set x [read $in] + close $in + file delete testfile + set x +} "$bindata$binurl" + +proc myProgress {token total current} { + global progress httpLog + if {[info exists httpLog] && $httpLog} { + puts "progress $total $current" + } + set progress [list $total $current] +} +if 0 { + # This test hangs on Windows95 because the client never gets EOF + set httpLog 1 + test http-4.6 {httpEvent} { + set token [http_get $url -blocksize 50 -progress myProgress] + set progress + } {111 111} +} +test http-4.7 {httpEvent} { + set token [http_get $url -progress myProgress] + set progress +} {111 111} +test http-4.8 {httpEvent} { + set token [http_get $url] + http_status $token +} {ok} +test http-4.9 {httpEvent} { + set token [http_get $url -progress myProgress] + http_code $token +} {HTTP/1.0 200 Data follows} +test http-4.10 {httpEvent} { + set token [http_get $url -progress myProgress] + http_size $token +} {111} +test http-4.11 {httpEvent} { + set token [http_get $url -timeout 1 -command {#}] + http_reset $token + http_status $token +} {reset} +test http-4.12 {httpEvent} { + update + set token [http_get $url -timeout 1 -command {#}] + update + http_status $token +} {timeout} + +test http-5.1 {http_formatQuery} { + http_formatQuery name1 value1 name2 "value two" +} {name1=value1&name2=value+two} + +test http-5.2 {http_formatQuery} { + http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 +} {name1=%7ebwelch&name2=%a1%a2%a2} + +test http-5.3 {http_formatQuery} { + http_formatQuery lines "line1\nline2\nline3" +} {lines=line1%0d%0aline2%0d%0aline3} + +test http-6.1 {httpProxyRequired} { + update + http_config -proxyhost [info hostname] -proxyport $port + set token [http_get $url] + http_wait $token + http_config -proxyhost {} -proxyport {} + upvar #0 $token data + set data(body) +} "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>GET http://$url</h2> +</body></html>" + +unset url +unset port +close $listen diff --git a/tests/if-old.test b/tests/if-old.test new file mode 100644 index 0000000..abade28 --- /dev/null +++ b/tests/if-old.test @@ -0,0 +1,156 @@ +# Commands covered: if +# +# This file contains the original set of tests for Tcl's if command. +# Since the if command is now compiled, a new set of tests covering +# the new implementation is in the file "if.test". Sourcing this file +# into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) if-old.test 1.10 96/10/22 11:33:06 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test if-old-1.1 {taking proper branch} { + set a {} + if 0 {set a 1} else {set a 2} + set a +} 2 +test if-old-1.2 {taking proper branch} { + set a {} + if 1 {set a 1} else {set a 2} + set a +} 1 +test if-old-1.3 {taking proper branch} { + set a {} + if 1<2 {set a 1} + set a +} 1 +test if-old-1.4 {taking proper branch} { + set a {} + if 1>2 {set a 1} + set a +} {} +test if-old-1.5 {taking proper branch} { + set a {} + if 0 {set a 1} else {} + set a +} {} +test if-old-1.5 {taking proper branch} { + set a {} + if 0 {set a 1} elseif 1 {set a 2} elseif 1 {set a 3} else {set a 4} + set a +} {2} +test if-old-1.6 {taking proper branch} { + set a {} + if 0 {set a 1} elseif 0 {set a 2} elseif 1 {set a 3} else {set a 4} + set a +} {3} +test if-old-1.7 {taking proper branch} { + set a {} + if 0 {set a 1} elseif 0 {set a 2} elseif 0 {set a 3} else {set a 4} + set a +} {4} +test if-old-1.8 {taking proper branch, multiline test expr} { + set a {} + if {($tcl_platform(platform) != "foobar1") && \ + ($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4} + set a +} {3} + + +test if-old-2.1 {optional then-else args} { + set a 44 + if 0 then {set a 1} elseif 0 then {set a 3} else {set a 2} + set a +} 2 +test if-old-2.2 {optional then-else args} { + set a 44 + if 1 then {set a 1} else {set a 2} + set a +} 1 +test if-old-2.3 {optional then-else args} { + set a 44 + if 0 {set a 1} else {set a 2} + set a +} 2 +test if-old-2.4 {optional then-else args} { + set a 44 + if 1 {set a 1} else {set a 2} + set a +} 1 +test if-old-2.5 {optional then-else args} { + set a 44 + if 0 then {set a 1} {set a 2} + set a +} 2 +test if-old-2.6 {optional then-else args} { + set a 44 + if 1 then {set a 1} {set a 2} + set a +} 1 +test if-old-2.7 {optional then-else args} { + set a 44 + if 0 then {set a 1} else {set a 2} + set a +} 2 +test if-old-2.8 {optional then-else args} { + set a 44 + if 0 then {set a 1} elseif 0 {set a 2} elseif 0 {set a 3} {set a 4} + set a +} 4 + +test if-old-3.1 {return value} { + if 1 then {set a 22; concat abc} +} abc +test if-old-3.2 {return value} { + if 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi} +} def +test if-old-3.3 {return value} { + if 0 then {set a 22; concat abc} else {concat def} +} def +test if-old-3.4 {return value} { + if 0 then {set a 22; concat abc} +} {} +test if-old-3.5 {return value} { + if 0 then {set a 22; concat abc} elseif 0 {concat def} +} {} + +test if-old-4.1 {error conditions} { + list [catch {if} msg] $msg +} {1 {wrong # args: no expression after "if" argument}} +test if-old-4.2 {error conditions} { + list [catch {if {[error "error in condition"]} foo} msg] $msg +} {1 {error in condition}} +test if-old-4.3 {error conditions} { + list [catch {if 2} msg] $msg +} {1 {wrong # args: no script following "2" argument}} +test if-old-4.4 {error conditions} { + list [catch {if 2 then} msg] $msg +} {1 {wrong # args: no script following "then" argument}} +test if-old-4.5 {error conditions} { + list [catch {if 2 the} msg] $msg +} {1 {invalid command name "the"}} +test if-old-4.6 {error conditions} { + list [catch {if 2 then {[error "error in then clause"]}} msg] $msg +} {1 {error in then clause}} +test if-old-4.7 {error conditions} { + list [catch {if 0 then foo elseif} msg] $msg +} {1 {wrong # args: no expression after "elseif" argument}} +test if-old-4.8 {error conditions} { + list [catch {if 0 then foo elsei} msg] $msg +} {1 {invalid command name "elsei"}} +test if-old-4.9 {error conditions} { + list [catch {if 0 then foo elseif 0 bar else} msg] $msg +} {1 {wrong # args: no script following "else" argument}} +test if-old-4.10 {error conditions} { + list [catch {if 0 then foo elseif 0 bar els} msg] $msg +} {1 {invalid command name "els"}} +test if-old-4.11 {error conditions} { + list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg +} {1 {error in else clause}} diff --git a/tests/if.test b/tests/if.test new file mode 100644 index 0000000..03b8bcd --- /dev/null +++ b/tests/if.test @@ -0,0 +1,505 @@ +# Commands covered: if +# +# 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: @(#) if.test 1.9 97/07/02 16:40:58 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Basic "if" operation. + +catch {unset a} +test if-1.1 {TclCompileIfCmd: missing if/elseif test} { + list [catch {if} msg] $msg +} {1 {wrong # args: no expression after "if" argument}} +test if-1.2 {TclCompileIfCmd: error in if/elseif test} { + list [catch {if {[error "error in condition"]} foo} msg] $msg +} {1 {error in condition}} +test if-1.3 {TclCompileIfCmd: error in if/elseif test} { + list [catch {if {1+}} msg] $msg $errorInfo +} {1 {syntax error in expression "1+"} {syntax error in expression "1+" + ("if" test expression) + while compiling +"if {1+}"}} +test if-1.4 {TclCompileIfCmd: if/elseif test in braces} { + set a {} + if {1<2} {set a 1} + set a +} {1} +test if-1.5 {TclCompileIfCmd: if/elseif test not in braces} { + set a {} + if 1<2 {set a 1} + set a +} {1} +test if-1.6 {TclCompileIfCmd: multiline test expr} { + set a {} + if {($tcl_platform(platform) != "foobar1") && \ + ($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4} + set a +} 3 +test if-1.7 {TclCompileIfCmd: "then" after if/elseif test} { + set a {} + if 4>3 then {set a 1} + set a +} {1} +test if-1.8 {TclCompileIfCmd: keyword other than "then" after if/elseif test} { + set a {} + catch {if 1<2 therefore {set a 1}} msg + set msg +} {invalid command name "therefore"} +test if-1.9 {TclCompileIfCmd: missing "then" body} { + set a {} + catch {if 1<2 then} msg + set msg +} {wrong # args: no script following "then" argument} +test if-1.10 {TclCompileIfCmd: error in "then" body} { + set a {} + list [catch {if {$a!="xxx"} then {set}} msg] $msg $errorInfo +} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("if" then script line 1) + while compiling +"if {$a!="xxx"} then {set}"}} +test if-1.11 {TclCompileIfCmd: error in "then" body} { + list [catch {if 2 then {[error "error in then clause"]}} msg] $msg +} {1 {error in then clause}} +test if-1.12 {TclCompileIfCmd: "then" body in quotes} { + set a {} + if 27>17 "append a x" + set a +} {x} +test if-1.13 {TclCompileIfCmd: computed "then" body} { + catch {unset x1} + catch {unset x2} + set a {} + set x1 {append a x1} + set x2 {; append a x2} + set a {} + if 1 $x1$x2 + set a +} {x1x2} +test if-1.14 {TclCompileIfCmd: taking proper branch} { + set a {} + if 1<2 {set a 1} + set a +} 1 +test if-1.15 {TclCompileIfCmd: taking proper branch} { + set a {} + if 1>2 {set a 1} + set a +} {} +test if-1.16 {TclCompileIfCmd: test jumpFalse instruction replacement after long "then" body} { + catch {unset i} + set a {} + if 1<2 { + set a 1 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 2 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 3 + } + set a +} 3 +test if-1.17 {TclCompileIfCmd: if/elseif test in quotes} { + set a {} + list [catch {if {"0 < 3"} {set a 1}} msg] $msg +} {1 {expected boolean value but got "0 < 3"}} + + +test if-2.1 {TclCompileIfCmd: "elseif" after if/elseif test} { + set a {} + if 3>4 {set a 1} elseif 1 {set a 2} + set a +} {2} +# Since "else" is optional, the "elwood" below is treated as a command. +# But then there shouldn't be any additional argument words for the "if". +test if-2.2 {TclCompileIfCmd: keyword other than "elseif"} { + set a {} + catch {if 1<2 {set a 1} elwood {set a 2}} msg + set msg +} {wrong # args: extra words after "else" clause in "if" command} +test if-2.3 {TclCompileIfCmd: missing expression after "elseif"} { + set a {} + catch {if 1<2 {set a 1} elseif} msg + set msg +} {wrong # args: no expression after "elseif" argument} +test if-2.4 {TclCompileIfCmd: error in expression after "elseif"} { + set a {} + list [catch {if 3>4 {set a 1} elseif {1>}} msg] $msg $errorInfo +} {1 {syntax error in expression "1>"} {syntax error in expression "1>" + ("if" test expression) + while compiling +"if 3>4 {set a 1} elseif {1>}"}} +test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long "elseif" body} { + catch {unset i} + set a {} + if 1>2 { + set a 1 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 2 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 3 + } elseif 1<2 then { #; this if arm should be taken + set a 4 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 5 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 6 + } + set a +} 6 + +test if-3.1 {TclCompileIfCmd: "else" clause} { + set a {} + if 3>4 {set a 1} elseif {$a == "foo"} {set a 2} else {set a 3} + set a +} 3 +# Since "else" is optional, the "elsex" below is treated as a command. +# But then there shouldn't be any additional argument words for the "if". +test if-3.2 {TclCompileIfCmd: keyword other than "else"} { + set a {} + catch {if 1<2 then {set a 1} elsex {set a 2}} msg + set msg +} {wrong # args: extra words after "else" clause in "if" command} +test if-3.3 {TclCompileIfCmd: missing body after "else"} { + set a {} + catch {if 2<1 {set a 1} else} msg + set msg +} {wrong # args: no script following "else" argument} +test if-3.4 {TclCompileIfCmd: error compiling body after "else"} { + set a {} + catch {if 2<1 {set a 1} else {set}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("if" else script line 1) + while compiling +"if 2<1 {set a 1} else {set}"} +test if-3.5 {TclCompileIfCmd: extra arguments after "else" argument} { + set a {} + catch {if 2<1 {set a 1} else {set a 2} or something} msg + set msg +} {wrong # args: extra words after "else" clause in "if" command} +# The following test also checks whether contained loops and other +# commands are properly relocated because a short jump must be replaced +# by a "long distance" one. +test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long "else" clause} { + catch {unset i} + set a {} + if 1>2 { + set a 1 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 2 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 3 + } elseif 1==2 then { #; this if arm should be taken + set a 4 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 5 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 6 + } else { + set a 7 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 8 + while {$a != "xxx"} { + break; + while {$i >= 0} { + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + if {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 9 + } + set a +} 9 + +test if-4.1 {TclCompileIfCmd: "if" command result} { + set a {} + set a [if 3<4 {set i 27}] + set a +} 27 +test if-4.2 {TclCompileIfCmd: "if" command result} { + set a {} + set a [if 3>4 {set i 27}] + set a +} {} +test if-4.3 {TclCompileIfCmd: "if" command result} { + set a {} + set a [if 0 {set i 1} elseif 1 {set i 2}] + set a +} 2 +test if-4.4 {TclCompileIfCmd: "if" command result} { + set a {} + set a [if 0 {set i 1} elseif 0 {set i 2} elseif 2>5 {set i 3} else {set i 4}] + set a +} 4 +test if-4.5 {TclCompileIfCmd: return value} { + if 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi} +} def + +# Check "if" and computed command names. + +test if-5.1 {if and computed command names} { + set i 0 + set z if + $z 1 { + set i 1 + } + set i +} 1 diff --git a/tests/incr-old.test b/tests/incr-old.test new file mode 100644 index 0000000..8fbd89f --- /dev/null +++ b/tests/incr-old.test @@ -0,0 +1,89 @@ +# Commands covered: incr +# +# This file contains the original set of tests for Tcl's incr command. +# Since the incr command is now compiled, a new set of tests covering +# the new implementation is in the file "incr.test". Sourcing this file +# into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) incr-old.test 1.11 96/11/19 16:56:23 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset x} + +test incr-old-1.1 {basic incr operation} { + set x 23 + list [incr x] $x +} {24 24} +test incr-old-1.2 {basic incr operation} { + set x 106 + list [incr x -5] $x +} {101 101} +test incr-old-1.3 {basic incr operation} { + set x " -106" + list [incr x 1] $x +} {-105 -105} +test incr-old-1.3 {basic incr operation} { + set x " +106" + list [incr x 1] $x +} {107 107} + +test incr-old-2.1 {incr errors} { + list [catch incr msg] $msg +} {1 {wrong # args: should be "incr varName ?increment?"}} +test incr-old-2.2 {incr errors} { + list [catch {incr a b c} msg] $msg +} {1 {wrong # args: should be "incr varName ?increment?"}} +test incr-old-2.3 {incr errors} { + catch {unset x} + list [catch {incr x} msg] $msg $errorInfo +} {1 {can't read "x": no such variable} {can't read "x": no such variable + (reading value of variable to increment) + invoked from within +"incr x"}} +test incr-old-2.4 {incr errors} { + set x abc + list [catch {incr x} msg] $msg $errorInfo +} {1 {expected integer but got "abc"} {expected integer but got "abc" + while executing +"incr x"}} +test incr-old-2.5 {incr errors} { + set x 123 + list [catch {incr x 1a} msg] $msg $errorInfo +} {1 {expected integer but got "1a"} {expected integer but got "1a" + while executing +"incr x 1a"}} +test incr-old-2.6 {incr errors} { + proc readonly args {error "variable is read-only"} + set x 123 + trace var x w readonly + list [catch {incr x 1} msg] $msg $errorInfo +} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only + while executing +"incr x 1"}} +catch {unset x} +test incr-old-2.7 {incr errors} { + set x - + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got "-"}} +test incr-old-2.8 {incr errors} { + set x { - } + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got " - "}} +test incr-old-2.9 {incr errors} { + set x + + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got "+"}} +test incr-old-2.10 {incr errors} { + set x {20 x} + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got "20 x"}} + +concat {} diff --git a/tests/incr.test b/tests/incr.test new file mode 100644 index 0000000..e187d41 --- /dev/null +++ b/tests/incr.test @@ -0,0 +1,246 @@ +# Commands covered: incr +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) incr.test 1.9 97/07/02 16:41:32 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Basic "incr" operation. + +catch {unset x} +catch {unset i} + +test incr-1.1 {TclCompileIncrCmd: missing variable name} { + list [catch {incr} msg] $msg +} {1 {wrong # args: should be "incr varName ?increment?"}} +test incr-1.2 {TclCompileIncrCmd: simple variable name} { + set i 10 + list [incr i] $i +} {11 11} +test incr-1.3 {TclCompileIncrCmd: error compiling variable name} { + set i 10 + catch {incr "i"xxx} msg + set msg +} {extra characters after close-quote} +test incr-1.4 {TclCompileIncrCmd: simple variable name in quotes} { + set i 17 + list [incr "i"] $i +} {18 18} +test incr-1.5 {TclCompileIncrCmd: simple variable name in braces} { + catch {unset {a simple var}} + set {a simple var} 27 + list [incr {a simple var}] ${a simple var} +} {28 28} +test incr-1.6 {TclCompileIncrCmd: simple array variable name} { + catch {unset a} + set a(foo) 37 + list [incr a(foo)] $a(foo) +} {38 38} +test incr-1.7 {TclCompileIncrCmd: non-simple (computed) variable name} { + set x "i" + set i 77 + list [incr $x 2] $i +} {79 79} +test incr-1.8 {TclCompileIncrCmd: non-simple (computed) variable name} { + set x "i" + set i 77 + list [incr [set x] +2] $i +} {79 79} + +test incr-1.9 {TclCompileIncrCmd: increment given} { + set i 10 + list [incr i +07] $i +} {17 17} +test incr-1.10 {TclCompileIncrCmd: no increment given} { + set i 10 + list [incr i] $i +} {11 11} + +test incr-1.11 {TclCompileIncrCmd: simple global name} { + proc p {} { + global i + set i 54 + incr i + } + p +} {55} +test incr-1.12 {TclCompileIncrCmd: simple local name} { + proc p {} { + set foo 100 + incr foo + } + p +} {101} +test incr-1.13 {TclCompileIncrCmd: simple but new (unknown) local name} { + proc p {} { + incr bar + } + catch {p} msg + set msg +} {can't read "bar": no such variable} +test incr-1.14 {TclCompileIncrCmd: simple local name, >255 locals} { + proc 260locals {} { + # create 260 locals + set a0 0; set a1 0; set a2 0; set a3 0; set a4 0 + set a5 0; set a6 0; set a7 0; set a8 0; set a9 0 + set b0 0; set b1 0; set b2 0; set b3 0; set b4 0 + set b5 0; set b6 0; set b7 0; set b8 0; set b9 0 + set c0 0; set c1 0; set c2 0; set c3 0; set c4 0 + set c5 0; set c6 0; set c7 0; set c8 0; set c9 0 + set d0 0; set d1 0; set d2 0; set d3 0; set d4 0 + set d5 0; set d6 0; set d7 0; set d8 0; set d9 0 + set e0 0; set e1 0; set e2 0; set e3 0; set e4 0 + set e5 0; set e6 0; set e7 0; set e8 0; set e9 0 + set f0 0; set f1 0; set f2 0; set f3 0; set f4 0 + set f5 0; set f6 0; set f7 0; set f8 0; set f9 0 + set g0 0; set g1 0; set g2 0; set g3 0; set g4 0 + set g5 0; set g6 0; set g7 0; set g8 0; set g9 0 + set h0 0; set h1 0; set h2 0; set h3 0; set h4 0 + set h5 0; set h6 0; set h7 0; set h8 0; set h9 0 + set i0 0; set i1 0; set i2 0; set i3 0; set i4 0 + set i5 0; set i6 0; set i7 0; set i8 0; set i9 0 + set j0 0; set j1 0; set j2 0; set j3 0; set j4 0 + set j5 0; set j6 0; set j7 0; set j8 0; set j9 0 + set k0 0; set k1 0; set k2 0; set k3 0; set k4 0 + set k5 0; set k6 0; set k7 0; set k8 0; set k9 0 + set l0 0; set l1 0; set l2 0; set l3 0; set l4 0 + set l5 0; set l6 0; set l7 0; set l8 0; set l9 0 + set m0 0; set m1 0; set m2 0; set m3 0; set m4 0 + set m5 0; set m6 0; set m7 0; set m8 0; set m9 0 + set n0 0; set n1 0; set n2 0; set n3 0; set n4 0 + set n5 0; set n6 0; set n7 0; set n8 0; set n9 0 + set o0 0; set o1 0; set o2 0; set o3 0; set o4 0 + set o5 0; set o6 0; set o7 0; set o8 0; set o9 0 + set p0 0; set p1 0; set p2 0; set p3 0; set p4 0 + set p5 0; set p6 0; set p7 0; set p8 0; set p9 0 + set q0 0; set q1 0; set q2 0; set q3 0; set q4 0 + set q5 0; set q6 0; set q7 0; set q8 0; set q9 0 + set r0 0; set r1 0; set r2 0; set r3 0; set r4 0 + set r5 0; set r6 0; set r7 0; set r8 0; set r9 0 + set s0 0; set s1 0; set s2 0; set s3 0; set s4 0 + set s5 0; set s6 0; set s7 0; set s8 0; set s9 0 + set t0 0; set t1 0; set t2 0; set t3 0; set t4 0 + set t5 0; set t6 0; set t7 0; set t8 0; set t9 0 + set u0 0; set u1 0; set u2 0; set u3 0; set u4 0 + set u5 0; set u6 0; set u7 0; set u8 0; set u9 0 + set v0 0; set v1 0; set v2 0; set v3 0; set v4 0 + set v5 0; set v6 0; set v7 0; set v8 0; set v9 0 + set w0 0; set w1 0; set w2 0; set w3 0; set w4 0 + set w5 0; set w6 0; set w7 0; set w8 0; set w9 0 + set x0 0; set x1 0; set x2 0; set x3 0; set x4 0 + set x5 0; set x6 0; set x7 0; set x8 0; set x9 0 + set y0 0; set y1 0; set y2 0; set y3 0; set y4 0 + set y5 0; set y6 0; set y7 0; set y8 0; set y9 0 + set z0 0; set z1 0; set z2 0; set z3 0; set z4 0 + set z5 0; set z6 0; set z7 0; set z8 0; set z9 0 + # now increment the last one (local var index > 255) + incr z9 + } + 260locals +} {1} +test incr-1.15 {TclCompileIncrCmd: variable is array} { + catch {unset a} + set a(foo) 27 + set x [incr a(foo) 11] + catch {unset a} + set x +} 38 +test incr-1.16 {TclCompileIncrCmd: variable is array, elem substitutions} { + catch {unset a} + set i 5 + set a(foo5) 27 + set x [incr a(foo$i) 11] + catch {unset a} + set x +} 38 + +test incr-1.17 {TclCompileIncrCmd: increment given, simple int} { + set i 5 + incr i 123 +} 128 +test incr-1.18 {TclCompileIncrCmd: increment given, simple int} { + set i 5 + incr i -100 +} -95 +test incr-1.19 {TclCompileIncrCmd: increment given, but erroneous} { + set i 5 + catch {incr i [set]} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + (increment expression) + while compiling +"incr i [set]"} +test incr-1.20 {TclCompileIncrCmd: increment given, in quotes} { + set i 25 + incr i "-100" +} -75 +test incr-1.21 {TclCompileIncrCmd: increment given, in braces} { + set i 24 + incr i {126} +} 150 +test incr-1.22 {TclCompileIncrCmd: increment given, large int} { + set i 5 + incr i 200000 +} 200005 +test incr-1.23 {TclCompileIncrCmd: increment given, formatted int != int} { + set i 25 + incr i 000012345 ;# an octal literal +} 5374 +test incr-1.24 {TclCompileIncrCmd: increment given, formatted int != int} { + set i 25 + catch {incr i 1a} msg + set msg +} {expected integer but got "1a"} + +test incr-1.25 {TclCompileIncrCmd: too many arguments} { + set i 10 + catch {incr i 10 20} msg + set msg +} {wrong # args: should be "incr varName ?increment?"} + + +test incr-1.26 {TclCompileIncrCmd: runtime error, bad variable name} { + list [catch {incr {"foo}} msg] $msg $errorInfo +} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable + (reading value of variable to increment) + invoked from within +"incr {"foo}"}} +test incr-1.27 {TclCompileIncrCmd: runtime error, bad variable name} { + list [catch {incr [set]} msg] $msg $errorInfo +} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + while compiling +"incr [set]"}} +test incr-1.28 {TclCompileIncrCmd: runtime error, readonly variable} { + proc readonly args {error "variable is read-only"} + set x 123 + trace var x w readonly + list [catch {incr x 1} msg] $msg $errorInfo +} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only + while executing +"incr x 1"}} +catch {unset x} +test incr-1.29 {TclCompileIncrCmd: runtime error, bad variable value} { + set x " - " + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got " - "}} + +# Check "incr" and computed command names. + +test incr-2.1 {incr and computed command names} { + set i 5 + set z incr + $z i -1 + set i +} 4 diff --git a/tests/indexObj.test b/tests/indexObj.test new file mode 100644 index 0000000..9f30ee0 --- /dev/null +++ b/tests/indexObj.test @@ -0,0 +1,68 @@ +# This file is a Tcl script to test out the the procedures in file +# tkIndexObj.c, which implement indexed table lookups. The tests here +# are organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# @(#) indexObj.test 1.3 97/06/23 18:23:09 + +if {[info procs test] != "test"} { + source defs +} + +if {[info commands testindexobj] == {}} { + puts "This application hasn't been compiled with the \"testindexobj\"" + puts "command, so I can't test Tcl_GetIndexFromObj etc." + return +} + +test indexObj-1.1 {exact match} { + testindexobj 1 1 xyz abc def xyz alm +} {2} +test indexObj-1.2 {exact match} { + testindexobj 1 1 abc abc def xyz alm +} {0} +test indexObj-1.3 {exact match} { + testindexobj 1 1 alm abc def xyz alm +} {3} +test indexObj-1.4 {unique abbreviation} { + testindexobj 1 1 xy abc def xalb xyz alm +} {3} +test indexObj-1.5 {multiple abbreviations and exact match} { + testindexobj 1 1 x abc def xalb xyz alm x +} {5} +test indexObj-1.6 {forced exact match} { + testindexobj 1 0 xy abc def xalb xy alm +} {3} +test indexObj-1.7 {forced exact match} { + testindexobj 1 0 x abc def xalb xyz alm x +} {5} + +test indexObj-2.1 {no match} { + list [catch {testindexobj 1 1 dddd abc def xalb xyz alm x} msg] $msg +} {1 {bad token "dddd": must be abc, def, xalb, xyz, alm, or x}} +test indexObj-2.2 {no match} { + list [catch {testindexobj 1 1 dddd abc} msg] $msg +} {1 {bad token "dddd": must be abc}} +test indexObj-2.3 {no match: no abbreviations} { + list [catch {testindexobj 1 0 xy abc def xalb xyz alm} msg] $msg +} {1 {bad token "xy": must be abc, def, xalb, xyz, or alm}} +test indexObj-2.4 {ambiguous value} { + list [catch {testindexobj 1 1 d dumb daughter a c} msg] $msg +} {1 {ambiguous token "d": must be dumb, daughter, a, or c}} +test indexObj-2.5 {omit error message} { + list [catch {testindexobj 0 1 d x} msg] $msg +} {1 {}} + +test indexObj-3.1 {cache result to skip next lookup} { + testindexobj check 42 +} {42} + +test indexObj-4.1 {free old internal representation} { + set x {a b} + lindex $x 1 + testindexobj 1 1 $x abc def {a b} zzz +} {2} diff --git a/tests/info.test b/tests/info.test new file mode 100644 index 0000000..784dad1 --- /dev/null +++ b/tests/info.test @@ -0,0 +1,576 @@ +# Commands covered: info +# +# 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-1994 The Regents of the University of California. +# Copyright (c) 1994-1995 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 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test info-1.1 {info args option} { + proc t1 {a bbb c} {return foo} + info args t1 +} {a bbb c} +test info-1.2 {info args option} { + proc t1 {{a default1} {bbb default2} {c default3} args} {return foo} + info a t1 +} {a bbb c args} +test info-1.3 {info args option} { + proc t1 "" {return foo} + info args t1 +} {} +test info-1.4 {info args option} { + catch {rename t1 {}} + list [catch {info args t1} msg] $msg +} {1 {"t1" isn't a procedure}} +test info-1.5 {info args option} { + list [catch {info args set} msg] $msg +} {1 {"set" isn't a procedure}} +test info-1.6 {info args option} { + proc t1 {a b} {set c 123; set d $c} + t1 1 2 + info args t1 +} {a b} + +test info-2.1 {info body option} { + proc t1 {} {body of t1} + info body t1 +} {body of t1} +test info-2.2 {info body option} { + list [catch {info body set} msg] $msg +} {1 {"set" isn't a procedure}} +test info-2.3 {info body option} { + list [catch {info args set 1} msg] $msg +} {1 {wrong # args: should be "info args procname"}} + +# "info cmdcount" is no longer accurate for compiled commands! The expected +# result for info-3.1 used to be "3" and is now "1" since the "set"s have +# been compiled away. +test info-3.1 {info cmdcount option} { + set x [info cmdcount] + set y 12345 + set z [info cm] + expr $z-$x +} 1 +test info-3.2 {info body option} { + list [catch {info cmdcount 1} msg] $msg +} {1 {wrong # args: should be "info cmdcount"}} + +test info-4.1 {info commands option} { + proc t1 {} {} + proc t2 {} {} + set x " [info commands] " + list [string match {* t1 *} $x] [string match {* t2 *} $x] \ + [string match {* set *} $x] [string match {* list *} $x] +} {1 1 1 1} +test info-4.2 {info commands option} { + proc t1 {} {} + rename t1 {} + set x [info comm] + string match {* t1 *} $x +} 0 +test info-4.3 {info commands option} { + proc _t1_ {} {} + proc _t2_ {} {} + info commands _t1_ +} _t1_ +test info-4.4 {info commands option} { + proc _t1_ {} {} + proc _t2_ {} {} + lsort [info commands _t*] +} {_t1_ _t2_} +catch {rename _t1_ {}} +catch {rename _t2_ {}} +test info-4.5 {info commands option} { + list [catch {info commands a b} msg] $msg +} {1 {wrong # args: should be "info commands ?pattern?"}} + +test info-5.1 {info complete option} { + info complete "" +} 1 +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 " +} 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" +} 0 + +test info-6.1 {info default option} { + proc t1 {a b {c d} {e "long default value"}} {} + info default t1 a value +} 0 +test info-6.2 {info default option} { + proc t1 {a b {c d} {e "long default value"}} {} + set value 12345 + info d t1 a value + set value +} {} +test info-6.3 {info default option} { + proc t1 {a b {c d} {e "long default value"}} {} + info default t1 c value +} 1 +test info-6.4 {info default option} { + proc t1 {a b {c d} {e "long default value"}} {} + set value 12345 + info default t1 c value + set value +} d +test info-6.5 {info default option} { + proc t1 {a b {c d} {e "long default value"}} {} + set value 12345 + set x [info default t1 e value] + list $x $value +} {1 {long default value}} +test info-6.6 {info default option} { + list [catch {info default a b} msg] $msg +} {1 {wrong # args: should be "info default procname arg varname"}} +test info-6.7 {info default option} { + list [catch {info default _nonexistent_ a b} msg] $msg +} {1 {"_nonexistent_" isn't a procedure}} +test info-6.8 {info default option} { + proc t1 {a b} {} + list [catch {info default t1 x value} msg] $msg +} {1 {procedure "t1" doesn't have an argument "x"}} +test info-6.9 {info default option} { + catch {unset a} + set a(0) 88 + proc t1 {a b} {} + list [catch {info default t1 a a} msg] $msg +} {1 {couldn't store default value in variable "a"}} +test info-6.10 {info default option} { + catch {unset a} + set a(0) 88 + proc t1 {{a 18} b} {} + list [catch {info default t1 a a} msg] $msg +} {1 {couldn't store default value in variable "a"}} +catch {unset a} + +test info-7.1 {info exists option} { + set value foo + info exists value +} 1 +catch {unset _nonexistent_} +test info-7.2 {info exists option} { + info exists _nonexistent_ +} 0 +test info-7.3 {info exists option} { + proc t1 {x} {return [info exists x]} + t1 2 +} 1 +test info-7.4 {info exists option} { + proc t1 {x} { + global _nonexistent_ + return [info exists _nonexistent_] + } + t1 2 +} 0 +test info-7.5 {info exists option} { + proc t1 {x} { + set y 47 + return [info exists y] + } + t1 2 +} 1 +test info-7.6 {info exists option} { + proc t1 {x} {return [info exists value]} + t1 2 +} 0 +test info-7.7 {info exists option} { + catch {unset x} + set x(2) 44 + list [info exists x] [info exists x(1)] [info exists x(2)] +} {1 0 1} +catch {unset x} +test info-7.8 {info exists option} { + list [catch {info exists} msg] $msg +} {1 {wrong # args: should be "info exists varName"}} +test info-7.9 {info exists option} { + list [catch {info exists 1 2} msg] $msg +} {1 {wrong # args: should be "info exists varName"}} + +test info-8.1 {info globals option} { + set x 1 + set y 2 + set value 23 + set a " [info globals] " + list [string match {* x *} $a] [string match {* y *} $a] \ + [string match {* value *} $a] [string match {* _foobar_ *} $a] +} {1 1 1 0} +test info-8.2 {info globals option} { + set _xxx1 1 + set _xxx2 2 + lsort [info g _xxx*] +} {_xxx1 _xxx2} +test info-8.3 {info globals option} { + list [catch {info globals 1 2} msg] $msg +} {1 {wrong # args: should be "info globals ?pattern?"}} + +test info-9.1 {info level option} { + info level +} 0 +test info-9.2 {info level option} { + proc t1 {a b} { + set x [info le] + set y [info level 1] + list $x $y + } + t1 146 testString +} {1 {t1 146 testString}} +test info-9.3 {info level option} { + proc t1 {a b} { + t2 [expr $a*2] $b + } + proc t2 {x y} { + list [info level] [info level 1] [info level 2] [info level -1] \ + [info level 0] + } + t1 146 {a {b c} {{{c}}}} +} {2 {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}} {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}}} +test info-9.4 {info level option} { + proc t1 {} { + set x [info level] + set y [info level 1] + list $x $y + } + t1 +} {1 t1} +test info-9.5 {info level option} { + list [catch {info level 1 2} msg] $msg +} {1 {wrong # args: should be "info level ?number?"}} +test info-9.6 {info level option} { + list [catch {info level 123a} msg] $msg +} {1 {expected integer but got "123a"}} +test info-9.7 {info level option} { + list [catch {info level 0} msg] $msg +} {1 {bad level "0"}} +test info-9.8 {info level option} { + proc t1 {} {info level -1} + list [catch {t1} msg] $msg +} {1 {bad level "-1"}} +test info-9.9 {info level option} { + proc t1 {x} {info level $x} + list [catch {t1 -3} msg] $msg +} {1 {bad level "-3"}} + +set savedLibrary $tcl_library +test info-10.1 {info library option} { + list [catch {info library x} msg] $msg +} {1 {wrong # args: should be "info library"}} +test info-10.2 {info library option} { + set tcl_library 12345 + info library +} {12345} +test info-10.3 {info library option} { + unset tcl_library + list [catch {info library} msg] $msg +} {1 {no library has been specified for Tcl}} +set tcl_library $savedLibrary + +test info-11.1 {info loaded option} { + list [catch {info loaded a b} msg] $msg +} {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"}} + +test info-12.1 {info locals option} { + set a 22 + proc t1 {x y} { + set b 13 + set c testing + global a + return [info locals] + } + lsort [t1 23 24] +} {b c x y} +test info-12.2 {info locals option} { + proc t1 {x y} { + set xx1 2 + set xx2 3 + set y 4 + return [info loc x*] + } + lsort [t1 2 3] +} {x xx1 xx2} +test info-12.3 {info locals option} { + list [catch {info locals 1 2} msg] $msg +} {1 {wrong # args: should be "info locals ?pattern?"}} +test info-12.4 {info locals option} { + info locals +} {} +test info-12.5 {info locals option} { + proc t1 {} {return [info locals]} + t1 +} {} +test info-12.6 {info locals vs unset compiled locals} { + proc t1 {lst} { + foreach $lst $lst {} + unset lst + return [info locals] + } + lsort [t1 {a b c c d e f}] +} {a b c d e f} + +test info-13.1 {info nameofexecutable option} { + list [catch {info nameofexecutable foo} msg] $msg +} {1 {wrong # args: should be "info nameofexecutable"}} + +test info-14.1 {info patchlevel option} { + set a [info patchlevel] + regexp {[0-9]+\.[0-9]+([p[0-9]+)?} $a +} 1 +test info-14.2 {info patchlevel option} { + list [catch {info patchlevel a} msg] $msg +} {1 {wrong # args: should be "info patchlevel"}} +test info-14.3 {info patchlevel option} { + set t $tcl_patchLevel + unset tcl_patchLevel + set result [list [catch {info patchlevel} msg] $msg] + set tcl_patchLevel $t + set result +} {1 {can't read "tcl_patchLevel": no such variable}} + +test info-15.1 {info procs option} { + proc t1 {} {} + proc t2 {} {} + set x " [info procs] " + list [string match {* t1 *} $x] [string match {* t2 *} $x] \ + [string match {* _undefined_ *} $x] +} {1 1 0} +test info-15.2 {info procs option} { + proc _tt1 {} {} + proc _tt2 {} {} + lsort [info pr _tt*] +} {_tt1 _tt2} +catch {rename _tt1 {}} +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?"}} + +set self info.test +if {$tcl_platform(os) == "Win32s"} { + set self info~1.tes +} + +test info-16.1 {info script option} { + list [catch {info script x} msg] $msg +} {1 {wrong # args: should be "info script"}} +test info-16.2 {info script option} { + file tail [info sc] +} $self +removeFile gorp.info +makeFile "info script\n" gorp.info +test info-16.3 {info script option} { + list [source gorp.info] [file tail [info script]] +} [list gorp.info $self] +test info-16.4 {resetting "info script" after errors} { + catch {source ~_nobody_/foo} + file tail [info script] +} $self +test info-16.5 {resetting "info script" after errors} { + catch {source _nonexistent_} + file tail [info script] +} $self +removeFile gorp.info + +test info-17.1 {info sharedlibextension option} { + list [catch {info sharedlibextension foo} msg] $msg +} {1 {wrong # args: should be "info sharedlibextension"}} + +test info-18.1 {info tclversion option} { + set x [info tclversion] + scan $x "%d.%d%c" a b c +} 2 +test info-18.2 {info tclversion option} { + list [catch {info t 2} msg] $msg +} {1 {wrong # args: should be "info tclversion"}} +test info-18.3 {info tclversion option} { + set t $tcl_version + unset tcl_version + set result [list [catch {info tclversion} msg] $msg] + set tcl_version $t + set result +} {1 {can't read "tcl_version": no such variable}} + +test info-19.1 {info vars option} { + set a 1 + set b 2 + proc t1 {x y} { + global a b + set c 33 + return [info vars] + } + lsort [t1 18 19] +} {a b c x y} +test info-19.2 {info vars option} { + set xxx1 1 + set xxx2 2 + proc t1 {xxa y} { + global xxx1 xxx2 + set c 33 + return [info vars x*] + } + lsort [t1 18 19] +} {xxa xxx1 xxx2} +test info-19.3 {info vars option} { + lsort [info vars] +} [lsort [info globals]] +test info-19.4 {info vars option} { + list [catch {info vars a b} msg] $msg +} {1 {wrong # args: should be "info vars ?pattern?"}} + +test info-20.1 {miscellaneous error conditions} { + list [catch {info} msg] $msg +} {1 {wrong # args: should be "info option ?arg arg ...?"}} +test info-20.2 {miscellaneous error conditions} { + list [catch {info gorp} msg] $msg +} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +test info-20.3 {miscellaneous error conditions} { + list [catch {info c} msg] $msg +} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +test info-20.4 {miscellaneous error conditions} { + list [catch {info l} msg] $msg +} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +test info-20.5 {miscellaneous error conditions} { + list [catch {info s} msg] $msg +} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} diff --git a/tests/init.test b/tests/init.test new file mode 100644 index 0000000..2d6e068 --- /dev/null +++ b/tests/init.test @@ -0,0 +1,149 @@ +# Functionality covered: this file contains a collection of tests for the +# auto loading and namespaces. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) init.test 1.5 97/11/19 18:08:20 + + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Clear out any namespaces called test_ns_* +catch {eval namespace delete [namespace children :: test_ns_*]} + +# Six cases - white box testing + +test init-1.1 {auto_qualify - absolute cmd - namespace} { + auto_qualify ::foo::bar ::blue +} ::foo::bar + +test init-1.2 {auto_qualify - absolute cmd - global} { + auto_qualify ::global ::sub +} global + +test init-1.3 {auto_qualify - no colons cmd - global} { + auto_qualify nocolons :: +} nocolons + +test init-1.4 {auto_qualify - no colons cmd - namespace} { + auto_qualify nocolons ::sub +} {::sub::nocolons nocolons} + +test init-1.5 {auto_qualify - colons in cmd - global} { + auto_qualify foo::bar :: +} ::foo::bar + +test init-1.6 {auto_qualify - colons in cmd - namespace} { + auto_qualify foo::bar ::sub +} {::sub::foo::bar ::foo::bar} + +# Some additional tests + +test init-1.7 {auto_qualify - multiples colons 1} { + auto_qualify :::foo::::bar ::blue +} ::foo::bar + +test init-1.8 {auto_qualify - multiple colons 2} { + auto_qualify :::foo ::bar +} foo + + +# we use a sub interp and auto_reset and double the tests because there is 2 +# places where auto_loading occur (before loading the indexes files and after) + +set testInterp [interp create] +interp eval $testInterp [list set VERBOSE $VERBOSE] +interp eval $testInterp [list set TESTS $TESTS] + +interp eval $testInterp { + +if {[string compare test [info procs test]] == 1} then {source defs} + +auto_reset +catch {rename parray {}} + +test init-2.0 {load parray - stage 1} { + set ret [catch {namespace eval ::test {parray}} error] + rename parray {} ; # remove it, for the next test - that should not fail. + list $ret $error +} {1 {no value given for parameter "a" to "parray"}} + + +test init-2.1 {load parray - stage 2} { + set ret [catch {namespace eval ::test {parray}} error] + list $ret $error +} {1 {no value given for parameter "a" to "parray"}} + + +auto_reset +catch {rename ::safe::setLogCmd {}} +#unset auto_index(::safe::setLogCmd) +#unset auto_oldpath + +test init-2.2 {load ::safe::setLogCmd - stage 1} { + ::safe::setLogCmd + rename ::safe::setLogCmd {} ; # should not fail +} {} + +test init-2.3 {load ::safe::setLogCmd - stage 2} { + ::safe::setLogCmd + rename ::safe::setLogCmd {} ; # should not fail +} {} + +auto_reset +catch {rename ::safe::setLogCmd {}} + +test init-2.4 {load safe:::setLogCmd - stage 1} { + safe:::setLogCmd ; # intentionally 3 : + rename ::safe::setLogCmd {} ; # should not fail +} {} + +test init-2.5 {load safe:::setLogCmd - stage 2} { + safe:::setLogCmd ; # intentionally 3 : + rename ::safe::setLogCmd {} ; # should not fail +} {} + +auto_reset +catch {rename ::safe::setLogCmd {}} + +test init-2.6 {load setLogCmd from safe:: - stage 1} { + namespace eval safe setLogCmd + rename ::safe::setLogCmd {} ; # should not fail +} {} + +test init-2.7 {oad setLogCmd from safe:: - stage 2} { + namespace eval safe setLogCmd + rename ::safe::setLogCmd {} ; # should not fail +} {} + + +auto_reset +package require http 2.0 +catch {rename ::http::geturl {}} + +test init-2.8 {load http::geturl (package)} { + # 3 ':' on purpose + set ret [catch {namespace eval ::test {http:::geturl}} error] + # removing it, for the next test. should not fail. + rename ::http::geturl {} ; + list $ret $error +} {1 {no value given for parameter "url" to "http:::geturl"}} + + +test init-3.0 {random stuff in the auto_index, should still work} { + set auto_index(foo:::bar::blah) { + namespace eval foo {namespace eval bar {proc blah {} {return 1}}} + } + foo:::bar::blah +} 1 + +} + +interp delete $testInterp + diff --git a/tests/interp.test b/tests/interp.test new file mode 100644 index 0000000..919774f --- /dev/null +++ b/tests/interp.test @@ -0,0 +1,2258 @@ +# This file tests the multiple interpreter facility of Tcl +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) interp.test 1.64 97/09/04 16:02:23 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# The set of hidden commands is platform dependent: + +if {"$tcl_platform(platform)" == "macintosh"} { + set hidden_cmds {beep cd echo exit fconfigure file glob load ls open pwd socket source} +} else { + set hidden_cmds {cd exec exit fconfigure file glob load open pwd socket source} +} + +foreach i [interp slaves] { + interp delete $i +} + +proc equiv {x} {return $x} + +# Part 0: Check out options for interp command +test interp-1.1 {options for interp command} { + list [catch {interp} msg] $msg +} {1 {wrong # args: should be "interp cmd ?arg ...?"}} +test interp-1.2 {options for interp command} { + list [catch {interp frobox} msg] $msg +} {1 {bad option "frobox": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}} +test interp-1.3 {options for interp command} { + interp delete +} "" +test interp-1.4 {options for interp command} { + list [catch {interp delete foo bar} msg] $msg +} {1 {interpreter named "foo" not found}} +test interp-1.5 {options for interp command} { + list [catch {interp exists foo bar} msg] $msg +} {1 {wrong # args: should be "interp exists ?path?"}} +# +# test interp-0.6 was removed +# +test interp-1.6 {options for interp command} { + list [catch {interp slaves foo bar zop} msg] $msg +} {1 {wrong # args: should be "interp slaves ?path?"}} +test interp-1.7 {options for interp command} { + list [catch {interp hello} msg] $msg +} {1 {bad option "hello": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}} +test interp-1.8 {options for interp command} { + list [catch {interp -froboz} msg] $msg +} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}} +test interp-1.9 {options for interp command} { + list [catch {interp -froboz -safe} msg] $msg +} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}} +test interp-1.10 {options for interp command} { + list [catch {interp target} msg] $msg +} {1 {wrong # args: should be "interp target path alias"}} + +# Part 1: Basic interpreter creation tests: +test interp-2.1 {basic interpreter creation} { + interp create a +} a +test interp-2.2 {basic interpreter creation} { + catch {interp create} +} 0 +test interp-2.3 {basic interpreter creation} { + catch {interp create -safe} +} 0 +test interp-2.4 {basic interpreter creation} { + list [catch {interp create a} msg] $msg +} {1 {interpreter named "a" already exists, cannot create}} +test interp-2.5 {basic interpreter creation} { + interp create b -safe +} b +test interp-2.6 {basic interpreter creation} { + interp create d -safe +} d +test interp-2.7 {basic interpreter creation} { + list [catch {interp create -froboz} msg] $msg +} {1 {bad option "-froboz": should be -safe}} +test interp-2.8 {basic interpreter creation} { + interp create -- -froboz +} -froboz +test interp-2.9 {basic interpreter creation} { + interp create -safe -- -froboz1 +} -froboz1 +test interp-2.10 {basic interpreter creation} { + interp create {a x1} + interp create {a x2} + interp create {a x3} -safe +} {a x3} +test interp-2.11 {anonymous interps vs existing procs} { + set x [interp create] + regexp "interp(\[0-9]+)" $x dummy thenum + interp delete $x + incr thenum + proc interp$thenum {} {} + set x [interp create] + regexp "interp(\[0-9]+)" $x dummy anothernum + expr $anothernum - $thenum +} 1 +test interp-2.12 {anonymous interps vs existing procs} { + set x [interp create -safe] + regexp "interp(\[0-9]+)" $x dummy thenum + interp delete $x + incr thenum + proc interp$thenum {} {} + set x [interp create -safe] + regexp "interp(\[0-9]+)" $x dummy anothernum + expr $anothernum - $thenum +} 1 + +foreach i [interp slaves] { + interp delete $i +} + +# Part 2: Testing "interp slaves" and "interp exists" +test interp-3.1 {testing interp exists and interp slaves} { + interp slaves +} "" +test interp-3.2 {testing interp exists and interp slaves} { + interp create a + interp exists a +} 1 +test interp-3.3 {testing interp exists and interp slaves} { + interp exists nonexistent +} 0 +test interp-3.4 {testing interp exists and interp slaves} { + list [catch {interp slaves a b c} msg] $msg +} {1 {wrong # args: should be "interp slaves ?path?"}} +test interp-3.5 {testing interp exists and interp slaves} { + list [catch {interp exists a b c} msg] $msg +} {1 {wrong # args: should be "interp exists ?path?"}} +test interp-3.6 {testing interp exists and interp slaves} { + interp exists +} 1 +test interp-3.7 {testing interp exists and interp slaves} { + interp slaves +} a +test interp-3.8 {testing interp exists and interp slaves} { + list [catch {interp slaves a b c} msg] $msg +} {1 {wrong # args: should be "interp slaves ?path?"}} +test interp-3.9 {testing interp exists and interp slaves} { + interp create {a a2} -safe + interp slaves a +} {a2} +test interp-3.10 {testing interp exists and interp slaves} { + interp exists {a a2} +} 1 + +# Part 3: Testing "interp delete" +test interp-3.11 {testing interp delete} { + interp delete +} "" +test interp-4.1 {testing interp delete} { + catch {interp create a} + interp delete a +} "" +test interp-4.2 {testing interp delete} { + list [catch {interp delete nonexistent} msg] $msg +} {1 {interpreter named "nonexistent" not found}} +test interp-4.3 {testing interp delete} { + list [catch {interp delete x y z} msg] $msg +} {1 {interpreter named "x" not found}} +test interp-4.4 {testing interp delete} { + interp delete +} "" +test interp-4.5 {testing interp delete} { + interp create a + interp create {a x1} + interp delete {a x1} + interp slaves a +} "" +test interp-4.6 {testing interp delete} { + interp create c1 + interp create c2 + interp create c3 + interp delete c1 c2 c3 +} "" +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}} + +foreach i [interp slaves] { + interp delete $i +} + +# Part 4: Consistency checking - all nondeleted interpreters should be +# there: +test interp-5.1 {testing consistency} { + interp slaves +} "" +test interp-5.2 {testing consistency} { + interp exists a +} 0 +test interp-5.3 {testing consistency} { + interp exists nonexistent +} 0 + +# Recreate interpreter "a" +interp create a + +# Part 5: Testing eval in interpreter object command and with interp command +test interp-6.1 {testing eval} { + a eval expr 3 + 5 +} 8 +test interp-6.2 {testing eval} { + list [catch {a eval foo} msg] $msg +} {1 {invalid command name "foo"}} +test interp-6.3 {testing eval} { + a eval {proc foo {} {expr 3 + 5}} + a eval foo +} 8 +test interp-6.4 {testing eval} { + interp eval a foo +} 8 + +test interp-6.5 {testing eval} { + interp create {a x2} + interp eval {a x2} {proc frob {} {expr 4 * 9}} + interp eval {a x2} frob +} 36 +test interp-6.6 {testing eval} { + list [catch {interp eval {a x2} foo} msg] $msg +} {1 {invalid command name "foo"}} + +# UTILITY PROCEDURE RUNNING IN MASTER INTERPRETER: +proc in_master {args} { + return [list seen in master: $args] +} + +# Part 6: Testing basic alias creation +test interp-7.1 {testing basic alias creation} { + a alias foo in_master +} foo +test interp-7.2 {testing basic alias creation} { + a alias bar in_master a1 a2 a3 +} bar +# Test 6.3 has been deleted. +test interp-7.3 {testing basic alias creation} { + a alias foo +} in_master +test interp-7.4 {testing basic alias creation} { + a alias bar +} {in_master a1 a2 a3} +test interp-7.5 {testing basic alias creation} { + a aliases +} {foo bar} + +# Part 7: testing basic alias invocation +test interp-8.1 {testing basic alias invocation} { + catch {interp create a} + a alias foo in_master + a eval foo s1 s2 s3 +} {seen in master: {s1 s2 s3}} +test interp-8.2 {testing basic alias invocation} { + catch {interp create a} + a alias bar in_master a1 a2 a3 + a eval bar s1 s2 s3 +} {seen in master: {a1 a2 a3 s1 s2 s3}} + +# Part 8: Testing aliases for non-existent targets +test interp-9.1 {testing aliases for non-existent targets} { + catch {interp create a} + a alias zop nonexistent-command-in-master + list [catch {a eval zop} msg] $msg +} {1 {invalid command name "nonexistent-command-in-master"}} +test interp-9.2 {testing aliases for non-existent targets} { + catch {interp create a} + a alias zop nonexistent-command-in-master + proc nonexistent-command-in-master {} {return i_exist!} + a eval zop +} i_exist! + +if {[info command nonexistent-command-in-master] != ""} { + rename nonexistent-command-in-master {} +} + +# Part 9: Aliasing between interpreters +test interp-10.1 {testing aliasing between interpreters} { + catch {interp delete a} + catch {interp delete b} + interp create a + interp create b + interp alias a a_alias b b_alias 1 2 3 +} a_alias +test interp-10.2 {testing aliasing between interpreters} { + catch {interp delete a} + catch {interp delete b} + interp create a + interp create b + b eval {proc b_alias {args} {return [list got $args]}} + interp alias a a_alias b b_alias 1 2 3 + a eval a_alias a b c +} {got {1 2 3 a b c}} +test interp-10.3 {testing aliasing between interpreters} { + catch {interp delete a} + catch {interp delete b} + interp create a + interp create b + interp alias a a_alias b b_alias 1 2 3 + list [catch {a eval a_alias a b c} msg] $msg +} {1 {invalid command name "b_alias"}} +test interp-10.4 {testing aliasing between interpreters} { + catch {interp delete a} + interp create a + a alias a_alias puts + a aliases +} a_alias +test interp-10.5 {testing aliasing between interpreters} { + catch {interp delete a} + catch {interp delete b} + interp create a + interp create b + a alias a_alias puts + interp alias a a_del b b_del + interp delete b + a aliases +} a_alias +test interp-10.6 {testing aliasing between interpreters} { + catch {interp delete a} + catch {interp delete b} + interp create a + interp create b + interp alias a a_command b b_command a1 a2 a3 + b alias b_command in_master b1 b2 b3 + a eval a_command m1 m2 m3 +} {seen in master: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} +test interp-10.7 {testing aliases between interpreters} { + catch {interp delete a} + interp create a + interp alias "" foo a zoppo + a eval {proc zoppo {x} {list $x $x $x}} + set x [foo 33] + a eval {rename zoppo {}} + interp alias "" foo a {} + equiv $x +} {33 33 33} + +# Part 10: Testing "interp target" +test interp-11.1 {testing interp target} { + list [catch {interp target} msg] $msg +} {1 {wrong # args: should be "interp target path alias"}} +test interp-11.2 {testing interp target} { + list [catch {interp target nosuchinterpreter foo} msg] $msg +} {1 {could not find interpreter "nosuchinterpreter"}} +test interp-11.3 {testing interp target} { + catch {interp delete a} + interp create a + a alias boo no_command + interp target a boo +} "" +test interp-11.4 {testing interp target} { + catch {interp delete x1} + interp create x1 + x1 eval interp create x2 + x1 eval x2 eval interp create x3 + catch {interp delete y1} + interp create y1 + y1 eval interp create y2 + y1 eval y2 eval interp create y3 + interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand + interp target {x1 x2 x3} xcommand +} {y1 y2 y3} +test interp-11.5 {testing interp target} { + catch {interp delete x1} + interp create x1 + interp create {x1 x2} + interp create {x1 x2 x3} + catch {interp delete y1} + interp create y1 + interp create {y1 y2} + interp create {y1 y2 y3} + interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand + list [catch {x1 eval {interp target {x2 x3} xcommand}} msg] $msg +} {1 {target interpreter for alias "xcommand" in path "x2 x3" is not my descendant}} +test interp-11.6 {testing interp target} { + foreach a [interp aliases] { + rename $a {} + } + list [catch {interp target {} foo} msg] $msg +} {1 {alias "foo" in path "" not found}} +test interp-11.7 {testing interp target} { + catch {interp delete a} + interp create a + list [catch {interp target a foo} msg] $msg +} {1 {alias "foo" in path "a" not found}} + +# Part 11: testing "interp issafe" +test interp-12.1 {testing interp issafe} { + interp issafe +} 0 +test interp-12.2 {testing interp issafe} { + catch {interp delete a} + interp create a + interp issafe a +} 0 +test interp-12.3 {testing interp issafe} { + catch {interp delete a} + interp create a + interp create {a x3} -safe + interp issafe {a x3} +} 1 +test interp-12.4 {testing interp issafe} { + catch {interp delete a} + interp create a + interp create {a x3} -safe + interp create {a x3 foo} + interp issafe {a x3 foo} +} 1 + +# Part 12: testing interpreter object command "issafe" sub-command +test interp-13.1 {testing foo issafe} { + catch {interp delete a} + interp create a + a issafe +} 0 +test interp-13.2 {testing foo issafe} { + catch {interp delete a} + interp create a + interp create {a x3} -safe + a eval x3 issafe +} 1 +test interp-13.3 {testing foo issafe} { + catch {interp delete a} + interp create a + interp create {a x3} -safe + interp create {a x3 foo} + a eval x3 eval foo issafe +} 1 + +# part 14: testing interp aliases +test interp-14.1 {testing interp aliases} { + interp aliases +} "" +test interp-14.2 {testing interp aliases} { + catch {interp delete a} + interp create a + a alias a1 puts + a alias a2 puts + a alias a3 puts + lsort [interp aliases a] +} {a1 a2 a3} +test interp-14.3 {testing interp aliases} { + catch {interp delete a} + interp create a + interp create {a x3} + interp alias {a x3} froboz "" puts + interp aliases {a x3} +} froboz + +# part 15: testing file sharing +test interp-15.1 {testing file sharing} { + catch {interp delete z} + interp create z + z eval close stdout + list [catch {z eval puts hello} msg] $msg +} {1 {can not find channel named "stdout"}} +catch {removeFile file-15.2} +test interp-15.2 {testing file sharing} { + catch {interp delete z} + interp create z + set f [open file-15.2 w] + interp share "" $f z + z eval puts $f hello + z eval close $f + close $f +} "" +catch {removeFile file-15.2} +test interp-15.3 {testing file sharing} { + catch {interp delete xsafe} + interp create xsafe -safe + list [catch {xsafe eval puts hello} msg] $msg +} {1 {can not find channel named "stdout"}} +catch {removeFile file-15.4} +test interp-15.4 {testing file sharing} { + catch {interp delete xsafe} + interp create xsafe -safe + set f [open file-15.4 w] + interp share "" $f xsafe + xsafe eval puts $f hello + xsafe eval close $f + close $f +} "" +catch {removeFile file-15.4} +test interp-15.5 {testing file sharing} { + catch {interp delete xsafe} + interp create xsafe -safe + interp share "" stdout xsafe + list [catch {xsafe eval gets stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +catch {removeFile file-15.6} +test interp-15.6 {testing file sharing} { + catch {interp delete xsafe} + interp create xsafe -safe + set f [open file-15.6 w] + interp share "" $f xsafe + set x [list [catch [list xsafe eval gets $f] msg] $msg] + xsafe eval close $f + close $f + string compare [string tolower $x] \ + [list 1 [format "channel \"%s\" wasn't opened for reading" $f]] +} 0 +catch {removeFile file-15.6} +catch {removeFile file-15.7} +test interp-15.7 {testing file transferring} { + catch {interp delete xsafe} + interp create xsafe -safe + set f [open file-15.7 w] + interp transfer "" $f xsafe + xsafe eval puts $f hello + xsafe eval close $f +} "" +catch {removeFile file-15.7} +catch {removeFile file-15.8} +test interp-15.8 {testing file transferring} { + catch {interp delete xsafe} + interp create xsafe -safe + set f [open file-15.8 w] + interp transfer "" $f xsafe + xsafe eval close $f + set x [list [catch {close $f} msg] $msg] + string compare [string tolower $x] \ + [list 1 [format "can not find channel named \"%s\"" $f]] +} 0 +catch {removeFile file-15.8} + +# +# Torture tests for interpreter deletion order +# +proc kill {} {interp delete xxx} + +test interp-15.9 {testing deletion order} { + catch {interp delete xxx} + interp create xxx + xxx alias kill kill + list [catch {xxx eval kill} msg] $msg +} {0 {}} +test interp-16.1 {testing deletion order} { + catch {interp delete xxx} + interp create xxx + interp create {xxx yyy} + interp alias {xxx yyy} kill "" kill + list [catch {interp eval {xxx yyy} kill} msg] $msg +} {0 {}} +test interp-16.2 {testing deletion order} { + catch {interp delete xxx} + interp create xxx + interp create {xxx yyy} + interp alias {xxx yyy} kill "" kill + list [catch {xxx eval yyy eval kill} msg] $msg +} {0 {}} +test interp-16.3 {testing deletion order} { + catch {interp delete xxx} + interp create xxx + interp create ddd + xxx alias kill kill + interp alias ddd kill xxx kill + set x [ddd eval kill] + interp delete ddd + set x +} "" +test interp-16.4 {testing deletion order} { + catch {interp delete xxx} + interp create xxx + interp create {xxx yyy} + interp alias {xxx yyy} kill "" kill + interp create ddd + interp alias ddd kill {xxx yyy} kill + set x [ddd eval kill] + interp delete ddd + set x +} "" +test interp-16.5 {testing deletion order, bgerror} { + catch {interp delete xxx} + interp create xxx + xxx eval {proc bgerror {args} {exit}} + xxx alias exit kill xxx + proc kill {i} {interp delete $i} + xxx eval after 100 expr a + b + after 200 + update + interp exists xxx +} 0 + +# +# Alias loop prevention testing. +# + +test interp-17.1 {alias loop prevention} { + list [catch {interp alias {} a {} a} msg] $msg +} {1 {cannot define or rename alias "a": would create a loop}} +test interp-17.2 {alias loop prevention} { + catch {interp delete x} + interp create x + x alias a loop + list [catch {interp alias {} loop x a} msg] $msg +} {1 {cannot define or rename alias "loop": would create a loop}} +test interp-17.3 {alias loop prevention} { + catch {interp delete x} + interp create x + interp alias x a x b + list [catch {interp alias x b x a} msg] $msg +} {1 {cannot define or rename alias "b": would create a loop}} +test interp-17.4 {alias loop prevention} { + catch {interp delete x} + interp create x + interp alias x b x a + list [catch {x eval rename b a} msg] $msg +} {1 {cannot define or rename alias "b": would create a loop}} +test interp-17.5 {alias loop prevention} { + catch {interp delete x} + interp create x + x alias z l1 + interp alias {} l2 x z + list [catch {rename l2 l1} msg] $msg +} {1 {cannot define or rename alias "l2": would create a loop}} + +# +# Test robustness of Tcl_DeleteInterp when applied to a slave interpreter. +# If there are bugs in the implementation these tests are likely to expose +# the bugs as a core dump. +# + +if {[info commands testinterpdelete] != ""} { + test interp-18.1 {testing Tcl_DeleteInterp vs slaves} { + list [catch {testinterpdelete} msg] $msg + } {1 {wrong # args: should be "testinterpdelete path"}} + test interp-18.2 {testing Tcl_DeleteInterp vs slaves} { + catch {interp delete a} + interp create a + testinterpdelete a + } "" + test interp-18.3 {testing Tcl_DeleteInterp vs slaves} { + catch {interp delete a} + interp create a + interp create {a b} + testinterpdelete {a b} + } "" + test interp-18.4 {testing Tcl_DeleteInterp vs slaves} { + catch {interp delete a} + interp create a + interp create {a b} + testinterpdelete a + } "" + test interp-18.5 {testing Tcl_DeleteInterp vs slaves} { + catch {interp delete a} + interp create a + interp create {a b} + interp alias {a b} dodel {} dodel + proc dodel {x} {testinterpdelete $x} + list [catch {interp eval {a b} {dodel {a b}}} msg] $msg + } {0 {}} + test interp-18.6 {testing Tcl_DeleteInterp vs slaves} { + catch {interp delete a} + interp create a + interp create {a b} + interp alias {a b} dodel {} dodel + proc dodel {x} {testinterpdelete $x} + list [catch {interp eval {a b} {dodel a}} msg] $msg + } {0 {}} + test interp-18.7 {eval in deleted interp} { + catch {interp delete a} + interp create a + a eval { + proc dodel {} { + delme + dosomething else + } + proc dosomething args { + puts "I should not have been called!!" + } + } + a alias delme dela + proc dela {} {interp delete a} + list [catch {a eval dodel} msg] $msg + } {1 {attempt to call eval in deleted interpreter}} + test interp-18.8 {eval in deleted interp} { + catch {interp delete a} + interp create a + a eval { + interp create b + b eval { + proc dodel {} { + dela + } + } + proc foo {} { + b eval dela + dosomething else + } + proc dosomething args { + puts "I should not have been called!!" + } + } + interp alias {a b} dela {} dela + proc dela {} {interp delete a} + list [catch {a eval foo} msg] $msg + } {1 {attempt to call eval in deleted interpreter}} +} + +# Test alias deletion + +test interp-19.1 {alias deletion} { + catch {interp delete a} + interp create a + interp alias a foo a bar + set s [interp alias a foo {}] + interp delete a + set s +} {} +test interp-19.2 {alias deletion} { + catch {interp delete a} + interp create a + catch {interp alias a foo {}} msg + interp delete a + set msg +} {alias "foo" not found} +test interp-19.3 {alias deletion} { + catch {interp delete a} + interp create a + interp alias a foo a bar + interp eval a {rename foo zop} + interp alias a foo a zop + catch {interp eval a foo} msg + interp delete a + set msg +} {invalid command name "zop"} +test interp-19.4 {alias deletion} { + catch {interp delete a} + interp create a + interp alias a foo a bar + interp eval a {rename foo zop} + catch {interp eval a foo} msg + interp delete a + set msg +} {invalid command name "foo"} +test interp-19.5 {alias deletion} { + catch {interp delete a} + interp create a + interp eval a {proc bar {} {return 1}} + interp alias a foo a bar + interp eval a {rename foo zop} + catch {interp eval a zop} msg + interp delete a + set msg +} 1 +test interp-19.6 {alias deletion} { + catch {interp delete a} + interp create a + interp alias a foo a bar + interp eval a {rename foo zop} + interp alias a foo a zop + set s [interp aliases a] + interp delete a + set s +} foo +test interp-19.7 {alias deletion, renaming} { + catch {interp delete a} + interp create a + interp alias a foo a bar + interp eval a rename foo blotz + interp alias a foo {} + set s [interp aliases a] + interp delete a + set s +} {} +test interp-19.8 {alias deletion, renaming} { + catch {interp delete a} + interp create a + interp alias a foo a bar + interp eval a rename foo blotz + set l "" + lappend l [interp aliases a] + interp alias a foo {} + lappend l [interp aliases a] + interp delete a + set l +} {foo {}} +test interp-19.9 {alias deletion, renaming} { + catch {interp delete a} + interp create a + interp alias a foo a bar + interp eval a rename foo blotz + interp eval a {proc foo {} {expr 34 * 34}} + interp alias a foo {} + set l [interp eval a foo] + interp delete a + set l +} 1156 + +test interp-20.1 {interp hide, interp expose and interp invokehidden} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + a eval {proc foo {} {}} + a hide foo + catch {a eval foo something} msg + interp delete a + set msg +} {invalid command name "foo"} +test interp-20.2 {interp hide, interp expose and interp invokehidden} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + a hide list + set l "" + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + a expose list + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {1 2 3}} +test interp-20.3 {interp hide, interp expose and interp invokehidden} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + a hide list + set l "" + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + lappend l [catch {a invokehidden list 1 2 3} msg] + lappend l $msg + a expose list + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}} +test interp-20.4 {interp hide, interp expose and interp invokehidden -- passing {}} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + a hide list + set l "" + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + lappend l [catch {a invokehidden list {"" 1 2 3}} msg] + lappend l $msg + a expose list + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}} +test interp-20.5 {interp hide, interp expose and interp invokehidden -- passing {}} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + a hide list + set l "" + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + lappend l [catch {a invokehidden list {{} 1 2 3}} msg] + lappend l $msg + a expose list + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}} +test interp-20.6 {interp invokehidden -- eval args} { + catch {interp delete a} + interp create a + a hide list + set l "" + set z 45 + lappend l [catch {a invokehidden list $z 1 2 3} msg] + lappend l $msg + a expose list + lappend l [catch {a eval list $z 1 2 3} msg] + lappend l $msg + interp delete a + set l +} {0 {45 1 2 3} 0 {45 1 2 3}} +test interp-20.7 {interp invokehidden vs variable eval} { + catch {interp delete a} + interp create a + a hide list + set z 45 + set l "" + lappend l [catch {a invokehidden list {$z a b c}} msg] + lappend l $msg + interp delete a + set l +} {0 {{$z a b c}}} +test interp-20.8 {interp invokehidden vs variable eval} { + catch {interp delete a} + interp create a + a hide list + a eval set z 89 + set z 45 + set l "" + lappend l [catch {a invokehidden list {$z a b c}} msg] + lappend l $msg + interp delete a + set l +} {0 {{$z a b c}}} +test interp-20.9 {interp invokehidden vs variable eval} { + catch {interp delete a} + interp create a + a hide list + a eval set z 89 + set z 45 + set l "" + lappend l [catch {a invokehidden list $z {$z a b c}} msg] + lappend l $msg + interp delete a + set l +} {0 {45 {$z a b c}}} +test interp-20.10 {interp hide, interp expose and interp invokehidden} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + a eval {proc foo {} {}} + interp hide a foo + catch {interp eval a foo something} msg + interp delete a + set msg +} {invalid command name "foo"} +test interp-20.11 {interp hide, interp expose and interp invokehidden} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + interp hide a list + set l "" + lappend l [catch {interp eval a {list 1 2 3}} msg] + lappend l $msg + interp expose a list + lappend l [catch {interp eval a {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {1 2 3}} +test interp-20.12 {interp hide, interp expose and interp invokehidden} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + interp hide a list + set l "" + lappend l [catch {interp eval a {list 1 2 3}} msg] + lappend l $msg + lappend l [catch {interp invokehidden a list 1 2 3} msg] + lappend l $msg + interp expose a list + lappend l [catch {interp eval a {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}} +test interp-20.13 {interp hide, interp expose, interp invokehidden -- passing {}} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + interp hide a list + set l "" + lappend l [catch {interp eval a {list 1 2 3}} msg] + lappend l $msg + lappend l [catch {interp invokehidden a list {"" 1 2 3}} msg] + lappend l $msg + interp expose a list + lappend l [catch {interp eval a {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}} +test interp-20.14 {interp hide, interp expose, interp invokehidden -- passing {}} { + catch {interp delete a} + interp create a + a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + interp hide a list + set l "" + lappend l [catch {interp eval a {list 1 2 3}} msg] + lappend l $msg + lappend l [catch {interp invokehidden a list {{} 1 2 3}} msg] + lappend l $msg + interp expose a list + lappend l [catch {a eval {list 1 2 3}} msg] + lappend l $msg + interp delete a + set l +} {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}} +test interp-20.15 {interp invokehidden -- eval args} { + catch {interp delete a} + interp create a + interp hide a list + set l "" + set z 45 + lappend l [catch {interp invokehidden a list $z 1 2 3} msg] + lappend l $msg + a expose list + lappend l [catch {interp eval a list $z 1 2 3} msg] + lappend l $msg + interp delete a + set l +} {0 {45 1 2 3} 0 {45 1 2 3}} +test interp-20.16 {interp invokehidden vs variable eval} { + catch {interp delete a} + interp create a + interp hide a list + set z 45 + set l "" + lappend l [catch {interp invokehidden a list {$z a b c}} msg] + lappend l $msg + interp delete a + set l +} {0 {{$z a b c}}} +test interp-20.17 {interp invokehidden vs variable eval} { + catch {interp delete a} + interp create a + interp hide a list + a eval set z 89 + set z 45 + set l "" + lappend l [catch {interp invokehidden a list {$z a b c}} msg] + lappend l $msg + interp delete a + set l +} {0 {{$z a b c}}} +test interp-20.18 {interp invokehidden vs variable eval} { + catch {interp delete a} + interp create a + interp hide a list + a eval set z 89 + set z 45 + set l "" + lappend l [catch {interp invokehidden a list $z {$z a b c}} msg] + lappend l $msg + interp delete a + set l +} {0 {45 {$z a b c}}} +test interp-20.19 {interp invokehidden vs nested commands} { + catch {interp delete a} + interp create a + a hide list + set l [a invokehidden list {[list x y z] f g h} z] + interp delete a + set l +} {{[list x y z] f g h} z} +test interp-20.20 {interp invokehidden vs nested commands} { + catch {interp delete a} + interp create a + a hide list + set l [interp invokehidden a list {[list x y z] f g h} z] + interp delete a + set l +} {{[list x y z] f g h} z} +test interp-20.21 {interp hide vs safety} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [catch {a hide list} msg] + lappend l $msg + interp delete a + set l +} {0 {}} +test interp-20.22 {interp hide vs safety} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [catch {interp hide a list} msg] + lappend l $msg + interp delete a + set l +} {0 {}} +test interp-20.23 {interp hide vs safety} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [catch {a eval {interp hide {} list}} msg] + lappend l $msg + interp delete a + set l +} {1 {permission denied: safe interpreter cannot hide commands}} +test interp-20.24 {interp hide vs safety} { + catch {interp delete a} + interp create a -safe + interp create {a b} + set l "" + lappend l [catch {a eval {interp hide b list}} msg] + lappend l $msg + interp delete a + set l +} {1 {permission denied: safe interpreter cannot hide commands}} +test interp-20.25 {interp hide vs safety} { + catch {interp delete a} + interp create a -safe + interp create {a b} + set l "" + lappend l [catch {interp hide {a b} list} msg] + lappend l $msg + interp delete a + set l +} {0 {}} +test interp-20.26 {interp expoose vs safety} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [catch {a hide list} msg] + lappend l $msg + lappend l [catch {a expose list} msg] + lappend l $msg + interp delete a + set l +} {0 {} 0 {}} +test interp-20.27 {interp expose vs safety} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [catch {interp hide a list} msg] + lappend l $msg + lappend l [catch {interp expose a list} msg] + lappend l $msg + interp delete a + set l +} {0 {} 0 {}} +test interp-20.28 {interp expose vs safety} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [catch {a hide list} msg] + lappend l $msg + lappend l [catch {a eval {interp expose {} list}} msg] + lappend l $msg + interp delete a + set l +} {0 {} 1 {permission denied: safe interpreter cannot expose commands}} +test interp-20.29 {interp expose vs safety} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [catch {interp hide a list} msg] + lappend l $msg + lappend l [catch {a eval {interp expose {} list}} msg] + lappend l $msg + interp delete a + set l +} {0 {} 1 {permission denied: safe interpreter cannot expose commands}} +test interp-20.30 {interp expose vs safety} { + catch {interp delete a} + interp create a -safe + interp create {a b} + set l "" + lappend l [catch {interp hide {a b} list} msg] + lappend l $msg + lappend l [catch {a eval {interp expose b list}} msg] + lappend l $msg + interp delete a + set l +} {0 {} 1 {permission denied: safe interpreter cannot expose commands}} +test interp-20.31 {interp expose vs safety} { + catch {interp delete a} + interp create a -safe + interp create {a b} + set l "" + lappend l [catch {interp hide {a b} list} msg] + lappend l $msg + lappend l [catch {interp expose {a b} list} msg] + lappend l $msg + interp delete a + set l +} {0 {} 0 {}} +test interp-20.32 {interp invokehidden vs safety} { + catch {interp delete a} + interp create a -safe + interp hide a list + set l "" + lappend l [catch {a eval {interp invokehidden {} list a b c}} msg] + lappend l $msg + interp delete a + set l +} {1 {not allowed to invoke hidden commands from safe interpreter}} +test interp-20.33 {interp invokehidden vs safety} { + catch {interp delete a} + interp create a -safe + interp hide a list + set l "" + lappend l [catch {a eval {interp invokehidden {} list a b c}} msg] + lappend l $msg + lappend l [catch {a invokehidden list a b c} msg] + lappend l $msg + interp delete a + set l +} {1 {not allowed to invoke hidden commands from safe interpreter}\ +0 {a b c}} +test interp-20.34 {interp invokehidden vs safety} { + catch {interp delete a} + interp create a -safe + interp create {a b} + interp hide {a b} list + set l "" + lappend l [catch {a eval {interp invokehidden b list a b c}} msg] + lappend l $msg + lappend l [catch {interp invokehidden {a b} list a b c} msg] + lappend l $msg + interp delete a + set l +} {1 {not allowed to invoke hidden commands from safe interpreter}\ +0 {a b c}} +test interp-20.35 {invokehidden at local level} { + catch {interp delete a} + interp create a + a eval { + proc p1 {} { + set z 90 + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a h1 + } + set r [interp eval a p1] + interp delete a + set r +} 91 +test interp-20.36 {invokehidden at local level} { + catch {interp delete a} + interp create a + a eval { + set z 90 + proc p1 {} { + global z + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a h1 + } + set r [interp eval a p1] + interp delete a + set r +} 91 +test interp-20.37 {invokehidden at local level} { + catch {interp delete a} + interp create a + a eval { + proc p1 {} { + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a h1 + } + set r [interp eval a p1] + interp delete a + set r +} 91 +test interp-20.38 {invokehidden at global level} { + catch {interp delete a} + interp create a + a eval { + proc p1 {} { + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a -global h1 + } + set r [catch {interp eval a p1} msg] + interp delete a + list $r $msg +} {1 {can't read "z": no such variable}} +test interp-20.39 {invokehidden at global level} { + catch {interp delete a} + interp create a + a eval { + proc p1 {} { + global z + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a -global h1 + } + set r [catch {interp eval a p1} msg] + interp delete a + list $r $msg +} {0 91} +test interp-20.40 {safe, invokehidden at local level} { + catch {interp delete a} + interp create a -safe + a eval { + proc p1 {} { + set z 90 + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a h1 + } + set r [interp eval a p1] + interp delete a + set r +} 91 +test interp-20.41 {safe, invokehidden at local level} { + catch {interp delete a} + interp create a -safe + a eval { + set z 90 + proc p1 {} { + global z + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a h1 + } + set r [interp eval a p1] + interp delete a + set r +} 91 +test interp-20.42 {safe, invokehidden at local level} { + catch {interp delete a} + interp create a -safe + a eval { + proc p1 {} { + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a h1 + } + set r [interp eval a p1] + interp delete a + set r +} 91 +test interp-20.43 {invokehidden at global level} { + catch {interp delete a} + interp create a + a eval { + proc p1 {} { + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a -global h1 + } + set r [catch {interp eval a p1} msg] + interp delete a + list $r $msg +} {1 {can't read "z": no such variable}} +test interp-20.44 {invokehidden at global level} { + catch {interp delete a} + interp create a + a eval { + proc p1 {} { + global z + a1 + set z + } + proc h1 {} { + upvar z z + set z 91 + } + } + a hide h1 + a alias a1 a1 + proc a1 {} { + interp invokehidden a -global h1 + } + set r [catch {interp eval a p1} msg] + interp delete a + list $r $msg +} {0 91} +test interp-20.45 {interp hide vs namespaces} { + catch {interp delete a} + interp create a + a eval { + namespace eval foo {} + proc foo::x {} {} + } + set l [list [catch {interp hide a foo::x} msg] $msg] + interp delete a + set l +} {1 {cannot use namespace qualifiers as hidden commandtoken (rename)}} +test interp-20.46 {interp hide vs namespaces} { + catch {interp delete a} + interp create a + a eval { + namespace eval foo {} + proc foo::x {} {} + } + set l [list [catch {interp hide a foo::x x} msg] $msg] + interp delete a + set l +} {1 {can only hide global namespace commands (use rename then hide)}} +test interp-20.47 {interp hide vs namespaces} { + catch {interp delete a} + interp create a + a eval { + proc x {} {} + } + set l [list [catch {interp hide a x foo::x} msg] $msg] + interp delete a + set l +} {1 {cannot use namespace qualifiers as hidden commandtoken (rename)}} +test interp-20.48 {interp hide vs namespaces} { + catch {interp delete a} + interp create a + a eval { + namespace eval foo {} + proc foo::x {} {} + } + set l [list [catch {interp hide a foo::x bar::x} msg] $msg] + interp delete a + set l +} {1 {cannot use namespace qualifiers as hidden commandtoken (rename)}} + +test interp-21.1 {interp hidden} { + interp hidden {} +} "" +test interp-21.2 {interp hidden} { + interp hidden +} "" +test interp-21.3 {interp hidden vs interp hide, interp expose} { + set l "" + lappend l [interp hidden] + interp hide {} pwd + lappend l [interp hidden] + interp expose {} pwd + lappend l [interp hidden] + set l +} {{} pwd {}} +test interp-21.4 {interp hidden} { + catch {interp delete a} + interp create a + set l [interp hidden a] + interp delete a + set l +} "" +test interp-21.5 {interp hidden} { + catch {interp delete a} + interp create -safe a + set l [lsort [interp hidden a]] + interp delete a + set l +} $hidden_cmds +test interp-21.6 {interp hidden vs interp hide, interp expose} { + catch {interp delete a} + interp create a + set l "" + lappend l [interp hidden a] + interp hide a pwd + lappend l [interp hidden a] + interp expose a pwd + lappend l [interp hidden a] + interp delete a + set l +} {{} pwd {}} +test interp-21.7 {interp hidden} { + catch {interp delete a} + interp create a + set l [a hidden] + interp delete a + set l +} "" +test interp-21.8 {interp hidden} { + catch {interp delete a} + interp create a -safe + set l [lsort [a hidden]] + interp delete a + set l +} $hidden_cmds +test interp-21.9 {interp hidden vs interp hide, interp expose} { + catch {interp delete a} + interp create a + set l "" + lappend l [a hidden] + a hide pwd + lappend l [a hidden] + a expose pwd + lappend l [a hidden] + interp delete a + set l +} {{} pwd {}} + +test interp-22.1 {testing interp marktrusted} { + catch {interp delete a} + interp create a + set l "" + lappend l [a issafe] + lappend l [a marktrusted] + lappend l [a issafe] + interp delete a + set l +} {0 {} 0} +test interp-22.2 {testing interp marktrusted} { + catch {interp delete a} + interp create a + set l "" + lappend l [interp issafe a] + lappend l [interp marktrusted a] + lappend l [interp issafe a] + interp delete a + set l +} {0 {} 0} +test interp-22.3 {testing interp marktrusted} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [a issafe] + lappend l [a marktrusted] + lappend l [a issafe] + interp delete a + set l +} {1 {} 0} +test interp-22.4 {testing interp marktrusted} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [interp issafe a] + lappend l [interp marktrusted a] + lappend l [interp issafe a] + interp delete a + set l +} {1 {} 0} +test interp-22.5 {testing interp marktrusted} { + catch {interp delete a} + interp create a -safe + interp create {a b} + catch {a eval {interp marktrusted b}} msg + interp delete a + set msg +} {"interp marktrusted" can only be invoked from a trusted interpreter} +test interp-22.6 {testing interp marktrusted} { + catch {interp delete a} + interp create a -safe + interp create {a b} + catch {a eval {b marktrusted}} msg + interp delete a + set msg +} {"b marktrusted" can only be invoked from a trusted interpreter} +test interp-22.7 {testing interp marktrusted} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [interp issafe a] + interp marktrusted a + interp create {a b} + lappend l [interp issafe a] + lappend l [interp issafe {a b}] + interp delete a + set l +} {1 0 0} +test interp-22.8 {testing interp marktrusted} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [interp issafe a] + interp create {a b} + lappend l [interp issafe {a b}] + interp marktrusted a + interp create {a c} + lappend l [interp issafe a] + lappend l [interp issafe {a c}] + interp delete a + set l +} {1 1 0 0} +test interp-22.9 {testing interp marktrusted} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [interp issafe a] + interp create {a b} + lappend l [interp issafe {a b}] + interp marktrusted {a b} + lappend l [interp issafe a] + lappend l [interp issafe {a b}] + interp create {a b c} + lappend l [interp issafe {a b c}] + interp delete a + set l +} {1 1 1 0 0} + +test interp-23.1 {testing hiding vs aliases} { + catch {interp delete a} + interp create a + set l "" + lappend l [interp hidden a] + a alias bar bar + lappend l [interp aliases a] + lappend l [interp hidden a] + a hide bar + lappend l [interp aliases a] + lappend l [interp hidden a] + a alias bar {} + lappend l [interp aliases a] + lappend l [interp hidden a] + interp delete a + set l +} {{} bar {} bar bar {} {}} +test interp-23.2 {testing hiding vs aliases} {pc || unix} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [lsort [interp hidden a]] + a alias bar bar + lappend l [interp aliases a] + lappend l [lsort [interp hidden a]] + a hide bar + lappend l [interp aliases a] + lappend l [lsort [interp hidden a]] + a alias bar {} + lappend l [interp aliases a] + lappend l [lsort [interp hidden a]] + interp delete a + set l +} {{cd exec exit fconfigure file glob load open pwd socket source} bar {cd exec exit fconfigure file glob load open pwd socket source} bar {bar cd exec exit fconfigure file glob load open pwd socket source} {} {cd exec exit fconfigure file glob load open pwd socket source}} + +test interp-23.3 {testing hiding vs aliases} {macOnly} { + catch {interp delete a} + interp create a -safe + set l "" + lappend l [lsort [interp hidden a]] + a alias bar bar + lappend l [interp aliases a] + lappend l [lsort [interp hidden a]] + a hide bar + lappend l [interp aliases a] + lappend l [lsort [interp hidden a]] + a alias bar {} + lappend l [interp aliases a] + lappend l [lsort [interp hidden a]] + interp delete a + set l +} {{beep cd echo exit fconfigure file glob load ls open pwd socket source} bar {beep cd echo exit fconfigure file glob load ls open pwd socket source} bar {bar beep cd echo exit fconfigure file glob load ls open pwd socket source} {} {beep cd echo exit fconfigure file glob load ls open pwd socket source}} + +test interp-24.1 {result resetting on error} { + catch {interp delete a} + interp create a + proc foo args {error $args} + interp alias a foo {} foo + set l [interp eval a { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.2 {result resetting on error} { + catch {interp delete a} + interp create a -safe + proc foo args {error $args} + interp alias a foo {} foo + set l [interp eval a { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.3 {result resetting on error} { + catch {interp delete a} + interp create a + interp create {a b} + interp eval a { + proc foo args {error $args} + } + interp alias {a b} foo a foo + set l [interp eval {a b} { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.4 {result resetting on error} { + catch {interp delete a} + interp create a -safe + interp create {a b} + interp eval a { + proc foo args {error $args} + } + interp alias {a b} foo a foo + set l [interp eval {a b} { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.5 {result resetting on error} { + catch {interp delete a} + catch {interp delete b} + interp create a + interp create b + interp eval a { + proc foo args {error $args} + } + interp alias b foo a foo + set l [interp eval b { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.6 {result resetting on error} { + catch {interp delete a} + catch {interp delete b} + interp create a -safe + interp create b -safe + interp eval a { + proc foo args {error $args} + } + interp alias b foo a foo + set l [interp eval b { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.7 {result resetting on error} { + catch {interp delete a} + interp create a + interp eval a { + proc foo args {error $args} + } + set l {} + lappend l [catch {interp eval a foo 1 2 3} msg] + lappend l $msg + lappend l [catch {interp eval a foo 3 4 5} msg] + lappend l $msg + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.8 {result resetting on error} { + catch {interp delete a} + interp create a -safe + interp eval a { + proc foo args {error $args} + } + set l {} + lappend l [catch {interp eval a foo 1 2 3} msg] + lappend l $msg + lappend l [catch {interp eval a foo 3 4 5} msg] + lappend l $msg + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.9 {result resetting on error} { + catch {interp delete a} + interp create a + interp create {a b} + interp eval {a b} { + proc foo args {error $args} + } + interp eval a { + proc foo args { + eval interp eval b foo $args + } + } + set l {} + lappend l [catch {interp eval a foo 1 2 3} msg] + lappend l $msg + lappend l [catch {interp eval a foo 3 4 5} msg] + lappend l $msg + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.10 {result resetting on error} { + catch {interp delete a} + interp create a -safe + interp create {a b} + interp eval {a b} { + proc foo args {error $args} + } + interp eval a { + proc foo args { + eval interp eval b foo $args + } + } + set l {} + lappend l [catch {interp eval a foo 1 2 3} msg] + lappend l $msg + lappend l [catch {interp eval a foo 3 4 5} msg] + lappend l $msg + interp delete a + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.11 {result resetting on error} { + catch {interp delete a} + interp create a + interp create {a b} + interp eval {a b} { + proc foo args {error $args} + } + interp eval a { + proc foo args { + set l {} + lappend l [catch {eval interp eval b foo $args} msg] + lappend l $msg + lappend l [catch {eval interp eval b foo $args} msg] + lappend l $msg + set l + } + } + set l [interp eval a foo 1 2 3] + interp delete a + set l +} {1 {1 2 3} 1 {1 2 3}} +test interp-24.12 {result resetting on error} { + catch {interp delete a} + interp create a -safe + interp create {a b} + interp eval {a b} { + proc foo args {error $args} + } + interp eval a { + proc foo args { + set l {} + lappend l [catch {eval interp eval b foo $args} msg] + lappend l $msg + lappend l [catch {eval interp eval b foo $args} msg] + lappend l $msg + set l + } + } + set l [interp eval a foo 1 2 3] + interp delete a + set l +} {1 {1 2 3} 1 {1 2 3}} + +unset hidden_cmds + +test interp-25.1 {testing aliasing of string commands} { + catch {interp delete a} + interp create a + a alias exec foo ;# Relies on exec being a string command! + interp delete a +} "" + + +# Interps result transmission +test interp-26.1 {result code transmission 1} {knownBug} { + # This test currently fails ! (only ok/error are passed, not the other + # codes). Fixing the code is thus needed... -- dl + # (the only other acceptable result list would be + # {-1 0 1 0 3 4 5} because of the way return -code return(=2) works) + # test that all the possibles error codes from Tcl get passed + catch {interp delete a} + interp create a + interp eval a {proc ret {code} {return -code $code $code}} + set res {} + # use a for so if a return -code break 'escapes' we would notice + for {set code -1} {$code<=5} {incr code} { + lappend res [catch {interp eval a ret $code} msg] + } + interp delete a + set res +} {-1 0 1 2 3 4 5} + +test interp-26.2 {result code transmission 2} {knownBug} { + # This test currently fails ! (error is cleared) + # Code fixing is needed... -- dl + # (the only other acceptable result list would be + # {-1 0 1 0 3 4 5} because of the way return -code return(=2) works) + # test that all the possibles error codes from Tcl get passed + set interp [interp create]; + proc MyTestAlias {interp args} { + global aliasTrace; + lappend aliasTrace $args; + eval interp invokehidden [list $interp] $args + } + foreach c {return} { + interp hide $interp $c; + interp alias $interp $c {} MyTestAlias $interp $c; + } + interp eval $interp {proc ret {code} {return -code $code $code}} + set res {} + set aliasTrace {} + for {set code -1} {$code<=5} {incr code} { + lappend res [catch {interp eval $interp ret $code} msg] + } + interp delete $interp; + list $res +} {-1 0 1 2 3 4 5} + +test interp-26.3 {errorInfo transmission : regular interps} { + set interp [interp create]; + proc MyError {secret} { + return -code error "msg" + } + proc MyTestAlias {interp args} { + MyError "some secret" + } + interp alias $interp test {} MyTestAlias $interp; + set res [interp eval $interp {catch test;set errorInfo}] + interp delete $interp; + set res +} {msg + while executing +"MyError "some secret"" + (procedure "test" line 2) + invoked from within +"catch test"} + +test interp-26.4 {errorInfo transmission : safe interps} {knownBug} { + # this test fails because the errorInfo is fully transmitted + # whether the interp is safe or not. this is maybe a feature + # and not a bug. + set interp [interp create -safe]; + proc MyError {secret} { + return -code error "msg" + } + proc MyTestAlias {interp args} { + MyError "some secret" + } + interp alias $interp test {} MyTestAlias $interp; + set res [interp eval $interp {catch test;set errorInfo}] + interp delete $interp; + set res +} {msg + while executing +"catch test"} + +# Interps & Namespaces +test interp-27.1 {interp aliases & namespaces} { + set i [interp create]; + set aliasTrace {}; + proc tstAlias {args} { + global aliasTrace; + lappend aliasTrace [list [namespace current] $args]; + } + $i alias foo::bar tstAlias foo::bar; + $i eval foo::bar test + interp delete $i + set aliasTrace; +} {{:: {foo::bar test}}} + +test interp-27.2 {interp aliases & namespaces} { + set i [interp create]; + set aliasTrace {}; + proc tstAlias {args} { + global aliasTrace; + lappend aliasTrace [list [namespace current] $args]; + } + $i alias foo::bar tstAlias foo::bar; + $i eval namespace eval foo {bar test} + interp delete $i + set aliasTrace; +} {{:: {foo::bar test}}} + +test interp-27.3 {interp aliases & namespaces} { + set i [interp create]; + set aliasTrace {}; + proc tstAlias {args} { + global aliasTrace; + lappend aliasTrace [list [namespace current] $args]; + } + interp eval $i {namespace eval foo {proc bar {} {error "bar called"}}} + interp alias $i foo::bar {} tstAlias foo::bar; + interp eval $i {namespace eval foo {bar test}} + interp delete $i + set aliasTrace; +} {{:: {foo::bar test}}} + +test interp-27.4 {interp aliases & namespaces} { + set i [interp create]; + namespace eval foo2 { + variable aliasTrace {}; + proc bar {args} { + variable aliasTrace; + lappend aliasTrace [list [namespace current] $args]; + } + } + $i alias foo::bar foo2::bar foo::bar; + $i eval namespace eval foo {bar test} + set r $foo2::aliasTrace; + namespace delete foo2; + set r +} {{::foo2 {foo::bar test}}} + +# the following tests are commented out while we don't support +# hiding in namespaces + +# test interp-27.5 {interp hidden & namespaces} { +# set i [interp create]; +# interp eval $i { +# namespace eval foo { +# proc bar {args} { +# return "bar called ([namespace current]) ($args)" +# } +# } +# } +# set res [list [interp eval $i {namespace eval foo {bar test1}}]] +# interp hide $i foo::bar; +# lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg] +# interp delete $i; +# set res; +#} {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}} + +# test interp-27.6 {interp hidden & aliases & namespaces} { +# set i [interp create]; +# set v root-master; +# namespace eval foo { +# variable v foo-master; +# proc bar {interp args} { +# variable v; +# list "master bar called ($v) ([namespace current]) ($args)"\ +# [interp invokehidden $interp foo::bar $args]; +# } +# } +# interp eval $i { +# namespace eval foo { +# namespace export * +# variable v foo-slave; +# proc bar {args} { +# variable v; +# return "slave bar called ($v) ([namespace current]) ($args)" +# } +# } +# } +# set res [list [interp eval $i {namespace eval foo {bar test1}}]] +# $i hide foo::bar; +# $i alias foo::bar foo::bar $i; +# set res [concat $res [interp eval $i { +# set v root-slave; +# namespace eval test { +# variable v foo-test; +# namespace import ::foo::*; +# bar test2 +# } +# }]] +# namespace delete foo; +# interp delete $i; +# set res +# } {{slave bar called (foo-slave) (::foo) (test1)} {master bar called (foo-master) (::foo) (test2)} {slave bar called (foo-slave) (::foo) (test2)}} + + +# test interp-27.7 {interp hidden & aliases & imports & namespaces} { +# set i [interp create]; +# set v root-master; +# namespace eval mfoo { +# variable v foo-master; +# proc bar {interp args} { +# variable v; +# list "master bar called ($v) ([namespace current]) ($args)"\ +# [interp invokehidden $interp test::bar $args]; +# } +# } +# interp eval $i { +# namespace eval foo { +# namespace export * +# variable v foo-slave; +# proc bar {args} { +# variable v; +# return "slave bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)" +# } +# } +# set v root-slave; +# namespace eval test { +# variable v foo-test; +# namespace import ::foo::*; +# } +# } +# set res [list [interp eval $i {namespace eval test {bar test1}}]] +# $i hide test::bar; +# $i alias test::bar mfoo::bar $i; +# set res [concat $res [interp eval $i {test::bar test2}]]; +# namespace delete mfoo; +# interp delete $i; +# set res +# } {{slave bar called (foo-slave) (bar test1) (::test) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}} + +#test interp-27.8 {hiding, namespaces and integrity} { +# namespace eval foo { +# variable v 3; +# proc bar {} {variable v; set v} +# # next command would currently generate an unknown command "bar" error. +# interp hide {} bar; +# } +# namespace delete foo; +# list [catch {interp invokehidden {} foo} msg] $msg; +#} {1 {invalid hidden command name "foo"}} + + +test interp-28.1 {getting fooled by slave's namespace ?} { + set i [interp create -safe]; + proc master {interp args} {interp hide $interp list} + $i alias master master $i; + set r [interp eval $i { + namespace eval foo { + proc list {args} { + return "dummy foo::list"; + } + master; + } + info commands list + }] + interp delete $i; + set r +} {} + +# Tests of recursionlimit +# We need testsetrecursionlimit so we need Tcltest package +if {[catch {package require Tcltest} msg]} { + puts "This application hasn't been compiled with Tcltest" + puts "skipping remining interp tests that relies on it." +} else { + # +test interp-29.1 {recursion limit} { + set i [interp create] + load {} Tcltest $i + set r [interp eval $i { + testsetrecursionlimit 50 + proc p {} {incr ::i; p} + set i 0 + catch p + set i + }] + interp delete $i + set r +} 49 + +test interp-29.2 {recursion limit inheritance} { + set i [interp create] + load {} Tcltest $i + set ii [interp eval $i { + testsetrecursionlimit 50 + interp create + }] + set r [interp eval [list $i $ii] { + proc p {} {incr ::i; p} + set i 0 + catch p + set i + }] + interp delete $i + set r +} 49 + +# # Deep recursion (into interps when the regular one fails): +# # still crashes... +# proc p {} { +# if {[catch p ret]} { +# catch { +# set i [interp create] +# interp eval $i [list proc p {} [info body p]] +# interp eval $i p +# } +# interp delete $i +# return ok +# } +# return $ret +# } +# p + +# more tests needed... + +# Interp & stack +#test interp-29.1 {interp and stack (info level)} { +#} {} + +} + + +foreach i [interp slaves] { + interp delete $i +} diff --git a/tests/io.test b/tests/io.test new file mode 100644 index 0000000..2b6670f --- /dev/null +++ b/tests/io.test @@ -0,0 +1,5143 @@ +# Functionality covered: operation of all IO commands, and all procedures +# defined in generic/tclIO.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-1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) io.test 1.131 97/09/22 11:15:05 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {"[info commands testchannel]" != "testchannel"} { + puts "Skipping io tests. This application does not seem to have the" + puts "testchannel command that is needed to run these tests." + return +} + +removeFile test1 +removeFile pipe + +# set up a long data file for some of the following tests + +set f [open longfile w] +fconfigure $f -eofchar {} -translation lf +for { set i 0 } { $i < 100 } { incr i} { + puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef +\#123456789abcdef01 +\#" + } +close $f + +set f [open cat w] +puts $f { + if {$argv == {}} { + set argv - + } + foreach name $argv { + if {$name == "-"} { + set f stdin + } elseif {[catch {open $name r} f] != 0} { + puts stderr $f + continue + } + while {[eof $f] == 0} { + puts -nonewline stdout [read $f] + } + if {$f != "stdin"} { + close $f + } + } +} +close $f + +# These tests are disabled until we decide what to do with "unsupported0". +# +#test io-1.7 {unsupported0 command} { +# removeFile test1 +# set f1 [open iocmd.test] +# set f2 [open test1 w] +# unsupported0 $f1 $f2 +# close $f1 +# catch {close $f2} +# set s1 [file size [info script]] +# set s2 [file size test1] +# set x ok +# if {"$s1" != "$s2"} { +# set x broken +# } +# set x +#} ok +#test io-1.8 {unsupported0 command} { +# removeFile test1 +# set f1 [open [info script]] +# set f2 [open test1 w] +# unsupported0 $f1 $f2 40 +# close $f1 +# close $f2 +# file size test1 +#} 40 +#test io-1.9 {unsupported0 command} { +# removeFile test1 +# set f1 [open [info script]] +# set f2 [open test1 w] +# unsupported0 $f1 $f2 -1 +# close $f1 +# close $f2 +# set x ok +# set s1 [file size [info script]] +# set s2 [file size test1] +# if {$s1 != $s2} { +# set x broken +# } +# set x +#} ok +#test io-1.10 {unsupported0 command} {unixOrPc} { +# removeFile pipe +# removeFile test1 +# set f1 [open pipe w] +# puts $f1 {puts ready} +# puts $f1 {gets stdin} +# puts $f1 {set f1 [open [info script] r]} +# puts $f1 {puts [read $f1 100]} +# puts $f1 {close $f1} +# close $f1 +# set f1 [open "|[list $tcltest pipe]" r+] +# gets $f1 +# puts $f1 ready +# flush $f1 +# set f2 [open test1 w] +# set c [unsupported0 $f1 $f2 40] +# catch {close $f1} +# close $f2 +# set s1 [file size test1] +# set x ok +# if {$s1 != "40"} { +# set x broken +# } +# list $c $x +#} {40 ok} + +# Test standard handle management. The functions tested are +# Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are +# also testing channel table management. + +if {$tcl_platform(platform) == "macintosh"} { + set consoleFileNames [list console0 console1 console2] +} else { + set consoleFileNames [lsort [testchannel open]] +} +test io-1.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} { + set l "" + lappend l [fconfigure stdin -buffering] + lappend l [fconfigure stdout -buffering] + lappend l [fconfigure stderr -buffering] + lappend l [lsort [testchannel open]] + set l +} [list line line none $consoleFileNames] +test io-1.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { + interp create x + set l "" + lappend l [x eval {fconfigure stdin -buffering}] + lappend l [x eval {fconfigure stdout -buffering}] + lappend l [x eval {fconfigure stderr -buffering}] + interp delete x + set l +} {line line none} +test io-1.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {stdio} { + set f [open test1 w] + puts $f { + close stdin + close stdout + close stderr + set f [open test1 r] + set f2 [open test2 w] + set f3 [open test3 w] + puts stdout [gets stdin] + puts stdout out + puts stderr err + close $f + close $f2 + close $f3 + } + close $f + set result [exec $tcltest test1] + set f [open test2 r] + set f2 [open test3 r] + lappend result [read $f] [read $f2] + close $f + close $f2 + set result +} {{ +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} { + set f [open test1 w] + puts $f { close stdin + close stdout + close stderr + set f [open test1 r] + set f2 [open test2 w] + set f3 [open test3 w] + puts stdout [gets stdin] + puts stdout $f2 + puts stderr $f3 + close $f + close $f2 + close $f3 + } + close $f + set result [exec $tcltest test1] + set f [open test2 r] + set f2 [open test3 r] + lappend result [read $f] [read $f2] + close $f + close $f2 + set result +} {{ close stdin +file1 +} {file2 +}} +catch {interp delete z} +test io-1.5 {Tcl_GetChannel: stdio name translation} { + interp create z + eof stdin + catch {z eval flush stdin} msg1 + catch {z eval close stdin} msg2 + catch {z eval flush stdin} msg3 + set result [list $msg1 $msg2 $msg3] + 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} { + interp create z + eof stdout + catch {z eval flush stdout} msg1 + catch {z eval close stdout} msg2 + catch {z eval flush stdout} msg3 + set result [list $msg1 $msg2 $msg3] + interp delete z + set result +} {{} {} {can not find channel named "stdout"}} +test io-1.7 {Tcl_GetChannel: stdio name translation} { + interp create z + eof stderr + catch {z eval flush stderr} msg1 + catch {z eval close stderr} msg2 + catch {z eval flush stderr} msg3 + set result [list $msg1 $msg2 $msg3] + interp delete z + set result +} {{} {} {can not find channel named "stderr"}} +test io-1.8 {reuse of stdio special channels} {unixOnly} { + removeFile script + removeFile test1 + set f [open script w] + puts $f { + close stderr + set f [open test1 w] + puts stderr hello + close $f + set f [open test1 r] + puts [gets $f] + } + close $f + set f [open "|[list $tcltest script]" r] + set c [gets $f] + close $f + set c +} hello +test io-1.9 {reuse of stdio special channels} {stdio} { + removeFile script + removeFile test1 + set f [open script w] + puts $f { + set f [open test1 w] + puts $f hello + close $f + close stderr + set f [open "|[list [info nameofexecutable] cat test1]" r] + puts [gets $f] + } + close $f + set f [open "|[list $tcltest script]" r] + set c [gets $f] + close $f + set c +} hello + +# Must add test function for testing Tcl_CreateCloseHandler and +# Tcl_DeleteCloseHandler. + +# Test channel table management. The functions tested are +# GetChannelTable, DeleteChannelTable, Tcl_RegisterChannel, +# Tcl_UnregisterChannel, Tcl_GetChannel and Tcl_CreateChannel. +# +# These functions use "eof stdin" to ensure that the standard +# channels are added to the channel table of the interpreter. + +test io-2.1 {GetChannelTable, DeleteChannelTable on std handles} { + set l1 [testchannel refcount stdin] + eof stdin + interp create x + set l "" + lappend l [expr [testchannel refcount stdin] - $l1] + x eval {eof stdin} + lappend l [expr [testchannel refcount stdin] - $l1] + interp delete x + lappend l [expr [testchannel refcount stdin] - $l1] + set l +} {0 1 0} +test io-2.2 {GetChannelTable, DeleteChannelTable on std handles} { + set l1 [testchannel refcount stdout] + eof stdin + interp create x + set l "" + lappend l [expr [testchannel refcount stdout] - $l1] + x eval {eof stdout} + lappend l [expr [testchannel refcount stdout] - $l1] + interp delete x + lappend l [expr [testchannel refcount stdout] - $l1] + set l +} {0 1 0} +test io-2.3 {GetChannelTable, DeleteChannelTable on std handles} { + set l1 [testchannel refcount stderr] + eof stdin + interp create x + set l "" + lappend l [expr [testchannel refcount stderr] - $l1] + x eval {eof stderr} + lappend l [expr [testchannel refcount stderr] - $l1] + interp delete x + lappend l [expr [testchannel refcount stderr] - $l1] + set l +} {0 1 0} +test io-2.4 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { + removeFile test1 + set l "" + set f [open test1 w] + lappend l [lindex [testchannel info $f] 15] + close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being closed" + } + string compare [string tolower $l] \ + [list 1 [format "can not find channel named \"%s\"" $f]] +} 0 +test io-2.5 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { + removeFile test1 + set l "" + set f [open test1 w] + lappend l [lindex [testchannel info $f] 15] + interp create x + interp share "" $f x + lappend l [lindex [testchannel info $f] 15] + x eval close $f + lappend l [lindex [testchannel info $f] 15] + interp delete x + lappend l [lindex [testchannel info $f] 15] + close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being closed" + } + 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} { + removeFile test1 + set l "" + set f [open test1 w] + lappend l [lindex [testchannel info $f] 15] + interp create x + interp share "" $f x + lappend l [lindex [testchannel info $f] 15] + interp delete x + lappend l [lindex [testchannel info $f] 15] + close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being closed" + } + 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} { + eof stdin +} 0 +test io-2.8 {testing Tcl_GetChannel, user opened handle} { + removeFile test1 + set f [open test1 w] + set x [eof $f] + close $f + set x +} 0 +test io-2.9 {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} { + removeFile test1 + set f [open test1 w] + set l "" + lappend l [eof $f] + close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being closed" + } + string compare [string tolower $l] \ + [list 0 [format "can not find channel named \"%s\"" $f]] +} 0 + +# 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} { + 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} { + 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} { + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + puts $f "1234567890\n098765432" + close $f + set f [open test1 r] + gets $f + set l "" + lappend l [testchannel inputbuffered $f] + lappend l [tell $f] + close $f + set l +} {10 11} +test io-3.4 {Tcl_GetChannelFile, output} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [tell $f] + flush $f + lappend l [testchannel outputbuffered $f] + lappend l [tell $f] + close $f + removeFile test1 + set l +} {6 6 0 6} + +# Test flushing. The functions tested here are FlushChannel. + +test io-4.1 {FlushChannel, no output buffered} { + removeFile test1 + set f [open test1 w] + flush $f + set s [file size test1] + close $f + set s +} 0 +test io-4.2 {FlushChannel, some output buffered} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set l "" + puts $f hello + lappend l [file size test1] + flush $f + lappend l [file size test1] + close $f + lappend l [file size test1] + set l +} {0 6 6} +test io-4.3 {FlushChannel, implicit flush on close} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set l "" + puts $f hello + lappend l [file size test1] + close $f + lappend l [file size test1] + set l +} {0 6} +test io-4.4 {FlushChannel, implicit flush when buffer fills} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + fconfigure $f -buffersize 60 + set l "" + lappend l [file size test1] + for {set i 0} {$i < 12} {incr i} { + puts $f hello + } + lappend l [file size test1] + flush $f + lappend l [file size test1] + close $f + set l +} {0 60 72} +test io-4.5 {FlushChannel, implicit flush when buffer fills and on close} {unixOrPc} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -buffersize 60 -eofchar {} + set l "" + lappend l [file size test1] + for {set i 0} {$i < 12} {incr i} { + puts $f hello + } + lappend l [file size test1] + close $f + lappend l [file size test1] + set l +} {0 60 72} +test io-4.6 {FlushChannel, async flushing, async close} {stdio && asyncPipeClose} { + removeFile pipe + removeFile output + set f [open pipe w] + puts $f { + set f [open output w] + fconfigure $f -translation lf -buffering none -eofchar {} + while {![eof stdin]} { + after 20 + puts -nonewline $f [read stdin 1024] + } + close $f + } + close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open output w] + close $f + set f [open "|[list $tcltest pipe]" w] + fconfigure $f -blocking off + puts -nonewline $f $x + close $f + set counter 0 + while {([file size output] < 65536) && ($counter < 1000)} { + incr counter + after 20 + update + } + if {$counter == 1000} { + set result probably_broken + } else { + set result ok + } +} ok + +# Tests closing a channel. The functions tested are CloseChannel and Tcl_Close. + +test io-5.1 {CloseChannel called when all references are dropped} { + removeFile test1 + set f [open test1 w] + interp create x + interp share "" $f x + set l "" + lappend l [testchannel refcount $f] + x eval close $f + interp delete x + lappend l [testchannel refcount $f] + close $f + set l +} {2 1} +test io-5.2 {CloseChannel called when all references are dropped} { + removeFile test1 + set f [open test1 w] + interp create x + interp share "" $f x + puts -nonewline $f abc + close $f + x eval puts $f def + x eval close $f + interp delete x + set f [open test1 r] + set l [gets $f] + close $f + set l +} abcdef +test io-5.3 {CloseChannel, not called before output queue is empty} {unixOrPc asyncPipeClose nonPortable tempNotPc} { + removeFile pipe + removeFile output + set f [open pipe w] + puts $f { + + # Need to not have eof char appended on close, because the other + # side of the pipe already closed, so that writing would cause an + # error "invalid file". + + fconfigure stdout -eofchar {} + fconfigure stderr -eofchar {} + + set f [open output w] + fconfigure $f -translation lf -buffering none + for {set x 0} {$x < 20} {incr x} { + after 20 + puts -nonewline $f [read stdin 1024] + } + close $f + } + close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open output w] + close $f + 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 + while {([file size output] < 20480) && ($counter < 1000)} { + incr counter + after 20 + update + } + if {$counter == 1000} { + set result probably_broken + } else { + set result ok + } +} ok +test io-5.4 {Tcl_Close} { + removeFile test1 + set l "" + lappend l [lsort [testchannel open]] + set f [open test1 w] + lappend l [lsort [testchannel open]] + close $f + lappend l [lsort [testchannel open]] + set x [list $consoleFileNames \ + [lsort [eval list $consoleFileNames $f]] \ + $consoleFileNames] + string compare $l $x +} 0 +test io-5.5 {Tcl_Close vs standard handles} {unixOnly} { + removeFile script + set f [open script w] + puts $f { + close stdin + puts [testchannel open] + } + close $f + set f [open "|[list $tcltest script]" r] + set l [gets $f] + close $f + 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} { + list [catch {puts stdin hello} msg] $msg +} {1 {channel "stdin" wasn't opened for writing}} +test io-6.2 {Tcl_Write, empty string} { + removeFile test1 + set f [open test1 w] + fconfigure $f -eofchar {} + puts -nonewline $f "" + close $f + file size test1 +} 0 +test io-6.3 {Tcl_Write, nonempty string} { + removeFile test1 + set f [open test1 w] + fconfigure $f -eofchar {} + puts -nonewline $f hello + close $f + file size test1 +} 5 +test io-6.4 {Tcl_Write, buffering in full buffering mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -buffering full -eofchar {} + puts $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + close $f + set l +} {6 0 0 6} +test io-6.5 {Tcl_Write, buffering in line buffering mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -buffering line -eofchar {} + puts -nonewline $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + close $f + set l +} {5 0 0 11} +test io-6.6 {Tcl_Write, buffering in no buffering mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -buffering none -eofchar {} + puts -nonewline $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + close $f + set l +} {0 5 0 11} +test io-6.7 {Tcl_Flush, full buffering} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -buffering full -eofchar {} + puts -nonewline $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + close $f + set l +} {5 0 11 0 0 11} +test io-6.8 {Tcl_Flush, full buffering} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -buffering line + puts -nonewline $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + close $f + set l +} {5 0 0 5 0 11 0 11} +test io-6.9 {Tcl_Flush, channel not writable} { + list [catch {flush stdin} msg] $msg +} {1 {channel "stdin" wasn't opened for writing}} +test io-6.10 {Tcl_Write, 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] + } + close $f2 + close $f1 + file size test1 +} 387 +test io-6.11 {Tcl_Write, 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] + } + close $f1 + close $f2 + file size test1 +} 377 +test io-6.12 {Tcl_Write on a pipe} {stdio} { + removeFile test1 + removeFile pipe + set f1 [open pipe w] + puts $f1 { + set f1 [open longfile r] + for {set x 0} {$x < 10} {incr x} { + puts [gets $f1] + } + } + close $f1 + set f1 [open "|[list $tcltest pipe]" r] + 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 + } + } + close $f1 + close $f2 + set y +} ok +test io-6.13 {Tcl_Write to a pipe, line buffered} {stdio} { + removeFile test1 + removeFile pipe + set f1 [open pipe w] + puts $f1 { + puts [gets stdin] + puts [gets stdin] + } + close $f1 + set y ok + set f1 [open "|[list $tcltest pipe]" r+] + fconfigure $f1 -buffering line + set f2 [open longfile r] + set line [gets $f2] + puts $f1 $line + set backline [gets $f1] + if {"$line" != "$backline"} { + set y broken + } + set line [gets $f2] + puts $f1 $line + set backline [gets $f1] + if {"$line" != "$backline"} { + set y broken + } + close $f1 + close $f2 + set y +} ok +test io-6.14 {Tcl_Write, buffering and implicit flush at close} { + removeFile test3 + set f [open test3 w] + puts -nonewline $f "Text1" + puts -nonewline $f " Text 2" + puts $f " Text 3" + close $f + set f [open test3 r] + set x [gets $f] + close $f + set x +} {Text1 Text 2 Text 3} +test io-6.15 {Tcl_Flush, channel not open for writing} { + removeFile test1 + set fd [open test1 w] + close $fd + set fd [open test1 r] + set x [list [catch {flush $fd} msg] $msg] + close $fd + 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} { + 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} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf + puts $f1 hello + puts $f1 hello + puts $f1 hello + flush $f1 + set x [file size test1] + close $f1 + set x +} 18 +test io-6.18 {Tcl_Write and Tcl_Flush intermixed} { + removeFile test1 + set x "" + set f1 [open test1 w] + fconfigure $f1 -translation lf + puts $f1 hello + puts $f1 hello + puts $f1 hello + flush $f1 + lappend x [file size test1] + puts $f1 hello + flush $f1 + lappend x [file size test1] + puts $f1 hello + flush $f1 + lappend x [file size test1] + close $f1 + set x +} {18 24 30} +test io-6.19 {Explicit and implicit flushes} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + set x "" + puts $f1 hello + puts $f1 hello + puts $f1 hello + flush $f1 + lappend x [file size test1] + puts $f1 hello + flush $f1 + lappend x [file size test1] + puts $f1 hello + close $f1 + lappend x [file size test1] + set x +} {18 24 30} +test io-6.20 {Implicit flush when buffer is full} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" + for {set x 0} {$x < 100} {incr x} { + puts $f1 $line + } + set z "" + lappend z [file size test1] + for {set x 0} {$x < 100} {incr x} { + 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} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {set x [read stdin 6]} + puts $f1 {set cnt [string length $x]} + puts $f1 {puts "read $cnt characters"} + close $f1 + set f1 [open "|[list $tcltest pipe]" r+] + puts $f1 hello + flush $f1 + set x [gets $f1] + catch {close $f1} + set x +} "read 6 characters" +test io-6.22 {Tcl_Flush called at other end of pipe} {stdio} { + removeFile pipe + set f1 [open pipe w] + puts $f1 { + fconfigure stdout -buffering full + puts hello + puts hello + flush stdout + gets stdin + puts bye + flush stdout + } + close $f1 + set f1 [open "|[list $tcltest pipe]" r+] + set x "" + lappend x [gets $f1] + lappend x [gets $f1] + puts $f1 hello + flush $f1 + lappend x [gets $f1] + close $f1 + set x +} {hello hello bye} +test io-6.23 {Tcl_Flush and line buffering at end of pipe} {stdio} { + removeFile pipe + set f1 [open pipe w] + puts $f1 { + puts hello + puts hello + gets stdin + puts bye + } + close $f1 + set f1 [open "|[list $tcltest pipe]" r+] + set x "" + lappend x [gets $f1] + lappend x [gets $f1] + puts $f1 hello + flush $f1 + lappend x [gets $f1] + close $f1 + set x +} {hello hello bye} +test io-6.24 {Tcl_Write and Tcl_Flush move end of file} { + set f [open test3 w] + puts $f "Line 1" + puts $f "Line 2" + set f2 [open test3] + set x {} + lappend x [read -nonewline $f2] + close $f2 + flush $f + set f2 [open test3] + lappend x [read -nonewline $f2] + close $f2 + close $f + set x +} {{} {Line 1 +Line 2}} +test io-6.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" + puts $f "Line 2" + close $f + after 100 + set f [open test3 r] + 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} { + set f [open "|[list cat -u]" r+] + puts $f "Line1" + flush $f + set x [gets $f] + close $f + set x +} {Line1} +test io-6.27 {Tcl_Flush on closed pipeline} {stdio && tempNotPc} { + removeFile pipe + set f [open pipe w] + puts $f {exit} + close $f + set f [open "|[list $tcltest pipe]" r+] + gets $f + puts $f output + after 50 + # + # The flush below will get a SIGPIPE. This is an expected part of + # test and indicates that the test operates correctly. If you run + # this test under a debugger, the signal will by intercepted unless + # you disable the debugger's signal interception. + # + if {[catch {flush $f} msg]} { + set x [list 1 $msg $errorCode] + catch {close $f} + } else { + if {[catch {close $f} msg]} { + set x [list 1 $msg $errorCode] + } else { + set x {this was supposed to fail and did not} + } + } + regsub {".*":} $x {"":} x + string tolower $x +} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}} +test io-6.28 {Tcl_Write, lf mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + puts $f hello\nthere\nand\nhere + flush $f + set s [file size test1] + close $f + set s +} 21 +test io-6.29 {Tcl_Write, cr mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar {} + puts $f hello\nthere\nand\nhere + close $f + file size test1 +} 21 +test io-6.30 {Tcl_Write, crlf mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar {} + puts $f hello\nthere\nand\nhere + close $f + file size test1 +} 25 +test io-6.31 {Tcl_Write, background flush} {stdio} { + removeFile pipe + removeFile output + set f [open pipe w] + puts $f {set f [open output w]} + puts $f {fconfigure $f -translation lf} + set x [list while {![eof stdin]}] + set x "$x {" + puts $f $x + puts $f { puts -nonewline $f [read stdin 4096]} + puts $f { flush $f} + puts $f "}" + puts $f {close $f} + close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open output w] + close $f + set f [open "|[list $tcltest pipe]" r+] + fconfigure $f -blocking off + puts -nonewline $f $x + close $f + set counter 0 + while {([file size output] < 65536) && ($counter < 1000)} { + incr counter + after 5 + update + } + if {$counter == 1000} { + set result probably_broken + } else { + set result ok + } +} ok +test io-6.32 {Tcl_Write, background flush to slow reader} {stdio && asyncPipeClose} { + removeFile pipe + removeFile output + set f [open pipe w] + puts $f {set f [open output w]} + puts $f {fconfigure $f -translation lf} + set x [list while {![eof stdin]}] + set x "$x {" + puts $f $x + puts $f { after 20} + puts $f { puts -nonewline $f [read stdin 1024]} + puts $f { flush $f} + puts $f "}" + puts $f {close $f} + close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open output w] + close $f + set f [open "|[list $tcltest pipe]" r+] + fconfigure $f -blocking off + puts -nonewline $f $x + close $f + set counter 0 + while {([file size output] < 65536) && ($counter < 1000)} { + incr counter + after 20 + update + } + if {$counter == 1000} { + set result probably_broken + } else { + set result ok + } +} ok +test io-6.33 {Tcl_Flush, implicit flush on exit} {stdio} { + set f [open script w] + puts $f { + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello + puts $f bye + puts $f strange + } + close $f + exec $tcltest script + set f [open test1 r] + 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} { + set c 0 + set x running + set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz + proc writelots {s l} { + for {set i 0} {$i < 2000} {incr i} { + puts $s $l + } + } + proc accept {s a p} { + global x + fileevent $s readable [list readit $s] + fconfigure $s -blocking off + set x accepted + } + proc readit {s} { + global c x + set l [gets $s] + + if {[eof $s]} { + close $s + set x done + } elseif {([string length $l] > 0) || ![fblocked $s]} { + incr c + } + } + set ss [socket -server accept 2828] + set cs [socket [info hostname] 2828] + vwait x + fconfigure $cs -blocking off + writelots $cs $l + close $cs + close $ss + vwait x + set c +} 2000 +test io-6.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket} { + catch {interp delete x} + catch {interp delete y} + interp create x + interp create y + set s [socket -server accept 2828] + proc accept {s a p} { + puts $s hello + close $s + } + set c [socket [info hostname] 2828] + interp share {} $c x + interp share {} $c y + close $c + x eval { + proc readit {s} { + gets $s + if {[eof $s]} { + close $s + } + } + } + y eval { + proc readit {s} { + gets $s + if {[eof $s]} { + close $s + } + } + } + x eval "fileevent $c readable \{readit $c\}" + y eval "fileevent $c readable \{readit $c\}" + y eval [list close $c] + update + close $s + interp delete x + interp delete y +} "" + +# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read. + +test io-7.1 {Tcl_Write lf, Tcl_Read lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set x [read $f] + close $f + set x +} "hello\nthere\nand\nhere\n" +test io-7.2 {Tcl_Write lf, Tcl_Read cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set x [read $f] + close $f + set x +} "hello\nthere\nand\nhere\n" +test io-7.3 {Tcl_Write lf, Tcl_Read crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "hello\nthere\nand\nhere\n" +test io-7.4 {Tcl_Write cr, Tcl_Read cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set x [read $f] + close $f + set x +} "hello\nthere\nand\nhere\n" +test io-7.5 {Tcl_Write cr, Tcl_Read lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set x [read $f] + close $f + set x +} "hello\rthere\rand\rhere\r" +test io-7.6 {Tcl_Write cr, Tcl_Read crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "hello\rthere\rand\rhere\r" +test io-7.7 {Tcl_Write crlf, Tcl_Read crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "hello\nthere\nand\nhere\n" +test io-7.8 {Tcl_Write crlf, Tcl_Read lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set x [read $f] + close $f + set x +} "hello\r\nthere\r\nand\r\nhere\r\n" +test io-7.9 {Tcl_Write crlf, Tcl_Read cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set x [read $f] + close $f + set x +} "hello\n\nthere\n\nand\n\nhere\n\n" +test io-7.10 {Tcl_Write lf, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set c [read $f] + set x [fconfigure $f -translation] + close $f + list $c $x +} {{hello +there +and +here +} auto} +test io-7.11 {Tcl_Write cr, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set c [read $f] + set x [fconfigure $f -translation] + close $f + list $c $x +} {{hello +there +and +here +} auto} +test io-7.12 {Tcl_Write crlf, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set c [read $f] + set x [fconfigure $f -translation] + close $f + list $c $x +} {{hello +there +and +here +} auto} + +test io-7.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set line "123456789ABCDE" ;# 14 char plus crlf + puts -nonewline $f x ;# shift crlf across block boundary + for {set i 0} {$i < 700} {incr i} { + puts $f $line + } + close $f + set f [open test1 r] + fconfigure $f -translation auto + set c [read $f] + close $f + string length $c +} [expr 700*15+1] + +test io-7.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { + 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 < 700} {incr i} { + puts $f $line + } + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set c [read $f] + close $f + string length $c +} [expr 700*15+1] + +test io-7.15 {Tcl_Write mixed, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\rhere + close $f + set f [open test1 r] + fconfigure $f -translation auto + set c [read $f] + close $f + set c +} {hello +there +and +here +} +test io-7.16 {Tcl_Write ^Z at end, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f hello\nthere\nand\rhere\n\x1a + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set c [read $f] + close $f + set c +} {hello +there +and +here +} +test io-7.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} { + removeFile test1 + set f [open test1 w] + fconfigure $f -eofchar \x1a -translation lf + puts $f hello\nthere\nand\rhere + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set c [read $f] + close $f + set c +} {hello +there +and +here +} +test io-7.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set s [format "abc\ndef\n%cghi\nqrs" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1 {} 1} +test io-7.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set s [format "abc\ndef\n%cghi\nqrs" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1 {} 1} +test io-7.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set s [format "abc\ndef\n%cghi\nqrs" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation lf -eofchar {} + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + 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} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set s [format "abc\ndef\n%cghi\nqrs" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation cr -eofchar {} + set l "" + set x [gets $f] + lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs"] + 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} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set s [format "abc\ndef\n%cghi\nqrs" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation crlf -eofchar {} + set l "" + set x [gets $f] + lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs"] + 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} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set c [format abc\ndef\n%cqrs\ntuv 26] + puts $f $c + close $f + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} +test io-7.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set c [format abc\ndef\n%cqrs\ntuv 26] + puts $f $c + close $f + set f [open test1 r] + fconfigure $f -translation lf -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} +test io-7.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + set c [format abc\ndef\n%cqrs\ntuv 26] + puts $f $c + close $f + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} +test io-7.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + set c [format abc\ndef\n%cqrs\ntuv 26] + puts $f $c + close $f + set f [open test1 r] + fconfigure $f -translation cr -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} +test io-7.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set c [format abc\ndef\n%cqrs\ntuv 26] + puts $f $c + close $f + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} +test io-7.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set c [format abc\ndef\n%cqrs\ntuv 26] + puts $f $c + close $f + set f [open test1 r] + fconfigure $f -translation crlf -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} + +# Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets. + +test io-8.1 {Tcl_Write lf, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + close $f + set l +} {hello 6 auto there 12 auto} +test io-8.2 {Tcl_Write cr, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + close $f + set l +} {hello 6 auto there 12 auto} +test io-8.3 {Tcl_Write crlf, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + close $f + set l +} {hello 7 auto there 14 auto} +test io-8.4 {Tcl_Write lf, Tcl_Gets lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + close $f + set l +} {hello 6 lf there 12 lf} +test io-8.5 {Tcl_Write lf, Tcl_Gets cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set l "" + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + 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} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set l "" + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + 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} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {hello 6 cr 0 there 12 cr 0} +test io-8.8 {Tcl_Write cr, Tcl_Gets lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set l "" + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {21 21 lf 1 {} 21 lf 1} +test io-8.9 {Tcl_Write cr, Tcl_Gets crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set l "" + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {21 21 crlf 1 {} 21 crlf 1} +test io-8.10 {Tcl_Write crlf, Tcl_Gets crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {hello 7 crlf 0 there 14 crlf 0} +test io-8.11 {Tcl_Write crlf, Tcl_Gets cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {hello 6 cr 0 6 13 cr 0} +test io-8.12 {Tcl_Write crlf, Tcl_Gets lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set l "" + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {6 7 lf 0 6 14 lf 0} +test io-8.13 {binary mode is synonym of lf mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation binary + set x [fconfigure $f -translation] + close $f + set x +} lf +# +# 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} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\rand\r\nhere + close $f + set f [open test1 r] + fconfigure $f -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-8.15 {Tcl_Write mixed, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f hello\nthere\rand\r\nhere\r + close $f + set f [open test1 r] + fconfigure $f -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-8.16 {Tcl_Write mixed, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f hello\nthere\rand\r\nhere\n + close $f + set f [open test1 r] + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-8.17 {Tcl_Write mixed, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f hello\nthere\rand\r\nhere\r\n + close $f + set f [open test1 r] + fconfigure $f -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-8.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set s [format "hello\nthere\nand\rhere\n\%c" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-8.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -eofchar \x1a -translation lf + puts $f hello\nthere\nand\rhere + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-8.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a + fconfigure $f -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-8.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-8.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation lf -eofchar {} + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + 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} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation cr -eofchar {} + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + 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} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation crlf -eofchar {} + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + 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} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-8.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation lf -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-8.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-8.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation cr -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-8.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-8.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + puts $f $s + close $f + set f [open test1 r] + fconfigure $f -translation crlf -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-8.31 {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 < 700} {incr i} { + puts $f $line + } + close $f + set f [open test1 r] + fconfigure $f -translation auto + set c "" + while {[gets $f line] >= 0} { + append c $line\n + } + close $f + string length $c +} [expr 700*15+1] +test io-8.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} { + puts $f $line + } + close $f + set f [open test1 r] + fconfigure $f -translation auto + set c "" + while {[gets $f line] >= 0} { + append c $line\n + } + close $f + string length $c +} [expr 256*15+1] + + +# Test Tcl_Read and buffering. + +test io-9.1 {Tcl_Read, channel not readable} { + list [catch {read stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +test io-9.2 {Tcl_Read, zero byte count} { + read stdin 0 +} "" +test io-9.3 {Tcl_Read, negative byte count} { + set f [open longfile r] + set l [list [catch {read $f -1} msg] $msg] + close $f + set l +} {1 {bad argument "-1": should be "nonewline"}} +test io-9.4 {Tcl_Read, positive byte count} { + set f [open longfile r] + set x [read $f 1024] + set s [string length $x] + unset x + close $f + set s +} 1024 +test io-9.5 {Tcl_Read, multiple buffers} { + set f [open longfile r] + fconfigure $f -buffersize 100 + set x [read $f 1024] + set s [string length $x] + unset x + close $f + set s +} 1024 +test io-9.6 {Tcl_Read, very large read} { + set f1 [open longfile r] + set z [read $f1 1000000] + close $f1 + set l [string length $z] + set x ok + set z [file size longfile] + if {$z != $l} { + set x broken + } + set x +} ok +test io-9.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { + set f1 [open longfile r] + fconfigure $f1 -blocking off + set z [read $f1 20] + close $f1 + set l [string length $z] + set x ok + if {$l != 20} { + set x broken + } + set x +} ok +test io-9.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { + set f1 [open longfile r] + fconfigure $f1 -blocking off + set z [read $f1 1000000] + close $f1 + set x ok + set l [string length $z]] + set z [file size longfile]] + if {$z != $l} { + set x broken + } + set x +} ok +test io-9.9 {Tcl_Read, read to end of file} { + set f1 [open longfile r] + set z [read $f1] + close $f1 + set l [string length $z] + set x ok + set z [file size longfile] + if {$z != $l} { + set x broken + } + set x +} ok +test io-9.10 {Tcl_Read from a pipe} {stdio} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {puts [gets stdin]} + close $f1 + set f1 [open "|[list $tcltest pipe]" r+] + puts $f1 hello + flush $f1 + set x [read $f1] + close $f1 + set x +} "hello\n" +test io-9.11 {Tcl_Read from a pipe} {stdio} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {puts [gets stdin]} + puts $f1 {puts [gets stdin]} + close $f1 + set f1 [open "|[list $tcltest pipe]" r+] + puts $f1 hello + flush $f1 + set x "" + lappend x [read $f1 6] + puts $f1 hello + flush $f1 + lappend x [read $f1] + close $f1 + set x +} {{hello +} {hello +}} +test io-9.12 {Tcl_Read, -nonewline} { + removeFile test1 + set f1 [open test1 w] + puts $f1 hello + puts $f1 bye + close $f1 + set f1 [open test1 r] + set c [read -nonewline $f1] + close $f1 + set c +} {hello +bye} +test io-9.13 {Tcl_Read, -nonewline} { + removeFile test1 + set f1 [open test1 w] + puts $f1 hello + puts $f1 bye + close $f1 + set f1 [open test1 r] + set c [read -nonewline $f1] + close $f1 + list [string length $c] $c +} {9 {hello +bye}} +test io-9.14 {Tcl_Read, reading in small chunks} { + removeFile test1 + set f [open test1 w] + puts $f "Two lines: this one" + puts $f "and this one" + close $f + set f [open test1] + set x [list [read $f 1] [read $f 2] [read $f]] + close $f + set x +} {T wo { lines: this one +and this one +}} +test io-9.15 {Tcl_Read, asking for more input than available} { + removeFile test1 + set f [open test1 w] + puts $f "Two lines: this one" + puts $f "and this one" + close $f + set f [open test1] + set x [read $f 100] + close $f + set x +} {Two lines: this one +and this one +} +test io-9.16 {Tcl_Read, read to end of file with -nonewline} { + removeFile test1 + set f [open test1 w] + puts $f "Two lines: this one" + puts $f "and this one" + close $f + set f [open test1] + set x [read -nonewline $f] + close $f + set x +} {Two lines: this one +and this one} + +# Test Tcl_Gets. + +test io-10.1 {Tcl_Gets, reading what was written} { + removeFile test1 + set f1 [open test1 w] + set y "first line" + puts $f1 $y + close $f1 + set f1 [open test1 r] + set x [gets $f1] + set z ok + if {"$x" != "$y"} { + set z broken + } + close $f1 + set z +} ok +test io-10.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 + } + close $f1 + set z +} ok +test io-10.3 {Tcl_Gets from pipe} {stdio} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {puts [gets stdin]} + close $f1 + set f1 [open "|[list $tcltest pipe]" r+] + puts $f1 hello + flush $f1 + set x [gets $f1] + close $f1 + set z ok + if {"$x" != "hello"} { + set z broken + } + set z +} ok +test io-10.4 {Tcl_Gets with long line} { + removeFile test3 + set f [open test3 w] + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + close $f + set f [open test3] + set x [gets $f] + close $f + set x +} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +test io-10.5 {Tcl_Gets with long line} { + set f [open test3] + set x [gets $f y] + close $f + list $x $y +} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +test io-10.6 {Tcl_Gets and end of file} { + removeFile test3 + set f [open test3 w] + puts -nonewline $f "Test1\nTest2" + close $f + set f [open test3] + set x {} + set y {} + lappend x [gets $f y] $y + set y {} + lappend x [gets $f y] $y + set y {} + lappend x [gets $f y] $y + close $f + set x +} {5 Test1 5 Test2 -1 {}} +test io-10.7 {Tcl_Gets and bad variable} { + set f [open test3 w] + puts $f "Line 1" + puts $f "Line 2" + close $f + catch {unset x} + set x 24 + set f [open test3 r] + set result [list [catch {gets $f x(0)} msg] $msg] + close $f + set result +} {1 {can't set "x(0)": variable isn't array}} +test io-10.8 {Tcl_Gets, exercising double buffering} { + set f [open test3 w] + fconfigure $f -translation lf -eofchar {} + set x "" + for {set y 0} {$y < 99} {incr y} {set x "a$x"} + for {set y 0} {$y < 100} {incr y} {puts $f $x} + close $f + set f [open test3 r] + fconfigure $f -translation lf + for {set y 0} {$y < 100} {incr y} {gets $f} + close $f + set y +} 100 +test io-10.9 {Tcl_Gets, exercising double buffering} { + set f [open test3 w] + fconfigure $f -translation lf -eofchar {} + set x "" + for {set y 0} {$y < 99} {incr y} {set x "a$x"} + for {set y 0} {$y < 200} {incr y} {puts $f $x} + close $f + set f [open test3 r] + fconfigure $f -translation lf + for {set y 0} {$y < 200} {incr y} {gets $f} + close $f + set y +} 200 +test io-10.10 {Tcl_Gets, exercising double buffering} { + set f [open test3 w] + fconfigure $f -translation lf -eofchar {} + set x "" + for {set y 0} {$y < 99} {incr y} {set x "a$x"} + for {set y 0} {$y < 300} {incr y} {puts $f $x} + close $f + set f [open test3 r] + fconfigure $f -translation lf + for {set y 0} {$y < 300} {incr y} {gets $f} + close $f + set y +} 300 + +# Test Tcl_Seek and Tcl_Tell. + +test io-11.1 {Tcl_Seek to current position at start of file} { + set f1 [open longfile r] + seek $f1 0 current + set c [tell $f1] + close $f1 + set c +} 0 +test io-11.2 {Tcl_Seek to offset from start} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 10 start + set c [tell $f1] + close $f1 + set c +} 10 +test io-11.3 {Tcl_Seek to end of file} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 0 end + set c [tell $f1] + close $f1 + set c +} 54 +test io-11.4 {Tcl_Seek to offset from end of file} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 -10 end + set c [tell $f1] + close $f1 + set c +} 44 +test io-11.5 {Tcl_Seek to offset from current position} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 10 current + seek $f1 10 current + set c [tell $f1] + close $f1 + set c +} 20 +test io-11.6 {Tcl_Seek to offset from end of file} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 -10 end + set c [tell $f1] + set r [read $f1] + close $f1 + list $c $r +} {44 {rstuvwxyz +}} +test io-11.7 {Tcl_Seek to offset from end of file, then to current position} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 -10 end + set c1 [tell $f1] + set r1 [read $f1 5] + seek $f1 0 current + set c2 [tell $f1] + close $f1 + list $c1 $r1 $c2 +} {44 rstuv 49} +test io-11.8 {Tcl_Seek on pipes: not supported} {stdio} { + set f1 [open "|[list $tcltest]" r+] + set x [list [catch {seek $f1 0 current} msg] $msg] + close $f1 + regsub {".*":} $x {"":} x + string tolower $x +} {1 {error during seek on "": invalid argument}} +test io-11.9 {Tcl_Seek, testing buffered input flushing} { + removeFile test3 + set f [open test3 w] + fconfigure $f -eofchar {} + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + close $f + set f [open test3 RDWR] + set x [read $f 1] + seek $f 3 + lappend x [read $f 1] + seek $f 0 start + lappend x [read $f 1] + seek $f 10 current + lappend x [read $f 1] + seek $f -2 end + lappend x [read $f 1] + seek $f 50 end + lappend x [read $f 1] + seek $f 1 + lappend x [read $f 1] + close $f + set x +} {a d a l Y {} b} +test io-11.10 {Tcl_Seek testing flushing of buffered input} { + set f [open test3 w] + fconfigure $f -translation lf + puts $f xyz\n123 + close $f + set f [open test3 r+] + fconfigure $f -translation lf + set x [gets $f] + seek $f 0 current + puts $f 456 + close $f + list $x [viewFile test3] +} "xyz {xyz +456}" +test io-11.11 {Tcl_Seek testing flushing of buffered output} { + set f [open test3 w] + puts $f xyz\n123 + close $f + set f [open test3 w+] + puts $f xyzzy + seek $f 2 + set x [gets $f] + close $f + list $x [viewFile test3] +} "zzy xyzzy" +test io-11.12 {Tcl_Seek testing combination of write, seek back and read} { + set f [open test3 w] + fconfigure $f -translation lf -eofchar {} + puts $f xyz\n123 + close $f + set f [open test3 a+] + fconfigure $f -translation lf -eofchar {} + puts $f xyzzy + flush $f + set x [tell $f] + seek $f -4 cur + set y [gets $f] + close $f + list $x [viewFile test3] $y +} {14 {xyz +123 +xyzzy} zzy} +test io-11.13 {Tcl_Tell at start of file} { + removeFile test1 + set f1 [open test1 w] + set p [tell $f1] + close $f1 + set p +} 0 +test io-11.14 {Tcl_Tell after seek to end of file} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 0 end + set c1 [tell $f1] + close $f1 + set c1 +} 54 +test io-11.15 {Tcl_Tell combined with seeking} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 10 start + set c1 [tell $f1] + seek $f1 10 current + set c2 [tell $f1] + close $f1 + list $c1 $c2 +} {10 20} +test io-11.16 {Tcl_tell on pipe: always -1} {stdio} { + set f1 [open "|[list $tcltest]" r+] + set c [tell $f1] + close $f1 + set c +} -1 +test io-11.17 {Tcl_Tell on pipe: always -1} {stdio} { + set f1 [open "|[list $tcltest]" r+] + puts $f1 {puts hello} + flush $f1 + set c [tell $f1] + gets $f1 + close $f1 + set c +} -1 +test io-11.18 {Tcl_Tell combined with seeking and reading} { + removeFile test2 + set f [open test2 w] + fconfigure $f -translation lf -eofchar {} + puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n" + close $f + set f [open test2] + fconfigure $f -translation lf + set x [tell $f] + read $f 3 + lappend x [tell $f] + seek $f 2 + lappend x [tell $f] + seek $f 10 current + lappend x [tell $f] + seek $f 0 end + lappend x [tell $f] + close $f + set x +} {0 3 2 12 30} +test io-11.19 {Tcl_Tell combined with opening in append mode} { + set f [open test3 w] + fconfigure $f -translation lf -eofchar {} + puts $f "abcdefghijklmnopqrstuvwxyz" + puts $f "abcdefghijklmnopqrstuvwxyz" + close $f + set f [open test3 a] + set c [tell $f] + close $f + set c +} 54 +test io-11.20 {Tcl_Tell combined with writing} { + set f [open test3 w] + set l "" + seek $f 29 start + lappend l [tell $f] + puts -nonewline $f a + seek $f 39 start + lappend l [tell $f] + puts -nonewline $f a + lappend l [tell $f] + seek $f 407 end + lappend l [tell $f] + close $f + set l +} {29 39 40 447} + +# Test Tcl_Eof + +test io-12.1 {Tcl_Eof} { + removeFile test1 + set f [open test1 w] + puts $f hello + puts $f hello + close $f + set f [open test1] + set x [eof $f] + lappend x [eof $f] + gets $f + lappend x [eof $f] + gets $f + lappend x [eof $f] + gets $f + lappend x [eof $f] + lappend x [eof $f] + close $f + set x +} {0 0 0 0 1 1} +test io-12.2 {Tcl_Eof with pipe} {stdio} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {gets stdin} + puts $f1 {puts hello} + close $f1 + set f1 [open "|[list $tcltest pipe]" r+] + puts $f1 hello + set x [eof $f1] + flush $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + close $f1 + set x +} {0 0 0 1} +test io-12.3 {Tcl_Eof with pipe} {stdio} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {gets stdin} + puts $f1 {puts hello} + close $f1 + set f1 [open "|[list $tcltest pipe]" r+] + puts $f1 hello + set x [eof $f1] + flush $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + close $f1 + set x +} {0 0 0 1 1 1} +test io-12.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + fconfigure $f -blocking off + set l "" + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {{} 1} +test io-12.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio} { + removeFile pipe + set f [open pipe w] + puts $f { + exit + } + close $f + set f [open "|[list $tcltest pipe]" r] + set l "" + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {{} 1} +test io-12.6 {Tcl_Eof, eof char, lf write, auto read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {9 8 1} +test io-12.7 {Tcl_Eof, eof char, lf write, lf read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation lf -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {9 8 1} +test io-12.8 {Tcl_Eof, eof char, cr write, auto read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {9 8 1} +test io-12.9 {Tcl_Eof, eof char, cr write, cr read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation cr -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {9 8 1} +test io-12.10 {Tcl_Eof, eof char, crlf write, auto read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {11 8 1} +test io-12.11 {Tcl_Eof, eof char, crlf write, crlf read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {11 8 1} +test io-12.12 {Tcl_Eof, eof char in middle, lf write, auto read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size test1] + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {17 8 1} +test io-12.13 {Tcl_Eof, eof char in middle, lf write, lf read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size test1] + set f [open test1 r] + fconfigure $f -translation lf -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {17 8 1} +test io-12.14 {Tcl_Eof, eof char in middle, cr write, auto read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size test1] + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {17 8 1} +test io-12.15 {Tcl_Eof, eof char in middle, cr write, cr read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size test1] + set f [open test1 r] + fconfigure $f -translation cr -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {17 8 1} +test io-12.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size test1] + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {21 8 1} +test io-12.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size test1] + set f [open test1 r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {21 8 1} + +# Test Tcl_InputBlocked + +test io-13.1 {Tcl_InputBlocked on nonblocking pipe} {unixOrPc tempNotPc} { + set f1 [open "|[list $tcltest]" r+] + puts $f1 {puts hello_from_pipe} + flush $f1 + gets $f1 + fconfigure $f1 -blocking off -buffering full + puts $f1 {puts hello} + set x "" + lappend x [gets $f1] + lappend x [fblocked $f1] + flush $f1 + after 200 + lappend x [gets $f1] + lappend x [fblocked $f1] + lappend x [gets $f1] + lappend x [fblocked $f1] + close $f1 + set x +} {{} 1 hello 0 {} 1} +test io-13.2 {Tcl_InputBlocked on blocking pipe} {unixOrPc tempNotPc} { + set f1 [open "|[list $tcltest]" r+] + fconfigure $f1 -buffering line + puts $f1 {puts hello_from_pipe} + set x "" + lappend x [gets $f1] + lappend x [fblocked $f1] + puts $f1 {exit} + lappend x [gets $f1] + lappend x [fblocked $f1] + lappend x [eof $f1] + close $f1 + set x +} {hello_from_pipe 0 {} 0 1} +test io-13.3 {Tcl_InputBlocked vs files, short read} { + removeFile test1 + set f [open test1 w] + puts $f abcdefghijklmnop + close $f + set f [open test1 r] + set l "" + lappend l [fblocked $f] + lappend l [read $f 3] + lappend l [fblocked $f] + lappend l [read -nonewline $f] + lappend l [fblocked $f] + lappend l [eof $f] + close $f + set l +} {0 abc 0 defghijklmnop 0 1} +test io-13.4 {Tcl_InputBlocked vs files, event driven read} { + proc in {f} { + global l x + lappend l [read $f 3] + if {[eof $f]} {lappend l eof; close $f; set x done} + } + removeFile test1 + set f [open test1 w] + puts $f abcdefghijklmnop + close $f + set f [open test1 r] + set l "" + fileevent $f readable [list in $f] + vwait x + set l +} {abc def ghi jkl mno {p +} eof} +test io-13.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} { + removeFile test1 + set f [open test1 w] + puts $f abcdefghijklmnop + close $f + set f [open test1 r] + fconfigure $f -blocking off + set l "" + lappend l [fblocked $f] + lappend l [read $f 3] + lappend l [fblocked $f] + lappend l [read -nonewline $f] + lappend l [fblocked $f] + lappend l [eof $f] + close $f + set l +} {0 abc 0 defghijklmnop 0 1} +test io-13.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} { + proc in {f} { + global l x + lappend l [read $f 3] + if {[eof $f]} {lappend l eof; close $f; set x done} + } + removeFile test1 + set f [open test1 w] + puts $f abcdefghijklmnop + close $f + set f [open test1 r] + fconfigure $f -blocking off + set l "" + fileevent $f readable [list in $f] + vwait x + set l +} {abc def ghi jkl mno {p +} eof} + +# Test Tcl_InputBuffered + +test io-14.1 {Tcl_InputBuffered} { + set f [open longfile r] + fconfigure $f -buffersize 4096 + read $f 3 + set l "" + lappend l [testchannel inputbuffered $f] + lappend l [tell $f] + close $f + set l +} {4093 3} +test io-14.2 {Tcl_InputBuffered, test input flushing on seek} { + set f [open longfile r] + fconfigure $f -buffersize 4096 + read $f 3 + set l "" + lappend l [testchannel inputbuffered $f] + lappend l [tell $f] + seek $f 0 current + lappend l [testchannel inputbuffered $f] + lappend l [tell $f] + close $f + set l +} {4093 3 0 3} + +# Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize + +test io-15.1 {Tcl_GetChannelBufferSize, default buffer size} { + set f [open longfile r] + set s [fconfigure $f -buffersize] + close $f + set s +} 4096 +test io-15.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { + set f [open longfile r] + set l "" + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize 10000 + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize 1 + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize -1 + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize 0 + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize 100000 + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize 10000000 + lappend l [fconfigure $f -buffersize] + close $f + set l +} {4096 10000 4096 4096 4096 100000 4096} + +# Test Tcl_SetChannelOption, Tcl_GetChannelOption + +test io-16.1 {Tcl_GetChannelOption} { + removeFile test1 + set f1 [open test1 w] + set x [fconfigure $f1 -blocking] + close $f1 + set x +} 1 +# +# Test 17.2 was removed. +# +test io-16.2 {Tcl_GetChannelOption} { + removeFile test1 + set f1 [open test1 w] + set x [fconfigure $f1 -buffering] + close $f1 + set x +} full +test io-16.3 {Tcl_GetChannelOption} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -buffering line + set x [fconfigure $f1 -buffering] + close $f1 + set x +} line +test io-16.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} { + removeFile test1 + set f1 [open test1 w] + set l "" + lappend l [fconfigure $f1 -buffering] + fconfigure $f1 -buffering line + lappend l [fconfigure $f1 -buffering] + fconfigure $f1 -buffering none + lappend l [fconfigure $f1 -buffering] + fconfigure $f1 -buffering line + lappend l [fconfigure $f1 -buffering] + fconfigure $f1 -buffering full + lappend l [fconfigure $f1 -buffering] + close $f1 + set l +} {full line none line full} +test io-16.5 {Tcl_GetChannelOption, invariance} { + removeFile test1 + set f1 [open test1 w] + set l "" + lappend l [fconfigure $f1 -buffering] + lappend l [list [catch {fconfigure $f1 -buffering green} msg] $msg] + lappend l [fconfigure $f1 -buffering] + 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} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -buffering line + puts $f1 hello + puts $f1 bye + set x [file size test1] + close $f1 + set x +} 10 +test io-16.7 {Tcl_SetChannelOption, buffering, translation} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf + puts $f1 hello + puts $f1 bye + set x "" + fconfigure $f1 -buffering line + lappend x [file size test1] + puts $f1 really_bye + lappend x [file size test1] + close $f1 + set x +} {0 21} +test io-16.8 {Tcl_SetChannelOption, different buffering options} { + removeFile test1 + set f1 [open test1 w] + set l "" + fconfigure $f1 -translation lf -buffering none -eofchar {} + puts -nonewline $f1 hello + lappend l [file size test1] + puts -nonewline $f1 hello + lappend l [file size test1] + fconfigure $f1 -buffering full + puts -nonewline $f1 hello + lappend l [file size test1] + fconfigure $f1 -buffering none + lappend l [file size test1] + puts -nonewline $f1 hello + lappend l [file size test1] + close $f1 + lappend l [file size test1] + set l +} {5 10 10 10 20 20} +test io-16.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { + removeFile test1 + set f1 [open test1 w] + close $f1 + set f1 [open test1 r] + set x "" + lappend x [fconfigure $f1 -blocking] + fconfigure $f1 -blocking off + lappend x [fconfigure $f1 -blocking] + lappend x [gets $f1] + lappend x [read $f1 1000] + lappend x [fblocked $f1] + lappend x [eof $f1] + close $f1 + set x +} {1 0 {} {} 0 1} +test io-16.10 {Tcl_SetChannelOption, blocking mode} {unixOrPc tempNotPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {gets stdin} + puts $f1 {after 100} + puts $f1 {puts hi} + puts $f1 {gets stdin} + close $f1 + set x "" + set f1 [open "|[list $tcltest pipe]" r+] + fconfigure $f1 -blocking off -buffering line + lappend x [fconfigure $f1 -blocking] + lappend x [gets $f1] + lappend x [fblocked $f1] + puts $f1 hello + lappend x [gets $f1] + lappend x [fblocked $f1] + puts $f1 bye + lappend x [gets $f1] + lappend x [fblocked $f1] + fconfigure $f1 -blocking on + lappend x [fconfigure $f1 -blocking] + lappend x [gets $f1] + lappend x [fblocked $f1] + lappend x [eof $f1] + lappend x [gets $f1] + lappend x [eof $f1] + close $f1 + set x +} {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1} +test io-16.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { + removeFile test1 + set f [open test1 w] + fconfigure $f -buffersize -10 + set x [fconfigure $f -buffersize] + close $f + set x +} 4096 +test io-16.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} { + removeFile test1 + set f [open test1 w] + fconfigure $f -buffersize 10000000 + set x [fconfigure $f -buffersize] + close $f + set x +} 4096 +test io-16.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { + removeFile test1 + set f [open test1 w] + fconfigure $f -buffersize 40000 + set x [fconfigure $f -buffersize] + close $f + set x +} 40000 +test io-16.14 {Tcl_SetChannelOption, setting read mode independently} \ + {socket} { + proc accept {s a p} {close $s} + set s1 [socket -server accept 0] + set port [lindex [fconfigure $s1 -sockname] 2] + set s2 [socket localhost $port] + update + fconfigure $s2 -translation {auto lf} + set modes [fconfigure $s2 -translation] + close $s1 + close $s2 + set modes +} {auto lf} +test io-16.15 {Tcl_SetChannelOption, setting read mode independently} \ + {socket} { + proc accept {s a p} {close $s} + set s1 [socket -server accept 0] + set port [lindex [fconfigure $s1 -sockname] 2] + set s2 [socket localhost $port] + update + fconfigure $s2 -translation {auto crlf} + set modes [fconfigure $s2 -translation] + close $s1 + close $s2 + set modes +} {auto crlf} +test io-16.16 {Tcl_SetChannelOption, setting read mode independently} \ + {socket} { + proc accept {s a p} {close $s} + set s1 [socket -server accept 0] + set port [lindex [fconfigure $s1 -sockname] 2] + set s2 [socket localhost $port] + update + fconfigure $s2 -translation {auto cr} + set modes [fconfigure $s2 -translation] + close $s1 + close $s2 + set modes +} {auto cr} +test io-16.17 {Tcl_SetChannelOption, setting read mode independently} \ + {socket} { + proc accept {s a p} {close $s} + set s1 [socket -server accept 0] + set port [lindex [fconfigure $s1 -sockname] 2] + set s2 [socket localhost $port] + update + fconfigure $s2 -translation {auto auto} + set modes [fconfigure $s2 -translation] + close $s1 + close $s2 + set modes +} {auto crlf} + +test io-17.1 {POSIX open access modes: RDWR} { + removeFile test3 + set f [open test3 w] + puts $f xyzzy + close $f + set f [open test3 RDWR] + puts -nonewline $f "ab" + seek $f 0 current + set x [gets $f] + close $f + set f [open test3 r] + lappend x [gets $f] + close $f + set x +} {zzy abzzy} +test io-17.2 {POSIX open access modes: CREAT} {unixOnly} { + removeFile test3 + set f [open test3 {WRONLY CREAT} 0600] + file stat test3 stats + set x [format "0%o" [expr $stats(mode)&0777]] + puts $f "line 1" + close $f + set f [open test3 r] + lappend x [gets $f] + close $f + set x +} {0600 {line 1}} +test io-17.3 {POSIX open access modes: CREAT} {$testConfig(unix) && ([exec umask] == 2)} { + # This test only works if your umask is 2, like ouster's. + removeFile test3 + set f [open test3 {WRONLY CREAT}] + close $f + file stat test3 stats + format "0%o" [expr $stats(mode)&0777] +} 0664 +test io-17.4 {POSIX open access modes: CREAT} { + removeFile test3 + set f [open test3 w] + fconfigure $f -eofchar {} + puts $f xyzzy + close $f + set f [open test3 {WRONLY CREAT}] + fconfigure $f -eofchar {} + puts -nonewline $f "ab" + close $f + set f [open test3 r] + set x [gets $f] + close $f + set x +} abzzy +test io-17.5 {POSIX open access modes: APPEND} { + removeFile test3 + set f [open test3 w] + fconfigure $f -translation lf -eofchar {} + puts $f xyzzy + close $f + set f [open test3 {WRONLY APPEND}] + fconfigure $f -translation lf + puts $f "new line" + seek $f 0 + puts $f "abc" + close $f + set f [open test3 r] + fconfigure $f -translation lf + set x "" + seek $f 6 current + lappend x [gets $f] + lappend x [gets $f] + close $f + set x +} {{new line} abc} +test io-17.6 {POSIX open access modes: EXCL} { + removeFile test3 + set f [open test3 w] + puts $f xyzzy + close $f + set msg [list [catch {open test3 {WRONLY CREAT EXCL}} msg] $msg] + regsub " already " $msg " " msg + string tolower $msg +} {1 {couldn't open "test3": file exists}} +test io-17.7 {POSIX open access modes: EXCL} { + removeFile test3 + set f [open test3 {WRONLY CREAT EXCL}] + fconfigure $f -eofchar {} + puts $f "A test line" + close $f + viewFile test3 +} {A test line} +test io-17.8 {POSIX open access modes: TRUNC} { + removeFile test3 + set f [open test3 w] + puts $f xyzzy + close $f + set f [open test3 {WRONLY TRUNC}] + puts $f abc + close $f + set f [open test3 r] + set x [gets $f] + close $f + set x +} abc +test io-17.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} { + removeFile test3 + set f [open test3 {WRONLY NONBLOCK CREAT}] + puts $f "NONBLOCK test" + close $f + set f [open test3 r] + set x [gets $f] + close $f + set x +} {NONBLOCK test} +test io-17.10 {POSIX open access modes: RDONLY} { + set f [open test1 w] + puts $f "two lines: this one" + puts $f "and this" + close $f + set f [open test1 RDONLY] + set x [list [gets $f] [catch {puts $f Test} msg] $msg] + close $f + string compare [string tolower $x] \ + [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} { + 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} { + 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} { + makeFile xyzzy test3 + set f [open test3 WRONLY] + fconfigure $f -eofchar {} + puts -nonewline $f "ab" + seek $f 0 current + set x [list [catch {gets $f} msg] $msg] + close $f + lappend x [viewFile test3] + 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} { + 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} { + makeFile xyzzy test3 + set f [open test3 RDWR] + puts -nonewline $f "ab" + seek $f 0 current + set x [gets $f] + close $f + lappend x [viewFile test3] +} {zzy abzzy} +if {![file exists ~/_test_] && [file writable ~]} { + test io-17.16 {tilde substitution in open} { + set f [open ~/_test_ w] + puts $f "Some text" + close $f + set x [file exists [file join $env(HOME) _test_]] + removeFile [file join $env(HOME) _test_] + set x + } 1 +} +test io-17.17 {tilde substitution in open} { + set home $env(HOME) + unset env(HOME) + set x [list [catch {open ~/foo} msg] $msg] + set env(HOME) $home + set x +} {1 {couldn't find HOME environment variable to expand path}} + +test io-18.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} { + 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} { + list [catch {fileevent gorp readable} msg] $msg +} {1 {can not find channel named "gorp"}} +test io-18.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} { + list [catch {fileevent gorp who-knows} msg] $msg +} {1 {bad event name "who-knows": must be readable or writable}} + +# +# Test fileevent on a file +# + +set f [open foo w+] + +test io-19.1 {Tcl_FileeventCmd: creating, deleting, querying} { + list [fileevent $f readable] [fileevent $f writable] +} {{} {}} +test io-19.2 {Tcl_FileeventCmd: replacing} { + set result {} + fileevent $f r "first script" + lappend result [fileevent $f readable] + fileevent $f r "new script" + lappend result [fileevent $f readable] + fileevent $f r "yet another" + lappend result [fileevent $f readable] + fileevent $f r "" + lappend result [fileevent $f readable] +} {{first script} {new script} {yet another} {}} + +# +# Test fileevent on a pipe +# + +if {($tcl_platform(platform) != "macintosh") && \ + ($testConfig(unixExecs) == 1)} { + +catch {set f2 [open "|[list cat -u]" r+]} +catch {set f3 [open "|[list cat -u]" r+]} + +test io-20.1 {Tcl_FileeventCmd: creating, deleting, querying} { + set result {} + fileevent $f readable "script 1" + lappend result [fileevent $f readable] [fileevent $f writable] + fileevent $f writable "write script" + lappend result [fileevent $f readable] [fileevent $f writable] + fileevent $f readable {} + lappend result [fileevent $f readable] [fileevent $f writable] + 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} { + set result {} + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] + fileevent $f r "read f" + fileevent $f2 r "read f2" + fileevent $f3 r "read f3" + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] + fileevent $f2 r {} + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] + fileevent $f3 r {} + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] + fileevent $f r {} + 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} { + fileevent $f2 readable { + set x [gets $f2]; fileevent $f2 readable {} + } + puts $f2 text; flush $f2 + set x initial + vwait x + set x +} {text} +test io-21.2 {FileEventProc procedure: error in read event} { + proc bgerror args { + global x + set x $args + } + fileevent $f2 readable {error bogus} + puts $f2 text; flush $f2 + set x initial + vwait x + rename bgerror {} + list $x [fileevent $f2 readable] +} {bogus {}} +test io-21.3 {FileEventProc procedure: normal write event} { + fileevent $f2 writable { + lappend x "triggered" + incr count -1 + if {$count <= 0} { + fileevent $f2 writable {} + } + } + set x initial + set count 3 + vwait x + vwait x + vwait x + set x +} {initial triggered triggered triggered} +test io-21.4 {FileEventProc procedure: eror in write event} { + proc bgerror args { + global x + set x $args + } + fileevent $f2 writable {error bad-write} + set x initial + vwait x + rename bgerror {} + list $x [fileevent $f2 writable] +} {bad-write {}} +test io-21.5 {FileEventProc procedure: end of file} {unixOrPc} { + set f4 [open "|[list $tcltest cat << foo]" r] + fileevent $f4 readable { + if {[gets $f4 line] < 0} { + lappend x eof + fileevent $f4 readable {} + } else { + lappend x $line + } + } + set x initial + vwait x + vwait x + close $f4 + set x +} {initial foo eof} + +catch {close $f2} +catch {close $f3} + +} + # Closes if {($platform(platform) != "macintosh") && \ + # ($testConfig(unixExecs) == 1)} clause + +close $f +makeFile "foo bar" foo +test io-22.1 {DeleteFileEvent, cleanup on close} { + set f [open foo r] + fileevent $f readable { + lappend x "binding triggered: \"[gets $f]\"" + fileevent $f readable {} + } + close $f + set x initial + after 100 { set y done } + vwait y + set x +} {initial} +test io-22.2 {DeleteFileEvent, cleanup on close} { + set f [open foo r] + set f2 [open foo r] + fileevent $f readable { + lappend x "f triggered: \"[gets $f]\"" + fileevent $f readable {} + } + fileevent $f2 readable { + lappend x "f2 triggered: \"[gets $f2]\"" + fileevent $f2 readable {} + } + close $f + set x initial + vwait x + close $f2 + set x +} {initial {f2 triggered: "foo bar"}} +test io-22.3 {DeleteFileEvent, cleanup on close} { + set f [open foo r] + set f2 [open foo r] + set f3 [open foo r] + fileevent $f readable {f script} + fileevent $f2 readable {f2 script} + fileevent $f3 readable {f3 script} + set x {} + close $f2 + lappend x [catch {fileevent $f readable} msg] $msg \ + [catch {fileevent $f2 readable}] \ + [catch {fileevent $f3 readable} msg] $msg + close $f3 + lappend x [catch {fileevent $f readable} msg] $msg \ + [catch {fileevent $f2 readable}] \ + [catch {fileevent $f3 readable}] + close $f + lappend x [catch {fileevent $f readable}] \ + [catch {fileevent $f2 readable}] \ + [catch {fileevent $f3 readable}] +} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1} + +# Execute these tests only if the "testfevent" command is present. + +if {[info commands testfevent] == "testfevent"} { + +test io-23.1 {Tcl event loop vs multiple interpreters} { + testfevent create + testfevent cmd { + set f [open foo r] + set x "no event" + fileevent $f readable { + set x "f triggered: [gets $f]" + fileevent $f readable {} + } + } + after 1 ;# We must delay because Windows takes a little time to notice + update + testfevent cmd {close $f} + list [testfevent cmd {set x}] [testfevent cmd {info commands after}] +} {{f triggered: foo bar} after} +test io-23.2 {Tcl event loop vs multiple interpreters} { + testfevent create + testfevent cmd { + set x 0 + after 100 {set x triggered} + vwait x + set x + } +} {triggered} +test io-23.3 {Tcl event loop vs multiple interpreters} { + testfevent create + testfevent cmd { + set x 0 + after 10 {lappend x timer} + after 30 + set result $x + update idletasks + lappend result $x + update + lappend result $x + } +} {0 0 {0 timer}} + +test io-24.1 {fileevent vs multiple interpreters} { + set f [open foo r] + set f2 [open foo r] + set f3 [open foo r] + fileevent $f readable {script 1} + testfevent create + testfevent share $f2 + testfevent cmd "fileevent $f2 readable {script 2}" + fileevent $f3 readable {sript 3} + set x {} + lappend x [fileevent $f2 readable] + testfevent delete + lappend x [fileevent $f readable] [fileevent $f2 readable] \ + [fileevent $f3 readable] + close $f + close $f2 + close $f3 + set x +} {{} {script 1} {} {sript 3}} +test io-24.2 {deleting fileevent on interpreter delete} { + set f [open foo r] + set f2 [open foo r] + set f3 [open foo r] + set f4 [open foo r] + fileevent $f readable {script 1} + testfevent create + testfevent share $f2 + testfevent share $f3 + testfevent cmd "fileevent $f2 readable {script 2} + fileevent $f3 readable {script 3}" + fileevent $f4 readable {script 4} + testfevent delete + set x [list [fileevent $f readable] [fileevent $f2 readable] \ + [fileevent $f3 readable] [fileevent $f4 readable]] + close $f + close $f2 + close $f3 + close $f4 + set x +} {{script 1} {} {} {script 4}} +test io-24.3 {deleting fileevent on interpreter delete} { + set f [open foo r] + set f2 [open foo r] + set f3 [open foo r] + set f4 [open foo r] + testfevent create + testfevent share $f3 + testfevent share $f4 + fileevent $f readable {script 1} + fileevent $f2 readable {script 2} + testfevent cmd "fileevent $f3 readable {script 3} + fileevent $f4 readable {script 4}" + testfevent delete + set x [list [fileevent $f readable] [fileevent $f2 readable] \ + [fileevent $f3 readable] [fileevent $f4 readable]] + close $f + close $f2 + close $f3 + close $f4 + set x +} {{script 1} {script 2} {} {}} +test io-24.4 {file events on shared files and multiple interpreters} { + set f [open foo r] + set f2 [open foo r] + testfevent create + testfevent share $f + testfevent cmd "fileevent $f readable {script 1}" + fileevent $f readable {script 2} + fileevent $f2 readable {script 3} + set x [list [fileevent $f2 readable] \ + [testfevent cmd "fileevent $f readable"] \ + [fileevent $f readable]] + testfevent delete + close $f + close $f2 + set x +} {{script 3} {script 1} {script 2}} +test io-24.5 {file events on shared files, deleting file events} { + set f [open foo r] + testfevent create + testfevent share $f + testfevent cmd "fileevent $f readable {script 1}" + fileevent $f readable {script 2} + testfevent cmd "fileevent $f readable {}" + set x [list [testfevent cmd "fileevent $f readable"] \ + [fileevent $f readable]] + testfevent delete + close $f + set x +} {{} {script 2}} +test io-24.6 {file events on shared files, deleting file events} { + set f [open foo r] + testfevent create + testfevent share $f + testfevent cmd "fileevent $f readable {script 1}" + fileevent $f readable {script 2} + fileevent $f readable {} + set x [list [testfevent cmd "fileevent $f readable"] \ + [fileevent $f readable]] + testfevent delete + close $f + set x +} {{script 1} {}} + +} + +# The above curly closes the test for presence of the "testfevent" command. + +test io-25.1 {testing readability conditions} { + set f [open bar w] + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + close $f + set f [open bar r] + fileevent $f readable [list consume $f] + proc consume {f} { + global x l + lappend l called + if {[eof $f]} { + close $f + set x done + } else { + gets $f + } + } + set l "" + set x not_done + vwait x + list $x $l +} {done {called called called called called called called}} +test io-25.2 {testing readability conditions} {nonBlockFiles} { + set f [open bar w] + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + close $f + set f [open bar r] + fileevent $f readable [list consume $f] + fconfigure $f -blocking off + proc consume {f} { + global x l + lappend l called + if {[eof $f]} { + close $f + set x done + } else { + gets $f + } + } + set l "" + set x not_done + vwait x + list $x $l +} {done {called called called called called called called}} +test io-25.3 {testing readability conditions} {unixOnly nonBlockFiles} { + set f [open bar w] + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + puts $f abcdefg + close $f + set f [open my_script w] + puts $f { + proc copy_slowly {f} { + while {![eof $f]} { + puts [gets $f] + after 200 + } + close $f + } + } + close $f + set f [open "|[list $tcltest]" r+] + fileevent $f readable [list consume $f] + fconfigure $f -buffering line + fconfigure $f -blocking off + proc consume {f} { + global x l + if {[eof $f]} { + set x done + } else { + gets $f + lappend l [fblocked $f] + gets $f + lappend l [fblocked $f] + } + } + set l "" + set x not_done + puts $f {source my_script} + puts $f {set f [open bar r]} + puts $f {copy_slowly $f} + puts $f {exit} + vwait x + 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} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set c [format "abc\ndef\n%c" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-25.5 {lf write, testing readability, ^Z in middle, auto read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-25.6 {cr write, testing readability, ^Z termination, auto read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + set c [format "abc\ndef\n%c" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-25.7 {cr write, testing readability, ^Z in middle, auto read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-25.8 {crlf write, testing readability, ^Z termination, auto read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set c [format "abc\ndef\n%c" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-25.9 {crlf write, testing readability, ^Z in middle, auto read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-25.10 {lf write, testing readability, ^Z in middle, lf read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation lf + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-25.11 {lf write, testing readability, ^Z termination, lf read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + set c [format "abc\ndef\n%c" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation lf -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-25.12 {cr write, testing readability, ^Z in middle, cr read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation cr + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-25.13 {cr write, testing readability, ^Z termination, cr read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + set c [format "abc\ndef\n%c" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation cr -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-25.14 {crlf write, testing readability, ^Z in middle, crlf read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation crlf + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-25.15 {crlf write, testing readability, ^Z termi, crlf read mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set c [format "abc\ndef\n%c" 26] + puts -nonewline $f $c + close $f + proc consume {f} { + global c x l + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation crlf -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} + +test io-26.1 {testing crlf reading, leftover cr disgorgment} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\rb\rc\r\n" + close $f + set f [open test1 r] + set l "" + lappend l [file size test1] + fconfigure $f -translation crlf + lappend l [read $f 1] + lappend l [tell $f] + lappend l [read $f 1] + lappend l [tell $f] + lappend l [read $f 1] + lappend l [tell $f] + lappend l [read $f 1] + lappend l [tell $f] + lappend l [read $f 1] + lappend l [tell $f] + lappend l [read $f 1] + lappend l [tell $f] + lappend l [eof $f] + lappend l [read $f 1] + lappend l [eof $f] + close $f + set l +} "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 { +} 7 0 {} 1" +test io-26.2 {testing crlf reading, leftover cr disgorgment} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\rb\rc\r\n" + close $f + set f [open test1 r] + set l "" + lappend l [file size test1] + fconfigure $f -translation crlf + lappend l [read $f 2] + lappend l [tell $f] + lappend l [read $f 2] + lappend l [tell $f] + lappend l [read $f 2] + lappend l [tell $f] + lappend l [eof $f] + lappend l [read $f 2] + lappend l [tell $f] + lappend l [eof $f] + close $f + set l +} "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1" +test io-26.3 {testing crlf reading, leftover cr disgorgment} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\rb\rc\r\n" + close $f + set f [open test1 r] + set l "" + lappend l [file size test1] + fconfigure $f -translation crlf + lappend l [read $f 3] + lappend l [tell $f] + lappend l [read $f 3] + lappend l [tell $f] + lappend l [eof $f] + lappend l [read $f 3] + lappend l [tell $f] + lappend l [eof $f] + close $f + set l +} "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1" +test io-26.4 {testing crlf reading, leftover cr disgorgment} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\rb\rc\r\n" + close $f + set f [open test1 r] + set l "" + lappend l [file size test1] + fconfigure $f -translation crlf + lappend l [read $f 3] + lappend l [tell $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [eof $f] + close $f + set l +} "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1" +test io-26.5 {testing crlf reading, leftover cr disgorgment} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\rb\rc\r\n" + close $f + set f [open test1 r] + set l "" + lappend l [file size test1] + fconfigure $f -translation crlf + lappend l [set x [gets $f]] + lappend l [tell $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [eof $f] + close $f + set l +} [list 7 a\rb\rc 7 {} 7 1] + +test io-27.1 {testing handler deletion} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list delhandler $f] + proc delhandler {f} { + global z + set z called + testchannelevent $f delete 0 + } + set z not_called + update + close $f + set z +} called +test io-27.2 {testing handler deletion with multiple handlers} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list delhandler $f 1] + testchannelevent $f add readable [list delhandler $f 0] + proc delhandler {f i} { + global z + lappend z "called delhandler $f $i" + testchannelevent $f delete 0 + } + set z "" + update + close $f + 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} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list notcalled $f 1] + testchannelevent $f add readable [list delhandler $f 0] + set z "" + proc notcalled {f i} { + global z + lappend z "notcalled was called!! $f $i" + } + proc delhandler {f i} { + global z + testchannelevent $f delete 1 + lappend z "delhandler $f $i called" + testchannelevent $f delete 0 + lappend z "delhandler $f $i deleted myself" + } + set z "" + update + close $f + string compare [string tolower $z] \ + [list [list delhandler $f 0 called] \ + [list delhandler $f 0 deleted myself]] +} 0 +test io-27.4 {testing handler deletion vs reentrant calls} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list delrecursive $f] + proc delrecursive {f} { + global z u + if {"$u" == "recursive"} { + testchannelevent $f delete 0 + lappend z "delrecursive deleting recursive" + } else { + lappend z "delrecursive calling recursive" + set u recursive + update + } + } + set u toplevel + set z "" + update + close $f + string compare [string tolower $z] \ + {{delrecursive calling recursive} {delrecursive deleting recursive}} +} 0 +test io-27.5 {testing handler deletion vs reentrant calls} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list notcalled $f] + testchannelevent $f add readable [list del $f] + proc notcalled {f} { + global z + lappend z "notcalled was called!! $f" + } + proc del {f} { + global z u + if {"$u" == "recursive"} { + testchannelevent $f delete 1 + testchannelevent $f delete 0 + lappend z "del deleted notcalled" + lappend z "del deleted myself" + } else { + set u recursive + lappend z "del calling recursive" + update + lappend z "del after update" + } + } + set z "" + set u toplevel + update + close $f + string compare [string tolower $z] \ + [list {del calling recursive} {del deleted notcalled} \ + {del deleted myself} {del after update}] +} 0 +test io-27.6 {testing handler deletion vs reentrant calls} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list second $f] + testchannelevent $f add readable [list first $f] + proc first {f} { + global u z + if {"$u" == "toplevel"} { + lappend z "first called" + set u first + update + lappend z "first after update" + } else { + lappend z "first called not toplevel" + } + } + proc second {f} { + global u z + if {"$u" == "first"} { + lappend z "second called, first time" + set u second + testchannelevent $f delete 0 + } elseif {"$u" == "second"} { + lappend z "second called, second time" + testchannelevent $f delete 0 + } else { + lappend z "second called, cannot happen!" + testchannelevent $f removeall + } + } + set z "" + set u toplevel + update + close $f + string compare [string tolower $z] \ + [list {first called} {first called not toplevel} \ + {second called, first time} {second called, second time} \ + {first after update}] +} 0 + +test io-28.1 {Test old socket deletion on Macintosh} {socket} { + set x 0 + set result "" + proc accept {s a p} { + global x wait + fconfigure $s -blocking off + puts $s "sock[incr x]" + close $s + set wait done + } + set ss [socket -server accept 2831] + set wait "" + set cs [socket [info hostname] 2831] + vwait wait + lappend result [gets $cs] + close $cs + + set wait "" + set cs [socket [info hostname] 2831] + vwait wait + lappend result [gets $cs] + close $cs + + set wait "" + set cs [socket [info hostname] 2831] + vwait wait + lappend result [gets $cs] + close $cs + + set wait "" + set cs [socket [info hostname] 2831] + vwait wait + lappend result [gets $cs] + close $cs + close $ss + set result +} {sock1 sock2 sock3 sock4} + +test io-29.1 {TclCopyChannel} { + removeFile test1 + set f1 [open [info script]] + set f2 [open test1 w] + fcopy $f1 $f2 -command { # } + catch { fcopy $f1 $f2 } msg + close $f1 + close $f2 + string compare $msg "channel \"$f1\" is busy" +} {0} +test io-29.2 {TclCopyChannel} { + removeFile test1 + set f1 [open [info script]] + set f2 [open test1 w] + set f3 [open [info script]] + fcopy $f1 $f2 -command { # } + catch { fcopy $f3 $f2 } msg + close $f1 + close $f2 + close $f3 + string compare $msg "channel \"$f2\" is busy" +} {0} +test io-29.3 {TclCopyChannel} { + removeFile test1 + set f1 [open [info script]] + set f2 [open test1 w] + fconfigure $f1 -translation lf -blocking 0 + fconfigure $f2 -translation cr -blocking 0 + set s0 [fcopy $f1 $f2] + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + close $f1 + close $f2 + set s1 [file size [info script]] + set s2 [file size test1] + if {("$s1" == "$s2") && ($s0 == $s1)} { + lappend result ok + } + set result +} {0 0 ok} +test io-29.4 {TclCopyChannel} { + removeFile test1 + set f1 [open [info script]] + set f2 [open test1 w] + fconfigure $f1 -translation lf -blocking 0 + fconfigure $f2 -translation cr -blocking 0 + fcopy $f1 $f2 -size 40 + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + close $f1 + close $f2 + lappend result [file size test1] +} {0 0 40} +test io-29.5 {TclCopyChannel} { + removeFile test1 + set f1 [open [info script]] + set f2 [open test1 w] + fconfigure $f1 -translation lf -blocking 0 + fconfigure $f2 -translation lf -blocking 0 + fcopy $f1 $f2 -size -1 + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + close $f1 + close $f2 + set s1 [file size [info script]] + set s2 [file size test1] + if {"$s1" == "$s2"} { + lappend result ok + } + set result +} {0 0 ok} +test io-29.6 {TclCopyChannel} { + removeFile test1 + set f1 [open [info script]] + set f2 [open test1 w] + fconfigure $f1 -translation lf -blocking 0 + fconfigure $f2 -translation lf -blocking 0 + set s0 [fcopy $f1 $f2 -size [expr [file size [info script]] + 5]] + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + close $f1 + close $f2 + set s1 [file size [info script]] + set s2 [file size test1] + if {("$s1" == "$s2") && ($s0 == $s1)} { + lappend result ok + } + set result +} {0 0 ok} +test io-29.7 {TclCopyChannel} { + removeFile test1 + set f1 [open [info script]] + set f2 [open test1 w] + fconfigure $f1 -translation lf -blocking 0 + fconfigure $f2 -translation lf -blocking 0 + fcopy $f1 $f2 + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + set s1 [file size [info script]] + set s2 [file size test1] + close $f1 + close $f2 + if {"$s1" == "$s2"} { + lappend result ok + } + set result +} {0 0 ok} +test io-29.8 {TclCopyChannel} {stdio} { + removeFile test1 + removeFile pipe + set f1 [open pipe w] + fconfigure $f1 -translation lf + puts $f1 { + puts ready + gets stdin + set f1 [open [info script] r] + fconfigure $f1 -translation lf + puts [read $f1 100] + close $f1 + } + close $f1 + set f1 [open "|[list $tcltest pipe]" r+] + fconfigure $f1 -translation lf + gets $f1 + puts $f1 ready + flush $f1 + set f2 [open test1 w] + fconfigure $f2 -translation lf + set s0 [fcopy $f1 $f2 -size 40] + catch {close $f1} + close $f2 + list $s0 [file size test1] +} {40 40} + +test io-30.1 {CopyData} { + removeFile test1 + set f1 [open [info script]] + set f2 [open test1 w] + fconfigure $f1 -translation lf -blocking 0 + fconfigure $f2 -translation cr -blocking 0 + fcopy $f1 $f2 -size 0 + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + close $f1 + close $f2 + lappend result [file size test1] +} {0 0 0} +test io-30.2 {CopyData} { + removeFile test1 + set f1 [open [info script]] + set f2 [open test1 w] + fconfigure $f1 -translation lf -blocking 0 + fconfigure $f2 -translation cr -blocking 0 + fcopy $f1 $f2 -command {set s0} + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + vwait s0 + close $f1 + close $f2 + set s1 [file size [info script]] + set s2 [file size test1] + if {("$s1" == "$s2") && ($s0 == $s1)} { + lappend result ok + } + set result +} {0 0 ok} +test io-30.3 {CopyData: background read underflow} {unixOnly} { + removeFile test1 + removeFile pipe + set f1 [open pipe w] + puts $f1 { + puts ready + flush stdout ;# Don't assume line buffered! + fcopy stdin stdout -command { set x } + vwait x + set f [open test1 w] + fconfigure $f -translation lf + puts $f "done" + close $f + } + close $f1 + set f1 [open "|[list $tcltest pipe]" r+] + set result [gets $f1] + puts $f1 line1 + flush $f1 + lappend result [gets $f1] + puts $f1 line2 + flush $f1 + lappend result [gets $f1] + close $f1 + after 500 + set f [open test1] + lappend result [read $f] + close $f + set result +} "ready line1 line2 {done\n}" +test io-30.4 {CopyData: background write overflow} {unixOnly} { + set big aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n + for {set x 0} {$x < 12} {incr x} { + append big $big + } + removeFile test1 + removeFile pipe + set f1 [open pipe w] + puts $f1 { + puts ready + fcopy stdin stdout -command { set x } + vwait x + set f [open test1 w] + fconfigure $f -translation lf + puts $f "done" + close $f + } + close $f1 + set f1 [open "|[list $tcltest pipe]" r+] + set result [gets $f1] + fconfigure $f1 -blocking 0 + puts $f1 $big + flush $f1 + after 500 + set result "" + fileevent $f1 read { + append result [read $f1 1024] + if {[string length $result] >= [string length $big]} { + set x done + } + } + vwait x + close $f1 + set big {} + set x +} done + +proc FcopyTestAccept {sock args} { + after 1000 "close $sock" +} +proc FcopyTestDone {bytes {error {}}} { + global fcopyTestDone + if {[string length $error]} { + set fcopyTestDone 1 + } else { + set fcopyTestDone 0 + } +} +if [catch {socket -server FcopyTestAccept 2828} listen] { + puts stderr "Skipping fcopy error test" +} else { + test io-30.5 {CopyData: error during fcopy} { + set in [open [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} { + removeFile pipe + removeFile test1 + catch {unset fcopyTestDone} + set f1 [open pipe w] + puts $f1 "exit 1" + close $f1 + set in [open "|[list $tcltest pipe]" r+] + set out [open test1 w] + fcopy $in $out -command [list FcopyTestDone] + if ![info exists fcopyTestDone] { + vwait fcopyTestDone + } + catch {close $in} + close $out + set fcopyTestDone ;# 0 for plain end of file +} {0} + +test io-31.1 {Recursive channel events} {socket} { + # This test checks to see if file events are delivered during recursive + # event loops when there is buffered data on the channel. + + proc accept {s a p} { + global as + fconfigure $s -translation lf + puts $s "line 1\nline2\nline3" + flush $s + set as $s + } + proc readit {s next} { + global result x + lappend result $next + if {$next == 1} { + fileevent $s readable [list readit $s 2] + vwait x + } + incr x + } + set ss [socket -server accept 2828] + + # We need to delay on some systems until the creation of the + # server socket completes. + + set done 0 + for {set i 0} {$i < 10} {incr i} { + if {![catch {set cs [socket [info hostname] 2828]}]} { + set done 1 + break + } + after 100 + } + if {$done == 0} { + close $ss + error "failed to connect to server" + } + set result {} + set x 0 + vwait as + fconfigure $cs -translation lf + lappend result [gets $cs] + fconfigure $cs -blocking off + fileevent $cs readable [list readit $cs 1] + set a [after 2000 { set x failure }] + vwait x + after cancel $a + close $as + close $ss + close $cs + list $result $x +} {{{line 1} 1 2} 2} +test io-31.2 {Testing for busy-wait in recursive channel events} {socket} { + set s [socket -server accept 3939] + proc accept {s a p} { + global counter + + set counter 0 + fconfigure $s -blocking off -buffering line -translation lf + fileevent $s readable "doit $s" + } + proc doit {s} { + global counter + + incr counter + set l [gets $s] + if {"$l" == ""} { + fileevent $s readable "doit1 $s" + after 1000 newline + } + } + proc doit1 {s} { + global counter + + incr counter + set l [gets $s] + close $s + } + proc producer {} { + global writer + + set writer [socket localhost 3939] + fconfigure $writer -buffering line + puts -nonewline $writer hello + flush $writer + } + proc newline {} { + global writer done + + puts $writer hello + flush $writer + set done 1 + } + producer + vwait done + close $writer + close $s + set counter +} 1 +test io-32.1 {ChannelEventScriptInvoker: deletion} { + proc eventScript {fd} { + close $fd + error "planned error" + set ::x whoops + } + proc bgerror {args} { + set ::x got_error + } + set f [open fooBar w] + fileevent $f writable [list eventScript $f] + set x not_done + vwait x + set x +} {got_error} + +test io-33.1 {ChannelTimerProc} { + set f [open fooBar w] + puts $f "this is a test" + close $f + set f [open fooBar r] + testchannelevent $f add readable { + read $f 1 + incr x + } + set x 0 + vwait x + vwait x + set result $x + testchannelevent $f set 0 none + after idle {set y done} + vwait y + lappend result $y +} {2 done} + +removeFile fooBar +removeFile longfile +removeFile script +removeFile output +removeFile test1 +removeFile pipe +removeFile my_script +removeFile foo +removeFile bar +removeFile test2 +removeFile test3 + +file delete cat + +set x "" +unset x diff --git a/tests/ioCmd.test b/tests/ioCmd.test new file mode 100644 index 0000000..fd39263 --- /dev/null +++ b/tests/ioCmd.test @@ -0,0 +1,512 @@ +# Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, +# fblocked, fconfigure, open, channel, fcopy +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# 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" + +if {[string compare test [info procs test]] == 1} then {source defs} + +removeFile test1 +removeFile pipe + +set executable [list [info nameofexecutable]] + +test iocmd-1.1 {puts command} { + list [catch {puts} msg] $msg +} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}} +test iocmd-1.2 {puts command} { + list [catch {puts a b c d e f g} msg] $msg +} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}} +test iocmd-1.3 {puts command} { + list [catch {puts froboz -nonewline kablooie} msg] $msg +} {1 {bad argument "kablooie": should be "nonewline"}} +test iocmd-1.4 {puts command} { + list [catch {puts froboz hello} msg] $msg +} {1 {can not find channel named "froboz"}} +test iocmd-1.5 {puts command} { + list [catch {puts stdin hello} msg] $msg +} {1 {channel "stdin" wasn't opened for writing}} +test iocmd-1.6 {puts command} { + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + puts -nonewline $f foobar + close $f + file size test1 +} 6 +test iocmd-1.7 {puts command} { + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + puts $f foobar + close $f + file size test1 +} 7 +test iocmd-1.8 {puts command} { + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + puts -nonewline $f [binary format a4a5 foo bar] + close $f + file size test1 +} 9 + + +test iocmd-2.1 {flush command} { + list [catch {flush} msg] $msg +} {1 {wrong # args: should be "flush channelId"}} +test iocmd-2.2 {flush command} { + list [catch {flush a b c d e} msg] $msg +} {1 {wrong # args: should be "flush channelId"}} +test iocmd-2.3 {flush command} { + list [catch {flush foo} msg] $msg +} {1 {can not find channel named "foo"}} +test iocmd-2.4 {flush command} { + list [catch {flush stdin} msg] $msg +} {1 {channel "stdin" wasn't opened for writing}} + +test iocmd-3.1 {gets command} { + list [catch {gets} msg] $msg +} {1 {wrong # args: should be "gets channelId ?varName?"}} +test iocmd-3.2 {gets command} { + list [catch {gets a b c d e f g} msg] $msg +} {1 {wrong # args: should be "gets channelId ?varName?"}} +test iocmd-3.3 {gets command} { + list [catch {gets aaa} msg] $msg +} {1 {can not find channel named "aaa"}} +test iocmd-3.4 {gets command} { + list [catch {gets stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +test iocmd-3.5 {gets command} { + set f [open test1 w] + puts $f [binary format a4a5 foo bar] + close $f + set f [open test1 r] + set result [gets $f] + close $f + set x foo\x00 + set x "${x}bar\x00\x00" + string compare $x $result +} 0 + +test iocmd-4.1 {read command} { + list [catch {read} msg] $msg +} {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"}} +test iocmd-4.2 {read command} { + list [catch {read a b c d e f g h} msg] $msg +} {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"}} +test iocmd-4.3 {read command} { + list [catch {read aaa} msg] $msg +} {1 {can not find channel named "aaa"}} +test iocmd-4.4 {read command} { + list [catch {read -nonewline} msg] $msg +} {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"}} +test iocmd-4.5 {read command} { + list [catch {read -nonew file4} msg] $msg $errorCode +} {1 {can not find channel named "-nonew"} NONE} +test iocmd-4.6 {read command} { + list [catch {read stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +test iocmd-4.7 {read command} { + list [catch {read -nonewline stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +test iocmd-4.8 {read command with incorrect combination of arguments} { + removeFile test1 + set f [open test1 w] + puts $f "Two lines: this one" + puts $f "and this one" + close $f + set f [open test1] + set x [list [catch {read -nonewline $f 20 z} msg] $msg $errorCode] + close $f + set x +} {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"} NONE} +test iocmd-4.9 {read command} { + list [catch {read stdin foo} msg] $msg $errorCode +} {1 {bad argument "foo": should be "nonewline"} NONE} +test iocmd-4.10 {read command} { + list [catch {read file107} msg] $msg $errorCode +} {1 {can not find channel named "file107"} NONE} +test iocmd-4.11 {read command} { + set f [open test3 w] + set x [list [catch {read $f} msg] $msg $errorCode] + close $f + string compare [string tolower $x] \ + [list 1 [format "channel \"%s\" wasn't opened for reading" $f] none] +} 0 +test iocmd-4.12 {read command} { + set f [open test1] + set x [list [catch {read $f 12z} msg] $msg $errorCode] + close $f + set x +} {1 {expected integer but got "12z"} NONE} + +test iocmd-5.1 {seek command} { + list [catch {seek} msg] $msg +} {1 {wrong # args: should be "seek channelId offset ?origin?"}} +test iocmd-5.2 {seek command} { + list [catch {seek a b c d e f g} msg] $msg +} {1 {wrong # args: should be "seek channelId offset ?origin?"}} +test iocmd-5.3 {seek command} { + list [catch {seek stdin gugu} msg] $msg +} {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}} + +test iocmd-6.1 {tell command} { + list [catch {tell} msg] $msg +} {1 {wrong # args: should be "tell channelId"}} +test iocmd-6.2 {tell command} { + list [catch {tell a b c d e} msg] $msg +} {1 {wrong # args: should be "tell channelId"}} +test iocmd-6.3 {tell command} { + list [catch {tell aaa} msg] $msg +} {1 {can not find channel named "aaa"}} + +test iocmd-7.1 {close command} { + list [catch {close} msg] $msg +} {1 {wrong # args: should be "close channelId"}} +test iocmd-7.2 {close command} { + list [catch {close a b c d e} msg] $msg +} {1 {wrong # args: should be "close channelId"}} +test iocmd-7.3 {close command} { + list [catch {close aaa} msg] $msg +} {1 {can not find channel named "aaa"}} + +test iocmd-8.1 {fconfigure command} { + list [catch {fconfigure} msg] $msg +} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}} +test iocmd-8.2 {fconfigure command} { + list [catch {fconfigure a b c d e f} msg] $msg +} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}} +test iocmd-8.3 {fconfigure command} { + list [catch {fconfigure a b} msg] $msg +} {1 {can not find channel named "a"}} +test iocmd-8.4 {fconfigure command} { + removeFile test1 + set f1 [open test1 w] + set x [list [catch {fconfigure $f1 froboz} msg] $msg] + close $f1 + set x +} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -eofchar, or -translation}} +test iocmd-8.5 {fconfigure command} { + list [catch {fconfigure stdin -buffering froboz} msg] $msg +} {1 {bad value for -buffering: must be one of full, line, or none}} +test iocmd-8.6 {fconfigure command} { + list [catch {fconfigure stdin -translation froboz} msg] $msg +} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}} +test iocmd-8.7 {fconfigure command} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + set x [fconfigure $f1] + close $f1 + set x +} {-blocking 1 -buffering full -buffersize 4096 -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 {} + 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}} +test iocmd-8.9 {fconfigure command} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ + -eofchar {} + set x [fconfigure $f1] + close $f1 + set x +} {-blocking 1 -buffering none -buffersize 4040 -eofchar {} -translation lf} +test iocmd-8.10 {fconfigure command} { + list [catch {fconfigure a b} msg] $msg +} {1 {can not find channel named "a"}} +test iocmd-8.11 {fconfigure command} { + list [catch {fconfigure stdout -froboz blarfo} msg] $msg +} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -eofchar, or -translation}} +test iocmd-8.12 {fconfigure command} { + list [catch {fconfigure stdout -b blarfo} msg] $msg +} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -eofchar, or -translation}} +test iocmd-8.13 {fconfigure command} { + list [catch {fconfigure stdout -buffer blarfo} msg] $msg +} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -eofchar, or -translation}} +test iocmd-8.14 {fconfigure command} { + fconfigure stdin -buffers +} 4096 +proc iocmdSSETUP {} { + uplevel { + set srv [socket -server iocmdSRV 0]; + set port [lindex [fconfigure $srv -sockname] 2]; + proc iocmdSRV {sock ip port} {close $sock} + set cli [socket localhost $port]; + } +} +proc iocmdSSHTDWN {} { + uplevel { + close $cli; + close $srv; + unset cli srv port + rename iocmdSRV {} + } +} + +test iocmd-8.15 {fconfigure command / tcp channel} {socket} { + iocmdSSETUP + set r [list [catch {fconfigure $cli -blah} msg] $msg]; + iocmdSSHTDWN + set r; +} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, -peername, or -sockname}} +test iocmd-8.16 {fconfigure command / tcp channel} {socket} { + iocmdSSETUP + set r [expr [lindex [fconfigure $cli -peername] 2]==$port]; + iocmdSSHTDWN + set r +} 1 +test iocmd-8.17 {fconfigure command / tcp channel} {nonPortable} { + # It is possible that you don't get the connection reset by peer + # error but rather a valid answer. depends of the tcp implementation + iocmdSSETUP + update; + puts $cli "blah"; flush $cli; # that flush could/should fail too + update; + set r [catch {fconfigure $cli -peername} msg] + iocmdSSHTDWN + regsub -all {can([^:])+: } $r {} r; + set r +} 1 +test iocmd-8.18 {fconfigure command / unix tty channel} {nonPortable unixOnly} { + # might fail if /dev/ttya is unavailable + set tty [open /dev/ttya] + set r [list [catch {fconfigure $tty -blah blih} msg] $msg]; + close $tty; + set r; +} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}} +test iocmd-8.19 {fconfigure command / win tty channel} {pcOnly && !win32s} { + # None of the com port functions are implemented on Win32s. + # Also, might fail if com1 is unavailable + set tty [open com1] + set r [list [catch {fconfigure $tty -blah blih} msg] $msg]; + close $tty; + set r; +} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}} + +test iocmd-9.1 {eof command} { + list [catch {eof} msg] $msg $errorCode +} {1 {wrong # args: should be "eof channelId"} NONE} +test iocmd-9.2 {eof command} { + list [catch {eof a b} msg] $msg $errorCode +} {1 {wrong # args: should be "eof channelId"} NONE} +test iocmd-9.3 {eof command} { + catch {close file100} + list [catch {eof file100} msg] $msg $errorCode +} {1 {can not find channel named "file100"} NONE} + +test iocmd-10.1 {fblocked command} { + list [catch {fblocked} msg] $msg +} {1 {wrong # args: should be "fblocked channelId"}} +test iocmd-10.2 {fblocked command} { + list [catch {fblocked a b c d e f g} msg] $msg +} {1 {wrong # args: should be "fblocked channelId"}} +test iocmd-10.3 {fblocked command} { + list [catch {fblocked file1000} msg] $msg +} {1 {can not find channel named "file1000"}} +test iocmd-10.4 {fblocked command} { + list [catch {fblocked stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +test iocmd-10.5 {fblocked command} { + fblocked stdin +} 0 + +removeFile test5 +test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} { + set f [open test4 w] + close $f + list [catch {open "| cat < test4 > test5" w} msg] $msg $errorCode +} {1 {can't write input to command: standard input was redirected} NONE} +test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} { + list [catch {open "| echo > test5" r} msg] $msg $errorCode +} {1 {can't read output from command: standard output was redirected} NONE} +test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} { + list [catch {open "| echo > test5" r+} msg] $msg $errorCode +} {1 {can't read output from command: standard output was redirected} NONE} + +test iocmd-12.1 {POSIX open access modes: RDONLY} { + removeFile test1 + set f [open test1 w] + puts $f "Two lines: this one" + puts $f "and this one" + close $f + set f [open test1 RDONLY] + set x [list [gets $f] [catch {puts $f Test} msg] $msg] + close $f + string compare $x \ + "{Two lines: this one} 1 [list [format "channel \"%s\" wasn't opened for writing" $f]]" +} 0 +test iocmd-12.2 {POSIX open access modes: RDONLY} { + removeFile test3 + string tolower [list [catch {open test3 RDONLY} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +test iocmd-12.3 {POSIX open access modes: WRONLY} { + removeFile test3 + string tolower [list [catch {open test3 WRONLY} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +# +# Test 13.4 relies on assigning the same channel name twice. +# +test iocmd-12.4 {POSIX open access modes: WRONLY} {unixOnly} { + removeFile test3 + set f [open test3 w] + fconfigure $f -eofchar {} + puts $f xyzzy + close $f + set f [open test3 WRONLY] + fconfigure $f -eofchar {} + puts -nonewline $f "ab" + seek $f 0 current + set x [list [catch {gets $f} msg] $msg] + close $f + set f [open test3 r] + fconfigure $f -eofchar {} + lappend x [gets $f] + close $f + set y [list 1 [format "channel \"%s\" wasn't opened for reading" $f] abzzy] + string compare $x $y +} 0 +test iocmd-12.5 {POSIX open access modes: RDWR} { + removeFile test3 + string tolower [list [catch {open test3 RDWR} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +test iocmd-12.6 {POSIX open access modes: errors} { + concat [catch {open test3 "FOO \{BAR BAZ"} msg] $msg\n$errorInfo +} "1 unmatched open brace in list +unmatched open brace in list + while processing open access modes \"FOO {BAR BAZ\" + invoked from within +\"open test3 \"FOO \\{BAR BAZ\"\"" +test iocmd-12.7 {POSIX open access modes: errors} { + list [catch {open test3 {FOO BAR BAZ}} msg] $msg +} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, CREAT EXCL, NOCTTY, NONBLOCK, or TRUNC}} +test iocmd-12.8 {POSIX open access modes: errors} { + list [catch {open test3 {TRUNC CREAT}} msg] $msg +} {1 {access mode must include either RDONLY, WRONLY, or RDWR}} + +test iocmd-13.1 {errors in open command} { + list [catch {open} msg] $msg +} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}} +test iocmd-13.2 {errors in open command} { + list [catch {open a b c d} msg] $msg +} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}} +test iocmd-13.3 {errors in open command} { + list [catch {open test1 x} msg] $msg +} {1 {illegal access mode "x"}} +test iocmd-13.4 {errors in open command} { + list [catch {open test1 rw} msg] $msg +} {1 {illegal access mode "rw"}} +test iocmd-13.5 {errors in open command} { + list [catch {open test1 r+1} msg] $msg +} {1 {illegal access mode "r+1"}} +test iocmd-13.6 {errors in open command} { + string tolower [list [catch {open _non_existent_} msg] $msg $errorCode] +} {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} + +test iocmd-14.1 {file id parsing errors} { + list [catch {eof gorp} msg] $msg $errorCode +} {1 {can not find channel named "gorp"} NONE} +test iocmd-14.2 {file id parsing errors} { + list [catch {eof filex} msg] $msg +} {1 {can not find channel named "filex"}} +test iocmd-14.3 {file id parsing errors} { + list [catch {eof file12a} msg] $msg +} {1 {can not find channel named "file12a"}} +test iocmd-14.4 {file id parsing errors} { + list [catch {eof file123} msg] $msg +} {1 {can not find channel named "file123"}} +test iocmd-14.5 {file id parsing errors} { + list [catch {eof stdout} msg] $msg +} {0 0} +test iocmd-14.6 {file id parsing errors} { + list [catch {eof stdin} msg] $msg +} {0 0} +test iocmd-14.7 {file id parsing errors} { + list [catch {eof stdout} msg] $msg +} {0 0} +test iocmd-14.8 {file id parsing errors} { + list [catch {eof stderr} msg] $msg +} {0 0} +test iocmd-14.9 {file id parsing errors} { + list [catch {eof stderr1} msg] $msg +} {1 {can not find channel named "stderr1"}} +set f [open test1 w] +close $f +set expect "1 {can not find channel named \"$f\"}" +test iocmd-14.10 {file id parsing errors} { + list [catch {eof $f} msg] $msg +} $expect + +test iocmd-15.1 {Tcl_FcopyObjCmd} { + list [catch {fcopy} msg] $msg +} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} +test iocmd-15.2 {Tcl_FcopyObjCmd} { + list [catch {fcopy 1} msg] $msg +} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} +test iocmd-15.3 {Tcl_FcopyObjCmd} { + list [catch {fcopy 1 2 3 4 5 6 7} msg] $msg +} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} +test iocmd-15.4 {Tcl_FcopyObjCmd} { + list [catch {fcopy 1 2 3} msg] $msg +} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} +test iocmd-15.5 {Tcl_FcopyObjCmd} { + list [catch {fcopy 1 2 3 4 5} msg] $msg +} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} +set f [open test1 w] +close $f +set rfile [open test1 r] +set wfile [open test2 w] +test iocmd-15.6 {Tcl_FcopyObjCmd} { + list [catch {fcopy foo $wfile} msg] $msg +} {1 {can not find channel named "foo"}} +test iocmd-15.7 {Tcl_FcopyObjCmd} { + list [catch {fcopy $rfile foo} msg] $msg +} {1 {can not find channel named "foo"}} +test iocmd-15.8 {Tcl_FcopyObjCmd} { + list [catch {fcopy $wfile $wfile} msg] $msg +} "1 {channel \"$wfile\" wasn't opened for reading}" +test iocmd-15.9 {Tcl_FcopyObjCmd} { + list [catch {fcopy $rfile $rfile} msg] $msg +} "1 {channel \"$rfile\" wasn't opened for writing}" +test iocmd-15.10 {Tcl_FcopyObjCmd} { + list [catch {fcopy $rfile $wfile foo bar} msg] $msg +} {1 {bad switch "foo": must be -size, or -command}} +test iocmd-15.11 {Tcl_FcopyObjCmd} { + list [catch {fcopy $rfile $wfile -size foo} msg] $msg +} {1 {expected integer but got "foo"}} +test iocmd-15.12 {Tcl_FcopyObjCmd} { + list [catch {fcopy $rfile $wfile -command bar -size foo} msg] $msg +} {1 {expected integer but got "foo"}} + +close $rfile +close $wfile + +removeFile test1 +removeFile test2 +removeFile test3 +removeFile test4 +# delay long enough for background processes to finish +after 500 +removeFile test5 +removeFile pipe +removeFile output +set x "" +set x diff --git a/tests/join.test b/tests/join.test new file mode 100644 index 0000000..62af644 --- /dev/null +++ b/tests/join.test @@ -0,0 +1,48 @@ +# Commands covered: join +# +# 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: @(#) join.test 1.7 97/10/06 13:04:59 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test join-1.1 {basic join commands} { + join {a b c} xyz +} axyzbxyzc +test join-1.2 {basic join commands} { + join {a b c} {} +} abc +test join-1.3 {basic join commands} { + join {} xyz +} {} +test join-1.4 {basic join commands} { + join {12 34 56} +} {12 34 56} + +test join-2.1 {join errors} { + list [catch join msg] $msg $errorCode +} {1 {wrong # args: should be "join list ?joinString?"} NONE} +test join-2.2 {join errors} { + list [catch {join a b c} msg] $msg $errorCode +} {1 {wrong # args: should be "join list ?joinString?"} NONE} +test join-2.3 {join errors} { + list [catch {join "a \{ c" 111} msg] $msg $errorCode +} {1 {unmatched open brace in list} NONE} + +test join-3.1 {joinString is binary ok} { + string length [join {a b c} a\0b] +} 9 + +test join-3.2 {join is binary ok} { + string length [join "a\0b a\0b a\0b"] +} 11 + + diff --git a/tests/lindex.test b/tests/lindex.test new file mode 100644 index 0000000..fa2c1c6 --- /dev/null +++ b/tests/lindex.test @@ -0,0 +1,74 @@ +# Commands covered: lindex +# +# 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: @(#) lindex.test 1.7 97/02/27 16:53:56 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test lindex-1.1 {basic tests} { + lindex {a b c} 0} a +test lindex-1.2 {basic tests} { + lindex {a {b c d} x} 1} {b c d} +test lindex-1.3 {basic tests} { + lindex {a b\ c\ d x} 1} {b c d} +test lindex-1.4 {basic tests} { + lindex {a b c} 3} {} +test lindex-1.5 {basic tests} { + list [catch {lindex {a b c} -1} msg] $msg +} {0 {}} +test lindex-1.6 {basic tests} { + lindex {a b c d} end +} d +test lindex-1.7 {basic tests} { + lindex {a b c d} 100 +} {} +test lindex-1.8 {basic tests} { + lindex {a} e +} a +test lindex-1.9 {basic tests} { + lindex {} end +} {} +test lindex-1.10 {basic tests} { + lindex {a b c d} 3 +} d + +test lindex-2.1 {error conditions} { + list [catch {lindex msg} msg] $msg +} {1 {wrong # args: should be "lindex list index"}} +test lindex-2.2 {error conditions} { + list [catch {lindex 1 2 3 4} msg] $msg +} {1 {wrong # args: should be "lindex list index"}} +test lindex-2.3 {error conditions} { + list [catch {lindex 1 2a2} msg] $msg +} {1 {bad index "2a2": must be integer or "end"}} +test lindex-2.4 {error conditions} { + list [catch {lindex "a \{" 2} msg] $msg +} {1 {unmatched open brace in list}} +test lindex-2.5 {error conditions} { + list [catch {lindex {a {b c}d e} 2} msg] $msg +} {1 {list element in braces followed by "d" instead of space}} +test lindex-2.6 {error conditions} { + list [catch {lindex {a "b c"def ghi} 2} msg] $msg +} {1 {list element in quotes followed by "def" instead of space}} + +test lindex-3.1 {quoted elements} { + lindex {a "b c" d} 1 +} {b c} +test lindex-3.2 {quoted elements} { + lindex {"{}" b c} 0 +} {{}} +test lindex-3.3 {quoted elements} { + lindex {ab "c d \" x" y} 1 +} {c d " x} +test lindex-3.4 {quoted elements} { + lindex {a b {c d "e} {f g"}} 2 +} {c d "e} diff --git a/tests/link.test b/tests/link.test new file mode 100644 index 0000000..25eefb1 --- /dev/null +++ b/tests/link.test @@ -0,0 +1,234 @@ +# Commands covered: none +# +# This file contains a collection of tests for Tcl_LinkVar and related +# library procedures. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 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: @(#) link.test 1.12 97/01/21 21:16:04 + +if {[info commands testlink] == {}} { + puts "This application hasn't been compiled with the \"testlink\"" + puts "command, so I can't test Tcl_LinkVar et al." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +foreach i {int real bool string} { + catch {unset $i} +} +test link-1.1 {reading C variables from Tcl} { + testlink delete + testlink set 43 1.23 4 - + testlink create 1 1 1 1 + list $int $real $bool $string +} {43 1.23 1 NULL} +test link-1.2 {reading C variables from Tcl} { + testlink delete + testlink create 1 1 1 1 + testlink set -3 2 0 "A long string with spaces" + list $int $real $bool $string $int $real $bool $string +} {-3 2.0 0 {A long string with spaces} -3 2.0 0 {A long string with spaces}} + +test link-2.1 {writing C variables from Tcl} { + testlink delete + testlink set 43 1.21 4 - + testlink create 1 1 1 1 + set int "00721" + set real -10.5 + set bool true + set string abcdef + concat [testlink get] $int $real $bool $string +} {465 -10.5 1 abcdef 00721 -10.5 true abcdef} +test link-2.2 {writing bad values into variables} { + testlink delete + testlink set 43 1.23 4 - + testlink create 1 1 1 1 + list [catch {set int 09a} msg] $msg $int +} {1 {can't set "int": variable must have integer value} 43} +test link-2.3 {writing bad values into variables} { + testlink delete + testlink set 43 1.23 4 - + testlink create 1 1 1 1 + list [catch {set real 1.x3} msg] $msg $real +} {1 {can't set "real": variable must have real value} 1.23} +test link-2.4 {writing bad values into variables} { + testlink delete + testlink set 43 1.23 4 - + testlink create 1 1 1 1 + list [catch {set bool gorp} msg] $msg $bool +} {1 {can't set "bool": variable must have boolean value} 1} + +test link-3.1 {read-only variables} { + testlink delete + testlink set 43 1.23 4 - + testlink create 0 1 1 0 + list [catch {set int 4} msg] $msg $int \ + [catch {set real 10.6} msg] $msg $real \ + [catch {set bool no} msg] $msg $bool \ + [catch {set string "new value"} msg] $msg $string +} {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL} +test link-3.2 {read-only variables} { + testlink delete + testlink set 43 1.23 4 - + testlink create 1 0 0 1 + list [catch {set int 4} msg] $msg $int \ + [catch {set real 10.6} msg] $msg $real \ + [catch {set bool no} msg] $msg $bool \ + [catch {set string "new value"} msg] $msg $string +} {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value}} + +test link-4.1 {unsetting linked variables} { + testlink delete + testlink set -6 -2.5 0 stringValue + testlink create 1 1 1 1 + unset int real bool string + list [catch {set int} msg] $msg [catch {set real} msg] $msg \ + [catch {set bool} msg] $msg [catch {set string} msg] $msg +} {0 -6 0 -2.5 0 0 0 stringValue} +test link-4.2 {unsetting linked variables} { + testlink delete + testlink set -6 -2.1 0 stringValue + testlink create 1 1 1 1 + unset int real bool string + set int 102 + set real 16 + set bool true + set string newValue + testlink get +} {102 16.0 1 newValue} + +test link-5.1 {unlinking variables} { + testlink delete + testlink set -6 -2.25 0 stringValue + testlink delete + set int xx1 + set real qrst + set bool bogus + set string 12345 + testlink get +} {-6 -2.25 0 stringValue} +test link-5.2 {unlinking variables} { + testlink delete + testlink set -6 -2.25 0 stringValue + testlink create 1 1 1 1 + testlink delete + testlink set 25 14.7 7 - + list $int $real $bool $string +} {-6 -2.25 0 stringValue} + +test link-6.1 {errors in setting up link} { + testlink delete + catch {unset int} + set int(44) 1 + list [catch {testlink create 1 1 1 1} msg] $msg +} {1 {can't set "int": variable is array}} +catch {unset int} + +test link-7.1 {access to linked variables via upvar} { + proc x {} { + upvar int y + unset y + } + testlink delete + testlink create 1 0 0 0 + testlink set 14 {} {} {} + x + list [catch {set int} msg] $msg +} {0 14} +test link-7.2 {access to linked variables via upvar} { + proc x {} { + upvar int y + return [set y] + } + testlink delete + testlink create 1 0 0 0 + testlink set 0 {} {} {} + set int + testlink set 23 {} {} {} + x + list [x] $int +} {23 23} +test link-7.3 {access to linked variables via upvar} { + proc x {} { + upvar int y + set y 44 + } + testlink delete + testlink create 0 0 0 0 + testlink set 11 {} {} {} + list [catch x msg] $msg $int +} {1 {can't set "y": linked variable is read-only} 11} +test link-7.4 {access to linked variables via upvar} { + proc x {} { + upvar int y + set y abc + } + testlink delete + testlink create 1 1 1 1 + testlink set -4 {} {} {} + list [catch x msg] $msg $int +} {1 {can't set "y": variable must have integer value} -4} +test link-7.5 {access to linked variables via upvar} { + proc x {} { + upvar real y + set y abc + } + testlink delete + testlink create 1 1 1 1 + testlink set -4 16.75 {} {} + list [catch x msg] $msg $real +} {1 {can't set "y": variable must have real value} 16.75} +test link-7.6 {access to linked variables via upvar} { + proc x {} { + upvar bool y + set y abc + } + testlink delete + testlink create 1 1 1 1 + testlink set -4 16.3 1 {} + list [catch x msg] $msg $bool +} {1 {can't set "y": variable must have boolean value} 1} + +test link-8.1 {Tcl_UpdateLinkedVar procedure} { + proc x args { + global x int real bool string + lappend x $args $int $real $bool $string + } + set x {} + testlink create 1 1 1 1 + testlink set 14 -2.0 0 xyzzy + trace var int w x + testlink update 32 4.0 3 abcd + trace vdelete int w x + set x +} {{int {} w} 32 -2.0 0 xyzzy} +test link-8.2 {Tcl_UpdateLinkedVar procedure} { + proc x args { + global x int real bool string + lappend x $args $int $real $bool $string + } + set x {} + testlink create 1 1 1 1 + testlink set 14 -2.0 0 xyzzy + testlink delete + trace var int w x + testlink update 32 4.0 6 abcd + trace vdelete int w x + set x +} {} +test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} { + testlink create 0 0 0 0 + list [catch {testlink update 47 {} {} {}} msg] $msg $int +} {0 {} 47} + +testlink delete +foreach i {int real bool string} { + catch {unset $i} +} diff --git a/tests/linsert.test b/tests/linsert.test new file mode 100644 index 0000000..86a47f5 --- /dev/null +++ b/tests/linsert.test @@ -0,0 +1,105 @@ +# Commands covered: linsert +# +# 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: @(#) linsert.test 1.14 97/11/18 13:54:18 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset lis} +catch {rename p ""} + +test linsert-1.1 {linsert command} { + linsert {1 2 3 4 5} 0 a +} {a 1 2 3 4 5} +test linsert-1.2 {linsert command} { + linsert {1 2 3 4 5} 1 a +} {1 a 2 3 4 5} +test linsert-1.3 {linsert command} { + linsert {1 2 3 4 5} 2 a +} {1 2 a 3 4 5} +test linsert-1.4 {linsert command} { + linsert {1 2 3 4 5} 3 a +} {1 2 3 a 4 5} +test linsert-1.5 {linsert command} { + linsert {1 2 3 4 5} 4 a +} {1 2 3 4 a 5} +test linsert-1.6 {linsert command} { + linsert {1 2 3 4 5} 5 a +} {1 2 3 4 5 a} +test linsert-1.7 {linsert command} { + linsert {1 2 3 4 5} 2 one two \{three \$four +} {1 2 one two \{three {$four} 3 4 5} +test linsert-1.8 {linsert command} { + linsert {\{one \$two \{three \ four \ five} 2 a b c +} {\{one {$two} a b c \{three { four} { five}} +test linsert-1.9 {linsert command} { + linsert {{1 2} {3 4} {5 6} {7 8}} 2 {x y} {a b} +} {{1 2} {3 4} {x y} {a b} {5 6} {7 8}} +test linsert-1.10 {linsert command} { + linsert {} 2 a b c +} {a b c} +test linsert-1.11 {linsert command} { + linsert {} 2 {} +} {{}} +test linsert-1.12 {linsert command} { + linsert {a b "c c" d e} 3 1 +} {a b {c c} 1 d e} +test linsert-1.13 {linsert command} { + linsert { a b c d} 0 1 2 +} {1 2 a b c d} +test linsert-1.14 {linsert command} { + linsert {a b c {d e f}} 4 1 2 +} {a b c {d e f} 1 2} +test linsert-1.15 {linsert command} { + linsert {a b c \{\ abc} 4 q r +} {a b c \{\ q r abc} +test linsert-1.16 {linsert command} { + linsert {a b c \{ abc} 4 q r +} {a b c \{ q r abc} +test linsert-1.17 {linsert command} { + linsert {a b c} end q r +} {a b c q r} +test linsert-1.18 {linsert command} { + linsert {a} end q r +} {a q r} +test linsert-1.19 {linsert command} { + linsert {} end q r +} {q r} + +test linsert-2.1 {linsert errors} { + list [catch linsert msg] $msg +} {1 {wrong # args: should be "linsert list index element ?element ...?"}} +test linsert-2.2 {linsert errors} { + list [catch {linsert a b} msg] $msg +} {1 {wrong # args: should be "linsert list index element ?element ...?"}} +test linsert-2.3 {linsert errors} { + list [catch {linsert a 12x 2} msg] $msg +} {1 {bad index "12x": must be integer or "end"}} +test linsert-2.4 {linsert errors} { + list [catch {linsert \{ 12 2} msg] $msg +} {1 {unmatched open brace in list}} + +test linsert-3.1 {linsert won't modify shared argument objects} { + proc p {} { + linsert "a b c" 1 "x y" + return "a b c" + } + p +} "a b c" +test linsert-3.2 {linsert won't modify shared argument objects} { + catch {unset lis} + set lis [format "a \"%s\" c" "b"] + linsert $lis 0 [string length $lis] +} "7 a b c" + +catch {unset lis} +catch {rename p ""} diff --git a/tests/list.test b/tests/list.test new file mode 100644 index 0000000..6c59f20 --- /dev/null +++ b/tests/list.test @@ -0,0 +1,107 @@ +# Commands covered: list +# +# 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: @(#) list.test 1.22 97/06/23 18:19:17 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# First, a bunch of individual tests + +test list-1.1 {basic tests} {list a b c} {a b c} +test list-1.2 {basic tests} {list {a b} c} {{a b} c} +test list-1.3 {basic tests} {list \{a b c} {\{a b c} +test list-1.4 {basic tests} "list a{}} b{} c}" "a\\{\\}\\} b{} c\\}" +test list-1.5 {basic tests} {list a\[ b\] } "{a\[} b\\]" +test list-1.6 {basic tests} {list c\ d\t } "{c } {d\t}" +test list-1.7 {basic tests} {list e\n f\$ } "{e\n} {f\$}" +test list-1.8 {basic tests} {list g\; h\\} {{g;} h\\} +test list-1.9 {basic tests} "list a\\\[} b\\\]} " "a\\\[\\\} b\\\]\\\}" +test list-1.10 {basic tests} "list c\\\} d\\t} " "c\\} d\\t\\}" +test list-1.11 {basic tests} "list e\\n} f\\$} " "e\\n\\} f\\$\\}" +test list-1.12 {basic tests} "list g\\;} h\\\\} " "g\\;\\} {h\\}}" +test list-1.13 {basic tests} {list a {{}} b} {a {{}} b} +test list-1.14 {basic tests} {list a b xy\\} "a b xy\\\\" +test list-1.15 {basic tests} "list a b\} e\\" "a b\\} e\\\\" +test list-1.16 {basic tests} "list a b\}\\\$ e\\\$\\" "a b\\}\\\$ e\\\$\\\\" +test list-1.17 {basic tests} {list a\f \{\f} "{a\f} \\\{\\f" +test list-1.18 {basic tests} {list a\r \{\r} "{a\r} \\\{\\r" +test list-1.19 {basic tests} {list a\v \{\v} "{a\v} \\\{\\v" +test list-1.20 {basic tests} {list \"\}\{} "\\\"\\}\\{" +test list-1.21 {basic tests} {list a b c\\\nd} "a b c\\\\\\nd" +test list-1.22 {basic tests} {list "{ab}\\"} \\{ab\\}\\\\ +test list-1.23 {basic tests} {list \{} "\\{" +test list-1.24 {basic tests} {list} {} + +# For the next round of tests create a list and then pick it apart +# with "index" to make sure that we get back exactly what went in. + +test list-2.1 {placeholder} { +} {} +set num 1 +proc lcheck {a b c} { + global num d + set d [list $a $b $c] +; test list-2.$num {what goes in must come out} {lindex $d 0} $a + set num [expr $num+1] +; test list-2.$num {what goes in must come out} {lindex $d 1} $b + set num [expr $num+1] +; test list-2.$num {what goes in must come out} {lindex $d 2} $c + set num [expr $num+1] +} +lcheck a b c +lcheck "a b" c\td e\nf +lcheck {{a b}} {} { } +lcheck \$ \$ab ab\$ +lcheck \; \;ab ab\; +lcheck \[ \[ab ab\[ +lcheck \\ \\ab ab\\ +lcheck {"} {"ab} {ab"} +lcheck {a b} { ab} {ab } +lcheck a{ a{b \{ab +lcheck a} a}b }ab +lcheck a\\} {a \}b} {a \{c} +lcheck xyz \\ 1\\\n2 +lcheck "{ab}\\" "{ab}xy" abc + +concat {} + +# Check that tclListObj.c's SetListFromAny handles possible overlarge +# string rep lengths in the source object. + +proc slowsort list { + set result {} + set last [expr [llength $list] - 1] + while {$last > 0} { + set minIndex [expr [llength $list] - 1] + set min [lindex $list $last] + set i [expr $minIndex-1] + while {$i >= 0} { + if {[string compare [lindex $list $i] $min] < 0} { + set minIndex $i + set min [lindex $list $i] + } + set i [expr $i-1] + } + set result [concat $result [list $min]] + if {$minIndex == 0} { + set list [lrange $list 1 end] + } else { + set list [concat [lrange $list 0 [expr $minIndex-1]] \ + [lrange $list [expr $minIndex+1] end]] + } + set last [expr $last-1] + } + return [concat $result $list] +} +test list-3.1 {SetListFromAny and lrange/concat results} { + slowsort {fred julie alex carol bill annie} +} {alex annie bill carol fred julie} diff --git a/tests/listObj.test b/tests/listObj.test new file mode 100644 index 0000000..00eb7c6 --- /dev/null +++ b/tests/listObj.test @@ -0,0 +1,176 @@ +# Functionality covered: operation of the procedures in tclListObj.c that +# implement the Tcl type manager for the list object type. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) listObj.test 1.9 97/06/10 15:28:11 + +if {[info commands testobj] == {}} { + puts "This application hasn't been compiled with the \"testobj\"" + puts "command, so I can't test the Tcl type and object support." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset x} +test listobj-1.1 {Tcl_GetListObjType} { + set t [testobj types] + set first [string first "list" $t] + set result [expr {$first != -1}] +} {1} + +test listobj-2.1 {Tcl_ListObjForObjArray, use in lappend} { + catch {unset x} + list [lappend x 1 abc def] [lappend x 1 ghi jkl] $x +} {{1 abc def} {1 abc def 1 ghi jkl} {1 abc def 1 ghi jkl}} +test listobj-2.2 {Tcl_ListObjForObjArray, use in ObjInterpProc} { + proc return_args {args} { + return $args + } + list [return_args] [return_args x] [return_args x y] +} {{} x {x y}} + +test listobj-3.1 {Tcl_ListObjAppend, list conversion} { + catch {unset x} + list [lappend x 1 2 abc "long string"] $x +} {{1 2 abc {long string}} {1 2 abc {long string}}} +test listobj-3.2 {Tcl_ListObjAppend, list conversion} { + set x "" + list [lappend x first second] [lappend x third fourth] $x +} {{first second} {first second third fourth} {first second third fourth}} +test listobj-3.3 {Tcl_ListObjAppend, list conversion} { + set x "abc def" + list [lappend x first second] $x +} {{abc def first second} {abc def first second}} +test listobj-3.4 {Tcl_ListObjAppend, error in conversion} { + set x " \{" + list [catch {lappend x abc def} msg] $msg +} {1 {unmatched open brace in list}} +test listobj-3.5 {Tcl_ListObjAppend, force internal rep array to grow} { + set x "" + list [lappend x 1 1] [lappend x 2 2] [lappend x 3 3] [lappend x 4 4] \ + [lappend x 5 5] [lappend x 6 6] [lappend x 7 7] [lappend x 8 8] $x +} {{1 1} {1 1 2 2} {1 1 2 2 3 3} {1 1 2 2 3 3 4 4} {1 1 2 2 3 3 4 4 5 5} {1 1 2 2 3 3 4 4 5 5 6 6} {1 1 2 2 3 3 4 4 5 5 6 6 7 7} {1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8} {1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8}} + +test listobj-4.1 {Tcl_ListObjAppendElement, list conversion} { + catch {unset x} + list [lappend x 1] $x +} {1 1} +test listobj-4.2 {Tcl_ListObjAppendElement, list conversion} { + set x "" + list [lappend x first] [lappend x second] $x +} {first {first second} {first second}} +test listobj-4.3 {Tcl_ListObjAppendElement, list conversion} { + set x "abc def" + list [lappend x first] $x +} {{abc def first} {abc def first}} +test listobj-4.4 {Tcl_ListObjAppendElement, error in conversion} { + set x " \{" + list [catch {lappend x abc} msg] $msg +} {1 {unmatched open brace in list}} +test listobj-4.5 {Tcl_ListObjAppendElement, force internal rep array to grow} { + set x "" + list [lappend x 1] [lappend x 2] [lappend x 3] [lappend x 4] \ + [lappend x 5] [lappend x 6] [lappend x 7] [lappend x 8] $x +} {1 {1 2} {1 2 3} {1 2 3 4} {1 2 3 4 5} {1 2 3 4 5 6} {1 2 3 4 5 6 7} {1 2 3 4 5 6 7 8} {1 2 3 4 5 6 7 8}} + +test listobj-5.1 {Tcl_ListObjIndex, basic tests} { + lindex {a b c} 0 +} a +test listobj-5.2 {Tcl_ListObjIndex, basic tests} { + lindex a 0 +} a +test listobj-5.3 {Tcl_ListObjIndex, basic tests} { + lindex {a {b c d} x} 1 +} {b c d} +test listobj-5.4 {Tcl_ListObjIndex, basic tests} { + lindex {a b c} 3 +} {} +test listobj-5.5 {Tcl_ListObjIndex, basic tests} { + lindex {a b c} 100 +} {} +test listobj-5.6 {Tcl_ListObjIndex, basic tests} { + lindex a 100 +} {} +test listobj-5.7 {Tcl_ListObjIndex, basic tests} { + lindex {} -1 +} {} +test listobj-5.8 {Tcl_ListObjIndex, error in conversion} { + set x " \{" + list [catch {lindex $x 0} msg] $msg +} {1 {unmatched open brace in list}} + +test listobj-6.1 {Tcl_ListObjLength} { + llength {a b c d} +} 4 +test listobj-6.2 {Tcl_ListObjLength} { + llength {a b c {a b {c d}} d} +} 5 +test listobj-6.3 {Tcl_ListObjLength} { + llength {} +} 0 +test listobj-6.4 {Tcl_ListObjLength, convert from non-list} { + llength 123 +} 1 +test listobj-6.5 {Tcl_ListObjLength, error converting from non-list} { + list [catch {llength "a b c \{"} msg] $msg +} {1 {unmatched open brace in list}} +test listobj-6.6 {Tcl_ListObjLength, error converting from non-list} { + list [catch {llength "a {b}c"} msg] $msg +} {1 {list element in braces followed by "c" instead of space}} + +test listobj-7.1 {Tcl_ListObjReplace, conversion from non-list} { + lreplace 123 0 0 x +} {x} +test listobj-7.2 {Tcl_ListObjReplace, error converting from non-list} { + list [catch {lreplace "a b c \{" 1 1 x} msg] $msg +} {1 {unmatched open brace in list}} +test listobj-7.3 {Tcl_ListObjReplace, error converting from non-list} { + list [catch {lreplace "a {b}c" 1 2 x} msg] $msg +} {1 {list element in braces followed by "c" instead of space}} +test listobj-7.4 {Tcl_ListObjReplace, negative first element index} { + lreplace {1 2 3 4 5} -1 1 a +} {a 3 4 5} +test listobj-7.5 {Tcl_ListObjReplace, last element index >= num elems} { + lreplace {1 2 3 4 5} 3 7 a b c +} {1 2 3 a b c} +test listobj-7.6 {Tcl_ListObjReplace, first element index > last index} { + lreplace {1 2 3 4 5} 3 1 a b c +} {1 2 3 a b c 4 5} +test listobj-7.7 {Tcl_ListObjReplace, no new elements} { + lreplace {1 2 3 4 5} 1 1 +} {1 3 4 5} +test listobj-7.8 {Tcl_ListObjReplace, shrink array in place} { + lreplace {1 2 3 4 5 6 7} 4 5 +} {1 2 3 4 7} +test listobj-7.9 {Tcl_ListObjReplace, grow array in place} { + lreplace {1 2 3 4 5 6 7} 1 3 a b c d e +} {1 a b c d e 5 6 7} +test listobj-7.10 {Tcl_ListObjReplace, replace tail of array} { + lreplace {1 2 3 4 5 6 7} 3 6 a +} {1 2 3 a} +test listobj-7.11 {Tcl_ListObjReplace, must grow internal array} { + lreplace {1 2 3 4 5} 2 3 a b c d e f g h i j k l +} {1 2 a b c d e f g h i j k l 5} +test listobj-7.12 {Tcl_ListObjReplace, grow array, insert at start} { + lreplace {1 2 3 4 5} -1 -1 a b c d e f g h i j k l +} {a b c d e f g h i j k l 1 2 3 4 5} +test listobj-7.13 {Tcl_ListObjReplace, grow array, insert at end} { + lreplace {1 2 3 4 5} 4 1 a b c d e f g h i j k l +} {1 2 3 4 a b c d e f g h i j k l 5} + +test listobj-8.1 {SetListFromAny} { + lindex {0 foo\x00help 2} 1 +} "foo\x00help" + +test listobj-9.1 {UpdateStringOfList} { + string length [list foo\x00help] +} 8 diff --git a/tests/llength.test b/tests/llength.test new file mode 100644 index 0000000..badfd17 --- /dev/null +++ b/tests/llength.test @@ -0,0 +1,35 @@ +# Commands covered: llength +# +# 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: @(#) llength.test 1.4 96/02/16 08:56:11 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test llength-1.1 {length of list} { + llength {a b c d} +} 4 +test llength-1.2 {length of list} { + llength {a b c {a b {c d}} d} +} 5 +test llength-1.3 {length of list} { + llength {} +} 0 + +test llength-2.1 {error conditions} { + list [catch {llength} msg] $msg +} {1 {wrong # args: should be "llength list"}} +test llength-2.2 {error conditions} { + list [catch {llength 123 2} msg] $msg +} {1 {wrong # args: should be "llength list"}} +test llength-2.3 {error conditions} { + list [catch {llength "a b c \{"} msg] $msg +} {1 {unmatched open brace in list}} diff --git a/tests/load.test b/tests/load.test new file mode 100644 index 0000000..5c33677 --- /dev/null +++ b/tests/load.test @@ -0,0 +1,160 @@ +# Commands covered: load +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995 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: @(#) load.test 1.19 96/11/30 16:05:18 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Figure out what extension is used for shared libraries on this +# platform. + +if {$tcl_platform(platform) == "macintosh"} { + puts "can't run dynamic library tests on macintosh machines" + return +} +set ext [info sharedlibextension] +set testDir [file join [file dirname [info nameofexecutable]] dltest] +if ![file readable [file join $testDir pkga$ext]] { + puts "libraries in $testDir haven't been compiled: skipping tests" + return +} + +if [string match *pkga* [set alreadyLoaded [info loaded {}]]] { + puts "load tests have already been run once: skipping (can't rerun)" + return +} + +set alreadyTotalLoaded [info loaded] + +test load-1.1 {basic errors} { + list [catch {load} msg] $msg +} {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}} +test load-1.2 {basic errors} { + list [catch {load a b c d} msg] $msg +} {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"}} +test load-1.4 {basic errors} { + list [catch {load {}} msg] $msg +} {1 {must specify either file name or package name}} +test load-1.5 {basic errors} { + list [catch {load {} {}} msg] $msg +} {1 {must specify either file name or package name}} +test load-1.6 {basic errors} { + list [catch {load {} Unknown} msg] $msg +} {1 {package "Unknown" isn't loaded statically}} + +test load-2.1 {basic loading, with guess for package name} { + load [file join $testDir pkga$ext] + list [pkga_eq abc def] [info commands pkga_*] +} {0 {pkga_eq pkga_quote}} +interp create -safe child +test load-2.2 {loading into a safe interpreter, with package name conversion} { + load [file join $testDir pkgb$ext] pKgB child + list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ + [catch {pkgb_sub 12 10} msg2] $msg2 +} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} +test load-2.3 {loading with no _Init procedure} { + list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg +} {1 {couldn't find procedure Foo_Init}} +test load-2.4 {loading with no _SafeInit procedure} { + list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg +} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}} + +test load-3.1 {error in _Init procedure, same interpreter} { + list [catch {load [file join $testDir pkge$ext] pkge} msg] $msg $errorInfo $errorCode +} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory + while executing +"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} + interp create x + set errorCode foo + set errorInfo bar + set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \ + $msg $errorInfo $errorCode] + interp delete x + set result +} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory + while executing +"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} { + list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg +} {0 {}} +test load-4.2 {reloading package into same interpreter} { + list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg +} "1 {file \"[file join $testDir pkga$ext\"] is already loaded for package \"Pkga\"}" + +test load-5.1 {file name not specified and no static package: pick default} { + catch {interp delete x} + interp create x + load [file join $testDir pkga$ext] pkga + load {} pkga x + set result [info loaded x] + interp delete x + set result +} "{[file join $testDir pkga$ext] Pkga}" + +# On some platforms, like SunOS 4.1.3, these tests can't be run because +# they cause the process to exit. + +test load-6.1 {errors loading file} {nonPortable} { + catch {load foo foo} +} {1} + +if {[info command teststaticpkg] != ""} { + test load-7.1 {Tcl_StaticPackage procedure} { + set x "not loaded" + teststaticpkg Test 1 0 + load {} Test + load {} Test child + list [set x] [child eval set x] + } {loaded loaded} + test load-7.2 {Tcl_StaticPackage procedure} { + set x "not loaded" + teststaticpkg Another 0 0 + load {} Another + child eval {set x "not loaded"} + list [catch {load {} Another child} msg] $msg [child eval set x] [set x] + } {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded} + test load-7.3 {Tcl_StaticPackage procedure} { + set x "not loaded" + teststaticpkg More 0 1 + load {} More + set x + } {not loaded} + test load-7.4 {Tcl_StaticPackage procedure, redundant calls} { + teststaticpkg Double 0 1 + teststaticpkg Double 0 1 + info loaded + } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded" + + test load-8.1 {TclGetLoadedPackages procedure} { + info loaded + } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded" + test load-8.2 {TclGetLoadedPackages procedure} { + list [catch {info loaded gorp} msg] $msg + } {1 {couldn't find slave interpreter named "gorp"}} + test load-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}}" + test load-8.4 {TclGetLoadedPackages procedure} { + load [file join $testDir pkgb$ext] pkgb + list [info loaded {}] [lsort [info commands pkgb_*]] + } "{{[file join $testDir pkgb$ext] Pkgb} {{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyLoaded} {pkgb_sub pkgb_unsafe}" + interp delete child +} diff --git a/tests/lrange.test b/tests/lrange.test new file mode 100644 index 0000000..32fbbaa --- /dev/null +++ b/tests/lrange.test @@ -0,0 +1,83 @@ +# Commands covered: lrange +# +# 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: @(#) lrange.test 1.12 97/06/23 18:19:25 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test lrange-1.1 {range of list elements} { + lrange {a b c d} 1 2 +} {b c} +test lrange-1.2 {range of list elements} { + lrange {a {bcd e {f g {}}} l14 l15 d} 1 1 +} {{bcd e {f g {}}}} +test lrange-1.3 {range of list elements} { + lrange {a {bcd e {f g {}}} l14 l15 d} 3 end +} {l15 d} +test lrange-1.4 {range of list elements} { + lrange {a {bcd e {f g {}}} l14 l15 d} 4 10000 +} {d} +test lrange-1.5 {range of list elements} { + lrange {a {bcd e {f g {}}} l14 l15 d} 4 3 +} {} +test lrange-1.6 {range of list elements} { + lrange {a {bcd e {f g {}}} l14 l15 d} 10 11 +} {} +test lrange-1.7 {range of list elements} { + lrange {a b c d e} -1 2 +} {a b c} +test lrange-1.8 {range of list elements} { + lrange {a b c d e} -2 -1 +} {} +test lrange-1.9 {range of list elements} { + lrange {a b c d e} -2 e +} {a b c d e} +test lrange-1.10 {range of list elements} { + lrange "a b\{c d" 1 2 +} "b\\{c d" +test lrange-1.11 {range of list elements} { + lrange "a b c d" end end +} d +test lrange-1.12 {range of list elements} { + lrange "a b c d" end 100000 +} d +test lrange-1.13 {range of list elements} { + lrange "a b c d" e 3 +} d +test lrange-1.14 {range of list elements} { + lrange "a b c d" end 2 +} {} +test lrange-1.15 {range of list elements} { + concat \"[lrange {a b \{\ } 0 2]" +} {"a b \{\ "} +test lrange-1.16 {list element quoting} { + lrange {[append a .b]} 0 end +} {{[append} a .b\]} + +test lrange-2.1 {error conditions} { + list [catch {lrange a b} msg] $msg +} {1 {wrong # args: should be "lrange list first last"}} +test lrange-2.2 {error conditions} { + list [catch {lrange a b 6 7} msg] $msg +} {1 {wrong # args: should be "lrange list first last"}} +test lrange-2.3 {error conditions} { + list [catch {lrange a b 6} msg] $msg +} {1 {bad index "b": must be integer or "end"}} +test lrange-2.4 {error conditions} { + list [catch {lrange a 0 enigma} msg] $msg +} {1 {bad index "enigma": must be integer or "end"}} +test lrange-2.5 {error conditions} { + list [catch {lrange "a \{b c" 3 4} msg] $msg +} {1 {unmatched open brace in list}} +test lrange-2.6 {error conditions} { + list [catch {lrange "a b c \{ d e" 1 4} msg] $msg +} {1 {unmatched open brace in list}} diff --git a/tests/lreplace.test b/tests/lreplace.test new file mode 100644 index 0000000..44e8ee1 --- /dev/null +++ b/tests/lreplace.test @@ -0,0 +1,131 @@ +# Commands covered: lreplace +# +# 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: @(#) lreplace.test 1.16 97/10/29 16:32:39 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test lreplace-1.1 {lreplace command} { + lreplace {1 2 3 4 5} 0 0 a +} {a 2 3 4 5} +test lreplace-1.2 {lreplace command} { + lreplace {1 2 3 4 5} 1 1 a +} {1 a 3 4 5} +test lreplace-1.3 {lreplace command} { + lreplace {1 2 3 4 5} 2 2 a +} {1 2 a 4 5} +test lreplace-1.4 {lreplace command} { + lreplace {1 2 3 4 5} 3 3 a +} {1 2 3 a 5} +test lreplace-1.5 {lreplace command} { + lreplace {1 2 3 4 5} 4 4 a +} {1 2 3 4 a} +test lreplace-1.6 {lreplace command} { + lreplace {1 2 3 4 5} 4 5 a +} {1 2 3 4 a} +test lreplace-1.7 {lreplace command} { + lreplace {1 2 3 4 5} -1 -1 a +} {a 1 2 3 4 5} +test lreplace-1.8 {lreplace command} { + lreplace {1 2 3 4 5} 2 end a b c d +} {1 2 a b c d} +test lreplace-1.9 {lreplace command} { + lreplace {1 2 3 4 5} 0 3 +} {5} +test lreplace-1.10 {lreplace command} { + lreplace {1 2 3 4 5} 0 4 +} {} +test lreplace-1.11 {lreplace command} { + lreplace {1 2 3 4 5} 0 1 +} {3 4 5} +test lreplace-1.12 {lreplace command} { + lreplace {1 2 3 4 5} 2 3 +} {1 2 5} +test lreplace-1.13 {lreplace command} { + lreplace {1 2 3 4 5} 3 end +} {1 2 3} +test lreplace-1.14 {lreplace command} { + lreplace {1 2 3 4 5} -1 4 a b c +} {a b c} +test lreplace-1.15 {lreplace command} { + lreplace {a b "c c" d e f} 3 3 +} {a b {c c} e f} +test lreplace-1.16 {lreplace command} { + lreplace { 1 2 3 4 5} 0 0 a +} {a 2 3 4 5} +test lreplace-1.17 {lreplace command} { + lreplace {1 2 3 4 "5 6"} 4 4 a +} {1 2 3 4 a} +test lreplace-1.18 {lreplace command} { + lreplace {1 2 3 4 {5 6}} 4 4 a +} {1 2 3 4 a} +test lreplace-1.19 {lreplace command} { + lreplace {1 2 3 4} 2 end x y z +} {1 2 x y z} +test lreplace-1.20 {lreplace command} { + lreplace {1 2 3 4} end end a +} {1 2 3 a} +test lreplace-1.21 {lreplace command} { + lreplace {1 2 3 4} end 3 a +} {1 2 3 a} +test lreplace-1.22 {lreplace command} { + lreplace {1 2 3 4} end end +} {1 2 3} +test lreplace-1.23 {lreplace command} { + lreplace {1 2 3 4} 2 -1 xy +} {1 2 xy 3 4} +test lreplace-1.24 {lreplace command} { + lreplace {1 2 3 4} end -1 z +} {1 2 3 z 4} +test lreplace-1.25 {lreplace command} { + concat \"[lreplace {\}\ hello} end end]\" +} {"\}\ "} +test lreplace-1.26 {lreplace command} { + catch {unset foo} + set foo {a b} + list [set foo [lreplace $foo end end]] \ + [set foo [lreplace $foo end end]] \ + [set foo [lreplace $foo end end]] +} {a {} {}} + + +test lreplace-2.1 {lreplace errors} { + list [catch lreplace msg] $msg +} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}} +test lreplace-2.2 {lreplace errors} { + list [catch {lreplace a b} msg] $msg +} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}} +test lreplace-2.3 {lreplace errors} { + list [catch {lreplace x a 10} msg] $msg +} {1 {bad index "a": must be integer or "end"}} +test lreplace-2.4 {lreplace errors} { + list [catch {lreplace x 10 x} msg] $msg +} {1 {bad index "x": must be integer or "end"}} +test lreplace-2.5 {lreplace errors} { + list [catch {lreplace x 10 1x} msg] $msg +} {1 {bad index "1x": must be integer or "end"}} +test lreplace-2.6 {lreplace errors} { + list [catch {lreplace x 3 2} msg] $msg +} {1 {list doesn't contain element 3}} +test lreplace-2.7 {lreplace errors} { + list [catch {lreplace x 1 1} msg] $msg +} {1 {list doesn't contain element 1}} + +test lreplace-3.1 {lreplace won't modify shared argument objects} { + proc p {} { + lreplace "a b c" 1 1 "x y" + return "a b c" + } + p +} "a b c" + +catch {unset foo} diff --git a/tests/lsearch.test b/tests/lsearch.test new file mode 100644 index 0000000..4eda84b --- /dev/null +++ b/tests/lsearch.test @@ -0,0 +1,86 @@ +# Commands covered: lsearch +# +# 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: @(#) lsearch.test 1.7 97/04/30 13:23:53 + +if {[string compare test [info procs test]] == 1} then {source defs} + +set x {abcd bbcd 123 234 345} +test lsearch-1.1 {lsearch command} { + lsearch $x 123 +} 2 +test lsearch-1.2 {lsearch command} { + lsearch $x 3456 +} -1 +test lsearch-1.3 {lsearch command} { + lsearch $x *5 +} 4 +test lsearch-1.4 {lsearch command} { + lsearch $x *bc* +} 0 + +test lsearch-2.1 {search modes} { + lsearch -exact {xyz bbcc *bc*} *bc* +} 2 +test lsearch-2.2 {search modes} { + lsearch -exact {b.x ^bc xy bcx} ^bc +} 1 +test lsearch-2.3 {search modes} { + lsearch -exact {foo bar cat} ba +} -1 +test lsearch-2.4 {search modes} { + lsearch -exact {foo bar cat} bart +} -1 +test lsearch-2.5 {search modes} { + lsearch -exact {foo bar cat} bar +} 1 +test lsearch-2.6 {search modes} { + list [catch {lsearch -regexp {xyz bbcc *bc*} *bc*} msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} +test lsearch-2.7 {search modes} { + lsearch -regexp {b.x ^bc xy bcx} ^bc +} 3 +test lsearch-2.8 {search modes} { + lsearch -glob {xyz bbcc *bc*} *bc* +} 1 +test lsearch-2.9 {search modes} { + lsearch -glob {b.x ^bc xy bcx} ^bc +} 1 +test lsearch-2.10 {search modes} { + list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg +} {1 {bad search mode "-glib": must be -exact, -glob, or -regexp}} + +test lsearch-3.1 {lsearch errors} { + list [catch lsearch msg] $msg +} {1 {wrong # args: should be "lsearch ?mode? list pattern"}} +test lsearch-3.2 {lsearch errors} { + list [catch {lsearch a} msg] $msg +} {1 {wrong # args: should be "lsearch ?mode? list pattern"}} +test lsearch-3.3 {lsearch errors} { + list [catch {lsearch a b c} msg] $msg +} {1 {bad search mode "a": must be -exact, -glob, or -regexp}} +test lsearch-3.4 {lsearch errors} { + list [catch {lsearch a b c d} msg] $msg +} {1 {wrong # args: should be "lsearch ?mode? list pattern"}} +test lsearch-3.5 {lsearch errors} { + list [catch {lsearch "\{" b} msg] $msg +} {1 {unmatched open brace in list}} + +test lsearch-4.1 {binary data} { + lsearch -exact [list foo one\000two bar] bar +} 2 +test lsearch-4.2 {binary data} { + set x one + append x \x00 + append x two + lsearch -exact [list foo one\000two bar] $x +} 1 diff --git a/tests/macFCmd.test b/tests/macFCmd.test new file mode 100644 index 0000000..a06004c --- /dev/null +++ b/tests/macFCmd.test @@ -0,0 +1,168 @@ +# This file tests the tclfCmd.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) macFCmd.test 1.3 97/06/23 18:24:10 +# + +if {$tcl_platform(platform) != "macintosh"} { + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {file delete -force foo.dir} +file mkdir foo.dir +if {[catch {file attributes foo.dir -readonly 1}]} { + set testConfig(fileSharing) 0 + set testConfig(notFileSharing) 1 +} else { + set testConfig(fileSharing) 1 + set testConfig(notFileSharing) 0 +} +file delete -force foo.dir + +test macFCmd-1.1 {GetFileFinderAttributes - no file} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -creator} msg] $msg +} {1 {couldn't get attributes for file ":foo.file": no such file or directory}} +test macFCmd-1.2 {GetFileFinderAttributes - creator} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + list [catch {file attributes foo.file -creator} msg] $msg [file delete -force foo.file] +} {0 {MPW } {}} +test macFCmd-1.3 {GetFileFinderAttributes - type} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + list [catch {file attributes foo.file -type} msg] $msg [file delete -force foo.file] +} {0 TEXT {}} +test macFCmd-1.4 {GetFileFinderAttributes - not hidden} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + list [catch {file attributes foo.file -hidden} msg] $msg [file delete -force foo.file] +} {0 0 {}} +test macFCmd-1.5 {GetFileFinderAttributes - hidden} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + file attributes foo.file -hidden 1 + list [catch {file attributes foo.file -hidden} msg] $msg [file delete -force foo.file] +} {0 1 {}} +test macFCmd-1.6 {GetFileFinderAttributes - folder creator} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -creator} msg] $msg [file delete -force foo.dir] +} {0 Fldr {}} +test macFCmd-1.7 {GetFileFinderAttributes - folder type} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -type} msg] $msg [file delete -force foo.dir] +} {0 Fldr {}} +test macFCmd-1.8 {GetFileFinderAttributes - folder hidden} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -hidden} msg] $msg [file delete -force foo.dir] +} {0 0 {}} + +test macFCmd-2.1 {GetFileReadOnly - bad file} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -readonly} msg] $msg +} {1 {couldn't get attributes for file ":foo.file": no such file or directory}} +test macFCmd-2.2 {GetFileReadOnly - file not read only} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -readonly} msg] $msg [file delete -force foo.file] +} {0 0 {}} +test macFCmd-2.3 {GetFileReadOnly - file read only} { + catch {file delete -force foo.file} + close [open foo.file w] + file attributes foo.file -readonly 1 + list [catch {file attributes foo.file -readonly} msg] $msg [file delete -force foo.file] +} {0 1 {}} +test macFCmd-2.4 {GetFileReadOnly - directory not read only} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly} msg] $msg [file delete -force foo.dir] +} {0 0 {}} +test macFCmd-2.5 {GetFileReadOnly - directory read only} {fileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + file attributes foo.dir -readonly 1 + list [catch {file attributes foo.dir -readonly} msg] $msg [file delete -force foo.dir] +} {0 1 {}} + +test macFCmd-3.1 {SetFileFinderAttributes - bad file} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -creator FOOO} msg] $msg +} {1 {couldn't set attributes for file ":foo.file": no such file or directory}} +test macFCmd-3.2 {SetFileFinderAttributes - creator} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -creator FOOO} msg] $msg [file attributes foo.file -creator] [file delete -force foo.file] +} {0 {} FOOO {}} +test macFCmd-3.3 {SetFileFinderAttributes - bad creator} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -creator 0} msg] $msg [file delete -force foo.file] +} {1 {expected Macintosh OS type but got "0"} {}} +test macFCmd-3.4 {SetFileFinderAttributes - hidden} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -hidden 1} msg] $msg [file attributes foo.file -hidden] [file delete -force foo.file] +} {0 {} 1 {}} +test macFCmd-3.5 {SetFileFinderAttributes - type} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -type FOOO} msg] $msg [file attributes foo.file -type] [file delete -force foo.file] +} {0 {} FOOO {}} +test macFCmd-3.6 {SetFileFinderAttributes - bad type} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -type 0} msg] $msg [file delete -force foo.file] +} {1 {expected Macintosh OS type but got "0"} {}} +test macFCmd-3.7 {SetFileFinderAttributes - directory} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -creator FOOO} msg] $msg [file delete -force foo.dir] +} {1 {cannot set -creator: ":foo.dir" is a directory} {}} + +test macFCmd-4.1 {SetFileReadOnly - bad file} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -readonly 1} msg] $msg +} {1 {couldn't set attributes for file ":foo.file": no such file or directory}} +test macFCmd-4.2 {SetFileReadOnly - file not readonly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -readonly 0} msg] $msg [file attributes foo.file -readonly] [file delete -force foo.file] +} {0 {} 0 {}} +test macFCmd-4.3 {SetFileReadOnly - file readonly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -readonly 1} msg] $msg [file attributes foo.file -readonly] [file delete -force foo.file] +} {0 {} 1 {}} +test macFCmd-4.4 {SetFileReadOnly - directory not readonly} {fileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 0} msg] $msg [file attributes foo.dir -readonly] [file delete -force foo.dir] +} {0 {} 0 {}} +test macFCmd-4.5 {SetFileReadOnly - directory not readonly} {notFileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 0} msg] $msg [file delete -force foo.dir] +} {1 {cannot set a directory to read-only when File Sharing is turned off} {}} +test macFCmd-4.6 {SetFileReadOnly - directory readonly} {fileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 1} msg] $msg [file attributes foo.dir -readonly] [file delete -force foo.dir] +} {0 {} 1 {}} +test macFCmd-4.7 {SetFileReadOnly - directory readonly} {notFileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 1} msg] $msg [file delete -force foo.dir] +} {1 {cannot set a directory to read-only when File Sharing is turned off} {}} diff --git a/tests/misc.test b/tests/misc.test new file mode 100644 index 0000000..b2168c1 --- /dev/null +++ b/tests/misc.test @@ -0,0 +1,51 @@ +# Commands covered: various +# +# This file contains a collection of miscellaneous Tcl tests that +# don't fit naturally in any of the other test files. Many of these +# tests are pathological cases that caused bugs in earlier Tcl +# releases. +# +# Copyright (c) 1992-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: @(#) misc.test 1.12 97/07/02 16:41:34 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test misc-1.1 {error in variable ref. in command in array reference} { + proc tstProc {} { + global a + + set tst $a([winfo name $zz]) + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + } + set msg {} + list [catch tstProc msg] $msg +} {1 {can't read "zz": no such variable}} +test misc-1.2 {error in variable ref. in command in array reference} { + proc tstProc {} " + global a + + set tst \$a(\[winfo name \$\{zz) + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + " + 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\"} diff --git a/tests/namespace-old.test b/tests/namespace-old.test new file mode 100644 index 0000000..f743722 --- /dev/null +++ b/tests/namespace-old.test @@ -0,0 +1,844 @@ +# Functionality covered: this file contains slightly modified versions of +# the original tests written by Mike McLennan of Lucent Technologies for +# the procedures in tclNamesp.c that implement Tcl's basic support for +# namespaces. Other namespace-related tests appear in namespace.test +# and variable.test. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1997 Lucent Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) namespace-old.test 1.5 97/06/20 14:51:17 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Clear out any namespaces called test_ns_* +catch {eval namespace delete [namespace children :: test_ns_*]} + +test namespace-old-1.1 {usage for "namespace" command} { + list [catch {namespace} msg] $msg +} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}} + +test namespace-old-1.2 {global namespace's name is "::" or {}} { + list [namespace current] [namespace eval {} {namespace current}] +} {:: ::} + +test namespace-old-1.3 {usage for "namespace eval"} { + list [catch {namespace eval} msg] $msg +} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}} + +test namespace-old-1.4 {create new namespaces} { + list [lsort [namespace children :: test_ns_simple*]] \ + [namespace eval test_ns_simple {}] \ + [namespace eval test_ns_simple2 {}] \ + [lsort [namespace children :: test_ns_simple*]] +} {{} {} {} {::test_ns_simple ::test_ns_simple2}} + +test namespace-old-1.5 {access a new namespace} { + namespace eval test_ns_simple { namespace current } +} {::test_ns_simple} + +test namespace-old-1.6 {usage for "namespace eval"} { + list [catch {namespace eval} msg] $msg +} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}} + +test namespace-old-1.7 {usage for "namespace eval"} { + list [catch {namespace eval test_ns_xyzzy} msg] $msg +} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}} + +test namespace-old-1.8 {command "namespace eval" concatenates args} { + namespace eval test_ns_simple namespace current +} {::test_ns_simple} + +test namespace-old-1.9 {add elements to a namespace} { + namespace eval test_ns_simple { + variable test_ns_x 0 + proc test {test_ns_x} { + return "test: $test_ns_x" + } + } +} {} + +test namespace-old-1.10 {commands in a namespace} { + namespace eval test_ns_simple { info commands [namespace current]::*} +} {::test_ns_simple::test} + +test namespace-old-1.11 {variables in a namespace} { + namespace eval test_ns_simple { info vars [namespace current]::* } +} {::test_ns_simple::test_ns_x} + +test namespace-old-1.12 {global vars are separate from locals vars} { + list [test_ns_simple::test 123] [set test_ns_simple::test_ns_x] +} {{test: 123} 0} + +test namespace-old-1.13 {add to an existing namespace} { + namespace eval test_ns_simple { + variable test_ns_y 123 + proc _backdoor {cmd} { + eval $cmd + } + } +} "" + +test namespace-old-1.14 {commands in a namespace} { + lsort [namespace eval test_ns_simple {info commands [namespace current]::*}] +} {::test_ns_simple::_backdoor ::test_ns_simple::test} + +test namespace-old-1.15 {variables in a namespace} { + lsort [namespace eval test_ns_simple {info vars [namespace current]::*}] +} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y} +test namespace-old-1.16 {variables in a namespace} { + lsort [info vars test_ns_simple::*] +} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y} + +test namespace-old-1.17 {commands in a namespace are hidden} { + list [catch "_backdoor {return yes!}" msg] $msg +} {1 {invalid command name "_backdoor"}} +test namespace-old-1.18 {using namespace qualifiers} { + list [catch "test_ns_simple::_backdoor {return yes!}" msg] $msg +} {0 yes!} +test namespace-old-1.19 {using absolute namespace qualifiers} { + list [catch "::test_ns_simple::_backdoor {return yes!}" msg] $msg +} {0 yes!} + +test namespace-old-1.20 {variables in a namespace are hidden} { + list [catch "set test_ns_x" msg] $msg [catch "set test_ns_y" msg] $msg +} {1 {can't read "test_ns_x": no such variable} 1 {can't read "test_ns_y": no such variable}} +test namespace-old-1.21 {using namespace qualifiers} { + list [catch "set test_ns_simple::test_ns_x" msg] $msg \ + [catch "set test_ns_simple::test_ns_y" msg] $msg +} {0 0 0 123} +test namespace-old-1.22 {using absolute namespace qualifiers} { + list [catch "set ::test_ns_simple::test_ns_x" msg] $msg \ + [catch "set ::test_ns_simple::test_ns_y" msg] $msg +} {0 0 0 123} +test namespace-old-1.23 {variables can be accessed within a namespace} { + test_ns_simple::_backdoor { + variable test_ns_x + variable test_ns_y + return "$test_ns_x $test_ns_y" + } +} {0 123} + +test namespace-old-1.24 {setting global variables} { + test_ns_simple::_backdoor {variable test_ns_x; set test_ns_x "new val"} + namespace eval test_ns_simple {set test_ns_x} +} {new val} + +test namespace-old-1.25 {qualified variables don't need a global declaration} { + namespace eval test_ns_another { variable test_ns_x 456 } + set cmd {set ::test_ns_another::test_ns_x} + list [catch {test_ns_simple::_backdoor "$cmd some-value"} msg] $msg \ + [eval $cmd] +} {0 some-value some-value} + +test namespace-old-1.26 {namespace qualifiers are okay after $'s} { + namespace eval test_ns_simple { set test_ns_x 12; set test_ns_y 34 } + set cmd {list $::test_ns_simple::test_ns_x $::test_ns_simple::test_ns_y} + list [test_ns_simple::_backdoor $cmd] [eval $cmd] +} {{12 34} {12 34}} + +test namespace-old-1.27 {can create commands with null names} { + proc test_ns_simple:: {args} {return $args} +} {} + +# ----------------------------------------------------------------------- +# TEST: using "info" in namespace contexts +# ----------------------------------------------------------------------- +test namespace-old-2.1 {querying: info commands} { + lsort [test_ns_simple::_backdoor {info commands [namespace current]::*}] +} {::test_ns_simple:: ::test_ns_simple::_backdoor ::test_ns_simple::test} + +test namespace-old-2.2 {querying: info procs} { + lsort [test_ns_simple::_backdoor {info procs}] +} {{} _backdoor test} + +test namespace-old-2.3 {querying: info vars} { + lsort [info vars test_ns_simple::*] +} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y} + +test namespace-old-2.4 {querying: info vars} { + lsort [test_ns_simple::_backdoor {info vars [namespace current]::*}] +} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y} + +test namespace-old-2.5 {querying: info locals} { + lsort [test_ns_simple::_backdoor {info locals}] +} {cmd} + +test namespace-old-2.6 {querying: info exists} { + test_ns_simple::_backdoor {info exists test_ns_x} +} {0} + +test namespace-old-2.7 {querying: info exists} { + test_ns_simple::_backdoor {info exists cmd} +} {1} + +test namespace-old-2.8 {querying: info args} { + info args test_ns_simple::_backdoor +} {cmd} + +test namespace-old-2.9 {querying: info body} { + string trim [info body test_ns_simple::test] +} {return "test: $test_ns_x"} + +# ----------------------------------------------------------------------- +# TEST: namespace qualifiers, namespace tail +# ----------------------------------------------------------------------- +test namespace-old-3.1 {usage for "namespace qualifiers"} { + list [catch "namespace qualifiers" msg] $msg +} {1 {wrong # args: should be "namespace qualifiers string"}} + +test namespace-old-3.2 {querying: namespace qualifiers} { + list [namespace qualifiers ""] \ + [namespace qualifiers ::] \ + [namespace qualifiers x] \ + [namespace qualifiers ::x] \ + [namespace qualifiers foo::x] \ + [namespace qualifiers ::foo::bar::xyz] +} {{} {} {} {} foo ::foo::bar} + +test namespace-old-3.3 {usage for "namespace tail"} { + list [catch "namespace tail" msg] $msg +} {1 {wrong # args: should be "namespace tail string"}} + +test namespace-old-3.4 {querying: namespace tail} { + list [namespace tail ""] \ + [namespace tail ::] \ + [namespace tail x] \ + [namespace tail ::x] \ + [namespace tail foo::x] \ + [namespace tail ::foo::bar::xyz] +} {{} {} x x x xyz} + +# ----------------------------------------------------------------------- +# TEST: delete commands and namespaces +# ----------------------------------------------------------------------- +test namespace-old-4.1 {define test namespaces} { + namespace eval test_ns_delete { + namespace eval ns1 { + variable var1 1 + proc cmd1 {} {return "cmd1"} + } + namespace eval ns2 { + variable var2 2 + proc cmd2 {} {return "cmd2"} + } + namespace eval another {} + lsort [namespace children] + } +} {::test_ns_delete::another ::test_ns_delete::ns1 ::test_ns_delete::ns2} + +test namespace-old-4.2 {it's okay to invoke "namespace delete" with no args} { + list [catch {namespace delete} msg] $msg +} {0 {}} + +test namespace-old-4.3 {command "namespace delete" doesn't support patterns} { + set cmd { + namespace eval test_ns_delete {namespace delete ns*} + } + list [catch $cmd msg] $msg +} {1 {unknown namespace "ns*" in namespace delete command}} + +test namespace-old-4.4 {command "namespace delete" handles multiple args} { + set cmd { + namespace eval test_ns_delete { + eval namespace delete \ + [namespace children [namespace current] ns?] + } + } + list [catch $cmd msg] $msg [namespace children test_ns_delete] +} {0 {} ::test_ns_delete::another} + +# ----------------------------------------------------------------------- +# TEST: namespace hierarchy +# ----------------------------------------------------------------------- +test namespace-old-5.1 {define nested namespaces} { + set test_ns_var_global "var in ::" + proc test_ns_cmd_global {} {return "cmd in ::"} + + namespace eval test_ns_hier1 { + set test_ns_var_hier1 "particular to hier1" + proc test_ns_cmd_hier1 {} {return "particular to hier1"} + + set test_ns_level 1 + proc test_ns_show {} {return "[namespace current]: 1"} + + namespace eval test_ns_hier2 { + set test_ns_var_hier2 "particular to hier2" + proc test_ns_cmd_hier2 {} {return "particular to hier2"} + + set test_ns_level 2 + proc test_ns_show {} {return "[namespace current]: 2"} + + namespace eval test_ns_hier3a {} + namespace eval test_ns_hier3b {} + } + + namespace eval test_ns_hier2a {} + namespace eval test_ns_hier2b {} + } +} {} + +test namespace-old-5.2 {namespaces can be nested} { + list [namespace eval test_ns_hier1 {namespace current}] \ + [namespace eval test_ns_hier1 { + namespace eval test_ns_hier2 {namespace current} + }] +} {::test_ns_hier1 ::test_ns_hier1::test_ns_hier2} + +test namespace-old-5.3 {namespace qualifiers work in namespace command} { + list [namespace eval ::test_ns_hier1 {namespace current}] \ + [namespace eval test_ns_hier1::test_ns_hier2 {namespace current}] \ + [namespace eval ::test_ns_hier1::test_ns_hier2 {namespace current}] +} {::test_ns_hier1 ::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2} + +test namespace-old-5.4 {nested namespaces can access global namespace} { + list [namespace eval test_ns_hier1 {set test_ns_var_global}] \ + [namespace eval test_ns_hier1 {test_ns_cmd_global}] \ + [namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_global}] \ + [namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_global}] +} {{var in ::} {cmd in ::} {var in ::} {cmd in ::}} + +test namespace-old-5.5 {variables in different namespaces don't conflict} { + list [set test_ns_hier1::test_ns_level] \ + [set test_ns_hier1::test_ns_hier2::test_ns_level] +} {1 2} + +test namespace-old-5.6 {commands in different namespaces don't conflict} { + list [test_ns_hier1::test_ns_show] \ + [test_ns_hier1::test_ns_hier2::test_ns_show] +} {{::test_ns_hier1: 1} {::test_ns_hier1::test_ns_hier2: 2}} + +test namespace-old-5.7 {nested namespaces don't see variables in parent} { + set cmd { + namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_hier1} + } + list [catch $cmd msg] $msg +} {1 {can't read "test_ns_var_hier1": no such variable}} + +test namespace-old-5.8 {nested namespaces don't see commands in parent} { + set cmd { + namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_hier1} + } + list [catch $cmd msg] $msg +} {1 {invalid command name "test_ns_cmd_hier1"}} + +test namespace-old-5.9 {usage for "namespace children"} { + list [catch {namespace children test_ns_hier1 y z} msg] $msg +} {1 {wrong # args: should be "namespace children ?name? ?pattern?"}} + +test namespace-old-5.10 {command "namespace children" must get valid namespace} { + list [catch {namespace children xyzzy} msg] $msg +} {1 {unknown namespace "xyzzy" in namespace children command}} + +test namespace-old-5.11 {querying namespace children} { + lsort [namespace children :: test_ns_hier*] +} {::test_ns_hier1} + +test namespace-old-5.12 {querying namespace children} { + lsort [namespace children test_ns_hier1] +} {::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2a ::test_ns_hier1::test_ns_hier2b} + +test namespace-old-5.13 {querying namespace children} { + lsort [namespace eval test_ns_hier1 {namespace children}] +} {::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2a ::test_ns_hier1::test_ns_hier2b} + +test namespace-old-5.14 {querying namespace children} { + lsort [namespace children test_ns_hier1::test_ns_hier2] +} {::test_ns_hier1::test_ns_hier2::test_ns_hier3a ::test_ns_hier1::test_ns_hier2::test_ns_hier3b} + +test namespace-old-5.15 {querying namespace children} { + lsort [namespace eval test_ns_hier1::test_ns_hier2 {namespace children}] +} {::test_ns_hier1::test_ns_hier2::test_ns_hier3a ::test_ns_hier1::test_ns_hier2::test_ns_hier3b} + +test namespace-old-5.16 {querying namespace children with patterns} { + lsort [namespace children test_ns_hier1::test_ns_hier2 test_ns_*] +} {::test_ns_hier1::test_ns_hier2::test_ns_hier3a ::test_ns_hier1::test_ns_hier2::test_ns_hier3b} + +test namespace-old-5.17 {querying namespace children with patterns} { + lsort [namespace children test_ns_hier1::test_ns_hier2 *b] +} {::test_ns_hier1::test_ns_hier2::test_ns_hier3b} + +test namespace-old-5.18 {usage for "namespace parent"} { + list [catch {namespace parent x y} msg] $msg +} {1 {wrong # args: should be "namespace parent ?name?"}} + +test namespace-old-5.19 {command "namespace parent" must get valid namespace} { + list [catch {namespace parent xyzzy} msg] $msg +} {1 {unknown namespace "xyzzy" in namespace parent command}} + +test namespace-old-5.20 {querying namespace parent} { + list [namespace eval :: {namespace parent}] \ + [namespace eval test_ns_hier1 {namespace parent}] \ + [namespace eval test_ns_hier1::test_ns_hier2 {namespace parent}] \ + [namespace eval test_ns_hier1::test_ns_hier2::test_ns_hier3a {namespace parent}] \ +} {{} :: ::test_ns_hier1 ::test_ns_hier1::test_ns_hier2} + +test namespace-old-5.21 {querying namespace parent for explicit namespace} { + list [namespace parent ::] \ + [namespace parent test_ns_hier1] \ + [namespace parent test_ns_hier1::test_ns_hier2] \ + [namespace parent test_ns_hier1::test_ns_hier2::test_ns_hier3a] +} {{} :: ::test_ns_hier1 ::test_ns_hier1::test_ns_hier2} + +# ----------------------------------------------------------------------- +# TEST: name resolution and caching +# ----------------------------------------------------------------------- +test namespace-old-6.1 {relative ns names only looked up in current ns} { + namespace eval test_ns_cache1 {} + namespace eval test_ns_cache2 {} + namespace eval test_ns_cache2::test_ns_cache3 {} + set trigger { + namespace eval test_ns_cache2 {namespace current} + } + set trigger2 { + namespace eval test_ns_cache2::test_ns_cache3 {namespace current} + } + list [namespace eval test_ns_cache1 $trigger] \ + [namespace eval test_ns_cache1 $trigger2] +} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} + +test namespace-old-6.2 {relative ns names only looked up in current ns} { + namespace eval test_ns_cache1::test_ns_cache2 {} + list [namespace eval test_ns_cache1 $trigger] \ + [namespace eval test_ns_cache1 $trigger2] +} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} + +test namespace-old-6.3 {relative ns names only looked up in current ns} { + namespace eval test_ns_cache1::test_ns_cache2::test_ns_cache3 {} + list [namespace eval test_ns_cache1 $trigger] \ + [namespace eval test_ns_cache1 $trigger2] +} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} + +test namespace-old-6.4 {relative ns names only looked up in current ns} { + namespace delete test_ns_cache1::test_ns_cache2 + list [namespace eval test_ns_cache1 $trigger] \ + [namespace eval test_ns_cache1 $trigger2] +} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} + +test namespace-old-6.5 {define test commands} { + proc test_ns_cache_cmd {} { + return "global version" + } + namespace eval test_ns_cache1 { + proc trigger {} { + test_ns_cache_cmd + } + } + test_ns_cache1::trigger +} {global version} + +test namespace-old-6.6 {one-level check for command shadowing} { + proc test_ns_cache1::test_ns_cache_cmd {} { + return "cache1 version" + } + test_ns_cache1::trigger +} {cache1 version} + +test namespace-old-6.7 {renaming commands changes command epoch} { + namespace eval test_ns_cache1 { + rename test_ns_cache_cmd test_ns_new + } + test_ns_cache1::trigger +} {global version} + +test namespace-old-6.8 {renaming back handles shadowing} { + namespace eval test_ns_cache1 { + rename test_ns_new test_ns_cache_cmd + } + test_ns_cache1::trigger +} {cache1 version} + +test namespace-old-6.9 {deleting commands changes command epoch} { + namespace eval test_ns_cache1 { + rename test_ns_cache_cmd "" + } + test_ns_cache1::trigger +} {global version} + +test namespace-old-6.10 {define test namespaces} { + namespace eval test_ns_cache2 { + proc test_ns_cache_cmd {} { + return "global cache2 version" + } + } + namespace eval test_ns_cache1 { + proc trigger {} { + test_ns_cache2::test_ns_cache_cmd + } + } + namespace eval test_ns_cache1::test_ns_cache2 { + proc trigger {} { + test_ns_cache_cmd + } + } + list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger] +} {{global cache2 version} {global version}} + +test namespace-old-6.11 {commands affect all parent namespaces} { + proc test_ns_cache1::test_ns_cache2::test_ns_cache_cmd {} { + return "cache2 version" + } + list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger] +} {{cache2 version} {cache2 version}} + +test namespace-old-6.12 {define test variables} { + variable test_ns_cache_var "global version" + set trigger {set test_ns_cache_var} + namespace eval test_ns_cache1 $trigger +} {global version} + +test namespace-old-6.13 {one-level check for variable shadowing} { + namespace eval test_ns_cache1 { + variable test_ns_cache_var "cache1 version" + } + namespace eval test_ns_cache1 $trigger +} {cache1 version} + +test namespace-old-6.14 {deleting variables changes variable epoch} { + namespace eval test_ns_cache1 { + unset test_ns_cache_var + } + namespace eval test_ns_cache1 $trigger +} {global version} + +test namespace-old-6.15 {define test namespaces} { + namespace eval test_ns_cache2 { + variable test_ns_cache_var "global cache2 version" + } + set trigger2 {set test_ns_cache2::test_ns_cache_var} + list [namespace eval test_ns_cache1 $trigger2] \ + [namespace eval test_ns_cache1::test_ns_cache2 $trigger] +} {{global cache2 version} {global version}} + +test namespace-old-6.16 {public variables affect all parent namespaces} { + variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version" + list [namespace eval test_ns_cache1 $trigger2] \ + [namespace eval test_ns_cache1::test_ns_cache2 $trigger] +} {{cache2 version} {cache2 version}} + +test namespace-old-6.17 {usage for "namespace which"} { + list [catch "namespace which -baz" msg] $msg +} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} +test namespace-old-6.18 {usage for "namespace which"} { + list [catch "namespace which -command" msg] $msg +} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} + +test namespace-old-6.19 {querying: namespace which -command} { + proc test_ns_cache1::test_ns_cache_cmd {} { + return "cache1 version" + } + list [namespace eval :: {namespace which test_ns_cache_cmd}] \ + [namespace eval test_ns_cache1 {namespace which test_ns_cache_cmd}] \ + [namespace eval :: {namespace which -command test_ns_cache_cmd}] \ + [namespace eval test_ns_cache1 {namespace which -command test_ns_cache_cmd}] +} {::test_ns_cache_cmd ::test_ns_cache1::test_ns_cache_cmd ::test_ns_cache_cmd ::test_ns_cache1::test_ns_cache_cmd} + +test namespace-old-6.20 {command "namespace which" may not find commands} { + namespace eval test_ns_cache1 {namespace which -command xyzzy} +} {} + +test namespace-old-6.21 {querying: namespace which -variable} { + namespace eval test_ns_cache1::test_ns_cache2 { + namespace which -variable test_ns_cache_var + } +} {::test_ns_cache1::test_ns_cache2::test_ns_cache_var} + +test namespace-old-6.22 {command "namespace which" may not find variables} { + namespace eval test_ns_cache1 {namespace which -variable xyzzy} +} {} + +# ----------------------------------------------------------------------- +# TEST: uplevel/upvar across namespace boundaries +# ----------------------------------------------------------------------- +test namespace-old-7.1 {define test namespace} { + namespace eval test_ns_uplevel { + variable x 0 + variable y 1 + + proc show_vars {num} { + return [uplevel $num {info vars}] + } + proc test_uplevel {num} { + set a 0 + set b 1 + namespace eval ::test_ns_uplevel " return \[show_vars $num\] " + } + } +} {} +test namespace-old-7.2 {uplevel can access namespace call frame} { + list [expr {[lsearch -exact [test_ns_uplevel::test_uplevel 1] x]>=0}] \ + [expr {[lsearch -exact [test_ns_uplevel::test_uplevel 1] y]>=0}] +} {1 1} +test namespace-old-7.3 {uplevel can go beyond namespace call frame} { + lsort [test_ns_uplevel::test_uplevel 2] +} {a b num} +test namespace-old-7.4 {uplevel can go up to global context} { + expr {[test_ns_uplevel::test_uplevel 3] == [info globals]} +} {1} + +test namespace-old-7.5 {absolute call frame references work too} { + list [expr {[lsearch -exact [test_ns_uplevel::test_uplevel #2] x]>=0}] \ + [expr {[lsearch -exact [test_ns_uplevel::test_uplevel #2] y]>=0}] +} {1 1} +test namespace-old-7.6 {absolute call frame references work too} { + lsort [test_ns_uplevel::test_uplevel #1] +} {a b num} +test namespace-old-7.7 {absolute call frame references work too} { + expr {[test_ns_uplevel::test_uplevel #0] == [info globals]} +} {1} + +test namespace-old-7.8 {namespaces are included in the call stack} { + namespace eval test_ns_upvar { + variable scope "test_ns_upvar" + + proc show_val {var num} { + upvar $num $var x + return $x + } + proc test_upvar {num} { + set scope "test_ns_upvar::test_upvar" + namespace eval ::test_ns_upvar " return \[show_val scope $num\] " + } + } +} {} +test namespace-old-7.9 {upvar can access namespace call frame} { + test_ns_upvar::test_upvar 1 +} {test_ns_upvar} +test namespace-old-7.10 {upvar can go beyond namespace call frame} { + test_ns_upvar::test_upvar 2 +} {test_ns_upvar::test_upvar} +test namespace-old-7.11 {absolute call frame references work too} { + test_ns_upvar::test_upvar #2 +} {test_ns_upvar} +test namespace-old-7.12 {absolute call frame references work too} { + test_ns_upvar::test_upvar #1 +} {test_ns_upvar::test_upvar} + +# ----------------------------------------------------------------------- +# TEST: variable traces across namespace boundaries +# ----------------------------------------------------------------------- +test namespace-old-8.1 {traces work across namespace boundaries} { + namespace eval test_ns_trace { + namespace eval foo { + variable x "" + } + + variable status "" + proc monitor {name1 name2 op} { + variable status + lappend status "$op: $name1" + } + trace variable foo::x rwu [namespace code monitor] + } + set test_ns_trace::foo::x "yes!" + set test_ns_trace::foo::x + unset test_ns_trace::foo::x + + namespace eval test_ns_trace { set status } +} {{w: test_ns_trace::foo::x} {r: test_ns_trace::foo::x} {u: test_ns_trace::foo::x}} + +# ----------------------------------------------------------------------- +# TEST: imported commands +# ----------------------------------------------------------------------- +test namespace-old-9.1 {empty "namespace export" list} { + list [catch "namespace export" msg] $msg +} {0 {}} +test namespace-old-9.2 {usage for "namespace export" command} { + list [catch "namespace export test_ns_trace::zzz" msg] $msg +} {1 {invalid export pattern "test_ns_trace::zzz": pattern can't specify a namespace}} + +test namespace-old-9.3 {define test namespaces for import} { + namespace eval test_ns_export { + namespace export cmd1 cmd2 cmd3 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + proc cmd5 {args} {return "cmd5: $args"} + proc cmd6 {args} {return "cmd6: $args"} + } + lsort [info commands test_ns_export::*] +} {::test_ns_export::cmd1 ::test_ns_export::cmd2 ::test_ns_export::cmd3 ::test_ns_export::cmd4 ::test_ns_export::cmd5 ::test_ns_export::cmd6} + +test namespace-old-9.4 {check export status} { + set x "" + namespace eval test_ns_import { + namespace export cmd1 cmd2 + namespace import ::test_ns_export::* + } + foreach cmd [lsort [info commands test_ns_import::*]] { + lappend x $cmd + } + set x +} {::test_ns_import::cmd1 ::test_ns_import::cmd2 ::test_ns_import::cmd3} + +test namespace-old-9.5 {empty import list in "namespace import" command} { + namespace import +} {} + +test namespace-old-9.6 {empty import list for "namespace import" command} { + namespace import +} {} + +test namespace-old-9.7 {empty forget list for "namespace forget" command} { + namespace forget +} {} + +catch {rename cmd1 {}} +catch {rename cmd2 {}} +catch {rename ncmd {}} +catch {rename ncmd1 {}} +catch {rename ncmd2 {}} +test namespace-old-9.8 {only exported commands are imported} { + namespace import test_ns_import::cmd* + set x [lsort [info commands cmd*]] +} {cmd1 cmd2} + +test namespace-old-9.9 {imported commands work just the same as original} { + list [cmd1 test 1 2 3] [test_ns_import::cmd1 test 4 5 6] +} {{cmd1: test 1 2 3} {cmd1: test 4 5 6}} + +test namespace-old-9.10 {commands can be imported from many namespaces} { + namespace eval test_ns_import2 { + namespace export ncmd ncmd1 ncmd2 + proc ncmd {args} {return "ncmd: $args"} + proc ncmd1 {args} {return "ncmd1: $args"} + proc ncmd2 {args} {return "ncmd2: $args"} + proc ncmd3 {args} {return "ncmd3: $args"} + } + namespace import test_ns_import2::* + lsort [concat [info commands cmd*] [info commands ncmd*]] +} {cmd1 cmd2 ncmd ncmd1 ncmd2} + +test namespace-old-9.11 {imported commands can be removed by deleting them} { + rename cmd1 "" + lsort [concat [info commands cmd*] [info commands ncmd*]] +} {cmd2 ncmd ncmd1 ncmd2} + +test namespace-old-9.12 {command "namespace forget" checks for valid namespaces} { + list [catch {namespace forget xyzzy::*} msg] $msg +} {1 {unknown namespace in namespace forget pattern "xyzzy::*"}} + +test namespace-old-9.13 {command "namespace forget" ignores patterns that don't match} { + list [catch {namespace forget test_ns_import::xy*zzy} msg] $msg \ + [lsort [info commands cmd?]] +} {0 {} cmd2} + +test namespace-old-9.14 {imported commands can be removed} { + namespace forget test_ns_import::cmd? + list [lsort [info commands cmd?]] \ + [catch {cmd1 another test} msg] $msg +} {{} 1 {invalid command name "cmd1"}} + +test namespace-old-9.15 {existing commands can't be overwritten} { + proc cmd1 {x y} { + return [expr $x+$y] + } + list [catch {namespace import test_ns_import::cmd?} msg] $msg \ + [cmd1 3 5] +} {1 {can't import command "cmd1": already exists} 8} + +test namespace-old-9.16 {use "-force" option to override existing commands} { + list [cmd1 3 5] \ + [namespace import -force test_ns_import::cmd?] \ + [cmd1 3 5] +} {8 {} {cmd1: 3 5}} + +test namespace-old-9.17 {commands can be imported into many namespaces} { + namespace eval test_ns_import_use { + namespace import ::test_ns_import::* ::test_ns_import2::ncmd? + lsort [concat [info commands ::test_ns_import_use::cmd*] \ + [info commands ::test_ns_import_use::ncmd*]] + } +} {::test_ns_import_use::cmd1 ::test_ns_import_use::cmd2 ::test_ns_import_use::ncmd1 ::test_ns_import_use::ncmd2} + +test namespace-old-9.18 {when command is deleted, imported commands go away} { + namespace eval test_ns_import { rename cmd1 "" } + list [info commands cmd1] \ + [namespace eval test_ns_import_use {info commands cmd1}] +} {{} {}} + +test namespace-old-9.19 {when namesp is deleted, all imported commands go away} { + namespace delete test_ns_import test_ns_import2 + list [info commands cmd*] \ + [info commands ncmd*] \ + [namespace eval test_ns_import_use {info commands cmd*}] \ + [namespace eval test_ns_import_use {info commands ncmd*}] \ +} {{} {} {} {}} + +# ----------------------------------------------------------------------- +# TEST: scoped values +# ----------------------------------------------------------------------- +test namespace-old-10.1 {define namespace for scope test} { + namespace eval test_ns_inscope { + variable x "x-value" + proc show {args} { + return "show: $args" + } + proc do {args} { + return [eval $args] + } + list [set x] [show test] + } +} {x-value {show: test}} + +test namespace-old-10.2 {command "namespace code" requires one argument} { + list [catch {namespace code} msg] $msg +} {1 {wrong # args: should be "namespace code arg"}} + +test namespace-old-10.3 {command "namespace code" requires one argument} { + list [catch {namespace code first "second arg" third} msg] $msg +} {1 {wrong # args: should be "namespace code arg"}} + +test namespace-old-10.4 {command "namespace code" gets current namesp context} { + namespace eval test_ns_inscope { + namespace code {"1 2 3" "4 5" 6} + } +} {namespace inscope ::test_ns_inscope {"1 2 3" "4 5" 6}} + +test namespace-old-10.5 {with one arg, first "scope" sticks} { + set sval [namespace eval test_ns_inscope {namespace code {one two}}] + namespace code $sval +} {namespace inscope ::test_ns_inscope {one two}} + +test namespace-old-10.6 {with many args, each "scope" adds new args} { + set sval [namespace eval test_ns_inscope {namespace code {one two}}] + namespace code "$sval three" +} {namespace inscope ::test_ns_inscope {one two} three} + +test namespace-old-10.7 {scoped commands work with eval} { + set cref [namespace eval test_ns_inscope {namespace code show}] + list [eval $cref "a" "b c" "d e f"] +} {{show: a b c d e f}} + +test namespace-old-10.8 {scoped commands execute in namespace context} { + set cref [namespace eval test_ns_inscope { + namespace code {set x "some new value"} + }] + list [set test_ns_inscope::x] [eval $cref] [set test_ns_inscope::x] +} {x-value {some new value} {some new value}} + +foreach cmd [info commands test_ns_*] { + rename $cmd "" +} +catch {rename cmd {}} +catch {rename cmd1 {}} +catch {rename cmd2 {}} +catch {rename ncmd {}} +catch {rename ncmd1 {}} +catch {rename ncmd2 {}} +catch {unset cref} +catch {unset trigger} +catch {unset trigger2} +catch {unset sval} +catch {unset msg} +catch {unset x} +catch {unset test_ns_var_global} +catch {unset cmd} +eval namespace delete [namespace children :: test_ns_*] diff --git a/tests/namespace.test b/tests/namespace.test new file mode 100644 index 0000000..e876391 --- /dev/null +++ b/tests/namespace.test @@ -0,0 +1,1080 @@ +# Functionality covered: this file contains a collection of tests for the +# procedures in tclNamesp.c that implement Tcl's basic support for +# namespaces. Other namespace-related tests appear in variable.test. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) namespace.test 1.15 97/07/30 15:26:42 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Clear out any namespaces called test_ns_* +catch {eval namespace delete [namespace children :: test_ns_*]} + +test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} { + namespace children :: test_ns_* +} {} + +catch {unset l} +test namespace-2.1 {Tcl_GetCurrentNamespace} { + list [namespace current] [namespace eval {} {namespace current}] \ + [namespace eval {} {namespace current}] +} {:: :: ::} +test namespace-2.2 {Tcl_GetCurrentNamespace} { + set l {} + lappend l [namespace current] + namespace eval test_ns_1 { + lappend l [namespace current] + namespace eval foo { + lappend l [namespace current] + } + } + lappend l [namespace current] + set l +} {:: ::test_ns_1 ::test_ns_1::foo ::} + +test namespace-3.1 {Tcl_GetGlobalNamespace} { + namespace eval test_ns_1 {namespace eval foo {namespace eval bar {} } } + # namespace children uses Tcl_GetGlobalNamespace + namespace eval test_ns_1 {namespace children foo b*} +} {::test_ns_1::foo::bar} + +test namespace-4.1 {Tcl_PushCallFrame with isProcCallFrame=1} { + namespace eval test_ns_1 { + variable v 123 + proc p {} { + variable v + return $v + } + } + test_ns_1::p ;# does Tcl_PushCallFrame to push p's namespace +} {123} +test namespace-4.2 {Tcl_PushCallFrame with isProcCallFrame=0} { + namespace eval test_ns_1::baz {} ;# does Tcl_PushCallFrame to create baz + proc test_ns_1::baz::p {} { + variable v + set v 789 + set v} + test_ns_1::baz::p +} {789} + +test namespace-5.1 {Tcl_PopCallFrame, no vars} { + namespace eval test_ns_1::blodge {} ;# pushes then pops frame +} {} +test namespace-5.2 {Tcl_PopCallFrame, local vars must be deleted} { + proc test_ns_1::r {} { + set a 123 + } + test_ns_1::r ;# pushes then pop's r's frame +} {123} + +test namespace-6.1 {Tcl_CreateNamespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [lsort [namespace children :: test_ns_*]] \ + [namespace eval test_ns_1 {namespace current}] \ + [namespace eval test_ns_2 {namespace current}] \ + [namespace eval ::test_ns_3 {namespace current}] \ + [namespace eval ::test_ns_4 \ + {namespace eval foo {namespace current}}] \ + [namespace eval ::test_ns_5 \ + {namespace eval ::test_ns_6 {namespace current}}] \ + [lsort [namespace children :: test_ns_*]] +} {{} ::test_ns_1 ::test_ns_2 ::test_ns_3 ::test_ns_4::foo ::test_ns_6 {::test_ns_1 ::test_ns_2 ::test_ns_3 ::test_ns_4 ::test_ns_5 ::test_ns_6}} +test namespace-6.2 {Tcl_CreateNamespace, odd number of :'s in name is okay} { + list [namespace eval :::test_ns_1::::foo {namespace current}] \ + [namespace eval test_ns_2:::::foo {namespace current}] +} {::test_ns_1::foo ::test_ns_2::foo} +test namespace-6.3 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} { + list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg +} {0 ::test_ns_7} +test namespace-6.4 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1:: { + namespace eval test_ns_2:: {} + namespace eval test_ns_3:: {} + } + namespace children ::test_ns_1 +} {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_3} +test namespace-6.5 {Tcl_CreateNamespace, relative ns names now only looked up in current ns} { + set trigger { + namespace eval test_ns_2 {namespace current} + } + set l {} + lappend l [namespace eval test_ns_1 $trigger] + namespace eval test_ns_1::test_ns_2 {} + lappend l [namespace eval test_ns_1 $trigger] +} {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_2} + +test namespace-7.1 {Tcl_DeleteNamespace, active call frames in ns} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc p {} { + namespace delete [namespace current] + return [namespace current] + } + } + list [test_ns_1::p] [catch {test_ns_1::p} msg] $msg +} {::test_ns_1 1 {invalid command name "test_ns_1::p"}} +test namespace-7.2 {Tcl_DeleteNamespace, no active call frames in ns} { + namespace eval test_ns_2 { + proc p {} { + return [namespace current] + } + } + list [test_ns_2::p] [namespace delete test_ns_2] +} {::test_ns_2 {}} + +test namespace-8.1 {TclTeardownNamespace, delete global namespace} { + catch {interp delete test_interp} + interp create test_interp + interp eval test_interp { + namespace eval test_ns_1 { + namespace export p + proc p {} { + return [namespace current] + } + } + namespace eval test_ns_2 { + namespace import ::test_ns_1::p + variable v 27 + proc q {} { + variable v + return "[p] $v" + } + } + set x [test_ns_2::q] + catch {set xxxx} + } + list [interp eval test_interp {test_ns_2::q}] \ + [interp eval test_interp {namespace delete ::}] \ + [catch {interp eval test_interp {set a 123}} msg] $msg \ + [interp delete test_interp] +} {{::test_ns_1 27} {} 1 {invalid command name "set"} {}} +test namespace-8.2 {TclTeardownNamespace, remove deleted ns from parent} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2::test_ns_3a {proc p {} {}} + namespace eval test_ns_1::test_ns_2::test_ns_3b {proc q {} {}} + list [namespace children test_ns_1] \ + [namespace delete test_ns_1::test_ns_2] \ + [namespace children test_ns_1] +} {::test_ns_1::test_ns_2 {} {}} +test namespace-8.3 {TclTeardownNamespace, delete child namespaces} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2::test_ns_3a {proc p {} {}} + namespace eval test_ns_1::test_ns_2::test_ns_3b {proc q {} {}} + list [namespace children test_ns_1] \ + [namespace delete test_ns_1::test_ns_2] \ + [namespace children test_ns_1] \ + [catch {namespace children test_ns_1::test_ns_2} msg] $msg \ + [info commands test_ns_1::test_ns_2::test_ns_3a::*] +} {::test_ns_1::test_ns_2 {} {} 1 {unknown namespace "test_ns_1::test_ns_2" in namespace children command} {}} +test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 cmd2 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_import { + namespace import ::test_ns_export::* + proc p {} {return foo} + } + list [info commands test_ns_import::*] \ + [namespace delete test_ns_export] \ + [info commands test_ns_import::*] +} {{::test_ns_import::p ::test_ns_import::cmd1 ::test_ns_import::cmd2} {} ::test_ns_import::p} + +test namespace-9.1 {Tcl_Import, empty import pattern} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace eval test_ns_import {namespace import {}}} msg] $msg +} {1 {empty import pattern}} +test namespace-9.2 {Tcl_Import, unknown namespace in import pattern} { + list [catch {namespace eval test_ns_import {namespace import fred::x}} msg] $msg +} {1 {unknown namespace in import pattern "fred::x"}} +test namespace-9.3 {Tcl_Import, import ns == export ns} { + list [catch {namespace eval test_ns_import {namespace import ::test_ns_import::puts}} msg] $msg +} {1 {import pattern "::test_ns_import::puts" tries to import from namespace "test_ns_import" into itself}} +test namespace-9.4 {Tcl_Import, simple import} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_import { + namespace import ::test_ns_export::* + proc p {} {return [cmd1 123]} + } + test_ns_import::p +} {cmd1: 123} +test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} { + list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg +} {1 {can't import command "cmd1": already exists}} +test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} { + namespace eval test_ns_import { + namespace import -force ::test_ns_export::* + cmd1 555 + } +} {cmd1: 555} + +test namespace-10.1 {Tcl_ForgetImport, check for valid namespaces} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace forget xyzzy::*} msg] $msg +} {1 {unknown namespace in namespace forget pattern "xyzzy::*"}} +test namespace-10.2 {Tcl_ForgetImport, ignores patterns that don't match} { + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_import { + namespace forget ::test_ns_export::wombat + } +} {} +test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} { + namespace eval test_ns_import { + namespace import ::test_ns_export::* + proc p {} {return [cmd1 123]} + set l {} + lappend l [info commands ::test_ns_import::*] + namespace forget ::test_ns_export::cmd1 + lappend l [info commands ::test_ns_import::*] + lappend l [catch {cmd1 777} msg] $msg + } +} {{::test_ns_import::p ::test_ns_import::cmd1} ::test_ns_import::p 1 {invalid command name "cmd1"}} + +test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + } + list [namespace origin set] [namespace origin test_ns_export::cmd1] +} {::set ::test_ns_export::cmd1} +test namespace-11.2 {TclGetOriginalCommand, directly imported cmd} { + namespace eval test_ns_import1 { + namespace import ::test_ns_export::* + namespace export * + proc p {} {namespace origin cmd1} + } + list [test_ns_import1::p] [namespace origin test_ns_import1::cmd1] +} {::test_ns_export::cmd1 ::test_ns_export::cmd1} +test namespace-11.3 {TclGetOriginalCommand, indirectly imported cmd} { + namespace eval test_ns_import2 { + namespace import ::test_ns_import1::* + proc q {} {return [cmd1 123]} + } + list [test_ns_import2::q] [namespace origin test_ns_import2::cmd1] +} {{cmd1: 123} ::test_ns_export::cmd1} + +test namespace-12.1 {InvokeImportedCmd} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {namespace current} + } + namespace eval test_ns_import { + namespace import ::test_ns_export::* + } + list [test_ns_import::cmd1] +} {::test_ns_export} + +test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} { + namespace eval test_ns_import { + set l {} + lappend l [info commands ::test_ns_import::*] + namespace forget ::test_ns_export::cmd1 + lappend l [info commands ::test_ns_import::*] + } +} {::test_ns_import::cmd1 {}} + +test namespace-14.1 {TclGetNamespaceForQualName, absolute names} { + catch {eval namespace delete [namespace children :: test_ns_*]} + variable v 10 + namespace eval test_ns_1::test_ns_2 { + variable v 20 + } + namespace eval test_ns_2 { + variable v 30 + } + namespace eval test_ns_1 { + list $::v $::test_ns_2::v $::test_ns_1::test_ns_2::v \ + [namespace children :: test_ns_*] + } +} {10 30 20 {::test_ns_1 ::test_ns_2}} +test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} { + namespace eval test_ns_1 { + list [catch {set ::test_ns_777::v} msg] $msg \ + [catch {namespace children test_ns_777} msg] $msg + } +} {1 {can't read "::test_ns_777::v": no such variable} 1 {unknown namespace "test_ns_777" in namespace children command}} +test namespace-14.3 {TclGetNamespaceForQualName, relative names} { + namespace eval test_ns_1 { + list $v $test_ns_2::v + } +} {10 20} +test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { + namespace eval test_ns_1::test_ns_2 { + namespace eval foo {} + } + namespace eval test_ns_1 { + list [namespace children test_ns_2] \ + [catch {namespace children test_ns_1} msg] $msg + } +} {::test_ns_1::test_ns_2::foo 1 {unknown namespace "test_ns_1" in namespace children command}} +test namespace-14.5 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { + namespace eval ::test_ns_2 { + namespace eval bar {} + } + namespace eval test_ns_1 { + set l [list [catch {namespace delete test_ns_2::bar} msg] $msg] + } + set l +} {1 {unknown namespace "test_ns_2::bar" in namespace delete command}} +test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { + namespace eval test_ns_1::test_ns_2 { + namespace eval foo {} + } + namespace eval test_ns_1 { + list [namespace children test_ns_2] \ + [catch {namespace children test_ns_1} msg] $msg + } +} {::test_ns_1::test_ns_2::foo 1 {unknown namespace "test_ns_1" in namespace children command}} +test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} { + namespace children test_ns_1::: +} {::test_ns_1::test_ns_2} +test namespace-14.8 {TclGetNamespaceForQualName, ignore extra :s if ns} { + namespace children :::test_ns_1:::::test_ns_2::: +} {::test_ns_1::test_ns_2::foo} +test namespace-14.9 {TclGetNamespaceForQualName, extra ::s are significant for vars} { + set l {} + lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg + namespace eval test_ns_1::test_ns_2 {variable {} 2525} + lappend l [set test_ns_1::test_ns_2::] +} {1 {can't read "test_ns_1::test_ns_2::": no such variable} 2525} +test namespace-14.10 {TclGetNamespaceForQualName, extra ::s are significant for vars} { + catch {unset test_ns_1::test_ns_2::} + set l {} + lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg + set test_ns_1::test_ns_2:: 314159 + lappend l [set test_ns_1::test_ns_2::] +} {1 {can't read "test_ns_1::test_ns_2::": no such variable} 314159} +test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for commands} { + catch {rename test_ns_1::test_ns_2:: {}} + set l {} + lappend l [catch {test_ns_1::test_ns_2:: hello} msg] $msg + proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"} + lappend l [test_ns_1::test_ns_2:: hello] +} {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} +test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 { + variable {} + set test_ns_1::(x) y + } + set test_ns_1::(x) +} y +test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace eval test_ns_1 {proc {} {} {}; namespace eval {} {}; {}}} msg] $msg +} {1 {can't create namespace "": only global namespace can have empty name}} + +test namespace-15.1 {Tcl_FindNamespace, absolute name found} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_delete { + namespace eval test_ns_delete2 {} + proc cmd {args} {namespace current} + } + list [namespace delete ::test_ns_delete::test_ns_delete2] \ + [namespace children ::test_ns_delete] +} {{} {}} +test namespace-15.2 {Tcl_FindNamespace, absolute name not found} { + list [catch {namespace delete ::test_ns_delete::test_ns_delete2} msg] $msg +} {1 {unknown namespace "::test_ns_delete::test_ns_delete2" in namespace delete command}} +test namespace-15.3 {Tcl_FindNamespace, relative name found} { + namespace eval test_ns_delete { + namespace eval test_ns_delete2 {} + namespace eval test_ns_delete3 {} + list [namespace delete test_ns_delete2] \ + [namespace children [namespace current]] + } +} {{} ::test_ns_delete::test_ns_delete3} +test namespace-15.4 {Tcl_FindNamespace, relative name not found} { + namespace eval test_ns_delete2 {} + namespace eval test_ns_delete { + list [catch {namespace delete test_ns_delete2} msg] $msg + } +} {1 {unknown namespace "test_ns_delete2" in namespace delete command}} + +test namespace-16.1 {Tcl_FindCommand, absolute name found} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc cmd {args} {return "[namespace current]::cmd: $args"} + variable v "::test_ns_1::cmd" + eval $v one + } +} {::test_ns_1::cmd: one} +test namespace-16.2 {Tcl_FindCommand, absolute name found} { + eval $test_ns_1::v two +} {::test_ns_1::cmd: two} +test namespace-16.3 {Tcl_FindCommand, absolute name not found} { + namespace eval test_ns_1 { + variable v2 "::test_ns_1::ladidah" + list [catch {eval $v2} msg] $msg + } +} {1 {invalid command name "::test_ns_1::ladidah"}} + +# save the "unknown" proc, which is redefined by the following two tests +catch {rename unknown unknown.old} +proc unknown {args} { + return "unknown: $args" +} +test namespace-16.4 {Tcl_FindCommand, absolute name and TCL_GLOBAL_ONLY} { + ::test_ns_1::foobar x y z +} {unknown: ::test_ns_1::foobar x y z} +test namespace-16.5 {Tcl_FindCommand, absolute name and TCL_GLOBAL_ONLY} { + ::foobar 1 2 3 4 5 +} {unknown: ::foobar 1 2 3 4 5} +test namespace-16.6 {Tcl_FindCommand, relative name and TCL_GLOBAL_ONLY} { + test_ns_1::foobar x y z +} {unknown: test_ns_1::foobar x y z} +test namespace-16.7 {Tcl_FindCommand, relative name and TCL_GLOBAL_ONLY} { + foobar 1 2 3 4 5 +} {unknown: foobar 1 2 3 4 5} +# restore the "unknown" proc saved previously +catch {rename unknown {}} +catch {rename unknown.old unknown} + +test namespace-16.8 {Tcl_FindCommand, relative name found} { + namespace eval test_ns_1 { + cmd a b c + } +} {::test_ns_1::cmd: a b c} +test namespace-16.9 {Tcl_FindCommand, relative name found} { + catch {rename cmd2 {}} + proc cmd2 {args} {return "[namespace current]::cmd2: $args"} + namespace eval test_ns_1 { + cmd2 a b c + } +} {::::cmd2: a b c} +test namespace-16.10 {Tcl_FindCommand, relative name found, only look in current then global ns} { + namespace eval test_ns_1 { + proc cmd2 {args} { + return "[namespace current]::cmd2 in test_ns_1: $args" + } + namespace eval test_ns_12 { + cmd2 a b c + } + } +} {::::cmd2: a b c} +test namespace-16.11 {Tcl_FindCommand, relative name not found} { + namespace eval test_ns_1 { + list [catch {cmd3 a b c} msg] $msg + } +} {1 {invalid command name "cmd3"}} + +catch {unset x} +test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} { + catch {eval namespace delete [namespace children :: test_ns_*]} + set x 314159 + namespace eval test_ns_1 { + set ::x + } +} {314159} +test namespace-17.2 {Tcl_FindNamespaceVar, absolute name found} { + namespace eval test_ns_1 { + variable x 777 + set ::test_ns_1::x + } +} {777} +test namespace-17.3 {Tcl_FindNamespaceVar, absolute name found} { + namespace eval test_ns_1 { + namespace eval test_ns_2 { + variable x 1111 + } + set ::test_ns_1::test_ns_2::x + } +} {1111} +test namespace-17.4 {Tcl_FindNamespaceVar, absolute name not found} { + namespace eval test_ns_1 { + namespace eval test_ns_2 { + variable x 1111 + } + list [catch {set ::test_ns_1::test_ns_2::y} msg] $msg + } +} {1 {can't read "::test_ns_1::test_ns_2::y": no such variable}} +test namespace-17.5 {Tcl_FindNamespaceVar, absolute name and TCL_GLOBAL_ONLY} { + namespace eval test_ns_1 { + namespace eval test_ns_3 { + variable ::test_ns_1::test_ns_2::x 2222 + } + } + set ::test_ns_1::test_ns_2::x +} {2222} +test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} { + namespace eval test_ns_1 { + set x + } +} {777} +test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} { + namespace eval test_ns_1 { + unset x + set x ;# must be global x now + } +} {314159} +test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} { + namespace eval test_ns_1 { + list [catch {set wuzzat} msg] $msg + } +} {1 {can't read "wuzzat": no such variable}} +test namespace-17.9 {Tcl_FindNamespaceVar, relative name and TCL_GLOBAL_ONLY} { + namespace eval test_ns_1 { + variable a hello + } + set test_ns_1::a +} {hello} +catch {unset x} + +catch {unset l} +catch {rename foo {}} +test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} { + catch {eval namespace delete [namespace children :: test_ns_*]} + proc foo {} {return "global foo"} + namespace eval test_ns_1 { + proc trigger {} { + return [foo] + } + } + set l "" + lappend l [test_ns_1::trigger] + namespace eval test_ns_1 { + # force invalidation of cached ref to "foo" in proc trigger + proc foo {} {return "foo in test_ns_1"} + } + lappend l [test_ns_1::trigger] + set l +} {{global foo} {foo in test_ns_1}} +test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shadowing} { + namespace eval test_ns_2 { + proc foo {} {return "foo in ::test_ns_2"} + } + namespace eval test_ns_1 { + namespace eval test_ns_2 {} + proc trigger {} { + return [test_ns_2::foo] + } + } + set l "" + lappend l [test_ns_1::trigger] + namespace eval test_ns_1 { + namespace eval test_ns_2 { + # force invalidation of cached ref to "foo" in proc trigger + proc foo {} {return "foo in ::test_ns_1::test_ns_2"} + } + } + lappend l [test_ns_1::trigger] + set l +} {{foo in ::test_ns_2} {foo in ::test_ns_1::test_ns_2}} +catch {unset l} +catch {rename foo {}} + +test namespace-19.1 {GetNamespaceFromObj, global name found} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} + namespace children ::test_ns_1 +} {::test_ns_1::test_ns_2} +test namespace-19.2 {GetNamespaceFromObj, relative name found} { + namespace eval test_ns_1 { + namespace children test_ns_2 + } +} {} +test namespace-19.3 {GetNamespaceFromObj, name not found} { + namespace eval test_ns_1 { + list [catch {namespace children test_ns_99} msg] $msg + } +} {1 {unknown namespace "test_ns_99" in namespace children command}} +test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { + namespace eval test_ns_1 { + proc foo {} { + return [namespace children test_ns_2] + } + list [catch {namespace children test_ns_99} msg] $msg + } + set l {} + lappend l [test_ns_1::foo] + namespace delete test_ns_1::test_ns_2 + namespace eval test_ns_1::test_ns_2::test_ns_3 {} + lappend l [test_ns_1::foo] + set l +} {{} ::test_ns_1::test_ns_2::test_ns_3} + +test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace} msg] $msg +} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}} +test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} { + list [catch {namespace wombat {}} msg] $msg +} {1 {bad option "wombat": must be children, code, current, delete, eval, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}} +test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} { + namespace ch :: test_ns_* +} {} + +test namespace-21.1 {NamespaceChildrenCmd, no args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} + expr {[string first ::test_ns_1 [namespace children]] != -1} +} {1} +test namespace-21.2 {NamespaceChildrenCmd, no args} { + namespace eval test_ns_1 { + namespace children + } +} {::test_ns_1::test_ns_2} +test namespace-21.3 {NamespaceChildrenCmd, ns name given} { + namespace children ::test_ns_1 +} {::test_ns_1::test_ns_2} +test namespace-21.4 {NamespaceChildrenCmd, ns name given} { + namespace eval test_ns_1 { + namespace children test_ns_2 + } +} {} +test namespace-21.5 {NamespaceChildrenCmd, too many args} { + namespace eval test_ns_1 { + list [catch {namespace children test_ns_2 xxx yyy} msg] $msg + } +} {1 {wrong # args: should be "namespace children ?name? ?pattern?"}} +test namespace-21.6 {NamespaceChildrenCmd, glob-style pattern given} { + namespace eval test_ns_1::test_ns_foo {} + namespace children test_ns_1 *f* +} {::test_ns_1::test_ns_foo} +test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} { + namespace eval test_ns_1::test_ns_foo {} + namespace children test_ns_1 test* +} {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo} + +test namespace-22.1 {NamespaceCodeCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace code} msg] $msg \ + [catch {namespace code xxx yyy} msg] $msg +} {1 {wrong # args: should be "namespace code arg"} 1 {wrong # args: should be "namespace code arg"}} +test namespace-22.2 {NamespaceCodeCmd, arg is already scoped value} { + namespace eval test_ns_1 { + proc cmd {} {return "test_ns_1::cmd"} + } + namespace code {namespace inscope ::test_ns_1 cmd} +} {namespace inscope ::test_ns_1 cmd} +test namespace-22.3 {NamespaceCodeCmd, arg is already scoped value} { + namespace code {namespace inscope ::test_ns_1 cmd} +} {namespace inscope ::test_ns_1 cmd} +test namespace-22.4 {NamespaceCodeCmd, in :: namespace} { + namespace code unknown +} {namespace inscope :: unknown} +test namespace-22.5 {NamespaceCodeCmd, in other namespace} { + namespace eval test_ns_1 { + namespace code cmd + } +} {namespace inscope ::test_ns_1 cmd} + +test namespace-23.1 {NamespaceCurrentCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace current xxx} msg] $msg \ + [catch {namespace current xxx yyy} msg] $msg +} {1 {wrong # args: should be "namespace current"} 1 {wrong # args: should be "namespace current"}} +test namespace-23.2 {NamespaceCurrentCmd, at global level} { + namespace current +} {::} +test namespace-23.3 {NamespaceCurrentCmd, in nested ns} { + namespace eval test_ns_1::test_ns_2 { + namespace current + } +} {::test_ns_1::test_ns_2} + +test namespace-24.1 {NamespaceDeleteCmd, no args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace delete +} {} +test namespace-24.2 {NamespaceDeleteCmd, one arg} { + namespace eval test_ns_1::test_ns_2 {} + namespace delete ::test_ns_1 +} {} +test namespace-24.3 {NamespaceDeleteCmd, two args} { + namespace eval test_ns_1::test_ns_2 {} + list [namespace delete ::test_ns_1::test_ns_2] [namespace delete ::test_ns_1] +} {{} {}} +test namespace-24.4 {NamespaceDeleteCmd, unknown ns} { + list [catch {namespace delete ::test_ns_foo} msg] $msg +} {1 {unknown namespace "::test_ns_foo" in namespace delete command}} + +test namespace-25.1 {NamespaceEvalCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace eval} msg] $msg +} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}} +test namespace-25.2 {NamespaceEvalCmd, bad args} { + list [catch {namespace test_ns_1} msg] $msg +} {1 {bad option "test_ns_1": must be children, code, current, delete, eval, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}} +catch {unset v} +test namespace-25.3 {NamespaceEvalCmd, new namespace} { + set v 123 + namespace eval test_ns_1 { + variable v 314159 + proc p {} { + variable v + return $v + } + } + test_ns_1::p +} {314159} +test namespace-25.4 {NamespaceEvalCmd, existing namespace} { + namespace eval test_ns_1 { + proc q {} {return [expr {[p]+1}]} + } + test_ns_1::q +} {314160} +test namespace-25.5 {NamespaceEvalCmd, multiple args} { + namespace eval test_ns_1 "set" "v" +} {314159} +test namespace-25.6 {NamespaceEvalCmd, error in eval'd script} { + list [catch {namespace eval test_ns_1 {xxxx}} msg] $msg $errorInfo +} {1 {invalid command name "xxxx"} {invalid command name "xxxx" + while executing +"xxxx" + (in namespace eval "::test_ns_1" script line 1) + invoked from within +"namespace eval test_ns_1 {xxxx}"}} +catch {unset v} + +test namespace-26.1 {NamespaceExportCmd, no args and new ns} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace export +} {} +test namespace-26.2 {NamespaceExportCmd, just -clear arg} { + namespace export -clear +} {} +test namespace-26.3 {NamespaceExportCmd, pattern can't specify a namespace} { + namespace eval test_ns_1 { + list [catch {namespace export ::zzz} msg] $msg + } +} {1 {invalid export pattern "::zzz": pattern can't specify a namespace}} +test namespace-26.4 {NamespaceExportCmd, one pattern} { + namespace eval test_ns_1 { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + } + namespace eval test_ns_2 { + namespace import ::test_ns_1::* + } + list [info commands test_ns_2::*] [test_ns_2::cmd1 hello] +} {::test_ns_2::cmd1 {cmd1: hello}} +test namespace-26.5 {NamespaceExportCmd, sequence of patterns, patterns accumulate} { + namespace eval test_ns_1 { + namespace export cmd1 cmd3 + } + namespace eval test_ns_2 { + namespace import -force ::test_ns_1::* + } + list [info commands test_ns_2::*] [test_ns_2::cmd3 hello] +} {{::test_ns_2::cmd1 ::test_ns_2::cmd3} {cmd3: hello}} +test namespace-26.6 {NamespaceExportCmd, no patterns means return export list} { + namespace eval test_ns_1 { + namespace export + } +} {cmd1 cmd1 cmd3} +test namespace-26.7 {NamespaceExportCmd, -clear resets export list} { + namespace eval test_ns_1 { + namespace export -clear cmd4 + } + namespace eval test_ns_2 { + namespace import ::test_ns_1::* + } + list [info commands test_ns_2::*] [test_ns_2::cmd4 hello] +} {{::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3} {cmd4: hello}} + +test namespace-27.1 {NamespaceForgetCmd, no args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace forget +} {} +test namespace-27.2 {NamespaceForgetCmd, args must be valid namespaces} { + list [catch {namespace forget ::test_ns_1::xxx} msg] $msg +} {1 {unknown namespace in namespace forget pattern "::test_ns_1::xxx"}} +test namespace-27.3 {NamespaceForgetCmd, arg is forgotten} { + namespace eval test_ns_1 { + namespace export cmd* + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace import ::test_ns_1::* + namespace forget ::test_ns_1::cmd1 + } + info commands ::test_ns_2::* +} {::test_ns_2::cmd2} + +test namespace-28.1 {NamespaceImportCmd, no args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace import +} {} +test namespace-28.2 {NamespaceImportCmd, no args and just "-force"} { + namespace import -force +} {} +test namespace-28.3 {NamespaceImportCmd, arg is imported} { + namespace eval test_ns_1 { + namespace export cmd2 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace import ::test_ns_1::* + namespace forget ::test_ns_1::cmd1 + } + info commands test_ns_2::* +} {::test_ns_2::cmd2} + +test namespace-29.1 {NamespaceInscopeCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace inscope} msg] $msg +} {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}} +test namespace-29.2 {NamespaceInscopeCmd, bad args} { + list [catch {namespace inscope ::} msg] $msg +} {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}} +test namespace-29.3 {NamespaceInscopeCmd, specified ns must exist} { + list [catch {namespace inscope test_ns_1 {set v}} msg] $msg +} {1 {unknown namespace "test_ns_1" in inscope namespace command}} +test namespace-29.4 {NamespaceInscopeCmd, simple case} { + namespace eval test_ns_1 { + variable v 747 + proc cmd {args} { + variable v + return "[namespace current]::cmd: v=$v, args=$args" + } + } + namespace inscope test_ns_1 cmd +} {::test_ns_1::cmd: v=747, args=} +test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} { + list [namespace inscope test_ns_1 cmd x y z] \ + [namespace eval test_ns_1 [concat cmd [list x y z]]] +} {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}} + +test namespace-30.1 {NamespaceOriginCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace origin} msg] $msg +} {1 {wrong # args: should be "namespace origin name"}} +test namespace-30.2 {NamespaceOriginCmd, bad args} { + list [catch {namespace origin x y} msg] $msg +} {1 {wrong # args: should be "namespace origin name"}} +test namespace-30.3 {NamespaceOriginCmd, command not found} { + list [catch {namespace origin fred} msg] $msg +} {1 {invalid command name "fred"}} +test namespace-30.4 {NamespaceOriginCmd, command isn't imported} { + namespace origin set +} {::set} +test namespace-30.5 {NamespaceOriginCmd, imported command} { + namespace eval test_ns_1 { + namespace export cmd* + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace export * + namespace import ::test_ns_1::* + proc p {} {} + } + namespace eval test_ns_3 { + namespace import ::test_ns_2::* + list [namespace origin foreach] \ + [namespace origin p] \ + [namespace origin cmd1] \ + [namespace origin ::test_ns_2::cmd2] + } +} {::foreach ::test_ns_2::p ::test_ns_1::cmd1 ::test_ns_1::cmd2} + +test namespace-31.1 {NamespaceParentCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace parent a b} msg] $msg +} {1 {wrong # args: should be "namespace parent ?name?"}} +test namespace-31.2 {NamespaceParentCmd, no args} { + namespace parent +} {} +test namespace-31.3 {NamespaceParentCmd, namespace specified} { + namespace eval test_ns_1 { + namespace eval test_ns_2 { + namespace eval test_ns_3 {} + } + } + list [namespace parent ::] \ + [namespace parent test_ns_1::test_ns_2] \ + [namespace eval test_ns_1::test_ns_2::test_ns_3 {namespace parent ::test_ns_1::test_ns_2}] +} {{} ::test_ns_1 ::test_ns_1} +test namespace-31.4 {NamespaceParentCmd, bad namespace specified} { + list [catch {namespace parent test_ns_1::test_ns_foo} msg] $msg +} {1 {unknown namespace "test_ns_1::test_ns_foo" in namespace parent command}} + +test namespace-32.1 {NamespaceQualifiersCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace qualifiers} msg] $msg +} {1 {wrong # args: should be "namespace qualifiers string"}} +test namespace-32.2 {NamespaceQualifiersCmd, bad args} { + list [catch {namespace qualifiers x y} msg] $msg +} {1 {wrong # args: should be "namespace qualifiers string"}} +test namespace-32.3 {NamespaceQualifiersCmd, simple name} { + namespace qualifiers foo +} {} +test namespace-32.4 {NamespaceQualifiersCmd, leading ::} { + namespace qualifiers ::x::y::z +} {::x::y} +test namespace-32.5 {NamespaceQualifiersCmd, no leading ::} { + namespace qualifiers a::b +} {a} +test namespace-32.6 {NamespaceQualifiersCmd, :: argument} { + namespace qualifiers :: +} {} +test namespace-32.7 {NamespaceQualifiersCmd, odd number of :s} { + namespace qualifiers ::::: +} {} +test namespace-32.8 {NamespaceQualifiersCmd, odd number of :s} { + namespace qualifiers foo::: +} {foo} + +test namespace-33.1 {NamespaceTailCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace tail} msg] $msg +} {1 {wrong # args: should be "namespace tail string"}} +test namespace-33.2 {NamespaceTailCmd, bad args} { + list [catch {namespace tail x y} msg] $msg +} {1 {wrong # args: should be "namespace tail string"}} +test namespace-33.3 {NamespaceTailCmd, simple name} { + namespace tail foo +} {foo} +test namespace-33.4 {NamespaceTailCmd, leading ::} { + namespace tail ::x::y::z +} {z} +test namespace-33.5 {NamespaceTailCmd, no leading ::} { + namespace tail a::b +} {b} +test namespace-33.6 {NamespaceTailCmd, :: argument} { + namespace tail :: +} {} +test namespace-33.7 {NamespaceTailCmd, odd number of :s} { + namespace tail ::::: +} {} +test namespace-33.8 {NamespaceTailCmd, odd number of :s} { + namespace tail foo::: +} {} + +test namespace-34.1 {NamespaceWhichCmd, bad args} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {namespace which} msg] $msg +} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} +test namespace-34.2 {NamespaceWhichCmd, bad args} { + list [catch {namespace which -fred} msg] $msg +} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} +test namespace-34.3 {NamespaceWhichCmd, bad args} { + list [catch {namespace which -command} msg] $msg +} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} +test namespace-34.4 {NamespaceWhichCmd, bad args} { + list [catch {namespace which a b} msg] $msg +} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} +test namespace-34.5 {NamespaceWhichCmd, command lookup} { + namespace eval test_ns_1 { + namespace export cmd* + variable v1 111 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace export * + namespace import ::test_ns_1::* + variable v2 222 + proc p {} {} + } + namespace eval test_ns_3 { + namespace import ::test_ns_2::* + variable v3 333 + list [namespace which -command foreach] \ + [namespace which -command p] \ + [namespace which -command cmd1] \ + [namespace which -command ::test_ns_2::cmd2] \ + [catch {namespace which -command ::test_ns_2::noSuchCmd} msg] $msg + } +} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2 0 {}} +test namespace-34.6 {NamespaceWhichCmd, -command is default} { + namespace eval test_ns_3 { + list [namespace which foreach] \ + [namespace which p] \ + [namespace which cmd1] \ + [namespace which ::test_ns_2::cmd2] + } +} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2} +test namespace-34.7 {NamespaceWhichCmd, variable lookup} { + namespace eval test_ns_3 { + list [namespace which -variable env] \ + [namespace which -variable v3] \ + [namespace which -variable ::test_ns_2::v2] \ + [catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg + } +} {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} + +test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc p {} { + namespace delete [namespace current] + return [namespace current] + } + } + test_ns_1::p +} {::test_ns_1} +test namespace-35.2 {FreeNsNameInternalRep, resulting ref count == 0} { + namespace eval test_ns_1 { + proc q {} { + return [namespace current] + } + } + list [test_ns_1::q] \ + [namespace delete test_ns_1] \ + [catch {test_ns_1::q} msg] $msg +} {::test_ns_1 {} 1 {invalid command name "test_ns_1::q"}} + +catch {unset x} +catch {unset y} +test namespace-36.1 {DupNsNameInternalRep} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 {} + set x "::test_ns_1" + list [namespace parent $x] [set y $x] [namespace parent $y] +} {:: ::test_ns_1 ::} +catch {unset x} +catch {unset y} + +test namespace-37.1 {SetNsNameFromAny, ns name found} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} + namespace eval test_ns_1 { + namespace children ::test_ns_1 + } +} {::test_ns_1::test_ns_2} +test namespace-37.2 {SetNsNameFromAny, ns name not found} { + namespace eval test_ns_1 { + list [catch {namespace children ::test_ns_1::test_ns_foo} msg] $msg + } +} {1 {unknown namespace "::test_ns_1::test_ns_foo" in namespace children command}} + +test namespace-38.1 {UpdateStringOfNsName} { + catch {eval namespace delete [namespace children :: test_ns_*]} + ;# Tcl_NamespaceObjCmd calls UpdateStringOfNsName to get subcmd name + list [namespace eval {} {namespace current}] \ + [namespace eval {} {namespace current}] +} {:: ::} + +catch {rename cmd1 {}} +catch {unset l} +catch {unset msg} +catch {unset trigger} +eval namespace delete [namespace children :: test_ns_*] diff --git a/tests/obj.test b/tests/obj.test new file mode 100644 index 0000000..08f230b --- /dev/null +++ b/tests/obj.test @@ -0,0 +1,496 @@ +# Functionality covered: this file contains a collection of tests for the +# procedures in tclObj.c that implement Tcl's basic type support and the +# type managers for the types boolean, double, and integer. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# @(#) obj.test 1.12 97/10/31 17:23:23 + +if {[info commands testobj] == {}} { + puts "This application hasn't been compiled with the \"testobj\"" + puts "command, so I can't test the Tcl type and object support." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} { + set r 1 + foreach {t} {list boolean cmdName bytecode string int double} { + set first [string first $t [testobj types]] + set r [expr {$r && ($first != -1)}] + } + set result $r +} {1} + +test obj-2.1 {Tcl_GetObjType error} { + list [testintobj set 1 0] [catch {testobj convert 1 foo} msg] $msg +} {0 1 {no type foo found}} +test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} { + set result "" + lappend result [testobj freeallvars] + lappend result [testintobj set 1 12] + lappend result [testobj convert 1 double] + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 12 12 double 3} + +test obj-3.1 {Tcl_ConvertToType error} { + list [testdoubleobj set 1 12.34] [catch {testobj convert 1 int} msg] $msg +} {12.34 1 {expected integer but got "12.34"}} +test obj-3.2 {Tcl_ConvertToType error, "empty string" object} { + list [testobj newobj 1] [catch {testobj convert 1 int} msg] $msg +} {{} 1 {expected integer but got ""}} + +test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} { + set result "" + lappend result [testobj freeallvars] + lappend result [testobj newobj 1] + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} {} string 2} + +test obj-5.1 {Tcl_FreeObj} { + set result "" + lappend result [testintobj set 1 12345] + lappend result [testobj freeallvars] + lappend result [catch {testintobj get 1} msg] + lappend result $msg +} {12345 {} 1 {variable 1 is unset (NULL)}} + +test obj-6.1 {Tcl_DuplicateObj, object has internal rep} { + set result "" + lappend result [testobj freeallvars] + lappend result [testintobj set 1 47] + lappend result [testobj duplicate 1 2] + lappend result [testintobj get 2] + lappend result [testobj refcount 1] + lappend result [testobj refcount 2] +} {{} 47 47 47 2 3} +test obj-6.2 {Tcl_DuplicateObj, "empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testobj newobj 1] + lappend result [testobj duplicate 1 2] + lappend result [testintobj get 2] + lappend result [testobj refcount 1] + lappend result [testobj refcount 2] +} {{} {} {} {} 2 3} + +test obj-7.1 {Tcl_GetStringFromObj, return existing string rep} { + set result "" + lappend result [testintobj set 1 47] + lappend result [testintobj get 1] +} {47 47} +test obj-7.2 {Tcl_GetStringFromObj, "empty string" object} { + set result "" + lappend result [testobj newobj 1] + lappend result [teststringobj append 1 abc -1] + lappend result [teststringobj get 1] +} {{} abc abc} +test obj-7.3 {Tcl_GetStringFromObj, returns string internal rep (DString)} { + set result "" + lappend result [teststringobj set 1 xyz] + lappend result [teststringobj append 1 abc -1] + lappend result [teststringobj get 1] +} {xyz xyzabc xyzabc} +test obj-7.4 {Tcl_GetStringFromObj, recompute string rep from internal rep} { + set result "" + lappend result [testintobj set 1 77] + lappend result [testintobj mult10 1] + lappend result [teststringobj get 1] +} {77 770 770} + +test obj-8.1 {Tcl_NewBooleanObj} { + set result "" + lappend result [testobj freeallvars] + lappend result [testbooleanobj set 1 0] + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 0 boolean 2} + +test obj-9.1 {Tcl_SetBooleanObj, existing "empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testobj newobj 1] + lappend result [testbooleanobj set 1 0] ;# makes existing obj boolean + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} {} 0 boolean 2} +test obj-9.2 {Tcl_SetBooleanObj, existing non-"empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testintobj set 1 98765] + lappend result [testbooleanobj set 1 1] ;# makes existing obj boolean + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 98765 1 boolean 2} + +test obj-10.1 {Tcl_GetBooleanFromObj, existing boolean object} { + set result "" + lappend result [testbooleanobj set 1 1] + lappend result [testbooleanobj not 1] ;# gets existing boolean rep +} {1 0} +test obj-10.2 {Tcl_GetBooleanFromObj, convert to boolean} { + set result "" + lappend result [testintobj set 1 47] + lappend result [testbooleanobj not 1] ;# must convert to bool + lappend result [testobj type 1] +} {47 0 boolean} +test obj-10.3 {Tcl_GetBooleanFromObj, error converting to boolean} { + set result "" + lappend result [teststringobj set 1 abc] + lappend result [catch {testbooleanobj not 1} msg] + lappend result $msg +} {abc 1 {expected boolean value but got "abc"}} +test obj-10.4 {Tcl_GetBooleanFromObj, error converting from "empty string"} { + set result "" + lappend result [testobj newobj 1] + lappend result [catch {testbooleanobj not 1} msg] + lappend result $msg +} {{} 1 {expected boolean value but got ""}} + +test obj-11.1 {DupBooleanInternalRep} { + set result "" + lappend result [testbooleanobj set 1 1] + lappend result [testobj duplicate 1 2] ;# uses DupBooleanInternalRep + lappend result [testbooleanobj get 2] +} {1 1 1} + +test obj-12.1 {SetBooleanFromAny, int to boolean special case} { + set result "" + lappend result [testintobj set 1 1234] + lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny + lappend result [testobj type 1] +} {1234 0 boolean} +test obj-12.2 {SetBooleanFromAny, double to boolean special case} { + set result "" + lappend result [testdoubleobj set 1 3.14159] + lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny + lappend result [testobj type 1] +} {3.14159 0 boolean} +test obj-12.3 {SetBooleanFromAny, special case strings representing booleans} { + set result "" + foreach s {yes no true false on off} { + teststringobj set 1 $s + lappend result [testbooleanobj not 1] + } + lappend result [testobj type 1] +} {0 1 0 1 0 1 boolean} +test obj-12.4 {SetBooleanFromAny, recompute string rep then parse it} { + set result "" + lappend result [testintobj set 1 456] + lappend result [testintobj div10 1] + lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny + lappend result [testobj type 1] +} {456 45 0 boolean} +test obj-12.5 {SetBooleanFromAny, error parsing string} { + set result "" + lappend result [teststringobj set 1 abc] + lappend result [catch {testbooleanobj not 1} msg] + lappend result $msg +} {abc 1 {expected boolean value but got "abc"}} +test obj-12.6 {SetBooleanFromAny, error parsing string} { + set result "" + lappend result [teststringobj set 1 x1.0] + lappend result [catch {testbooleanobj not 1} msg] + lappend result $msg +} {x1.0 1 {expected boolean value but got "x1.0"}} +test obj-12.7 {SetBooleanFromAny, error converting from "empty string"} { + set result "" + lappend result [testobj newobj 1] + lappend result [catch {testbooleanobj not 1} msg] + lappend result $msg +} {{} 1 {expected boolean value but got ""}} + +test obj-13.1 {UpdateStringOfBoolean} { + set result "" + lappend result [testbooleanobj set 1 0] + lappend result [testbooleanobj not 1] + lappend result [testbooleanobj get 1] ;# must update string rep +} {0 1 1} + +test obj-14.1 {Tcl_NewDoubleObj} { + set result "" + lappend result [testobj freeallvars] + lappend result [testdoubleobj set 1 3.1459] + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 3.1459 double 2} + +test obj-15.1 {Tcl_SetDoubleObj, existing "empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testobj newobj 1] + lappend result [testdoubleobj set 1 0.123] ;# makes existing obj boolean + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} {} 0.123 double 2} +test obj-15.2 {Tcl_SetDoubleObj, existing non-"empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testintobj set 1 98765] + lappend result [testdoubleobj set 1 27.56] ;# makes existing obj double + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 98765 27.56 double 2} + +test obj-16.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} { + 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} { + set result "" + lappend result [teststringobj set 1 abc] + lappend result [catch {testdoubleobj mult10 1} msg] + lappend result $msg +} {abc 1 {expected floating-point number but got "abc"}} +test obj-16.4 {Tcl_GetDoubleFromObj, error converting from "empty string"} { + set result "" + lappend result [testobj newobj 1] + lappend result [catch {testdoubleobj div10 1} msg] + lappend result $msg +} {{} 1 {expected floating-point number but got ""}} + +test obj-17.1 {DupDoubleInternalRep} { + set result "" + lappend result [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} { + set result "" + lappend result [testintobj set 1 1234] + lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny + lappend result [testobj type 1] +} {1234 12340.0 double} +test obj-18.2 {SetDoubleFromAny, boolean to double special case} { + set result "" + lappend result [testbooleanobj set 1 1] + lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny + lappend result [testobj type 1] +} {1 10.0 double} +test obj-18.3 {SetDoubleFromAny, recompute string rep then parse it} { + set result "" + lappend result [testintobj set 1 456] + lappend result [testintobj div10 1] + lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny + lappend result [testobj type 1] +} {456 45 450.0 double} +test obj-18.4 {SetDoubleFromAny, error parsing string} { + set result "" + lappend result [teststringobj set 1 abc] + lappend result [catch {testdoubleobj mult10 1} msg] + lappend result $msg +} {abc 1 {expected floating-point number but got "abc"}} +test obj-18.5 {SetDoubleFromAny, error parsing string} { + set result "" + lappend result [teststringobj set 1 x1.0] + lappend result [catch {testdoubleobj mult10 1} msg] + lappend result $msg +} {x1.0 1 {expected floating-point number but got "x1.0"}} +test obj-18.6 {SetDoubleFromAny, error converting from "empty string"} { + set result "" + lappend result [testobj newobj 1] + lappend result [catch {testdoubleobj div10 1} msg] + lappend result $msg +} {{} 1 {expected floating-point number but got ""}} + +test obj-19.1 {UpdateStringOfDouble} { + set result "" + lappend result [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} { + set result "" + lappend result [testobj freeallvars] + lappend result [testintobj set 1 55] + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 55 int 2} + +test obj-21.1 {Tcl_SetIntObj, existing "empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testobj newobj 1] + lappend result [testintobj set 1 77] ;# makes existing obj int + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} {} 77 int 2} +test obj-21.2 {Tcl_SetIntObj, existing non-"empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testdoubleobj set 1 12.34] + lappend result [testintobj set 1 77] ;# makes existing obj int + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 12.34 77 int 2} + +test obj-22.1 {Tcl_GetIntFromObj, existing int object} { + set result "" + lappend result [testintobj set 1 22] + lappend result [testintobj mult10 1] ;# gets existing int rep +} {22 220} +test obj-22.2 {Tcl_GetIntFromObj, convert to int} { + set result "" + lappend result [testintobj set 1 477] + lappend result [testintobj div10 1] ;# must convert to bool + lappend result [testobj type 1] +} {477 47 int} +test obj-22.3 {Tcl_GetIntFromObj, error converting to int} { + set result "" + lappend result [teststringobj set 1 abc] + lappend result [catch {testintobj mult10 1} msg] + lappend result $msg +} {abc 1 {expected integer but got "abc"}} +test obj-22.4 {Tcl_GetIntFromObj, error converting from "empty string"} { + set result "" + lappend result [testobj newobj 1] + lappend result [catch {testintobj div10 1} msg] + lappend result $msg +} {{} 1 {expected integer but got ""}} +test obj-22.5 {Tcl_GetIntFromObj, integer too large to represent as non-long error} {nonPortable} { + set result "" + lappend result [testobj newobj 1] + lappend result [testintobj inttoobigtest 1] +} {{} 1} + +test obj-23.1 {DupIntInternalRep} { + set result "" + lappend result [testintobj set 1 23] + lappend result [testobj duplicate 1 2] ;# uses DupIntInternalRep + lappend result [testintobj get 2] +} {23 23 23} + +test obj-24.1 {SetIntFromAny, int to int special case} { + set result "" + lappend result [testintobj set 1 1234] + lappend result [testintobj mult10 1] ;# converts with SetIntFromAny + lappend result [testobj type 1] +} {1234 12340 int} +test obj-24.2 {SetIntFromAny, boolean to int special case} { + set result "" + lappend result [testbooleanobj set 1 1] + lappend result [testintobj mult10 1] ;# converts with SetIntFromAny + lappend result [testobj type 1] +} {1 10 int} +test obj-24.3 {SetIntFromAny, recompute string rep then parse it} { + set result "" + lappend result [testintobj set 1 456] + lappend result [testintobj div10 1] + lappend result [testintobj mult10 1] ;# converts with SetIntFromAny + lappend result [testobj type 1] +} {456 45 450 int} +test obj-24.4 {SetIntFromAny, error parsing string} { + set result "" + lappend result [teststringobj set 1 abc] + lappend result [catch {testintobj mult10 1} msg] + lappend result $msg +} {abc 1 {expected integer but got "abc"}} +test obj-24.5 {SetIntFromAny, error parsing string} { + set result "" + lappend result [teststringobj set 1 x17] + lappend result [catch {testintobj mult10 1} msg] + lappend result $msg +} {x17 1 {expected integer but got "x17"}} +test obj-24.6 {SetIntFromAny, integer too large} {nonPortable} { + set result "" + lappend result [teststringobj set 1 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"} { + set result "" + lappend result [testobj newobj 1] + lappend result [catch {testintobj div10 1} msg] + lappend result $msg +} {{} 1 {expected integer but got ""}} + +test obj-25.1 {UpdateStringOfInt} { + set result "" + lappend result [testintobj set 1 512] + lappend result [testintobj mult10 1] + lappend result [testintobj get 1] ;# must update string rep +} {512 5120 5120} + +test obj-26.1 {Tcl_NewLongObj} { + set result "" + lappend result [testobj freeallvars] + testintobj setmaxlong 1 + lappend result [testintobj ismaxlong 1] + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 1 int 1} + +test obj-27.1 {Tcl_SetLongObj, existing "empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testobj newobj 1] + lappend result [testintobj setlong 1 77] ;# makes existing obj long int + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} {} 77 int 2} +test obj-27.2 {Tcl_SetLongObj, existing non-"empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testdoubleobj set 1 12.34] + lappend result [testintobj setlong 1 77] ;# makes existing obj long int + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 12.34 77 int 2} + +test obj-28.1 {Tcl_GetLongFromObj, existing long integer object} { + set result "" + lappend result [testintobj setlong 1 22] + lappend result [testintobj mult10 1] ;# gets existing long int rep +} {22 220} +test obj-28.2 {Tcl_GetLongFromObj, convert to long} { + set result "" + lappend result [testintobj setlong 1 477] + lappend result [testintobj div10 1] ;# must convert to bool + lappend result [testobj type 1] +} {477 47 int} +test obj-28.3 {Tcl_GetLongFromObj, error converting to long integer} { + set result "" + lappend result [teststringobj set 1 abc] + lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int + lappend result $msg +} {abc 1 {expected integer but got "abc"}} +test obj-28.4 {Tcl_GetLongFromObj, error converting from "empty string"} { + set result "" + lappend result [testobj newobj 1] + lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int + lappend result $msg +} {{} 1 {expected integer but got ""}} + +test obj-29.1 {Ref counting and object deletion, simple types} { + set result "" + lappend result [testobj freeallvars] + lappend result [testintobj set 1 1024] + lappend result [testobj assign 1 2] ;# vars 1 and 2 share the int obj + lappend result [testobj type 2] + lappend result [testobj refcount 1] + lappend result [testobj refcount 2] + lappend result [testbooleanobj set 2 0] ;# must copy on write, now 2 objs + lappend result [testobj type 2] + lappend result [testobj refcount 1] + lappend result [testobj refcount 2] +} {{} 1024 1024 int 4 4 0 boolean 3 2} + +testobj freeallvars diff --git a/tests/opt.test b/tests/opt.test new file mode 100644 index 0000000..0b35b76 --- /dev/null +++ b/tests/opt.test @@ -0,0 +1,255 @@ +# Package covered: opt0.1/optparse.tcl +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) opt.test 1.2 97/08/20 15:57:18 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# the package we are going to test +package require opt 0.1 + +# we are using implementation specifics to test the package + + +#### functions tests ##### + +set n $::tcl::OptDescN + +test opt-1.1 {OptKeyRegister / check that auto allocation is skipping existing keys} { + list [::tcl::OptKeyRegister {} $n] [::tcl::OptKeyRegister {} [expr $n+1]] [::tcl::OptKeyRegister {}] +} "$n [expr $n+1] [expr $n+2]" + +test opt-2.1 {OptKeyDelete} { + list [::tcl::OptKeyRegister {} testkey] [::tcl::OptKeyDelete testkey] \ + [catch {::tcl::OptKeyDelete testkey} msg] $msg; +} {testkey {} 1 {can't unset "OptDesc(testkey)": no such element in array}} + + +test opt-3.1 {OptParse / temp key is removed} { + set n $::tcl::OptDescN + set prev [array names ::tcl::OptDesc] + ::tcl::OptKeyRegister {} $n + list [info exists ::tcl::OptDesc($n)]\ + [::tcl::OptKeyDelete $n]\ + [::tcl::OptParse {{-foo}} {}]\ + [info exists ::tcl::OptDesc($n)]\ + [expr {"[lsort $prev]"=="[lsort [array names ::tcl::OptDesc]]"}] +} {1 {} {} 0 1} + + +test opt-3.2 {OptParse / temp key is removed even on errors} { + set n $::tcl::OptDescN + catch {::tcl::OptKeyDelete $n} + list [catch {::tcl::OptParse {{-foo}} {-blah}}] \ + [info exists ::tcl::OptDesc($n)] +} {1 0} + +test opt-4.1 {OptProc} { + ::tcl::OptProc optTest {} {} + optTest ; + ::tcl::OptKeyDelete optTest +} {} + + +test opt-5.1 {OptProcArgGiven} { + ::tcl::OptProc optTest {{-foo}} { + if {[::tcl::OptProcArgGiven "-foo"]} { + return 1 + } else { + return 0 + } + } + list [optTest] [optTest -f] [optTest -F] [optTest -fOO] +} {0 1 1 1} + +test opt-6.1 {OptKeyParse} { + ::tcl::OptKeyRegister {} test; + list [catch {::tcl::OptKeyParse test {-help}} msg] $msg +} {1 {Usage information: + Var/FlagName Type Value Help + ------------ ---- ----- ---- + ( -help gives this help )}} + + +test opt-7.1 {OptCheckType} { + list \ + [::tcl::OptCheckType 23 int] \ + [::tcl::OptCheckType 23 float] \ + [::tcl::OptCheckType true boolean] \ + [::tcl::OptCheckType "-blah" any] \ + [::tcl::OptCheckType {a b c} list] \ + [::tcl::OptCheckType maYbe choice {yes maYbe no}] \ + [catch {::tcl::OptCheckType "-blah" string}] \ + [catch {::tcl::OptCheckType 6 boolean}] \ + [catch {::tcl::OptCheckType x float}] \ + [catch {::tcl::OptCheckType "a \{ c" list}] \ + [catch {::tcl::OptCheckType 2.3 int}] \ + [catch {::tcl::OptCheckType foo choice {x y Foo z}}] +} {23 23.0 1 -blah {a b c} maYbe 1 1 1 1 1 1} + + +test opt-8.1 {List utilities} { + ::tcl::Lempty {} +} 1 +test opt-8.2 {List utilities} { + ::tcl::Lempty {a b c} +} 0 +test opt-8.3 {List utilities} { + ::tcl::Lget {a {b c d} e} {1 2} +} d + +test opt-8.4 {List utilities} { + set l {a {b c d e} f} + ::tcl::Lvarset l {1 2} D + set l +} {a {b c D e} f} + +test opt-8.5 {List utilities} { + set l {a b c} + ::tcl::Lvarset1 l 6 X + set l +} {a b c {} {} {} X} + +test opt-8.6 {List utilities} { + set l {a {b c 7 e} f} + ::tcl::Lvarincr l {1 2} + set l +} {a {b c 8 e} f} + +test opt-8.7 {List utilities} { + set l {a {b c 7 e} f} + ::tcl::Lvarincr l {1 2} -9 + set l +} {a {b c -2 e} f} + +test opt-8.8 {List utilities} { + set l {{b c 7 e} f} + ::tcl::Lfirst $l +} {b c 7 e} + + +test opt-8.9 {List utilities} { + set l {a {b c 7 e} f} + ::tcl::Lrest $l +} {{b c 7 e} f} + +test opt-8.10 {List utilities} { + set l {a {b c 7 e} f} + ::tcl::Lvarpop l + set l +} {{b c 7 e} f} + +test opt-8.11 {List utilities} { + catch {unset x} + set l {a {b c 7 e} f} + list [::tcl::Lassign $l u v w x] \ + $u $v $w [info exists x] +} {3 a {b c 7 e} f 0} + +test opt-9.1 {Misc utilities} { + catch {unset v} + ::tcl::SetMax v 3 + ::tcl::SetMax v 7 + ::tcl::SetMax v 6 + set v +} 7 + +test opt-9.2 {Misc utilities} { + catch {unset v} + ::tcl::SetMin v 3 + ::tcl::SetMin v -7 + ::tcl::SetMin v 1 + set v +} -7 + +#### behaviour tests ##### + +test opt-10.1 {ambigous flags} { + ::tcl::OptProc optTest {{-fla} {-other} {-flag2xyz} {-flag3xyz}} {} + catch {optTest -fL} msg + set msg +} {ambigous option "-fL", choose from: + -fla boolflag (false) + -flag2xyz boolflag (false) + -flag3xyz boolflag (false) } + +test opt-10.2 {non ambigous flags} { + ::tcl::OptProc optTest {{-flag1xyz} {-other} {-flag2xyz} {-flag3xyz}} { + return $flag2xyz + } + optTest -fLaG2 +} 1 + +test opt-10.3 {non ambigous flags because of exact match} { + ::tcl::OptProc optTest {{-flag1x} {-other} {-flag1} {-flag1xy}} { + return $flag1 + } + optTest -flAg1 +} 1 + +test opt-10.4 {ambigous flags, not exact match} { + ::tcl::OptProc optTest {{-flag1xy} {-other} {-flag1} {-flag1xyz}} { + return $flag1 + } + catch {optTest -fLag1X} msg + set msg +} {ambigous option "-fLag1X", choose from: + -flag1xy boolflag (false) + -flag1xyz boolflag (false) } + + + +# medium size overall test example: (defined once) +::tcl::OptProc optTest { + {cmd -choice {print save delete} "sub command to choose"} + {-allowBoing -boolean true} + {arg2 -string "this is help"} + {?arg3? 7 "optional number"} + {-moreflags} +} { + list $cmd $allowBoing $arg2 $arg3 $moreflags +} + +test opt-10.5 {medium size overall test} { + list [catch {optTest} msg] $msg +} {1 {no value given for parameter "cmd" (use -help for full usage) : + cmd choice (print save delete) sub command to choose}} + + +test opt-10.6 {medium size overall test} { + list [catch {optTest -help} msg] $msg +} {1 {Usage information: + Var/FlagName Type Value Help + ------------ ---- ----- ---- + ( -help gives this help ) + cmd choice (print save delete) sub command to choose + -allowBoing boolean (true) + arg2 string () this is help + ?arg3? int (7) optional number + -moreflags boolflag (false) }} + +test opt-10.7 {medium size overall test} { + optTest save tst +} {save 1 tst 7 0} + +test opt-10.8 {medium size overall test} { + optTest save -allowBoing false -- 8 +} {save 0 8 7 0} + +test opt-10.9 {medium size overall test} { + optTest save tst -m -- +} {save 1 tst 7 1} + +test opt-10.10 {medium size overall test} { + list [catch {optTest save tst foo} msg] [lindex [split $msg "\n"] 0] +} {1 {too many arguments (unexpected argument(s): foo), usage:}} + diff --git a/tests/osa.test b/tests/osa.test new file mode 100644 index 0000000..0e94838 --- /dev/null +++ b/tests/osa.test @@ -0,0 +1,36 @@ +# Commands covered: AppleScript +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) osa.test 1.4 97/06/23 18:24:24 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# This command only runs on the Macintosh, only run the test if we +# can load the command +if {$tcl_platform(platform) != "macintosh"} { + puts "skipping: Mac only tests..." + return +} +if {[info commands AppleScript] == ""} { + puts "couldn't find AppleScript command..." + return +} + +test osa-1.1 {Tcl_OSAComponentCmd} { + list [catch AppleScript msg] $msg +} {1 {wrong # args: should be "AppleScript option ?arg ...?"}} +test osa-1.2 {Tcl_OSAComponentCmd} { + list [catch {AppleScript x} msg] $msg +} {1 {bad option "x": should be compile, decompile, delete, execute, info, load, run or store}} + +test osa-1.3 {TclOSACompileCmd} { + list [catch {AppleScript compile} msg] $msg +} {1 {wrong # args: should be "AppleScript compile ?options? code"}} diff --git a/tests/parse.test b/tests/parse.test new file mode 100644 index 0000000..514ed2a --- /dev/null +++ b/tests/parse.test @@ -0,0 +1,556 @@ +# 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 +# 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: @(#) parse.test 1.42 97/08/04 11:05:53 + +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 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. + +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} + +# Braces. + +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]} + +# Command substitution. + +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 + +]b + set a +} a22b +test parse-4.4 {command substitution} { + set a 7.7 + if [catch {expr int($a)}] {set a foo} + set a +} 7.7 + +# Variable substitution. + +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} + +# Backslash substitution. + +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 + +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. + +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. + +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 + +# Syntax errors. + +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 +} {1 {missing )} {missing ) + (parsing index for array "x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000") + while compiling +"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 ..." + ("eval" body line 1) + invoked from within +"eval \$x[format "%01000d" 0]("}} +test parse-9.15 {syntax errors, missplaced braces} { + catch { + proc misplaced_end_brace {} { + set what foo + set when [expr ${what}size - [set off$what]}] + } msg + set msg +} {wrong # args: should be "proc name args body"} +test parse-9.16 {syntax errors, missplaced braces} { + catch { + set a { + set what foo + set when [expr ${what}size - [set off$what]}] + } msg + set msg +} {argument word in braces doesn't terminate properly} + +# Long values (stressing storage management) + +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-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-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-12.1 {comments at the end of a bracketed script} { + set x "[ +expr 1+1 +# skip this! +]" +} {2} + +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} diff --git a/tests/pid.test b/tests/pid.test new file mode 100644 index 0000000..1f6e039 --- /dev/null +++ b/tests/pid.test @@ -0,0 +1,52 @@ +# Commands covered: pid +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1995 Sun Microsystems, Inc. +# +# 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 + +# If pid is not defined just return with no error +# Some platforms may not have the pid command implemented +if {[info commands pid] == ""} { + puts "pid is not implemented for this machine" + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {removeFile test1} + +test pid-1.1 {pid command} { + regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid] +} 1 +test pid-1.2 {pid command} {unixOrPc unixExecs} { + set f [open {| echo foo | cat >test1} w] + set pids [pid $f] + close $f + catch {removeFile test1} + list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \ + [regexp {^[0-9]+$} [lindex $pids 1]] \ + [expr {[lindex $pids 0] == [lindex $pids 1]}] +} {2 1 1 0} +test pid-1.3 {pid command} { + set f [open test1 w] + set pids [pid $f] + close $f + set pids +} {} +test pid-1.4 {pid command} { + list [catch {pid a b} msg] $msg +} {1 {wrong # args: should be "pid ?channelId?"}} +test pid-1.5 {pid command} { + list [catch {pid gorp} msg] $msg +} {1 {can not find channel named "gorp"}} + +catch {removeFile test1} +concat {} diff --git a/tests/pkg.test b/tests/pkg.test new file mode 100644 index 0000000..e6a99c6 --- /dev/null +++ b/tests/pkg.test @@ -0,0 +1,563 @@ +# Commands covered: pkg +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) pkg.test 1.12 97/08/14 01:33:54 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Do all this in a slave interp to avoid garbaging the +# package list +set i [interp create] +interp eval $i [list set VERBOSE $VERBOSE] +interp eval $i [list set TESTS $TESTS] +interp eval $i { + +if {[string compare test [info procs test]] == 1} then {source defs} + +eval package forget [package names] +set oldPkgUnknown [package unknown] +package unknown {} +set oldPath $auto_path +set auto_path "" + +test pkg-1.1 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 +} {} +test pkg-1.2 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + list [catch {package provide t 2.2} msg] $msg +} {1 {conflicting versions provided for package "t": 2.3, then 2.2}} +test pkg-1.3 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + list [catch {package provide t 2.4} msg] $msg +} {1 {conflicting versions provided for package "t": 2.3, then 2.4}} +test pkg-1.4 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + list [catch {package provide t 3.3} msg] $msg +} {1 {conflicting versions provided for package "t": 2.3, then 3.3}} +test pkg-1.5 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + package provide t 2.3 +} {} + +test pkg-2.1 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t + set x +} {3.4} +test pkg-2.2 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t + set x +} {3.5} +test pkg-2.3 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {3.5 2.1 2.3} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t 2.2 + set x +} {2.3} +test pkg-2.4 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require -exact t 2.3 + set x +} {2.3} +test pkg-2.5 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t 2.1 + set x +} {2.4} +test pkg-2.6 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + list [catch {package require t 2.5} msg] $msg +} {1 {can't find package t 2.5}} +test pkg-2.7 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + list [catch {package require t 4.1} msg] $msg +} {1 {can't find package t 4.1}} +test pkg-2.8 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + list [catch {package require -exact t 1.3} msg] $msg +} {1 {can't find package t 1.3}} +test pkg-2.9 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + list [catch {package require t} msg] $msg +} {1 {can't find package t}} +test pkg-2.10 {Tcl_PkgRequire procedure, error in ifneeded script} { + package forget t + package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test"} + list [catch {package require t 2.1} msg] $msg $errorInfo +} {1 {ifneeded test} {ifneeded test + while executing +"error "ifneeded test"" + ("package ifneeded" script) + invoked from within +"package require t 2.1"}} +test pkg-2.11 {Tcl_PkgRequire procedure, ifneeded script doesn't provide package} { + package forget t + package ifneeded t 2.1 "set x invoked" + set x xxx + list [catch {package require t 2.1} msg] $msg $x +} {1 {can't find package t 2.1} invoked} +test pkg-2.12 {Tcl_PkgRequire procedure, self-deleting script} { + package forget t + package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" + set x xxx + package require t 1.2 + set x +} {1.2} +test pkg-2.13 {Tcl_PkgRequire procedure, "package unknown" support} { + proc pkgUnknown args { + global x + set x $args + package provide [lindex $args 0] [lindex $args 1] + } + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + set x xxx + package require -exact t 1.5 + package unknown {} + set x +} {t 1.5 -exact} +test pkg-2.14 {Tcl_PkgRequire procedure, "package unknown" support} { + proc pkgUnknown args { + package ifneeded t 1.2 "set x loaded; package provide t 1.2" + } + package forget t + package unknown pkgUnknown + set x xxx + set result [list [package require t] $x] + package unknown {} + set result +} {1.2 loaded} +test pkg-2.15 {Tcl_PkgRequire procedure, "package unknown" support} { + proc pkgUnknown args { + global x + set x $args + package provide [lindex $args 0] 2.0 + } + package forget {a b} + package unknown pkgUnknown + set x xxx + package require {a b} + package unknown {} + set x +} {{a b} {}} +test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} { + proc pkgUnknown args { + error "testing package unknown" + } + package forget t + package unknown pkgUnknown + set result [list [catch {package require t} msg] $msg $errorInfo] + package unknown {} + set result +} {1 {testing package unknown} {testing package unknown + while executing +"error "testing package unknown"" + (procedure "pkgUnknown" line 2) + invoked from within +"pkgUnknown t {}" + ("package unknown" script) + invoked from within +"package require t"}} +test pkg-2.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} { + proc pkgUnknown args { + global x + set x $args + } + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + set x xxx + set result [list [catch {package require -exact t 1.5} msg] $msg $x] + package unknown {} + set result +} {1 {can't find package t 1.5} {t 1.5 -exact}} +test pkg-2.18 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require t +} {2.3} +test pkg-2.19 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require t 2.1 +} {2.3} +test pkg-2.20 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require t 2.3 +} {2.3} +test pkg-2.21 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + list [catch {package require t 2.4} msg] $msg +} {1 {version conflict for package "t": have 2.3, need 2.4}} +test pkg-2.22 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + list [catch {package require t 1.2} msg] $msg +} {1 {version conflict for package "t": have 2.3, need 1.2}} +test pkg-2.23 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require -exact t 2.3 +} {2.3} +test pkg-2.24 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + list [catch {package require -exact t 2.2} msg] $msg +} {1 {version conflict for package "t": have 2.3, need 2.2}} + +test pkg-3.1 {Tcl_PackageCmd procedure} { + list [catch {package} msg] $msg +} {1 {wrong # args: should be "package option ?arg arg ...?"}} +test pkg-3.2 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package names +} {} +test pkg-3.3 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package forget foo +} {} +test pkg-3.4 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package ifneeded t 1.1 {first script} + package ifneeded t 2.3 {second script} + package ifneeded x 1.4 {x's script} + set result {} + lappend result [lsort [package names]] [package versions t] + package forget t + lappend result [lsort [package names]] [package versions t] +} {{t x} {1.1 2.3} x {}} +test pkg-3.5 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package ifneeded a 1.1 {first script} + package ifneeded b 2.3 {second script} + package ifneeded c 1.4 {third script} + package forget + set result [list [lsort [package names]]] + package forget a c + lappend result [lsort [package names]] +} {{a b c} b} +test pkg-3.6 {Tcl_PackageCmd procedure, "ifneeded" option} { + list [catch {package ifneeded a} msg] $msg +} {1 {wrong # args: should be "package ifneeded package version ?script?"}} +test pkg-3.7 {Tcl_PackageCmd procedure, "ifneeded" option} { + list [catch {package ifneeded a b c d} msg] $msg +} {1 {wrong # args: should be "package ifneeded package version ?script?"}} +test pkg-3.8 {Tcl_PackageCmd procedure, "ifneeded" option} { + list [catch {package ifneeded t xyz} msg] $msg +} {1 {expected version number but got "xyz"}} +test pkg-3.9 {Tcl_PackageCmd procedure, "ifneeded" option} { + foreach i [package names] { + package forget $i + } + list [package ifneeded foo 1.1] [package names] +} {{} {}} +test pkg-3.10 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + list [package names] [package ifneeded t 1.4] [package versions t] +} {t {script for t 1.4} 1.4} +test pkg-3.11 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + list [package ifneeded t 1.5] [package names] [package versions t] +} {{} t 1.4} +test pkg-3.12 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + package ifneeded t 1.4 "second script for t 1.4" + list [package ifneeded t 1.4] [package names] [package versions t] +} {{second script for t 1.4} t 1.4} +test pkg-3.13 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + package ifneeded t 1.2 "second script" + package ifneeded t 3.1 "last script" + list [package ifneeded t 1.2] [package versions t] +} {{second script} {1.4 1.2 3.1}} +test pkg-3.14 {Tcl_PackageCmd procedure, "names" option} { + list [catch {package names a} msg] $msg +} {1 {wrong # args: should be "package names"}} +test pkg-3.15 {Tcl_PackageCmd procedure, "names" option} { + foreach i [package names] { + package forget $i + } + package names +} {} +test pkg-3.16 {Tcl_PackageCmd procedure, "names" option} { + foreach i [package names] { + package forget $i + } + package ifneeded x 1.2 {dummy} + package provide x 1.3 + package provide y 2.4 + catch {package require z 47.16} + lsort [package names] +} {x y} +test pkg-3.17 {Tcl_PackageCmd procedure, "provide" option} { + list [catch {package provide} msg] $msg +} {1 {wrong # args: should be "package provide package ?version?"}} +test pkg-3.18 {Tcl_PackageCmd procedure, "provide" option} { + list [catch {package provide a b c} msg] $msg +} {1 {wrong # args: should be "package provide package ?version?"}} +test pkg-3.19 {Tcl_PackageCmd procedure, "provide" option} { + package forget t + package provide t +} {} +test pkg-3.20 {Tcl_PackageCmd procedure, "provide" option} { + package forget t + package provide t 2.3 + package provide t +} {2.3} +test pkg-3.21 {Tcl_PackageCmd procedure, "provide" option} { + package forget t + list [catch {package provide t a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.22 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.23 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require a b c} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.24 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact a b c} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.25 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -bs a b} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.26 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require x a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.27 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact x a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.28 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact x} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.29 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.30 {Tcl_PackageCmd procedure, "require" option} { + package forget t + package provide t 2.3 + package require t 2.1 +} {2.3} +test pkg-3.31 {Tcl_PackageCmd procedure, "require" option} { + package forget t + list [catch {package require t} msg] $msg +} {1 {can't find package t}} +test pkg-3.32 {Tcl_PackageCmd procedure, "require" option} { + package forget t + package ifneeded t 2.3 "error {synthetic error}" + list [catch {package require t 2.3} msg] $msg +} {1 {synthetic error}} +test pkg-3.33 {Tcl_PackageCmd procedure, "unknown" option} { + list [catch {package unknown a b} msg] $msg +} {1 {wrong # args: should be "package unknown ?command?"}} +test pkg-3.34 {Tcl_PackageCmd procedure, "unknown" option} { + package unknown "test script" + package unknown +} {test script} +test pkg-3.35 {Tcl_PackageCmd procedure, "unknown" option} { + package unknown "test script" + package unknown {} + package unknown +} {} +test pkg-3.36 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare a} msg] $msg +} {1 {wrong # args: should be "package vcompare version1 version2"}} +test pkg-3.37 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare a b c} msg] $msg +} {1 {wrong # args: should be "package vcompare version1 version2"}} +test pkg-3.38 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare x.y 3.4} msg] $msg +} {1 {expected version number but got "x.y"}} +test pkg-3.39 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare 2.1 a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.40 {Tcl_PackageCmd procedure, "vcompare" option} { + package vc 2.1 2.3 +} {-1} +test pkg-3.41 {Tcl_PackageCmd procedure, "vcompare" option} { + package vc 2.2.4 2.2.4 +} {0} +test pkg-3.42 {Tcl_PackageCmd procedure, "versions" option} { + list [catch {package versions} msg] $msg +} {1 {wrong # args: should be "package versions package"}} +test pkg-3.43 {Tcl_PackageCmd procedure, "versions" option} { + list [catch {package versions a b} msg] $msg +} {1 {wrong # args: should be "package versions package"}} +test pkg-3.44 {Tcl_PackageCmd procedure, "versions" option} { + package forget t + package versions t +} {} +test pkg-3.45 {Tcl_PackageCmd procedure, "versions" option} { + package forget t + package provide t 2.3 + package versions t +} {} +test pkg-3.46 {Tcl_PackageCmd procedure, "versions" option} { + package forget t + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package versions t +} {2.3 2.4} +test pkg-3.47 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vsatisfies a} msg] $msg +} {1 {wrong # args: should be "package vsatisfies version1 version2"}} +test pkg-3.48 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vsatisfies a b c} msg] $msg +} {1 {wrong # args: should be "package vsatisfies version1 version2"}} +test pkg-3.49 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vsatisfies x.y 3.4} msg] $msg +} {1 {expected version number but got "x.y"}} +test pkg-3.50 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vcompare 2.1 a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.51 {Tcl_PackageCmd procedure, "vsatisfies" option} { + package vs 2.3 2.1 +} {1} +test pkg-3.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { + package vs 2.3 1.2 +} {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}} + +# No tests for FindPackage; can't think up anything detectable +# errors. + +test pkg-4.1 {TclFreePackageInfo procedure} { + interp create foo + foo eval { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package ifneeded x 3.1 z + package provide q 4.3 + package unknown "will this get freed?" + } + interp delete foo +} {} +test pkg-4.2 {TclFreePackageInfo procedure} { + interp create foo + foo eval { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package ifneeded x 3.1 z + package provide q 4.3 + } + foo alias z kill + proc kill {} { + interp delete foo + } + list [catch {foo eval package require x 3.1} msg] $msg +} {1 {can't find package x 3.1}} + +test pkg-5.1 {CheckVersion procedure} { + list [catch {package vcompare 1 2.1} msg] $msg +} {0 -1} +test pkg-5.2 {CheckVersion procedure} { + list [catch {package vcompare .1 2.1} msg] $msg +} {1 {expected version number but got ".1"}} +test pkg-5.3 {CheckVersion procedure} { + list [catch {package vcompare 111.2a.3 2.1} msg] $msg +} {1 {expected version number but got "111.2a.3"}} +test pkg-5.4 {CheckVersion procedure} { + list [catch {package vcompare 1.2.3. 2.1} msg] $msg +} {1 {expected version number but got "1.2.3."}} + +test pkg-6.1 {ComparePkgVersions procedure} { + package vcompare 1.23 1.22 +} {1} +test pkg-6.2 {ComparePkgVersions procedure} { + package vcompare 1.22.1.2.3 1.22.1.2.3 +} {0} +test pkg-6.3 {ComparePkgVersions procedure} { + package vcompare 1.21 1.22 +} {-1} +test pkg-6.4 {ComparePkgVersions procedure} { + package vcompare 1.21 1.21.2 +} {-1} +test pkg-6.5 {ComparePkgVersions procedure} { + package vcompare 1.21.1 1.21 +} {1} +test pkg-6.6 {ComparePkgVersions procedure} { + package vsatisfies 1.21.1 1.21 +} {1} +test pkg-6.7 {ComparePkgVersions procedure} { + package vsatisfies 2.22.3 1.21 +} {0} +test pkg-6.8 {ComparePkgVersions procedure} { + package vsatisfies 1 1 +} {1} +test pkg-6.9 {ComparePkgVersions procedure} { + package vsatisfies 2 1 +} {0} + +set auto_path $oldPath +package unknown $oldPkgUnknown +concat + +} +interp delete $i diff --git a/tests/proc-old.test b/tests/proc-old.test new file mode 100644 index 0000000..c770edb --- /dev/null +++ b/tests/proc-old.test @@ -0,0 +1,505 @@ +# Commands covered: proc, return, global +# +# This file, proc-old.test, includes the original set of tests for Tcl's +# proc, return, and global commands. There is now a new file proc.test +# that contains tests for the tclProc.c source file. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) proc-old.test 1.31 97/07/02 16:41:36 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {rename t1 ""} +catch {rename foo ""} + +proc tproc {} {return a; return b} +test proc-old-1.1 {simple procedure call and return} {tproc} a +proc tproc x { + set x [expr $x+1] + return $x +} +test proc-old-1.2 {simple procedure call and return} {tproc 2} 3 +test proc-old-1.3 {simple procedure call and return} { + proc tproc {} {return foo} +} {} +test proc-old-1.4 {simple procedure call and return} { + proc tproc {} {return} + tproc +} {} +proc tproc1 {a} {incr a; return $a} +proc tproc2 {a b} {incr a; return $a} +test proc-old-1.5 {simple procedure call and return (2 procs with same body but different parameters)} { + list [tproc1 123] [tproc2 456 789] +} {124 457} +test proc-old-1.6 {simple procedure call and return (shared proc body string)} { + set x {} + proc tproc {} {} ;# body is shared with x + list [tproc] [append x foo] +} {{} foo} + +test proc-old-2.1 {local and global variables} { + proc tproc x { + set x [expr $x+1] + return $x + } + set x 42 + list [tproc 6] $x +} {7 42} +test proc-old-2.2 {local and global variables} { + proc tproc x { + set y [expr $x+1] + return $y + } + set y 18 + list [tproc 6] $y +} {7 18} +test proc-old-2.3 {local and global variables} { + proc tproc x { + global y + set y [expr $x+1] + return $y + } + set y 189 + list [tproc 6] $y +} {7 7} +test proc-old-2.4 {local and global variables} { + proc tproc x { + global y + return [expr $x+$y] + } + set y 189 + list [tproc 6] $y +} {195 189} +catch {unset _undefined_} +test proc-old-2.5 {local and global variables} { + proc tproc x { + global _undefined_ + return $_undefined_ + } + list [catch {tproc xxx} msg] $msg +} {1 {can't read "_undefined_": no such variable}} +test proc-old-2.6 {local and global variables} { + set a 114 + set b 115 + global a b + list $a $b +} {114 115} + +proc do {cmd} {eval $cmd} +test proc-old-3.1 {local and global arrays} { + catch {unset a} + set a(0) 22 + list [catch {do {global a; set a(0)}} msg] $msg +} {0 22} +test proc-old-3.2 {local and global arrays} { + catch {unset a} + set a(x) 22 + list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x) +} {0 newValue newValue} +test proc-old-3.3 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + list [catch {do {global a; unset a(y)}; array names a} msg] $msg +} {0 x} +test proc-old-3.4 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + list [catch {do {global a; unset a; info exists a}} msg] $msg \ + [info exists a] +} {0 0 0} +test proc-old-3.5 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + list [catch {do {global a; unset a(y); array names a}} msg] $msg +} {0 x} +catch {unset a} +test proc-old-3.6 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + do {global a; do {global a; unset a}; set a(z) 22} + list [catch {array names a} msg] $msg +} {0 z} +test proc-old-3.7 {local and global arrays} { + proc t1 {args} {global info; set info 1} + catch {unset a} + set info {} + do {global a; trace var a(1) w t1} + set a(1) 44 + set info +} 1 +test proc-old-3.8 {local and global arrays} { + proc t1 {args} {global info; set info 1} + catch {unset a} + trace var a(1) w t1 + set info {} + do {global a; trace vdelete a(1) w t1} + set a(1) 44 + set info +} {} +test proc-old-3.9 {local and global arrays} { + proc t1 {args} {global info; set info 1} + catch {unset a} + trace var a(1) w t1 + do {global a; trace vinfo a(1)} +} {{w t1}} +catch {unset a} + +test proc-old-3.1 {arguments and defaults} { + proc tproc {x y z} { + return [list $x $y $z] + } + tproc 11 12 13 +} {11 12 13} +test proc-old-3.2 {arguments and defaults} { + proc tproc {x y z} { + return [list $x $y $z] + } + list [catch {tproc 11 12} msg] $msg +} {1 {no value given for parameter "z" to "tproc"}} +test proc-old-3.3 {arguments and defaults} { + proc tproc {x y z} { + return [list $x $y $z] + } + list [catch {tproc 11 12 13 14} msg] $msg +} {1 {called "tproc" with too many arguments}} +test proc-old-3.4 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + tproc 11 12 13 +} {11 12 13} +test proc-old-3.5 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + tproc 11 12 +} {11 12 z-default} +test proc-old-3.6 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + tproc 11 +} {11 y-default z-default} +test proc-old-3.7 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + list [catch {tproc} msg] $msg +} {1 {no value given for parameter "x" to "tproc"}} +test proc-old-3.8 {arguments and defaults} { + list [catch { + proc tproc {x {y y-default} z} { + return [list $x $y $z] + } + tproc 2 3 + } msg] $msg +} {1 {no value given for parameter "z" to "tproc"}} +test proc-old-3.9 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + tproc 2 3 4 5 +} {2 3 {4 5}} +test proc-old-3.10 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + tproc 2 3 +} {2 3 {}} +test proc-old-3.11 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + tproc 2 +} {2 y-default {}} +test proc-old-3.12 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + list [catch {tproc} msg] $msg +} {1 {no value given for parameter "x" to "tproc"}} + +test proc-old-4.1 {variable numbers of arguments} { + proc tproc args {return $args} + tproc +} {} +test proc-old-4.2 {variable numbers of arguments} { + proc tproc args {return $args} + tproc 1 2 3 4 5 6 7 8 +} {1 2 3 4 5 6 7 8} +test proc-old-4.3 {variable numbers of arguments} { + proc tproc args {return $args} + tproc 1 {2 3} {4 {5 6} {{{7}}}} 8 +} {1 {2 3} {4 {5 6} {{{7}}}} 8} +test proc-old-4.4 {variable numbers of arguments} { + proc tproc {x y args} {return $args} + tproc 1 2 3 4 5 6 7 +} {3 4 5 6 7} +test proc-old-4.5 {variable numbers of arguments} { + proc tproc {x y args} {return $args} + tproc 1 2 +} {} +test proc-old-4.6 {variable numbers of arguments} { + proc tproc {x missing args} {return $args} + list [catch {tproc 1} msg] $msg +} {1 {no value given for parameter "missing" to "tproc"}} + +test proc-old-5.1 {error conditions} { + list [catch {proc} msg] $msg +} {1 {wrong # args: should be "proc name args body"}} +test proc-old-5.2 {error conditions} { + list [catch {proc tproc b} msg] $msg +} {1 {wrong # args: should be "proc name args body"}} +test proc-old-5.3 {error conditions} { + list [catch {proc tproc b c d e} msg] $msg +} {1 {wrong # args: should be "proc name args body"}} +test proc-old-5.4 {error conditions} { + list [catch {proc tproc \{xyz {return foo}} msg] $msg +} {1 {unmatched open brace in list}} +test proc-old-5.5 {error conditions} { + list [catch {proc tproc {{} y} {return foo}} msg] $msg +} {1 {procedure "tproc" has argument with no name}} +test proc-old-5.6 {error conditions} { + list [catch {proc tproc {{} y} {return foo}} msg] $msg +} {1 {procedure "tproc" has argument with no name}} +test proc-old-5.7 {error conditions} { + list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg +} {1 {too many fields in argument specifier "x 1 2"}} +test proc-old-5.8 {error conditions} { + catch {return} +} 2 +test proc-old-5.9 {error conditions} { + list [catch {global} msg] $msg +} {1 {wrong # args: should be "global varName ?varName ...?"}} +proc tproc {} { + set a 22 + global a +} +test proc-old-5.10 {error conditions} { + list [catch {tproc} msg] $msg +} {1 {variable "a" already exists}} +test proc-old-5.11 {error conditions} { + catch {rename tproc {}} + catch { + proc tproc {x {} z} {return foo} + } + list [catch {tproc 1} msg] $msg +} {1 {invalid command name "tproc"}} +test proc-old-5.12 {error conditions} { + proc tproc {} { + set a 22 + error "error in procedure" + return + } + list [catch tproc msg] $msg +} {1 {error in procedure}} +test proc-old-5.13 {error conditions} { + proc tproc {} { + set a 22 + error "error in procedure" + return + } + catch tproc msg + set errorInfo +} {error in procedure + while executing +"error "error in procedure"" + (procedure "tproc" line 3) + invoked from within +"tproc"} +test proc-old-5.14 {error conditions} { + proc tproc {} { + set a 22 + break + return + } + catch tproc msg + set errorInfo +} {invoked "break" outside of a loop + while executing +"tproc"} +test proc-old-5.15 {error conditions} { + proc tproc {} { + set a 22 + continue + return + } + catch tproc msg + set errorInfo +} {invoked "continue" outside of a loop + while executing +"tproc"} +test proc-old-5.16 {error conditions} { + proc foo args { + global fooMsg + set fooMsg "foo was called: $args" + } + proc tproc {} { + set x 44 + trace var x u foo + while {$x < 100} { + error "Nested error" + } + } + set fooMsg "foo not called" + list [catch tproc msg] $msg $errorInfo $fooMsg +} {1 {Nested error} {Nested error + while executing +"error "Nested error"" + (procedure "tproc" line 5) + invoked from within +"tproc"} {foo was called: x {} u}} + +# The tests below will really only be useful when run under Purify or +# some other system that can detect accesses to freed memory... + +test proc-old-6.1 {procedure that redefines itself} { + proc tproc {} { + proc tproc {} { + return 44 + } + return 45 + } + tproc +} 45 +test proc-old-6.2 {procedure that deletes itself} { + proc tproc {} { + rename tproc {} + return 45 + } + tproc +} 45 + +proc tproc code { + return -code $code abc +} +test proc-old-7.1 {return with special completion code} { + list [catch {tproc ok} msg] $msg +} {0 abc} +test proc-old-7.2 {return with special completion code} { + list [catch {tproc error} msg] $msg $errorInfo $errorCode +} {1 abc {abc + while executing +"tproc error"} NONE} +test proc-old-7.3 {return with special completion code} { + list [catch {tproc return} msg] $msg +} {2 abc} +test proc-old-7.4 {return with special completion code} { + list [catch {tproc break} msg] $msg +} {3 abc} +test proc-old-7.5 {return with special completion code} { + list [catch {tproc continue} msg] $msg +} {4 abc} +test proc-old-7.6 {return with special completion code} { + list [catch {tproc -14} msg] $msg +} {-14 abc} +test proc-old-7.7 {return with special completion code} { + list [catch {tproc gorp} msg] $msg +} {1 {bad completion code "gorp": must be ok, error, return, break, continue, or an integer}} +test proc-old-7.8 {return with special completion code} { + list [catch {tproc 10b} msg] $msg +} {1 {bad completion code "10b": must be ok, error, return, break, continue, or an integer}} +test proc-old-7.9 {return with special completion code} { + proc tproc2 {} { + tproc return + } + list [catch tproc2 msg] $msg +} {0 abc} +test proc-old-7.10 {return with special completion code} { + proc tproc2 {} { + return -code error + } + list [catch tproc2 msg] $msg +} {1 {}} +test proc-old-7.11 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error -errorinfo $errorInfo -errorcode $errorCode $msg + } + normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory + while executing +"open _bad_file_name r" + invoked from within +"tproc2"} {posix enoent {no such file or directory}}} +test proc-old-7.12 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error -errorcode $errorCode $msg + } + normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory + while executing +"tproc2"} {posix enoent {no such file or directory}}} +test proc-old-7.13 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error -errorinfo $errorInfo $msg + } + normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory + while executing +"open _bad_file_name r" + invoked from within +"tproc2"} none} +test proc-old-7.14 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error $msg + } + normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory + while executing +"tproc2"} none} +test proc-old-7.14 {return with special completion code} { + list [catch {return -badOption foo message} msg] $msg +} {1 {bad option "-badOption": must be -code, -errorcode, or -errorinfo}} + +test proc-old-8.1 {unset and undefined local arrays} { + proc t1 {} { + foreach v {xxx, yyy} { + catch {unset $v} + } + set yyy(foo) bar + } + t1 +} bar + +test proc-old-9.1 {empty command name} { + catch {rename {} ""} + proc t1 {args} { + return + } + set v [t1] + catch {$v} +} 1 + +test proc-old-10.1 {ByteCode epoch change during recursive proc execution} { + proc t1 x { + set y 20 + rename expr expr.old + rename expr.old expr + if $x then {t1 0} ;# recursive call after foo's code is invalidated + return 20 + } + t1 1 +} 20 + +catch {rename t1 ""} +catch {rename foo ""} diff --git a/tests/proc.test b/tests/proc.test new file mode 100644 index 0000000..eeace97 --- /dev/null +++ b/tests/proc.test @@ -0,0 +1,163 @@ +# This file contains tests for the tclProc.c source file. Tests appear in +# the same order as the C code that they test. The set of tests is +# currently incomplete since it includes only new tests, in particular +# tests for code changed for the addition of Tcl namespaces. Other +# procedure-related tests appear in other test files such as proc-old.test. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) proc.test 1.11 97/08/12 13:31:43 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {eval namespace delete [namespace children :: test_ns_*]} +catch {rename p ""} +catch {rename {} ""} +catch {unset msg} + +test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 { + namespace eval baz {} + } + proc test_ns_1::baz::p {} { + return "p in [namespace current]" + } + list [test_ns_1::baz::p] \ + [namespace eval test_ns_1 {baz::p}] \ + [info commands test_ns_1::baz::*] +} {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p} +test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [catch {proc test_ns_1::baz::p {} {}} msg] $msg +} {1 {can't create procedure "test_ns_1::baz::p": unknown namespace}} +test proc-1.3 {Tcl_ProcObjCmd, empty proc name} { + catch {eval namespace delete [namespace children :: test_ns_*]} + proc :: {} { + return "empty called" + } + list [::] \ + [info body {}] +} {{empty called} { + return "empty called" + }} +test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 { + namespace eval baz { + proc p {} { + return "p in [namespace current]" + } + } + } + list [test_ns_1::baz::p] \ + [info commands test_ns_1::baz::*] +} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p} +test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::baz {} + namespace eval test_ns_1 { + proc baz::p {} { + return "p in [namespace current]" + } + } + list [test_ns_1::baz::p] \ + [info commands test_ns_1::baz::*] \ + [namespace eval test_ns_1::baz {namespace which p}] +} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p} +test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc q: {} {return "q:"} + proc value:at: {} {return "value:at:"} + } + list [namespace eval test_ns_1 {q:}] \ + [namespace eval test_ns_1 {value:at:}] \ + [test_ns_1::q:] \ + [test_ns_1::value:at:] \ + [lsort [info commands test_ns_1::*]] \ + [namespace eval test_ns_1 {namespace which q:}] \ + [namespace eval test_ns_1 {namespace which value:at:}] +} {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:} +test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} { + catch {rename p ""} + list [catch {proc p {a(1) a(2)} { + set z [expr $a(1)+$a(2)] + puts "$z=z, $a(1)=$a(1)" + }} msg] $msg +} {1 {procedure "p" has formal parameter "a(1)" that is an array element}} + +test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename p ""} + proc p {} {return "p in [namespace current]"} + info body p +} {return "p in [namespace current]"} +test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1 { + namespace eval baz { + proc p {} {return "p in [namespace current]"} + } + } + namespace eval test_ns_1::baz {info body p} +} {return "p in [namespace current]"} +test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::baz {} + namespace eval test_ns_1 { + proc baz::p {} {return "p in [namespace current]"} + } + namespace eval test_ns_1 {info body baz::p} +} {return "p in [namespace current]"} +test proc-2.4 {TclFindProc, global proc and executing in namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename p ""} + proc p {} {return "global p"} + namespace eval test_ns_1::baz {info body p} +} {return "global p"} + +test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + proc p {} {return "p in [namespace current]"} + p +} {p in ::} +test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + namespace eval test_ns_1::baz { + proc p {} {return "p in [namespace current]"} + p + } +} {p in ::test_ns_1::baz} +test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename p ""} + proc p {} {return "p in [namespace current]"} + namespace eval test_ns_1::baz { + p + } +} {p in ::} +test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename p ""} + namespace eval test_ns_1::baz { + proc p {} {return "p in [namespace current]"} + rename ::test_ns_1::baz::p ::p + list [p] [namespace which p] + } +} {{p in ::} ::p} +test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} { + proc p {x} {info commands 3m} + list [catch {p} msg] $msg +} {1 {no value given for parameter "x" to "p"}} + +catch {eval namespace delete [namespace children :: test_ns_*]} +catch {rename p ""} +catch {rename {} ""} +catch {unset msg} diff --git a/tests/pwd.test b/tests/pwd.test new file mode 100644 index 0000000..e283799 --- /dev/null +++ b/tests/pwd.test @@ -0,0 +1,22 @@ +# Commands covered: pwd +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) pwd.test 1.2 97/08/13 23:06:41 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test pwd-1.1 {simple pwd} { + catch pwd +} 0 +test pwd-1.2 {simple pwd} { + expr [string length pwd]>0 +} 1 diff --git a/tests/regexp.test b/tests/regexp.test new file mode 100644 index 0000000..5fb785b --- /dev/null +++ b/tests/regexp.test @@ -0,0 +1,318 @@ +# Commands covered: regexp, regsub +# +# 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: @(#) regexp.test 1.21 96/12/23 13:59:48 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset foo} +test regexp-1.1 {basic regexp operation} { + regexp ab*c abbbc +} 1 +test regexp-1.2 {basic regexp operation} { + regexp ab*c ac +} 1 +test regexp-1.3 {basic regexp operation} { + regexp ab*c ab +} 0 +test regexp-1.4 {basic regexp operation} { + regexp -- -gorp abc-gorpxxx +} 1 +test regexp-1.5 {basic regexp operation} { + regexp {^([^ ]*)[ ]*([^ ]*)} "" a +} 1 + +test regexp-2.1 {getting substrings back from regexp} { + set foo {} + list [regexp ab*c abbbbc foo] $foo +} {1 abbbbc} +test regexp-2.2 {getting substrings back from regexp} { + set foo {} + set f2 {} + list [regexp a(b*)c abbbbc foo f2] $foo $f2 +} {1 abbbbc bbbb} +test regexp-2.3 {getting substrings back from regexp} { + set foo {} + set f2 {} + list [regexp a(b*)(c) abbbbc foo f2] $foo $f2 +} {1 abbbbc bbbb} +test regexp-2.4 {getting substrings back from regexp} { + set foo {} + set f2 {} + set f3 {} + list [regexp a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3 +} {1 abbbbc bbbb c} +test regexp-2.5 {getting substrings back from regexp} { + set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {}; + set f6 {}; set f7 {}; set f8 {}; set f9 {}; set fa {}; set fb {}; + list [regexp (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*)(a*)(b*) \ + 12223345556789999aabbb \ + foo f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb] $foo $f1 $f2 $f3 $f4 $f5 \ + $f6 $f7 $f8 $f9 $fa $fb +} {1 12223345556789999aabbb 1 222 33 4 555 6 7 8 9999 aa bbb} +test regexp-2.6 {getting substrings back from regexp} { + set foo 2; set f2 2; set f3 2; set f4 2 + list [regexp (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4 +} {1 a a {} {}} +test regexp-2.7 {getting substrings back from regexp} { + set foo 1; set f2 1; set f3 1; set f4 1 + list [regexp (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4 +} {1 ac a {} c} + + +test regexp-3.1 {-indices option to regexp} { + set foo {} + list [regexp -indices ab*c abbbbc foo] $foo +} {1 {0 5}} +test regexp-3.2 {-indices option to regexp} { + set foo {} + set f2 {} + list [regexp -indices a(b*)c abbbbc foo f2] $foo $f2 +} {1 {0 5} {1 4}} +test regexp-3.3 {-indices option to regexp} { + set foo {} + set f2 {} + list [regexp -indices a(b*)(c) abbbbc foo f2] $foo $f2 +} {1 {0 5} {1 4}} +test regexp-3.4 {-indices option to regexp} { + set foo {} + set f2 {} + set f3 {} + list [regexp -indices a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3 +} {1 {0 5} {1 4} {5 5}} +test regexp-3.5 {-indices option to regexp} { + set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {}; + set f6 {}; set f7 {}; set f8 {}; set f9 {} + list [regexp -indices (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*) \ + 12223345556789999 \ + foo f1 f2 f3 f4 f5 f6 f7 f8 f9] $foo $f1 $f2 $f3 $f4 $f5 \ + $f6 $f7 $f8 $f9 +} {1 {0 16} {0 0} {1 3} {4 5} {6 6} {7 9} {10 10} {11 11} {12 12} {13 16}} +test regexp-3.6 {getting substrings back from regexp} { + set foo 2; set f2 2; set f3 2; set f4 2 + list [regexp -indices (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4 +} {1 {1 1} {1 1} {-1 -1} {-1 -1}} +test regexp-3.7 {getting substrings back from regexp} { + set foo 1; set f2 1; set f3 1; set f4 1 + list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4 +} {1 {1 2} {1 1} {-1 -1} {2 2}} + +test regexp-4.1 {-nocase option to regexp} { + regexp -nocase foo abcFOo +} 1 +test regexp-4.2 {-nocase option to regexp} { + set f1 22 + set f2 33 + set f3 44 + list [regexp -nocase {a(b*)([xy]*)z} aBbbxYXxxZ22 f1 f2 f3] $f1 $f2 $f3 +} {1 aBbbxYXxxZ Bbb xYXxx} +test regexp-4.3 {-nocase option to regexp} { + regexp -nocase FOo abcFOo +} 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} { + list [regexp -nocase $x $x foo] $foo +} "1 $x" +unset x + +test regexp-5.1 {exercise cache of compiled expressions} { + regexp .*a b + regexp .*b c + regexp .*c d + regexp .*d e + regexp .*e f + regexp .*a bbba +} 1 +test regexp-5.2 {exercise cache of compiled expressions} { + regexp .*a b + regexp .*b c + regexp .*c d + regexp .*d e + regexp .*e f + regexp .*b xxxb +} 1 +test regexp-5.3 {exercise cache of compiled expressions} { + regexp .*a b + regexp .*b c + regexp .*c d + regexp .*d e + regexp .*e f + regexp .*c yyyc +} 1 +test regexp-5.4 {exercise cache of compiled expressions} { + regexp .*a b + regexp .*b c + regexp .*c d + regexp .*d e + regexp .*e f + regexp .*d 1d +} 1 +test regexp-5.5 {exercise cache of compiled expressions} { + regexp .*a b + regexp .*b c + regexp .*c d + regexp .*d e + regexp .*e f + regexp .*e xe +} 1 + +test regexp-6.1 {regexp errors} { + list [catch {regexp a} msg] $msg +} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}} +test regexp-6.2 {regexp errors} { + list [catch {regexp -nocase a} msg] $msg +} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}} +test regexp-6.3 {regexp errors} { + list [catch {regexp -gorp a} msg] $msg +} {1 {bad switch "-gorp": must be -indices, -nocase, or --}} +test regexp-6.4 {regexp errors} { + list [catch {regexp a( b} msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} +test regexp-6.5 {regexp errors} { + list [catch {regexp a( b} msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} +test regexp-6.6 {regexp errors} { + list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg +} {0 1} +test regexp-6.7 {regexp errors} { + list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg +} {1 {couldn't compile regular expression pattern: too many ()}} +test regexp-6.8 {regexp errors} { + set f1 44 + list [catch {regexp abc abc f1(f2)} msg] $msg +} {1 {couldn't set variable "f1(f2)"}} + +test regexp-7.1 {basic regsub operation} { + list [regsub aa+ xaxaaaxaa 111&222 foo] $foo +} {1 xax111aaa222xaa} +test regexp-7.2 {basic regsub operation} { + list [regsub aa+ aaaxaa &111 foo] $foo +} {1 aaa111xaa} +test regexp-7.3 {basic regsub operation} { + list [regsub aa+ xaxaaa 111& foo] $foo +} {1 xax111aaa} +test regexp-7.4 {basic regsub operation} { + list [regsub aa+ aaa 11&2&333 foo] $foo +} {1 11aaa2aaa333} +test regexp-7.5 {basic regsub operation} { + list [regsub aa+ xaxaaaxaa &2&333 foo] $foo +} {1 xaxaaa2aaa333xaa} +test regexp-7.6 {basic regsub operation} { + list [regsub aa+ xaxaaaxaa 1&22& foo] $foo +} {1 xax1aaa22aaaxaa} +test regexp-7.7 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {1\122\1} foo] $foo +} {1 xax1aa22aaxaa} +test regexp-7.8 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {1\\\122\1} foo] $foo +} "1 {xax1\\aa22aaxaa}" +test regexp-7.9 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {1\\122\1} foo] $foo +} "1 {xax1\\122aaxaa}" +test regexp-7.10 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {1\\&\1} foo] $foo +} "1 {xax1\\aaaaaxaa}" +test regexp-7.11 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {1\&\1} foo] $foo +} {1 xax1&aaxaa} +test regexp-7.12 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {\1\1\1\1&&} foo] $foo +} {1 xaxaaaaaaaaaaaaaaxaa} +test regexp-7.13 {basic regsub operation} { + set foo xxx + list [regsub abc xyz 111 foo] $foo +} {0 xyz} +test regexp-7.14 {basic regsub operation} { + set foo xxx + list [regsub ^ xyz "111 " foo] $foo +} {1 {111 xyz}} +test regexp-7.15 {basic regsub operation} { + set foo xxx + list [regsub -- -foo abc-foodef "111 " foo] $foo +} {1 {abc111 def}} +test regexp-7.16 {basic regsub operation} { + set foo xxx + list [regsub x "" y foo] $foo +} {0 {}} + +test regexp-8.1 {case conversion in regsub} { + list [regsub -nocase a(a+) xaAAaAAay & foo] $foo +} {1 xaAAaAAay} +test regexp-8.2 {case conversion in regsub} { + list [regsub -nocase a(a+) xaAAaAAay & foo] $foo +} {1 xaAAaAAay} +test regexp-8.3 {case conversion in regsub} { + set foo 123 + list [regsub a(a+) xaAAaAAay & foo] $foo +} {0 xaAAaAAay} +test regexp-8.4 {case conversion in regsub} { + set foo 123 + list [regsub -nocase a CaDE b foo] $foo +} {1 CbDE} +test regexp-8.5 {case conversion in regsub} { + set foo 123 + list [regsub -nocase XYZ CxYzD b foo] $foo +} {1 CbD} +test regexp-8.6 {case conversion in regsub} { + set x abcdefghijklmnopqrstuvwxyz1234567890 + set x $x$x$x$x$x$x$x$x$x$x$x$x + set foo 123 + list [regsub -nocase $x $x b foo] $foo +} {1 b} + +test regexp-9.1 {-all option to regsub} { + set foo 86 + list [regsub -all x+ axxxbxxcxdx |&| foo] $foo +} {4 a|xxx|b|xx|c|x|d|x|} +test regexp-9.2 {-all option to regsub} { + set foo 86 + list [regsub -nocase -all x+ aXxXbxxcXdx |&| foo] $foo +} {4 a|XxX|b|xx|c|X|d|x|} +test regexp-9.3 {-all option to regsub} { + set foo 86 + list [regsub x+ axxxbxxcxdx |&| foo] $foo +} {1 a|xxx|bxxcxdx} +test regexp-9.4 {-all option to regsub} { + set foo 86 + list [regsub -all bc axxxbxxcxdx |&| foo] $foo +} {0 axxxbxxcxdx} +test regexp-9.5 {-all option to regsub} { + set foo xxx + list [regsub -all node "node node more" yy foo] $foo +} {2 {yy yy more}} +test regexp-9.6 {-all option to regsub} { + set foo xxx + list [regsub -all ^ xxx 123 foo] $foo +} {1 123xxx} + +test regexp-10.1 {regsub errors} { + list [catch {regsub a b c} msg] $msg +} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} +test regexp-10.2 {regsub errors} { + list [catch {regsub -nocase a b c} msg] $msg +} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} +test regexp-10.3 {regsub errors} { + list [catch {regsub -nocase -all a b c} msg] $msg +} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} +test regexp-10.4 {regsub errors} { + list [catch {regsub a b c d e f} msg] $msg +} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} +test regexp-10.5 {regsub errors} { + list [catch {regsub -gorp a b c} msg] $msg +} {1 {bad switch "-gorp": must be -all, -nocase, or --}} +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} { + list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg +} {1 {couldn't set variable "f1(f2)"}} diff --git a/tests/registry.test b/tests/registry.test new file mode 100644 index 0000000..605c84b --- /dev/null +++ b/tests/registry.test @@ -0,0 +1,512 @@ +# registry.test -- +# +# This file contains a collection of tests for the registry command. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# In order for these tests to run, the registry package must be on the +# auto_path or the registry package must have been loaded already. +# +# Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. +# +# SCCS: @(#) registry.test 1.5 97/08/01 11:14:25 + +if {$tcl_platform(platform) != "windows"} { + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +if [catch {package require registry}] { + puts "Unable to find the registry package. Skipping registry tests." + return +} + +if {$testConfig(win32s)} { + puts "Skipping registry tests under Win32s" + return +} + +switch $tcl_platform(os) { + "Windows NT" {set testConfig(NT) 1} + "Windows 95" {set testConfig(95) 1} +} + +set hostname [info hostname] + +test registry-1.1 {argument parsing for registry command} { + list [catch {registry} msg] $msg +} {1 {wrong # args: should be "registry option ?arg arg ...?"}} +test registry-1.2 {argument parsing for registry command} { + list [catch {registry foo} msg] $msg +} {1 {bad option "foo": must be delete, get, keys, set, type, or values}} + +test registry-1.3 {argument parsing for registry command} { + list [catch {registry d} msg] $msg +} {1 {wrong # args: should be "registry delete keyName ?valueName?"}} +test registry-1.4 {argument parsing for registry command} { + list [catch {registry delete} msg] $msg +} {1 {wrong # args: should be "registry delete keyName ?valueName?"}} +test registry-1.5 {argument parsing for registry command} { + list [catch {registry delete foo bar baz} msg] $msg +} {1 {wrong # args: should be "registry delete keyName ?valueName?"}} + +test registry-1.6 {argument parsing for registry command} { + list [catch {registry g} msg] $msg +} {1 {wrong # args: should be "registry get keyName valueName"}} +test registry-1.7 {argument parsing for registry command} { + list [catch {registry get} msg] $msg +} {1 {wrong # args: should be "registry get keyName valueName"}} +test registry-1.8 {argument parsing for registry command} { + list [catch {registry get foo} msg] $msg +} {1 {wrong # args: should be "registry get keyName valueName"}} +test registry-1.9 {argument parsing for registry command} { + list [catch {registry get foo bar baz} msg] $msg +} {1 {wrong # args: should be "registry get keyName valueName"}} + +test registry-1.10 {argument parsing for registry command} { + list [catch {registry k} msg] $msg +} {1 {wrong # args: should be "registry keys keyName ?pattern?"}} +test registry-1.11 {argument parsing for registry command} { + list [catch {registry keys} msg] $msg +} {1 {wrong # args: should be "registry keys keyName ?pattern?"}} +test registry-1.12 {argument parsing for registry command} { + list [catch {registry keys foo bar baz} msg] $msg +} {1 {wrong # args: should be "registry keys keyName ?pattern?"}} + +test registry-1.13 {argument parsing for registry command} { + list [catch {registry s} msg] $msg +} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}} +test registry-1.14 {argument parsing for registry command} { + list [catch {registry set} msg] $msg +} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}} +test registry-1.15 {argument parsing for registry command} { + list [catch {registry set foo bar} msg] $msg +} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}} +test registry-1.16 {argument parsing for registry command} { + list [catch {registry set foo bar baz blat gorp} msg] $msg +} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}} + +test registry-1.17 {argument parsing for registry command} { + list [catch {registry t} msg] $msg +} {1 {wrong # args: should be "registry type keyName valueName"}} +test registry-1.18 {argument parsing for registry command} { + list [catch {registry type} msg] $msg +} {1 {wrong # args: should be "registry type keyName valueName"}} +test registry-1.19 {argument parsing for registry command} { + list [catch {registry type foo} msg] $msg +} {1 {wrong # args: should be "registry type keyName valueName"}} +test registry-1.20 {argument parsing for registry command} { + list [catch {registry type foo bar baz} msg] $msg +} {1 {wrong # args: should be "registry type keyName valueName"}} + +test registry-1.21 {argument parsing for registry command} { + list [catch {registry v} msg] $msg +} {1 {wrong # args: should be "registry values keyName ?pattern?"}} +test registry-1.22 {argument parsing for registry command} { + list [catch {registry values} msg] $msg +} {1 {wrong # args: should be "registry values keyName ?pattern?"}} +test registry-1.23 {argument parsing for registry command} { + list [catch {registry values foo bar baz} msg] $msg +} {1 {wrong # args: should be "registry values keyName ?pattern?"}} + +test registry-2.1 {DeleteKey: bad key} { + list [catch {registry delete foo} msg] $msg +} {1 {bad root name "foo": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} +test registry-2.2 {DeleteKey: bad key} { + list [catch {registry delete HKEY_CLASSES_ROOT} msg] $msg +} {1 {bad key: cannot delete root keys}} +test registry-2.3 {DeleteKey: bad key} { + list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg +} {1 {bad key: cannot delete root keys}} +test registry-2.4 {DeleteKey: subkey at root level} { + registry set HKEY_CLASSES_ROOT\\TclFoobar + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry keys HKEY_CLASSES_ROOT TclFoobar +} {} +test registry-2.5 {DeleteKey: subkey below root level} { + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test + registry delete HKEY_CLASSES_ROOT\\TclFoobar\\test + set result [registry keys HKEY_CLASSES_ROOT TclFoobar\\test] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {} +test registry-2.6 {DeleteKey: recursive delete} { + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1 + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3 + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result [registry keys HKEY_CLASSES_ROOT TclFoobar] + set result +} {} +test registry-2.7 {DeleteKey: trailing backslashes} { + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz + list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar\\} msg] $msg +} {1 {unable to delete key: The configuration registry key is invalid.}} +test registry-2.8 {DeleteKey: failure} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry delete HKEY_CLASSES_ROOT\\TclFoobar +} {} + + +test registry-3.1 {DeleteValue} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test1 blort + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test2 blat + registry delete HKEY_CLASSES_ROOT\\TclFoobar\\baz test1 + set result [registry values HKEY_CLASSES_ROOT\\TclFoobar\\baz] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} test2 +test registry-3.2 {DeleteValue: bad key} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar test} msg] $msg +} {1 {unable to open key: The system cannot find the file specified.}} +test registry-3.3 {DeleteValue: bad value} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test2 blort + set result [list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar test1} msg] $msg] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {1 {unable to delete value "test1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}} + + +test registry-4.1 {GetKeyNames: bad key} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg +} {1 {unable to open key: The system cannot find the file specified.}} +test registry-4.2 {GetKeyNames} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz + set result [registry keys HKEY_CLASSES_ROOT\\TclFoobar] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {baz} +test registry-4.3 {GetKeyNames: remote key} {nonPortable} { + registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar\\baz + set result [registry keys \\\\gaspode\\HKEY_CLASSES_ROOT\\TclFoobar] + registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar + set result +} {baz} +test registry-4.4 {GetKeyNames: empty key} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar + set result [registry keys HKEY_CLASSES_ROOT\\TclFoobar] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {} +test registry-4.5 {GetKeyNames: patterns} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz + registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat + registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo + set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {baz blat} +test registry-4.6 {GetKeyNames: names with spaces} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz\ bar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat + registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo + set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {{baz bar} blat} + +test registry-5.1 {GetType} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg +} {1 {unable to open key: The system cannot find the file specified.}} +test registry-5.2 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg +} {1 {unable to get type of value "val1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}} +test registry-5.3 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar none + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} none +test registry-5.4 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} sz +test registry-5.5 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar sz + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} sz +test registry-5.6 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar expand_sz + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} expand_sz +test registry-5.7 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 binary + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} binary +test registry-5.8 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 dword + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} dword +test registry-5.9 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 dword_big_endian + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} dword_big_endian +test registry-5.10 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 link + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} link +test registry-5.11 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar multi_sz + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} multi_sz +test registry-5.12 {GetType} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 resource_list + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} resource_list +test registry-5.13 {GetType: unknown types} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 24 + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} 24 + +test registry-6.1 {GetValue} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry get HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg +} {1 {unable to open key: The system cannot find the file specified.}} +test registry-6.2 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry get HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg +} {1 {unable to get value "val1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}} +test registry-6.3 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar none + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} foobar +test registry-6.4 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} foobar +test registry-6.5 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} foobar +test registry-6.6 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar expand_sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} foobar +test registry-6.7 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 binary + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} 1 +test registry-6.8 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 0x20 dword + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} 32 +test registry-6.9 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 0x20 dword_big_endian + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} 32 +test registry-6.10 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 link + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} 1 +test registry-6.11 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar multi_sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} foobar +test registry-6.12 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {foo\ bar baz} multi_sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {{foo bar} baz} +test registry-6.13 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {} multi_sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {} +test registry-6.14 {GetValue: truncation of multivalues with null elements} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {a {} b} multi_sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} a +test registry-6.15 {GetValue} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 resource_list + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} 1 +test registry-6.16 {GetValue: unknown types} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 24 + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} 1 + +test registry-7.1 {GetValueNames: bad key} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry values HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg +} {1 {unable to open key: The system cannot find the file specified.}} +test registry-7.2 {GetValueNames} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar + set result [registry values HKEY_CLASSES_ROOT\\TclFoobar] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} baz +test registry-7.3 {GetValueNames} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1 + registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2 + registry set HKEY_CLASSES_ROOT\\TclFoobar {} foobar3 + set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar]] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {{} baz blat} +test registry-7.4 {GetValueNames: remote key} {nonPortable} { + registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar baz blat + set result [registry values \\\\gaspode\\HKEY_CLASSES_ROOT\\TclFoobar] + registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar + set result +} baz +test registry-7.5 {GetValueNames: empty key} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar + set result [registry values HKEY_CLASSES_ROOT\\TclFoobar] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {} +test registry-7.6 {GetValueNames: patterns} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1 + registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2 + registry set HKEY_CLASSES_ROOT\\TclFoobar foo foobar3 + set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar b*]] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {baz blat} +test registry-7.7 {GetValueNames: names with spaces} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar baz\ bar foobar1 + registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2 + registry set HKEY_CLASSES_ROOT\\TclFoobar foo foobar3 + set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar b*]] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {{baz bar} blat} + +test registry-8.1 {OpenSubKey} {nonPortable} { + list [catch {registry keys {\\petrouchka\HKEY_LOCAL_MACHINE}} msg] $msg +} {1 {unable to open key: Access is denied.}} +test registry-8.2 {OpenSubKey} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar + set result [registry keys HKEY_CLASSES_ROOT TclFoobar] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} TclFoobar +test registry-8.3 {OpenSubKey} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg +} {1 {unable to open key: The system cannot find the file specified.}} + +test registry-9.1 {ParseKeyName: bad keys} { + list [catch {registry values \\} msg] $msg +} "1 {bad key \"\\\": must start with a valid root}" +test registry-9.2 {ParseKeyName: bad keys} { + list [catch {registry values \\foobar} msg] $msg +} {1 {bad key "\foobar": must start with a valid root}} +test registry-9.3 {ParseKeyName: bad keys} { + list [catch {registry values \\\\} msg] $msg +} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} +test registry-9.4 {ParseKeyName: bad keys} { + list [catch {registry values \\\\\\} msg] $msg +} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} +test registry-9.5 {ParseKeyName: bad keys} { + list [catch {registry values \\\\\\HKEY_CLASSES_ROOT} msg] $msg +} {1 {unable to open key: The network address is invalid.}} +test registry-9.6 {ParseKeyName: bad keys} { + list [catch {registry values \\\\gaspode} msg] $msg +} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} +test registry-9.7 {ParseKeyName: bad keys} { + list [catch {registry values foobar} msg] $msg +} {1 {bad root name "foobar": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} +test registry-9.8 {ParseKeyName: null keys} { + list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg +} {1 {bad key: cannot delete root keys}} +test registry-9.9 {ParseKeyName: null keys} { + list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar\\baz} msg] $msg +} {1 {unable to open key: The system cannot find the file specified.}} + +test registry-10.1 {RecursiveDeleteKey} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1 + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3 + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result [registry keys HKEY_CLASSES_ROOT TclFoobar] + set result +} {} +test registry-10.2 {RecursiveDeleteKey} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1 + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3 + set result [registry delete HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test4] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {} + +test registry-11.1 {SetValue: recursive creation} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat foobar + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar\\baz blat] +} foobar +test registry-11.2 {SetValue: modification} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat foobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat frob + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar\\baz blat] +} frob +test registry-11.3 {SetValue: failure} {nonPortable} { + list [catch {registry set {\\petrouchka\HKEY_CLASSES_ROOT\TclFoobar} bar foobar} msg] $msg +} {1 {unable to open key: Access is denied.}} + + +unset hostname diff --git a/tests/rename.test b/tests/rename.test new file mode 100644 index 0000000..05f5938 --- /dev/null +++ b/tests/rename.test @@ -0,0 +1,172 @@ +# Commands covered: rename +# +# 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: @(#) rename.test 1.20 97/06/24 17:26:23 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Must eliminate the "unknown" command while the test is running, +# especially if the test is being run in a program with its +# own special-purpose unknown command. + +catch {rename unknown unknown.old} + +catch {rename r2 {}} +proc r1 {} {return "procedure r1"} +rename r1 r2 +test rename-1.1 {simple renaming} { + r2 +} {procedure r1} +test rename-1.2 {simple renaming} { + list [catch r1 msg] $msg +} {1 {invalid command name "r1"}} +rename r2 {} +test rename-1.3 {simple renaming} { + list [catch r2 msg] $msg +} {1 {invalid command name "r2"}} + +# The test below is tricky because it renames a built-in command. +# It's possible that the test procedure uses this command, so must +# restore the command before calling test again. + +rename list l.new +set a [catch list msg1] +set b [l.new a b c] +rename l.new list +set c [catch l.new msg2] +set d [list 111 222] +test rename-2.1 {renaming built-in command} { + list $a $msg1 $b $c $msg2 $d +} {1 {invalid command name "list"} {a b c} 1 {invalid command name "l.new"} {111 222}} + +test rename-3.1 {error conditions} { + list [catch {rename r1} msg] $msg $errorCode +} {1 {wrong # args: should be "rename oldName newName"} NONE} +test rename-3.2 {error conditions} { + list [catch {rename r1 r2 r3} msg] $msg $errorCode +} {1 {wrong # args: should be "rename oldName newName"} NONE} +test rename-3.3 {error conditions} { + proc r1 {} {} + proc r2 {} {} + list [catch {rename r1 r2} msg] $msg +} {1 {can't rename to "r2": command already exists}} +test rename-3.4 {error conditions} { + catch {rename r1 {}} + catch {rename r2 {}} + list [catch {rename r1 r2} msg] $msg +} {1 {can't rename "r1": command doesn't exist}} +test rename-3.5 {error conditions} { + catch {rename _non_existent_command {}} + list [catch {rename _non_existent_command {}} msg] $msg +} {1 {can't delete "_non_existent_command": command doesn't exist}} + +catch {rename unknown {}} +catch {rename unknown.old unknown} + +if {[info command testdel] == "testdel"} { + test rename-4.1 {reentrancy issues with command deletion and renaming} { + set x {} + testdel {} foo {lappend x deleted; rename bar {}; lappend x [info command bar]} + rename foo bar + lappend x | + rename bar {} + set x + } {| deleted {}} + test rename-4.2 {reentrancy issues with command deletion and renaming} { + set x {} + testdel {} foo {lappend x deleted; rename foo bar} + rename foo {} + set x + } {deleted} + test rename-4.3 {reentrancy issues with command deletion and renaming} { + set x {} + testdel {} foo {lappend x deleted; testdel {} foo {lappend x deleted2}} + rename foo {} + lappend x | + rename foo {} + set x + } {deleted | deleted2} + test rename-4.4 {reentrancy issues with command deletion and renaming} { + set x {} + testdel {} foo {lappend x deleted; rename foo bar} + rename foo {} + lappend x | [info command bar] + } {deleted | {}} + test rename-4.5 {reentrancy issues with command deletion and renaming} { + set env(value) before + interp create foo + testdel foo cmd {set env(value) deleted} + interp delete foo + set env(value) + } {deleted} + test rename-4.6 {reentrancy issues with command deletion and renaming} { + proc kill args { + interp delete foo + } + set env(value) before + interp create foo + foo alias kill kill + testdel foo cmd {set env(value) deleted; kill} + list [catch {foo eval {rename cmd {}}} msg] $msg $env(value) + } {0 {} deleted} + test rename-4.7 {reentrancy issues with command deletion and renaming} { + proc kill args { + interp delete foo + } + set env(value) before + interp create foo + foo alias kill kill + testdel foo cmd {set env(value) deleted; kill} + list [catch {interp delete foo} msg] $msg $env(value) + } {0 {} deleted} +} + +# Save the unknown procedure which is modified by the following test. + +catch {rename unknown unknown.old} + +test rename-5.1 {repeated rename deletion and redefinition of same command} { + set SAVED_UNKNOWN "proc unknown " + append SAVED_UNKNOWN "\{[info args unknown.old]\} " + append SAVED_UNKNOWN "\{[info body unknown.old]\}" + + for {set i 0} {$i < 10} {incr i} { + eval $SAVED_UNKNOWN + tcl_wordBreakBefore "" 0 + rename tcl_wordBreakBefore {} + rename unknown {} + } +} {} + +catch {rename unknown {}} +catch {rename unknown.old unknown} + + +test rename-6.1 {old code invalidated (epoch incremented) when cmd with compile proc is renamed } { + proc x {} { + set a 123 + set b [incr a] + } + x + rename incr incr.old + proc incr {} {puts "new incr called!"} + catch {x} msg + set msg +} {called "incr" with too many arguments} + +catch {rename incr {}} +catch {rename incr.old incr} + +# Make the file return an empty string (cleaner.). + +set x "" + diff --git a/tests/resource.test b/tests/resource.test new file mode 100644 index 0000000..e815ef8 --- /dev/null +++ b/tests/resource.test @@ -0,0 +1,341 @@ +# Commands covered: resource +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) resource.test 1.8 97/11/06 12:36:32 + +# Only run this test on Macintosh systems +if {$tcl_platform(platform) != "macintosh"} { + return +} +if {[string compare test [info procs test]] == 1} then {source defs} + +test resource-1.1 {resource tests} { + list [catch {resource} msg] $msg +} {1 {wrong # args: should be "resource option ?arg ...?"}} +test resource-1.2 {resource tests} { + list [catch {resource _bad_} msg] $msg +} {1 {bad option "_bad_": must be close, delete, files, list, open, read, types, or write}} + +# resource open & close tests +test resource-2.1 {resource open & close tests} { + list [catch {resource open} msg] $msg +} {1 {wrong # args: should be "resource open fileName ?permissions?"}} +test resource-2.2 {resource open & close tests} { + list [catch {resource open resource.test r extraArg} msg] $msg +} {1 {wrong # args: should be "resource open fileName ?permissions?"}} +test resource-2.3 {resource open & close tests} { + list [catch {resource open resource.test bad_perms} msg] $msg +} {1 {illegal access mode "bad_perms"}} +test resource-2.4 {resource open & close tests} { + list [catch {resource open _bad_file_} msg] $msg +} {1 {file does not exist}} +test resource-2.5 {resource open & close tests} { + testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"} + set id [resource open rsrc.file] + resource close $id + file delete rsrc.file +} {} +test resource-2.6 {resource open & close tests} { + catch {file delete rsrc.file} + testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"} + set id [resource open rsrc.file] + set result [string compare [resource open rsrc.file] $id] + resource close $id + file delete rsrc.file + set result +} {0} +test resource-2.7 {resource open & close tests} { + list [catch {resource close} msg] $msg +} {1 {wrong # args: should be "resource close resourceRef"}} +test resource-2.8 {resource open & close tests} { + list [catch {resource close foo bar} msg] $msg +} {1 {wrong # args: should be "resource close resourceRef"}} +test resource-2.9 {resource open & close tests} { + list [catch {resource close _bad_resource_} msg] $msg +} {1 {invalid resource file reference "_bad_resource_"}} +test resource-2.10 {resource open & close tests} { + set result [catch {resource close System} mssg] + lappend result $mssg +} {1 {can't close "System" resource file}} +test resource-2.11 {resource open & close tests} { + set result [catch {resource close application} mssg] + lappend result $mssg +} {1 {can't close "application" resource file}} + +# Tests for listing resources +test resource-3.1 {resource list tests} { + list [catch {resource list} msg] $msg +} {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}} +test resource-3.2 {resource list tests} { + list [catch {resource list _bad_type_} msg] $msg +} {1 {expected Macintosh OS type but got "_bad_type_"}} +test resource-3.3 {resource list tests} { + list [catch {resource list TEXT _bad_ref_} msg] $msg +} {1 {invalid resource file reference "_bad_ref_"}} +test resource-3.4 {resource list tests} { + list [catch {resource list TEXT _bad_ref_ extraArg} msg] $msg +} {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}} +test resource-3.5 {resource list tests} { + catch {file delete rsrc.file} + testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"} + set id [resource open rsrc.file] + catch "resource list TEXT $id" result + resource close $id + set result +} {fileRsrcName} +test resource-3.6 {resource list tests} { + # There should not be any resource of this type + resource list XXXX +} {} +test resource-3.7 {resource list tests} { + set resourceList [resource list STR#] + if {[lsearch $resourceList {Tcl Environment Variables}] == -1} { + set result {couldn't find resource that should exist} + } else { + set result ok + } +} {ok} + +# Tests for reading resources +test resource-4.1 {resource read tests} { + list [catch {resource read} msg] $msg +} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}} +test resource-4.2 {resource read tests} { + list [catch {resource read TEXT} msg] $msg +} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}} +test resource-4.3 {resource read tests} { + list [catch {resource read STR# {_non_existant_resource_}} msg] $msg +} {1 {could not load resource}} +test resource-4.4 {resource read tests} { + # The following resource should exist and load OK without error + catch {resource read STR# {Tcl Environment Variables}} +} {0} + +# Tests for getting resource types +test resource-5.1 {resource types tests} { + list [catch {resource types _bad_ref_} msg] $msg +} {1 {invalid resource file reference "_bad_ref_"}} +test resource-5.2 {resource types tests} { + list [catch {resource types _bad_ref_ extraArg} msg] $msg +} {1 {wrong # args: should be "resource types ?resourceRef?"}} +test resource-5.3 {resource types tests} { + # This should never cause an error + catch {resource types} +} {0} +test resource-5.4 {resource types tests} { + testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"} + set id [resource open rsrc.file] + set result [resource types $id] + resource close $id + set result +} {TEXT} + +# resource write tests +test resource-6.1 {resource write tests} { + list [catch {resource write} msg] $msg +} {1 {wrong # args: should be "resource write ?-id resourceId? ?-name resourceName? ?-file resourceRef? ?-force? resourceType data"}} +test resource-6.2 {resource write tests} { + list [catch {resource write _bad_type_ data} msg] $msg +} {1 {expected Macintosh OS type but got "_bad_type_"}} +test resource-6.3 {resource write tests} { + catch {file delete rsrc2.file} + set id [resource open rsrc2.file w] + resource close $id + set id [resource open rsrc2.file r] + set result [catch {resource write -file $id -name Hello TEXT foo} errMsg] + lappend result [string compare $errMsg "cannot write to resource file \"$id\", it was opened read only"] + lappend result [lsearch [resource list TEXT $id] Hello] + resource close $id + file delete rsrc2.file + set result +} {1 0 -1} +test resource-6.4 {resource write tests} { + catch {file delete rsrc2.file} + set id [resource open rsrc2.file w] + resource write -file $id -name Hello TEXT {set x "our test data"} + source -rsrc Hello rsrc2.file + resource close $id + file delete rsrc2.file + set x +} {our test data} +test resource-6.5 {resource write tests} { + catch {file delete rsrc2.file} + set id [resource open rsrc2.file w] + resource write -file $id -id 256 TEXT {HAHAHAHAHAHAHA} + set result [catch {resource write -file $id -id 256 TEXT {HOHOHOHOHOHO}} mssg] + resource close $id + file delete rsrc2.file + lappend result $mssg +} {1 {the resource 256 already exists, use "-force" to overwrite it.}} +test resource-6.6 {resource write tests} { + catch {file delete rsrc2.file} + testWriteTextResource -rsrc fileRsrcName -rsrcid 256 -file rsrc2.file -protected {error "don't tread on me"} + set id [resource open rsrc2.file w] + set result [catch {resource write -id 256 -force -file $id TEXT {NAHNAHNANAHNAH}} mssg] + resource close $id + file delete rsrc2.file + lappend result $mssg +} {1 {could not write resource id 256 of type TEXT, it was protected.}} +test resource-6.7 {resource write tests} { + catch {file delete rsrc2.file} + set id [resource open rsrc2.file w] + resource write -file $id -id 256 -name FOO TEXT {set x [list "our first test data"]} + resource write -file $id -id 256 -name BAR -force TEXT {set x [list "our second test data"]} + source -rsrcid 256 rsrc2.file + lappend x [resource list TEXT $id] + resource close $id + file delete rsrc2.file + set x +} {{our second test data} BAR} + +#Tests for listing open resource files +test resource-7.1 {resource file tests} { + catch {resource files foo bar} mssg + set mssg +} {wrong # args: should be "resource files ?resourceId?"} +test resource-7.2 {resource file tests} { + catch {file delete rsrc2.file} + set rsrcFiles [resource files] + set id [resource open rsrc2.file w] + set result [string compare $rsrcFiles [lrange [resource files] 1 end]] + lappend result [string compare $id [lrange [resource files] 0 0]] + resource close $id + file delete rsrc2.file + set result +} {0 0} +test resource-7.3 {resource file tests} { + set result 0 + foreach file [resource files] { + if {[catch {resource types $file}] != 0} { + set result 1 + } + } + set result +} {0} +test resource-7.4 {resource file tests} { + catch {resource files __NO_SUCH_RESOURCE__} mssg + set mssg +} {invalid resource file reference "__NO_SUCH_RESOURCE__"} +test resource-7.5 {resource file tests} { + set sys [resource files System] + string compare $sys [file join $env(SYS_FOLDER) System] +} {0} +test resource-7.6 {resource file tests} { + set app [resource files application] + string compare $app [info nameofexecutable] +} {0} + +#Tests for the resource delete command +test resource-8.1 {resource delete tests} { + list [catch {resource delete} msg] $msg +} {1 {wrong # args: should be "resource delete ?-id resourceId? ?-name resourceName? ?-file resourceRef? resourceType"}} +test resource-8.2 {resource delete tests} { + list [catch {resource delete TEXT} msg] $msg +} {1 {you must specify either "-id" or "-name" or both to "resource delete"}} +test resource-8.3 {resource delete tests} { + set result [catch {resource delete -file ffffff -id 128 TEXT} mssg] + lappend result $mssg +} {1 {invalid resource file reference "ffffff"}} +test resource-8.4 {resource delete tests} { + catch {file delete rsrc2.file} + testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff} + set id [resource open rsrc2.file r] + set result [catch {resource delete -id 128 -file $id TEXT} mssg] + resource close $id + file delete rsrc2.file + lappend result [string compare $mssg "cannot delete from resource file \"$id\", it was opened read only"] +} {1 0} +test resource-8.5 {resource delete tests} { + catch {file delete rsrc2.file} + testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff} + set id [resource open rsrc2.file w] + set result [catch {resource delete -id 128 -file $id _bad_type_} mssg] + resource close $id + file delete rsrc2.file + lappend result $mssg +} {1 {expected Macintosh OS type but got "_bad_type_"}} +test resource-8.5 {resource delete tests} { + catch {file delete rsrc2.file} + set id [resource open rsrc2.file w] + set result [catch {resource delete -id 128 -file $id TEXT} mssg] + resource close $id + file delete rsrc2.file + lappend result $mssg +} {1 {resource not found}} +test resource-8.6 {resource delete tests} { + catch {file delete rsrc2.file} + set id [resource open rsrc2.file w] + set result [catch {resource delete -name foo -file $id TEXT} mssg] + resource close $id + file delete rsrc2.file + lappend result $mssg +} {1 {resource not found}} +test resource-8.7 {resource delete tests} { + catch {file delete rsrc2.file} + set id [resource open rsrc2.file w] + resource write -file $id -name foo -id 128 TEXT {some stuff} + resource write -file $id -name bar -id 129 TEXT {some stuff} + set result [catch {resource delete -name foo -id 129 -file $id TEXT} mssg] + resource close $id + file delete rsrc2.file + lappend result $mssg +} {1 {"-id" and "-name" values do not point to the same resource}} +test resource-8.8 {resource delete tests} { + catch {file delete rsrc2.file} + testWriteTextResource -rsrc fileRsrcName -rsrcid 256 -file rsrc2.file -protected {error "don't tread on me"} + set id [resource open rsrc2.file w] + set result [catch {resource delete -id 256 -file $id TEXT } mssg] + resource close $id + file delete rsrc2.file + lappend result $mssg +} {1 {resource cannot be deleted: it is protected.}} +test resource-8.9 {resource delete tests} { + catch {file delete rsrc2.file} + testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff} + set id [resource open rsrc2.file w] + set result [resource list TEXT $id] + resource delete -id 128 -file $id TEXT + lappend result [resource list TEXT $id] + resource close $id + file delete rsrc2.file + set result +} {fileRsrcName {}} + +# Tests for the Mac version of the source command +catch {file delete rsrc.file} +testWriteTextResource -rsrc fileRsrcName -rsrcid 128 \ + -file rsrc.file {set rsrc_foo 1} +test resource-9.1 {source command} { + catch {unset rsrc_foo} + source -rsrc fileRsrcName rsrc.file + list [catch {set rsrc_foo} msg] $msg +} {0 1} +test resource-9.2 {source command} { + catch {unset rsrc_foo} + list [catch {source -rsrc no_resource rsrc.file} msg] $msg +} {1 {The resource "no_resource" could not be loaded from rsrc.file.}} +test resource-9.3 {source command} { + catch {unset rsrc_foo} + source -rsrcid 128 rsrc.file + list [catch {set rsrc_foo} msg] $msg +} {0 1} +test resource-9.4 {source command} { + catch {unset rsrc_foo} + list [catch {source -rsrcid bad_int rsrc.file} msg] $msg +} {1 {expected integer but got "bad_int"}} +test resource-9.5 {source command} { + catch {unset rsrc_foo} + list [catch {source -rsrcid 100 rsrc.file} msg] $msg +} {1 {The resource "ID=100" could not be loaded from rsrc.file.}} + +# Clean up and return +catch {file delete rsrc.file} +return diff --git a/tests/safe.test b/tests/safe.test new file mode 100644 index 0000000..c23f06a --- /dev/null +++ b/tests/safe.test @@ -0,0 +1,433 @@ +# safe.test -- +# +# This file contains a collection of tests for safe Tcl, packages loading, +# and using safe interpreters. Sourcing this file into tcl runs the tests +# and generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) safe.test 1.34 97/11/19 14:59:13 + +if {[string compare test [info procs test]] == 1} then {source defs} + +foreach i [interp slaves] { + interp delete $i +} + +# Force actual loading of the safe package +# because we use un exported (and thus un-autoindexed) APIs +# in this test result arguments: +catch {safe::interpConfigure} + +proc equiv {x} {return $x} + +test safe-1.1 {safe::interpConfigure syntax} { + list [catch {safe::interpConfigure} msg] $msg; +} {1 {no value given for parameter "slave" (use -help for full usage) : + slave name () name of the slave}} + +test safe-1.2 {safe::interpCreate syntax} { + list [catch {safe::interpCreate -help} msg] $msg; +} {1 {Usage information: + Var/FlagName Type Value Help + ------------ ---- ----- ---- + ( -help gives this help ) + ?slave? name () name of the slave (optional) + -accessPath list () access path for the slave + -noStatics boolflag (false) prevent loading of statically linked pkgs + -statics boolean (true) loading of statically linked pkgs + -nestedLoadOk boolflag (false) allow nested loading + -nested boolean (false) nested loading + -deleteHook script () delete hook}} + +test safe-1.3 {safe::interpInit syntax} { + list [catch {safe::interpInit -noStatics} msg] $msg; +} {1 {bad value "-noStatics" for parameter + slave name () name of the slave}} + + +test safe-2.1 {creating interpreters, should have no aliases} { + interp aliases +} "" +test safe-2.2 {creating interpreters, should have no aliases} { + catch {safe::interpDelete a} + interp create a + set l [a aliases] + safe::interpDelete a + set l +} "" +test safe-2.3 {creating safe interpreters, should have no aliases} { + catch {safe::interpDelete a} + interp create a -safe + set l [a aliases] + interp delete a + set l +} "" + +test safe-3.1 {calling safe::interpInit is safe} { + catch {safe::interpDelete a} + interp create a -safe + safe::interpInit a + catch {interp eval a exec ls} msg + safe::interpDelete a + set msg +} {invalid command name "exec"} +test safe-3.2 {calling safe::interpCreate on trusted interp} { + catch {safe::interpDelete a} + safe::interpCreate a + set l [lsort [a aliases]] + safe::interpDelete a + set l +} {exit file load source} +test safe-3.3 {calling safe::interpCreate on trusted interp} { + catch {safe::interpDelete a} + safe::interpCreate a + set x [interp eval a {source [file join $tcl_library init.tcl]}] + safe::interpDelete a + set x +} "" +test safe-3.4 {calling safe::interpCreate on trusted interp} { + catch {safe::interpDelete a} + safe::interpCreate a + catch {set x \ + [interp eval a {source [file join $tcl_library init.tcl]}]} msg + safe::interpDelete a + list $x $msg +} {{} {}} + +test safe-4.1 {safe::interpDelete} { + catch {safe::interpDelete a} + interp create a + safe::interpDelete a +} "" +test safe-4.2 {safe::interpDelete, indirectly} { + catch {safe::interpDelete a} + interp create a + a alias exit safe::interpDelete a + a eval exit +} "" +test safe-4.3 {safe::interpDelete, state array (not a public api)} { + catch {safe::interpDelete a} + namespace eval safe {set [InterpStateName a](foo) 33} + # not an error anymore to call it if interp is already + # deleted, to make trhings smooth if it's called twice... + catch {safe::interpDelete a} m1 + catch {namespace eval safe {set [InterpStateName a](foo)}} m2 + list $m1 $m2 +} "{}\ + {can't read \"[safe::InterpStateName a]\": no such variable}" + + +test safe-4.4 {safe::interpDelete, state array, indirectly (not a public api)} { + catch {safe::interpDelete a} + safe::interpCreate a + namespace eval safe {set [InterpStateName a](foo) 33} + a eval exit + catch {namespace eval safe {set [InterpStateName a](foo)}} msg +} 1 + +test safe-4.5 {safe::interpDelete} { + catch {safe::interpDelete a} + safe::interpCreate a + catch {safe::interpCreate a} msg + set msg +} {interpreter named "a" already exists, cannot create} +test safe-4.6 {safe::interpDelete, indirectly} { + catch {safe::interpDelete a} + safe::interpCreate a + a eval exit +} "" + +# The following test checks whether the definition of tcl_endOfWord can be +# obtained from auto_loading. + +test safe-5.1 {test auto-loading in safe interpreters} { + catch {safe::interpDelete a} + safe::interpCreate a + set r [catch {interp eval a {tcl_endOfWord "" 0}} msg] + safe::interpDelete a + list $r $msg +} {0 -1} + +# test safe interps 'information leak' +proc SI {} { + global I + set I [interp create -safe]; +} +proc DI {} { + global I; + interp delete $I; +} +test safe-6.1 {test safe interpreters knowledge of the world} { + SI; set r [lsort [$I eval {info globals}]]; DI; set r +} {tcl_interactive tcl_patchLevel tcl_platform tcl_version} +test safe-6.2 {test safe interpreters knowledge of the world} { + SI; set r [$I eval {info script}]; DI; set r +} {} +test safe-6.3 {test safe interpreters knowledge of the world} { + SI; set r [lsort [$I eval {array names tcl_platform}]]; DI; set r +} {byteOrder platform} + +# more test should be added to check that hostname, nameofexecutable, +# aren't leaking infos, but they still do... + +# high level general test +test safe-7.1 {tests that everything works at high level} { + set i [safe::interpCreate]; + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs + # so package require in a slave works like in the master) + set v [interp eval $i {package require http 1}] + # no error shall occur: + interp eval $i {http_config}; + safe::interpDelete $i + set v +} 1.0 + +test safe-7.2 {tests specific path and interpFind/AddToAccessPath} { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]; + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p1 + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]; + # an error shall occur (http is not anymore in the secure 0-level + # provided deep path) + list $token1 $token2 \ + [catch {interp eval $i {package require http 1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} "{\$p(:0:)} {\$p(:1:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" + + +# test source control on file name +test safe-8.1 {safe source control on file} { + set i "a"; + catch {safe::interpDelete $i} + safe::interpCreate $i; + list [catch {$i eval {source}} msg] \ + $msg \ + [safe::interpDelete $i] ; +} {1 {wrong # args: should be "source fileName"} {}} + +# test source control on file name +test safe-8.2 {safe source control on file} { + set i "a"; + catch {safe::interpDelete $i} + safe::interpCreate $i; + list [catch {$i eval {source}} msg] \ + $msg \ + [safe::interpDelete $i] ; +} {1 {wrong # args: should be "source fileName"} {}} + +test safe-8.3 {safe source control on file} { + set i "a"; + catch {safe::interpDelete $i} + safe::interpCreate $i; + set log {}; + proc safe-test-log {str} {global log; lappend log $str} + set prevlog [safe::setLogCmd]; + safe::setLogCmd safe-test-log; + list [catch {$i eval {source .}} msg] \ + $msg \ + $log \ + [safe::setLogCmd $prevlog; unset log] \ + [safe::interpDelete $i] ; +} {1 {permission denied} {{ERROR for slave a : ".": is a directory}} {} {}} + + +test safe-8.4 {safe source control on file} { + set i "a"; + catch {safe::interpDelete $i} + safe::interpCreate $i; + set log {}; + proc safe-test-log {str} {global log; lappend log $str} + set prevlog [safe::setLogCmd]; + safe::setLogCmd safe-test-log; + list [catch {$i eval {source /abc/def}} msg] \ + $msg \ + $log \ + [safe::setLogCmd $prevlog; unset log] \ + [safe::interpDelete $i] ; +} {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}} {} {}} + + +test safe-8.5 {safe source control on file} { + set i "a"; + catch {safe::interpDelete $i} + safe::interpCreate $i; + set log {}; + proc safe-test-log {str} {global log; lappend log $str} + set prevlog [safe::setLogCmd]; + safe::setLogCmd safe-test-log; + list [catch {$i eval {source [file join [info lib] blah]}} msg] \ + $msg \ + $log \ + [safe::setLogCmd $prevlog; unset log] \ + [safe::interpDelete $i] ; +} "1 {blah: must be a *.tcl or tclIndex} {{ERROR for slave a : [file join [info library] blah]:blah: must be a *.tcl or tclIndex}} {} {}" + + +test safe-8.6 {safe source control on file} { + set i "a"; + catch {safe::interpDelete $i} + safe::interpCreate $i; + set log {}; + proc safe-test-log {str} {global log; lappend log $str} + set prevlog [safe::setLogCmd]; + safe::setLogCmd safe-test-log; + list [catch {$i eval {source [file join [info lib] blah.tcl]}} msg] \ + $msg \ + $log \ + [safe::setLogCmd $prevlog; unset log] \ + [safe::interpDelete $i] ; +} "1 {no such file or directory} {{ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory}} {} {}" + + +test safe-8.7 {safe source control on file} { + set i "a"; + catch {safe::interpDelete $i} + safe::interpCreate $i; + set log {}; + proc safe-test-log {str} {global log; lappend log $str} + set prevlog [safe::setLogCmd]; + safe::setLogCmd safe-test-log; + list [catch {$i eval {source [file join [info lib] xxxxxxxxxxx.tcl]}}\ + msg] \ + $msg \ + $log \ + [safe::setLogCmd $prevlog; unset log] \ + [safe::interpDelete $i] ; +} "1 {xxxxxxxxxxx.tcl: filename too long} {{ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:xxxxxxxxxxx.tcl: filename too long}} {} {}" + +test safe-8.8 {safe source forbids -rsrc} { + set i "a"; + catch {safe::interpDelete $i} + safe::interpCreate $i; + list [catch {$i eval {source -rsrc Init}} msg] \ + $msg \ + [safe::interpDelete $i] ; +} {1 {wrong # args: should be "source fileName"} {}} + + +test safe-9.1 {safe interps' deleteHook} { + set i "a"; + catch {safe::interpDelete $i} + set res {} + proc testDelHook {args} { + global res; + # the interp still exists at that point + interp eval a {set delete 1} + # mark that we've been here (successfully) + set res $args; + } + safe::interpCreate $i -deleteHook "testDelHook arg1 arg2"; + list [interp eval $i exit] $res +} {{} {arg1 arg2 a}} + +test safe-9.2 {safe interps' error in deleteHook} { + set i "a"; + catch {safe::interpDelete $i} + set res {} + proc testDelHook {args} { + global res; + # the interp still exists at that point + interp eval a {set delete 1} + # mark that we've been here (successfully) + set res $args; + # create an exception + error "being catched"; + } + set log {}; + proc safe-test-log {str} {global log; lappend log $str} + safe::interpCreate $i -deleteHook "testDelHook arg1 arg2"; + set prevlog [safe::setLogCmd]; + safe::setLogCmd safe-test-log; + list [safe::interpDelete $i] $res \ + $log \ + [safe::setLogCmd $prevlog; unset log]; +} {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}} {}} + + +test safe-9.3 {dual specification of statics} { + list [catch {safe::interpCreate -stat true -nostat} msg] $msg +} {1 {conflicting values given for -statics and -noStatics}} + +test safe-9.4 {dual specification of statics} { + # no error shall occur + safe::interpDelete [safe::interpCreate -stat false -nostat] +} {} + +test safe-9.5 {dual specification of nested} { + list [catch {safe::interpCreate -nested 0 -nestedload} msg] $msg +} {1 {conflicting values given for -nested and -nestedLoadOk}} + +test safe-9.6 {interpConfigure widget like behaviour} { + # this test shall work, don't try to "fix it" unless + # you *really* know what you are doing (ie you are me :p) -- dl + list [set i [safe::interpCreate \ + -noStatics \ + -nestedLoadOk \ + -deleteHook {foo bar}]; + safe::interpConfigure $i -accessPath /foo/bar ; + safe::interpConfigure $i]\ + [safe::interpConfigure $i -aCCess]\ + [safe::interpConfigure $i -nested]\ + [safe::interpConfigure $i -statics]\ + [safe::interpConfigure $i -DEL]\ + [safe::interpConfigure $i -accessPath /blah -statics 1; + safe::interpConfigure $i]\ + [safe::interpConfigure $i -deleteHook toto -nosta -nested 0; + safe::interpConfigure $i] +} {{-accessPath /foo/bar -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath /foo/bar} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath /blah -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath /blah -statics 0 -nested 0 -deleteHook toto}} + + +# testing that nested and statics do what is advertised +# (we use a static package : Tcltest) + +if {[catch {package require Tcltest} msg]} { + puts "This application hasn't been compiled with Tcltest" + puts "skipping remining safe test that relies on it." +} else { + + # we use the Tcltest package , which has no Safe_Init + +test safe-10.1 {testing statics loading} { + set i [safe::interpCreate] + list \ + [catch {interp eval $i {load {} Tcltest}} msg] \ + $msg \ + [safe::interpDelete $i]; +} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}} + +test safe-10.2 {testing statics loading / -nostatics} { + set i [safe::interpCreate -nostatics] + list \ + [catch {interp eval $i {load {} Tcltest}} msg] \ + $msg \ + [safe::interpDelete $i]; +} {1 {permission denied (static package)} {}} + + + +test safe-10.3 {testing nested statics loading / no nested by default} { + set i [safe::interpCreate] + list \ + [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \ + $msg \ + [safe::interpDelete $i]; +} {1 {permission denied (nested load)} {}} + + +test safe-10.4 {testing nested statics loading / -nestedloadok} { + set i [safe::interpCreate -nestedloadok] + list \ + [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \ + $msg \ + [safe::interpDelete $i]; +} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}} + + +} diff --git a/tests/scan.test b/tests/scan.test new file mode 100644 index 0000000..50bf876 --- /dev/null +++ b/tests/scan.test @@ -0,0 +1,246 @@ +# Commands covered: scan +# +# 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-1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) scan.test 1.26 97/08/06 08:56:08 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test scan-1.1 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "-20 1476 \n33 0" "%d %d %d %d" a b c d] $a $b $c $d +} {4 -20 1476 33 0} +test scan-1.2 {integer scanning} { + set a {}; set b {}; set c {} + list [scan "-45 16 7890 +10" "%2d %*d %10d %d" a b c] $a $b $c +} {3 -4 16 7890} +test scan-1.3 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "-45 16 +10 987" "%ld %d %ld %d" a b c d] $a $b $c $d +} {4 -45 16 10 987} +test scan-1.4 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "14 1ab 62 10" "%d %x %lo %x" a b c d] $a $b $c $d +} {4 14 427 50 16} +test scan-1.5 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "12345670 1234567890ab cdefg" "%o %o %x %lx" a b c d] \ + $a $b $c $d +} {4 2739128 342391 561323 52719} +test scan-1.6 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "ab123-24642" "%2x %3x %3o %2o" a b c d] $a $b $c $d +} {4 171 291 -20 52} +test scan-1.7 {integer scanning} { + set a {}; set b {} + list [scan "1234567 234 567 " "%*3x %x %*o %4o" a b] $a $b +} {2 17767 375} +test scan-1.8 {integer scanning} { + set a {}; set b {} + list [scan "a 1234" "%d %d" a b] $a $b +} {0 {} {}} +test scan-1.9 {integer scanning} { + set a {}; set b {}; set c {}; set d {}; + list [scan "12345678" "%2d %2d %2ld %2d" a b c d] $a $b $c $d +} {4 12 34 56 78} +test scan-1.10 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d +} {2 1 2 {} {}} +# +# The behavior for scaning intergers larger than MAX_INT is +# not defined by the ANSI spec. Some implementations wrap the +# input (-16) some return MAX_INT. +# +test scan-1.11 {integer scanning} {nonPortable} { + set a {}; set b {}; + list [scan "4294967280 4294967280" "%u %d" a b] $a $b +} {2 4294967280 -16} + +test scan-2.1 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d +} {3 2.1 -300000000.0 0.99962 {}} +test scan-2.2 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "-1.2345 +8.2 9" "%3e %3lf %f %f" a b c d] $a $b $c $d +} {4 -1.0 234.0 5.0 8.2} +test scan-2.3 {floating-point scanning} { + set a {}; set b {}; set c {} + list [scan "1e00004 332E-4 3e+4" "%Lf %*2e %f %f" a b c] $a $c +} {3 10000.0 30000.0} +# +# Some libc implementations consider 3.e- bad input. The ANSI +# spec states that digits must follow the - sign. +# +test scan-2.4 {floating-point scanning} {nonPortable} { + set a {}; set b {}; set c {} + list [scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c] $a $b $c +} {3 1.0 200.0 3.0} +test scan-2.5 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d +} {4 4.6 99999.7 87.643 118.0} +test scan-2.6 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d +} {4 1.2345 0.697 124.0 5e-05} +test scan-2.7 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d +} {1 4.6 {} {} {}} +test scan-2.8 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d +} {2 4.6 5.2 {} {}} + +test scan-3.1 {string and character scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "abc defghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d +} {4 abc def ghijk dum} +test scan-3.2 {string and character scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "a bcdef" "%c%c%1s %s" a b c d] $a $b $c $d +} {4 97 32 b cdef} +test scan-3.3 {string and character scanning} { + set a {}; set b {}; set c {} + list [scan "123456 test " "%*c%*s %s %s %s" a b c] $a $b $c +} {1 test {} {}} +test scan-3.4 {string and character scanning} { + set a {}; set b {}; set c {}; set d + list [scan "ababcd01234 f 123450" {%4[abcd] %4[abcd] %[^abcdef] %[^0]} a b c d] $a $b $c $d +} {4 abab cd {01234 } {f 12345}} +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-4.1 {error conditions} { + catch {scan a} +} 1 +test scan-4.2 {error conditions} { + catch {scan a} msg + set msg +} {wrong # args: should be "scan string format ?varName varName ...?"} +test scan-4.3 {error conditions} { + catch {scan "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21} +} 1 +test scan-4.4 {error conditions} { + catch {scan "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21} msg + set msg +} {too many fields to scan} +test scan-4.5 {error conditions} { + list [catch {scan a %D} msg] $msg +} {1 {bad scan conversion character "D"}} +test scan-4.6 {error conditions} { + list [catch {scan a %O} msg] $msg +} {1 {bad scan conversion character "O"}} +test scan-4.7 {error conditions} { + list [catch {scan a %X} msg] $msg +} {1 {bad scan conversion character "X"}} +test scan-4.8 {error conditions} { + list [catch {scan a %F} msg] $msg +} {1 {bad scan conversion character "F"}} +test scan-4.9 {error conditions} { + list [catch {scan a %E} msg] $msg +} {1 {bad scan conversion character "E"}} +test scan-4.10 {error conditions} { + list [catch {scan a "%d %d" a} msg] $msg +} {1 {different numbers of variable names and field specifiers}} +test scan-4.11 {error conditions} { + list [catch {scan a "%d %d" a b c} msg] $msg +} {1 {different numbers of variable names and field specifiers}} +test scan-4.12 {error conditions} { + set a {}; set b {}; set c {}; set d {} + list [expr {[scan " a" " a %d %d %d %d" a b c d] <= 0}] $a $b $c $d +} {1 {} {} {} {}} +test scan-4.13 {error conditions} { + set a {}; set b {}; set c {}; set d {} + list [scan "1 2" "%d %d %d %d" a b c d] $a $b $c $d +} {2 1 2 {} {}} +test scan-4.14 {error conditions} { + catch {unset a} + set a(0) 44 + list [catch {scan 44 %d a} msg] $msg +} {1 {couldn't set variable "a"}} +test scan-4.15 {error conditions} { + catch {unset a} + set a(0) 44 + list [catch {scan 44 %c a} msg] $msg +} {1 {couldn't set variable "a"}} +test scan-4.16 {error conditions} { + catch {unset a} + set a(0) 44 + list [catch {scan 44 %s a} msg] $msg +} {1 {couldn't set variable "a"}} +test scan-4.17 {error conditions} { + catch {unset a} + set a(0) 44 + list [catch {scan 44 %f a} msg] $msg +} {1 {couldn't set variable "a"}} +test scan-4.18 {error conditions} { + catch {unset a} + set a(0) 44 + list [catch {scan 44 %f a} msg] $msg +} {1 {couldn't set variable "a"}} +catch {unset a} +test scan-4.19 {error conditions} { + list [catch {scan 44 %2c a} msg] $msg +} {1 {field width may not be specified in %c conversion}} +test scan-4.20 {error conditions} { + list [catch {scan abc {%[}} msg] $msg +} {1 {unmatched [ in format string}} + +test scan-5.1 {lots of arguments} { + scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 +} 20 +test scan-5.2 {lots of arguments} { + scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 + set a20 +} 200 + +test scan-6.1 {miscellaneous tests} { + set a {} + list [scan ab16c ab%dc a] $a +} {1 16} +test scan-6.2 {miscellaneous tests} { + set a {} + list [scan ax16c ab%dc a] $a +} {0 {}} +test scan-6.3 {miscellaneous tests} { + set a {} + list [catch {scan ab%c114 ab%%c%d a} msg] $msg $a +} {0 1 114} +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-7.1 {alignment in results array (TCL_ALIGN)} { + scan "123 13.6" "%s %f" a b + set b +} 13.6 +test scan-7.2 {alignment in results array (TCL_ALIGN)} { + scan "1234567 13.6" "%s %f" a b + set b +} 13.6 +test scan-7.3 {alignment in results array (TCL_ALIGN)} { + scan "12345678901 13.6" "%s %f" a b + set b +} 13.6 +test scan-7.4 {alignment in results array (TCL_ALIGN)} { + scan "123456789012345 13.6" "%s %f" a b + set b +} 13.6 +test scan-7.5 {alignment in results array (TCL_ALIGN)} { + scan "1234567890123456789 13.6" "%s %f" a b + set b +} 13.6 diff --git a/tests/set-old.test b/tests/set-old.test new file mode 100644 index 0000000..a101e7b --- /dev/null +++ b/tests/set-old.test @@ -0,0 +1,771 @@ +# Commands covered: set, unset, array +# +# This file includes the original set of tests for Tcl's set command. +# Since the set command is now compiled, a new set of tests covering +# the new implementation is in the file "set.test". Sourcing this file +# into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) set-old.test 1.22 97/10/29 14:05:07 + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc ignore args {} + +# Simple variable operations. + +catch {unset a} +test set-old-1.1 {basic variable setting and unsetting} { + set a 22 +} 22 +test set-old-1.2 {basic variable setting and unsetting} { + set a 123 + set a +} 123 +test set-old-1.3 {basic variable setting and unsetting} { + set a xxx + format %s $a +} xxx +test set-old-1.4 {basic variable setting and unsetting} { + set a 44 + unset a + list [catch {set a} msg] $msg +} {1 {can't read "a": no such variable}} + +# Basic array operations. + +catch {unset a} +set a(xyz) 2 +set a(44) 3 +set {a(a long name)} test +test set-old-2.1 {basic array operations} { + lsort [array names a] +} {44 {a long name} xyz} +test set-old-2.2 {basic array operations} { + set a(44) +} 3 +test set-old-2.3 {basic array operations} { + set a(xyz) +} 2 +test set-old-2.4 {basic array operations} { + set "a(a long name)" +} test +test set-old-2.5 {basic array operations} { + list [catch {set a(other)} msg] $msg +} {1 {can't read "a(other)": no such element in array}} +test set-old-2.6 {basic array operations} { + list [catch {set a} msg] $msg +} {1 {can't read "a": variable is array}} +test set-old-2.7 {basic array operations} { + format %s $a(44) +} 3 +test set-old-2.8 {basic array operations} { + format %s $a(a long name) +} test +unset a(44) +test set-old-2.9 {basic array operations} { + lsort [array names a] +} {{a long name} xyz} +test set-old-2.10 {basic array operations} { + catch {unset b} + list [catch {set b(123)} msg] $msg +} {1 {can't read "b(123)": no such variable}} +test set-old-2.11 {basic array operations} { + catch {unset b} + set b 44 + list [catch {set b(123)} msg] $msg +} {1 {can't read "b(123)": variable isn't array}} +test set-old-2.12 {basic array operations} { + list [catch {set a 14} msg] $msg +} {1 {can't set "a": variable is array}} +unset a +test set-old-2.13 {basic array operations} { + list [catch {set a(xyz)} msg] $msg +} {1 {can't read "a(xyz)": no such variable}} + +# Test the set commands, and exercise the corner cases of the code +# that parses array references into two parts. + +test set-old-3.1 {set command} { + list [catch {set} msg] $msg +} {1 {wrong # args: should be "set varName ?newValue?"}} +test set-old-3.2 {set command} { + list [catch {set x y z} msg] $msg +} {1 {wrong # args: should be "set varName ?newValue?"}} +test set-old-3.3 {set command} { + catch {unset a} + list [catch {set a} msg] $msg +} {1 {can't read "a": no such variable}} +test set-old-3.4 {set command} { + catch {unset a} + set a(14) 83 + list [catch {set a 22} msg] $msg +} {1 {can't set "a": variable is array}} + +# Test the corner-cases of parsing array names, using set and unset. + +test set-old-4.1 {parsing array names} { + catch {unset a} + set a(()) 44 + list [catch {array names a} msg] $msg +} {0 ()} +test set-old-4.2 {parsing array names} { + catch {unset a a(abcd} + set a(abcd 33 + info exists a(abcd +} 1 +test set-old-4.3 {parsing array names} { + catch {unset a a(abcd} + set a(abcd 33 + list [catch {array names a} msg] $msg +} {0 {}} +test set-old-4.4 {parsing array names} { + catch {unset a abcd)} + set abcd) 33 + info exists abcd) +} 1 +test set-old-4.5 {parsing array names} { + set a(bcd yyy + catch {unset a} + list [catch {set a(bcd} msg] $msg +} {0 yyy} +test set-old-4.6 {parsing array names} { + catch {unset a} + set a 44 + list [catch {set a(bcd test} msg] $msg +} {0 test} + +# Errors in reading variables + +test set-old-5.1 {errors in reading variables} { + catch {unset a} + list [catch {set a} msg] $msg +} {1 {can't read "a": no such variable}} +test set-old-5.2 {errors in reading variables} { + catch {unset a} + set a 44 + list [catch {set a(18)} msg] $msg +} {1 {can't read "a(18)": variable isn't array}} +test set-old-5.3 {errors in reading variables} { + catch {unset a} + set a(6) 44 + list [catch {set a(18)} msg] $msg +} {1 {can't read "a(18)": no such element in array}} +test set-old-5.4 {errors in reading variables} { + catch {unset a} + set a(6) 44 + list [catch {set a} msg] $msg +} {1 {can't read "a": variable is array}} + +# Errors and other special cases in writing variables + +test set-old-6.1 {creating array during write} { + catch {unset a} + trace var a rwu ignore + list [catch {set a(14) 186} msg] $msg [array names a] +} {0 186 14} +test set-old-6.2 {errors in writing variables} { + catch {unset a} + set a xxx + list [catch {set a(14) 186} msg] $msg +} {1 {can't set "a(14)": variable isn't array}} +test set-old-6.3 {errors in writing variables} { + catch {unset a} + set a(100) yyy + list [catch {set a 2} msg] $msg +} {1 {can't set "a": variable is array}} +test set-old-6.4 {expanding variable size} { + catch {unset a} + list [set a short] [set a "longer name"] [set a "even longer name"] \ + [set a "a much much truly longer name"] +} {short {longer name} {even longer name} {a much much truly longer name}} + +# Unset command, Tcl_UnsetVar procedures + +test set-old-7.1 {unset command} { + catch {unset a}; catch {unset b}; catch {unset c}; catch {unset d} + set a 44 + set b 55 + set c 66 + set d 77 + unset a b c + list [catch {set a(0) 0}] [catch {set b(0) 0}] [catch {set c(0) 0}] \ + [catch {set d(0) 0}] +} {0 0 0 1} +test set-old-7.2 {unset command} { + list [catch {unset} msg] $msg +} {1 {wrong # args: should be "unset varName ?varName ...?"}} +test set-old-7.3 {unset command} { + catch {unset a} + list [catch {unset a} msg] $msg +} {1 {can't unset "a": no such variable}} +test set-old-7.4 {unset command} { + catch {unset a} + set a 44 + list [catch {unset a(14)} msg] $msg +} {1 {can't unset "a(14)": variable isn't array}} +test set-old-7.5 {unset command} { + catch {unset a} + set a(0) xx + list [catch {unset a(14)} msg] $msg +} {1 {can't unset "a(14)": no such element in array}} +test set-old-7.6 {unset command} { + catch {unset a}; catch {unset b}; catch {unset c} + set a foo + set c gorp + list [catch {unset a a a(14)} msg] $msg [info exists c] +} {1 {can't unset "a": no such variable} 1} +test set-old-7.7 {unsetting globals from within procedures} { + set y 0 + proc p1 {} { + global y + set z [p2] + return [list $z [catch {set y} msg] $msg] + } + proc p2 {} {global y; unset y; list [catch {set y} msg] $msg} + p1 +} {{1 {can't read "y": no such variable}} 1 {can't read "y": no such variable}} +test set-old-7.8 {unsetting globals from within procedures} { + set y 0 + proc p1 {} { + global y + p2 + return [list [catch {set y 44} msg] $msg] + } + proc p2 {} {global y; unset y} + concat [p1] [list [catch {set y} msg] $msg] +} {0 44 0 44} +test set-old-7.9 {unsetting globals from within procedures} { + set y 0 + proc p1 {} { + global y + unset y + return [list [catch {set y 55} msg] $msg] + } + concat [p1] [list [catch {set y} msg] $msg] +} {0 55 0 55} +test set-old-7.10 {unset command} { + catch {unset a} + set a(14) 22 + unset a(14) + list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2 +} {1 {can't read "a(14)": no such element in array} 0 {}} +test set-old-7.11 {unset command} { + catch {unset a} + set a(14) 22 + unset a + list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2 +} {1 {can't read "a(14)": no such variable} 0 {}} + +# Array command. + +test set-old-8.1 {array command} { + list [catch {array} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} +test set-old-8.2 {array command} { + list [catch {array a} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} +test set-old-8.3 {array command} { + catch {unset a} + list [catch {array anymore a b} msg] $msg +} {1 {"a" isn't an array}} +test set-old-8.4 {array command} { + catch {unset a} + set a 44 + list [catch {array anymore a b} msg] $msg +} {1 {"a" isn't an array}} +test set-old-8.5 {array command} { + proc foo {} { + set a 44 + upvar 0 a x + list [catch {array anymore x b} msg] $msg + } + foo +} {1 {"x" isn't an array}} +test set-old-8.6 {array command} { + catch {unset a} + set a(22) 3 + list [catch {array gorp a} msg] $msg +} {1 {bad option "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, or startsearch}} +test set-old-8.7 {array command, anymore option} { + catch {unset a} + list [catch {array anymore a x} msg] $msg +} {1 {"a" isn't an array}} +test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} { + proc foo {x} { + if {$x==1} { + return [array anymore a x] + } + set a(x) 123 + } + list [catch {foo 1} msg] $msg +} {1 {"a" isn't an array}} +test set-old-8.9 {array command, donesearch option} { + catch {unset a} + list [catch {array donesearch a x} msg] $msg +} {1 {"a" isn't an array}} +test set-old-8.10 {array command, donesearch option, array doesn't exist yet but has compiler-allocated procedure slot} { + proc foo {x} { + if {$x==1} { + return [array donesearch a x] + } + set a(x) 123 + } + list [catch {foo 1} msg] $msg +} {1 {"a" isn't an array}} +test set-old-8.11 {array command, exists option} { + list [catch {array exists a b} msg] $msg +} {1 {wrong # args: should be "array exists arrayName"}} +test set-old-8.12 {array command, exists option} { + catch {unset a} + array exists a +} {0} +test set-old-8.13 {array command, exists option} { + catch {unset a} + set a(0) 1 + array exists a +} {1} +test set-old-8.14 {array command, exists option, array doesn't exist yet but has compiler-allocated procedure slot} { + proc foo {x} { + if {$x==1} { + return [array exists a] + } + set a(x) 123 + } + list [catch {foo 1} msg] $msg +} {0 0} +test set-old-8.15 {array command, get option} { + list [catch {array get} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} +test set-old-8.16 {array command, get option} { + list [catch {array get a b c} msg] $msg +} {1 {wrong # args: should be "array get arrayName ?pattern?"}} +test set-old-8.17 {array command, get option} { + catch {unset a} + array get a +} {} +test set-old-8.18 {array command, get option} { + catch {unset a} + set a(22) 3 + set {a(long name)} {} + array get a +} {22 3 {long name} {}} +test set-old-8.19 {array command, get option (unset variable)} { + catch {unset a} + set a(x) 3 + trace var a(y) w ignore + array get a +} {x 3} +test set-old-8.20 {array command, get option, with pattern} { + catch {unset a} + set a(x1) 3 + set a(x2) 4 + set a(x3) 5 + set a(b1) 24 + set a(b2) 25 + array get a x* +} {x1 3 x2 4 x3 5} +test set-old-8.21 {array command, get option, array doesn't exist yet but has compiler-allocated procedure slot} { + proc foo {x} { + if {$x==1} { + return [array get a] + } + set a(x) 123 + } + list [catch {foo 1} msg] $msg +} {0 {}} +test set-old-8.22 {array command, names option} { + catch {unset a} + set a(22) 3 + list [catch {array names a 4 5} msg] $msg +} {1 {wrong # args: should be "array names arrayName ?pattern?"}} +test set-old-8.19 {array command, names option} { + catch {unset a} + array names a +} {} +test set-old-8.23 {array command, names option} { + catch {unset a} + set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx + list [catch {lsort [array names a]} msg] $msg +} {0 {22 Textual_name {name with spaces}}} +test set-old-8.24 {array command, names option} { + catch {unset a} + set a(22) 3; set a(33) 44; + trace var a(xxx) w ignore + list [catch {lsort [array names a]} msg] $msg +} {0 {22 33}} +test set-old-8.25 {array command, names option} { + catch {unset a} + set a(22) 3; set a(33) 44; + trace var a(xxx) w ignore + set a(xxx) value + list [catch {lsort [array names a]} msg] $msg +} {0 {22 33 xxx}} +test set-old-8.26 {array command, names option} { + catch {unset a} + set a(axy) 3 + set a(bxy) 44 + set a(no) yes + set a(xxx) value + list [lsort [array names a *xy]] [lsort [array names a]] +} {{axy bxy} {axy bxy no xxx}} +test set-old-8.27 {array command, names option, array doesn't exist yet but has compiler-allocated procedure slot} { + proc foo {x} { + if {$x==1} { + return [array names a] + } + set a(x) 123 + } + list [catch {foo 1} msg] $msg +} {0 {}} +test set-old-8.28 {array command, nextelement option} { + list [catch {array nextelement a} msg] $msg +} {1 {wrong # args: should be "array nextelement arrayName searchId"}} +test set-old-8.29 {array command, nextelement option} { + catch {unset a} + list [catch {array nextelement a b} msg] $msg +} {1 {"a" isn't an array}} +test set-old-8.30 {array command, nextelement option, array doesn't exist yet but has compiler-allocated procedure slot} { + proc foo {x} { + if {$x==1} { + return [array nextelement a b] + } + set a(x) 123 + } + list [catch {foo 1} msg] $msg +} {1 {"a" isn't an array}} +test set-old-8.31 {array command, set option} { + list [catch {array set a} msg] $msg +} {1 {wrong # args: should be "array set arrayName list"}} +test set-old-8.32 {array command, set option} { + list [catch {array set a 1 2} msg] $msg +} {1 {wrong # args: should be "array set arrayName list"}} +test set-old-8.33 {array command, set option} { + list [catch {array set a "a \{ c"} msg] $msg +} {1 {unmatched open brace in list}} +test set-old-8.34 {array command, set option} { + catch {unset a} + set a 44 + list [catch {array set a {a b c d}} msg] $msg +} {1 {can't set "a(a)": variable isn't array}} +test set-old-8.35 {array command, set option} { + catch {unset a} + set a(xx) yy + array set a {b c d e} + array get a +} {d e xx yy b c} +test set-old-8.36 {array command, set option, array doesn't exist yet but has compiler-allocated procedure slot} { + proc foo {x} { + if {$x==1} { + return [array set a {x 0}] + } + set a(x) + } + list [catch {foo 1} msg] $msg +} {0 {}} +test set-old-8.37 {array command, set option} { + catch {unset aVaRnAmE} + array set aVaRnAmE {} + list [info exists aVaRnAmE] [catch {set aVaRnAmE} msg] $msg +} {1 1 {can't read "aVaRnAmE": variable is array}} +test set-old-8.38 {array command, size option} { + catch {unset a} + array size a +} {0} +test set-old-8.39 {array command, size option} { + list [catch {array size a 4} msg] $msg +} {1 {wrong # args: should be "array size arrayName"}} +test set-old-8.40 {array command, size option} { + catch {unset a} + array size a +} {0} +test set-old-8.41 {array command, size option} { + catch {unset a} + set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx + list [catch {array size a} msg] $msg +} {0 3} +test set-old-8.42 {array command, size option} { + catch {unset a} + set a(22) 3; set a(xx) 44; set a(y) xxx + unset a(22) a(y) a(xx) + list [catch {array size a} msg] $msg +} {0 0} +test set-old-8.43 {array command, size option} { + catch {unset a} + set a(22) 3; + trace var a(33) rwu ignore + list [catch {array size a} msg] $msg +} {0 1} +test set-old-8.44 {array command, size option, array doesn't exist yet but has compiler-allocated procedure slot} { + proc foo {x} { + if {$x==1} { + return [array size a] + } + set a(x) 123 + } + list [catch {foo 1} msg] $msg +} {0 0} +test set-old-8.45 {array command, startsearch option} { + list [catch {array startsearch a b} msg] $msg +} {1 {wrong # args: should be "array startsearch arrayName"}} +test set-old-8.46 {array command, startsearch option} { + catch {unset a} + list [catch {array startsearch a} msg] $msg +} {1 {"a" isn't an array}} +test set-old-8.47 {array command, startsearch option, array doesn't exist yet but has compiler-allocated procedure slot} { + catch {rename p ""} + proc p {x} { + if {$x==1} { + return [array startsearch a] + } + set a(x) 123 + } + list [catch {p 1} msg] $msg +} {1 {"a" isn't an array}} + +test set-old-9.1 {ids for array enumeration} { + catch {unset a} + set a(a) 1 + list [array st a] [array st a] [array done a s-1-a; array st a] \ + [array done a s-2-a; array d a s-3-a; array start a] +} {s-1-a s-2-a s-3-a s-1-a} +test set-old-9.2 {array enumeration} { + catch {unset a} + set a(a) 1 + set a(b) 1 + set a(c) 1 + set x [array startsearch a] + list [array nextelement a $x] [array ne a $x] [array next a $x] \ + [array next a $x] [array next a $x] +} {a b c {} {}} +test set-old-9.3 {array enumeration} { + catch {unset a} + set a(a) 1 + set a(b) 1 + set a(c) 1 + set x [array startsearch a] + set y [array startsearch a] + set z [array startsearch a] + list [array nextelement a $x] [array ne a $x] \ + [array next a $y] [array next a $z] [array next a $y] \ + [array next a $z] [array next a $y] [array next a $z] \ + [array next a $y] [array next a $z] [array next a $x] \ + [array next a $x] +} {a b a a b b c c {} {} c {}} +test set-old-9.4 {array enumeration: stopping searches} { + catch {unset a} + set a(a) 1 + set a(b) 1 + set a(c) 1 + set x [array startsearch a] + set y [array startsearch a] + set z [array startsearch a] + list [array next a $x] [array next a $x] [array next a $y] \ + [array done a $z; array next a $x] \ + [array done a $x; array next a $y] [array next a $y] +} {a b a c b c} +test set-old-9.5 {array enumeration: stopping searches} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + array done a $x + list [catch {array next a $x} msg] $msg +} {1 {couldn't find search "s-1-a"}} +test set-old-9.6 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + set a(b) 1 + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} +test set-old-9.7 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + set a(a) 2 + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {0 a 0 a} +test set-old-9.8 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set a(c) 2 + set x [array startsearch a] + set y [array startsearch a] + catch {unset a(c)} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} +test set-old-9.9 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + catch {unset a(c)} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {0 a 0 a} +test set-old-9.10 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + trace var a(b) r {} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} +test set-old-9.11 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + trace var a(a) r {} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {0 a 0 a} +test set-old-9.12 {array enumeration with traced undefined elements} { + catch {unset a} + set a(a) 1 + trace var a(b) r {} + set x [array startsearch a] + list [array next a $x] [array next a $x] +} {a {}} + +test set-old-10.1 {array enumeration errors} { + list [catch {array start} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} +test set-old-10.2 {array enumeration errors} { + list [catch {array start a b} msg] $msg +} {1 {wrong # args: should be "array startsearch arrayName"}} +test set-old-10.3 {array enumeration errors} { + catch {unset a} + list [catch {array start a} msg] $msg +} {1 {"a" isn't an array}} +test set-old-10.4 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a} msg] $msg +} {1 {wrong # args: should be "array nextelement arrayName searchId"}} +test set-old-10.5 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a b c} msg] $msg +} {1 {wrong # args: should be "array nextelement arrayName searchId"}} +test set-old-10.6 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a a-1-a} msg] $msg +} {1 {illegal search identifier "a-1-a"}} +test set-old-10.7 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a sx1-a} msg] $msg +} {1 {illegal search identifier "sx1-a"}} +test set-old-10.8 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s--a} msg] $msg +} {1 {illegal search identifier "s--a"}} +test set-old-10.9 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s-1-b} msg] $msg +} {1 {search identifier "s-1-b" isn't for variable "a"}} +test set-old-10.10 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s-1ba} msg] $msg +} {1 {illegal search identifier "s-1ba"}} +test set-old-10.11 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s-2-a} msg] $msg +} {1 {couldn't find search "s-2-a"}} +test set-old-10.12 {array enumeration errors} { + list [catch {array done a} msg] $msg +} {1 {wrong # args: should be "array donesearch arrayName searchId"}} +test set-old-10.13 {array enumeration errors} { + list [catch {array done a b c} msg] $msg +} {1 {wrong # args: should be "array donesearch arrayName searchId"}} +test set-old-10.14 {array enumeration errors} { + list [catch {array done a b} msg] $msg +} {1 {illegal search identifier "b"}} +test set-old-10.15 {array enumeration errors} { + list [catch {array anymore a} msg] $msg +} {1 {wrong # args: should be "array anymore arrayName searchId"}} +test set-old-10.16 {array enumeration errors} { + list [catch {array any a b c} msg] $msg +} {1 {wrong # args: should be "array anymore arrayName searchId"}} +test set-old-10.17 {array enumeration errors} { + catch {unset a} + set a(0) 44 + list [catch {array any a bogus} msg] $msg +} {1 {illegal search identifier "bogus"}} + +# Array enumeration with "anymore" option + +test set-old-11.1 {array anymore option} { + catch {unset a} + set a(a) 1 + set a(b) 2 + set a(c) 3 + array startsearch a + list [array anymore a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] +} {1 a 1 b 1 c 0 {}} +test set-old-11.2 {array anymore option} { + catch {unset a} + set a(a) 1 + set a(b) 2 + set a(c) 3 + array startsearch a + list [array next a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] \ + [array next a s-1-a] [array anymore a s-1-a] +} {a b 1 c {} 0} + +# Special check to see that the value of a variable is handled correctly +# if it is returned as the result of a procedure (must not free the variable +# string while deleting the call frame). Errors will only be detected if +# a memory consistency checker such as Purify is being used. + +test set-old-12.1 {cleanup on procedure return} { + proc foo {} { + set x 12345 + } + foo +} 12345 +test set-old-12.2 {cleanup on procedure return} { + proc foo {} { + set x(1) 23456 + } + foo +} 23456 + +# Must delete variables when done, since these arrays get used as +# scalars by other tests. + +catch {unset a} +catch {unset b} +catch {unset c} +catch {unset aVaRnAmE} +return "" diff --git a/tests/set.test b/tests/set.test new file mode 100644 index 0000000..4d0f352 --- /dev/null +++ b/tests/set.test @@ -0,0 +1,233 @@ +# Commands covered: set +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) set.test 1.6 97/06/23 18:18:54 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset x} +catch {unset i} + +test set-1.1 {TclCompileSetCmd: missing variable name} { + list [catch {set} msg] $msg +} {1 {wrong # args: should be "set varName ?newValue?"}} +test set-1.2 {TclCompileSetCmd: simple variable name} { + set i 10 + list [set i] $i +} {10 10} +test set-1.3 {TclCompileSetCmd: error compiling variable name} { + set i 10 + catch {set "i"xxx} msg + set msg +} {quoted string doesn't terminate properly} +test set-1.4 {TclCompileSetCmd: simple variable name in quotes} { + set i 17 + list [set "i"] $i +} {17 17} +test set-1.5 {TclCompileSetCmd: simple variable name in braces} { + catch {unset {a simple var}} + set {a simple var} 27 + list [set {a simple var}] ${a simple var} +} {27 27} +test set-1.6 {TclCompileSetCmd: simple array variable name} { + catch {unset a} + set a(foo) 37 + list [set a(foo)] $a(foo) +} {37 37} +test set-1.7 {TclCompileSetCmd: non-simple (computed) variable name} { + set x "i" + set i 77 + list [set $x] $i +} {77 77} +test set-1.8 {TclCompileSetCmd: non-simple (computed) variable name} { + set x "i" + set i 77 + list [set [set x] 2] $i +} {2 2} + +test set-1.9 {TclCompileSetCmd: 3rd arg => assignment} { + set i "abcdef" + list [set i] $i +} {abcdef abcdef} +test set-1.10 {TclCompileSetCmd: only two args => just getting value} { + set i {one two} + set i +} {one two} + +test set-1.11 {TclCompileSetCmd: simple global name} { + proc p {} { + global i + set i 54 + set i + } + p +} {54} +test set-1.12 {TclCompileSetCmd: simple local name} { + proc p {bar} { + set foo $bar + set foo + } + p 999 +} {999} +test set-1.13 {TclCompileSetCmd: simple but new (unknown) local name} { + proc p {} { + set bar + } + catch {p} msg + set msg +} {can't read "bar": no such variable} +test set-1.14 {TclCompileSetCmd: simple local name, >255 locals} { + proc 260locals {} { + # create 260 locals (the last ones with index > 255) + set a0 0; set a1 0; set a2 0; set a3 0; set a4 0 + set a5 0; set a6 0; set a7 0; set a8 0; set a9 0 + set b0 0; set b1 0; set b2 0; set b3 0; set b4 0 + set b5 0; set b6 0; set b7 0; set b8 0; set b9 0 + set c0 0; set c1 0; set c2 0; set c3 0; set c4 0 + set c5 0; set c6 0; set c7 0; set c8 0; set c9 0 + set d0 0; set d1 0; set d2 0; set d3 0; set d4 0 + set d5 0; set d6 0; set d7 0; set d8 0; set d9 0 + set e0 0; set e1 0; set e2 0; set e3 0; set e4 0 + set e5 0; set e6 0; set e7 0; set e8 0; set e9 0 + set f0 0; set f1 0; set f2 0; set f3 0; set f4 0 + set f5 0; set f6 0; set f7 0; set f8 0; set f9 0 + set g0 0; set g1 0; set g2 0; set g3 0; set g4 0 + set g5 0; set g6 0; set g7 0; set g8 0; set g9 0 + set h0 0; set h1 0; set h2 0; set h3 0; set h4 0 + set h5 0; set h6 0; set h7 0; set h8 0; set h9 0 + set i0 0; set i1 0; set i2 0; set i3 0; set i4 0 + set i5 0; set i6 0; set i7 0; set i8 0; set i9 0 + set j0 0; set j1 0; set j2 0; set j3 0; set j4 0 + set j5 0; set j6 0; set j7 0; set j8 0; set j9 0 + set k0 0; set k1 0; set k2 0; set k3 0; set k4 0 + set k5 0; set k6 0; set k7 0; set k8 0; set k9 0 + set l0 0; set l1 0; set l2 0; set l3 0; set l4 0 + set l5 0; set l6 0; set l7 0; set l8 0; set l9 0 + set m0 0; set m1 0; set m2 0; set m3 0; set m4 0 + set m5 0; set m6 0; set m7 0; set m8 0; set m9 0 + set n0 0; set n1 0; set n2 0; set n3 0; set n4 0 + set n5 0; set n6 0; set n7 0; set n8 0; set n9 0 + set o0 0; set o1 0; set o2 0; set o3 0; set o4 0 + set o5 0; set o6 0; set o7 0; set o8 0; set o9 0 + set p0 0; set p1 0; set p2 0; set p3 0; set p4 0 + set p5 0; set p6 0; set p7 0; set p8 0; set p9 0 + set q0 0; set q1 0; set q2 0; set q3 0; set q4 0 + set q5 0; set q6 0; set q7 0; set q8 0; set q9 0 + set r0 0; set r1 0; set r2 0; set r3 0; set r4 0 + set r5 0; set r6 0; set r7 0; set r8 0; set r9 0 + set s0 0; set s1 0; set s2 0; set s3 0; set s4 0 + set s5 0; set s6 0; set s7 0; set s8 0; set s9 0 + set t0 0; set t1 0; set t2 0; set t3 0; set t4 0 + set t5 0; set t6 0; set t7 0; set t8 0; set t9 0 + set u0 0; set u1 0; set u2 0; set u3 0; set u4 0 + set u5 0; set u6 0; set u7 0; set u8 0; set u9 0 + set v0 0; set v1 0; set v2 0; set v3 0; set v4 0 + set v5 0; set v6 0; set v7 0; set v8 0; set v9 0 + set w0 0; set w1 0; set w2 0; set w3 0; set w4 0 + set w5 0; set w6 0; set w7 0; set w8 0; set w9 0 + set x0 0; set x1 0; set x2 0; set x3 0; set x4 0 + set x5 0; set x6 0; set x7 0; set x8 0; set x9 0 + set y0 0; set y1 0; set y2 0; set y3 0; set y4 0 + set y5 0; set y6 0; set y7 0; set y8 0; set y9 0 + set z0 0; set z1 0; set z2 0; set z3 0; set z4 0 + set z5 0; set z6 0; set z7 0; set z8 0; set z9 1234 + } + 260locals +} {1234} +test set-1.15 {TclCompileSetCmd: variable is array} { + catch {unset a} + set x 27 + set x [set a(foo) 11] + catch {unset a} + set x +} 11 +test set-1.16 {TclCompileSetCmd: variable is array, elem substitutions} { + catch {unset a} + set i 5 + set x 789 + set a(foo5) 27 + set x [set a(foo$i)] + catch {unset a} + set x +} 27 + +test set-1.17 {TclCompileSetCmd: doing assignment, simple int} { + set i 5 + set i 123 +} 123 +test set-1.18 {TclCompileSetCmd: doing assignment, simple int} { + set i 5 + set i -100 +} -100 +test set-1.19 {TclCompileSetCmd: doing assignment, simple but not int} { + set i 5 + set i 0x12MNOP + set i +} {0x12MNOP} +test set-1.20 {TclCompileSetCmd: doing assignment, in quotes} { + set i 25 + set i "-100" +} -100 +test set-1.21 {TclCompileSetCmd: doing assignment, in braces} { + set i 24 + set i {126} +} 126 +test set-1.22 {TclCompileSetCmd: doing assignment, large int} { + set i 5 + set i 200000 +} 200000 +test set-1.23 {TclCompileSetCmd: doing assignment, formatted int != int} { + set i 25 + set i 000012345 ;# an octal literal == 5349 decimal + list $i [incr i] +} {000012345 5350} + +test set-1.24 {TclCompileSetCmd: too many arguments} { + set i 10 + catch {set i 20 30} msg + set msg +} {wrong # args: should be "set varName ?newValue?"} + +test set-2.1 {set command: runtime error, bad variable name} { + list [catch {set {"foo}} msg] $msg $errorInfo +} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable + while executing +"set {"foo}"}} +test set-2.2 {set command: runtime error, not array variable} { + catch {unset b} + set b 44 + list [catch {set b(123)} msg] $msg +} {1 {can't read "b(123)": variable isn't array}} +test set-2.3 {set command: runtime error, errors in reading variables} { + catch {unset a} + set a(6) 44 + list [catch {set a(18)} msg] $msg +} {1 {can't read "a(18)": no such element in array}} +test set-2.4 {set command: runtime error, readonly variable} { + proc readonly args {error "variable is read-only"} + set x 123 + trace var x w readonly + list [catch {set x 1} msg] $msg $errorInfo +} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only + while executing +"set x 1"}} +test set-2.5 {set command: runtime error, basic array operations} { + list [catch {set a(other)} msg] $msg +} {1 {can't read "a(other)": no such element in array}} +test set-2.6 {set command: runtime error, basic array operations} { + list [catch {set a} msg] $msg +} {1 {can't read "a": variable is array}} + +catch {unset a} +catch {unset b} +catch {unset i} +catch {unset x} +return "" diff --git a/tests/socket.test b/tests/socket.test new file mode 100644 index 0000000..b2719de --- /dev/null +++ b/tests/socket.test @@ -0,0 +1,1344 @@ +# Commands tested in this file: socket. +# +# 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) 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. +# +# Running socket tests with a remote server: +# ------------------------------------------ +# +# Some tests in socket.test depend on the existence of a remote server to +# which they connect. The remote server must be an instance of tcltest and it +# must run the script found in the file "remote.tcl" in this directory. You +# can start the remote server on any machine reachable from the machine on +# which you want to run the socket tests, by issuing: +# +# tcltest remote.tcl -port 2048 # Or choose another port number. +# +# If the machine you are running the remote server on has several IP +# interfaces, you can choose which interface the server listens on for +# connections by specifying the -address command line flag, so: +# +# tcltest remote.tcl -address your.machine.com +# +# These options can also be set by environment variables. On Unix, you can +# type these commands to the shell from which the remote server is started: +# +# shell% setenv serverPort 2048 +# shell% setenv serverAddress your.machine.com +# +# and subsequently you can start the remote server with: +# +# tcltest remote.tcl +# +# to have it listen on port 2048 on the interface your.machine.com. +# +# When the server starts, it prints out a detailed message containing its +# configuration information, and it will block until killed with a Ctrl-C. +# Once the remote server exists, you can run the tests in socket.test with +# the server by setting two Tcl variables: +# +# % set remoteServerIP <name or address of machine on which server runs> +# % set remoteServerPort 2048 +# +# These variables are also settable from the environment. On Unix, you can: +# +# shell% setenv remoteServerIP machine.where.server.runs +# shell% senetv remoteServerPort 2048 +# +# The preamble of the socket.test file checks to see if the variables are set +# either in Tcl or in the environment; if they are, it attempts to connect to +# the server. If the connection is successful, the tests using the remote +# server will be performed; otherwise, it will attempt to start the remote +# server (via exec) on platforms that support this, on the local host, +# 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 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {$testConfig(socket) == 0} { + return +} + +# +# If remoteServerIP or remoteServerPort are not set, check in the +# environment variables for externally set values. +# + +if {![info exists remoteServerIP]} { + if {[info exists env(remoteServerIP)]} { + set remoteServerIP $env(remoteServerIP) + } +} +if {![info exists remoteServerPort]} { + if {[info exists env(remoteServerIP)]} { + set remoteServerPort $env(remoteServerPort) + } else { + if {[info exists remoteServerIP]} { + set remoteServerPort 2048 + } + } +} + +# +# Check if we're supposed to do tests against the remote server +# + +set doTestsWithRemoteServer 1 +if {![info exists remoteServerIP] && ($tcl_platform(platform) != "macintosh")} { + set remoteServerIP localhost +} +if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} { + set remoteServerPort 2048 +} + +# Attempt to connect to a remote server if one is already running. If it +# is not running or for some other reason the connect fails, attempt to +# start the remote server on the local host listening on port 2048. This +# is only done on platforms that support exec (i.e. not on the Mac). On +# platforms that do not support exec, the remote server must be started +# by the user before running the tests. + +set remoteProcChan "" +set commandSocket "" +if {$doTestsWithRemoteServer} { + catch {close $commandSocket} + if {[catch {set commandSocket [socket $remoteServerIP \ + $remoteServerPort]}] != 0} { + if {[info commands exec] == ""} { + set noRemoteTestReason "can't exec" + set doTestsWithRemoteServer 0 + } elseif {$testConfig(win32s)} { + set noRemoteTestReason "\ncan't run multiple instances of tcltest under win32s." + set doTestsWithRemoteServer 0 + } else { + set remoteServerIP localhost + if {[catch {set remoteProcChan \ + [open "|[list $tcltest remote.tcl \ + -serverIsSilent \ + -port $remoteServerPort \ + -address $remoteServerIP]" \ + w+]} \ + msg] == 0} { + after 1000 + if {[catch {set commandSocket [socket $remoteServerIP \ + $remoteServerPort]} msg] == 0} { + fconfigure $commandSocket -translation crlf -buffering line + } else { + set noRemoteTestReason $msg + set doTestsWithRemoteServer 0 + } + } else { + set noRemoteTestReason "$msg $tcltest" + set doTestsWithRemoteServer 0 + } + } + } else { + fconfigure $commandSocket -translation crlf -buffering line + } +} + +if {$doTestsWithRemoteServer == 0} { + puts "Skipping tests with remote server. See tests/socket.test for" + puts "information on how to run remote server." + if {[info exists VERBOSE] && ($VERBOSE != 0)} { + puts "Reason for not doing remote tests: $noRemoteTestReason" + } +} + +# +# If we do the tests, define a command to send a command to the +# remote server. +# + +if {$doTestsWithRemoteServer == 1} { + proc sendCommand {c} { + global commandSocket + + if {[eof $commandSocket]} { + error "remote server disappeared" + } + + if {[catch {puts $commandSocket $c} msg]} { + error "remote server disappaered: $msg" + } + if {[catch {puts $commandSocket "--Marker--Marker--Marker--"} msg]} { + error "remote server disappeared: $msg" + } + + set resp "" + while {1} { + set line [gets $commandSocket] + if {[eof $commandSocket]} { + error "remote server disappaered" + } + if {[string compare $line "--Marker--Marker--Marker--"] == 0} { + if {[string compare [lindex $resp 0] error] == 0} { + error [lindex $resp 1] + } else { + return [lindex $resp 1] + } + } else { + append resp $line "\n" + } + } + } +} + +test socket-1.1 {arg parsing for socket command} { + list [catch {socket -server} msg] $msg +} {1 {no argument given for -server option}} +test socket-1.2 {arg parsing for socket command} { + list [catch {socket -server foo} msg] $msg +} {1 {wrong # args: should be either: +socket ?-myaddr addr? ?-myport myport? ?-async? host port +socket -server command ?-myaddr addr? port}} +test socket-1.3 {arg parsing for socket command} { + list [catch {socket -myaddr} msg] $msg +} {1 {no argument given for -myaddr option}} +test socket-1.4 {arg parsing for socket command} { + list [catch {socket -myaddr 127.0.0.1} msg] $msg +} {1 {wrong # args: should be either: +socket ?-myaddr addr? ?-myport myport? ?-async? host port +socket -server command ?-myaddr addr? port}} +test socket-1.5 {arg parsing for socket command} { + list [catch {socket -myport} msg] $msg +} {1 {no argument given for -myport option}} +test socket-1.6 {arg parsing for socket command} { + list [catch {socket -myport xxxx} msg] $msg +} {1 {expected integer but got "xxxx"}} +test socket-1.7 {arg parsing for socket command} { + list [catch {socket -myport 2522} msg] $msg +} {1 {wrong # args: should be either: +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}} +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}} +test socket-1.10 {arg parsing for socket command} { + list [catch {socket host 2528 -junk} msg] $msg +} {1 {wrong # args: should be either: +socket ?-myaddr addr? ?-myport myport? ?-async? host port +socket -server command ?-myaddr addr? port}} +test socket-1.11 {arg parsing for socket command} { + list [catch {socket -server callback 2520 --} msg] $msg +} {1 {wrong # args: should be either: +socket ?-myaddr addr? ?-myport myport? ?-async? host port +socket -server command ?-myaddr addr? port}} +test socket-1.12 {arg parsing for socket command} { + list [catch {socket foo badport} msg] $msg +} {1 {expected integer but got "badport"}} + +test socket-2.1 {tcp connection} {stdio} { + removeFile script + set f [open script w] + puts $f { + set timer [after 2000 "set x timed_out"] + set f [socket -server accept 2828] + proc accept {file addr port} { + global x + set x done + close $file + } + puts ready + vwait x + after cancel $timer + close $f + puts $x + } + close $f + set f [open "|[list $tcltest script]" r] + gets $f x + if {[catch {socket localhost 2828} msg]} { + set x $msg + } else { + lappend x [gets $f] + close $msg + } + lappend x [gets $f] + close $f + set x +} {ready done {}} + +if [info exists port] { + incr port +} else { + set port [expr 2048 + [pid]%1024] +} +test socket-2.2 {tcp connection with client port specified} {stdio} { + removeFile script + set f [open script w] + puts $f { + set timer [after 2000 "set x done"] + set f [socket -server accept 2828] + proc accept {file addr port} { + global x + puts "[gets $file] $port" + close $file + set x done + } + puts ready + vwait x + after cancel $timer + close $f + } + close $f + set f [open "|[list $tcltest script]" r] + gets $f x + global port + if {[catch {socket -myport $port localhost 2828} sock]} { + set x $sock + close [socket localhost 2828] + puts stderr $sock + } else { + puts $sock hello + flush $sock + lappend x [gets $f] + close $sock + } + close $f + set x +} [list ready "hello $port"] +test socket-2.3 {tcp connection with client interface specified} {stdio} { + removeFile script + set f [open script w] + puts $f { + set timer [after 2000 "set x done"] + set f [socket -server accept 2828] + proc accept {file addr port} { + global x + puts "[gets $file] $addr" + close $file + set x done + } + puts ready + vwait x + after cancel $timer + close $f + } + close $f + set f [open "|[list $tcltest script]" r] + gets $f x + if {[catch {socket -myaddr localhost localhost 2828} sock]} { + set x $sock + } else { + puts $sock hello + flush $sock + lappend x [gets $f] + close $sock + } + close $f + set x +} {ready {hello 127.0.0.1}} +test socket-2.4 {tcp connection with server interface specified} {stdio} { + removeFile script + set f [open script w] + puts $f { + set timer [after 2000 "set x done"] + set f [socket -server accept -myaddr [info hostname] 2828] + proc accept {file addr port} { + global x + puts "[gets $file]" + close $file + set x done + } + puts ready + vwait x + after cancel $timer + close $f + } + close $f + set f [open "|[list $tcltest script]" r] + gets $f x + if {[catch {socket [info hostname] 2828} sock]} { + set x $sock + } else { + puts $sock hello + flush $sock + lappend x [gets $f] + close $sock + } + close $f + set x +} {ready hello} +test socket-2.5 {tcp connection with redundant server port} {stdio} { + removeFile script + set f [open script w] + puts $f { + set timer [after 2000 "set x done"] + set f [socket -server accept 2828] + proc accept {file addr port} { + global x + puts "[gets $file]" + close $file + set x done + } + puts ready + vwait x + after cancel $timer + close $f + } + close $f + set f [open "|[list $tcltest script]" r] + gets $f x + if {[catch {socket localhost 2828} sock]} { + set x $sock + } else { + puts $sock hello + flush $sock + lappend x [gets $f] + close $sock + } + close $f + set x +} {ready hello} +test socket-2.6 {tcp connection} {} { + set status ok + if {![catch {set sock [socket localhost 2828]}]} { + if {![catch {gets $sock}]} { + set status broken + } + close $sock + } + set status +} ok +test socket-2.7 {echo server, one line} {stdio} { + removeFile script + set f [open script w] + puts $f { + set timer [after 2000 "set x done"] + set f [socket -server accept 2828] + proc accept {s a p} { + fileevent $s readable [list echo $s] + fconfigure $s -translation lf -buffering line + } + proc echo {s} { + set l [gets $s] + if {[eof $s]} { + global x + close $s + set x done + } else { + puts $s $l + } + } + puts ready + vwait x + after cancel $timer + close $f + puts done + } + close $f + set f [open "|[list $tcltest script]" r] + gets $f + set s [socket localhost 2828] + fconfigure $s -buffering line -translation lf + puts $s "hello abcdefghijklmnop" + set x [gets $s] + close $s + set y [gets $f] + close $f + list $x $y +} {{hello abcdefghijklmnop} done} +test socket-2.8 {echo server, loop 50 times, single connection} {stdio} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + proc accept {s a p} { + fileevent $s readable [list echo $s] + fconfigure $s -buffering line + } + proc echo {s} { + global i + set l [gets $s] + if {[eof $s]} { + global x + close $s + set x done + } else { + incr i + puts $s $l + } + } + set i 0 + puts ready + set timer [after 20000 "set x done"] + vwait x + after cancel $timer + close $f + puts "done $i" + } + close $f + set f [open "|[list $tcltest script]" r] + 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 + } + close $s + set x [gets $f] + close $f + set x +} {done 50} +test socket-2.9 {socket conflict} {stdio} { + set s [socket -server accept 2828] + removeFile script + set f [open script w] + puts $f {set f [socket -server accept 2828]} + close $f + set f [open "|[list $tcltest script]" r] + gets $f + after 100 + set x [list [catch {close $f} msg] $msg] + close $s + set x +} {1 {couldn't open socket: address already in use + while executing +"socket -server accept 2828" + (file "script" line 1)}} +test socket-2.10 {close on accept, accepted socket lives} { + set done 0 + set timer [after 20000 "set done timed_out"] + set ss [socket -server accept 2830] + proc accept {s a p} { + global ss + close $ss + fileevent $s readable "readit $s" + fconfigure $s -trans lf + } + proc readit {s} { + global done + gets $s + close $s + set done 1 + } + set cs [socket [info hostname] 2830] + puts $cs hello + close $cs + vwait done + after cancel $timer + set done +} 1 + +test socket-3.1 {socket conflict} {stdio} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + puts ready + gets stdin + close $f + } + close $f + set f [open "|[list $tcltest script]" r+] + gets $f + set x [list [catch {socket -server accept 2828} msg] \ + $msg] + puts $f bye + close $f + set x +} {1 {couldn't open socket: address already in use}} +test socket-3.2 {server with several clients} {stdio} { + removeFile script + set f [open script w] + puts $f { + set t1 [after 30000 "set x timed_out"] + set t2 [after 31000 "set x timed_out"] + set t3 [after 32000 "set x timed_out"] + set counter 0 + set s [socket -server accept 2828] + proc accept {s a p} { + fileevent $s readable [list echo $s] + fconfigure $s -buffering line + } + proc echo {s} { + global x + set l [gets $s] + if {[eof $s]} { + close $s + set x done + } else { + puts $s $l + } + } + puts ready + vwait x + after cancel $t1 + vwait x + after cancel $t2 + vwait x + after cancel $t3 + close $s + puts $x + } + close $f + set f [open "|[list $tcltest script]" r+] + set x [gets $f] + set s1 [socket localhost 2828] + fconfigure $s1 -buffering line + set s2 [socket localhost 2828] + fconfigure $s2 -buffering line + set s3 [socket localhost 2828] + fconfigure $s3 -buffering line + for {set i 0} {$i < 100} {incr i} { + puts $s1 hello,s1 + gets $s1 + puts $s2 hello,s2 + gets $s2 + puts $s3 hello,s3 + gets $s3 + } + close $s1 + close $s2 + close $s3 + lappend x [gets $f] + close $f + set x +} {ready done} + +test socket-4.1 {server with several clients} {stdio} { + removeFile script + set f [open script w] + puts $f { + gets stdin + set s [socket localhost 2828] + fconfigure $s -buffering line + for {set i 0} {$i < 100} {incr i} { + puts $s hello + gets $s + } + close $s + puts bye + gets stdin + } + close $f + set p1 [open "|[list $tcltest script]" r+] + fconfigure $p1 -buffering line + set p2 [open "|[list $tcltest script]" r+] + fconfigure $p2 -buffering line + set p3 [open "|[list $tcltest script]" r+] + fconfigure $p3 -buffering line + proc accept {s a p} { + fconfigure $s -buffering line + fileevent $s readable [list echo $s] + } + proc echo {s} { + global x + set l [gets $s] + if {[eof $s]} { + close $s + set x done + } else { + puts $s $l + } + } + set t1 [after 30000 "set x timed_out"] + set t2 [after 31000 "set x timed_out"] + set t3 [after 32000 "set x timed_out"] + set s [socket -server accept 2828] + puts $p1 open + puts $p2 open + puts $p3 open + vwait x + vwait x + vwait x + after cancel $t1 + after cancel $t2 + after cancel $t3 + close $s + set l "" + lappend l [list p1 [gets $p1] $x] + lappend l [list p2 [gets $p2] $x] + lappend l [list p3 [gets $p3] $x] + puts $p1 bye + puts $p2 bye + puts $p3 bye + close $p1 + close $p2 + close $p3 + set l +} {{p1 bye done} {p2 bye done} {p3 bye done}} +test socket-4.2 {byte order problems, socket numbers, htons} { + set x ok + if {[catch {socket -server dodo 0x3000} msg]} { + set x $msg + } else { + close $msg + } + set x +} ok + +test socket-5.1 {byte order problems, socket numbers, htons} {unixOnly} { + # + # THIS TEST WILL FAIL if you are running as superuser. + # + set x {couldn't open socket: not owner} + if {![catch {socket -server dodo 0x1} msg]} { + set x {htons problem, should be disallowed, are you running as SU?} + close $msg + } + set x +} {couldn't open socket: not owner} +test socket-5.2 {byte order problems, socket numbers, htons} { + set x {couldn't open socket: port number too high} + if {![catch {socket -server dodo 0x10000} msg]} { + set x {port resolution problem, should be disallowed} + close $msg + } + set x +} {couldn't open socket: port number too high} +test socket-5.3 {byte order problems, socket numbers, htons} {unixOnly} { + # + # THIS TEST WILL FAIL if you are running as superuser. + # + set x {couldn't open socket: not owner} + if {![catch {socket -server dodo 21} msg]} { + set x {htons problem, should be disallowed, are you running as SU?} + close $msg + } + set x +} {couldn't open socket: not owner} + +test socket-6.1 {accept callback error} {stdio} { + removeFile script + set f [open script w] + puts $f { + gets stdin + socket localhost 2848 + } + close $f + set f [open "|[list $tcltest script]" r+] + proc bgerror args { + global x + set x $args + } + proc accept {s a p} {expr 10 / 0} + set s [socket -server accept 2848] + puts $f hello + close $f + set timer [after 10000 "set x timed_out"] + vwait x + after cancel $timer + close $s + rename bgerror {} + set x +} {{divide by zero}} + +test socket-7.1 {testing socket specific options} {stdio} { + removeFile script + set f [open script w] + puts $f { + socket -server accept 2820 + proc accept args { + global x + set x done + } + puts ready + set timer [after 10000 "set x timed_out"] + vwait x + after cancel $timer + } + close $f + set f [open "|[list $tcltest script]" r] + gets $f + set s [socket localhost 2820] + set p [fconfigure $s -peername] + close $s + close $f + set l "" + lappend l [string compare [lindex $p 0] 127.0.0.1] + lappend l [string compare [lindex $p 2] 2820] + lappend l [llength $p] +} {0 0 3} +test socket-7.2 {testing socket specific options} {stdio} { + removeFile script + set f [open script w] + puts $f { + socket -server accept 2821 + proc accept args { + global x + set x done + } + puts ready + set timer [after 10000 "set x timed_out"] + vwait x + after cancel $timer + } + close $f + set f [open "|[list $tcltest script]" r] + gets $f + set s [socket localhost 2821] + set p [fconfigure $s -sockname] + close $s + close $f + set l "" + lappend l [llength $p] + lappend l [lindex $p 0] + lappend l [expr [lindex $p 2] == 2821] +} {3 127.0.0.1 0} +test socket-7.3 {testing socket specific options} { + set s [socket -server accept 2822] + set l [fconfigure $s] + close $s + update + llength $l +} 10 +test socket-7.4 {testing socket specific options} { + set s [socket -server accept 2823] + proc accept {s a p} { + global x + set x [fconfigure $s -sockname] + close $s + } + set s1 [socket [info hostname] 2823] + set timer [after 10000 "set x timed_out"] + vwait x + after cancel $timer + close $s + close $s1 + set l "" + lappend l [lindex $x 2] [llength $x] +} {2823 3} +test socket-7.5 {testing socket specific options} {unixOrPc} { + set s [socket -server accept 2829] + proc accept {s a p} { + global x + set x [fconfigure $s -sockname] + close $s + } + set s1 [socket localhost 2829] + set timer [after 10000 "set x timed_out"] + vwait x + after cancel $timer + close $s + close $s1 + set l "" + lappend l [lindex $x 0] [lindex $x 2] [llength $x] +} {127.0.0.1 2829 3} + +test socket-8.1 {testing -async flag on sockets} { + # NOTE: This test may fail on some Solaris 2.4 systems. If it does, + # check that you have these patches installed (using showrev -p): + # + # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03, + # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01, + # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03, + # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01, + # 101878-03, 101879-01, 101880-03, 101933-01, 101950-01, 102030-01, + # 102057-08, 102140-01, 101920-02, 101921-09, 101922-07, 101923-03 + # + # If after installing these patches you are still experiencing a + # problem, please email jyl@eng.sun.com. We have not observed this + # failure on Solaris 2.5, so another option (instead of installing + # these patches) is to upgrade to Solaris 2.5. + set s [socket -server accept 2830] + proc accept {s a p} { + global x + puts $s bye + close $s + set x done + } + set s1 [socket -async [info hostname] 2830] + vwait x + set z [gets $s1] + close $s + close $s1 + set z +} bye + +test socket-9.1 {testing spurious events} { + set len 0 + set spurious 0 + set done 0 + proc readlittle {s} { + global spurious done len + set l [read $s 1] + if {[string length $l] == 0} { + if {![eof $s]} { + incr spurious + } else { + close $s + set done 1 + } + } else { + incr len [string length $l] + } + } + proc accept {s a p} { + fconfigure $s -buffering none -blocking off + fileevent $s readable [list readlittle $s] + } + set s [socket -server accept 2831] + set c [socket [info hostname] 2831] + puts -nonewline $c 01234567890123456789012345678901234567890123456789 + close $c + set timer [after 10000 "set done timed_out"] + vwait done + after cancel $timer + close $s + list $spurious $len +} {0 50} +test socket-9.2 {testing async write, fileevents, flush on close} {} { + set firstblock "" + for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"} + set secondblock "" + for {set i 0} {$i < 16} {incr i} { + set secondblock "b$secondblock$secondblock" + } + set l [socket -server accept 2832] + proc accept {s a p} { + fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ + -buffering line + fileevent $s readable "readable $s" + } + proc readable {s} { + set l [gets $s] + fileevent $s readable {} + after 1000 respond $s + } + proc respond {s} { + global firstblock + puts -nonewline $s $firstblock + after 1000 writedata $s + } + proc writedata {s} { + global secondblock + puts -nonewline $s $secondblock + close $s + } + set s [socket [info hostname] 2832] + fconfigure $s -blocking 0 -trans lf -buffering line + set count 0 + puts $s hello + proc readit {s} { + global count done + set l [read $s] + incr count [string length $l] + if {[eof $s]} { + close $s + set done 1 + } + } + fileevent $s readable "readit $s" + set timer [after 10000 "set done timed_out"] + vwait done + after cancel $timer + close $l + set count +} 65566 +test socket-9.3 {testing EOF stickyness} { + proc count_to_eof {s} { + global count done timer + set l [gets $s] + if {[eof $s]} { + incr count + if {$count > 9} { + close $s + set done true + set count {eof is sticky} + after cancel $timer + } + } + } + proc timerproc {} { + global done count c + set done true + set count {timer went off, eof is not sticky} + close $c + } + set count 0 + set done false + proc write_then_close {s} { + puts $s bye + close $s + } + proc accept {s a p} { + fconfigure $s -buffering line -translation lf + fileevent $s writable "write_then_close $s" + } + set s [socket -server accept 2833] + set c [socket [info hostname] 2833] + fconfigure $c -blocking off -buffering line -translation lf + fileevent $c readable "count_to_eof $c" + set timer [after 1000 timerproc] + vwait done + close $s + set count +} {eof is sticky} + +removeFile script + +# +# The rest of the tests are run only if we are doing testing against +# a remote server. +# + +if {$doTestsWithRemoteServer == 0} { + return +} + +test socket-10.1 {tcp connection} { + sendCommand { + set socket9_1_test_server [socket -server accept 2834] + proc accept {s a p} { + puts $s done + close $s + } + } + set s [socket $remoteServerIP 2834] + set r [gets $s] + close $s + sendCommand {close $socket9_1_test_server} + set r +} done +test socket-10.2 {client specifies its port} { + if {[info exists port]} { + incr port + } else { + set port [expr 2048 + [pid]%1024] + } + sendCommand { + set socket9_2_test_server [socket -server accept 2835] + proc accept {s a p} { + puts $s $p + close $s + } + } + set s [socket -myport $port $remoteServerIP 2835] + set r [gets $s] + close $s + sendCommand {close $socket9_2_test_server} + if {$r == $port} { + set result ok + } else { + set result broken + } + set result +} ok +# +# Tests io-10.3, io-10.4 have been removed. +# +test socket-10.3 {trying to connect, no server} { + set status ok + if {![catch {set s [socket $remoteServerIp 2836]}]} { + if {![catch {gets $s}]} { + set status broken + } + close $s + } + set status +} ok +test socket-10.4 {remote echo, one line} { + sendCommand { + set socket10_6_test_server [socket -server accept 2836] + proc accept {s a p} { + fileevent $s readable [list echo $s] + fconfigure $s -buffering line -translation crlf + } + proc echo {s} { + set l [gets $s] + if {[eof $s]} { + close $s + } else { + puts $s $l + } + } + } + set f [socket $remoteServerIP 2836] + fconfigure $f -translation crlf -buffering line + puts $f hello + set r [gets $f] + close $f + sendCommand {close $socket10_6_test_server} + set r +} hello +test socket-10.5 {remote echo, 50 lines} { + sendCommand { + set socket10_7_test_server [socket -server accept 2836] + proc accept {s a p} { + fileevent $s readable [list echo $s] + fconfigure $s -buffering line -translation crlf + } + proc echo {s} { + set l [gets $s] + if {[eof $s]} { + close $s + } else { + puts $s $l + } + } + } + set f [socket $remoteServerIP 2836] + fconfigure $f -translation crlf -buffering line + for {set cnt 0} {$cnt < 50} {incr cnt} { + puts $f "hello, $cnt" + if {[string compare [gets $f] "hello, $cnt"] != 0} { + break + } + } + close $f + sendCommand {close $socket10_7_test_server} + set cnt +} 50 +# Macintosh sockets can have more than one server per port +if {$tcl_platform(platform) == "macintosh"} { + set conflictResult {0 2836} +} else { + set conflictResult {1 {couldn't open socket: address already in use}} +} +test socket-10.6 {socket conflict} { + set s1 [socket -server accept 2836] + if {[catch {set s2 [socket -server accept 2836]} msg]} { + set result [list 1 $msg] + } else { + set result [list 0 [lindex [fconfigure $s2 -sockname] 2]] + close $s2 + } + close $s1 + set result +} $conflictResult +test socket-10.7 {server with several clients} { + sendCommand { + set socket10_9_test_server [socket -server accept 2836] + proc accept {s a p} { + fconfigure $s -buffering line + fileevent $s readable [list echo $s] + } + proc echo {s} { + set l [gets $s] + if {[eof $s]} { + close $s + } else { + puts $s $l + } + } + } + set s1 [socket $remoteServerIP 2836] + fconfigure $s1 -buffering line + set s2 [socket $remoteServerIP 2836] + fconfigure $s2 -buffering line + set s3 [socket $remoteServerIP 2836] + fconfigure $s3 -buffering line + for {set i 0} {$i < 100} {incr i} { + puts $s1 hello,s1 + gets $s1 + puts $s2 hello,s2 + gets $s2 + puts $s3 hello,s3 + gets $s3 + } + close $s1 + close $s2 + close $s3 + sendCommand {close $socket10_9_test_server} + set i +} 100 +test socket-10.8 {client with several servers} { + sendCommand { + set s1 [socket -server "accept 4003" 4003] + set s2 [socket -server "accept 4004" 4004] + set s3 [socket -server "accept 4005" 4005] + proc accept {mp s a p} { + puts $s $mp + close $s + } + } + set s1 [socket $remoteServerIP 4003] + set s2 [socket $remoteServerIP 4004] + set s3 [socket $remoteServerIP 4005] + set l "" + lappend l [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \ + [gets $s3] [gets $s3] [eof $s3] + close $s1 + close $s2 + close $s3 + sendCommand { + close $s1 + close $s2 + close $s3 + } + set l +} {4003 {} 1 4004 {} 1 4005 {} 1} +test socket-10.9 {accept callback error} { + set s [socket -server accept 2836] + proc accept {s a p} {expr 10 / 0} + proc bgerror args { + global x + set x $args + } + if {[catch {sendCommand { + set peername [fconfigure $callerSocket -peername] + set s [socket [lindex $peername 0] 2836] + close $s + }} msg]} { + close $s + error $msg + } + set timer [after 10000 "set x timed_out"] + vwait x + after cancel $timer + close $s + rename bgerror {} + set x +} {{divide by zero}} +test socket-10.10 {testing socket specific options} { + sendCommand { + set socket10_12_test_server [socket -server accept 2836] + proc accept {s a p} {close $s} + } + set s [socket $remoteServerIP 2836] + set p [fconfigure $s -peername] + set n [fconfigure $s -sockname] + set l "" + lappend l [lindex $p 2] [llength $p] [llength $p] + close $s + sendCommand {close $socket10_12_test_server} + set l +} {2836 3 3} +test socket-10.11 {testing spurious events} { + sendCommand { + set socket10_13_test_server [socket -server accept 2836] + proc accept {s a p} { + fconfigure $s -translation "auto lf" + after 100 writesome $s + } + proc writesome {s} { + for {set i 0} {$i < 100} {incr i} { + puts $s "line $i from remote server" + } + close $s + } + } + set len 0 + set spurious 0 + set done 0 + proc readlittle {s} { + global spurious done len + set l [read $s 1] + if {[string length $l] == 0} { + if {![eof $s]} { + incr spurious + } else { + close $s + set done 1 + } + } else { + incr len [string length $l] + } + } + set c [socket $remoteServerIP 2836] + fileevent $c readable "readlittle $c" + set timer [after 10000 "set done timed_out"] + vwait done + after cancel $timer + sendCommand {close $socket10_13_test_server} + list $spurious $len +} {0 2690} +test socket-10.12 {testing EOF stickyness} { + set counter 0 + set done 0 + proc count_up {s} { + global counter done after_id + set l [gets $s] + if {[eof $s]} { + incr counter + if {$counter > 9} { + set done {EOF is sticky} + after cancel $after_id + close $s + } + } + } + proc timed_out {} { + global c done + set done {timed_out, EOF is not sticky} + close $c + } + sendCommand { + set socket10_14_test_server [socket -server accept 2836] + proc accept {s a p} { + after 100 close $s + } + } + set c [socket $remoteServerIP 2836] + fileevent $c readable "count_up $c" + set after_id [after 1000 timed_out] + vwait done + sendCommand {close $socket10_14_test_server} + set done +} {EOF is sticky} +test socket-10.13 {testing async write, async flush, async close} { + proc readit {s} { + global count done + set l [read $s] + incr count [string length $l] + if {[eof $s]} { + close $s + set done 1 + } + } + sendCommand { + set firstblock "" + for {set i 0} {$i < 5} {incr i} { + set firstblock "a$firstblock$firstblock" + } + set secondblock "" + for {set i 0} {$i < 16} {incr i} { + set secondblock "b$secondblock$secondblock" + } + set l [socket -server accept 2845] + proc accept {s a p} { + fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ + -buffering line + fileevent $s readable "readable $s" + } + proc readable {s} { + set l [gets $s] + fileevent $s readable {} + after 1000 respond $s + } + proc respond {s} { + global firstblock + puts -nonewline $s $firstblock + after 1000 writedata $s + } + proc writedata {s} { + global secondblock + puts -nonewline $s $secondblock + close $s + } + } + set s [socket $remoteServerIP 2845] + fconfigure $s -blocking 0 -trans lf -buffering line + set count 0 + puts $s hello + fileevent $s readable "readit $s" + set timer [after 10000 "set done timed_out"] + vwait done + after cancel $timer + sendCommand {close $l} + set count +} 65566 + +if {[string match sock* $commandSocket] == 1} { + puts $commandSocket exit + flush $commandSocket +} +catch {close $commandSocket} +catch {close $remoteProcChan} + +set x "" +unset x diff --git a/tests/source.test b/tests/source.test new file mode 100644 index 0000000..9a7e230 --- /dev/null +++ b/tests/source.test @@ -0,0 +1,187 @@ +# Commands covered: source +# +# 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: @(#) source.test 1.26 97/09/24 16:33:37 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test source-1.1 {source command} { + set x "old x value" + set y "old y value" + set z "old z value" + makeFile { + set x 22 + set y 33 + set z 44 + } source.file + source source.file + list $x $y $z +} {22 33 44} +test source-1.2 {source command} { + makeFile {list result} source.file + source source.file +} result + +# The mac version of source returns a different result for +# the next two tests. + +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 + 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 source-2.4 {source error conditions} { + makeFile {break} source.file + catch {source source.file} +} 3 +test source-2.5 {source error conditions} { + makeFile {continue} source.file + catch {source source.file} +} 4 +test source-2.6 {source error conditions} { + normalizeMsg [list [catch {source _non_existent_} msg] $msg $errorCode] +} {1 {couldn't read file "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} + +test source-3.1 {return in middle of source file} { + makeFile { + set x new-x + return allDone + set y new-y + } source.file + set x old-x + set y old-y + set z [source source.file] + list $x $y $z +} {new-x old-y allDone} +test source-3.2 {return with special code etc.} { + makeFile { + set x new-x + return -code break "Silly result" + set y new-y + } source.file + list [catch {source source.file} msg] $msg +} {3 {Silly result}} +test source-3.3 {return with special code etc.} { + makeFile { + set x new-x + return -code error "Simulated error" + set y new-y + } source.file + list [catch {source source.file} msg] $msg $errorInfo $errorCode +} {1 {Simulated error} {Simulated error + while executing +"source source.file"} NONE} +test source-3.4 {return with special code etc.} { + makeFile { + set x new-x + return -code error -errorinfo "Simulated errorInfo stuff" + set y new-y + } source.file + list [catch {source source.file} msg] $msg $errorInfo $errorCode +} {1 {} {Simulated errorInfo stuff + invoked from within +"source source.file"} NONE} +test source-3.5 {return with special code etc.} { + makeFile { + set x new-x + return -code error -errorinfo "Simulated errorInfo stuff" \ + -errorcode {a b c} + set y new-y + } source.file + list [catch {source source.file} msg] $msg $errorInfo $errorCode +} {1 {} {Simulated errorInfo stuff + invoked from within +"source source.file"} {a b c}} + +# Test for the Macintosh specfic features of the source command +test source-4.1 {source error conditions} {macOnly} { + list [catch {source -rsrc _no_exist_} msg] $msg +} [list 1 "The resource \"_no_exist_\" could not be loaded from application."] +test source-4.2 {source error conditions} {macOnly} { + list [catch {source -rsrcid bad_id} msg] $msg +} [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 +test source-4.4 {source error conditions} {macOnly} { + list [catch {source non_switch rsrcName} msg] $msg +} $retMsg2 +test source-4.5 {source error conditions} {macOnly} { + list [catch {source -bad_switch argument} msg] $msg +} $retMsg2 +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\"."] +test source-5.2 {source resource files} {macOnly} { + makeFile {return} source.file + list [catch {source -rsrc rsrcName source.file} msg] $msg +} [list 1 "Error reading the file: \"source.file\"."] +test source-5.3 {source resource files} {macOnly} { + testWriteTextResource -rsrc rsrcName -file rsrc.file {set msg2 ok; return} + set result [catch {source -rsrc rsrcName rsrc.file} msg] + removeFile rsrc.file + list $msg2 $result $msg +} [list ok 0 {}] +test source-5.4 {source resource files} {macOnly} { + catch {unset msg2} + testWriteTextResource -rsrc fileRsrcName -file rsrc.file {set msg2 ok; return} + source -rsrc fileRsrcName rsrc.file + set result [catch {source -rsrc fileRsrcName} msg] + removeFile rsrc.file + list $msg2 $result $msg +} [list ok 1 {The resource "fileRsrcName" could not be loaded from application.}] +test source-5.5 {source resource files} {macOnly} { + testWriteTextResource -rsrcid 200 -file rsrc.file {set msg2 hello; set msg3 bye} + set result [catch {source -rsrcid 200 rsrc.file} msg] + removeFile rsrc.file + list $msg2 $result $msg +} [list hello 0 bye] +test source-5.6 {source resource files} {macOnly} { + testWriteTextResource -rsrcid 200 -file rsrc.file {set msg2 hello; error bad; set msg3 bye} + set result [catch {source -rsrcid 200 rsrc.file} msg] + removeFile rsrc.file + list $msg2 $result $msg +} [list hello 1 bad] + +test source-6.1 {source is binary ok} { + set x {} + makeFile [list set x "a b\0c"] source.file + source source.file + string length $x +} 5 + +catch {removeFile source.file} + +# Generate null final value + +concat {} diff --git a/tests/split.test b/tests/split.test new file mode 100644 index 0000000..a57c714 --- /dev/null +++ b/tests/split.test @@ -0,0 +1,65 @@ +# Commands covered: split +# +# 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: @(#) split.test 1.10 97/07/07 16:30:07 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test split-1.1 {basic split commands} { + split "a\n b\t\r c\n " +} {a {} b {} {} c {} {}} +test split-1.2 {basic split commands} { + split "word 1xyzword 2zword 3" xyz +} {{word 1} {} {} {word 2} {word 3}} +test split-1.3 {basic split commands} { + split "12345" {} +} {1 2 3 4 5} +test split-1.4 {basic split commands} { + split "a\}b\[c\{\]\$" +} "a\\}b\\\[c\\{\\\]\\\$" +test split-1.5 {basic split commands} { + split {} {} +} {} +test split-1.6 {basic split commands} { + split {} +} {} +test split-1.7 {basic split commands} { + split { } +} {{} {} {} {}} +test split-1.8 {basic split commands} { + proc foo {} { + set x {} + foreach f [split {]\n} {}] { + append x $f + } + return $x + } + foo +} {]\n} +test split-1.9 {basic split commands} { + proc foo {} { + set x ab\000c + set y [split $x {}] + return $y + } + foo +} "a b \000 c" +test split-1.10 {basic split commands} { + split "a0ab1b2bbb3\000c4" ab\000c +} {{} 0 {} 1 2 {} {} 3 {} 4} + +test split-2.1 {split errors} { + list [catch split msg] $msg $errorCode +} {1 {wrong # args: should be "split string ?splitChars?"} NONE} +test split-2.2 {split errors} { + list [catch {split a b c} msg] $msg $errorCode +} {1 {wrong # args: should be "split string ?splitChars?"} NONE} diff --git a/tests/string.test b/tests/string.test new file mode 100644 index 0000000..6643d4f --- /dev/null +++ b/tests/string.test @@ -0,0 +1,384 @@ +# Commands covered: string +# +# 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: @(#) string.test 1.15 97/07/02 16:49:27 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test string-1.1 {string compare} { + string compare abcde abdef +} -1 +test string-1.2 {string compare} { + string c abcde ABCDE +} 1 +test string-1.3 {string compare} { + string compare abcde abcde +} 0 +test string-1.4 {string compare} { + list [catch {string compare a} msg] $msg +} {1 {wrong # args: should be "string compare string1 string2"}} +test string-1.5 {string compare} { + list [catch {string compare a b c} msg] $msg +} {1 {wrong # args: should be "string compare string1 string2"}} + +test string-2.1 {string first} { + string first bq abcdefgbcefgbqrs +} 12 +test string-2.2 {string first} { + string fir bcd abcdefgbcefgbqrs +} 1 +test string-2.3 {string first} { + string f b abcdefgbcefgbqrs +} 1 +test string-2.4 {string first} { + string first xxx x123xx345xxx789xxx012 +} 9 +test string-2.5 {string first} { + string first "" x123xx345xxx789xxx012 +} -1 +test string-2.6 {string first} { + list [catch {string first a} msg] $msg +} {1 {wrong # args: should be "string first string1 string2"}} +test string-2.7 {string first} { + list [catch {string first a b c} msg] $msg +} {1 {wrong # args: should be "string first string1 string2"}} + +test string-3.1 {string index} { + string index abcde 0 +} a +test string-3.2 {string index} { + string i abcde 4 +} e +test string-3.3 {string index} { + string index abcde 5 +} {} +test string-3.4 {string index} { + list [catch {string index abcde -10} msg] $msg +} {0 {}} +test string-3.5 {string index} { + list [catch {string index} msg] $msg +} {1 {wrong # args: should be "string index string charIndex"}} +test string-3.6 {string index} { + list [catch {string index a b c} msg] $msg +} {1 {wrong # args: should be "string index string charIndex"}} +test string-3.7 {string index} { + list [catch {string index a xyz} msg] $msg +} {1 {expected integer but got "xyz"}} + +test string-4.1 {string last} { + string la xxx xxxx123xx345x678 +} 1 +test string-4.2 {string last} { + string last xx xxxx123xx345x678 +} 7 +test string-4.3 {string last} { + string las x xxxx123xx345x678 +} 12 +test string-4.4 {string last} { + list [catch {string last a} msg] $msg +} {1 {wrong # args: should be "string last string1 string2"}} +test string-4.5 {string last} { + list [catch {string last a b c} msg] $msg +} {1 {wrong # args: should be "string last string1 string2"}} + +test string-5.1 {string length} { + string length "a little string" +} 15 +test string-5.2 {string length} { + string le "" +} 0 +test string-5.3 {string length} { + list [catch {string length} msg] $msg +} {1 {wrong # args: should be "string length string"}} +test string-5.4 {string length} { + list [catch {string length a b} msg] $msg +} {1 {wrong # args: should be "string length string"}} + +test string-6.1 {string match} { + string match abc abc +} 1 +test string-6.2 {string match} { + string m abc abd +} 0 +test string-6.3 {string match} { + string match ab*c abc +} 1 +test string-6.4 {string match} { + string match ab**c abc +} 1 +test string-6.5 {string match} { + string match ab* abcdef +} 1 +test string-6.6 {string match} { + string match *c abc +} 1 +test string-6.7 {string match} { + string match *3*6*9 0123456789 +} 1 +test string-6.8 {string match} { + string match *3*6*9 01234567890 +} 0 +test string-6.9 {string match} { + string match a?c abc +} 1 +test string-6.10 {string match} { + string match a??c abc +} 0 +test string-6.11 {string match} { + string match ?1??4???8? 0123456789 +} 1 +test string-6.12 {string match} { + string match {[abc]bc} abc +} 1 +test string-6.13 {string match} { + string match {a[abc]c} abc +} 1 +test string-6.14 {string match} { + string match {a[xyz]c} abc +} 0 +test string-6.15 {string match} { + string match {12[2-7]45} 12345 +} 1 +test string-6.16 {string match} { + string match {12[ab2-4cd]45} 12345 +} 1 +test string-6.17 {string match} { + string match {12[ab2-4cd]45} 12b45 +} 1 +test string-6.18 {string match} { + string match {12[ab2-4cd]45} 12d45 +} 1 +test string-6.19 {string match} { + string match {12[ab2-4cd]45} 12145 +} 0 +test string-6.20 {string match} { + string match {12[ab2-4cd]45} 12545 +} 0 +test string-6.21 {string match} { + string match {a\*b} a*b +} 1 +test string-6.22 {string match} { + string match {a\*b} ab +} 0 +test string-6.23 {string match} { + string match {a\*\?\[\]\\\x} "a*?\[\]\\x" +} 1 +test string-6.24 {string match} { + string match ** "" +} 1 +test string-6.25 {string match} { + string match *. "" +} 0 +test string-6.26 {string match} { + string match "" "" +} 1 +test string-6.27 {string match} { + string match \[a a +} 1 +test string-6.28 {string match} { + list [catch {string match a} msg] $msg +} {1 {wrong # args: should be "string match pattern string"}} +test string-6.29 {string match} { + list [catch {string match a b c} msg] $msg +} {1 {wrong # args: should be "string match pattern string"}} + +test string-7.1 {string range} { + string range abcdefghijklmnop 2 14 +} {cdefghijklmno} +test string-7.2 {string range} { + string range abcdefghijklmnop 7 1000 +} {hijklmnop} +test string-7.3 {string range} { + string range abcdefghijklmnop 10 e +} {klmnop} +test string-7.4 {string range} { + string range abcdefghijklmnop 10 9 +} {} +test string-7.5 {string range} { + string range abcdefghijklmnop -3 2 +} {abc} +test string-7.6 {string range} { + string range abcdefghijklmnop -3 -2 +} {} +test string-7.7 {string range} { + string range abcdefghijklmnop 1000 1010 +} {} +test string-7.8 {string range} { + string range abcdefghijklmnop -100 end +} {abcdefghijklmnop} +test string-7.9 {string range} { + list [catch {string range} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test string-7.10 {string range} { + list [catch {string range a 1} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test string-7.11 {string range} { + list [catch {string range a 1 2 3} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test string-7.12 {string range} { + list [catch {string range abc abc 1} msg] $msg +} {1 {bad index "abc": must be integer or "end"}} +test string-7.13 {string range} { + list [catch {string range abc 1 eof} msg] $msg +} {1 {bad index "eof": must be integer or "end"}} +test string-7.14 {string range} { + string range abcdefghijklmnop end end +} {p} +test string-7.15 {string range} { + string range abcdefghijklmnop e 1000 +} {p} + +test string-8.1 {string trim} { + string trim " XYZ " +} {XYZ} +test string-8.2 {string trim} { + string trim "\t\nXYZ\t\n\r\n" +} {XYZ} +test string-8.3 {string trim} { + string trim " A XYZ A " +} {A XYZ A} +test string-8.4 {string trim} { + string trim "XXYYZZABC XXYYZZ" ZYX +} {ABC } +test string-8.5 {string trim} { + string trim " \t\r " +} {} +test string-8.6 {string trim} { + string trim {abcdefg} {} +} {abcdefg} +test string-8.7 {string trim} { + string trim {} +} {} +test string-8.8 {string trim} { + string trim ABC DEF +} {ABC} +test string-8.9 {string trim} { + list [catch {string trim} msg] $msg +} {1 {wrong # args: should be "string trim string ?chars?"}} +test string-8.10 {string trim} { + list [catch {string trim a b c} msg] $msg +} {1 {wrong # args: should be "string trim string ?chars?"}} + +test string-9.1 {string trimleft} { + string trimleft " XYZ " +} {XYZ } +test string-9.2 {string trimleft} { + list [catch {string trimleft} msg] $msg +} {1 {wrong # args: should be "string trimleft string ?chars?"}} + +test string-10.1 {string trimright} { + string trimright " XYZ " +} { XYZ} +test string-10.2 {string trimright} { + string trimright " " +} {} +test string-10.3 {string trimright} { + string trimright "" +} {} +test string-10.4 {string trimright errors} { + list [catch {string trimright} msg] $msg +} {1 {wrong # args: should be "string trimright string ?chars?"}} +test string-10.5 {string trimright errors} { + list [catch {string trimg a} msg] $msg +} {1 {bad option "trimg": must be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} + +test string-11.1 {string tolower} { + string tolower ABCDeF +} {abcdef} +test string-11.2 {string tolower} { + string tolower "ABC XyZ" +} {abc xyz} +test string-11.3 {string tolower} { + string tolower {123#$&*()} +} {123#$&*()} +test string-11.4 {string tolower} { + list [catch {string tolower} msg] $msg +} {1 {wrong # args: should be "string tolower string"}} +test string-11.5 {string tolower} { + list [catch {string tolower a b} msg] $msg +} {1 {wrong # args: should be "string tolower string"}} + +test string-12.1 {string toupper} { + string toupper abCDEf +} {ABCDEF} +test string-12.2 {string toupper} { + string toupper "abc xYz" +} {ABC XYZ} +test string-12.3 {string toupper} { + string toupper {123#$&*()} +} {123#$&*()} +test string-12.4 {string toupper} { + list [catch {string toupper} msg] $msg +} {1 {wrong # args: should be "string toupper string"}} +test string-12.5 {string toupper} { + list [catch {string toupper a b} msg] $msg +} {1 {wrong # args: should be "string toupper string"}} + +test string-13.1 {string wordend} { + list [catch {string wordend a} msg] $msg +} {1 {wrong # args: should be "string wordend string index"}} +test string-13.2 {string wordend} { + list [catch {string wordend a b c} msg] $msg +} {1 {wrong # args: should be "string wordend string index"}} +test string-13.3 {string wordend} { + list [catch {string wordend a gorp} msg] $msg +} {1 {expected integer but got "gorp"}} +test string-13.4 {string wordend} { + string wordend abc. -1 +} 3 +test string-13.5 {string wordend} { + string wordend abc. 100 +} 4 +test string-13.6 {string wordend} { + string wordend "word_one two three" 2 +} 8 +test string-13.7 {string wordend} { + string wordend "one .&# three" 5 +} 6 +test string-13.8 {string wordend} { + string worde "x.y" 0 +} 1 + +test string-14.1 {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 string-14.2 {string wordstart} { + list [catch {string wordstart a} msg] $msg +} {1 {wrong # args: should be "string wordstart string index"}} +test string-14.3 {string wordstart} { + list [catch {string wordstart a b c} msg] $msg +} {1 {wrong # args: should be "string wordstart string index"}} +test string-14.4 {string wordstart} { + list [catch {string wordstart a gorp} msg] $msg +} {1 {expected integer but got "gorp"}} +test string-14.5 {string wordstart} { + string wordstart "one two three_words" 400 +} 8 +test string-14.6 {string wordstart} { + string wordstart "one two three_words" 2 +} 0 +test string-14.7 {string wordend} { + string wordstart "one two three_words" -2 +} 0 +test string-14.8 {string wordend} { + string wordstart "one .*&^ three" 6 +} 6 +test string-14.9 {string wordend} { + string wordstart "one two three" 4 +} 4 + +test string-15.1 {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 string-15.2 {error conditions} { + list [catch {string} msg] $msg +} {1 {wrong # args: should be "string option arg ?arg ...?"}} diff --git a/tests/stringObj.test b/tests/stringObj.test new file mode 100644 index 0000000..3d03bad --- /dev/null +++ b/tests/stringObj.test @@ -0,0 +1,189 @@ +# Commands covered: none +# +# This file contains tests for the procedures in tclStringObj.c +# that implement the Tcl type manager for the string type. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# @(#) stringObj.test 1.8 97/04/09 11:29:37 + +if {[info commands testobj] == {}} { + puts "This application hasn't been compiled with the \"testobj\"" + puts "command, so I can't test the Tcl type and object support." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test stringObj-1.1 {string type registration} { + set t [testobj types] + set first [string first "string" $t] + set result [expr {$first != -1}] +} {1} + +test stringObj-2.1 {Tcl_NewStringObj} { + set result "" + lappend result [testobj freeallvars] + lappend result [teststringobj set 1 abcd] + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} abcd string 2} + +test stringObj-3.1 {Tcl_SetStringObj, existing "empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testobj newobj 1] + lappend result [teststringobj set 1 xyz] ;# makes existing obj a string + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} {} xyz string 2} +test stringObj-3.2 {Tcl_SetStringObj, existing non-"empty string" object} { + set result "" + lappend result [testobj freeallvars] + lappend result [testintobj set 1 512] + lappend result [teststringobj set 1 foo] ;# makes existing obj a string + lappend result [testobj type 1] + lappend result [testobj refcount 1] +} {{} 512 foo string 2} + +test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} { + testobj freeallvars + teststringobj set 1 test + teststringobj setlength 1 3 + list [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj get 1] +} {3 4 tes} +test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} { + testobj freeallvars + teststringobj set 1 abcdef + teststringobj setlength 1 10 + list [teststringobj length 1] [teststringobj length2 1] +} {10 10} +test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} { + testobj freeallvars + teststringobj set 1 abcdef + teststringobj append 1 xyzq -1 + list [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj get 1] +} {10 20 abcdefxyzq} +test stringObj-4.4 {Tcl_SetObjLength procedure, "expty string", length 0} { + testobj freeallvars + testobj newobj 1 + teststringobj setlength 1 0 + list [teststringobj length2 1] [teststringobj get 1] +} {0 {}} + +test stringObj-5.1 {Tcl_AppendToObj procedure, type conversion} { + testobj freeallvars + testintobj set2 1 43 + teststringobj append 1 xyz -1 + teststringobj get 1 +} {43xyz} +test stringObj-5.2 {Tcl_AppendToObj procedure, length calculation} { + testobj freeallvars + teststringobj set 1 {x y } + teststringobj append 1 bbCCddEE 4 + teststringobj append 1 123 -1 + teststringobj get 1 +} {x y bbCC123} +test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} { + testobj freeallvars + teststringobj set 1 xyz + teststringobj setlength 1 15 + teststringobj setlength 1 2 + set result {} + teststringobj append 1 1234567890123 -1 + lappend result [teststringobj length 1] [teststringobj length2 1] + teststringobj setlength 1 10 + teststringobj append 1 abcdef -1 + lappend result [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj get 1] +} {15 15 16 32 xy12345678abcdef} + +test stringObj-6.1 {Tcl_AppendStringsToObj procedure, type conversion} { + testobj freeallvars + teststringobj set2 1 [list a b] + teststringobj appendstrings 1 xyz { 1234 } foo + teststringobj get 1 +} {a bxyz 1234 foo} +test stringObj-6.2 {Tcl_AppendStringsToObj procedure, counting space} { + testobj freeallvars + teststringobj set 1 abc + teststringobj appendstrings 1 + list [teststringobj length 1] [teststringobj get 1] +} {3 abc} +test stringObj-6.3 {Tcl_AppendStringsToObj procedure, counting space} { + testobj freeallvars + teststringobj set 1 abc + teststringobj appendstrings 1 {} {} {} {} + list [teststringobj length 1] [teststringobj get 1] +} {3 abc} +test stringObj-6.4 {Tcl_AppendStringsToObj procedure, counting space} { + testobj freeallvars + teststringobj set 1 abc + teststringobj appendstrings 1 { 123 } abcdefg + list [teststringobj length 1] [teststringobj get 1] +} {15 {abc 123 abcdefg}} +test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} { + testobj freeallvars + testobj newobj 1 + teststringobj appendstrings 1 123 abcdefg + list [teststringobj length 1] [teststringobj length2 1] [teststringobj get 1] +} {10 10 123abcdefg} +test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} { + testobj freeallvars + teststringobj set 1 abc + teststringobj setlength 1 10 + teststringobj setlength 1 2 + teststringobj appendstrings 1 34567890 + list [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj get 1] +} {10 10 ab34567890} +test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} { + testobj freeallvars + teststringobj set 1 abc + teststringobj setlength 1 10 + teststringobj setlength 1 2 + teststringobj appendstrings 1 34567890x + list [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj get 1] +} {11 22 ab34567890x} +test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} { + testobj freeallvars + testobj newobj 1 + teststringobj appendstrings 1 {} + list [teststringobj length2 1] [teststringobj get 1] +} {0 {}} + +test stringObj-7.1 {ConvertToStringType procedure} { + testobj freeallvars + teststringobj set2 1 [list a b] + teststringobj append 1 x -1 + list [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj get 1] +} {4 8 {a bx}} +test stringObj-7.2 {ConvertToStringType procedure, null object} { + testobj freeallvars + testobj newobj 1 + teststringobj appendstrings 1 {} + list [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj get 1] +} {0 0 {}} + +test stringObj-8.1 {DupStringInternalRep procedure} { + testobj freeallvars + teststringobj set 1 {} + teststringobj append 1 abcde -1 + testobj duplicate 1 2 + list [teststringobj length 1] [teststringobj length2 1] \ + [teststringobj length 2] [teststringobj length2 2] \ + [teststringobj get 2] +} {5 10 5 5 abcde} + +testobj freeallvars diff --git a/tests/subst.test b/tests/subst.test new file mode 100644 index 0000000..356114d --- /dev/null +++ b/tests/subst.test @@ -0,0 +1,106 @@ +# Commands covered: subst +# +# 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) 1994 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: @(#) subst.test 1.8 97/06/23 18:20:15 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test subst-1.1 {basics} { + list [catch {subst} msg] $msg +} {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}} +test subst-1.2 {basics} { + list [catch {subst a b c} msg] $msg +} {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}} + +test subst-2.1 {simple strings} { + subst {} +} {} +test subst-2.2 {simple strings} { + subst a +} a +test subst-2.3 {simple strings} { + subst abcdefg +} abcdefg + +test subst-3.1 {backslash substitutions} { + subst {\x\$x\[foo bar]\\} +} "x\$x\[foo bar]\\" + +test subst-4.1 {variable substitutions} { + set a 44 + subst {$a} +} {44} +test subst-4.2 {variable substitutions} { + set a 44 + subst {x$a.y{$a}.z} +} {x44.y{44}.z} +test subst-4.3 {variable substitutions} { + catch {unset a} + set a(13) 82 + set i 13 + subst {x.$a($i)} +} {x.82} +catch {unset a} +set long {This is a very long string, intentionally made so long that it + will overflow the static character size for dstrings, so that + additional memory will have to be allocated by subst. That way, + if the subst procedure forgets to free up memory while returning + an error, there will be memory that isn't freed (this will be + detected when the tests are run under a checking memory allocator + such as Purify).} +test subst-4.4 {variable substitutions} { + list [catch {subst {$long $a}} msg] $msg +} {1 {can't read "a": no such variable}} + +test subst-5.1 {command substitutions} { + subst {[concat {}]} +} {} +test subst-5.2 {command substitutions} { + subst {[concat A test string]} +} {A test string} +test subst-5.3 {command substitutions} { + subst {x.[concat foo].y.[concat bar].z} +} {x.foo.y.bar.z} +test subst-5.4 {command substitutions} { + list [catch {subst {$long [set long] [bogus_command]}} msg] $msg +} {1 {invalid command name "bogus_command"}} + +test subst-6.1 {clear the result after command substitution} { + catch {unset a} + list [catch {subst {[concat foo] $a}} msg] $msg +} {1 {can't read "a": no such variable}} + +test subst-7.1 {switches} { + list [catch {subst foo bar} msg] $msg +} {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}} +test subst-7.3 {switches} { + list [catch {subst -bogus bar} msg] $msg +} {1 {bad switch "-bogus": must be -nobackslashes, -nocommands, or -novariables}} +test subst-7.4 {switches} { + set x 123 + subst -nobackslashes {abc $x [expr 1+2] \\\x41} +} {abc 123 3 \\\x41} +test subst-7.5 {switches} { + set x 123 + subst -nocommands {abc $x [expr 1+2] \\\x41} +} {abc 123 [expr 1+2] \A} +test subst-7.6 {switches} { + set x 123 + subst -novariables {abc $x [expr 1+2] \\\x41} +} {abc $x 3 \A} +test subst-7.7 {switches} { + set x 123 + subst -nov -nob -noc {abc $x [expr 1+2] \\\x41} +} {abc $x [expr 1+2] \\\x41} diff --git a/tests/switch.test b/tests/switch.test new file mode 100644 index 0000000..347e7a5 --- /dev/null +++ b/tests/switch.test @@ -0,0 +1,179 @@ +# Commands covered: switch +# +# 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) 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: @(#) switch.test 1.7 97/02/10 17:27:13 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test switch-1.1 {simple patterns} { + switch a a {format 1} b {format 2} c {format 3} default {format 4} +} 1 +test switch-1.2 {simple patterns} { + switch b a {format 1} b {format 2} c {format 3} default {format 4} +} 2 +test switch-1.3 {simple patterns} { + switch x a {format 1} b {format 2} c {format 3} default {format 4} +} 4 +test switch-1.4 {simple patterns} { + switch x a {format 1} b {format 2} c {format 3} +} {} +test switch-1.5 {simple pattern matches many times} { + switch b a {format 1} b {format 2} b {format 3} b {format 4} +} 2 +test switch-1.6 {simple patterns} { + switch default a {format 1} default {format 2} c {format 3} default {format 4} +} 2 +test switch-1.7 {simple patterns} { + switch x a {format 1} default {format 2} c {format 3} default {format 4} +} 4 + +test switch-2.1 {single-argument form for pattern/command pairs} { + switch b { + a {format 1} + b {format 2} + default {format 6} + } +} {2} +test switch-2.2 {single-argument form for pattern/command pairs} { + list [catch {switch z {a 2 b}} msg] $msg +} {1 {extra switch pattern with no body}} + +test switch-3.1 {-exact vs. -glob vs. -regexp} { + switch -exact aaaab { + ^a*b$ {concat regexp} + *b {concat glob} + aaaab {concat exact} + default {concat none} + } +} exact +test switch-3.2 {-exact vs. -glob vs. -regexp} { + switch -exact -regexp aaaab { + ^a*b$ {concat regexp} + *b {concat glob} + aaaab {concat exact} + default {concat none} + } +} regexp +test switch-3.3 {-exact vs. -glob vs. -regexp} { + switch -glob aaaab { + ^a*b$ {concat regexp} + *b {concat glob} + aaaab {concat exact} + default {concat none} + } +} glob +test switch-3.4 {-exact vs. -glob vs. -regexp} { + switch aaaab {^a*b$} {concat regexp} *b {concat glob} \ + aaaab {concat exact} default {concat none} +} exact +test switch-3.5 {-exact vs. -glob vs. -regexp} { + switch -- -glob { + ^g.*b$ {concat regexp} + -* {concat glob} + -glob {concat exact} + default {concat none} + } +} exact +test switch-3.6 {-exact vs. -glob vs. -regexp} { + list [catch {switch -foo a b c} msg] $msg +} {1 {bad option "-foo": must be -exact, -glob, -regexp, or --}} + +test switch-4.1 {error in executed command} { + list [catch {switch a a {error "Just a test"} default {format 1}} msg] \ + $msg $errorInfo +} {1 {Just a test} {Just a test + while executing +"error "Just a test"" + ("a" arm line 1) + invoked from within +"switch a a {error "Just a test"} default {format 1}"}} +test switch-4.2 {error: not enough args} { + list [catch {switch} msg] $msg +} {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}} +test switch-4.3 {error: pattern with no body} { + list [catch {switch a b} msg] $msg +} {1 {extra switch pattern with no body}} +test switch-4.4 {error: pattern with no body} { + list [catch {switch a b {format 1} c} msg] $msg +} {1 {extra switch pattern with no body}} +test switch-4.5 {error in default command} { + list [catch {switch foo a {error switch1} b {error switch 3} \ + default {error switch2}} msg] $msg $errorInfo +} {1 switch2 {switch2 + while executing +"error switch2" + ("default" arm line 1) + invoked from within +"switch foo a {error switch1} b {error switch 3} default {error switch2}"}} + +test switch-5.1 {errors in -regexp matching} { + list [catch {switch -regexp aaaab { + *b {concat glob} + aaaab {concat exact} + default {concat none} + }} msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test switch-6.1 {backslashes in patterns} { + switch -exact {\a\$\.\[} { + \a\$\.\[ {concat first} + \a\\$\.\\[ {concat second} + \\a\\$\\.\\[ {concat third} + {\a\\$\.\\[} {concat fourth} + {\\a\\$\\.\\[} {concat fifth} + default {concat none} + } +} third +test switch-6.2 {backslashes in patterns} { + switch -exact {\a\$\.\[} { + \a\$\.\[ {concat first} + {\a\$\.\[} {concat second} + {{\a\$\.\[}} {concat third} + default {concat none} + } +} second + +test switch-7.1 {"-" bodies} { + switch a { + a - + b - + c {concat 1} + default {concat 2} + } +} 1 +test switch-7.2 {"-" bodies} { + list [catch { + switch a { + a - + b - + c - + } + } msg] $msg +} {1 {no body specified for pattern "a"}} +test switch-7.3 {"-" bodies} { + list [catch { + switch a { + a - + b -foo + c - + } + } msg] $msg +} {1 {invalid command name "-foo"}} + +test switch-8.1 {empty body} { + set msg {} + switch {2} { + 1 {set msg 1} + 2 {} + default {set msg 2} + } +} {} diff --git a/tests/timer.test b/tests/timer.test new file mode 100644 index 0000000..4671366 --- /dev/null +++ b/tests/timer.test @@ -0,0 +1,455 @@ +# This file contains a collection of tests for the procedures in the +# file tclTimer.c, which includes the "after" Tcl command. Sourcing +# this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) timer.test 1.2 97/04/29 11:59:59 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test timer-1.1 {Tcl_CreateTimerHandler procedure} { + foreach i [after info] { + after cancel $i + } + set x "" + foreach i {100 200 1000 50 150} { + after $i lappend x $i + } + after 200 + update + set x +} {50 100 150 200} + +test timer-2.1 {Tcl_DeleteTimerHandler procedure} { + foreach i [after info] { + after cancel $i + } + set x "" + foreach i {100 200 300 50 150} { + after $i lappend x $i + } + after cancel lappend x 150 + after cancel lappend x 50 + after 200 + update + set x +} {100 200} + +# No tests for Tcl_ServiceTimer or ResetTimer, since it is already tested +# above. + +test timer-3.1 {TimerHandlerEventProc procedure: event masks} { + set x start + after 100 { set x fired } + update idletasks + set result $x + after 200 + update + lappend result $x +} {start fired} +test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} { + foreach i [after info] { + after cancel $i + } + foreach i {200 600 1000} { + after $i lappend x $i + } + after 200 + set result "" + set x "" + update + lappend result $x + after 400 + update + lappend result $x + after 400 + update + lappend result $x +} {200 {200 600} {200 600 1000}} +test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} { + foreach i [after info] { + after cancel $i + } + set x {} + after 100 lappend x 100 + set i [after 300 lappend x 300] + after 200 after cancel $i + after 400 + update + set x +} 100 +test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} { + foreach i [after info] { + after cancel $i + } + set x {} + after 100 lappend x a + after 200 lappend x b + after 300 lappend x c + after 300 + vwait x + set x +} {a b c} +test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} { + foreach i [after info] { + after cancel $i + } + set x {} + after 100 {lappend x a; after 0 lappend x b} + after 100 + vwait x + set x +} a +test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} { + foreach i [after info] { + after cancel $i + } + set x {} + after 100 {lappend x a; after 100 lappend x b; after 100} + after 100 + vwait x + set result $x + vwait x + lappend result $x +} {a {a b}} + +# No tests for Tcl_DoWhenIdle: it's already tested by other tests +# below. + +test timer-4.1 {Tcl_CancelIdleCall procedure} { + foreach i [after info] { + after cancel $i + } + set x before + set y before + set z before + after idle set x after1 + after idle set y after2 + after idle set z after3 + after cancel set y after2 + update idletasks + concat $x $y $z +} {after1 before after3} +test timer-4.2 {Tcl_CancelIdleCall procedure} { + foreach i [after info] { + after cancel $i + } + set x before + set y before + set z before + after idle set x after1 + after idle set y after2 + after idle set z after3 + after cancel set x after1 + update idletasks + concat $x $y $z +} {before after2 after3} + +test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} { + foreach i [after info] { + after cancel $i + } + set x 1 + set y 23 + after idle {incr x; after idle {incr x; after idle {incr x}}} + after idle {incr y} + vwait x + set result "$x $y" + update idletasks + lappend result $x +} {2 24 4} + +test timer-6.1 {Tcl_AfterCmd procedure, basics} { + list [catch {after} msg] $msg +} {1 {wrong # args: should be "after option ?arg arg ...?"}} +test timer-6.2 {Tcl_AfterCmd procedure, basics} { + list [catch {after 2x} msg] $msg +} {1 {expected integer but got "2x"}} +test timer-6.3 {Tcl_AfterCmd procedure, basics} { + list [catch {after gorp} msg] $msg +} {1 {bad argument "gorp": must be cancel, idle, info, or a number}} +test timer-6.4 {Tcl_AfterCmd procedure, ms argument} { + set x before + after 400 {set x after} + after 200 + update + set y $x + after 400 + update + list $y $x +} {before after} +test timer-6.5 {Tcl_AfterCmd procedure, ms argument} { + set x before + after 300 set x after + after 200 + update + set y $x + after 200 + update + list $y $x +} {before after} +test timer-6.6 {Tcl_AfterCmd procedure, cancel option} { + list [catch {after cancel} msg] $msg +} {1 {wrong # args: should be "after cancel id|command"}} +test timer-6.7 {Tcl_AfterCmd procedure, cancel option} { + after cancel after#1 +} {} +test timer-6.8 {Tcl_AfterCmd procedure, cancel option} { + after cancel {foo bar} +} {} +test timer-6.9 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x before + set y [after 100 set x after] + after cancel $y + after 200 + update + set x +} {before} +test timer-6.10 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x before + after 100 set x after + after cancel {set x after} + after 200 + update + set x +} {before} +test timer-6.11 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x before + after 100 set x after + set id [after 300 set x after] + after cancel $id + after 200 + update + set y $x + set x cleared + after 200 + update + list $y $x +} {after cleared} +test timer-6.12 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x first + after idle lappend x second + after idle lappend x third + set i [after idle lappend x fourth] + after cancel {lappend x second} + after cancel $i + update idletasks + set x +} {first third} +test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} { + foreach i [after info] { + after cancel $i + } + set x first + after idle lappend x second + after idle lappend x third + set i [after idle lappend x fourth] + after cancel lappend x second + after cancel $i + update idletasks + set x +} {first third} +test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} { + foreach i [after info] { + after cancel $i + } + set id [ + after 100 { + set x done + after cancel $id + } + ] + vwait x +} {} +test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} { + foreach i [after info] { + after cancel $i + } + interp create x + x eval {set a before; set b before; after idle {set a a-after}; + after idle {set b b-after}} + set result [llength [x eval after info]] + lappend result [llength [after info]] + after cancel {set b b-after} + set a aaa + set b bbb + x eval {after cancel set a a-after} + update idletasks + lappend result $a $b [x eval {list $a $b}] + interp delete x + set result +} {2 0 aaa bbb {before b-after}} +test timer-6.16 {Tcl_AfterCmd procedure, idle option} { + list [catch {after idle} msg] $msg +} {1 {wrong # args: should be "after idle script script ..."}} +test timer-6.17 {Tcl_AfterCmd procedure, idle option} { + set x before + after idle {set x after} + set y $x + update idletasks + list $y $x +} {before after} +test timer-6.18 {Tcl_AfterCmd procedure, idle option} { + set x before + after idle set x after + set y $x + update idletasks + list $y $x +} {before after} +set event1 [after idle event 1] +set event2 [after 1000 event 2] +interp create x +set childEvent [x eval {after idle event in child}] +test timer-6.19 {Tcl_AfterCmd, info option} { + lsort [after info] +} [lsort "$event1 $event2"] +test timer-6.20 {Tcl_AfterCmd, info option} { + list [catch {after info a b} msg] $msg +} {1 {wrong # args: should be "after info ?id?"}} +test timer-6.21 {Tcl_AfterCmd, info option} { + list [catch {after info $childEvent} msg] $msg +} "1 {event \"$childEvent\" doesn't exist}" +test timer-6.22 {Tcl_AfterCmd, info option} { + list [after info $event1] [after info $event2] +} {{{event 1} idle} {{event 2} timer}} +after cancel $event1 +after cancel $event2 +interp delete x + +set event [after idle foo bar] +scan $event after#%d id +test timer-7.1 {GetAfterEvent procedure} { + list [catch {after info xfter#$id} msg] $msg +} "1 {event \"xfter#$id\" doesn't exist}" +test timer-7.2 {GetAfterEvent procedure} { + list [catch {after info afterx$id} msg] $msg +} "1 {event \"afterx$id\" doesn't exist}" +test timer-7.3 {GetAfterEvent procedure} { + list [catch {after info after#ab} msg] $msg +} {1 {event "after#ab" doesn't exist}} +test timer-7.4 {GetAfterEvent procedure} { + list [catch {after info after#} msg] $msg +} {1 {event "after#" doesn't exist}} +test timer-7.5 {GetAfterEvent procedure} { + list [catch {after info after#${id}x} msg] $msg +} "1 {event \"after#${id}x\" doesn't exist}" +test timer-7.6 {GetAfterEvent procedure} { + list [catch {after info afterx[expr $id+1]} msg] $msg +} "1 {event \"afterx[expr $id+1]\" doesn't exist}" +after cancel $event + +test timer-8.1 {AfterProc procedure} { + set x before + proc foo {} { + set x untouched + after 100 {set x after} + after 200 + update + return $x + } + list [foo] $x +} {untouched after} +test timer-8.2 {AfterProc procedure} { + catch {rename bgerror {}} + proc bgerror msg { + global x errorInfo + set x [list $msg $errorInfo] + } + set x empty + after 100 {error "After error"} + after 200 + set y $x + update + catch {rename bgerror {}} + list $y $x +} {empty {{After error} {After error + while executing +"error "After error"" + ("after" script)}}} +test timer-8.3 {AfterProc procedure, deleting handler from itself} { + foreach i [after info] { + after cancel $i + } + proc foo {} { + global x + set x {} + foreach i [after info] { + lappend x [after info $i] + } + after cancel foo + } + after idle foo + after 1000 {error "I shouldn't ever have executed"} + update idletasks + set x +} {{{error "I shouldn't ever have executed"} timer}} +test timer-8.4 {AfterProc procedure, deleting handler from itself} { + foreach i [after info] { + after cancel $i + } + proc foo {} { + global x + set x {} + foreach i [after info] { + lappend x [after info $i] + } + after cancel foo + } + after 1000 {error "I shouldn't ever have executed"} + after idle foo + update idletasks + set x +} {{{error "I shouldn't ever have executed"} timer}} + +foreach i [after info] { + after cancel $i +} + +# No test for FreeAfterPtr, since it is already tested above. + + +test timer-9.1 {AfterCleanupProc procedure} { + catch {interp delete x} + interp create x + x eval {after 200 { + lappend x after + puts "part 1: this message should not appear" + }} + after 200 {lappend x after2} + x eval {after 200 { + lappend x after3 + puts "part 2: this message should not appear" + }} + after 200 {lappend x after4} + x eval {after 200 { + lappend x after5 + puts "part 3: this message should not appear" + }} + interp delete x + set x before + after 300 + update + set x +} {before after2 after4} + diff --git a/tests/trace.test b/tests/trace.test new file mode 100644 index 0000000..b4d02d3 --- /dev/null +++ b/tests/trace.test @@ -0,0 +1,966 @@ +# Commands covered: trace +# +# 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: @(#) trace.test 1.27 97/07/23 17:08:38 + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc traceScalar {name1 name2 op} { + global info + set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg] +} +proc traceScalarAppend {name1 name2 op} { + global info + lappend info $name1 $name2 $op [catch {uplevel set $name1} msg] $msg +} +proc traceArray {name1 name2 op} { + global info + set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg] +} +proc traceArray2 {name1 name2 op} { + global info + set info [list $name1 $name2 $op] +} +proc traceProc {name1 name2 op} { + global info + set info [concat $info [list $name1 $name2 $op]] +} +proc traceTag {tag args} { + global info + set info [concat $info $tag] +} +proc traceError {args} { + error "trace returned error" +} +proc traceCheck {cmd args} { + global info + set info [list [catch $cmd msg] $msg] +} +proc traceCrtElement {value name1 name2 op} { + uplevel set ${name1}($name2) $value +} + +# Read-tracing on variables + +test trace-1.1 {trace variable reads} { + catch {unset x} + set info {} + trace var x r traceScalar + list [catch {set x} msg] $msg $info +} {1 {can't read "x": no such variable} {x {} r 1 {can't read "x": no such variable}}} +test trace-1.2 {trace variable reads} { + catch {unset x} + set x 123 + set info {} + trace var x r traceScalar + list [catch {set x} msg] $msg $info +} {0 123 {x {} r 0 123}} +test trace-1.3 {trace variable reads} { + catch {unset x} + set info {} + trace var x r traceScalar + set x 123 + set info +} {} +test trace-1.4 {trace array element reads} { + catch {unset x} + set info {} + trace var x(2) r traceArray + list [catch {set x(2)} msg] $msg $info +} {1 {can't read "x(2)": no such element in array} {x 2 r 1 {can't read "x(2)": no such element in array}}} +test trace-1.5 {trace array element reads} { + catch {unset x} + set x(2) zzz + set info {} + trace var x(2) r traceArray + list [catch {set x(2)} msg] $msg $info +} {0 zzz {x 2 r 0 zzz}} +test trace-1.6 {trace array element reads} { + catch {unset x} + set info {} + trace variable x r traceArray2 + proc p {} { + global x + set x(2) willi + return $x(2) + } + list [catch {p} msg] $msg $info +} {0 willi {x 2 r}} +test trace-1.7 {trace array element reads, create element undefined if nonexistant} { + catch {unset x} + set info {} + trace variable x r q + proc q {name1 name2 op} { + global info + set info [list $name1 $name2 $op] + global $name1 + set ${name1}($name2) wolf + } + proc p {} { + global x + set x(X) willi + return $x(Y) + } + list [catch {p} msg] $msg $info +} {0 wolf {x Y r}} +test trace-1.8 {trace reads on whole arrays} { + catch {unset x} + set info {} + trace var x r traceArray + list [catch {set x(2)} msg] $msg $info +} {1 {can't read "x(2)": no such variable} {}} +test trace-1.9 {trace reads on whole arrays} { + catch {unset x} + set x(2) zzz + set info {} + trace var x r traceArray + list [catch {set x(2)} msg] $msg $info +} {0 zzz {x 2 r 0 zzz}} +test trace-1.10 {trace variable reads} { + catch {unset x} + set x 444 + set info {} + trace var x r traceScalar + unset x + set info +} {} + +# Basic write-tracing on variables + +test trace-2.1 {trace variable writes} { + catch {unset x} + set info {} + trace var x w traceScalar + set x 123 + set info +} {x {} w 0 123} +test trace-2.2 {trace writes to array elements} { + catch {unset x} + set info {} + trace var x(33) w traceArray + set x(33) 444 + set info +} {x 33 w 0 444} +test trace-2.3 {trace writes on whole arrays} { + catch {unset x} + set info {} + trace var x w traceArray + set x(abc) qq + set info +} {x abc w 0 qq} +test trace-2.4 {trace variable writes} { + catch {unset x} + set x 1234 + set info {} + trace var x w traceScalar + set x + set info +} {} +test trace-2.5 {trace variable writes} { + catch {unset x} + set x 1234 + set info {} + trace var x w traceScalar + unset x + set info +} {} + +# append no longer triggers read traces when fetching the old values of +# variables before doing the append operation. However, lappend _does_ +# still trigger these read traces. Also lappend triggers only one write +# trace: after appending all arguments to the list. + +test trace-3.1 {trace variable read-modify-writes} { + catch {unset x} + set info {} + trace var x r traceScalarAppend + append x 123 + append x 456 + lappend x 789 + set info +} {x {} r 0 123456} +test trace-3.2 {trace variable read-modify-writes} { + catch {unset x} + set info {} + trace var x rw traceScalarAppend + append x 123 + lappend x 456 + set info +} {x {} w 0 123 x {} r 0 123 x {} w 0 {123 456}} + +# Basic unset-tracing on variables + +test trace-4.1 {trace variable unsets} { + catch {unset x} + set info {} + trace var x u traceScalar + catch {unset x} + set info +} {x {} u 1 {can't read "x": no such variable}} +test trace-4.2 {variable mustn't exist during unset trace} { + catch {unset x} + set x 1234 + set info {} + trace var x u traceScalar + unset x + set info +} {x {} u 1 {can't read "x": no such variable}} +test trace-4.3 {unset traces mustn't be called during reads and writes} { + catch {unset x} + set info {} + trace var x u traceScalar + set x 44 + set x + set info +} {} +test trace-4.4 {trace unsets on array elements} { + catch {unset x} + set x(0) 18 + set info {} + trace var x(1) u traceArray + catch {unset x(1)} + set info +} {x 1 u 1 {can't read "x(1)": no such element in array}} +test trace-4.5 {trace unsets on array elements} { + catch {unset x} + set x(1) 18 + set info {} + trace var x(1) u traceArray + unset x(1) + set info +} {x 1 u 1 {can't read "x(1)": no such element in array}} +test trace-4.6 {trace unsets on array elements} { + catch {unset x} + set x(1) 18 + set info {} + trace var x(1) u traceArray + unset x + set info +} {x 1 u 1 {can't read "x(1)": no such variable}} +test trace-4.7 {trace unsets on whole arrays} { + catch {unset x} + set x(1) 18 + set info {} + trace var x u traceProc + catch {unset x(0)} + set info +} {} +test trace-4.8 {trace unsets on whole arrays} { + catch {unset x} + set x(1) 18 + set x(2) 144 + set x(3) 14 + set info {} + trace var x u traceProc + unset x(1) + set info +} {x 1 u} +test trace-4.9 {trace unsets on whole arrays} { + catch {unset x} + set x(1) 18 + set x(2) 144 + set x(3) 14 + set info {} + trace var x u traceProc + unset x + set info +} {x {} u} + +# Trace multiple trace types at once. + +test trace-5.1 {multiple ops traced at once} { + catch {unset x} + set info {} + trace var x rwu traceProc + catch {set x} + set x 22 + set x + set x 33 + unset x + set info +} {x {} r x {} w x {} r x {} w x {} u} +test trace-5.2 {multiple ops traced on array element} { + catch {unset x} + set info {} + trace var x(0) rwu traceProc + catch {set x(0)} + set x(0) 22 + set x(0) + set x(0) 33 + unset x(0) + unset x + set info +} {x 0 r x 0 w x 0 r x 0 w x 0 u} +test trace-5.3 {multiple ops traced on whole array} { + catch {unset x} + set info {} + trace var x rwu traceProc + catch {set x(0)} + set x(0) 22 + set x(0) + set x(0) 33 + unset x(0) + unset x + set info +} {x 0 w x 0 r x 0 w x 0 u x {} u} + +# Check order of invocation of traces + +test trace-6.1 {order of invocation of traces} { + catch {unset x} + set info {} + trace var x r "traceTag 1" + trace var x r "traceTag 2" + trace var x r "traceTag 3" + catch {set x} + set x 22 + set x + set info +} {3 2 1 3 2 1} +test trace-6.2 {order of invocation of traces} { + catch {unset x} + set x(0) 44 + set info {} + trace var x(0) r "traceTag 1" + trace var x(0) r "traceTag 2" + trace var x(0) r "traceTag 3" + set x(0) + set info +} {3 2 1} +test trace-6.3 {order of invocation of traces} { + catch {unset x} + set x(0) 44 + set info {} + trace var x(0) r "traceTag 1" + trace var x r "traceTag A1" + trace var x(0) r "traceTag 2" + trace var x r "traceTag A2" + trace var x(0) r "traceTag 3" + trace var x r "traceTag A3" + set x(0) + set info +} {A3 A2 A1 3 2 1} + +# Check effects of errors in trace procedures + +test trace-7.1 {error returns from traces} { + catch {unset x} + set x 123 + set info {} + trace var x r "traceTag 1" + trace var x r traceError + list [catch {set x} msg] $msg $info +} {1 {can't read "x": trace returned error} {}} +test trace-7.2 {error returns from traces} { + catch {unset x} + set x 123 + set info {} + trace var x w "traceTag 1" + trace var x w traceError + list [catch {set x 44} msg] $msg $info +} {1 {can't set "x": trace returned error} {}} +test trace-7.3 {error returns from traces} { + catch {unset x} + set x 123 + set info {} + trace var x w traceError + list [catch {append x 44} msg] $msg $info +} {1 {can't set "x": trace returned error} {}} +test trace-7.4 {error returns from traces} { + catch {unset x} + set x 123 + set info {} + trace var x u "traceTag 1" + trace var x u traceError + list [catch {unset x} msg] $msg $info +} {0 {} 1} +test trace-7.5 {error returns from traces} { + catch {unset x} + set x(0) 123 + set info {} + trace var x(0) r "traceTag 1" + trace var x r "traceTag 2" + trace var x r traceError + trace var x r "traceTag 3" + list [catch {set x(0)} msg] $msg $info +} {1 {can't read "x(0)": trace returned error} 3} +test trace-7.6 {error returns from traces} { + catch {unset x} + set x 123 + trace var x u traceError + list [catch {unset x} msg] $msg +} {0 {}} +test trace-7.7 {error returns from traces} { + # This test just makes sure that the memory for the error message + # gets deallocated correctly when the trace is invoked again or + # when the trace is deleted. + catch {unset x} + set x 123 + trace var x r traceError + catch {set x} + catch {set x} + trace vdelete x r traceError +} {} + +# Check to see that variables are expunged before trace +# procedures are invoked, so trace procedure can even manipulate +# a new copy of the variables. + +test trace-8.1 {be sure variable is unset before trace is called} { + catch {unset x} + set x 33 + set info {} + trace var x u {traceCheck {uplevel set x}} + unset x + set info +} {1 {can't read "x": no such variable}} +test trace-8.2 {be sure variable is unset before trace is called} { + catch {unset x} + set x 33 + set info {} + trace var x u {traceCheck {uplevel set x 22}} + unset x + concat $info [list [catch {set x} msg] $msg] +} {0 22 0 22} +test trace-8.3 {be sure traces are cleared before unset trace called} { + catch {unset x} + set x 33 + set info {} + trace var x u {traceCheck {uplevel trace vinfo x}} + unset x + set info +} {0 {}} +test trace-8.4 {set new trace during unset trace} { + catch {unset x} + set x 33 + set info {} + trace var x u {traceCheck {global x; trace var x u traceProc}} + unset x + concat $info [trace vinfo x] +} {0 {} {u traceProc}} + +test trace-9.1 {make sure array elements are unset before traces are called} { + catch {unset x} + set x(0) 33 + set info {} + trace var x(0) u {traceCheck {uplevel set x(0)}} + unset x(0) + set info +} {1 {can't read "x(0)": no such element in array}} +test trace-9.2 {make sure array elements are unset before traces are called} { + catch {unset x} + set x(0) 33 + set info {} + trace var x(0) u {traceCheck {uplevel set x(0) zzz}} + unset x(0) + concat $info [list [catch {set x(0)} msg] $msg] +} {0 zzz 0 zzz} +test trace-9.3 {array elements are unset before traces are called} { + catch {unset x} + set x(0) 33 + set info {} + trace var x(0) u {traceCheck {global x; trace vinfo x(0)}} + unset x(0) + set info +} {0 {}} +test trace-9.4 {set new array element trace during unset trace} { + catch {unset x} + set x(0) 33 + set info {} + trace var x(0) u {traceCheck {uplevel {trace variable x(0) r {}}}} + catch {unset x(0)} + concat $info [trace vinfo x(0)] +} {0 {} {r {}}} + +test trace-10.1 {make sure arrays are unset before traces are called} { + catch {unset x} + set x(0) 33 + set info {} + trace var x u {traceCheck {uplevel set x(0)}} + unset x + set info +} {1 {can't read "x(0)": no such variable}} +test trace-10.2 {make sure arrays are unset before traces are called} { + catch {unset x} + set x(y) 33 + set info {} + trace var x u {traceCheck {uplevel set x(y) 22}} + unset x + concat $info [list [catch {set x(y)} msg] $msg] +} {0 22 0 22} +test trace-10.3 {make sure arrays are unset before traces are called} { + catch {unset x} + set x(y) 33 + set info {} + trace var x u {traceCheck {uplevel array exists x}} + unset x + set info +} {0 0} +test trace-10.4 {make sure arrays are unset before traces are called} { + catch {unset x} + set x(y) 33 + set info {} + set cmd {traceCheck {uplevel {trace vinfo x}}} + trace var x u $cmd + unset x + set info +} {0 {}} +test trace-10.5 {set new array trace during unset trace} { + catch {unset x} + set x(y) 33 + set info {} + trace var x u {traceCheck {global x; trace var x r {}}} + unset x + concat $info [trace vinfo x] +} {0 {} {r {}}} +test trace-10.6 {create scalar during array unset trace} { + catch {unset x} + set x(y) 33 + set info {} + trace var x u {traceCheck {global x; set x 44}} + unset x + concat $info [list [catch {set x} msg] $msg] +} {0 44 0 44} + +# Check special conditions (e.g. errors) in Tcl_TraceVar2. + +test trace-11.1 {creating array when setting variable traces} { + catch {unset x} + set info {} + trace var x(0) w traceProc + list [catch {set x 22} msg] $msg +} {1 {can't set "x": variable is array}} +test trace-11.2 {creating array when setting variable traces} { + catch {unset x} + set info {} + trace var x(0) w traceProc + list [catch {set x(0)} msg] $msg +} {1 {can't read "x(0)": no such element in array}} +test trace-11.3 {creating array when setting variable traces} { + catch {unset x} + set info {} + trace var x(0) w traceProc + set x(0) 22 + set info +} {x 0 w} +test trace-11.4 {creating variable when setting variable traces} { + catch {unset x} + set info {} + trace var x w traceProc + list [catch {set x} msg] $msg +} {1 {can't read "x": no such variable}} +test trace-11.5 {creating variable when setting variable traces} { + catch {unset x} + set info {} + trace var x w traceProc + set x 22 + set info +} {x {} w} +test trace-11.6 {creating variable when setting variable traces} { + catch {unset x} + set info {} + trace var x w traceProc + set x(0) 22 + set info +} {x 0 w} +test trace-11.7 {create array element during read trace} { + catch {unset x} + set x(2) zzz + trace var x r {traceCrtElement xyzzy} + list [catch {set x(3)} msg] $msg +} {0 xyzzy} +test trace-11.8 {errors when setting variable traces} { + catch {unset x} + set x 44 + list [catch {trace var x(0) w traceProc} msg] $msg +} {1 {can't trace "x(0)": variable isn't array}} + +# Check deleting one trace from another. + +test trace-12.1 {delete one trace from another} { + proc delTraces {args} { + global x + trace vdel x r {traceTag 2} + trace vdel x r {traceTag 3} + trace vdel x r {traceTag 4} + } + catch {unset x} + set x 44 + set info {} + trace var x r {traceTag 1} + trace var x r {traceTag 2} + trace var x r {traceTag 3} + trace var x r {traceTag 4} + trace var x r delTraces + trace var x r {traceTag 5} + set x + set info +} {5 1} + +# Check operation and syntax of "trace" command. + +test trace-13.1 {trace command (overall)} { + list [catch {trace} msg] $msg +} {1 {too few 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}} +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"}} +test trace-13.4 {trace command ("variable" option)} { + list [catch {trace var x y z z2} msg] $msg +} {1 {wrong # args: should be "trace variable name ops command"}} +test trace-13.5 {trace command ("variable" option)} { + list [catch {trace var x y z} msg] $msg +} {1 {bad operations "y": should be one or more of rwu}} +test trace-13.6 {trace command ("vdelete" option)} { + list [catch {trace vdelete x y} msg] $msg +} {1 {wrong # args: should be "trace vdelete name ops command"}} +test trace-13.7 {trace command ("vdelete" option)} { + list [catch {trace vdelete x y z foo} msg] $msg +} {1 {wrong # args: should be "trace vdelete name ops command"}} +test trace-13.8 {trace command ("vdelete" option)} { + list [catch {trace vdelete x y z} msg] $msg +} {1 {bad operations "y": should be one or more of rwu}} +test trace-13.9 {trace command ("vdelete" option)} { + catch {unset x} + set info {} + trace var x w traceProc + trace vdelete x w traceProc +} {} +test trace-13.10 {trace command ("vdelete" option)} { + catch {unset x} + set info {} + trace var x w traceProc + trace vdelete x w traceProc + set x 12345 + set info +} {} +test trace-13.11 {trace command ("vdelete" option)} { + catch {unset x} + set info {} + trace var x w {traceTag 1} + trace var x w traceProc + trace var x w {traceTag 2} + set x yy + trace vdelete x w traceProc + set x 12345 + trace vdelete x w {traceTag 1} + set x foo + trace vdelete x w {traceTag 2} + set x gorp + set info +} {2 x {} w 1 2 1 2} +test trace-13.12 {trace command ("vdelete" option)} { + catch {unset x} + set info {} + trace var x w {traceTag 1} + trace vdelete x w non_existent + set x 12345 + set info +} {1} +test trace-13.13 {trace command ("vinfo" option)} { + list [catch {trace vinfo} msg] $msg] +} {1 {wrong # args: should be "trace vinfo name"]}} +test trace-13.14 {trace command ("vinfo" option)} { + list [catch {trace vinfo x y} msg] $msg] +} {1 {wrong # args: should be "trace vinfo name"]}} +test trace-13.15 {trace command ("vinfo" option)} { + catch {unset x} + trace var x w {traceTag 1} + trace var x w traceProc + trace var x w {traceTag 2} + trace vinfo x +} {{w {traceTag 2}} {w traceProc} {w {traceTag 1}}} +test trace-13.16 {trace command ("vinfo" option)} { + catch {unset x} + trace vinfo x +} {} +test trace-13.17 {trace command ("vinfo" option)} { + catch {unset x} + trace vinfo x(0) +} {} +test trace-13.18 {trace command ("vinfo" option)} { + catch {unset x} + set x 44 + trace vinfo x(0) +} {} +test trace-13.19 {trace command ("vinfo" option)} { + catch {unset x} + set x 44 + trace var x w {traceTag 1} + proc check {} {global x; trace vinfo x} + check +} {{w {traceTag 1}}} + +# Check fancy trace commands (long ones, weird arguments, etc.) + +test trace-14.1 {long trace command} { + catch {unset x} + set info {} + trace var x w {traceTag {This is a very very long argument. It's \ + designed to test out the facilities of TraceVarProc for dealing \ + with such long arguments by malloc-ing space. One possibility \ + is that space doesn't get freed properly. If this happens, then \ + invoking this test over and over again will eventually leak memory.}} + set x 44 + set info +} {This is a very very long argument. It's \ + designed to test out the facilities of TraceVarProc for dealing \ + with such long arguments by malloc-ing space. One possibility \ + is that space doesn't get freed properly. If this happens, then \ + invoking this test over and over again will eventually leak memory.} +test trace-14.2 {long trace command result to ignore} { + proc longResult {args} {return "quite a bit of text, designed to + generate a core leak if this command file is invoked over and over again + and memory isn't being recycled correctly"} + catch {unset x} + trace var x w longResult + set x 44 + set x 5 + set x abcde +} abcde +test trace-14.3 {special list-handling in trace commands} { + catch {unset "x y z"} + set "x y z(a\n\{)" 44 + set info {} + trace var "x y z(a\n\{)" w traceProc + set "x y z(a\n\{)" 33 + set info +} "{x y z} a\\n\\{ w" + +# Check for proper handling of unsets during traces. + +proc traceUnset {unsetName args} { + global info + upvar $unsetName x + lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg +} +proc traceReset {unsetName resetName args} { + global info + upvar $unsetName x $resetName y + lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg +} +proc traceReset2 {unsetName resetName args} { + global info + lappend info [catch {uplevel unset $unsetName} msg] $msg \ + [catch {uplevel set $resetName xyzzy} msg] $msg +} +proc traceAppend {string name1 name2 op} { + global info + lappend info $string +} + +test trace-15.1 {unsets during read traces} { + catch {unset y} + set y 1234 + set info {} + trace var y r {traceUnset y} + trace var y u {traceAppend unset} + lappend info [catch {set y} msg] $msg +} {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} +test trace-15.2 {unsets during read traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {traceUnset y(0)} + lappend info [catch {set y(0)} msg] $msg +} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}} +test trace-15.3 {unsets during read traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {traceUnset y} + lappend info [catch {set y(0)} msg] $msg +} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} +test trace-15.4 {unsets during read traces} { + catch {unset y} + set y 1234 + set info {} + trace var y r {traceReset y y} + lappend info [catch {set y} msg] $msg +} {0 {} 0 xyzzy 0 xyzzy} +test trace-15.5 {unsets during read traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {traceReset y(0) y(0)} + lappend info [catch {set y(0)} msg] $msg +} {0 {} 0 xyzzy 0 xyzzy} +test trace-15.6 {unsets during read traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {traceReset y y(0)} + lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg +} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}} +test trace-15.7 {unsets during read traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {traceReset2 y y(0)} + lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg +} {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy} +test trace-15.8 {unsets during write traces} { + catch {unset y} + set y 1234 + set info {} + trace var y w {traceUnset y} + trace var y u {traceAppend unset} + lappend info [catch {set y xxx} msg] $msg +} {unset 0 {} 1 {can't read "x": no such variable} 0 {}} +test trace-15.9 {unsets during write traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) w {traceUnset y(0)} + lappend info [catch {set y(0) xxx} msg] $msg +} {0 {} 1 {can't read "x": no such variable} 0 {}} +test trace-15.10 {unsets during write traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) w {traceUnset y} + lappend info [catch {set y(0) xxx} msg] $msg +} {0 {} 1 {can't read "x": no such variable} 0 {}} +test trace-15.11 {unsets during write traces} { + catch {unset y} + set y 1234 + set info {} + trace var y w {traceReset y y} + lappend info [catch {set y xxx} msg] $msg +} {0 {} 0 xyzzy 0 xyzzy} +test trace-15.12 {unsets during write traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) w {traceReset y(0) y(0)} + lappend info [catch {set y(0) xxx} msg] $msg +} {0 {} 0 xyzzy 0 xyzzy} +test trace-15.13 {unsets during write traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) w {traceReset y y(0)} + lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg +} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}} +test trace-15.14 {unsets during write traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) w {traceReset2 y y(0)} + lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg +} {0 {} 0 xyzzy 0 {} 0 xyzzy} +test trace-15.15 {unsets during unset traces} { + catch {unset y} + set y 1234 + set info {} + trace var y u {traceUnset y} + lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg +} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}} +test trace-15.16 {unsets during unset traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) u {traceUnset y(0)} + lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg +} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}} +test trace-15.17 {unsets during unset traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) u {traceUnset y} + lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg +} {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}} +test trace-15.18 {unsets during unset traces} { + catch {unset y} + set y 1234 + set info {} + trace var y u {traceReset2 y y} + lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg +} {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy} +test trace-15.19 {unsets during unset traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) u {traceReset2 y(0) y(0)} + lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg +} {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy} +test trace-15.20 {unsets during unset traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) u {traceReset2 y y(0)} + lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg +} {0 {} 0 xyzzy 0 {} 0 xyzzy} +test trace-15.21 {unsets cancelling traces} { + catch {unset y} + set y 1234 + set info {} + trace var y r {traceAppend first} + trace var y r {traceUnset y} + trace var y r {traceAppend third} + trace var y u {traceAppend unset} + lappend info [catch {set y} msg] $msg +} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} +test trace-15.22 {unsets cancelling traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {traceAppend first} + trace var y(0) r {traceUnset y} + trace var y(0) r {traceAppend third} + trace var y(0) u {traceAppend unset} + lappend info [catch {set y(0)} msg] $msg +} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} + +# Check various non-interference between traces and other things. + +test trace-16.1 {trace doesn't prevent unset errors} { + catch {unset x} + set info {} + trace var x u {traceProc} + list [catch {unset x} msg] $msg $info +} {1 {can't unset "x": no such variable} {x {} u}} +test trace-16.2 {traced variables must survive procedure exits} { + catch {unset x} + proc p1 {} {global x; trace var x w traceProc} + p1 + trace vinfo x +} {{w traceProc}} +test trace-16.3 {traced variables must survive procedure exits} { + catch {unset x} + set info {} + proc p1 {} {global x; trace var x w traceProc} + p1 + set x 44 + set info +} {x {} w} + +# Be sure that procedure frames are released before unset traces +# are invoked. + +test trace-17.1 {unset traces on procedure returns} { + proc p1 {x y} {set a 44; p2 14} + proc p2 {z} {trace var z u {traceCheck {lsort [uplevel {info vars}]}}} + set info {} + p1 foo bar + set info +} {0 {a x y}} + +# Delete arrays when done, so they can be re-used as scalars +# elsewhere. + +catch {unset x} +catch {unset y} +concat {} diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test new file mode 100644 index 0000000..037b5b4 --- /dev/null +++ b/tests/unixFCmd.test @@ -0,0 +1,251 @@ +# This file tests the tclUnixFCmd.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) unixFCmd.test 1.15 97/11/03 15:58:22 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {$tcl_platform(platform) != "unix"} { + return +} + +if {$user == "root"} { + puts "Skipping unixFCmd tests. They depend on not being able to write to" + puts "certain directories. It would be too dangerous to run them as root." + return +} + +proc openup {path} { + testchmod 777 $path + if {[file isdirectory $path]} { + catch { + foreach p [glob [file join $path *]] { + openup $p + } + } + } +} + +proc cleanup {args} { + foreach p ". $args" { + set x "" + catch { + set x [glob [file join $p tf*] [file join $p td*]] + } + foreach file $x { + if {[catch {file delete -force -- $file}]} { + openup $file + file delete -force -- $file + } + } + } +} + +test unixFCmd-1.1 {TclpRenameFile: EACCES} { + cleanup + file mkdir td1/td2/td3 + exec chmod 000 td1/td2 + set msg [list [catch {file rename td1/td2/td3 td2} msg] $msg] + exec chmod 755 td1/td2 + set msg +} {1 {error renaming "td1/td2/td3": permission denied}} +test unixFCmd-1.2 {TclpRenameFile: EEXIST} { + cleanup + file mkdir td1/td2 + file mkdir td2 + list [catch {file rename td2 td1} msg] $msg +} {1 {error renaming "td2" to "td1/td2": file already exists}} +test unixFCmd-1.3 {TclpRenameFile: EINVAL} { + cleanup + file mkdir td1 + list [catch {file rename td1 td1} msg] $msg +} {1 {error renaming "td1" to "td1/td1": trying to rename a volume or move a directory into itself}} +test unixFCmd-1.4 {TclpRenameFile: EISDIR} { + # can't make it happen +} {} +test unixFCmd-1.5 {TclpRenameFile: ENOENT} { + cleanup + file mkdir td1 + list [catch {file rename td2 td1} msg] $msg +} {1 {error renaming "td2": no such file or directory}} +test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} { + # can't make it happen +} {} +test unixFCmd-1.7 {TclpRenameFile: EXDEV} { + cleanup + file mkdir foo/bar + file attr foo -perm 040555 + set msg [list [catch {file rename foo/bar /tmp} msg] $msg] + set a1 {1 {can't unlink "foo/bar": permission denied}} + set result [expr {$msg == $a1}] + catch {file delete /tmp/bar} + catch {file attr foo -perm 040777} + catch {file delete -force foo} + set result +} {1} + +test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} { + cleanup + exec touch tf1 + exec touch tf2 + file copy -force tf1 tf2 +} {} +test unixFCmd-2.2 {TclpCopyFile: src is symlink} { + cleanup + exec ln -s tf1 tf2 + file copy tf2 tf3 + file type tf3 +} {link} +test unixFCmd-2.3 {TclpCopyFile: src is block} { + cleanup + set null "/dev/null" + while {[file type $null] != "characterSpecial"} { + set null [file join [file dirname $null] [file readlink $null]] + } + # file copy $null tf1 +} {} +test unixFCmd-2.4 {TclpCopyFile: src is fifo} { + cleanup + if [catch {exec mknod tf1 p}] { + list 1 + } else { + file copy tf1 tf2 + expr {"[file type tf1]" == "[file type tf2]"} + } +} {1} +test unixFCmd-2.5 {TclpCopyFile: copy attributes} { + cleanup + exec touch tf1 + exec chmod 472 tf1 + file copy tf1 tf2 + string range [exec ls -l tf2] 0 9 +} {-r--rwx-w-} + +test unixFCmd-3.1 {CopyFile not done} { +} {} + +test unixFCmd-4.1 {TclpDeleteFile not done} { +} {} + +test unixFCmd-5.1 {TclpCreateDirectory not done} { +} {} + +test unixFCmd-6.1 {TclpCopyDirectory not done} { +} {} + +test unixFCmd-7.1 {TclpRemoveDirectory not done} { +} {} + +test unixFCmd-8.1 {TraverseUnixTree not done} { +} {} + +test unixFCmd-9.1 {TraversalCopy not done} { +} {} + +test unixFCmd-10.1 {TraversalDelete not done} { +} {} + +test unixFCmd-11.1 {CopyFileAttrs not done} { +} {} + +set testConfig(tclGroup) 0 +if {[catch {exec {groups}} groupList] == 0} { + if {[lsearch $groupList tcl] != -1} { + set testConfig(tclGroup) 1 + } +} + +test unixFCmd-12.1 {GetGroupAttribute - file not found} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -group} msg] $msg +} {1 {could not stat file "foo.test": no such file or directory}} +test unixFCmd-12.2 {GetGroupAttribute - file found} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -group}] [file delete -force -- foo.test] +} {0 {}} + +test unixFCmd-13.1 {GetOwnerAttribute - file not found} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -group} msg] $msg +} {1 {could not stat file "foo.test": no such file or directory}} +test unixFCmd-13.2 {GetOwnerAttribute} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -owner} msg] [string compare $msg $user] [file delete -force -- foo.test] +} {0 0 {}} + +test unixFCmd-14.1 {GetPermissionsAttribute - file not found} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -permissions} msg] $msg +} {1 {could not stat file "foo.test": no such file or directory}} +test unixFCmd-14.2 {GetPermissionsAttribute} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attribute foo.test -permissions}] [file delete -force -- foo.test] +} {0 {}} + +#groups hard to test +test unixFCmd-15.1 {SetGroupAttribute - invalid group} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -group foozzz} msg] $msg [file delete -force -- foo.test] +} {1 {could not set group for file "foo.test": group "foozzz" does not exist} {}} +test unixFCmd-15.2 {SetGroupAttribute - invalid file} {tclGroup} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -group tcl} msg] $msg +} {1 {could not set group for file "foo.test": no such file or directory}} + +#changing owners hard to do +test unixFCmd-16.1 {SetOwnerAttribute - current owner} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -owner $user} msg] $msg [string compare [file attributes foo.test -owner] $user] [file delete -force -- foo.test] +} {0 {} 0 {}} +test unixFCmd-16.2 {SetOwnerAttribute - invalid file} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -owner $user} msg] $msg +} {1 {could not set owner for file "foo.test": no such file or directory}} +test unixFCmd-16.3 {SetOwnerAttribute - invalid owner} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -owner foozzz} msg] $msg +} {1 {could not set owner for file "foo.test": user "foozzz" does not exist}} + + +test unixFCmd-17.1 {SetPermissionsAttribute} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -permissions 0000} msg] $msg [file attributes foo.test -permissions] [file delete -force -- foo.test] +} {0 {} 00000 {}} +test unixFCmd-17.2 {SetPermissionsAttribute} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -permissions 0000} msg] $msg +} {1 {could not set permissions for file "foo.test": no such file or directory}} +test unixFCmd-17.3 {SetPermissionsAttribute} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -permissions foo} msg] $msg [file delete -force -- foo.test] +} {1 {expected integer but got "foo"} {}} +test unixFCmd-18.1 {Unix pwd} {nonPortable} { + # This test is nonportable because SunOS generates a weird error + # message when the current directory isn't readable. + set cd [pwd] + set nd $cd/tstdir + file mkdir $nd + cd $nd + exec chmod 000 $nd + set r [list [catch {pwd} res] [string range $res 0 36]]; + cd $cd; + exec chmod 755 $nd + file delete $nd + set r +} {1 {error getting working directory name:}} + +cleanup diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test new file mode 100644 index 0000000..5ed5f12 --- /dev/null +++ b/tests/unixNotfy.test @@ -0,0 +1,49 @@ +# This file contains tests for tclUnixNotfy.c. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) unixNotfy.test 1.3 97/09/15 15:39:53 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {$tcl_platform(platform) != "unix"} { + return +} + +# The tests should not be run if you have a notifier which is unable to +# detect infinite vwaits, as the tests below will hang. The presence of +# the "testeventloop" command indicates that this is the case. + +if {"[info commands testeventloop]" == "testeventloop"} { + return +} + +test unixNotfy-1.1 {Tcl_DeleteFileHandler} { + catch {vwait x} + set f [open foo w] + fileevent $f writable {set x 1} + vwait x + close $f + list [catch {vwait x} msg] $msg +} {1 {can't wait for variable "x": would wait forever}} +test unixNotfy-1.2 {Tcl_DeleteFileHandler} { + catch {vwait x} + set f1 [open foo w] + set f2 [open foo2 w] + fileevent $f1 writable {set x 1} + fileevent $f2 writable {set y 1} + vwait x + close $f1 + vwait y + close $f2 + list [catch {vwait x} msg] $msg +} {1 {can't wait for variable "x": would wait forever}} + +file delete foo diff --git a/tests/unknown.test b/tests/unknown.test new file mode 100644 index 0000000..83ad160 --- /dev/null +++ b/tests/unknown.test @@ -0,0 +1,61 @@ +# Commands covered: unknown +# +# 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: @(#) unknown.test 1.12 96/08/26 11:29:29 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset x} +catch {rename unknown unknown.old} + +test unknown-1.1 {non-existent "unknown" command} { + list [catch {_non-existent_ foo bar} msg] $msg +} {1 {invalid command name "_non-existent_"}} + +proc unknown {args} { + global x + set x $args +} + +test unknown-2.1 {calling "unknown" command} { + foobar x y z + set x +} {foobar x y z} +test unknown-2.2 {calling "unknown" command with lots of args} { + foobar 1 2 3 4 5 6 7 + set x +} {foobar 1 2 3 4 5 6 7} +test unknown-2.3 {calling "unknown" command with lots of args} { + foobar 1 2 3 4 5 6 7 8 + set x +} {foobar 1 2 3 4 5 6 7 8} +test unknown-2.4 {calling "unknown" command with lots of args} { + foobar 1 2 3 4 5 6 7 8 9 + set x +} {foobar 1 2 3 4 5 6 7 8 9} + +test unknown-3.1 {argument quoting in calls to "unknown"} { + foobar \{ \} a\{b \; "\\" \$a a\[b \] + set x +} "foobar \\{ \\} a\\{b {;} \\\\ {\$a} {a\[b} \\]" + +proc unknown args { + error "unknown failed" +} + +test unknown-4.1 {errors in "unknown" procedure} { + list [catch {non-existent a b} msg] $msg $errorCode +} {1 {unknown failed} NONE} + +catch {rename unknown {}} +catch {rename unknown.old unknown} +return {} diff --git a/tests/uplevel.test b/tests/uplevel.test new file mode 100644 index 0000000..84daa03 --- /dev/null +++ b/tests/uplevel.test @@ -0,0 +1,109 @@ +# Commands covered: uplevel +# +# 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: @(#) uplevel.test 1.13 96/02/16 08:56:35 + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc a {x y} { + newset z [expr $x+$y] + return $z +} +proc newset {name value} { + uplevel set $name $value + uplevel 1 {uplevel 1 {set xyz 22}} +} + +test uplevel-1.1 {simple operation} { + set xyz 0 + a 22 33 +} 55 +test uplevel-1.2 {command is another uplevel command} { + set xyz 0 + a 22 33 + set xyz +} 22 + +proc a1 {} { + b1 + global a a1 + set a $x + set a1 $y +} +proc b1 {} { + c1 + global b b1 + set b $x + set b1 $y +} +proc c1 {} { + uplevel 1 set x 111 + uplevel #2 set y 222 + uplevel 2 set x 333 + uplevel #1 set y 444 + uplevel 3 set x 555 + uplevel #0 set y 666 +} +a1 +test uplevel-2.1 {relative and absolute uplevel} {set a} 333 +test uplevel-2.2 {relative and absolute uplevel} {set a1} 444 +test uplevel-2.3 {relative and absolute uplevel} {set b} 111 +test uplevel-2.4 {relative and absolute uplevel} {set b1} 222 +test uplevel-2.5 {relative and absolute uplevel} {set x} 555 +test uplevel-2.6 {relative and absolute uplevel} {set y} 666 + +test uplevel-3.1 {uplevel to same level} { + set x 33 + uplevel #0 set x 44 + set x +} 44 +test uplevel-3.2 {uplevel to same level} { + set x 33 + uplevel 0 set x +} 33 +test uplevel-3.3 {uplevel to same level} { + set y xxx + proc a1 {} {set y 55; uplevel 0 set y 66; return $y} + a1 +} 66 +test uplevel-3.4 {uplevel to same level} { + set y zzz + proc a1 {} {set y 55; uplevel #1 set y} + a1 +} 55 + +test uplevel-4.1 {error: non-existent level} { + list [catch c1 msg] $msg +} {1 {bad level "#2"}} +test uplevel-4.2 {error: non-existent level} { + proc c2 {} {uplevel 3 {set a b}} + list [catch c2 msg] $msg +} {1 {bad level "3"}} +test uplevel-4.3 {error: not enough args} { + list [catch uplevel msg] $msg +} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} +test uplevel-4.4 {error: not enough args} { + proc upBug {} {uplevel 1} + list [catch upBug msg] $msg +} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} + +proc a2 {} { + uplevel a3 +} +proc a3 {} { + global x y + set x [info level] + set y [info level 1] +} +a2 +test uplevel-5.1 {info level} {set x} 1 +test uplevel-5.2 {info level} {set y} a3 diff --git a/tests/upvar.test b/tests/upvar.test new file mode 100644 index 0000000..d9548b0 --- /dev/null +++ b/tests/upvar.test @@ -0,0 +1,394 @@ +# Commands covered: upvar +# +# 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: @(#) upvar.test 1.15 97/10/29 18:25:56 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test upvar-1.1 {reading variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} + p1 foo bar +} {foo bar 22 33 abc} +test upvar-1.2 {reading variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {p3} + proc p3 {} {upvar 2 a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} + p1 foo bar +} {foo bar 22 33 abc} +test upvar-1.3 {reading variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {p3} + proc p3 {} { + upvar #1 a x1 b x2 c x3 d x4 + set a abc + list $x1 $x2 $x3 $x4 $a + } + p1 foo bar +} {foo bar 22 33 abc} +test upvar-1.4 {reading variables with upvar} { + set x1 44 + set x2 55 + proc p1 {} {p2} + proc p2 {} { + upvar 2 x1 x1 x2 a + upvar #0 x1 b + set c $b + incr b 3 + list $x1 $a $b + } + p1 +} {47 55 47} +test upvar-1.5 {reading array elements with upvar} { + proc p1 {} {set a(0) zeroth; set a(1) first; p2} + proc p2 {} {upvar a(0) x; set x} + p1 +} {zeroth} + +test upvar-2.1 {writing variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} + proc p2 {} { + upvar a x1 b x2 c x3 d x4 + set x1 14 + set x4 88 + } + p1 foo bar +} {14 bar 22 88} +test upvar-2.2 {writing variables with upvar} { + set x1 44 + set x2 55 + proc p1 {x1 x2} { + upvar #0 x1 a + upvar x2 b + set a $x1 + set b $x2 + } + p1 newbits morebits + list $x1 $x2 +} {newbits morebits} +test upvar-2.3 {writing variables with upvar} { + catch {unset x1} + catch {unset x2} + proc p1 {x1 x2} { + upvar #0 x1 a + upvar x2 b + set a $x1 + set b $x2 + } + p1 newbits morebits + list [catch {set x1} msg] $msg [catch {set x2} msg] $msg +} {0 newbits 0 morebits} +test upvar-2.4 {writing array elements with upvar} { + proc p1 {} {set a(0) zeroth; set a(1) first; list [p2] $a(0)} + proc p2 {} {upvar a(0) x; set x xyzzy} + p1 +} {xyzzy xyzzy} + +test upvar-3.1 {unsetting variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} + proc p2 {} { + upvar 1 a x1 d x2 + unset x1 x2 + } + p1 foo bar +} {b c} +test upvar-3.2 {unsetting variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} + proc p2 {} { + upvar 1 a x1 d x2 + unset x1 x2 + set x2 28 + } + p1 foo bar +} {b c d} +test upvar-3.3 {unsetting variables with upvar} { + set x1 44 + set x2 55 + proc p1 {} {p2} + proc p2 {} { + upvar 2 x1 a + upvar #0 x2 b + unset a b + } + p1 + list [info exists x1] [info exists x2] +} {0 0} +test upvar-3.4 {unsetting variables with upvar} { + set x1 44 + set x2 55 + proc p1 {} { + upvar x1 a x2 b + unset a b + set b 118 + } + p1 + list [info exists x1] [catch {set x2} msg] $msg +} {0 0 118} +test upvar-3.5 {unsetting array elements with upvar} { + proc p1 {} { + set a(0) zeroth + set a(1) first + set a(2) second + p2 + array names a + } + proc p2 {} {upvar a(0) x; unset x} + p1 +} {1 2} +test upvar-3.6 {unsetting then resetting array elements with upvar} { + proc p1 {} { + set a(0) zeroth + set a(1) first + set a(2) second + p2 + list [array names a] [catch {set a(0)} msg] $msg + } + proc p2 {} {upvar a(0) x; unset x; set x 12345} + p1 +} {{0 1 2} 0 12345} + +test upvar-4.1 {nested upvars} { + set x1 88 + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {global x1; upvar c x2; p3} + proc p3 {} { + upvar x1 a x2 b + list $a $b + } + p1 14 15 +} {88 22} +test upvar-4.2 {nested upvars} { + set x1 88 + proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} + proc p2 {} {global x1; upvar c x2; p3} + proc p3 {} { + upvar x1 a x2 b + set a foo + set b bar + } + list [p1 14 15] $x1 +} {{14 15 bar 33} foo} + +proc tproc {args} {global x; set x [list $args [uplevel info vars]]} +test upvar-5.1 {traces involving upvars} { + proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} + proc p2 {} {upvar c x1; set x1 22} + set x --- + p1 foo bar + set x +} {{x1 {} w} x1} +test upvar-5.2 {traces involving upvars} { + proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} + proc p2 {} {upvar c x1; set x1} + set x --- + p1 foo bar + set x +} {{x1 {} r} x1} +test upvar-5.3 {traces involving upvars} { + proc p1 {a b} {set c 22; set d 33; trace var c rwu tproc; p2} + proc p2 {} {upvar c x1; unset x1} + set x --- + p1 foo bar + set x +} {{x1 {} u} x1} + +test upvar-6.1 {retargeting an upvar} { + proc p1 {} { + set a(0) zeroth + set a(1) first + set a(2) second + p2 + } + proc p2 {} { + upvar a x + set result {} + foreach i [array names x] { + upvar a($i) x + lappend result $x + } + lsort $result + } + p1 +} {first second zeroth} +test upvar-6.2 {retargeting an upvar} { + set x 44 + set y abcde + proc p1 {} { + global x + set result $x + upvar y x + lappend result $x + } + p1 +} {44 abcde} +test upvar-6.3 {retargeting an upvar} { + set x 44 + set y abcde + proc p1 {} { + upvar y x + lappend result $x + global x + lappend result $x + } + p1 +} {abcde 44} + +test upvar-7.1 {upvar to same level} { + set x 44 + set y 55 + catch {unset uv} + upvar #0 x uv + set uv abc + upvar 0 y uv + set uv xyzzy + list $x $y +} {abc xyzzy} +test upvar-7.2 {upvar to same level} { + set x 1234 + set y 4567 + proc p1 {x y} { + upvar 0 x uv + set uv $y + return "$x $y" + } + p1 44 89 +} {89 89} +test upvar-7.3 {upvar to same level} { + set x 1234 + set y 4567 + proc p1 {x y} { + upvar #1 x uv + set uv $y + return "$x $y" + } + p1 xyz abc +} {abc abc} +test upvar-7.4 {upvar to same level: tricky problems when deleting variable table} { + proc tt {} {upvar #1 toto loc; return $loc} + list [catch tt msg] $msg +} {1 {can't read "loc": no such variable}} +test upvar-7.5 {potential memory leak when deleting variable table} { + proc leak {} { + array set foo {1 2 3 4} + upvar 0 foo(1) bar + } + leak +} {} + +test upvar-8.1 {errors in upvar command} { + list [catch upvar msg] $msg +} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}} +test upvar-8.2 {errors in upvar command} { + list [catch {upvar 1} msg] $msg +} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}} +test upvar-8.3 {errors in upvar command} { + proc p1 {} {upvar a b c} + list [catch p1 msg] $msg +} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}} +test upvar-8.4 {errors in upvar command} { + proc p1 {} {upvar 0 b b} + list [catch p1 msg] $msg +} {1 {can't upvar from variable to itself}} +test upvar-8.5 {errors in upvar command} { + proc p1 {} {upvar 0 a b; upvar 0 b a} + list [catch p1 msg] $msg +} {1 {can't upvar from variable to itself}} +test upvar-8.6 {errors in upvar command} { + proc p1 {} {set a 33; upvar b a} + list [catch p1 msg] $msg +} {1 {variable "a" already exists}} +test upvar-8.7 {errors in upvar command} { + proc p1 {} {trace variable a w foo; upvar b a} + list [catch p1 msg] $msg +} {1 {variable "a" has traces: can't use for upvar}} +test upvar-8.8 {create nested array with upvar} { + proc p1 {} {upvar x(a) b; set b(2) 44} + catch {unset x} + list [catch p1 msg] $msg +} {1 {can't set "b(2)": variable isn't array}} +test upvar-8.9 {upvar won't create namespace variable that refers to procedure variable} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename MakeLink ""} + namespace eval ::test_ns_1 {} + proc MakeLink {a} { + namespace eval ::test_ns_1 { + upvar a a + } + unset ::test_ns_1::a + } + list [catch {MakeLink 1} msg] $msg +} {1 {bad variable name "a": upvar won't create namespace variable that refers to procedure variable}} + +if {[info commands testupvar] != {}} { + test upvar-9.1 {Tcl_UpVar2 procedure} { + list [catch {testupvar xyz a {} x global} msg] $msg + } {1 {bad level "xyz"}} + test upvar-9.2 {Tcl_UpVar2 procedure} { + catch {unset a} + catch {unset x} + set a 44 + list [catch {testupvar #0 a 1 x global} msg] $msg + } {1 {can't access "a(1)": variable isn't array}} + test upvar-9.3 {Tcl_UpVar2 procedure} { + proc foo {} { + testupvar 1 a {} x local + set x + } + catch {unset a} + catch {unset x} + set a 44 + foo + } {44} + test upvar-9.4 {Tcl_UpVar2 procedure} { + proc foo {} { + testupvar 1 a {} _up_ global + list [catch {set x} msg] $msg + } + catch {unset a} + catch {unset _up_} + set a 44 + concat [foo] $_up_ + } {1 {can't read "x": no such variable} 44} + test upvar-9.5 {Tcl_UpVar2 procedure} { + proc foo {} { + testupvar 1 a b x local + set x + } + catch {unset a} + catch {unset x} + set a(b) 1234 + foo + } {1234} + test upvar-9.6 {Tcl_UpVar procedure} { + proc foo {} { + testupvar 1 a x local + set x + } + catch {unset a} + catch {unset x} + set a xyzzy + foo + } {xyzzy} + test upvar-9.7 {Tcl_UpVar procedure} { + proc foo {} { + testupvar #0 a(b) x local + set x + } + catch {unset a} + catch {unset x} + set a(b) 1234 + foo + } {1234} +} +catch {unset a} + +concat diff --git a/tests/util.test b/tests/util.test new file mode 100644 index 0000000..ee37047 --- /dev/null +++ b/tests/util.test @@ -0,0 +1,132 @@ +# This file is a Tcl script to test the code in the file tclUtil.c. +# This file is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) util.test 1.8 97/08/12 15:50:02 + +if {[info commands testobj] == {}} { + puts "This application hasn't been compiled with the \"testobj\"" + puts "command, so I can't test the Tcl type and object support." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test util-1.1 {TclFindElement procedure - binary element in middle of list} { + lindex {0 foo\x00help 1} 1 +} "foo\x00help" +test util-1.2 {TclFindElement procedure - binary element at end of list} { + lindex {0 foo\x00help} 1 +} "foo\x00help" + +test util-2.1 {TclCopyAndCollapse procedure - normal string} { + lindex {0 foo} 1 +} {foo} +test util-2.2 {TclCopyAndCollapse procedure - string with backslashes} { + lindex {0 foo\n\x00help 1} 1 +} "foo\n\x00help" + +test util-3.1 {Tcl_ScanCountedElement procedure - don't leave unmatched braces} { + # This test checks for a very tricky feature. Any list element + # generated with Tcl_ScanCountedElement and Tcl_ConvertElement must + # have the property that it can be enclosing in curly braces to make + # an embedded sub-list. If this property doesn't hold, then + # Tcl_DStringStartSublist doesn't work. + + set x {} + lappend x " \\\{ \\" + concat $x [llength "{$x}"] +} {\ \\\{\ \\ 1} + +test util-4.1 {Tcl_ConcatObj - backslash-space at end of argument} { + concat a {b\ } c +} {a b\ c} +test util-4.2 {Tcl_ConcatObj - backslash-space at end of argument} { + concat a {b\ } c +} {a b\ c} +test util-4.3 {Tcl_ConcatObj - backslash-space at end of argument} { + concat a {b\\ } c +} {a b\\ c} +test util-4.4 {Tcl_ConcatObj - backslash-space at end of argument} { + concat a {b } c +} {a b c} +test util-4.5 {Tcl_ConcatObj - backslash-space at end of argument} { + concat a { } c +} {a c} + +test util-5.1 {Tcl_SetObjErrorCode - one arg} { + catch {testsetobjerrorcode 1} + list [set errorCode] +} {1} +test util-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-6.1 {Tcl_PrintDouble - using tcl_precision} { + concat x[expr 1.4] +} {x1.4} +test util-6.2 {Tcl_PrintDouble - using tcl_precision} { + concat x[expr 1.39999999999] +} {x1.39999999999} +test util-6.3 {Tcl_PrintDouble - using tcl_precision} { + concat x[expr 1.399999999999] +} {x1.4} +test util-6.4 {Tcl_PrintDouble - using tcl_precision} { + set tcl_precision 5 + concat x[expr 1.123412341234] +} {x1.1234} +set tcl_precision 12 +test util-6.4 {Tcl_PrintDouble - make sure there's a decimal point} { + concat x[expr 2.0] +} {x2.0} +test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} { + concat x[expr 3.0e98] +} {x3e+98} + +test util-7.1 {TclPrecTraceProc - unset callbacks} { + set tcl_precision 7 + set x $tcl_precision + unset tcl_precision + list $x $tcl_precision +} {7 7} +test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} { + set tcl_precision 12 + interp create child + set x [child eval set tcl_precision] + child eval {set tcl_precision 6} + interp delete child + list $x $tcl_precision +} {12 6} +test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} { + set tcl_precision 12 + interp create -safe child + set x [child eval { + list [catch {set tcl_precision 8} msg] $msg + }] + interp delete child + list $x $tcl_precision +} {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12} +test util-7.3 {TclPrecTraceProc - write traces, bogus values} { + set tcl_precision 12 + list [catch {set tcl_precision abc} msg] $msg $tcl_precision +} {1 {can't set "tcl_precision": improper value for precision} 12} + +set tcl_precision 12 +concat "" diff --git a/tests/var.test b/tests/var.test new file mode 100644 index 0000000..6452577 --- /dev/null +++ b/tests/var.test @@ -0,0 +1,467 @@ +# This file contains tests for the tclVar.c source file. Tests appear in +# the same order as the C code that they test. The set of tests is +# currently incomplete since it currently includes only new tests for +# code changed for the addition of Tcl namespaces. Other variable- +# related tests appear in several other test files including +# namespace.test, set.test, trace.test, and upvar.test. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) var.test 1.10 97/07/28 18:31:47 +# + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {rename p ""} +catch {namespace delete test_ns_var} +catch {unset xx} +catch {unset x} +catch {unset y} +catch {unset i} +catch {unset a} +catch {unset arr} + +test var-1.1 {TclLookupVar, TCL_PARSE_PART1 flag set} { + catch {unset a} + set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd + set i 10 + set arr(foo) 37 + list [$x i] $i [$x arr(foo)] $arr(foo) +} {11 11 38 38} +test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} { + set x "global value" + namespace eval test_ns_var { + variable x "namespace value" + proc p {} { + global x ;# specifies TCL_GLOBAL_ONLY to get global x + return $x + } + } + test_ns_var::p +} {global value} +test var-1.3 {TclLookupVar, TCL_NAMESPACE_ONLY implies namespace var} { + namespace eval test_ns_var { + proc q {} { + variable x ;# specifies TCL_NAMESPACE_ONLY to get namespace x + return $x + } + } + test_ns_var::q +} {namespace value} +test var-1.4 {TclLookupVar, no active call frame implies global namespace var} { + set x +} {global value} +test var-1.5 {TclLookupVar, active call frame pushed for namespace eval implies namespace var} { + namespace eval test_ns_var {set x} +} {namespace value} +test var-1.6 {TclLookupVar, name starts with :: implies some namespace var} { + namespace eval test_ns_var {set ::x} +} {global value} +test var-1.7 {TclLookupVar, error finding namespace var} { + list [catch {set a:::b} msg] $msg +} {1 {can't read "a:::b": no such variable}} +test var-1.8 {TclLookupVar, error finding namespace var} { + list [catch {set ::foobarfoo} msg] $msg +} {1 {can't read "::foobarfoo": no such variable}} +test var-1.9 {TclLookupVar, create new namespace var} { + namespace eval test_ns_var { + set v hello + } +} {hello} +test var-1.10 {TclLookupVar, create new namespace var} { + catch {unset y} + namespace eval test_ns_var { + set ::y 789 + } + set y +} {789} +test var-1.11 {TclLookupVar, error creating new namespace var} { + namespace eval test_ns_var { + list [catch {set ::test_ns_var::foo::bar 314159} msg] $msg + } +} {1 {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist}} +test var-1.12 {TclLookupVar, error creating new namespace var} { + namespace eval test_ns_var { + list [catch {set ::test_ns_var::foo:: 1997} msg] $msg + } +} {1 {can't set "::test_ns_var::foo::": parent namespace doesn't exist}} +test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} { + catch {unset aNeWnAmEiNnS} + namespace eval test_ns_var { + namespace eval test_ns_var2::test_ns_var3 { + set aNeWnAmEiNnS 77777 + } + # namespace which builds a name by traversing nsPtr chain to :: + namespace which -variable test_ns_var2::test_ns_var3::aNeWnAmEiNnS + } +} {::test_ns_var::test_ns_var2::test_ns_var3::aNeWnAmEiNnS} +test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of var names} { + namespace eval test_ns_var { + set : 123 + set v: 456 + set x:y: 789 + list [set :] [set v:] [set x:y:] \ + ${:} ${v:} ${x:y:} \ + [expr {[lsearch [info vars] :] != -1}] \ + [expr {[lsearch [info vars] v:] != -1}] \ + [expr {[lsearch [info vars] x:y:] != -1}] + } +} {123 456 789 123 456 789 1 1 1} + +test var-2.1 {Tcl_LappendObjCmd, create var if new} { + catch {unset x} + lappend x 1 2 +} {1 2} + +test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} { + catch {unset x} + set x 1997 + proc p {} { + global x ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x + return $x + } + p +} {1997} +test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { + namespace eval test_ns_var { + catch {unset v} + variable v 1998 + proc p {} { + variable v ;# TCL_NAMESPACE_ONLY specified for other var x + return $v + } + p + } +} {1998} +if {[info commands testupvar] != {}} { + test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} { + catch {unset a} + set a 123321 + proc p {} { + # create global xx linked to global a + testupvar 1 a {} xx global + } + list [p] $xx [set xx 789] $a + } {{} 123321 789 789} + test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} { + catch {unset a} + set a 456 + namespace eval test_ns_var { + catch {unset ::test_ns_var::vv} + proc p {} { + # create namespace var vv linked to global a + testupvar 1 a {} vv namespace + } + p + } + list $test_ns_var::vv [set test_ns_var::vv 123] $a + } {456 123 123} +} +test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} { + catch {unset aaaaa} + catch {unset xxxxx} + set aaaaa 77777 + upvar #0 aaaaa xxxxx + list [set xxxxx] [set aaaaa] +} {77777 77777} +test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} { + catch {unset a} + set a 121212 + namespace eval test_ns_var { + upvar ::a vvv + set vvv + } +} {121212} +test var-3.7 {MakeUpvar, my var has ::s} { + catch {unset a} + set a 789789 + upvar #0 a test_ns_var::lnk + namespace eval test_ns_var { + set lnk + } +} {789789} +test var-3.8 {MakeUpvar, my var already exists in global ns} { + catch {unset aaaaa} + catch {unset xxxxx} + set aaaaa 456654 + set xxxxx hello + upvar #0 aaaaa xxxxx + set xxxxx +} {hello} +test var-3.9 {MakeUpvar, my var has invalid ns name} { + catch {unset aaaaa} + set aaaaa 789789 + list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg +} {1 {bad variable name "test_ns_fred::lnk": unknown namespace}} + +if {[info commands testgetvarfullname] != {}} { + test var-4.1 {Tcl_GetVariableName, global variable} { + catch {unset a} + set a 123 + testgetvarfullname a global + } ::a + test var-4.2 {Tcl_GetVariableName, namespace variable} { + namespace eval test_ns_var { + variable george + testgetvarfullname george namespace + } + } ::test_ns_var::george + test var-4.3 {Tcl_GetVariableName, variable can't be array element} { + catch {unset a} + set a(1) foo + list [catch {testgetvarfullname a(1) global} msg] $msg + } {1 {unknown variable "a(1)"}} +} + +test var-5.1 {Tcl_GetVariableFullName, global variable} { + catch {unset a} + set a bar + namespace which -variable a +} {::a} +test var-5.2 {Tcl_GetVariableFullName, namespace variable} { + namespace eval test_ns_var { + variable martha + namespace which -variable martha + } +} {::test_ns_var::martha} +test var-5.3 {Tcl_GetVariableFullName, namespace variable} { + namespace which -variable test_ns_var::martha +} {::test_ns_var::martha} + +test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { + namespace eval test_ns_var { + variable boeing 777 + } + proc p {} { + global ::test_ns_var::boeing + set boeing + } + p +} {777} +test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { + namespace eval test_ns_var { + namespace eval test_ns_nested { + variable java java + } + proc p {} { + global ::test_ns_var::test_ns_nested::java + set java + } + } + test_ns_var::p +} {java} +test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} { + set ::test_ns_var::test_ns_nested:: 24 + proc p {} { + global ::test_ns_var::test_ns_nested:: + set {} + } + p +} {24} + +test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} { + catch {namespace delete test_ns_var} + namespace eval test_ns_var { + variable one 1 + } + list [info vars test_ns_var::*] [set test_ns_var::one] +} {::test_ns_var::one 1} +test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} { + set two 2222222 + namespace eval test_ns_var { + variable two + } + list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg +} {0 1 {can't read "test_ns_var::two": no such variable}} +test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} { + namespace eval test_ns_var { + variable two 2 + } + list [info vars test_ns_var::*] \ + [namespace eval test_ns_var {set two}] +} {{::test_ns_var::two ::test_ns_var::one} 2} +test var-7.4 {Tcl_VariableObjCmd, list of vars} { + namespace eval test_ns_var { + variable three 3 four 4 + } + list [info vars test_ns_var::*] \ + [namespace eval test_ns_var {expr $three+$four}] +} {{::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one} 7} +test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} { + catch {unset a} + catch {unset five} + catch {unset six} + set a "" + set five 555 + set six 666 + namespace eval test_ns_var { + variable five 5 six + lappend a $five + } + lappend a $test_ns_var::five \ + [set test_ns_var::six 6] [set test_ns_var::six] $six + catch {unset five} + catch {unset six} + set a +} {5 5 6 6 666} +catch {unset newvar} +test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} { + namespace eval test_ns_var { + variable ::newvar cheers! + } + set newvar +} {cheers!} +catch {unset newvar} +test var-7.7 {Tcl_VariableObjCmd, bad var name} { + namespace eval test_ns_var { + list [catch {variable sev:::en 7} msg] $msg + } +} {1 {can't define "sev:::en": parent namespace doesn't exist}} +test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} { + set a "" + namespace eval test_ns_var { + variable eight 8 + lappend a $eight + variable eight + lappend a $eight + } + set a +} {8 8} +test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} { + catch {namespace delete test_ns_var2} + set a "" + namespace eval test_ns_var2 { + variable x 123 + variable y + variable z + } + lappend a [info vars test_ns_var2::*] + lappend a [info exists test_ns_var2::x] [info exists test_ns_var2::y] \ + [info exists test_ns_var2::z] + lappend a [list [catch {set test_ns_var2::y} msg] $msg] + lappend a [info vars test_ns_var2::*] + lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z] + lappend a [set test_ns_var2::y hello] + lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z] + lappend a [list [catch {unset test_ns_var2::y} msg] $msg] + lappend a [info vars test_ns_var2::*] + lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z] + lappend a [list [catch {unset test_ns_var2::z} msg] $msg] + lappend a [namespace delete test_ns_var2] + set a +} {{::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z} 1 0 0\ +{1 {can't read "test_ns_var2::y": no such variable}}\ +{::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z} 0 0\ +hello 1 0\ +{0 {}}\ +{::test_ns_var2::x ::test_ns_var2::z} 0 0\ +{1 {can't unset "test_ns_var2::z": no such variable}}\ +{}} +test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { + namespace eval test_ns_var { + proc p {} { + variable eight + list [set eight] [info vars] + } + p + } +} {8 eight} +test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { + proc p {} { ;# note this proc is at global :: scope + variable test_ns_var::eight + list [set eight] [info vars] + } + p +} {8 eight} +test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { + namespace eval test_ns_var { + variable {} {My name is empty} + } + proc p {} { ;# note this proc is at global :: scope + variable test_ns_var:: + list [set {}] [info vars] + } + p +} {{My name is empty} {{}}} + +test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} { + catch {namespace delete test_ns_var} + catch {unset a} + namespace eval test_ns_var { + variable v 123 + variable info "" + + proc traceUnset {name1 name2 op} { + variable info + set info [concat $info [list $name1 $name2 $op]] + } + + trace var v u [namespace code traceUnset] + } + list [unset test_ns_var::v] $test_ns_var::info +} {{} {test_ns_var::v {} u}} + +test var-9.1 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { + testsetnoerr v 1 +} 1 +test var-9.2 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { + catch {unset v} + list [catch {testsetnoerr v} res] $res; +} {1 {before get}} +test var-9.3 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { + catch {unset arr} + set arr(1) 1; + list [catch {testsetnoerr arr} res] $res; +} {1 {before get}} +test var-9.4 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { + namespace eval ns {variable v nsv} + testsetnoerr ns::v; +} nsv; +test var-9.5 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { + catch {namespace delete ns} + list [catch {testsetnoerr ns::v} res] $res; +} {1 {before get}} +test var-9.6 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { + catch {unset arr} + set arr(1) 1; + list [catch {testsetnoerr arr 2} res] $res; +} {1 {before set}} +test var-9.7 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { + catch {unset arr} + set arr(1) 1; + list [catch {testsetnoerr arr 2} res] $res; +} {1 {before set}} +test var-9.8 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { + # this test currently fails, should not... + # (some namespace function resets the interp while it should not) + catch {namespace delete ns} + list [catch {testsetnoerr ns::v 1} res] $res; +} {1 {before set}} +test var-9.9 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { + proc readonly args {error "read-only"} + set v 456 + trace var v w readonly + list [catch {testsetnoerr v 2} msg] $msg +} {1 {before set}} + +catch {namespace delete ns} +catch {unset arr} +catch {unset v} + +catch {rename p ""} +catch {namespace delete test_ns_var} +catch {namespace delete test_ns_var2} +catch {unset xx} +catch {unset x} +catch {unset y} +catch {unset i} +catch {unset a} +catch {unset xxxxx} +catch {unset aaaaa} + diff --git a/tests/while-old.test b/tests/while-old.test new file mode 100644 index 0000000..f5e5b05 --- /dev/null +++ b/tests/while-old.test @@ -0,0 +1,113 @@ +# Commands covered: while +# +# This file contains the original set of tests for Tcl's while command. +# Since the while command is now compiled, a new set of tests covering +# the new implementation is in the file "while.test". Sourcing this file +# into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) while-old.test 1.14 97/05/16 10:44:19 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test while-old-1.1 {basic while loops} { + set count 0 + while {$count < 10} {set count [expr $count+1]} + set count +} 10 +test while-old-1.2 {basic while loops} { + set value xxx + while {2 > 3} {set value yyy} + set value +} xxx +test while-old-1.3 {basic while loops} { + set value 1 + while {"true"} { + incr value; + if {$value > 5} { + break; + } + } + set value +} 6 +test while-old-1.4 {basic while loops, multiline test expr} { + set value 1 + while {($tcl_platform(platform) != "foobar1") && \ + ($tcl_platform(platform) != "foobar2")} { + incr value + break + } + set value +} {2} +test while-old-1.5 {basic while loops, test expr in quotes} { + set value 1 + while "0 < 3" {set value 2; break} + set value +} {2} + +test while-old-2.1 {continue in while loop} { + set list {1 2 3 4 5} + set index 0 + set result {} + while {$index < 5} { + if {$index == 2} {set index [expr $index+1]; continue} + set result [concat $result [lindex $list $index]] + set index [expr $index+1] + } + set result +} {1 2 4 5} + +test while-old-3.1 {break in while loop} { + set list {1 2 3 4 5} + set index 0 + set result {} + while {$index < 5} { + if {$index == 3} break + set result [concat $result [lindex $list $index]] + set index [expr $index+1] + } + set result +} {1 2 3} + +test while-old-4.1 {errors in while loops} { + set err [catch {while} msg] + list $err $msg +} {1 {wrong # args: should be "while test command"}} +test while-old-4.2 {errors in while loops} { + set err [catch {while 1} msg] + list $err $msg +} {1 {wrong # args: should be "while test command"}} +test while-old-4.3 {errors in while loops} { + set err [catch {while 1 2 3} msg] + list $err $msg +} {1 {wrong # args: should be "while test command"}} +test while-old-4.4 {errors in while loops} { + set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] + list $err $msg +} {1 {can't use non-numeric string as operand of "+"}} +test while-old-4.5 {errors in while loops} { + catch {unset x} + set x 1 + set err [catch {while {$x} {set x foo}} msg] + list $err $msg +} {1 {expected boolean value but got "foo"}} +test while-old-4.6 {errors in while loops} { + set err [catch {while {1} {error "loop aborted"}} msg] + list $err $msg $errorInfo +} {1 {loop aborted} {loop aborted + while executing +"error "loop aborted""}} + +test while-old-5.1 {while return result} { + while {0} {set a 400} +} {} +test while-old-5.2 {while return result} { + set x 1 + while {$x} {set x 0} +} {} diff --git a/tests/while.test b/tests/while.test new file mode 100644 index 0000000..8642747 --- /dev/null +++ b/tests/while.test @@ -0,0 +1,319 @@ +# Commands covered: while +# +# 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: @(#) @(#) while.test 1.9 97/07/02 16:41:35 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Basic "while" operation. + +catch {unset i} +catch {unset a} + +test while-1.1 {TclCompileWhileCmd: missing test expression} { + catch {while } msg + set msg +} {wrong # args: should be "while test command"} +test while-1.2 {TclCompileWhileCmd: error in test expression} { + set i 0 + catch {while {$i<}} msg + set errorInfo +} {syntax error in expression "$i<" + ("while" test expression) + while compiling +"while {$i<}"} +test while-1.3 {TclCompileWhileCmd: error in test expression} { + set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] + list $err $msg +} {1 {can't use non-numeric string as operand of "+"}} +test while-1.4 {TclCompileWhileCmd: multiline test expr} { + set value 1 + while {($tcl_platform(platform) != "foobar1") && \ + ($tcl_platform(platform) != "foobar2")} { + incr value + break + } + set value +} {2} +test while-1.5 {TclCompileWhileCmd: non-numeric boolean test expr} { + set value 1 + while {"true"} { + incr value; + if {$value > 5} { + break; + } + } + set value +} 6 +test while-1.6 {TclCompileWhileCmd: test expr is enclosed in quotes} { + set i 0 + while "$i > 5" {} +} {} +test while-1.7 {TclCompileWhileCmd: missing command body} { + set i 0 + catch {while {$i < 5} } msg + set msg +} {wrong # args: should be "while test command"} +test while-1.8 {TclCompileWhileCmd: error compiling command body} { + set i 0 + catch {while {$i < 5} {set}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("while" body line 1) + while compiling +"while {$i < 5} {set}"} +test while-1.9 {TclCompileWhileCmd: simple command body} { + set a {} + set i 1 + while {$i<6} { + if $i==4 break + set a [concat $a $i] + incr i + } + set a +} {1 2 3} +test while-1.10 {TclCompileWhileCmd: command body in quotes} { + set a {} + set i 1 + while {$i<6} "append a x; incr i" + set a +} {xxxxx} +test while-1.11 {TclCompileWhileCmd: computed command body} { + catch {unset x1} + catch {unset bb} + catch {unset x2} + set x1 {append a x1; } + set bb {break} + set x2 {; append a x2; incr i} + set a {} + set i 1 + while {$i<6} $x1$bb$x2 + set a +} {x1} +test while-1.12 {TclCompileWhileCmd: long command body} { + set a {} + set i 1 + while {$i<6} { + if $i==4 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + incr i + } + set a +} {1 2 3} +test while-1.13 {TclCompileWhileCmd: while command result} { + set i 0 + set a [while {$i < 5} {incr i}] + set a +} {} +test while-1.14 {TclCompileWhileCmd: while command result} { + set i 0 + set a [while {$i < 5} {if $i==3 break; incr i}] + set a +} {} + +# Check "while" and "continue". + +test while-2.1 {continue tests} { + set a {} + set i 1 + while {$i <= 4} { + incr i + if {$i == 3} continue + set a [concat $a $i] + } + set a +} {2 4 5} +test while-2.2 {continue tests} { + set a {} + set i 1 + while {$i <= 4} { + incr i + if {$i != 2} continue + set a [concat $a $i] + } + set a +} {2} +test while-2.3 {continue tests, nested loops} { + set msg {} + set i 1 + while {$i <= 4} { + incr i + set a 1 + while {$a <= 2} { + incr a + if {$i>=3 && $a>=3} continue + set msg [concat $msg "$i.$a"] + } + } + set msg +} {2.2 2.3 3.2 4.2 5.2} +test while-2.4 {continue tests, long command body} { + set a {} + set i 1 + while {$i<6} { + if $i==2 {incr i; continue} + if $i==4 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + incr i + } + set a +} {1 3} + +# Check "while" and "break". + +test while-3.1 {break tests} { + set a {} + set i 1 + while {$i <= 4} { + if {$i == 3} break + set a [concat $a $i] + incr i + } + set a +} {1 2} +test while-3.2 {break tests, nested loops} { + set msg {} + set i 1 + while {$i <= 4} { + set a 1 + while {$a <= 2} { + if {$i>=2 && $a>=2} break + set msg [concat $msg "$i.$a"] + incr a + } + incr i + } + set msg +} {1.1 1.2 2.1 3.1 4.1} +test while-3.3 {break tests, long command body} { + set a {} + set i 1 + while {$i<6} { + if $i==2 {incr i; continue} + if $i==5 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if $i==4 break + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + incr i + } + set a +} {1 3} + +# Check "while", "break", "continue" and computed command names. + +test while-4.1 {while and computed command names} { + set i 0 + set z while + $z {$i < 10} { + incr i + } + set i +} 10 + +test while-5.1 {break and computed command names} { + set i 0 + set z break + while 1 { + if {$i > 10} $z + incr i + } + set i +} 11 + +test while-6.1 {continue and computed command names} { + set i 0 + set z continue + while 1 { + incr i + if {$i < 10} $z + break + } + set i +} 10 diff --git a/tests/winFCmd.test b/tests/winFCmd.test new file mode 100644 index 0000000..a38d72f --- /dev/null +++ b/tests/winFCmd.test @@ -0,0 +1,979 @@ +# This file tests the tclWinFCmd.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winFCmd.test 1.11 97/10/10 11:50:05 +# + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {$tcl_platform(platform) != "windows"} { + return +} + +proc createfile {file {string a}} { + set f [open $file w] + puts -nonewline $f $string + close $f + return $string +} + +proc contents {file} { + set f [open $file r] + set r [read $f] + close $f + set r +} + +proc cleanup {args} { + foreach p ". $args" { + set x "" + catch { + set x [glob [file join $p tf*] [file join $p td*]] + } + if {$x != ""} { + catch {eval file delete -force -- $x} + } + } +} + +set testConfig(cdrom) 0 +set testConfig(exdev) 0 +set testConfig(UNCPath} 0 + +# find a CD-ROM so we can test read-only filesystems. + +set cdrom {} +set nodrive x: +foreach p {d e f g h i j k l m n o p q r s t u v w x y z} { + set name ${p}:/dummy~~.fil + if [catch {set fd [open $name w]}] { + set err [lindex $errorCode 1] + if {$cdrom == "" && $err == "EACCES"} { + set cdrom ${p}: + } + if {$err == "ENOENT"} { + set nodrive ${p}: + } + } else { + close $fd + file delete $name + } +} + +proc findfile {dir} { + foreach p [glob $dir/*] { + if {[file type $p] == "file"} { + return $p + } + } + foreach p [glob $dir/*] { + if {[file type $p] == "directory"} { + set f [findfile $p] + if {$f != ""} { + return $f + } + } + } + return "" +} + +if {$cdrom == ""} { + puts "Couldn't find a CD-ROM. Skipping tests that access CD-ROM." + puts "If you have a CD-ROM, insert a data disk and rerun tests." +} else { + set testConfig(cdrom) 1 + set cdfile [findfile $cdrom] +} + +if {[file exists c:/] && [file exists d:/]} { + catch {file delete d:/tf1} + if {[catch {close [open d:/tf1 w]}] == 0} { + file delete d:/tf1 + set testConfig(exdev) 1 + } +} + +if {[file exists //bisque/icepick]} { + set testConfig(UNCPath) 1 +} + +file delete -force -- td1 +set foo [catch {open td1 w} testfile] +if {$foo} { + set testConfig(longFileNames) 0 +} else { + close $testfile + set testConfig(longFileNames) 1 + file delete -force -- td1 +} + +# A really long file name +# length of longname is 1216 chars, which should be greater than any static +# buffer or allowable filename. + +set longname "abcdefghihjllmnopqrstuvwxyz01234567890" +append longname $longname +append longname $longname +append longname $longname +append longname $longname +append longname $longname + +# Uses the "testfile" command instead of the "file" command. The "file" +# command provides several layers of sanity checks on the arguments and +# it can be difficult to actually forward "insane" arguments to the +# low-level posix emulation layer. + +test winFCmd-1.1 {TclpRenameFile: errno: EACCES} {cdrom} { + list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} { + cleanup + file mkdir td1/td2/td3 + file mkdir td2 + list [catch {testfile mv td2 td1/td2} msg] $msg +} {1 EEXIST} +test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} {!$testConfig(win32s) || ("[lindex [file split [pwd]] end]" == "C:/")} { + # Don't run this test under Win32s on a drive mounted from an NT + # machine; it causes the NT machine to die. + + cleanup + list [catch {testfile mv / td1} msg] $msg +} {1 EINVAL} +test winFCmd-1.4 {TclpRenameFile: errno: EINVAL} { + cleanup + file mkdir td1 + list [catch {testfile mv td1 td1/td2} msg] $msg +} {1 EINVAL} +test winFCmd-1.5 {TclpRenameFile: errno: EISDIR} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {testfile mv tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-1.6 {TclpRenameFile: errno: ENOENT} { + cleanup + list [catch {testfile mv tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.7 {TclpRenameFile: errno: ENOENT} { + cleanup + list [catch {testfile mv "" tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.8 {TclpRenameFile: errno: ENOENT} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 ""} msg] $msg +} {1 ENOENT} +test winFCmd-1.9 {TclpRenameFile: errno: ENOTDIR} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {testfile mv td1 tf1} msg] $msg +} {1 ENOTDIR} +test winFCmd-1.10 {TclpRenameFile: errno: EXDEV} {exdev} { + file delete -force d:/tf1 + file mkdir c:/tf1 + set msg [list [catch {testfile mv c:/tf1 d:/tf1} msg] $msg] + file delete -force c:/tf1 + set msg +} {1 EXDEV} +test winFCmd-1.11 {TclpRenameFile: errno: EACCES} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile mv tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-1.12 {TclpRenameFile: errno: EACCES} { + cleanup + createfile tf1 + set fd [open tf2 w] + set msg [list [catch {testfile mv tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-1.13 {TclpRenameFile: errno: EACCES} { + cleanup + list [catch {testfile mv nul tf1} msg] $msg +} {1 EACCES} +test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {95} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 nul} msg] $msg +} {1 EACCES} +test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {nt} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 nul} msg] $msg +} {1 EEXIST} +test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} { + cleanup + createfile tf1 tf1 + testfile mv tf1 tf2 + list [file exists tf1] [contents tf2] +} {0 tf1} +test winFCmd-1.17 {TclpRenameFile: MoveFile() == FALSE} { + cleanup + list [catch {testfile mv tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} { + cleanup + list [catch {testfile mv tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.19 {TclpRenameFile: errno == EACCES} { + cleanup + list [catch {testfile mv nul 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} { + 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. + + list [catch {testfile mv $longname tf1} msg] $msg +} {1 ENAMETOOLONG} +test winFCmd-1.22 {TclpRenameFile: obscenely long dst} {nt} { + # return ENOENT if name is too long! + cleanup + createfile tf1 + list [catch {testfile mv tf1 $longname} msg] $msg +} {1 ENOENT} +test winFCmd-1.23 {TclpRenameFile: obscenely long dst} {95} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 $longname} msg] $msg +} {1 ENAMETOOLONG} +test winFCmd-1.24 {TclpRenameFile: move dir into self} { + cleanup + file mkdir td1 + list [catch {testfile mv [pwd]/td1 td1/td2} msg] $msg +} {1 EINVAL} +test winFCmd-1.25 {TclpRenameFile: move a root dir} {!$testConfig(win32s) || ("[lindex [file split [pwd]] end]" == "C:/")} { + # Don't run this test under Win32s on a drive mounted from an NT + # machine; it causes the NT machine to die. + + cleanup + list [catch {testfile mv / c:/} msg] $msg +} {1 EINVAL} +test winFCmd-1.26 {TclpRenameFile: cross file systems} {cdrom} { + cleanup + file mkdir td1 + list [catch {testfile mv td1 $cdrom/td1} msg] $msg +} {1 EXDEV} +test winFCmd-1.27 {TclpRenameFile: readonly fs} {cdrom} { + cleanup + list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-1.28 {TclpRenameFile: open file} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile mv tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-1.29 {TclpRenameFile: errno == EEXIST} { + cleanup + createfile tf1 + createfile tf2 + testfile mv tf1 tf2 + list [file exist tf1] [file exist tf2] +} {0 1} +test winFCmd-1.30 {TclpRenameFile: src is dir} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {testfile mv td1 tf1} msg] $msg +} {1 ENOTDIR} +test winFCmd-1.31 {TclpRenameFile: dst is dir} { + cleanup + file mkdir td1 + file mkdir td2/td2 + list [catch {testfile mv td1 td2} msg] $msg +} {1 EEXIST} +test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory fails} { + cleanup + file mkdir td1 + file mkdir td2/td2 + list [catch {testfile mv td1 td2} msg] $msg +} {1 EEXIST} +test winFCmd-1.33 {TclpRenameFile: TclpRemoveDirectory succeeds} { + cleanup + file mkdir td1/td2 + file mkdir td2 + testfile mv td1 td2 + list [file exist td1] [file exist td2] [file exist td2/td2] +} {0 1 1} +test winFCmd-1.34 {TclpRenameFile: After removing dst dir, MoveFile fails} {exdev} { + file mkdir d:/td1 + testchmod 000 d:/td1 + set msg [list [catch {testfile mv c:/windows d:/td1} msg] $msg] + set msg "$msg [file writable d:/td1]" + file delete d:/td1 + set msg +} {1 EXDEV 0} +test winFCmd-1.35 {TclpRenameFile: src is dir, dst is not} { + file mkdir td1 + createfile tf1 + list [catch {testfile mv td1 tf1} msg] $msg +} {1 ENOTDIR} +test winFCmd-1.36 {TclpRenameFile: src is not dir, dst is} { + file mkdir td1 + createfile tf1 + list [catch {testfile mv tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-1.37 {TclpRenameFile: src and dst not dir} { + createfile tf1 tf1 + createfile tf2 tf2 + testfile mv tf1 tf2 + contents tf2 +} {tf1} +test winFCmd-1.38 {TclpRenameFile: need to restore temp file} { + # Can't figure out how to cause this. + # Need a file that can't be copied. +} {} + +test winFCmd-2.1 {TclpCopyFile: errno: EACCES} {cdrom} { + cleanup + list [catch {testfile cp $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-2.2 {TclpCopyFile: errno: EISDIR} { + cleanup + file mkdir td1 + list [catch {testfile cp td1 tf1} msg] $msg +} {1 EISDIR} +test winFCmd-2.3 {TclpCopyFile: errno: EISDIR} { + cleanup + createfile tf1 + file mkdir td1 + list [catch {testfile cp tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-2.4 {TclpCopyFile: errno: ENOENT} { + cleanup + list [catch {testfile cp tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-2.5 {TclpCopyFile: errno: ENOENT} { + cleanup + list [catch {testfile cp "" tf2} msg] $msg +} {1 ENOENT} +test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} { + cleanup + createfile tf1 + list [catch {testfile cp tf1 ""} msg] $msg +} {1 ENOENT} +test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {!nt} { + cleanup + createfile tf1 + set fd [open tf2 w] + set msg [list [catch {testfile cp tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {nt} { + cleanup + list [catch {testfile cp nul tf1} msg] $msg +} {1 EACCES} +test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} {95} { + cleanup + list [catch {testfile cp nul tf1} msg] $msg +} {1 ENOENT} +test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} { + cleanup + createfile tf1 tf1 + testfile cp tf1 tf2 + list [contents tf1] [contents tf2] +} {tf1 tf1} +test winFCmd-2.11 {TclpCopyFile: CopyFile succeeds} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + testfile cp tf1 tf2 + list [contents tf1] [contents tf2] +} {tf1 tf1} +test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} { + cleanup + createfile tf1 tf1 + testchmod 000 tf1 + testfile cp tf1 tf2 + list [contents tf2] [file writable tf2] +} {tf1 0} +test winFCmd-2.13 {TclpCopyFile: CopyFile fails} { + cleanup + createfile tf1 + file mkdir td1 + list [catch {testfile cp tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-2.14 {TclpCopyFile: errno == EACCES} { + cleanup + file mkdir td1 + list [catch {testfile cp td1 tf1} msg] $msg +} {1 EISDIR} +test winFCmd-2.15 {TclpCopyFile: src is directory} { + cleanup + file mkdir td1 + list [catch {testfile cp td1 tf1} msg] $msg +} {1 EISDIR} +test winFCmd-2.16 {TclpCopyFile: dst is directory} { + cleanup + createfile tf1 + file mkdir td1 + list [catch {testfile cp tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-2.17 {TclpCopyFile: dst is readonly} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + testchmod 000 tf2 + testfile cp tf1 tf2 + list [file writable tf2] [contents tf2] +} {1 tf1} +test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} {95} { + cleanup + createfile tf1 + createfile tf2 + testchmod 000 tf2 + set fd [open tf2] + set msg [list [catch {testfile cp tf1 tf2} msg] $msg] + close $fd + set msg "$msg [file writable tf2]" +} {1 EACCES 0} + +test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} {cdrom} { + list [catch {testfile rm $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-3.2 {TclpDeleteFile: errno: EISDIR} { + cleanup + file mkdir td1 + list [catch {testfile rm td1} msg] $msg +} {1 EISDIR} +test winFCmd-3.3 {TclpDeleteFile: errno: ENOENT} { + cleanup + list [catch {testfile rm tf1} msg] $msg +} {1 ENOENT} +test winFCmd-3.4 {TclpDeleteFile: errno: ENOENT} { + cleanup + list [catch {testfile rm ""} msg] $msg +} {1 ENOENT} +test winFCmd-3.5 {TclpDeleteFile: errno: EACCES} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile rm tf1} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-3.6 {TclpDeleteFile: errno: EACCES} { + cleanup + list [catch {testfile rm nul} msg] $msg +} {1 EACCES} +test winFCmd-3.7 {TclpDeleteFile: DeleteFile succeeds} { + cleanup + createfile tf1 + testfile rm tf1 + file exist tf1 +} {0} +test winFCmd-3.8 {TclpDeleteFile: DeleteFile fails} { + cleanup + file mkdir td1 + list [catch {testfile rm td1} msg] $msg +} {1 EISDIR} +test winFCmd-3.9 {TclpDeleteFile: errno == EACCES} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile rm tf1} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-3.10 {TclpDeleteFile: path is readonly} { + cleanup + createfile tf1 + testchmod 000 tf1 + testfile rm tf1 + file exists tf1 +} {0} +test winFCmd-3.11 {TclpDeleteFile: still can't remove path} { + cleanup + set fd [open tf1 w] + testchmod 000 tf1 + set msg [list [catch {testfile rm tf1} msg] $msg] + close $fd + set msg +} {1 EACCES} + +test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {cdrom nt} { + list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg +} {1 EACCES} +test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} {cdrom 95} { + list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg +} {1 ENOSPC} +test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} { + cleanup + file mkdir td1 + list [catch {testfile mkdir td1} msg] $msg +} {1 EEXIST} +test winFCmd-4.4 {TclpCreateDirectory: errno: ENOENT} { + cleanup + list [catch {testfile mkdir td1/td2} msg] $msg +} {1 ENOENT} +test winFCmd-4.5 {TclpCreateDirectory: CreateDirectory succeeds} { + cleanup + testfile mkdir td1 + file type td1 +} {directory} + +test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} { + cleanup + file mkdir td1 + testfile cpdir td1 td2 + list [file type td1] [file type td2] +} {directory directory} + +test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} { + cleanup + file mkdir td1 + testchmod 000 td1 + testfile rmdir td1 + file exist td1 +} {0} +test winFCmd-6.2 {TclpRemoveDirectory: errno: EEXIST} { + cleanup + file mkdir td1/td2 + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-6.3 {TclpRemoveDirectory: errno: EACCES} { + # can't test this w/o removing everything on your hard disk first! + # testfile rmdir / +} {} +test winFCmd-6.4 {TclpRemoveDirectory: errno: ENOENT} { + cleanup + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 ENOENT}} +test winFCmd-6.5 {TclpRemoveDirectory: errno: ENOENT} { + cleanup + list [catch {testfile rmdir ""} msg] $msg +} {1 ENOENT} +test winFCmd-6.6 {TclpRemoveDirectory: errno: ENOTDIR} { + cleanup + createfile tf1 + list [catch {testfile rmdir tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.7 {TclpRemoveDirectory: RemoveDirectory succeeds} { + cleanup + file mkdir td1 + testfile rmdir td1 + file exists td1 +} {0} +test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} { + cleanup + createfile tf1 + list [catch {testfile rmdir tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} { + cleanup + file mkdir td1 + testchmod 000 td1 + testfile rmdir td1 + file exists td1 +} {0} +test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {!nt} { + cleanup + list [catch {testfile rmdir nul} msg] $msg +} {1 {nul EACCES}} +test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {nt} { + cleanup + list [catch {testfile rmdir /} msg] $msg +} {1 {\ EACCES}} +test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {!nt} { + cleanup + createfile tf1 + list [catch {testfile rmdir tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.13 {TclpRemoveDirectory: write-protected} { + cleanup + file mkdir td1 + testchmod 000 td1 + testfile rmdir td1 + file exists td1 +} {0} +test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {!nt} { + cleanup + file mkdir td1/td2 + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-6.15 {TclpRemoveDirectory: !recursive} { + cleanup + file mkdir td1/td2 + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-6.16 {TclpRemoveDirectory: recursive, but errno != EEXIST} { + cleanup + createfile tf1 + list [catch {testfile rmdir -force tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.17 {TclpRemoveDirectory: calls TraverseWinTree} { + cleanup + file mkdir td1/td2 + testfile rmdir -force td1 + file exists td1 +} {0} + +test winFCmd-7.1 {TraverseWinTree: targetPtr == NULL} { + cleanup + file mkdir td1/td2/td3 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.2 {TraverseWinTree: targetPtr != NULL} { + cleanup + file mkdir td1/td2/td3 + testfile cpdir td1 td2 + list [file exists td1] [file exists td2] +} {1 1} +test winFCmd-7.3 {TraverseWinTree: sourceAttr == -1} { + cleanup + list [catch {testfile cpdir td1 td2} msg] $msg +} {1 {td1 ENOENT}} +test winFCmd-7.4 {TraverseWinTree: source isn't directory} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.5 {TraverseWinTree: call TraversalCopy: DOTREE_F} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.6 {TraverseWinTree: call TraversalDelete: DOTREE_F} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {!nt && cdrom} { + list [catch {testfile rmdir $cdrom/} msg] $msg +} "1 {$cdrom\\ EEXIST}" +test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} {nt cdrom} { + list [catch {testfile rmdir $cdrom/} msg] $msg +} "1 {$cdrom\\ EACCES}" +test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} { + # can't make it happen +} {} +test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} { + cleanup + file mkdir td1 + testchmod 000 td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + list [file exists td2] [file writable td2] +} {1 0} +test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {!nt} { + cleanup + file mkdir td1 + list [catch {testfile cpdir td1 /} msg] $msg +} {1 {\ EEXIST}} +test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {nt} { + cleanup + file mkdir td1 + list [catch {testfile cpdir td1 /} msg] $msg +} {1 {\ EACCES}} +test winFCmd-7.16 {TraverseWinTree: recurse on files: no files} { + cleanup + file mkdir td1 + testfile cpdir td1 td2 +} {} +test winFCmd-7.17 {TraverseWinTree: recurse on files: one file} { + cleanup + file mkdir td1 + createfile td1/td2 + testfile cpdir td1 td2 + glob td2/* +} {td2/td2} +test winFCmd-7.18 {TraverseWinTree: recurse on files: several files and dir} { + cleanup + file mkdir td1 + createfile td1/tf1 + createfile td1/tf2 + file mkdir td1/td2/td3 + createfile td1/tf3 + createfile td1/tf4 + testfile cpdir td1 td2 + glob td2/* +} {td2/tf1 td2/tf2 td2/td2 td2/tf3 td2/tf4} +test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} { + cleanup + file mkdir td1 + testchmod 000 td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + list [file exists td2] [file writable td2] +} {1 0} +test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.21 {TraverseWinTree: fill errorPtr} { + cleanup + list [catch {testfile cpdir td1 td2} msg] $msg +} {1 {td1 ENOENT}} + +test winFCmd-8.1 {TraversalCopy: DOTREE_F} { + cleanup + file mkdir td1 + list [catch {testfile cpdir td1 td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} { + cleanup + file mkdir td1/td2 + testchmod 000 td1 + testfile cpdir td1 td2 + list [file writable td1] [file writable td1/td2] +} {0 1} +test winFCmd-8.3 {TraversalCopy: DOTREE_POSTD} { + cleanup + file mkdir td1 + testfile cpdir td1 td2 +} {} + +test winFCmd-9.1 {TraversalDelete: DOTREE_F} { + cleanup + file mkdir td1 + createfile td1/tf1 + testfile rmdir -force td1 +} {} +test winFCmd-9.2 {TraversalDelete: DOTREE_F} {95} { + cleanup + file mkdir td1 + set fd [open td1/tf1 w] + set msg [list [catch {testfile rmdir -force td1} msg] $msg] + close $fd + set msg +} {1 {td1\tf1 EACCES}} +test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} { + cleanup + file mkdir td1/td2 + testchmod 000 td1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} { + cleanup + file mkdir td1/td1/td3/td4/td5 + testfile rmdir -force td1 +} {} + +test winFCmd-10.1 {AttributesPosixError - get} { + cleanup + list [catch {file attributes td1 -archive} msg] $msg +} {1 {cannot get attribute "-archive" for file "td1": no such file or directory}} +test winFCmd-10.2 {AttributesPosixError - set} { + cleanup + list [catch {file attributes td1 -archive 0} msg] $msg +} {1 {cannot set attribute "-archive" for file "td1": no such file or directory}} + +test winFCmd-11.1 {GetWinFileAttributes} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -archive} msg] $msg [cleanup] +} {0 1 {}} +test winFCmd-11.2 {GetWinFileAttributes} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -readonly} msg] $msg [cleanup] +} {0 0 {}} +test winFCmd-11.3 {GetWinFileAttributes} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -hidden} msg] $msg [cleanup] +} {0 0 {}} +test winFCmd-11.4 {GetWinFileAttributes} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -system} msg] $msg [cleanup] +} {0 0 {}} + +test winFCmd-12.1 {ConvertFileNameFormat} { + cleanup + close [open td1 w] + list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup] +} {0 td1 {}} +test winFCmd-12.2 {ConvertFileNameFormat} { + cleanup + file mkdir td1 + close [open td1/td1 w] + list [catch {string tolower [file attributes td1/td1 -longname]} msg] $msg [cleanup] +} {0 td1/td1 {}} +test winFCmd-12.3 {ConvertFileNameFormat} { + cleanup + file mkdir td1 + file mkdir td1/td2 + close [open td1/td3 w] + list [catch {string tolower [file attributes td1/td2/../td3 -longname]} msg] $msg [cleanup] +} {0 td1/td2/../td3 {}} +test winFCmd-12.4 {ConvertFileNameFormat} { + cleanup + close [open td1 w] + list [catch {string tolower [file attributes ./td1 -longname]} msg] $msg [cleanup] +} {0 ./td1 {}} +test winFCmd-12.5 {ConvertFileNameFormat: absolute path} { + list [file attributes / -longname] [file attributes \\ -longname] +} {/ /} +test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} { + catch {file delete -force -- c:/td1} + close [open c:/td1 w] + list [catch {string tolower [file attributes c:/td1 -longname]} msg] $msg [file delete -force -- c:/td1] +} {0 c:/td1 {}} +test winFCmd-12.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.8 {ConvertFileNameFormat} {longFileNames} { + cleanup + close [open td1 w] + list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup] +} {0 td1 {}} +test winFCmd-12.9 {ConvertFileNameFormat} {win32s} { + cleanup + close [open td1 w] + list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup] +} {0 td1 {}} +test winFCmd-12.10 {ConvertFileNameFormat} {longFileNames} { + cleanup + close [open td1td1td1 w] + list [catch {file attributes td1td1td1 -shortname}] [cleanup] +} {0 {}} +test winFCmd-12.11 {ConvertFileNameFormat} {longFileNames} { + cleanup + close [open td1 w] + list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup] +} {0 td1 {}} + +test winFCmd-13.1 {GetWinFileLongName} { + cleanup + close [open td1 w] + list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup] +} {0 td1 {}} + +test winFCmd-14.1 {GetWinFileShortName} { + cleanup + close [open td1 w] + list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup] +} {0 td1 {}} + +test winFCmd-15.1 {SetWinFileAttributes} { + cleanup + list [catch {file attributes td1 -archive 0} msg] $msg +} {1 {cannot set attribute "-archive" for file "td1": no such file or directory}} +test winFCmd-15.2 {SetWinFileAttributes - archive} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -archive 1} msg] $msg [file attributes td1 -archive] [cleanup] +} {0 {} 1 {}} +test winFCmd-15.3 {SetWinFileAttributes - archive} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -archive 0} msg] $msg [file attributes td1 -archive] [cleanup] +} {0 {} 0 {}} +test winFCmd-15.4 {SetWinFileAttributes - hidden} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -hidden 1} msg] $msg [file attributes td1 -hidden] [file attributes td1 -hidden 0] [cleanup] +} {0 {} 1 {} {}} +test winFCmd-15.5 {SetWinFileAttributes - hidden} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -hidden 0} msg] $msg [file attributes td1 -hidden] [cleanup] +} {0 {} 0 {}} +test winFCmd-15.6 {SetWinFileAttributes - readonly} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -readonly 1} msg] $msg [file attributes td1 -readonly] [cleanup] +} {0 {} 1 {}} +test winFCmd-15.7 {SetWinFileAttributes - readonly} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -readonly 0} msg] $msg [file attributes td1 -readonly] [cleanup] +} {0 {} 0 {}} +test winFCmd-15.8 {SetWinFileAttributes - system} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -system 1} msg] $msg [file attributes td1 -system] [cleanup] +} {0 {} 1 {}} +test winFCmd-15.9 {SetWinFileAttributes - system} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -system 0} msg] $msg [file attributes td1 -system] [cleanup] +} {0 {} 0 {}} +test winFCmd-15.10 {SetWinFileAttributes - failing} {cdrom} { + cleanup + catch {file attributes $cdfile -archive 1} +} {1} + +cleanup + +return + +foreach source {tef ted tnf tnd "" nul com1} { + foreach chmodsrc {000 755} { + foreach dest "tfn tfe tdn tdempty tdfull td1/td2 $p $p/td1 {} nul" { + foreach chmoddst {000 755} { + puts hi + cleanup + file delete -force ted tef + file mkdir ted + createfile tef + createfile tfe + file mkdir tdempty + file mkdir tdfull/td1/td2 + + catch {testchmod $chmodsrc $source} + catch {testchmod $chmoddst $dest} + + if [catch {file rename $source $dest} msg] { + puts "file rename $source ($chmodsrc) $dest ($chmoddst)" + puts $msg + } + } + } + } +} + diff --git a/tests/winNotify.test b/tests/winNotify.test new file mode 100644 index 0000000..2914a41 --- /dev/null +++ b/tests/winNotify.test @@ -0,0 +1,155 @@ +# This file tests the tclWinNotify.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winNotify.test 1.2 97/04/14 17:24:56 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {$tcl_platform(platform) != "windows"} { + return +} + +# There is no explicit test for InitNotifier or NotifierExitHandler + +test winNotify-1.1 {Tcl_SetTimer: positive timeout} { + set done 0 + after 1000 { set done 1 } + vwait done + set done +} 1 +test winNotify-1.2 {Tcl_SetTimer: positive timeout, message pending} { + set x 0 + set y 1 + set a1 [after 0 { incr y }] + after cancel $a1 + after 500 { incr x } + vwait x + list $x $y +} {1 1} +test winNotify-1.3 {Tcl_SetTimer: cancelling positive timeout} { + set x 0 + set y 1 + set id [after 10000 { incr y }] + after 0 { incr x } + vwait x + after cancel $id + list $x $y +} {1 1} +test winNotify-1.4 {Tcl_SetTimer: null timeout, message pending} { + set x 0 + set y 1 + after 0 { incr x } + after 0 { incr y } + vwait x + list $x $y +} {1 2} + +test winNotify-2.1 {Tcl_ResetIdleTimer} { + set x 0 + update + after idle { incr x } + vwait x + set x +} 1 +test winNotify-2.2 {Tcl_ResetIdleTimer: message pending} { + set x 0 + set y 1 + update + after idle { incr x } + after idle { incr y } + update + list $x $y +} {1 2} + +test winNotify-3.1 {NotifierProc: non-modal normal timer} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + after 500 { incr x; testeventloop done } + testeventloop wait + set x +} 1 +test winNotify-3.2 {NotifierProc: non-modal normal timer, rescheduled} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + after 500 { incr x; after 100 {incr x; testeventloop done }} + testeventloop wait + set x +} 2 +test winNotify-3.3 {NotifierProc: modal normal timer} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + after 500 { incr x } + vwait x + set x +} 1 +test winNotify-3.4 {NotifierProc: modal normal timer, rescheduled} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + set y 0 + after 500 { incr y; after 100 {incr x}} + vwait x + list $x $y +} {1 1} +test winNotify-3.5 {NotifierProc: non-modal idle timer} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + after idle { incr x; testeventloop done } + testeventloop wait + set x +} 1 +test winNotify-3.6 {NotifierProc: non-modal idle timer, rescheduled} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + after idle { incr x; after idle {incr x; testeventloop done }} + testeventloop wait + set x +} 2 +test winNotify-3.7 {NotifierProc: modal idle timer} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + after idle { incr x } + vwait x + set x +} 1 +test winNotify-3.8 {NotifierProc: modal idle timer, rescheduled} { + update + set x 0 + foreach i [after info] { + after cancel $i + } + set y 0 + after idle { incr y; after idle {incr x}} + vwait x + list $x $y +} {1 1} + +# Tcl_DoOneEvent is tested by the timer.test, io.test, and event.test files diff --git a/tests/winPipe.test b/tests/winPipe.test new file mode 100644 index 0000000..404251f --- /dev/null +++ b/tests/winPipe.test @@ -0,0 +1,359 @@ +# +# winPipe.test -- +# +# This file contains a collection of tests for tclWinPipe.c + +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winPipe.test 1.11 97/10/09 17:06:16 + +if {$tcl_platform(platform) != "windows"} { + return +} + +set cat16 [file join $tcl_library ../win/cat16.exe] +set cat32 [file join $tcl_library ../win/cat32.exe] + +if {[string compare test [info procs test]] == 1} then {source defs} + +if [catch {puts console1 ""}] { + set testConfig(AllocConsole) 1 +} else { + set testConfig(.console) 1 +} + +set big aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n +append big $big +append big $big +append big $big +append big $big +append big $big +append big $big + +set f [open "little" w] +puts -nonewline $f "little" +close $f + +set f [open "big" w] +puts -nonewline $f $big +close $f + +proc contents {file} { + set f [open $file r] + set r [read $f] + close $f + set r +} + +if {$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" +test winpipe-1.2 {32 bit comprehensive tests: from big file} { + exec $cat32 < big > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr32" +test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {nt} { + exec more < little | $cat32 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{little\n} stderr32" +test winpipe-1.4 {32 bit comprehensive tests: a little from pipe} {95} { + exec more < little |& $cat32 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\nlittle} stderr32" +test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {nt} { + exec more < big | $cat32 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr32" +test winpipe-1.6 {32 bit comprehensive tests: a lot from pipe} {95} { + exec command /c type big |& $cat32 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr32" +test winpipe-1.7 {32 bit comprehensive tests: from console} {AllocConsole} { + # would block waiting for human input +} {} +test winpipe-1.8 {32 bit comprehensive tests: from NUL} { + exec $cat32 < nul > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{} stderr32" +test winpipe-1.9 {32 bit comprehensive tests: from socket} { + # doesn't work +} {} +test winpipe-1.10 {32 bit comprehensive tests: from nowhere} {.console} { + exec $cat32 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{} stderr32" +test winpipe-1.11 {32 bit comprehensive tests: from file handle} { + set f [open "little" r] + exec $cat32 <@$f > stdout 2> stderr + close $f + list [contents stdout] [contents stderr] +} "little stderr32" +test winpipe-1.12 {32 bit comprehensive tests: read from application} { + set f [open "|$cat32 < little" r] + gets $f line + catch {close $f} msg + list $line $msg +} "little stderr32" +test winpipe-1.13 {32 bit comprehensive tests: a little to file} { + exec $cat32 < little > stdout 2> stderr + list [contents stdout] [contents stderr] +} "little stderr32" +test winpipe-1.14 {32 bit comprehensive tests: a lot to file} { + exec $cat32 < big > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr32" +test winpipe-1.15 {32 bit comprehensive tests: a little to pipe} {nt} { + exec $cat32 < little | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{little\n} stderr32" +test winpipe-1.16 {32 bit comprehensive tests: a little to pipe} {95} { + exec $cat32 < little | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\nlittle} stderr32" +test winpipe-1.17 {32 bit comprehensive tests: a lot to pipe} {nt} { + exec $cat32 < big | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big\n} stderr32" +test winpipe-1.18 {32 bit comprehensive tests: a lot to pipe} {95} { + exec $cat32 < big | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\n$big} stderr32" +test winpipe-1.19 {32 bit comprehensive tests: to console} { + catch {exec $cat32 << "You should see this\n" >@stdout} msg + set msg +} stderr32 +test winpipe-1.20 {32 bit comprehensive tests: to NUL} { + # some apps hang when sending a large amount to NUL. $cat32 isn't one. + catch {exec $cat32 < big > nul} msg + set msg +} stderr32 +test winpipe-1.21 {32 bit comprehensive tests: to nowhere} {.console} { + exec $cat32 < big >&@stdout +} {} +test winpipe-1.22 {32 bit comprehensive tests: to file handle} { + set f1 [open "stdout" w] + set f2 [open "stderr" w] + exec $cat32 < little >@$f1 2>@$f2 + close $f1 + close $f2 + list [contents stdout] [contents stderr] +} "little stderr32" +test winpipe-1.23 {32 bit comprehensive tests: write to application} { + set f [open "|$cat32 > stdout" w] + puts -nonewline $f "foo" + catch {close $f} msg + list [contents stdout] $msg +} "foo stderr32" +test winpipe-1.24 {32 bit comprehensive tests: read/write application} { + set f [open "|$cat32" r+] + puts $f $big + puts $f \032 + flush $f + set r [read $f 64] + catch {close $f} + set r +} "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" +} + +set stderr16 "stderr16" +if {$tcl_platform(os) == "Win32s"} { + set stderr16 "{}" +} +if [file exists $cat16] { +test winpipe-2.1 {16 bit comprehensive tests: from little file} { + exec $cat16 < little > stdout 2> stderr + list [contents stdout] [contents stderr] +} "little $stderr16" +test winpipe-2.2 {16 bit comprehensive tests: from big file} { + exec $cat16 < big > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} $stderr16" +test winpipe-2.3 {16 bit comprehensive tests: a little from pipe} {nt} { + exec more < little | $cat16 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{little\n} stderr16" +test winpipe-2.4 {16 bit comprehensive tests: a little from pipe} {95} { + exec more < little | $cat16 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\nlittle} stderr16" +test winpipe-2.5 {16 bit comprehensive tests: a lot from pipe} {nt} { + exec $cat16 < big | $cat16 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} stderr16stderr16" +test winpipe-2.6 {16 bit comprehensive tests: a lot from pipe} {95} { + exec more < big | $cat16 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\n$big} stderr16" +test winpipe-2.7 {16 bit comprehensive tests: from console} {AllocConsole} { + # would block waiting for human input +} {} +test winpipe-2.8 {16 bit comprehensive tests: from NUL} {nt} { + exec $cat16 < nul > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{} stderr16" +test winpipe-2.9 {16 bit comprehensive tests: from socket} { + # doesn't work +} {} +test winpipe-2.10 {16 bit comprehensive tests: from nowhere} {.console} { + exec $cat16 > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{} stderr16" +test winpipe-2.11 {16 bit comprehensive tests: from file handle} { + set f [open "little" r] + exec $cat16 <@$f > stdout 2> stderr + close $f + list [contents stdout] [contents stderr] +} "little $stderr16" +test winpipe-2.12 {16 bit comprehensive tests: read from application} { + set f [open "|$cat16 < little" r] + gets $f line + catch {close $f} msg + list $line $msg +} "little $stderr16" +test winpipe-2.13 {16 bit comprehensive tests: a little to file} { + exec $cat16 < little > stdout 2> stderr + list [contents stdout] [contents stderr] +} "little $stderr16" +test winpipe-2.14 {16 bit comprehensive tests: a lot to file} { + exec $cat16 < big > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{$big} $stderr16" +test winpipe-2.15 {16 bit comprehensive tests: a little to pipe} {nt} { + catch {exec $cat16 < little | more > stdout 2> stderr} + list [contents stdout] [contents stderr] +} "{little\n} stderr16" +test winpipe-2.16 {16 bit comprehensive tests: a little to pipe} {95} { + exec $cat16 < little | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\nlittle} stderr16" +test winpipe-2.17 {16 bit comprehensive tests: a lot to pipe} {nt} { + catch {exec $cat16 < big | more > stdout 2> stderr} + list [contents stdout] [contents stderr] +} "{$big\n} stderr16" +test winpipe-2.18 {16 bit comprehensive tests: a lot to pipe} {95} { + exec $cat16 < big | more > stdout 2> stderr + list [contents stdout] [contents stderr] +} "{\n$big} stderr16" +test winpipe-2.19 {16 bit comprehensive tests: to console} { + catch {exec $cat16 << "You should see this\n" >@stdout} msg + set msg +} [lindex $stderr16 0] +test winpipe-2.20 {16 bit comprehensive tests: to NUL} {nt} { + # some apps hang when sending a large amount to NUL. cat16 isn't one. + catch {exec $cat16 < big > nul} msg + set msg +} stderr16 +test winpipe-2.21 {16 bit comprehensive tests: to nowhere} {.console} { + exec $cat16 < big >&@stdout +} {} +test winpipe-2.22 {16 bit comprehensive tests: to file handle} { + set f1 [open "stdout" w] + set f2 [open "stderr" w] + exec $cat16 < little >@$f1 2>@$f2 + close $f1 + close $f2 + list [contents stdout] [contents stderr] +} "little $stderr16" +test winpipe-2.23 {16 bit comprehensive tests: write to application} {!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} { + set f [open "|$cat16" r+] + puts $f $big + puts $f \032 + flush $f + set r [read $f 64] + catch {close $f} + set r +} "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" +} + +test winpipe-3.1 {Tcl_WaitPid} {nt} { + proc readResults {f} { + global x result + if { [eof $f] } { + close $f + set x 1 + } else { + set line [read $f ] + set result "$result$line" + } + } + + set f [open "|$cat32 < big 2> stderr" r] + fconfigure $f -buffering none -blocking 0 + fileevent $f readable "readResults $f" + set x 0 + set result "" + vwait x + list $result $x [contents stderr] +} "{$big} 1 stderr32" + +close [open nothing w] + +catch {set env_tmp $env(TMP)} +catch {set env_temp $env(TEMP)} + +set env(TMP) c:/ +set env(TEMP) c:/ + +test winpipe-3.1 {TclpCreateTempFile: cleanup temp files} { + set x {} + set existing [glob -nocomplain c:/tcl*.tmp] + exec $tcltest < nothing + foreach p [glob -nocomplain c:/tcl*.tmp] { + if {[lsearch $existing $p] != -1} { + lappend x $p + } + } + set x +} {} +test winpipe-3.2 {TclpCreateTempFile: TMP and TEMP not defined} { + set tmp $env(TMP) + set temp $env(TEMP) + unset env(TMP) + unset env(TEMP) + exec $tcltest < nothing + set env(TMP) $tmp + set env(TEMP) $temp + set x {} +} {} +test winpipe-3.3 {TclpCreateTempFile: TMP specifies non-existent directory} { + set tmp $env(TMP) + set env(TMP) snarky + exec $tcltest < nothing + set env(TMP) $tmp + set x {} +} {} +test winpipe-3.3 {TclpCreateTempFile: TEMP specifies non-existent directory} { + set tmp $env(TMP) + set temp $env(TEMP) + unset env(TMP) + set env(TEMP) snarky + exec $tcltest < nothing + set env(TMP) $tmp + set env(TEMP) $temp + set x {} +} {} + +# restore old values fro env(TMP) and env(TEMP) + +if {[catch {set env(TMP) $env_tmp}]} { + unset $env(TMP) +} +if {[catch {set env(TEMP) $env_temp}]} { + unset $env(TEMP) +} + +file delete big little stdout stderr nothing diff --git a/unix/Makefile.in b/unix/Makefile.in new file mode 100644 index 0000000..6b15ff5 --- /dev/null +++ b/unix/Makefile.in @@ -0,0 +1,1014 @@ +# +# This file is a Makefile for Tcl. If it has the name "Makefile.in" +# then it is a template for a Makefile; to generate the actual Makefile, +# run "./configure", which is a configuration script generated by the +# "autoconf" program (constructs like "@foo@" will get replaced in the +# actual Makefile. +# +# SCCS: @(#) Makefile.in 1.190 97/11/05 10:57:38 + +# Current Tcl version; used in various names. + +VERSION = @TCL_VERSION@ + +#---------------------------------------------------------------- +# Things you can change to personalize the Makefile for your own +# site (you can make these changes in either Makefile.in or +# Makefile, but changes to Makefile will get lost if you re-run +# the configuration script). +#---------------------------------------------------------------- + +# Default top-level directories in which to install architecture- +# specific files (exec_prefix) and machine-independent files such +# as scripts (prefix). The values specified here may be overridden +# at configure-time with the --exec-prefix and --prefix options +# to the "configure" script. + +prefix = @prefix@ +exec_prefix = @exec_prefix@ + +# The following definition can be set to non-null for special systems +# like AFS with replication. It allows the pathnames used for installation +# to be different than those used for actually reference files at +# run-time. INSTALL_ROOT is prepended to $prefix and $exec_prefix +# when installing files. +INSTALL_ROOT = + +# Directory from which applications will reference the library of Tcl +# scripts (note: you can set the TCL_LIBRARY environment variable at +# run-time to override this value): +TCL_LIBRARY = $(prefix)/lib/tcl$(VERSION) + +# Package search path. +TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@ + +# Path name to use when installing library scripts: +SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) + +# Directory in which to install libtcl.so or libtcl.a: +LIB_INSTALL_DIR = $(INSTALL_ROOT)$(exec_prefix)/lib + +# Path to use at runtime to refer to LIB_INSTALL_DIR: +LIB_RUNTIME_DIR = $(exec_prefix)/lib + +# Directory in which to install the program tclsh: +BIN_INSTALL_DIR = $(INSTALL_ROOT)$(exec_prefix)/bin + +# Directory in which to install the include file tcl.h: +INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(prefix)/include + +# Top-level directory in which to install manual entries: +MAN_INSTALL_DIR = $(INSTALL_ROOT)$(prefix)/man + +# Directory in which to install manual entry for tclsh: +MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 + +# Directory in which to install manual entries for Tcl's C library +# procedures: +MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 + +# Directory in which to install manual entries for the built-in +# Tcl commands: +MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann + +# To change the compiler switches, for example to change from -O +# to -g, change the following line: +CFLAGS = -O + +# To disable ANSI-C procedure prototypes reverse the comment characters +# on the following lines: +PROTO_FLAGS = +#PROTO_FLAGS = -DNO_PROTOTYPE + +# Mathematical functions like sin and atan2 are enabled for expressions +# by default. To disable them, reverse the comment characters on the +# following pairs of lines: +MATH_FLAGS = +#MATH_FLAGS = -DTCL_NO_MATH +MATH_LIBS = @MATH_LIBS@ +#MATH_LIBS = + +# If you use the setenv, putenv, or unsetenv procedures to modify +# environment variables in your application and you'd like those +# modifications to appear in the "env" Tcl variable, switch the +# comments on the two lines below so that Tcl provides these +# procedures instead of your standard C library. + +ENV_FLAGS = +#ENV_FLAGS = -DTclSetEnv=setenv -DTcl_PutEnv=putenv -DTclUnsetEnv=unsetenv + +# To compile for non-UNIX systems (so that only the non-UNIX-specific +# commands are available), reverse the comment characters on the +# following pairs of lines. In addition, you'll have to provide your +# own replacement for the "panic" procedure (see panic.c for what +# the current one does). +GENERIC_FLAGS = +#GENERIC_FLAGS = -DTCL_GENERIC_ONLY +UNIX_OBJS = tclMtherr.o tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ + tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ + tclUnixTime.o tclUnixInit.o +#UNIX_OBJS = +NOTIFY_OBJS = tclUnixNotfy.o +#NOTIFY_OBJS = + +# To enable memory debugging reverse the comment characters on the following +# lines. Warning: if you enable memory debugging, you must do it +# *everywhere*, including all the code that calls Tcl, and you must use +# ckalloc and ckfree everywhere instead of malloc and free. +MEM_DEBUG_FLAGS = +#MEM_DEBUG_FLAGS = -DTCL_MEM_DEBUG + +# To enable compilation debugging reverse the comment characters on +# one of the following lines. +COMPILE_DEBUG_FLAGS = +#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_STATS +#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS + +# Some versions of make, like SGI's, use the following variable to +# determine which shell to use for executing commands: +SHELL = /bin/sh + +# Tcl used to let the configure script choose which program to use +# for installing, but there are just too many different versions of +# "install" around; better to use the install-sh script that comes +# with the distribution, which is slower but guaranteed to work. + +INSTALL = @srcdir@/install-sh -c +INSTALL_PROGRAM = ${INSTALL} +INSTALL_DATA = ${INSTALL} -m 644 + +# The following symbol defines additional compiler flags to enable +# Tcl itself to be a shared library. If Tcl isn't going to be a +# shared library then the symbol has an empty definition. + +TCL_SHLIB_CFLAGS = @TCL_SHLIB_CFLAGS@ +#TCL_SHLIB_CFLAGS = + +# The symbols below provide support for dynamic loading and shared +# libraries. See configure.in for a description of what the +# symbols mean. The values of the symbols are normally set by the +# configure script. You shouldn't normally need to modify any of +# these definitions by hand. + +SHLIB_LD = @SHLIB_LD@ + +SHLIB_SUFFIX = @SHLIB_SUFFIX@ +#SHLIB_SUFFIX = + +DLTEST_TARGETS = dltest/pkg5${SHLIB_SUFFIX} dltest/Makefile + +# The following symbol is defined to "$(DLTEST_TARGETS)" if dynamic +# loading is available; this causes everything in the "dltest" +# subdirectory to be built when making "tcltest. If dynamic loading +# isn't available, configure defines this symbol to an empty string, +# in which case the shared libraries aren't built. +BUILD_DLTEST = @BUILD_DLTEST@ +#BUILD_DLTEST = + +TCL_LIB_FILE = @TCL_LIB_FILE@ +#TCL_LIB_FILE = libtcl.a + +#---------------------------------------------------------------- +# The information below is modified by the configure script when +# Makefile is generated from Makefile.in. You shouldn't normally +# modify any of this stuff by hand. +#---------------------------------------------------------------- + +COMPAT_OBJS = @LIBOBJS@ + +AC_FLAGS = @DEFS@ +RANLIB = @RANLIB@ +SRC_DIR = @srcdir@ +TOP_DIR = @srcdir@/.. +GENERIC_DIR = $(TOP_DIR)/generic +COMPAT_DIR = $(TOP_DIR)/compat +TOOL_DIR = $(TOP_DIR)/tools +DLTEST_DIR = @srcdir@/dltest +UNIX_DIR = @srcdir@ +CC = @CC@ + +#---------------------------------------------------------------- +# The information below should be usable as is. The configure +# script won't modify it and you shouldn't need to modify it +# either. +#---------------------------------------------------------------- + + +CC_SWITCHES = ${CFLAGS} ${TCL_SHLIB_CFLAGS} -I${GENERIC_DIR} -I${SRC_DIR} \ +${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ +${COMPILE_DEBUG_FLAGS} ${ENV_FLAGS} -DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" + +LIBS = @DL_LIBS@ @LIBS@ $(MATH_LIBS) -lc + +DEPEND_SWITCHES = ${CFLAGS} -I${GENERIC_DIR} -I${SRC_DIR} \ +${AC_FLAGS} ${MATH_FLAGS} \ +${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ +-DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" + +TCLSH_OBJS = tclAppInit.o + +TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclUnixTest.o + +XTTEST_OBJS = tclTest.o tclTestObj.o tclUnixTest.o tclXtNotify.o \ + tclXtTest.o xtTestInit.o + +GENERIC_OBJS = panic.o regexp.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \ + tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompExpr.o \ + tclCompile.o tclDate.o tclEnv.o tclEvent.o tclExecute.o \ + tclFCmd.o tclFileName.o tclGet.o tclHash.o tclHistory.o \ + tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o tclIOSock.o \ + tclIOUtil.o tclLink.o tclListObj.o tclLoad.o tclMain.o tclNamesp.o \ + tclNotify.o tclObj.o tclParse.o tclPipe.o tclPkg.o tclPosixStr.o \ + tclPreserve.o tclProc.o tclStringObj.o tclTimer.o tclUtil.o tclVar.o + +OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} @DL_OBJS@ + +GENERIC_HDRS = \ + $(GENERIC_DIR)/tclRegexp.h \ + $(GENERIC_DIR)/tcl.h \ + $(GENERIC_DIR)/tclInt.h \ + $(GENERIC_DIR)/tclPort.h \ + $(GENERIC_DIR)/tclPatch.h + +GENERIC_SRCS = \ + $(GENERIC_DIR)/regexp.c \ + $(GENERIC_DIR)/tclAsync.c \ + $(GENERIC_DIR)/tclBasic.c \ + $(GENERIC_DIR)/tclBinary.c \ + $(GENERIC_DIR)/tclCkalloc.c \ + $(GENERIC_DIR)/tclClock.c \ + $(GENERIC_DIR)/tclCmdAH.c \ + $(GENERIC_DIR)/tclCmdIL.c \ + $(GENERIC_DIR)/tclCmdMZ.c \ + $(GENERIC_DIR)/tclCompExpr.c \ + $(GENERIC_DIR)/tclCompile.c \ + $(GENERIC_DIR)/tclDate.c \ + $(GENERIC_DIR)/tclEnv.c \ + $(GENERIC_DIR)/tclEvent.c \ + $(GENERIC_DIR)/tclExecute.c \ + $(GENERIC_DIR)/tclFCmd.c \ + $(GENERIC_DIR)/tclFileName.c \ + $(GENERIC_DIR)/tclGet.c \ + $(GENERIC_DIR)/tclHash.c \ + $(GENERIC_DIR)/tclHistory.c \ + $(GENERIC_DIR)/tclIndexObj.c \ + $(GENERIC_DIR)/tclInterp.c \ + $(GENERIC_DIR)/tclIO.c \ + $(GENERIC_DIR)/tclIOCmd.c \ + $(GENERIC_DIR)/tclIOSock.c \ + $(GENERIC_DIR)/tclIOUtil.c \ + $(GENERIC_DIR)/tclLink.c \ + $(GENERIC_DIR)/tclListObj.c \ + $(GENERIC_DIR)/tclLoad.c \ + $(GENERIC_DIR)/tclMain.c \ + $(GENERIC_DIR)/tclNamesp.c \ + $(GENERIC_DIR)/tclNotify.c \ + $(GENERIC_DIR)/tclObj.c \ + $(GENERIC_DIR)/tclParse.c \ + $(GENERIC_DIR)/tclPipe.c \ + $(GENERIC_DIR)/tclPkg.c \ + $(GENERIC_DIR)/tclPosixStr.c \ + $(GENERIC_DIR)/tclPreserve.c \ + $(GENERIC_DIR)/tclProc.c \ + $(GENERIC_DIR)/tclStringObj.c \ + $(GENERIC_DIR)/tclTest.c \ + $(GENERIC_DIR)/tclTestObj.c \ + $(GENERIC_DIR)/tclTimer.c \ + $(GENERIC_DIR)/tclUtil.c \ + $(GENERIC_DIR)/tclVar.c + +UNIX_HDRS = \ + $(UNIX_DIR)/tclUnixPort.h + +UNIX_SRCS = \ + $(UNIX_DIR)/tclAppInit.c \ + $(UNIX_DIR)/tclMtherr.c \ + $(UNIX_DIR)/tclUnixChan.c \ + $(UNIX_DIR)/tclUnixEvent.c \ + $(UNIX_DIR)/tclUnixFCmd.c \ + $(UNIX_DIR)/tclUnixFile.c \ + $(UNIX_DIR)/tclUnixNotfy.c \ + $(UNIX_DIR)/tclUnixPipe.c \ + $(UNIX_DIR)/tclUnixSock.c \ + $(UNIX_DIR)/tclUnixTest.c \ + $(UNIX_DIR)/tclUnixTime.c \ + $(UNIX_DIR)/tclUnixInit.c + +DL_SRCS = \ + $(UNIX_DIR)/tclLoadAix.c \ + $(UNIX_DIR)/tclLoadAout.c \ + $(UNIX_DIR)/tclLoadDl.c \ + $(UNIX_DIR)/tclLoadDl2.c \ + $(UNIX_DIR)/tclLoadDld.c \ + $(GENERIC_DIR)/tclLoadNone.c \ + $(UNIX_DIR)/tclLoadOSF.c \ + $(UNIX_DIR)/tclLoadShl.c + +# Note: don't include DL_SRCS in SRCS: most of those files won't +# compile on the current machine, and they will cause problems for +# things like "make depend". + +SRCS = $(GENERIC_SRCS) $(UNIX_SRCS) + +all: ${TCL_LIB_FILE} tclsh + +# The following target is configured by autoconf to generate either +# a shared library or non-shared library for Tcl. +${TCL_LIB_FILE}: ${OBJS} + rm -f ${TCL_LIB_FILE} + @MAKE_LIB@ + $(RANLIB) ${TCL_LIB_FILE} + +# Make target which outputs the list of the .o contained in the Tcl lib +# usefull to build a single big shared library containing Tcl and other +# extensions. used for the Tcl Plugin. -- dl +# The dependency on OBJS is not there because we just want the list +# of objects here, not actually building them +tclLibObjs: + @echo ${OBJS} +# This targets actually build the objects needed for the lib in the above +# case +objs: ${OBJS} + + +tclsh: ${TCLSH_OBJS} ${TCL_LIB_FILE} + ${CC} @LD_FLAGS@ ${TCLSH_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \ + @TCL_LD_SEARCH_FLAGS@ -o tclsh + +tcltest: ${TCLTEST_OBJS} ${TCL_LIB_FILE} ${BUILD_DLTEST} + ${CC} @LD_FLAGS@ ${TCLTEST_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \ + @TCL_LD_SEARCH_FLAGS@ -o tcltest + +xttest: ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ + @DL_OBJS@ ${BUILD_DLTEST} + ${CC} ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ + @DL_OBJS@ @TCL_BUILD_LIB_SPEC@ ${LIBS} \ + @TCL_LD_SEARCH_FLAGS@ -lXt -o xttest + + +# Note, in the target below TCL_LIBRARY needs to be set or else +# "make test" won't work in the case where the compilation directory +# isn't the same as the source directory. + +test: tcltest + LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \ + TCL_LIBRARY=${TOP_DIR}/library; export TCL_LIBRARY; \ + ( echo cd $(TOP_DIR)/tests\; source all ) | ./tcltest + +# Useful target to launch a built tcltest with the proper path,... +runtest: + LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \ + TCL_LIBRARY=${TOP_DIR}/library; export TCL_LIBRARY; \ + ./tcltest + +# The following target outputs the name of the top-level source directory +# for Tcl (it is used by Tk's configure script, for example). The +# .NO_PARALLEL line is needed to avoid problems under Sun's "pmake". +# Note: this target is now obsolete (use the autoconf variable +# TCL_SRC_DIR from tclConfig.sh instead). + +.NO_PARALLEL: topDirName +topDirName: + @cd $(TOP_DIR); pwd + +# The following target generates the file generic/tclDate.c +# from the yacc grammar found in generic/tclGetDate.y. This is +# only run by hand as yacc is not available in all environments. +# The name of the .c file is different than the name of the .y file +# so that make doesn't try to automatically regenerate the .c file. + +gendate: + yacc -l $(GENERIC_DIR)/tclGetDate.y + sed -e 's/yy/TclDate/g' -e '/^#include <values.h>/d' \ + -e 's/SCCSID/%Z\% %M\% %I\% %E\% %U\%/g' \ + -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \ + -e '/TclDatenewstate:/d' -e '/#pragma/d' \ + <y.tab.c >$(GENERIC_DIR)/tclDate.c + rm y.tab.c + +# The following targets generate the shared libraries in dltest that +# are used for testing; they are included as part of the "tcltest" +# target (via the BUILD_DLTEST variable) if dynamic loading is supported +# on this platform. The ".." environment variable stuff is needed +# because on some platforms tclsh scripts will be executed as part of +# building the shared libraries, and they need to be able to use the +# uninstalled tclsh that is present in this directory. The "make tclsh" +# command is needed for the same reason (must make sure that it exists). + +dltest/pkg5${SHLIB_SUFFIX}: dltest/Makefile + if test ! -f tclsh; then $(MAKE) tclsh; else true; fi + cd dltest; PATH=..:${PATH} TCL_LIBRARY=../../library $(MAKE) + +dltest/Makefile: $(DLTEST_DIR)/configure $(DLTEST_DIR)/Makefile.in tclConfig.sh + if test ! -d dltest; then mkdir dltest; else true; fi + cd dltest; if test -f configure; then ./configure; else \ + $(DLTEST_DIR)/configure; fi + +install: install-binaries install-libraries install-man + +# Note: before running ranlib below, must cd to target directory because +# some ranlibs write to current directory, and this might not always be +# possible (e.g. if installing as root). + +install-binaries: $(TCL_LIB_FILE) tclsh + @for i in $(LIB_INSTALL_DIR) $(BIN_INSTALL_DIR) ; \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + mkdir $$i; \ + chmod 755 $$i; \ + else true; \ + fi; \ + done; + @echo "Installing $(TCL_LIB_FILE)" + @$(INSTALL_DATA) $(TCL_LIB_FILE) $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE) + @(cd $(LIB_INSTALL_DIR); $(RANLIB) $(TCL_LIB_FILE)) + @chmod 555 $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE) + @echo "Installing tclsh" + @$(INSTALL_PROGRAM) tclsh $(BIN_INSTALL_DIR)/tclsh$(VERSION) + @echo "Installing tclConfig.sh" + @$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh + +install-libraries: + @for i in $(INSTALL_ROOT)$(prefix)/lib $(INCLUDE_INSTALL_DIR) \ + $(SCRIPT_INSTALL_DIR); \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + mkdir $$i; \ + chmod 755 $$i; \ + else true; \ + fi; \ + done; + @for i in http2.0 http1.0 opt0.1; \ + do \ + if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ + echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ + mkdir $(SCRIPT_INSTALL_DIR)/$$i; \ + chmod 755 $(SCRIPT_INSTALL_DIR)/$$i; \ + else true; \ + fi; \ + done; + @echo "Installing tcl.h" + @$(INSTALL_DATA) $(GENERIC_DIR)/tcl.h $(INCLUDE_INSTALL_DIR)/tcl.h + @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex $(UNIX_DIR)/tclAppInit.c $(UNIX_DIR)/ldAix; \ + do \ + echo "Installing $$i"; \ + $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \ + done; + @for i in http2.0 http1.0 opt0.1; \ + do \ + for j in $(TOP_DIR)/library/$$i/*.tcl ; \ + do \ + echo "Installing $$j"; \ + $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/$$i; \ + done; \ + done; + +install-man: + @for i in $(MAN_INSTALL_DIR) $(MAN1_INSTALL_DIR) $(MAN3_INSTALL_DIR) $(MANN_INSTALL_DIR) ; \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + mkdir $$i; \ + chmod 755 $$i; \ + else true; \ + fi; \ + done; + @cd $(TOP_DIR)/doc; for i in *.1; \ + do \ + echo "Installing doc/$$i"; \ + rm -f $(MAN1_INSTALL_DIR)/$$i; \ + sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ + $$i > $(MAN1_INSTALL_DIR)/$$i; \ + chmod 444 $(MAN1_INSTALL_DIR)/$$i; \ + done; + $(UNIX_DIR)/mkLinks $(MAN1_INSTALL_DIR) + @cd $(TOP_DIR)/doc; for i in *.3; \ + do \ + echo "Installing doc/$$i"; \ + rm -f $(MAN3_INSTALL_DIR)/$$i; \ + sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ + $$i > $(MAN3_INSTALL_DIR)/$$i; \ + chmod 444 $(MAN3_INSTALL_DIR)/$$i; \ + done; + $(UNIX_DIR)/mkLinks $(MAN3_INSTALL_DIR) + @cd $(TOP_DIR)/doc; for i in *.n; \ + do \ + echo "Installing doc/$$i"; \ + rm -f $(MANN_INSTALL_DIR)/$$i; \ + sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ + $$i > $(MANN_INSTALL_DIR)/$$i; \ + chmod 444 $(MANN_INSTALL_DIR)/$$i; \ + done; + $(UNIX_DIR)/mkLinks $(MANN_INSTALL_DIR) + +Makefile: $(UNIX_DIR)/Makefile.in + $(SHELL) config.status + +clean: + rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \ + errors tclsh tcltest lib.exp + if test -f dltest/Makefile; then cd dltest; $(MAKE) clean; fi + +distclean: clean + rm -rf Makefile config.status config.cache config.log tclConfig.sh \ + SUNWtcl.* prototype + if test -f dltest/Makefile; then cd dltest; $(MAKE) distclean; fi + +depend: + makedepend -- $(DEPEND_SWITCHES) -- $(SRCS) + +bp: $(UNIX_DIR)/bp.c + $(CC) $(CC_SWITCHES) $(UNIX_DIR)/bp.c -o bp + +# Test binaries. The rules for tclTestInit.o and xtTestInit.o are +# complicated because they are compiled from tclAppInit.c. Can't use +# the "-o" option because this doesn't work on some strange compilers +# (e.g. UnixWare). + +tclTestInit.o: $(UNIX_DIR)/tclAppInit.c + @if test -f tclAppInit.o ; then \ + rm -f tclAppInit.sav; \ + mv tclAppInit.o tclAppInit.sav; \ + fi; + $(CC) -c $(CC_SWITCHES) -DTCL_TEST $(UNIX_DIR)/tclAppInit.c + rm -f tclTestInit.o + mv tclAppInit.o tclTestInit.o + @if test -f tclAppInit.sav ; then \ + mv tclAppInit.sav tclAppInit.o; \ + fi; + +xtTestInit.o: $(UNIX_DIR)/tclAppInit.c + @if test -f tclAppInit.o ; then \ + rm -f tclAppInit.sav; \ + mv tclAppInit.o tclAppInit.sav; \ + fi; + $(CC) -c $(CC_SWITCHES) -DTCL_TEST -DTCL_XT_TEST \ + $(UNIX_DIR)/tclAppInit.c + rm -f xtTestInit.o + mv tclAppInit.o xtTestInit.o + @if test -f tclAppInit.sav ; then \ + mv tclAppInit.sav tclAppInit.o; \ + fi; + +# Object files used on all Unix systems: + +panic.o: $(GENERIC_DIR)/panic.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/panic.c + +regexp.o: $(GENERIC_DIR)/regexp.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regexp.c + +tclAppInit.o: $(UNIX_DIR)/tclAppInit.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclAppInit.c + +tclAsync.o: $(GENERIC_DIR)/tclAsync.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAsync.c + +tclBasic.o: $(GENERIC_DIR)/tclBasic.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBasic.c + +tclBinary.o: $(GENERIC_DIR)/tclBinary.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBinary.c + +tclCkalloc.o: $(GENERIC_DIR)/tclCkalloc.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCkalloc.c + +tclClock.o: $(GENERIC_DIR)/tclClock.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclClock.c + +tclCmdAH.o: $(GENERIC_DIR)/tclCmdAH.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdAH.c + +tclCmdIL.o: $(GENERIC_DIR)/tclCmdIL.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdIL.c + +tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdMZ.c + +tclDate.o: $(GENERIC_DIR)/tclDate.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDate.c + +tclCompExpr.o: $(GENERIC_DIR)/tclCompExpr.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompExpr.c + +tclCompile.o: $(GENERIC_DIR)/tclCompile.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompile.c + +tclEnv.o: $(GENERIC_DIR)/tclEnv.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEnv.c + +tclEvent.o: $(GENERIC_DIR)/tclEvent.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEvent.c + +tclExecute.o: $(GENERIC_DIR)/tclExecute.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclExecute.c + +tclFCmd.o: $(GENERIC_DIR)/tclFCmd.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclFCmd.c + +tclFileName.o: $(GENERIC_DIR)/tclFileName.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclFileName.c + +tclGet.o: $(GENERIC_DIR)/tclGet.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclGet.c + +tclHash.o: $(GENERIC_DIR)/tclHash.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclHash.c + +tclHistory.o: $(GENERIC_DIR)/tclHistory.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclHistory.c + +tclIndexObj.o: $(GENERIC_DIR)/tclIndexObj.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIndexObj.c + +tclInterp.o: $(GENERIC_DIR)/tclInterp.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclInterp.c + +tclIO.o: $(GENERIC_DIR)/tclIO.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIO.c + +tclIOCmd.o: $(GENERIC_DIR)/tclIOCmd.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOCmd.c + +tclIOSock.o: $(GENERIC_DIR)/tclIOSock.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOSock.c + +tclIOUtil.o: $(GENERIC_DIR)/tclIOUtil.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOUtil.c + +tclLink.o: $(GENERIC_DIR)/tclLink.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLink.c + +tclListObj.o: $(GENERIC_DIR)/tclListObj.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclListObj.c + +tclObj.o: $(GENERIC_DIR)/tclObj.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c + +tclLoad.o: $(GENERIC_DIR)/tclLoad.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c + +tclLoadAix.o: $(UNIX_DIR)/tclLoadAix.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAix.c + +tclLoadAout.o: $(UNIX_DIR)/tclLoadAout.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAout.c + +tclLoadDl.o: $(UNIX_DIR)/tclLoadDl.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl.c + +tclLoadDl2.o: $(UNIX_DIR)/tclLoadDl2.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl2.c + +tclLoadDld.o: $(UNIX_DIR)/tclLoadDld.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDld.c + +tclLoadNone.o: $(GENERIC_DIR)/tclLoadNone.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoadNone.c + +tclLoadOSF.o: $(UNIX_DIR)/tclLoadOSF.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadOSF.c + +tclLoadShl.o: $(UNIX_DIR)/tclLoadShl.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadShl.c + +tclMain.o: $(GENERIC_DIR)/tclMain.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclMain.c + +tclMtherr.o: $(UNIX_DIR)/tclMtherr.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclMtherr.c + +tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNamesp.c + +tclNotify.o: $(GENERIC_DIR)/tclNotify.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c + +tclParse.o: $(GENERIC_DIR)/tclParse.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclParse.c + +tclPipe.o: $(GENERIC_DIR)/tclPipe.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPipe.c + +tclPkg.o: $(GENERIC_DIR)/tclPkg.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPkg.c + +tclPosixStr.o: $(GENERIC_DIR)/tclPosixStr.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPosixStr.c + +tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPreserve.c + +tclProc.o: $(GENERIC_DIR)/tclProc.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c + +tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c + +tclUtil.o: $(GENERIC_DIR)/tclUtil.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtil.c + +tclVar.o: $(GENERIC_DIR)/tclVar.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclVar.c + +tclTest.o: $(GENERIC_DIR)/tclTest.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTest.c + +tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c + +tclTimer.o: $(GENERIC_DIR)/tclTimer.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTimer.c + +tclUnixChan.o: $(UNIX_DIR)/tclUnixChan.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixChan.c + +tclUnixEvent.o: $(UNIX_DIR)/tclUnixEvent.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixEvent.c + +tclUnixFCmd.o: $(UNIX_DIR)/tclUnixFCmd.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixFCmd.c + +tclUnixFile.o: $(UNIX_DIR)/tclUnixFile.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixFile.c + +tclUnixNotfy.o: $(UNIX_DIR)/tclUnixNotfy.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixNotfy.c + +tclUnixPipe.o: $(UNIX_DIR)/tclUnixPipe.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixPipe.c + +tclUnixSock.o: $(UNIX_DIR)/tclUnixSock.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixSock.c + +tclUnixTest.o: $(UNIX_DIR)/tclUnixTest.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTest.c + +tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c + +tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh + $(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \ + -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \ + $(UNIX_DIR)/tclUnixInit.c + +# compat binaries + +fixstrtod.o: $(COMPAT_DIR)/fixstrtod.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/fixstrtod.c + +getcwd.o: $(COMPAT_DIR)/getcwd.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/getcwd.c + +opendir.o: $(COMPAT_DIR)/opendir.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/opendir.c + +strncasecmp.o: $(COMPAT_DIR)/strncasecmp.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strncasecmp.c + +strstr.o: $(COMPAT_DIR)/strstr.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strstr.c + +strtod.o: $(COMPAT_DIR)/strtod.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strtod.c + +strtol.o: $(COMPAT_DIR)/strtol.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strtol.c + +strtoul.o: $(COMPAT_DIR)/strtoul.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strtoul.c + +tmpnam.o: $(COMPAT_DIR)/tmpnam.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/tmpnam.c + +waitpid.o: $(COMPAT_DIR)/waitpid.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/waitpid.c + +.c.o: + $(CC) -c $(CC_SWITCHES) $< + +# +# Target to check for proper usage of UCHAR macro. +# + +checkuchar: + -egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR + +# +# Target to make sure that only symbols with "Tcl" prefixes are +# exported. +# + +checkexports: $(TCL_LIB_FILE) + -nm -p $(TCL_LIB_FILE) | awk '$$2 ~ /[TDB]/ { print $$3 }' | sort -n | grep -v '^[Tt]cl' + +# +# Target to create a proper Tcl distribution from information in the +# master source directory. DISTDIR must be defined to indicate where +# to put the distribution. +# + +DISTNAME = tcl@TCL_VERSION@@TCL_PATCH_LEVEL@ +ZIPNAME = tcl@TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@@TCL_PATCH_LEVEL@.zip +DISTDIR = /proj/tcl/dist/$(DISTNAME) +$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.in + autoconf $(UNIX_DIR)/configure.in > $(UNIX_DIR)/configure +dist: $(UNIX_DIR)/configure + rm -rf $(DISTDIR) + mkdir $(DISTDIR) + mkdir $(DISTDIR)/unix + cp -p $(UNIX_DIR)/*.c $(UNIX_DIR)/*.h $(DISTDIR)/unix + rm -f $(DISTDIR)/unix/bp.c $(DISTDIR)/unix/tclXtNotify.c + cp $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix + chmod 664 $(DISTDIR)/unix/Makefile.in + cp $(UNIX_DIR)/configure $(UNIX_DIR)/configure.in \ + $(UNIX_DIR)/tclConfig.sh.in $(UNIX_DIR)/install-sh \ + $(UNIX_DIR)/porting.notes $(UNIX_DIR)/porting.old \ + $(UNIX_DIR)/README $(UNIX_DIR)/ldAix \ + $(DISTDIR)/unix + chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in + chmod 775 $(DISTDIR)/unix/ldAix + chmod +x $(DISTDIR)/unix/install-sh + tclsh $(UNIX_DIR)/mkLinks.tcl \ + $(UNIX_DIR)/../doc/*.[13n] > $(DISTDIR)/unix/mkLinks + chmod +x $(DISTDIR)/unix/mkLinks + mkdir $(DISTDIR)/generic + cp -p $(GENERIC_DIR)/*.c $(GENERIC_DIR)/*.h $(DISTDIR)/generic + cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic + cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic + cp -p $(TOP_DIR)/changes $(TOP_DIR)/README $(TOP_DIR)/license.terms \ + $(DISTDIR) + mkdir $(DISTDIR)/library + cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ + $(TOP_DIR)/library/tclIndex $(DISTDIR)/library + for i in http2.0 http1.0 opt0.1; \ + do \ + mkdir $(DISTDIR)/library/$$i ;\ + cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ + done; + mkdir $(DISTDIR)/doc + cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ + $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc + mkdir $(DISTDIR)/compat + cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/compat/*.c \ + $(TOP_DIR)/compat/*.h $(TOP_DIR)/compat/README \ + $(DISTDIR)/compat + mkdir $(DISTDIR)/tests + cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests + cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ + $(TOP_DIR)/tests/all $(TOP_DIR)/tests/remote.tcl \ + $(TOP_DIR)/tests/defs $(DISTDIR)/tests + mkdir $(DISTDIR)/win + cp -p $(TOP_DIR)/win/*.c $(TOP_DIR)/win/*.h $(TOP_DIR)/win/*.rc \ + $(DISTDIR)/win + cp -p $(TOP_DIR)/win/makefile.* $(DISTDIR)/win + cp -p $(TOP_DIR)/win/README $(DISTDIR)/win + cp -p $(TOP_DIR)/win/pkgIndex.tcl $(DISTDIR)/win + cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win + mkdir $(DISTDIR)/mac + sccs edit -s $(TOP_DIR)/mac/tclMacProjects.sit.hqx + cp -p tclMacProjects.sit.hqx $(DISTDIR)/mac + sccs unedit $(TOP_DIR)/mac/tclMacProjects.sit.hqx + rm -f tclMacProjects.sit.hqx + cp -p $(TOP_DIR)/mac/*.c $(TOP_DIR)/mac/*.h $(TOP_DIR)/mac/*.r \ + $(DISTDIR)/mac + cp -p $(TOP_DIR)/mac/porting.notes $(TOP_DIR)/mac/README $(DISTDIR)/mac + cp -p $(TOP_DIR)/mac/*.exp $(TOP_DIR)/mac/*.pch $(DISTDIR)/mac + cp -p $(TOP_DIR)/mac/*.doc $(DISTDIR)/mac + cp -p $(TOP_DIR)/mac/*.html $(DISTDIR)/mac + cp -p $(TOP_DIR)/license.terms $(DISTDIR)/mac + mkdir $(DISTDIR)/unix/dltest + cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ + $(DISTDIR)/unix/dltest + cp -p $(UNIX_DIR)/dltest/configure.in $(UNIX_DIR)/dltest/configure \ + $(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest + +# +# The following target can only be used for non-patch releases. Use +# the "allpatch" target below for patch releases. +# + +alldist: dist + rm -f /proj/tcl/dist/$(DISTNAME).tar.Z \ + /proj/tcl/dist/$(DISTNAME).tar.gz \ + /proj/tcl/dist/$(ZIPNAME) + cd /proj/tcl/dist; tar cf $(DISTNAME).tar $(DISTNAME); \ + gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \ + compress $(DISTNAME).tar; zip -r8 $(ZIPNAME) $(DISTNAME) + +# +# The target below is similar to "alldist" except it works for patch +# releases. It is needed because patch releases are peculiar: the +# patch designation appears in the name of the compressed file +# (e.g. tcl8.0p1.tar.gz) but the extracted source directory doesn't +# include the patch designation (e.g. tcl8.0). +# + +allpatch: dist + rm -f /proj/tcl/dist/$(DISTNAME).tar.Z \ + /proj/tcl/dist/$(DISTNAME).tar.gz \ + /proj/tcl/dist/$(ZIPNAME) + mv /proj/tcl/dist/tcl${VERSION} /proj/tcl/dist/old + mv /proj/tcl/dist/$(DISTNAME) /proj/tcl/dist/tcl${VERSION} + cd /proj/tcl/dist; tar cf $(DISTNAME).tar tcl${VERSION}; \ + gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \ + compress $(DISTNAME).tar; zip -r8 $(ZIPNAME) tcl${VERSION} + mv /proj/tcl/dist/tcl${VERSION} /proj/tcl/dist/$(DISTNAME) + mv /proj/tcl/dist/old /proj/tcl/dist/tcl${VERSION} + +# +# Target to create a Macintosh version of the distribution. This will +# do a normal distribution and then massage the output to prepare it +# for moving to the Mac platform. This requires a few scripts and +# programs found only in the Tcl group's tool workspace. +# + +macdist: dist + rm -f $(DISTDIR)/mac/tclMacProjects.sit.hqx + tclsh $(TOOL_DIR)/man2html.tcl $(DISTDIR)/tmp ../.. tcl$(VERSION) + mv $(DISTDIR)/tmp/tcl$(VERSION) $(DISTDIR)/html + rm -rf $(DISTDIR)/doc + rm -rf $(DISTDIR)/tmp + tclsh $(TOOL_DIR)/cvtEOL.tcl $(DISTDIR) + +# +# Targets to build Solaris package of the distribution for the current +# architecture. To build stream packages for both sun4 and i86pc +# architectures: +# +# On the sun4 machine, execute the following: +# make distclean; ./configure +# make DISTDIR=<distdir> package +# +# Once the build is complete, execute the following on the i86pc +# machine: +# make DISTDIR=<distdir> package-quick +# +# <distdir> is the absolute path to a directory where the build should +# take place. These steps will generate the SUNWtcl.sun4 and +# SUNWtcl.i86pc stream packages. It is important that the packages be +# built in this fashion in order to ensure that the architecture +# independent files are exactly the same, including timestamps, in +# both packages. +# + +package: dist package-config package-common package-binaries package-generate +package-quick: package-config package-binaries package-generate + +# +# Configure for the current architecture in the dist directory. +# +package-config: + mkdir -p $(DISTDIR)/unix/`arch` + cd $(DISTDIR)/unix/`arch`; \ + ../configure --prefix=/opt/SUNWtcl/$(VERSION) \ + --exec_prefix=/opt/SUNWtcl/$(VERSION)/`arch` \ + --enable-shared + mkdir -p $(DISTDIR)/SUNWtcl/$(VERSION) + mkdir -p $(DISTDIR)/SUNWtcl/$(VERSION)/`arch` + +# +# Build and install the architecture independent files in the dist directory. +# + +package-common: + cd $(DISTDIR)/unix/`arch`;\ + $(MAKE); \ + $(MAKE) prefix=$(DISTDIR)/SUNWtcl/$(VERSION) \ + exec_prefix=$(DISTDIR)/SUNWtcl/$(VERSION)/`arch` \ + install-libraries install-man + mkdir -p $(DISTDIR)/SUNWtcl/$(VERSION)/bin + sed -e "s/TCLVERSION/$(VERSION)/g" < $(UNIX_DIR)/tclsh.sh \ + > $(DISTDIR)/SUNWtcl/$(VERSION)/bin/tclsh$(VERSION) + chmod 755 $(DISTDIR)/SUNWtcl/$(VERSION)/bin/tclsh$(VERSION) + +# +# Build and install the architecture specific files in the dist directory. +# + +package-binaries: + cd $(DISTDIR)/unix/`arch`; \ + $(MAKE); \ + $(MAKE) install-binaries prefix=$(DISTDIR)/SUNWtcl/$(VERSION) \ + exec_prefix=$(DISTDIR)/SUNWtcl/$(VERSION)/`arch` + +# +# Generate a package from the installed files in the dist directory for the +# current architecture. +# + +package-generate: + pkgproto $(DISTDIR)/SUNWtcl/$(VERSION)/bin=bin \ + $(DISTDIR)/SUNWtcl/$(VERSION)/include=include \ + $(DISTDIR)/SUNWtcl/$(VERSION)/lib=lib \ + $(DISTDIR)/SUNWtcl/$(VERSION)/man=man \ + $(DISTDIR)/SUNWtcl/$(VERSION)/`arch`=`arch` \ + | tclsh $(UNIX_DIR)/mkProto.tcl \ + $(VERSION) $(UNIX_DIR) > prototype + pkgmk -o -d . -f prototype -a `arch` + pkgtrans -s . SUNWtcl.`arch` SUNWtcl + rm -rf SUNWtcl + +# DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/unix/README b/unix/README new file mode 100644 index 0000000..96c79c1 --- /dev/null +++ b/unix/README @@ -0,0 +1,110 @@ +This is the directory where you configure, compile, test, and install +UNIX versions of Tcl. This directory also contains source files for Tcl +that are specific to UNIX. Some of the files in this directory are +used on the PC or Mac platform too, but they all depend on UNIX +(POSIX/ANSI C) interfaces and some of them only make sense under UNIX. + +The rest of this file contains instructions on how to do this. The +release should compile and run either "out of the box" or with trivial +changes on any UNIX-like system that approximates POSIX, BSD, or System +V. We know that it runs on workstations from Sun, H-P, DEC, IBM, and +SGI, as well as PCs running Linux, BSDI, and SCO UNIX. To compile for +a PC running Windows, see the README file in the directory ../win. To +compile for a Macintosh, see the README file in the directory ../mac. + +SCCS: @(#) README 1.15 96/12/19 14:02:23 + +How To Compile And Install Tcl: +------------------------------- + +(a) Check for patches as described in ../README. + +(b) If you have already compiled Tcl once in this directory and are now + preparing to compile again in the same directory but for a different + platform, or if you have applied patches, type "make distclean" to + discard all the configuration information computed previously. + +(c) Type "./configure". This runs a configuration script created by GNU + autoconf, which configures Tcl for your system and creates a + Makefile. The configure script allows you to customize the Tcl + configuration for your site; for details on how you can do this, + type "./configure -help" or refer to the autoconf documentation (not + included here). Tcl's "configure" supports the following special + switches in addition to the standard ones: + --enable-gcc If this switch is set, Tcl will configure + itself to use gcc if it is available on your + system. Note: it is not safe to modify the + Makefile to use gcc after configure is run; + if you do this, then information related to + dynamic linking will be incorrect. + --disable-load If this switch is specified then Tcl will + configure itself not to allow dynamic loading, + even if your system appears to support it. + Normally you can leave this switch out and + Tcl will build itself for dynamic loading + if your system supports it. + --enable-shared If this switch is specified, Tcl will compile + itself as a shared library if it can figure + out how to do that on this platform. + Note: be sure to use only absolute path names (those starting with "/") + in the --prefix and --exec_prefix options. + +(d) Type "make". This will create a library archive called "libtcl.a" + or "libtcl.so" and an interpreter application called "tclsh" that + allows you to type Tcl commands interactively or execute script files. + +(e) If the make fails then you'll have to personalize the Makefile + for your site or possibly modify the distribution in other ways. + First check the file "porting.notes" to see if there are hints + for compiling on your system. Then look at the porting Web page + described later in this file. If you need to modify Makefile, there + are comments at the beginning of it that describe the things you + might want to change and how to change them. + +(f) Type "make install" to install Tcl binaries and script files in + standard places. You'll need write permission on the installation + directories to do this. The installation directories are + determined by the "configure" script and may be specified with + the --prefix and --exec_prefix options to "configure". See the + Makefile for information on what directories were chosen; you + can override these choices by modifying the "prefix" and + "exec_prefix" variables in the Makefile. + +(g) At this point you can play with Tcl by invoking the "tclsh" + program and typing Tcl commands. However, if you haven't installed + Tcl then you'll first need to set your TCL_LIBRARY variable to + hold the full path name of the "library" subdirectory. Note that + the installed versions of tclsh, libtcl.a, and libtcl.so have a + version number in their names, such as "tclsh8.0" or "libtcl8.0.so"; + to use the installed versions, either specify the version number + or create a symbolic link (e.g. from "tclsh" to "tclsh8.0"). + +If you have trouble compiling Tcl, read through the file" porting.notes". +It contains information that people have provided about changes they had +to make to compile Tcl in various environments. Or, check out the +following Web URL: + http://www.sunlabs.com/cgi-bin/tcl/info.8.0 +This is an on-line database of porting information. We make no guarantees +that this information is accurate, complete, or up-to-date, but you may +find it useful. If you get Tcl running on a new configuration, we would +be happy to receive new information to add to "porting.notes". You can +also make a new entry into the on-line Web database. We're also interested +in hearing how to change the configuration setup so that Tcl compiles out +of the box on more platforms. + +Test suite +---------- + +There is a relatively complete test suite for all of the Tcl core in +the subdirectory "tests". To use it just type "make test" in this +directory. You should then see a printout of the test files processed. +If any errors occur, you'll see a much more substantial printout for +each error. See the README file in the "tests" directory for more +information on the test suite. Note: don't run the tests as superuser: +this will cause several of them to fail. + +The Tcl test suite is very sensitive to proper implementation of +ANSI C library procedures such as sprintf and sscanf. If the test +suite generates errors, most likely they are due to non-conformance +of your system's ANSI C library; such problems are unlikely to +affect any real applications so it's probably safe to ignore them. diff --git a/unix/configure.in b/unix/configure.in new file mode 100644 index 0000000..ee36dc4 --- /dev/null +++ b/unix/configure.in @@ -0,0 +1,1232 @@ +dnl This file is an input file used by the GNU "autoconf" program to +dnl generate the file "configure", which is run during Tcl installation +dnl to configure the system for the local environment. +AC_INIT(../generic/tcl.h) +# SCCS: @(#) configure.in 1.144 97/11/20 12:39:44 + +TCL_VERSION=8.0 +TCL_MAJOR_VERSION=8 +TCL_MINOR_VERSION=0 +TCL_PATCH_LEVEL="p2" +VERSION=${TCL_VERSION} + +if test "${prefix}" = "NONE"; then + prefix=/usr/local +fi +if test "${exec_prefix}" = "NONE"; then + exec_prefix=$prefix +fi +TCL_SRC_DIR=`cd $srcdir/..; pwd` + +AC_PROG_RANLIB +AC_ARG_ENABLE(gcc, [ --enable-gcc allow use of gcc if available], + [tcl_ok=$enableval], [tcl_ok=no]) +if test "$tcl_ok" = "yes"; then + AC_PROG_CC +else + CC=${CC-cc} +AC_SUBST(CC) +fi +AC_C_CROSS + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX library procedures, or +# set flags so Tcl uses alternate procedures. +#-------------------------------------------------------------------- + +# Check if Posix compliant getcwd exists, if not we'll use getwd. +AC_CHECK_FUNCS(getcwd, , AC_DEFINE(USEGETWD)) +# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really +# define USEGETWD even if the posix getcwd exists. Add a test ? + +AC_REPLACE_FUNCS(opendir strstr) + +AC_REPLACE_FUNCS(strtol tmpnam waitpid) +AC_CHECK_FUNC(strerror, , AC_DEFINE(NO_STRERROR)) +AC_CHECK_FUNC(getwd, , AC_DEFINE(NO_GETWD)) +AC_CHECK_FUNC(wait3, , AC_DEFINE(NO_WAIT3)) +AC_CHECK_FUNC(uname, , AC_DEFINE(NO_UNAME)) + +#-------------------------------------------------------------------- +# On a few very rare systems, all of the libm.a stuff is +# already in libc.a. Set compiler flags accordingly. +# Also, Linux requires the "ieee" library for math to work +# right (and it must appear before "-lm"). +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(sin, MATH_LIBS="", MATH_LIBS="-lm") +AC_CHECK_LIB(ieee, main, [MATH_LIBS="-lieee $MATH_LIBS"]) + +#-------------------------------------------------------------------- +# On AIX systems, libbsd.a has to be linked in to support +# non-blocking file IO. This library has to be linked in after +# the MATH_LIBS or it breaks the pow() function. The way to +# insure proper sequencing, is to add it to the tail of MATH_LIBS. +# This library also supplies gettimeofday. +#-------------------------------------------------------------------- +libbsd=no +if test "`uname -s`" = "AIX" ; then + AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes) + if test $libbsd = yes; then + MATH_LIBS="$MATH_LIBS -lbsd" + fi +fi + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX header files. Special +# notes: +# - stdlib.h doesn't define strtol, strtoul, or +# strtod insome versions of SunOS +# - some versions of string.h don't declare procedures such +# as strstr +#-------------------------------------------------------------------- + +AC_MSG_CHECKING(dirent.h) +AC_TRY_LINK([#include <sys/types.h> +#include <dirent.h>], [ +#ifndef _POSIX_SOURCE +# ifdef __Lynx__ + /* + * Generate compilation error to make the test fail: Lynx headers + * are only valid if really in the POSIX environment. + */ + + missing_procedure(); +# endif +#endif +DIR *d; +struct dirent *entryPtr; +char *p; +d = opendir("foobar"); +entryPtr = readdir(d); +p = entryPtr->d_name; +closedir(d); +], tcl_ok=yes, tcl_ok=no) +if test $tcl_ok = no; then + AC_DEFINE(NO_DIRENT_H) +fi +AC_MSG_RESULT($tcl_ok) +AC_CHECK_HEADER(errno.h, , AC_DEFINE(NO_ERRNO_H)) +AC_CHECK_HEADER(float.h, , AC_DEFINE(NO_FLOAT_H)) +AC_CHECK_HEADER(values.h, , AC_DEFINE(NO_VALUES_H)) +AC_CHECK_HEADER(limits.h, , AC_DEFINE(NO_LIMITS_H)) +AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0) +AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0) +AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0) +AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0) +if test $tcl_ok = 0; then + AC_DEFINE(NO_STDLIB_H) +fi +AC_CHECK_HEADER(string.h, tcl_ok=1, tcl_ok=0) +AC_EGREP_HEADER(strstr, string.h, , tcl_ok=0) +AC_EGREP_HEADER(strerror, string.h, , tcl_ok=0) +if test $tcl_ok = 0; then + AC_DEFINE(NO_STRING_H) +fi +AC_CHECK_HEADER(sys/wait.h, , AC_DEFINE(NO_SYS_WAIT_H)) +AC_CHECK_HEADER(dlfcn.h, , AC_DEFINE(NO_DLFCN_H)) +AC_HAVE_HEADERS(unistd.h) + +#--------------------------------------------------------------------------- +# Determine which interface to use to talk to the serial port. +# Note that #include lines must begin in leftmost column for +# some compilers to recognize them as preprocessor directives. +#--------------------------------------------------------------------------- + +AC_MSG_CHECKING([termios vs. termio vs. sgtty]) +AC_TRY_RUN([ +#include <termios.h> + +main() +{ + struct termios t; + if (tcgetattr(0, &t) == 0) { + cfsetospeed(&t, 0); + t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB; + return 0; + } + return 1; +}], tk_ok=termios, tk_ok=no, tk_ok=no) +if test $tk_ok = termios; then + AC_DEFINE(USE_TERMIOS) +else +AC_TRY_RUN([ +#include <termio.h> + +main() +{ + struct termio t; + if (ioctl(0, TCGETA, &t) == 0) { + t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB; + return 0; + } + return 1; +}], tk_ok=termio, tk_ok=no, tk_ok=no) +if test $tk_ok = termio; then + AC_DEFINE(USE_TERMIO) +else +AC_TRY_RUN([ +#include <sgtty.h> + +main() +{ + struct sgttyb t; + if (ioctl(0, TIOCGETP, &t) == 0) { + t.sg_ospeed = 0; + t.sg_flags |= ODDP | EVENP | RAW; + return 0; + } + return 1; +}], tk_ok=sgtty, tk_ok=none, tk_ok=none) +if test $tk_ok = sgtty; then + AC_DEFINE(USE_SGTTY) +fi +fi +fi +AC_MSG_RESULT($tk_ok) + +#-------------------------------------------------------------------- +# Include sys/select.h if it exists and if it supplies things +# that appear to be useful and aren't already in sys/types.h. +# This appears to be true only on the RS/6000 under AIX. Some +# systems like OSF/1 have a sys/select.h that's of no use, and +# other systems like SCO UNIX have a sys/select.h that's +# pernicious. If "fd_set" isn't defined anywhere then set a +# special flag. +#-------------------------------------------------------------------- + +AC_MSG_CHECKING([fd_set and sys/select]) +AC_TRY_COMPILE([#include <sys/types.h>], + [fd_set readMask, writeMask;], tk_ok=yes, tk_ok=no) +if test $tk_ok = no; then + AC_HEADER_EGREP(fd_mask, sys/select.h, tk_ok=yes) + if test $tk_ok = yes; then + AC_DEFINE(HAVE_SYS_SELECT_H) + fi +fi +AC_MSG_RESULT($tk_ok) +if test $tk_ok = no; then + AC_DEFINE(NO_FD_SET) +fi + +#------------------------------------------------------------------------------ +# Find out all about time handling differences. +#------------------------------------------------------------------------------ + +AC_CHECK_HEADERS(sys/time.h) +AC_HEADER_TIME +AC_STRUCT_TIMEZONE + +AC_MSG_CHECKING([tm_tzadj in struct tm]) +AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_tzadj;], + [AC_DEFINE(HAVE_TM_TZADJ) + AC_MSG_RESULT(yes)], + AC_MSG_RESULT(no)) + +AC_MSG_CHECKING([tm_gmtoff in struct tm]) +AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_gmtoff;], + [AC_DEFINE(HAVE_TM_GMTOFF) + AC_MSG_RESULT(yes)], + AC_MSG_RESULT(no)) + +# +# Its important to include time.h in this check, as some systems (like convex) +# have timezone functions, etc. +# +have_timezone=no +AC_MSG_CHECKING([long timezone variable]) +AC_TRY_COMPILE([#include <time.h>], + [extern long timezone; + timezone += 1; + exit (0);], + [have_timezone=yes + AC_DEFINE(HAVE_TIMEZONE_VAR) + AC_MSG_RESULT(yes)], + AC_MSG_RESULT(no)) + +# +# On some systems (eg IRIX 6.2), timezone is a time_t and not a long. +# +if test "$have_timezone" = no; then + AC_MSG_CHECKING([time_t timezone variable]) + AC_TRY_COMPILE([#include <time.h>], + [extern time_t timezone; + timezone += 1; + exit (0);], + [AC_DEFINE(HAVE_TIMEZONE_VAR) + AC_MSG_RESULT(yes)], + AC_MSG_RESULT(no)) +fi + +# +# AIX does not have a timezone field in struct tm. When the AIX bsd +# library is used, the timezone global and the gettimeofday methods are +# to be avoided for timezone deduction instead, we deduce the timezone +# by comparing the localtime result on a known GMT value. +# +if test $libbsd = yes; then + AC_DEFINE(USE_DELTA_FOR_TZ) +fi + +#-------------------------------------------------------------------- +# Some systems (e.g., IRIX 4.0.5) lack the st_blksize field +# in struct stat. +#-------------------------------------------------------------------- +AC_STRUCT_ST_BLKSIZE + +#-------------------------------------------------------------------- +# On some systems strstr is broken: it returns a pointer even +# even if the original string is empty. +#-------------------------------------------------------------------- + +AC_MSG_CHECKING([proper strstr implementation]) +AC_TRY_RUN([ +extern int strstr(); +int main() +{ + exit(strstr("\0test", "test") ? 1 : 0); +} +], tcl_ok=yes, tcl_ok=no, tcl_ok=no) +if test $tcl_ok = yes; then + AC_MSG_RESULT(yes) +else + AC_MSG_RESULT([broken, using substitute]) + LIBOBJS="$LIBOBJS strstr.o" +fi + +#-------------------------------------------------------------------- +# Check for strtoul function. This is tricky because under some +# versions of AIX strtoul returns an incorrect terminator +# pointer for the string "0". +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(strtoul, tcl_ok=1, tcl_ok=0) +AC_TRY_RUN([ +extern int strtoul(); +int main() +{ + char *string = "0"; + char *term; + int value; + value = strtoul(string, &term, 0); + if ((value != 0) || (term != (string+1))) { + exit(1); + } + exit(0); +}], , tcl_ok=0, tcl_ok=0) +if test "$tcl_ok" = 0; then + test -n "$verbose" && echo " Adding strtoul.o." + LIBOBJS="$LIBOBJS strtoul.o" +fi + +#-------------------------------------------------------------------- +# Check for the strtod function. This is tricky because in some +# versions of Linux strtod mis-parses strings starting with "+". +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(strtod, tcl_ok=1, tcl_ok=0) +AC_TRY_RUN([ +extern double strtod(); +int main() +{ + char *string = " +69"; + char *term; + double value; + value = strtod(string, &term); + if ((value != 69) || (term != (string+4))) { + exit(1); + } + exit(0); +}], , tcl_ok=0, tcl_ok=0) +if test "$tcl_ok" = 0; then + test -n "$verbose" && echo " Adding strtod.o." + LIBOBJS="$LIBOBJS strtod.o" +fi + +#-------------------------------------------------------------------- +# Under Solaris 2.4, strtod returns the wrong value for the +# terminating character under some conditions. Check for this +# and if the problem exists use a substitute procedure +# "fixstrtod" that corrects the error. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0) +if test "$tcl_strtod" = 1; then + AC_MSG_CHECKING([for Solaris strtod bug]) + AC_TRY_RUN([ +extern double strtod(); +int main() +{ + char *string = "NaN"; + char *term; + strtod(string, &term); + if ((term != string) && (term[-1] == 0)) { + exit(1); + } + exit(0); +}], tcl_ok=1, tcl_ok=0, tcl_ok=0) + if test $tcl_ok = 1; then + AC_MSG_RESULT(ok) + else + AC_MSG_RESULT(buggy) + LIBOBJS="$LIBOBJS fixstrtod.o" + AC_DEFINE(strtod, fixstrtod) + fi +fi + +#-------------------------------------------------------------------- +# Check for various typedefs and provide substitutes if +# they don't exist. +#-------------------------------------------------------------------- + +AC_TYPE_MODE_T +AC_TYPE_PID_T +AC_TYPE_SIZE_T +AC_TYPE_UID_T + +#-------------------------------------------------------------------- +# If a system doesn't have an opendir function (man, that's old!) +# then we have to supply a different version of dirent.h which +# is compatible with the substitute version of opendir that's +# provided. This version only works with V7-style directories. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(opendir, , AC_DEFINE(USE_DIRENT2_H)) + +#-------------------------------------------------------------------- +# The check below checks whether <sys/wait.h> defines the type +# "union wait" correctly. It's needed because of weirdness in +# HP-UX where "union wait" is defined in both the BSD and SYS-V +# environments. Checking the usability of WIFEXITED seems to do +# the trick. +#-------------------------------------------------------------------- + +AC_MSG_CHECKING([union wait]) +AC_TRY_LINK([#include <sys/types.h> +#include <sys/wait.h>], [ +union wait x; +WIFEXITED(x); /* Generates compiler error if WIFEXITED + * uses an int. */ +], tcl_ok=yes, tcl_ok=no) +AC_MSG_RESULT($tcl_ok) +if test $tcl_ok = no; then + AC_DEFINE(NO_UNION_WAIT) +fi + +#-------------------------------------------------------------------- +# Check to see whether the system supports the matherr function +# and its associated type "struct exception". +#-------------------------------------------------------------------- + +AC_MSG_CHECKING([matherr support]) +AC_TRY_COMPILE([#include <math.h>], [ +struct exception x; +x.type = DOMAIN; +x.type = SING; +], tcl_ok=yes, tcl_ok=no) +AC_MSG_RESULT($tcl_ok) +if test $tcl_ok = yes; then + AC_DEFINE(NEED_MATHERR) +fi + +#-------------------------------------------------------------------- +# Check to see whether the system provides a vfork kernel call. +# If not, then use fork instead. Also, check for a problem with +# vforks and signals that can cause core dumps if a vforked child +# resets a signal handler. If the problem exists, then use fork +# instead of vfork. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(vfork, tcl_ok=1, tcl_ok=0) +if test "$tcl_ok" = 1; then + AC_MSG_CHECKING([vfork/signal bug]); + AC_TRY_RUN([ +#include <stdio.h> +#include <signal.h> +#include <sys/wait.h> +int gotSignal = 0; +sigProc(sig) + int sig; +{ + gotSignal = 1; +} +main() +{ + int pid, sts; + (void) signal(SIGCHLD, sigProc); + pid = vfork(); + if (pid < 0) { + exit(1); + } else if (pid == 0) { + (void) signal(SIGCHLD, SIG_DFL); + _exit(0); + } else { + (void) wait(&sts); + } + exit((gotSignal) ? 0 : 1); +}], tcl_ok=1, tcl_ok=0, tcl_ok=0) + if test "$tcl_ok" = 1; then + AC_MSG_RESULT(ok) + else + AC_MSG_RESULT([buggy, using fork instead]) + fi +fi +rm -f core +if test "$tcl_ok" = 0; then + AC_DEFINE(vfork, fork) +fi + +#-------------------------------------------------------------------- +# Check whether there is an strncasecmp function on this system. +# This is a bit tricky because under SCO it's in -lsocket and +# under Sequent Dynix it's in -linet. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(strncasecmp, tcl_ok=1, tcl_ok=0) +if test "$tcl_ok" = 0; then + AC_CHECK_LIB(socket, strncasecmp, tcl_ok=1, tcl_ok=0) +fi +if test "$tcl_ok" = 0; then + AC_CHECK_LIB(inet, strncasecmp, tcl_ok=1, tcl_ok=0) +fi +if test "$tcl_ok" = 0; then + LIBOBJS="$LIBOBJS strncasecmp.o" +fi + +#-------------------------------------------------------------------- +# The code below deals with several issues related to gettimeofday: +# 1. Some systems don't provide a gettimeofday function at all +# (set NO_GETTOD if this is the case). +# 2. SGI systems don't use the BSD form of the gettimeofday function, +# but they have a BSDgettimeofday function that can be used instead. +# 3. See if gettimeofday is declared in the <sys/time.h> header file. +# if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can +# declare it. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(BSDgettimeofday, AC_DEFINE(HAVE_BSDGETTIMEOFDAY), + AC_CHECK_FUNC(gettimeofday, , AC_DEFINE(NO_GETTOD))) +AC_MSG_CHECKING([for gettimeofday declaration]) +AC_EGREP_HEADER(gettimeofday, sys/time.h, AC_MSG_RESULT(present), [ + AC_MSG_RESULT(missing) + AC_DEFINE(GETTOD_NOT_DECLARED) +]) + +#-------------------------------------------------------------------- +# Interactive UNIX requires -linet instead of -lsocket, plus it +# needs net/errno.h to define the socket-related error codes. +#-------------------------------------------------------------------- + +AC_CHECK_LIB(inet, main, [LIBS="$LIBS -linet"]) +AC_CHECK_HEADER(net/errno.h, AC_DEFINE(HAVE_NET_ERRNO_H)) + +#-------------------------------------------------------------------- +# The following code checks to see whether it is possible to get +# signed chars on this platform. This is needed in order to +# properly generate sign-extended ints from character values. +#-------------------------------------------------------------------- + +AC_C_CHAR_UNSIGNED +AC_MSG_CHECKING([signed char declarations]) +AC_TRY_COMPILE(, [ +signed char *p; +p = 0; +], tcl_ok=yes, tcl_ok=no) +AC_MSG_RESULT($tcl_ok) +if test $tcl_ok = yes; then + AC_DEFINE(HAVE_SIGNED_CHAR) +fi + +#-------------------------------------------------------------------- +# Check for the existence of the -lsocket and -lnsl libraries. +# The order here is important, so that they end up in the right +# order in the command line generated by make. Here are some +# special considerations: +# 1. Use "connect" and "accept" to check for -lsocket, and +# "gethostbyname" to check for -lnsl. +# 2. Use each function name only once: can't redo a check because +# autoconf caches the results of the last check and won't redo it. +# 3. Use -lnsl and -lsocket only if they supply procedures that +# aren't already present in the normal libraries. This is because +# IRIX 5.2 has libraries, but they aren't needed and they're +# bogus: they goof up name resolution if used. +# 4. On some SVR4 systems, can't use -lsocket without -lnsl too. +# To get around this problem, check for both libraries together +# if -lsocket doesn't work by itself. +#-------------------------------------------------------------------- + +tcl_checkBoth=0 +AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) +if test "$tcl_checkSocket" = 1; then + AC_CHECK_LIB(socket, main, LIBS="$LIBS -lsocket", tcl_checkBoth=1) +fi +if test "$tcl_checkBoth" = 1; then + tk_oldLibs=$LIBS + LIBS="$LIBS -lsocket -lnsl" + AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs]) +fi +AC_CHECK_FUNC(gethostbyname, , AC_CHECK_LIB(nsl, main, [LIBS="$LIBS -lnsl"])) + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# dynamic loading and shared libraries: +# +# DL_OBJS - Name of the object file that implements dynamic +# loading for Tcl on this system. +# DL_LIBS - Library file(s) to include in tclsh and other base +# applications in order for the "load" command to work. +# LD_FLAGS - Flags to pass to the compiler when linking object +# files into an executable application binary such +# as tclsh. +# LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib", +# that tell the run-time dynamic linker where to look +# for shared libraries such as libtcl.so. Depends on +# the variable LIB_RUNTIME_DIR in the Makefile. +# MAKE_LIB - Command to execute to build the Tcl library; +# differs depending on whether or not Tcl is being +# compiled as a shared library. +# SHLIB_CFLAGS - Flags to pass to cc when compiling the components +# of a shared library (may request position-independent +# code, among other things). +# SHLIB_LD - Base command to use for combining object files +# into a shared library. +# SHLIB_LD_LIBS - Dependent libraries for the linker to scan when +# creating shared libraries. This symbol typically +# goes at the end of the "ld" commands that build +# shared libraries. The value of the symbol is +# "${LIBS}" if all of the dependent libraries should +# be specified when creating a shared library. If +# dependent libraries should not be specified (as on +# SunOS 4.x, where they cause the link to fail, or in +# general if Tcl and Tk aren't themselves shared +# libraries), then this symbol has an empty string +# as its value. +# SHLIB_SUFFIX - Suffix to use for the names of dynamically loadable +# extensions. An empty string means we don't know how +# to use shared libraries on this platform. +# TCL_LIB_FILE - Name of the file that contains the Tcl library, such +# as libtcl7.8.so or libtcl7.8.a. +# TCL_LIB_SUFFIX -Specifies everything that comes after the "libtcl" +# in the shared library name, using the $VERSION variable +# to put the version in the right place. This is used +# by platforms that need non-standard library names. +# Examples: ${VERSION}.so.1.1 on NetBSD, since it needs +# to have a version after the .so, and ${VERSION}.a +# on AIX, since the Tcl shared library needs to have +# a .a extension whereas shared objects for loadable +# extensions have a .so extension. Defaults to +# ${VERSION}${SHLIB_SUFFIX}. +#-------------------------------------------------------------------- + +# Step 1: set the variable "system" to hold the name and version number +# for the system. This can usually be done via the "uname" command, but +# there are a few systems, like Next, where this doesn't work. + +AC_MSG_CHECKING([system version (for dynamic loading)]) +if test -f /usr/lib/NextStep/software_version; then + system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` +else + system=`uname -s`-`uname -r` + if test "$?" -ne 0 ; then + AC_MSG_RESULT([unknown (can't find uname command)]) + system=unknown + else + # Special check for weird MP-RAS system (uname returns weird + # results, and the version is kept in special file). + + if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then + system=MP-RAS-`awk '{print $3}' /etc/.relid'` + fi + if test "`uname -s`" = "AIX" ; then + system=AIX-`uname -v`.`uname -r` + fi + AC_MSG_RESULT($system) + fi +fi + +# Step 2: check for existence of -ldl library. This is needed because +# Linux can use either -ldl or -ldld for dynamic loading. + +AC_CHECK_LIB(dl, dlopen, have_dl=yes, have_dl=no) + +# Step 3: set configuration options based on system name and version. + +fullSrcDir=`cd $srcdir; pwd` +TCL_SHARED_LIB_SUFFIX="" +TCL_UNSHARED_LIB_SUFFIX="" +TCL_LIB_VERSIONS_OK=ok +case $system in + AIX-4.[[2-9]]) + SHLIB_CFLAGS="" + SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + AIX=yes + TCL_SHARED_LIB_SUFFIX='${VERSION}.a' + ;; + AIX-*) + SHLIB_CFLAGS="" + SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o tclLoadAix.o" + DL_LIBS="-lld" + LD_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + TCL_SHARED_LIB_SUFFIX='${VERSION}.a' + ;; + BSD/OS-2.1*|BSD/OS-3*) + SHLIB_CFLAGS="" + SHLIB_LD="shlicc -r" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + dgux*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) + AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) + if test "$tcl_ok" = yes; then + SHLIB_CFLAGS="+z" + SHLIB_LD="ld -b" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".sl" + DL_OBJS="tclLoadShl.o" + DL_LIBS="-ldld" + LD_FLAGS="-Wl,-E" + LD_SEARCH_FLAGS='-Wl,+b,${LIB_RUNTIME_DIR}:.' + fi + ;; + IRIX-4.*) + SHLIB_CFLAGS="-G 0" + SHLIB_SUFFIX=".a" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS='${LIBS}' + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="-Wl,-D,08000000" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + TCL_SHARED_LIB_SUFFIX='${VERSION}.a' + ;; + IRIX-5.*|IRIX-6.*) + SHLIB_CFLAGS="" + SHLIB_LD="ld -shared -rdata_shared" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + ;; + IRIX64-6.*) + SHLIB_CFLAGS="" + SHLIB_LD="ld -32 -shared -rdata_shared -rpath /usr/local/lib" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + ;; + Linux*) + SHLIB_CFLAGS="-fPIC" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + if test "$have_dl" = yes; then + SHLIB_LD="${CC} -shared" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="-rdynamic" + LD_SEARCH_FLAGS="" + else + AC_CHECK_HEADER(dld.h, [ + SHLIB_LD="ld -shared" + DL_OBJS="tclLoadDld.o" + DL_LIBS="-ldld" + LD_FLAGS="" + LD_SEARCH_FLAGS=""]) + fi + ;; + MP-RAS-02*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + MP-RAS-*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="-Wl,-Bexport" + LD_SEARCH_FLAGS="" + ;; + NetBSD-*|FreeBSD-*|OpenBSD-*) + # Not available on all versions: check for include file. + AC_CHECK_HEADER(dlfcn.h, [ + SHLIB_CFLAGS="-fpic" + SHLIB_LD="ld -Bshareable -x" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + TCL_SHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.so.1.0' + ], [ + SHLIB_CFLAGS="" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".a" + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + TCL_SHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.a' + ]) + + # FreeBSD doesn't handle version numbers with dots. + + TCL_UNSHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.a' + TCL_LIB_VERSIONS_OK=nodots + ;; + NEXTSTEP-*) + SHLIB_CFLAGS="" + SHLIB_LD="cc -nostdlib -r" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadNext.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + OSF1-1.0|OSF1-1.1|OSF1-1.2) + # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1 + SHLIB_CFLAGS="" + # Hack: make package name same as library name + SHLIB_LD='ld -R -export $@:' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadOSF.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + OSF1-1.*) + # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2 + SHLIB_CFLAGS="-fpic" + SHLIB_LD="ld -shared" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + OSF1-V*) + # Digital OSF/1 + SHLIB_CFLAGS="" + SHLIB_LD='ld -shared -expect_unresolved "*"' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + ;; + RISCos-*) + SHLIB_CFLAGS="-G 0" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".a" + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="-Wl,-D,08000000" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + ;; + SCO_SV-3.2*) + # Note, dlopen is available only on SCO 3.2.5 and greater. However, + # this test works, since "uname -s" was non-standard in 3.2.4 and + # below. + SHLIB_CFLAGS="-Kpic -belf" + SHLIB_LD="ld -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="-belf -Wl,-Bexport" + LD_SEARCH_FLAGS="" + ;; + SINIX*5.4*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + SunOS-4*) + SHLIB_CFLAGS="-PIC" + SHLIB_LD="ld" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + + # SunOS can't handle version numbers with dots in them in library + # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it + # requires an extra version number at the end of .so file names. + # So, the library has to have a name like libtcl75.so.1.0 + + TCL_SHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.so.1.0' + TCL_UNSHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.a' + TCL_LIB_VERSIONS_OK=nodots + ;; + SunOS-5*) + SHLIB_CFLAGS="-KPIC" + SHLIB_LD="/usr/ccs/bin/ld -G -z text" + + # Note: need the LIBS below, otherwise Tk won't find Tcl's + # symbols when dynamically loaded into tclsh. + + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' + ;; + ULTRIX-4.*) + SHLIB_CFLAGS="-G 0" + SHLIB_SUFFIX=".a" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS='${LIBS}' + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="-Wl,-D,08000000" + LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + ;; + UNIX_SV*) + SHLIB_CFLAGS="-KPIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers + # that don't grok the -Bexport option. Test that it does. + hold_ldflags=$LDFLAGS + AC_MSG_CHECKING(for ld accepts -Bexport flag) + LDFLAGS="${LDFLAGS} -Wl,-Bexport" + AC_TRY_LINK(, [int i;], found=yes, found=no) + LDFLAGS=$hold_ldflags + AC_MSG_RESULT($found) + if test $found = yes; then + LD_FLAGS="-Wl,-Bexport" + else + LD_FLAGS="" + fi + LD_SEARCH_FLAGS="" + ;; +esac + +# Step 4: If pseudo-static linking is in use (see K. B. Kenny, "Dynamic +# Loading for Tcl -- What Became of It?". Proc. 2nd Tcl/Tk Workshop, +# New Orleans, LA, Computerized Processes Unlimited, 1994), then we need +# to determine which of several header files defines the a.out file +# format (a.out.h, sys/exec.h, or sys/exec_aout.h). At present, we +# support only a file format that is more or less version-7-compatible. +# In particular, +# - a.out files must begin with `struct exec'. +# - the N_TXTOFF on the `struct exec' must compute the seek address +# of the text segment +# - The `struct exec' must contain a_magic, a_text, a_data, a_bss +# and a_entry fields. +# The following compilation should succeed if and only if either sys/exec.h +# or a.out.h is usable for the purpose. +# +# Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the +# `struct exec' includes a second header that contains information that +# duplicates the v7 fields that are needed. + +if test "x$DL_OBJS" = "xtclLoadAout.o" ; then + AC_MSG_CHECKING(sys/exec.h) + AC_TRY_COMPILE([#include <sys/exec.h>],[ + struct exec foo; + unsigned long seek; + int flag; +#if defined(__mips) || defined(mips) + seek = N_TXTOFF (foo.ex_f, foo.ex_o); +#else + seek = N_TXTOFF (foo); +#endif + flag = (foo.a_magic == OMAGIC); + return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; +], tcl_ok=usable, tcl_ok=unusable) + AC_MSG_RESULT($tcl_ok) + if test $tcl_ok = usable; then + AC_DEFINE(USE_SYS_EXEC_H) + else + AC_MSG_CHECKING(a.out.h) + AC_TRY_COMPILE([#include <a.out.h>],[ + struct exec foo; + unsigned long seek; + int flag; +#if defined(__mips) || defined(mips) + seek = N_TXTOFF (foo.ex_f, foo.ex_o); +#else + seek = N_TXTOFF (foo); +#endif + flag = (foo.a_magic == OMAGIC); + return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; + ], tcl_ok=usable, tcl_ok=unusable) + AC_MSG_RESULT($tcl_ok) + if test $tcl_ok = usable; then + AC_DEFINE(USE_A_OUT_H) + else + AC_MSG_CHECKING(sys/exec_aout.h) + AC_TRY_COMPILE([#include <sys/exec_aout.h>],[ + struct exec foo; + unsigned long seek; + int flag; +#if defined(__mips) || defined(mips) + seek = N_TXTOFF (foo.ex_f, foo.ex_o); +#else + seek = N_TXTOFF (foo); +#endif + flag = (foo.a_midmag == OMAGIC); + return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; + ], tcl_ok=usable, tcl_ok=unusable) + AC_MSG_RESULT($tcl_ok) + if test $tcl_ok = usable; then + AC_DEFINE(USE_SYS_EXEC_AOUT_H) + else + DL_OBJS="" + fi + fi + fi +fi + +# Step 5: disable dynamic loading if requested via a command-line switch. + +AC_ARG_ENABLE(load, [ --disable-load disallow dynamic loading and "load" command], + [tcl_ok=$enableval], [tcl_ok=yes]) +if test "$tcl_ok" = "no"; then + DL_OBJS="" +fi + +if test "x$DL_OBJS" != "x" ; then + BUILD_DLTEST="\$(DLTEST_TARGETS)" +else + echo "Can't figure out how to do dynamic loading or shared libraries" + echo "on this system." + SHLIB_CFLAGS="" + SHLIB_LD="" + SHLIB_SUFFIX="" + DL_OBJS="tclLoadNone.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + BUILD_DLTEST="" +fi + +# If we're running gcc, then change the C flags for compiling shared +# libraries to the right flags for gcc, instead of those for the +# standard manufacturer compiler. + +if test "$DL_OBJS" != "tclLoadNone.o" ; then + if test "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then + case $system in + AIX-*) + ;; + BSD/OS*) + ;; + IRIX*) + ;; + NetBSD-*|FreeBSD-*|OpenBSD-*) + ;; + RISCos-*) + ;; + ULTRIX-4.*) + ;; + *) + SHLIB_CFLAGS="-fPIC" + ;; + esac + fi +fi + +#-------------------------------------------------------------------- +# The statements below check for systems where POSIX-style +# non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. +# On these systems (mostly older ones), use the old BSD-style +# FIONBIO approach instead. +#-------------------------------------------------------------------- + +AC_CHECK_HEADERS(sys/ioctl.h) +AC_CHECK_HEADERS(sys/filio.h) +AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O]) +if test -f /usr/lib/NextStep/software_version; then + system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` +else + system=`uname -s`-`uname -r` + if test "$?" -ne 0 ; then + system=unknown + else + # Special check for weird MP-RAS system (uname returns weird + # results, and the version is kept in special file). + + if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then + system=MP-RAS-`awk '{print $3}' /etc/.relid'` + fi + if test "`uname -s`" = "AIX" ; then + system=AIX-`uname -v`.`uname -r` + fi + fi +fi +case $system in + # There used to be code here to use FIONBIO under AIX. However, it + # was reported that FIONBIO doesn't work under AIX 3.2.5. Since + # using O_NONBLOCK seems fine under AIX 4.*, I removed the FIONBIO + # code (JO, 5/31/97). + + OSF*) + AC_DEFINE(USE_FIONBIO) + AC_MSG_RESULT(FIONBIO) + ;; + SunOS-4*) + AC_DEFINE(USE_FIONBIO) + AC_MSG_RESULT(FIONBIO) + ;; + ULTRIX-4.*) + AC_DEFINE(USE_FIONBIO) + AC_MSG_RESULT(FIONBIO) + ;; + *) + AC_MSG_RESULT(O_NONBLOCK) + ;; +esac + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# building libtcl as a shared library instead of a static library. +#-------------------------------------------------------------------- + +realRanlib=$RANLIB +if test "$TCL_SHARED_LIB_SUFFIX" = "" ; then + TCL_SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}' +fi +if test "$TCL_UNSHARED_LIB_SUFFIX" = "" ; then + TCL_UNSHARED_LIB_SUFFIX='${VERSION}.a' +fi +AC_ARG_ENABLE(shared, + [ --enable-shared build libtcl as a shared library], + [tcl_ok=$enableval], [tcl_ok=no]) +if test "$tcl_ok" = "yes" -a "${SHLIB_SUFFIX}" != "" ; then + TCL_SHARED_BUILD=1 + TCL_SHLIB_CFLAGS="${SHLIB_CFLAGS}" + TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}" + eval "TCL_LIB_FILE=libtcl${TCL_SHARED_LIB_SUFFIX}" + if test "x$DL_OBJS" = "xtclLoadAout.o"; then + MAKE_LIB="ar cr ${TCL_LIB_FILE} \${OBJS}" + else + MAKE_LIB="\${SHLIB_LD} -o ${TCL_LIB_FILE} \${OBJS} ${SHLIB_LD_LIBS}" + RANLIB=":" + fi +else + TCL_SHARED_BUILD=0 + case $system in + BSD/OS*) + ;; + + AIX-*) + ;; + + *) + SHLIB_LD_LIBS="" + ;; + esac + TCL_SHLIB_CFLAGS="" + TCL_LD_SEARCH_FLAGS="" + eval "TCL_LIB_FILE=libtcl${TCL_UNSHARED_LIB_SUFFIX}" + MAKE_LIB="ar cr ${TCL_LIB_FILE} \${OBJS}" +fi + +# Note: in the following variable, it's important to use the absolute +# path name of the Tcl directory rather than "..": this is because +# AIX remembers this path and will attempt to use it at run-time to look +# up the Tcl library. + +if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then + TCL_BUILD_LIB_SPEC="-L`pwd` -ltcl${VERSION}" + TCL_LIB_SPEC="-L${exec_prefix}/lib -ltcl${VERSION}" +else + TCL_BUILD_LIB_SPEC="-L`pwd` -ltcl`echo ${VERSION} | tr -d .`" + TCL_LIB_SPEC="-L${exec_prefix}/lib -ltcl`echo ${VERSION} | tr -d .`" +fi + +#-------------------------------------------------------------------- +# The statements below define the symbol TCL_PACKAGE_PATH, which +# gives a list of directories that may contain packages. The list +# consists of one directory for machine-dependent binaries and +# another for platform-independent scripts. +#-------------------------------------------------------------------- + +if test "$prefix" != "$exec_prefix"; then + TCL_PACKAGE_PATH="${exec_prefix}/lib ${prefix}/lib" +else + TCL_PACKAGE_PATH="${prefix}/lib" +fi + +AC_SUBST(BUILD_DLTEST) +AC_SUBST(DL_LIBS) +AC_SUBST(DL_OBJS) +AC_SUBST(LD_FLAGS) +AC_SUBST(MAKE_LIB) +AC_SUBST(MATH_LIBS) +AC_SUBST(SHLIB_CFLAGS) +AC_SUBST(SHLIB_LD) +AC_SUBST(SHLIB_LD_LIBS) +AC_SUBST(SHLIB_SUFFIX) +AC_SUBST(TCL_BUILD_LIB_SPEC) +AC_SUBST(TCL_LD_SEARCH_FLAGS) +AC_SUBST(TCL_LIB_FILE) +AC_SUBST(TCL_LIB_SPEC) +AC_SUBST(TCL_LIB_VERSIONS_OK) +AC_SUBST(TCL_MAJOR_VERSION) +AC_SUBST(TCL_MINOR_VERSION) +AC_SUBST(TCL_PACKAGE_PATH) +AC_SUBST(TCL_PATCH_LEVEL) +AC_SUBST(TCL_SHARED_LIB_SUFFIX) +AC_SUBST(TCL_SHARED_BUILD) +AC_SUBST(TCL_SHLIB_CFLAGS) +AC_SUBST(TCL_SRC_DIR) +AC_SUBST(TCL_UNSHARED_LIB_SUFFIX) +AC_SUBST(TCL_VERSION) + +AC_OUTPUT(Makefile tclConfig.sh) diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in new file mode 100644 index 0000000..2197b4b --- /dev/null +++ b/unix/dltest/Makefile.in @@ -0,0 +1,45 @@ +# This Makefile is used to create several test cases for Tcl's load +# command. It also illustrates how to take advantage of configuration +# exported by Tcl to set up Makefiles for shared libraries. +# SCCS: @(#) Makefile.in 1.12 97/02/22 14:13:54 + +CC = @CC@ +LIBS = @TCL_BUILD_LIB_SPEC@ @TCL_LIBS@ -lc +SHLIB_CFLAGS = @SHLIB_CFLAGS@ +SHLIB_LD = @SHLIB_LD@ +SHLIB_SUFFIX = @SHLIB_SUFFIX@ +SHLIB_VERSION = @SHLIB_VERSION@ +SRC_DIR = @srcdir@ +TCL_VERSION= @TCL_VERSION@ + +CFLAGS = -g +CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \ + ${SHLIB_CFLAGS} + +all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} + +pkga${SHLIB_SUFFIX}: $(SRC_DIR)/pkga.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c + ${SHLIB_LD} -o pkga${SHLIB_SUFFIX} pkga.o @SHLIB_LD_LIBS@ + +pkgb${SHLIB_SUFFIX}: $(SRC_DIR)/pkgb.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgb.c + ${SHLIB_LD} -o pkgb${SHLIB_SUFFIX} pkgb.o @SHLIB_LD_LIBS@ + +pkgc${SHLIB_SUFFIX}: $(SRC_DIR)/pkgc.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgc.c + ${SHLIB_LD} -o pkgc${SHLIB_SUFFIX} pkgc.o @SHLIB_LD_LIBS@ + +pkgd${SHLIB_SUFFIX}: $(SRC_DIR)/pkgd.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgd.c + ${SHLIB_LD} -o pkgd${SHLIB_SUFFIX} pkgd.o @SHLIB_LD_LIBS@ + +pkge${SHLIB_SUFFIX}: $(SRC_DIR)/pkge.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c + ${SHLIB_LD} -o pkge${SHLIB_SUFFIX} pkge.o @SHLIB_LD_LIBS@ + +clean: + rm -f *.o *${SHLIB_SUFFIX} config.cache config.log config.status lib.exp + +distclean: clean + rm -f Makefile diff --git a/unix/dltest/README b/unix/dltest/README new file mode 100644 index 0000000..f4e54d4 --- /dev/null +++ b/unix/dltest/README @@ -0,0 +1,12 @@ +This directory contains several files for testing Tcl's dynamic +loading capabilities. If this directory is present and the files +in here have been compiled, then the "load" test will use the shared +libraries present here to run a series of tests. To compile the +shared libraries, first type "./configure". This will read +configuration information created when Tcl was configured and +create Makefile from Makefile.in. Be sure that you have configured +Tcl before configuring here, since information learned during Tcl's +configure is needed here. Then type "make" to create the shared +libraries. + +sccsid: @(#) README 1.2 95/08/22 08:13:23 diff --git a/unix/dltest/configure.in b/unix/dltest/configure.in new file mode 100644 index 0000000..29924e9 --- /dev/null +++ b/unix/dltest/configure.in @@ -0,0 +1,29 @@ +dnl This file is an input file used by the GNU "autoconf" program to +dnl generate the file "configure", which is run to configure the +dnl Makefile in this directory. +AC_INIT(pkga.c) +# SCCS: @(#) configure.in 1.9 96/04/15 09:50:20 + +# Recover information that Tcl computed with its configure script. + +. ../tclConfig.sh + +CC=$TCL_CC +AC_SUBST(CC) +SHLIB_CFLAGS=$TCL_SHLIB_CFLAGS +AC_SUBST(SHLIB_CFLAGS) +SHLIB_LD=$TCL_SHLIB_LD +AC_SUBST(SHLIB_LD) +SHLIB_LD_LIBS=$TCL_SHLIB_LD_LIBS +AC_SUBST(SHLIB_LD_LIBS) +SHLIB_SUFFIX=$TCL_SHLIB_SUFFIX +AC_SUBST(SHLIB_SUFFIX) +SHLIB_VERSION=$TCL_SHLIB_VERSION +AC_SUBST(SHLIB_VERSION) +AC_SUBST(TCL_BUILD_LIB_SPEC) +TCL_LIBS=$TCL_LIBS +AC_SUBST(TCL_LIBS) +TCL_VERSION=$TCL_VERSION +AC_SUBST(TCL_VERSION) + +AC_OUTPUT(Makefile) diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c new file mode 100644 index 0000000..ab48522 --- /dev/null +++ b/unix/dltest/pkga.c @@ -0,0 +1,130 @@ +/* + * pkga.c -- + * + * This file contains a simple Tcl package "pkga" that is intended + * for testing the Tcl dynamic loading facilities. + * + * Copyright (c) 1995 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: @(#) pkga.c 1.4 96/02/15 12:30:35 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkga_EqCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkga_QuoteCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkga_EqCmd -- + * + * This procedure is invoked to process the "pkga_eq" Tcl command. + * It expects two arguments and returns 1 if they are the same, + * 0 if they are different. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkga_EqCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " string1 string2\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], argv[2]) == 0) { + interp->result = "1"; + } else { + interp->result = "0"; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkga_quoteCmd -- + * + * This procedure is invoked to process the "pkga_quote" Tcl command. + * It expects one argument, which it returns as result. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkga_QuoteCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " value\"", (char *) NULL); + return TCL_ERROR; + } + strcpy(interp->result, argv[1]); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkga_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkga_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + int code; + + code = Tcl_PkgProvide(interp, "Pkga", "1.0"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkga_eq", Pkga_EqCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkga_quote", Pkga_QuoteCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c new file mode 100644 index 0000000..1da9575 --- /dev/null +++ b/unix/dltest/pkgb.c @@ -0,0 +1,153 @@ +/* + * pkgb.c -- + * + * This file contains a simple Tcl package "pkgb" that is intended + * for testing the Tcl dynamic loading facilities. It can be used + * in both safe and unsafe interpreters. + * + * Copyright (c) 1995 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: @(#) pkgb.c 1.4 96/02/15 12:30:34 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgb_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgb_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkgb_SubCmd -- + * + * This procedure is invoked to process the "pkgb_sub" Tcl command. + * It expects two arguments and returns their difference. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgb_SubCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int first, second; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " num num\"", (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[1], &first) != TCL_OK) + || (Tcl_GetInt(interp, argv[2], &second) != TCL_OK)) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", first - second); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgb_UnsafeCmd -- + * + * This procedure is invoked to process the "pkgb_unsafe" Tcl command. + * It just returns a constant string. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgb_UnsafeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + interp->result = "unsafe command invoked"; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgb_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgb_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + int code; + + code = Tcl_PkgProvide(interp, "Pkgb", "2.3"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkgb_sub", Pkgb_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkgb_unsafe", Pkgb_UnsafeCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgb_SafeInit -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an unsafe interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgb_SafeInit(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + Tcl_CreateCommand(interp, "pkgb_sub", Pkgb_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c new file mode 100644 index 0000000..c35189a --- /dev/null +++ b/unix/dltest/pkgc.c @@ -0,0 +1,153 @@ +/* + * pkgc.c -- + * + * This file contains a simple Tcl package "pkgc" that is intended + * for testing the Tcl dynamic loading facilities. It can be used + * in both safe and unsafe interpreters. + * + * Copyright (c) 1995 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: @(#) pkgc.c 1.4 96/02/15 12:30:35 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgc_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgc_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkgc_SubCmd -- + * + * This procedure is invoked to process the "pkgc_sub" Tcl command. + * It expects two arguments and returns their difference. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgc_SubCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int first, second; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " num num\"", (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[1], &first) != TCL_OK) + || (Tcl_GetInt(interp, argv[2], &second) != TCL_OK)) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", first - second); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgc_UnsafeCmd -- + * + * This procedure is invoked to process the "pkgc_unsafe" Tcl command. + * It just returns a constant string. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgc_UnsafeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + interp->result = "unsafe command invoked"; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgc_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgc_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + int code; + + code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkgc_sub", Pkgc_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkgc_unsafe", Pkgc_UnsafeCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgc_SafeInit -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an unsafe interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgc_SafeInit(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + Tcl_CreateCommand(interp, "pkgc_sub", Pkgc_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c new file mode 100644 index 0000000..56821cc --- /dev/null +++ b/unix/dltest/pkgd.c @@ -0,0 +1,154 @@ +/* + * pkgd.c -- + * + * This file contains a simple Tcl package "pkgd" that is intended + * for testing the Tcl dynamic loading facilities. It can be used + * in both safe and unsafe interpreters. + * + * Copyright (c) 1995 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: @(#) pkgd.c 1.4 96/02/15 12:30:32 + */ + +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgd_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgd_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkgd_SubCmd -- + * + * This procedure is invoked to process the "pkgd_sub" Tcl command. + * It expects two arguments and returns their difference. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgd_SubCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int first, second; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " num num\"", (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[1], &first) != TCL_OK) + || (Tcl_GetInt(interp, argv[2], &second) != TCL_OK)) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", first - second); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgd_UnsafeCmd -- + * + * This procedure is invoked to process the "pkgd_unsafe" Tcl command. + * It just returns a constant string. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgd_UnsafeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + interp->result = "unsafe command invoked"; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgd_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgd_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + int code; + + code = Tcl_PkgProvide(interp, "Pkgd", "7.3"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkgd_sub", Pkgd_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkgd_unsafe", Pkgd_UnsafeCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgd_SafeInit -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an unsafe interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgd_SafeInit(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + Tcl_CreateCommand(interp, "pkgd_sub", Pkgd_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/unix/dltest/pkge.c b/unix/dltest/pkge.c new file mode 100644 index 0000000..1d585ca --- /dev/null +++ b/unix/dltest/pkge.c @@ -0,0 +1,49 @@ +/* + * pkge.c -- + * + * This file contains a simple Tcl package "pkge" that is intended + * for testing the Tcl dynamic loading facilities. Its Init + * procedure returns an error in order to test how this is handled. + * + * Copyright (c) 1995 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: @(#) pkge.c 1.5 96/03/07 09:34:27 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgd_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgd_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkge_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * Returns TCL_ERROR and leaves an error message in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkge_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + return Tcl_Eval(interp, "if 44 {open non_existent}"); +} diff --git a/unix/dltest/pkgf.c b/unix/dltest/pkgf.c new file mode 100644 index 0000000..d7c641a --- /dev/null +++ b/unix/dltest/pkgf.c @@ -0,0 +1,49 @@ +/* + * pkgf.c -- + * + * This file contains a simple Tcl package "pkgf" that is intended + * for testing the Tcl dynamic loading facilities. Its Init + * procedure returns an error in order to test how this is handled. + * + * Copyright (c) 1995 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: @(#) pkgf.c 1.2 96/02/15 12:30:32 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgd_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgd_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkgf_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * Returns TCL_ERROR and leaves an error message in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgf_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + return Tcl_Eval(interp, "if 44 {open non_existent}"); +} diff --git a/unix/install-sh b/unix/install-sh new file mode 100755 index 0000000..0ff4b6a --- /dev/null +++ b/unix/install-sh @@ -0,0 +1,119 @@ +#!/bin/sh + +# +# install - install a program, script, or datafile +# This comes from X11R5; it is not part of GNU. +# +# $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $ +# +# This script is compatible with the BSD install script, but was written +# from scratch. +# + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" + +instcmd="$mvprog" +chmodcmd="" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +fi + +if [ x"$dst" = x ] +then + echo "install: no destination specified" + exit 1 +fi + + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + +if [ -d $dst ] +then + dst="$dst"/`basename $src` +fi + +# Make a temp file name in the proper directory. + +dstdir=`dirname $dst` +dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + +$doit $instcmd $src $dsttmp + +# and set any options; do chmod last to preserve setuid bits + +if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; fi +if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; fi +if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; fi +if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; fi + +# Now rename the file to the real destination. + +$doit $rmcmd $dst +$doit $mvcmd $dsttmp $dst + + +exit 0 diff --git a/unix/ldAix b/unix/ldAix new file mode 100755 index 0000000..4da2b20 --- /dev/null +++ b/unix/ldAix @@ -0,0 +1,72 @@ +#!/bin/sh +# +# ldAix ldCmd ldArg ldArg ... +# +# This shell script provides a wrapper for ld under AIX in order to +# create the .exp file required for linking. Its arguments consist +# of the name and arguments that would normally be provided to the +# ld command. This script extracts the names of the object files +# from the argument list, creates a .exp file describing all of the +# symbols exported by those files, and then invokes "ldCmd" to +# perform the real link. +# +# SCCS: @(#) ldAix 1.8 97/02/21 14:50:27 + +# Extract from the arguments the names of all of the object files. + +args=$* +ofiles="" +for i do + x=`echo $i | grep '[^.].o$'` + if test "$x" != ""; then + ofiles="$ofiles $i" + fi +done + +# Create the export file from all of the object files, using nm followed +# by sed editing. Here are some tricky aspects of this: +# +# 1. Nm produces different output under AIX 4.1 than under AIX 3.2.5; +# the following statements handle both versions. +# 2. Use the -g switch to nm instead of -e under 4.1 (this shows just +# externals, not statics; -g isn't available under 3.2.5, though). +# 3. Eliminate lines that end in ":": these are the names of object +# files (relevant in 4.1 only). +# 4. Eliminate entries with the "U" key letter; these are undefined +# symbols (relevant in 4.1 only). +# 5. Eliminate lines that contain the string "0|extern" preceded by space; +# in 3.2.5, these are undefined symbols (address 0). +# 6. Eliminate lines containing the "unamex" symbol. In 3.2.5, these +# are also undefined symbols. +# 7. If a line starts with ".", delete the leading ".", since this will +# just cause confusion later. +# 8. Eliminate everything after the first field in a line, so that we're +# left with just the symbol name. + +nmopts="-g -C" +osver=`uname -v` +if test $osver -eq 3; then + nmopts="-e" +fi +rm -f lib.exp +echo "#! " >lib.exp +/usr/ccs/bin/nm $nmopts -h $ofiles | sed -e '/:$/d' -e '/ U /d' -e '/[ ]0|extern/d' -e '/unamex/d' -e 's/^\.//' -e 's/[ |].*//' | sort | uniq >>lib.exp + +# Extract the name of the object file that we're linking. If it's a .a +# file, then link all the objects together into a single file "shr.o" +# and then put that into the archive. Otherwise link the object files +# directly into the .a file. + +outputFile=`echo $args | sed -e 's/.*-o \([^ ]*\).*/\1/'` +noDotA=`echo $outputFile | sed -e '/\.a$/d'` +echo "noDotA=\"$noDotA\"" +if test "$noDotA" = "" ; then + linkArgs=`echo $args | sed -e 's/-o .*\.a /-o shr.o /'` + echo $linkArgs + eval $linkArgs + echo ar cr $outputFile shr.o + ar cr $outputFile shr.o + rm -f shr.o +else + eval $args +fi diff --git a/unix/mkLinks b/unix/mkLinks new file mode 100644 index 0000000..b4da360 --- /dev/null +++ b/unix/mkLinks @@ -0,0 +1,1010 @@ +#!/bin/sh +# This script is invoked when installing manual entries. It generates +# additional links to manual entries, corresponding to the procedure +# and command names described by the manual entry. For example, the +# Tcl manual entry Hash.3 describes procedures Tcl_InitHashTable, +# Tcl_CreateHashEntry, and many more. This script will make hard +# links so that Tcl_InitHashTable.3, Tcl_CreateHashEntry.3, and so +# on all refer to Hash.3 in the installed directory. +# +# Because of the length of command and procedure names, this mechanism +# only works on machines that support file names longer than 14 characters. +# This script checks to see if long file names are supported, and it +# doesn't make any links if they are not. +# +# The script takes one argument, which is the name of the directory +# where the manual entries have been installed. + +if test $# != 1; then + echo "Usage: mkLinks dir" + exit 1 +fi + +cd $1 +echo foo > xyzzyTestingAVeryLongFileName.foo +x=`echo xyzzyTe*` +rm xyzzyTe* +if test "$x" != "xyzzyTestingAVeryLongFileName.foo"; then + exit +fi +if test -r safe.n; then + rm -f Base.n + ln safe.n Base.n +fi +if test -r http.n; then + rm -f Http.n + ln http.n Http.n +fi +if test -r safe.n; then + rm -f Safe.n + ln safe.n Safe.n +fi +if test -r StringObj.3; then + rm -f TclConcatObj.3 + ln StringObj.3 TclConcatObj.3 +fi +if test -r AddErrInfo.3; then + rm -f Tcl_AddErrorInfo.3 + ln AddErrInfo.3 Tcl_AddErrorInfo.3 +fi +if test -r AddErrInfo.3; then + rm -f Tcl_AddObjErrorInfo.3 + ln AddErrInfo.3 Tcl_AddObjErrorInfo.3 +fi +if test -r Alloc.3; then + rm -f Tcl_Alloc.3 + ln Alloc.3 Tcl_Alloc.3 +fi +if test -r AllowExc.3; then + rm -f Tcl_AllowExceptions.3 + ln AllowExc.3 Tcl_AllowExceptions.3 +fi +if test -r AppInit.3; then + rm -f Tcl_AppInit.3 + ln AppInit.3 Tcl_AppInit.3 +fi +if test -r ObjectType.3; then + rm -f Tcl_AppendAllObjTypes.3 + ln ObjectType.3 Tcl_AppendAllObjTypes.3 +fi +if test -r SetResult.3; then + rm -f Tcl_AppendElement.3 + ln SetResult.3 Tcl_AppendElement.3 +fi +if test -r SetResult.3; then + rm -f Tcl_AppendResult.3 + ln SetResult.3 Tcl_AppendResult.3 +fi +if test -r StringObj.3; then + rm -f Tcl_AppendStringsToObj.3 + ln StringObj.3 Tcl_AppendStringsToObj.3 +fi +if test -r StringObj.3; then + rm -f Tcl_AppendToObj.3 + ln StringObj.3 Tcl_AppendToObj.3 +fi +if test -r Async.3; then + rm -f Tcl_AsyncCreate.3 + ln Async.3 Tcl_AsyncCreate.3 +fi +if test -r Async.3; then + rm -f Tcl_AsyncDelete.3 + ln Async.3 Tcl_AsyncDelete.3 +fi +if test -r Async.3; then + rm -f Tcl_AsyncInvoke.3 + ln Async.3 Tcl_AsyncInvoke.3 +fi +if test -r Async.3; then + rm -f Tcl_AsyncMark.3 + ln Async.3 Tcl_AsyncMark.3 +fi +if test -r BackgdErr.3; then + rm -f Tcl_BackgroundError.3 + ln BackgdErr.3 Tcl_BackgroundError.3 +fi +if test -r Backslash.3; then + rm -f Tcl_Backslash.3 + ln Backslash.3 Tcl_Backslash.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_BadChannelOption.3 + ln CrtChannel.3 Tcl_BadChannelOption.3 +fi +if test -r CallDel.3; then + rm -f Tcl_CallWhenDeleted.3 + ln CallDel.3 Tcl_CallWhenDeleted.3 +fi +if test -r DoWhenIdle.3; then + rm -f Tcl_CancelIdleCall.3 + ln DoWhenIdle.3 Tcl_CancelIdleCall.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Close.3 + ln OpenFileChnl.3 Tcl_Close.3 +fi +if test -r CmdCmplt.3; then + rm -f Tcl_CommandComplete.3 + ln CmdCmplt.3 Tcl_CommandComplete.3 +fi +if test -r Concat.3; then + rm -f Tcl_Concat.3 + ln Concat.3 Tcl_Concat.3 +fi +if test -r SplitList.3; then + rm -f Tcl_ConvertElement.3 + ln SplitList.3 Tcl_ConvertElement.3 +fi +if test -r ObjectType.3; then + rm -f Tcl_ConvertToType.3 + ln ObjectType.3 Tcl_ConvertToType.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_CreateAlias.3 + ln CrtSlave.3 Tcl_CreateAlias.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_CreateAliasObj.3 + ln CrtSlave.3 Tcl_CreateAliasObj.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_CreateChannel.3 + ln CrtChannel.3 Tcl_CreateChannel.3 +fi +if test -r CrtChnlHdlr.3; then + rm -f Tcl_CreateChannelHandler.3 + ln CrtChnlHdlr.3 Tcl_CreateChannelHandler.3 +fi +if test -r CrtCloseHdlr.3; then + rm -f Tcl_CreateCloseHandler.3 + ln CrtCloseHdlr.3 Tcl_CreateCloseHandler.3 +fi +if test -r CrtCommand.3; then + rm -f Tcl_CreateCommand.3 + ln CrtCommand.3 Tcl_CreateCommand.3 +fi +if test -r Notifier.3; then + rm -f Tcl_CreateEventSource.3 + ln Notifier.3 Tcl_CreateEventSource.3 +fi +if test -r Exit.3; then + rm -f Tcl_CreateExitHandler.3 + ln Exit.3 Tcl_CreateExitHandler.3 +fi +if test -r CrtFileHdlr.3; then + rm -f Tcl_CreateFileHandler.3 + ln CrtFileHdlr.3 Tcl_CreateFileHandler.3 +fi +if test -r Hash.3; then + rm -f Tcl_CreateHashEntry.3 + ln Hash.3 Tcl_CreateHashEntry.3 +fi +if test -r CrtInterp.3; then + rm -f Tcl_CreateInterp.3 + ln CrtInterp.3 Tcl_CreateInterp.3 +fi +if test -r CrtMathFnc.3; then + rm -f Tcl_CreateMathFunc.3 + ln CrtMathFnc.3 Tcl_CreateMathFunc.3 +fi +if test -r CrtObjCmd.3; then + rm -f Tcl_CreateObjCommand.3 + ln CrtObjCmd.3 Tcl_CreateObjCommand.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_CreateSlave.3 + ln CrtSlave.3 Tcl_CreateSlave.3 +fi +if test -r CrtTimerHdlr.3; then + rm -f Tcl_CreateTimerHandler.3 + ln CrtTimerHdlr.3 Tcl_CreateTimerHandler.3 +fi +if test -r CrtTrace.3; then + rm -f Tcl_CreateTrace.3 + ln CrtTrace.3 Tcl_CreateTrace.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringAppend.3 + ln DString.3 Tcl_DStringAppend.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringAppendElement.3 + ln DString.3 Tcl_DStringAppendElement.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringEndSublist.3 + ln DString.3 Tcl_DStringEndSublist.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringFree.3 + ln DString.3 Tcl_DStringFree.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringGetResult.3 + ln DString.3 Tcl_DStringGetResult.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringInit.3 + ln DString.3 Tcl_DStringInit.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringLength.3 + ln DString.3 Tcl_DStringLength.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringResult.3 + ln DString.3 Tcl_DStringResult.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringSetLength.3 + ln DString.3 Tcl_DStringSetLength.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringStartSublist.3 + ln DString.3 Tcl_DStringStartSublist.3 +fi +if test -r DString.3; then + rm -f Tcl_DStringValue.3 + ln DString.3 Tcl_DStringValue.3 +fi +if test -r Object.3; then + rm -f Tcl_DecrRefCount.3 + ln Object.3 Tcl_DecrRefCount.3 +fi +if test -r AssocData.3; then + rm -f Tcl_DeleteAssocData.3 + ln AssocData.3 Tcl_DeleteAssocData.3 +fi +if test -r CrtChnlHdlr.3; then + rm -f Tcl_DeleteChannelHandler.3 + ln CrtChnlHdlr.3 Tcl_DeleteChannelHandler.3 +fi +if test -r CrtCloseHdlr.3; then + rm -f Tcl_DeleteCloseHandler.3 + ln CrtCloseHdlr.3 Tcl_DeleteCloseHandler.3 +fi +if test -r CrtObjCmd.3; then + rm -f Tcl_DeleteCommand.3 + ln CrtObjCmd.3 Tcl_DeleteCommand.3 +fi +if test -r CrtObjCmd.3; then + rm -f Tcl_DeleteCommandFromToken.3 + ln CrtObjCmd.3 Tcl_DeleteCommandFromToken.3 +fi +if test -r Notifier.3; then + rm -f Tcl_DeleteEventSource.3 + ln Notifier.3 Tcl_DeleteEventSource.3 +fi +if test -r Notifier.3; then + rm -f Tcl_DeleteEvents.3 + ln Notifier.3 Tcl_DeleteEvents.3 +fi +if test -r Exit.3; then + rm -f Tcl_DeleteExitHandler.3 + ln Exit.3 Tcl_DeleteExitHandler.3 +fi +if test -r CrtFileHdlr.3; then + rm -f Tcl_DeleteFileHandler.3 + ln CrtFileHdlr.3 Tcl_DeleteFileHandler.3 +fi +if test -r Hash.3; then + rm -f Tcl_DeleteHashEntry.3 + ln Hash.3 Tcl_DeleteHashEntry.3 +fi +if test -r Hash.3; then + rm -f Tcl_DeleteHashTable.3 + ln Hash.3 Tcl_DeleteHashTable.3 +fi +if test -r CrtInterp.3; then + rm -f Tcl_DeleteInterp.3 + ln CrtInterp.3 Tcl_DeleteInterp.3 +fi +if test -r CrtTimerHdlr.3; then + rm -f Tcl_DeleteTimerHandler.3 + ln CrtTimerHdlr.3 Tcl_DeleteTimerHandler.3 +fi +if test -r CrtTrace.3; then + rm -f Tcl_DeleteTrace.3 + ln CrtTrace.3 Tcl_DeleteTrace.3 +fi +if test -r DetachPids.3; then + rm -f Tcl_DetachPids.3 + ln DetachPids.3 Tcl_DetachPids.3 +fi +if test -r DoOneEvent.3; then + rm -f Tcl_DoOneEvent.3 + ln DoOneEvent.3 Tcl_DoOneEvent.3 +fi +if test -r DoWhenIdle.3; then + rm -f Tcl_DoWhenIdle.3 + ln DoWhenIdle.3 Tcl_DoWhenIdle.3 +fi +if test -r CallDel.3; then + rm -f Tcl_DontCallWhenDeleted.3 + ln CallDel.3 Tcl_DontCallWhenDeleted.3 +fi +if test -r Object.3; then + rm -f Tcl_DuplicateObj.3 + ln Object.3 Tcl_DuplicateObj.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Eof.3 + ln OpenFileChnl.3 Tcl_Eof.3 +fi +if test -r Eval.3; then + rm -f Tcl_Eval.3 + ln Eval.3 Tcl_Eval.3 +fi +if test -r Eval.3; then + rm -f Tcl_EvalFile.3 + ln Eval.3 Tcl_EvalFile.3 +fi +if test -r EvalObj.3; then + rm -f Tcl_EvalObj.3 + ln EvalObj.3 Tcl_EvalObj.3 +fi +if test -r Preserve.3; then + rm -f Tcl_EventuallyFree.3 + ln Preserve.3 Tcl_EventuallyFree.3 +fi +if test -r Exit.3; then + rm -f Tcl_Exit.3 + ln Exit.3 Tcl_Exit.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_ExposeCommand.3 + ln CrtSlave.3 Tcl_ExposeCommand.3 +fi +if test -r ExprLong.3; then + rm -f Tcl_ExprBoolean.3 + ln ExprLong.3 Tcl_ExprBoolean.3 +fi +if test -r ExprLongObj.3; then + rm -f Tcl_ExprBooleanObj.3 + ln ExprLongObj.3 Tcl_ExprBooleanObj.3 +fi +if test -r ExprLong.3; then + rm -f Tcl_ExprDouble.3 + ln ExprLong.3 Tcl_ExprDouble.3 +fi +if test -r ExprLongObj.3; then + rm -f Tcl_ExprDoubleObj.3 + ln ExprLongObj.3 Tcl_ExprDoubleObj.3 +fi +if test -r ExprLong.3; then + rm -f Tcl_ExprLong.3 + ln ExprLong.3 Tcl_ExprLong.3 +fi +if test -r ExprLongObj.3; then + rm -f Tcl_ExprLongObj.3 + ln ExprLongObj.3 Tcl_ExprLongObj.3 +fi +if test -r ExprLongObj.3; then + rm -f Tcl_ExprObj.3 + ln ExprLongObj.3 Tcl_ExprObj.3 +fi +if test -r ExprLong.3; then + rm -f Tcl_ExprString.3 + ln ExprLong.3 Tcl_ExprString.3 +fi +if test -r Exit.3; then + rm -f Tcl_Finalize.3 + ln Exit.3 Tcl_Finalize.3 +fi +if test -r FindExec.3; then + rm -f Tcl_FindExecutable.3 + ln FindExec.3 Tcl_FindExecutable.3 +fi +if test -r Hash.3; then + rm -f Tcl_FindHashEntry.3 + ln Hash.3 Tcl_FindHashEntry.3 +fi +if test -r Hash.3; then + rm -f Tcl_FirstHashEntry.3 + ln Hash.3 Tcl_FirstHashEntry.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Flush.3 + ln OpenFileChnl.3 Tcl_Flush.3 +fi +if test -r Alloc.3; then + rm -f Tcl_Free.3 + ln Alloc.3 Tcl_Free.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_GetAlias.3 + ln CrtSlave.3 Tcl_GetAlias.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_GetAliasObj.3 + ln CrtSlave.3 Tcl_GetAliasObj.3 +fi +if test -r AssocData.3; then + rm -f Tcl_GetAssocData.3 + ln AssocData.3 Tcl_GetAssocData.3 +fi +if test -r GetInt.3; then + rm -f Tcl_GetBoolean.3 + ln GetInt.3 Tcl_GetBoolean.3 +fi +if test -r BoolObj.3; then + rm -f Tcl_GetBooleanFromObj.3 + ln BoolObj.3 Tcl_GetBooleanFromObj.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_GetChannel.3 + ln OpenFileChnl.3 Tcl_GetChannel.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelBufferSize.3 + ln CrtChannel.3 Tcl_GetChannelBufferSize.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelHandle.3 + ln CrtChannel.3 Tcl_GetChannelHandle.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelInstanceData.3 + ln CrtChannel.3 Tcl_GetChannelInstanceData.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelMode.3 + ln CrtChannel.3 Tcl_GetChannelMode.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelName.3 + ln CrtChannel.3 Tcl_GetChannelName.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_GetChannelOption.3 + ln OpenFileChnl.3 Tcl_GetChannelOption.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_GetChannelType.3 + ln CrtChannel.3 Tcl_GetChannelType.3 +fi +if test -r CrtObjCmd.3; then + rm -f Tcl_GetCommandInfo.3 + ln CrtObjCmd.3 Tcl_GetCommandInfo.3 +fi +if test -r CrtObjCmd.3; then + rm -f Tcl_GetCommandName.3 + ln CrtObjCmd.3 Tcl_GetCommandName.3 +fi +if test -r GetInt.3; then + rm -f Tcl_GetDouble.3 + ln GetInt.3 Tcl_GetDouble.3 +fi +if test -r DoubleObj.3; then + rm -f Tcl_GetDoubleFromObj.3 + ln DoubleObj.3 Tcl_GetDoubleFromObj.3 +fi +if test -r SetErrno.3; then + rm -f Tcl_GetErrno.3 + ln SetErrno.3 Tcl_GetErrno.3 +fi +if test -r Hash.3; then + rm -f Tcl_GetHashKey.3 + ln Hash.3 Tcl_GetHashKey.3 +fi +if test -r Hash.3; then + rm -f Tcl_GetHashValue.3 + ln Hash.3 Tcl_GetHashValue.3 +fi +if test -r GetIndex.3; then + rm -f Tcl_GetIndexFromObj.3 + ln GetIndex.3 Tcl_GetIndexFromObj.3 +fi +if test -r GetInt.3; then + rm -f Tcl_GetInt.3 + ln GetInt.3 Tcl_GetInt.3 +fi +if test -r IntObj.3; then + rm -f Tcl_GetIntFromObj.3 + ln IntObj.3 Tcl_GetIntFromObj.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_GetInterpPath.3 + ln CrtSlave.3 Tcl_GetInterpPath.3 +fi +if test -r IntObj.3; then + rm -f Tcl_GetLongFromObj.3 + ln IntObj.3 Tcl_GetLongFromObj.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_GetMaster.3 + ln CrtSlave.3 Tcl_GetMaster.3 +fi +if test -r SetResult.3; then + rm -f Tcl_GetObjResult.3 + ln SetResult.3 Tcl_GetObjResult.3 +fi +if test -r ObjectType.3; then + rm -f Tcl_GetObjType.3 + ln ObjectType.3 Tcl_GetObjType.3 +fi +if test -r GetOpnFl.3; then + rm -f Tcl_GetOpenFile.3 + ln GetOpnFl.3 Tcl_GetOpenFile.3 +fi +if test -r SplitPath.3; then + rm -f Tcl_GetPathType.3 + ln SplitPath.3 Tcl_GetPathType.3 +fi +if test -r Notifier.3; then + rm -f Tcl_GetServiceMode.3 + ln Notifier.3 Tcl_GetServiceMode.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_GetSlave.3 + ln CrtSlave.3 Tcl_GetSlave.3 +fi +if test -r GetStdChan.3; then + rm -f Tcl_GetStdChannel.3 + ln GetStdChan.3 Tcl_GetStdChannel.3 +fi +if test -r StringObj.3; then + rm -f Tcl_GetStringFromObj.3 + ln StringObj.3 Tcl_GetStringFromObj.3 +fi +if test -r SetResult.3; then + rm -f Tcl_GetStringResult.3 + ln SetResult.3 Tcl_GetStringResult.3 +fi +if test -r SetVar.3; then + rm -f Tcl_GetVar.3 + ln SetVar.3 Tcl_GetVar.3 +fi +if test -r SetVar.3; then + rm -f Tcl_GetVar2.3 + ln SetVar.3 Tcl_GetVar2.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Gets.3 + ln OpenFileChnl.3 Tcl_Gets.3 +fi +if test -r Eval.3; then + rm -f Tcl_GlobalEval.3 + ln Eval.3 Tcl_GlobalEval.3 +fi +if test -r EvalObj.3; then + rm -f Tcl_GlobalEvalObj.3 + ln EvalObj.3 Tcl_GlobalEvalObj.3 +fi +if test -r Hash.3; then + rm -f Tcl_HashStats.3 + ln Hash.3 Tcl_HashStats.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_HideCommand.3 + ln CrtSlave.3 Tcl_HideCommand.3 +fi +if test -r Object.3; then + rm -f Tcl_IncrRefCount.3 + ln Object.3 Tcl_IncrRefCount.3 +fi +if test -r Hash.3; then + rm -f Tcl_InitHashTable.3 + ln Hash.3 Tcl_InitHashTable.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_InputBlocked.3 + ln OpenFileChnl.3 Tcl_InputBlocked.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_InputBuffered.3 + ln OpenFileChnl.3 Tcl_InputBuffered.3 +fi +if test -r Interp.3; then + rm -f Tcl_Interp.3 + ln Interp.3 Tcl_Interp.3 +fi +if test -r CrtInterp.3; then + rm -f Tcl_InterpDeleted.3 + ln CrtInterp.3 Tcl_InterpDeleted.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_IsSafe.3 + ln CrtSlave.3 Tcl_IsSafe.3 +fi +if test -r Object.3; then + rm -f Tcl_IsShared.3 + ln Object.3 Tcl_IsShared.3 +fi +if test -r SplitPath.3; then + rm -f Tcl_JoinPath.3 + ln SplitPath.3 Tcl_JoinPath.3 +fi +if test -r LinkVar.3; then + rm -f Tcl_LinkVar.3 + ln LinkVar.3 Tcl_LinkVar.3 +fi +if test -r ListObj.3; then + rm -f Tcl_ListObjAppendElement.3 + ln ListObj.3 Tcl_ListObjAppendElement.3 +fi +if test -r ListObj.3; then + rm -f Tcl_ListObjAppendList.3 + ln ListObj.3 Tcl_ListObjAppendList.3 +fi +if test -r ListObj.3; then + rm -f Tcl_ListObjGetElements.3 + ln ListObj.3 Tcl_ListObjGetElements.3 +fi +if test -r ListObj.3; then + rm -f Tcl_ListObjIndex.3 + ln ListObj.3 Tcl_ListObjIndex.3 +fi +if test -r ListObj.3; then + rm -f Tcl_ListObjLength.3 + ln ListObj.3 Tcl_ListObjLength.3 +fi +if test -r ListObj.3; then + rm -f Tcl_ListObjReplace.3 + ln ListObj.3 Tcl_ListObjReplace.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_MakeFileChannel.3 + ln OpenFileChnl.3 Tcl_MakeFileChannel.3 +fi +if test -r CrtSlave.3; then + rm -f Tcl_MakeSafe.3 + ln CrtSlave.3 Tcl_MakeSafe.3 +fi +if test -r OpenTcp.3; then + rm -f Tcl_MakeTcpClientChannel.3 + ln OpenTcp.3 Tcl_MakeTcpClientChannel.3 +fi +if test -r SplitList.3; then + rm -f Tcl_Merge.3 + ln SplitList.3 Tcl_Merge.3 +fi +if test -r BoolObj.3; then + rm -f Tcl_NewBooleanObj.3 + ln BoolObj.3 Tcl_NewBooleanObj.3 +fi +if test -r DoubleObj.3; then + rm -f Tcl_NewDoubleObj.3 + ln DoubleObj.3 Tcl_NewDoubleObj.3 +fi +if test -r IntObj.3; then + rm -f Tcl_NewIntObj.3 + ln IntObj.3 Tcl_NewIntObj.3 +fi +if test -r ListObj.3; then + rm -f Tcl_NewListObj.3 + ln ListObj.3 Tcl_NewListObj.3 +fi +if test -r IntObj.3; then + rm -f Tcl_NewLongObj.3 + ln IntObj.3 Tcl_NewLongObj.3 +fi +if test -r Object.3; then + rm -f Tcl_NewObj.3 + ln Object.3 Tcl_NewObj.3 +fi +if test -r StringObj.3; then + rm -f Tcl_NewStringObj.3 + ln StringObj.3 Tcl_NewStringObj.3 +fi +if test -r Hash.3; then + rm -f Tcl_NextHashEntry.3 + ln Hash.3 Tcl_NextHashEntry.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_NotifyChannel.3 + ln CrtChannel.3 Tcl_NotifyChannel.3 +fi +if test -r ObjSetVar.3; then + rm -f Tcl_ObjGetVar2.3 + ln ObjSetVar.3 Tcl_ObjGetVar2.3 +fi +if test -r ObjSetVar.3; then + rm -f Tcl_ObjSetVar2.3 + ln ObjSetVar.3 Tcl_ObjSetVar2.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_OpenCommandChannel.3 + ln OpenFileChnl.3 Tcl_OpenCommandChannel.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_OpenFileChannel.3 + ln OpenFileChnl.3 Tcl_OpenFileChannel.3 +fi +if test -r OpenTcp.3; then + rm -f Tcl_OpenTcpClient.3 + ln OpenTcp.3 Tcl_OpenTcpClient.3 +fi +if test -r OpenTcp.3; then + rm -f Tcl_OpenTcpServer.3 + ln OpenTcp.3 Tcl_OpenTcpServer.3 +fi +if test -r PkgRequire.3; then + rm -f Tcl_PkgProvide.3 + ln PkgRequire.3 Tcl_PkgProvide.3 +fi +if test -r PkgRequire.3; then + rm -f Tcl_PkgRequire.3 + ln PkgRequire.3 Tcl_PkgRequire.3 +fi +if test -r AddErrInfo.3; then + rm -f Tcl_PosixError.3 + ln AddErrInfo.3 Tcl_PosixError.3 +fi +if test -r Preserve.3; then + rm -f Tcl_Preserve.3 + ln Preserve.3 Tcl_Preserve.3 +fi +if test -r PrintDbl.3; then + rm -f Tcl_PrintDouble.3 + ln PrintDbl.3 Tcl_PrintDouble.3 +fi +if test -r Notifier.3; then + rm -f Tcl_QueueEvent.3 + ln Notifier.3 Tcl_QueueEvent.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Read.3 + ln OpenFileChnl.3 Tcl_Read.3 +fi +if test -r Alloc.3; then + rm -f Tcl_Realloc.3 + ln Alloc.3 Tcl_Realloc.3 +fi +if test -r DetachPids.3; then + rm -f Tcl_ReapDetachedProcs.3 + ln DetachPids.3 Tcl_ReapDetachedProcs.3 +fi +if test -r RecordEval.3; then + rm -f Tcl_RecordAndEval.3 + ln RecordEval.3 Tcl_RecordAndEval.3 +fi +if test -r RecEvalObj.3; then + rm -f Tcl_RecordAndEvalObj.3 + ln RecEvalObj.3 Tcl_RecordAndEvalObj.3 +fi +if test -r RegExp.3; then + rm -f Tcl_RegExpCompile.3 + ln RegExp.3 Tcl_RegExpCompile.3 +fi +if test -r RegExp.3; then + rm -f Tcl_RegExpExec.3 + ln RegExp.3 Tcl_RegExpExec.3 +fi +if test -r RegExp.3; then + rm -f Tcl_RegExpMatch.3 + ln RegExp.3 Tcl_RegExpMatch.3 +fi +if test -r RegExp.3; then + rm -f Tcl_RegExpRange.3 + ln RegExp.3 Tcl_RegExpRange.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_RegisterChannel.3 + ln OpenFileChnl.3 Tcl_RegisterChannel.3 +fi +if test -r ObjectType.3; then + rm -f Tcl_RegisterObjType.3 + ln ObjectType.3 Tcl_RegisterObjType.3 +fi +if test -r Preserve.3; then + rm -f Tcl_Release.3 + ln Preserve.3 Tcl_Release.3 +fi +if test -r SetResult.3; then + rm -f Tcl_ResetResult.3 + ln SetResult.3 Tcl_ResetResult.3 +fi +if test -r SplitList.3; then + rm -f Tcl_ScanElement.3 + ln SplitList.3 Tcl_ScanElement.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Seek.3 + ln OpenFileChnl.3 Tcl_Seek.3 +fi +if test -r Notifier.3; then + rm -f Tcl_ServiceAll.3 + ln Notifier.3 Tcl_ServiceAll.3 +fi +if test -r Notifier.3; then + rm -f Tcl_ServiceEvent.3 + ln Notifier.3 Tcl_ServiceEvent.3 +fi +if test -r AssocData.3; then + rm -f Tcl_SetAssocData.3 + ln AssocData.3 Tcl_SetAssocData.3 +fi +if test -r BoolObj.3; then + rm -f Tcl_SetBooleanObj.3 + ln BoolObj.3 Tcl_SetBooleanObj.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_SetChannelBufferSize.3 + ln CrtChannel.3 Tcl_SetChannelBufferSize.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_SetChannelOption.3 + ln OpenFileChnl.3 Tcl_SetChannelOption.3 +fi +if test -r CrtObjCmd.3; then + rm -f Tcl_SetCommandInfo.3 + ln CrtObjCmd.3 Tcl_SetCommandInfo.3 +fi +if test -r CrtChannel.3; then + rm -f Tcl_SetDefaultTranslation.3 + ln CrtChannel.3 Tcl_SetDefaultTranslation.3 +fi +if test -r DoubleObj.3; then + rm -f Tcl_SetDoubleObj.3 + ln DoubleObj.3 Tcl_SetDoubleObj.3 +fi +if test -r SetErrno.3; then + rm -f Tcl_SetErrno.3 + ln SetErrno.3 Tcl_SetErrno.3 +fi +if test -r AddErrInfo.3; then + rm -f Tcl_SetErrorCode.3 + ln AddErrInfo.3 Tcl_SetErrorCode.3 +fi +if test -r Hash.3; then + rm -f Tcl_SetHashValue.3 + ln Hash.3 Tcl_SetHashValue.3 +fi +if test -r IntObj.3; then + rm -f Tcl_SetIntObj.3 + ln IntObj.3 Tcl_SetIntObj.3 +fi +if test -r ListObj.3; then + rm -f Tcl_SetListObj.3 + ln ListObj.3 Tcl_SetListObj.3 +fi +if test -r IntObj.3; then + rm -f Tcl_SetLongObj.3 + ln IntObj.3 Tcl_SetLongObj.3 +fi +if test -r Notifier.3; then + rm -f Tcl_SetMaxBlockTime.3 + ln Notifier.3 Tcl_SetMaxBlockTime.3 +fi +if test -r StringObj.3; then + rm -f Tcl_SetObjLength.3 + ln StringObj.3 Tcl_SetObjLength.3 +fi +if test -r SetResult.3; then + rm -f Tcl_SetObjResult.3 + ln SetResult.3 Tcl_SetObjResult.3 +fi +if test -r SetRecLmt.3; then + rm -f Tcl_SetRecursionLimit.3 + ln SetRecLmt.3 Tcl_SetRecursionLimit.3 +fi +if test -r SetResult.3; then + rm -f Tcl_SetResult.3 + ln SetResult.3 Tcl_SetResult.3 +fi +if test -r Notifier.3; then + rm -f Tcl_SetServiceMode.3 + ln Notifier.3 Tcl_SetServiceMode.3 +fi +if test -r GetStdChan.3; then + rm -f Tcl_SetStdChannel.3 + ln GetStdChan.3 Tcl_SetStdChannel.3 +fi +if test -r StringObj.3; then + rm -f Tcl_SetStringObj.3 + ln StringObj.3 Tcl_SetStringObj.3 +fi +if test -r Notifier.3; then + rm -f Tcl_SetTimer.3 + ln Notifier.3 Tcl_SetTimer.3 +fi +if test -r SetVar.3; then + rm -f Tcl_SetVar.3 + ln SetVar.3 Tcl_SetVar.3 +fi +if test -r SetVar.3; then + rm -f Tcl_SetVar2.3 + ln SetVar.3 Tcl_SetVar2.3 +fi +if test -r Sleep.3; then + rm -f Tcl_Sleep.3 + ln Sleep.3 Tcl_Sleep.3 +fi +if test -r SplitList.3; then + rm -f Tcl_SplitList.3 + ln SplitList.3 Tcl_SplitList.3 +fi +if test -r SplitPath.3; then + rm -f Tcl_SplitPath.3 + ln SplitPath.3 Tcl_SplitPath.3 +fi +if test -r StaticPkg.3; then + rm -f Tcl_StaticPackage.3 + ln StaticPkg.3 Tcl_StaticPackage.3 +fi +if test -r StrMatch.3; then + rm -f Tcl_StringMatch.3 + ln StrMatch.3 Tcl_StringMatch.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Tell.3 + ln OpenFileChnl.3 Tcl_Tell.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_TraceVar.3 + ln TraceVar.3 Tcl_TraceVar.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_TraceVar2.3 + ln TraceVar.3 Tcl_TraceVar2.3 +fi +if test -r Translate.3; then + rm -f Tcl_TranslateFileName.3 + ln Translate.3 Tcl_TranslateFileName.3 +fi +if test -r LinkVar.3; then + rm -f Tcl_UnlinkVar.3 + ln LinkVar.3 Tcl_UnlinkVar.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_UnregisterChannel.3 + ln OpenFileChnl.3 Tcl_UnregisterChannel.3 +fi +if test -r SetVar.3; then + rm -f Tcl_UnsetVar.3 + ln SetVar.3 Tcl_UnsetVar.3 +fi +if test -r SetVar.3; then + rm -f Tcl_UnsetVar2.3 + ln SetVar.3 Tcl_UnsetVar2.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_UntraceVar.3 + ln TraceVar.3 Tcl_UntraceVar.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_UntraceVar2.3 + ln TraceVar.3 Tcl_UntraceVar2.3 +fi +if test -r UpVar.3; then + rm -f Tcl_UpVar.3 + ln UpVar.3 Tcl_UpVar.3 +fi +if test -r UpVar.3; then + rm -f Tcl_UpVar2.3 + ln UpVar.3 Tcl_UpVar2.3 +fi +if test -r LinkVar.3; then + rm -f Tcl_UpdateLinkedVar.3 + ln LinkVar.3 Tcl_UpdateLinkedVar.3 +fi +if test -r Eval.3; then + rm -f Tcl_VarEval.3 + ln Eval.3 Tcl_VarEval.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_VarTraceInfo.3 + ln TraceVar.3 Tcl_VarTraceInfo.3 +fi +if test -r TraceVar.3; then + rm -f Tcl_VarTraceInfo2.3 + ln TraceVar.3 Tcl_VarTraceInfo2.3 +fi +if test -r Notifier.3; then + rm -f Tcl_WaitForEvent.3 + ln Notifier.3 Tcl_WaitForEvent.3 +fi +if test -r OpenFileChnl.3; then + rm -f Tcl_Write.3 + ln OpenFileChnl.3 Tcl_Write.3 +fi +if test -r WrongNumArgs.3; then + rm -f Tcl_WrongNumArgs.3 + ln WrongNumArgs.3 Tcl_WrongNumArgs.3 +fi +if test -r pkgMkIndex.n; then + rm -f pkg_mkIndex.n + ln pkgMkIndex.n pkg_mkIndex.n +fi +exit 0 diff --git a/unix/porting.notes b/unix/porting.notes new file mode 100644 index 0000000..2d0a403 --- /dev/null +++ b/unix/porting.notes @@ -0,0 +1,412 @@ +This file contains a collection of notes that various people have +provided about porting Tcl to various machines and operating systems. +I don't have personal access to any of these machines, so I make +no guarantees that the notes are correct, complete, or up-to-date. +If you see the word "I" in any explanations, it refers to the person +who contributed the information, not to me; this means that I +probably can't answer any questions about any of this stuff. In +some cases, a person has volunteered to act as a contact point for +questions about porting Tcl to a particular machine; in these +cases the person's name and e-mail address are listed. I'm +interested in getting new porting information to add to the file; +please mail updates to "john.ousterhout@eng.sun.com". + +This file reflects information provided for Tcl 7.4 and later releases (8.x). +If there is no information for your configuration in this file, check +the file "porting.old" too; it contains information that was +submitted for Tcl 7.3 and earlier releases, and some of that information +may still be valid. + +A new porting database has recently become available on the Web at +the following URL: + http://www.sunlabs.com/cgi-bin/tcl/info.8.0 +This page provides information about the platforms on which Tcl and +and Tk 8.0 have been compiled and what changes were needed to get Tcl +and Tk to compile. You can also add new entries to that database +when you install Tcl and Tk on a new platform. The Web database is +likely to be more up-to-date than this file. + +sccsid = SCCS: @(#) porting.notes 1.20 97/11/03 09:43:40 + +-------------------------------------------- +Solaris, various versions +-------------------------------------------- + +1. If typing "make test" results in an error message saying that +there are no "*.test" files, or you get lots of globbing errors, +it's probably because your system doesn't have cc installed and +you used gcc. In order for this to work, you have to set your +CC environment variable to gcc and your CPP environment variable +to "gcc -E" before running the configure script. + +2. Make sure that /usr/ucb is not in your PATH or LD_LIBRARY_PATH +environment variables; this will cause confusion between the new +Solaris libraries and older UCB versions (Tcl will expect one version +and get another). + +3. There have been several reports of problems with the "glob" command. +So far these reports have all been for older versions of Tcl, but +if you run into problems, edit the Makefile after "configure" is +run and add "-DNO_DIRENT_H=1" to the definitions of DEFS. Do this +before compiling. + +-------------------------------------------- +SunOS 4 and potentially other OSes +-------------------------------------------- + +On systems where both getcwd(3) and getwd(3) exist, check the man +page and if getcwd, like on SunOS 4, uses popen to pwd(1) +add -DUSEGETWD to the flags CFLAGS so getwd will be used instead. + +That is, change the CFLAGS = -O line so it reads +CFLAGS = -O -DUSEGETWD + +-------------------------------------------- +Linux, ELF, various versions/distributions +-------------------------------------------- + +If ./configure --enable-shared complains it can not do a shared +library you might have to make the following symbolic link: +ln -s /lib/libdl.so.1 /lib/libdl.so +then remove config.cache and re run configure. + +-------------------------------------------- +Pyramid DC/OSx SVr4, DC/OSx version 94c079 +-------------------------------------------- + +Tcl seems to dump core in cmdinfo.test when compiled with the +optimiser turned on in TclEval which calls 'free'. To get around +this, turn the optimiser off. + +-------------------------------------------- +SGI machines, IRIX 5.2, 5.3, IRIX64 6.0.1 +-------------------------------------------- + +1. If you compile with gcc-2.6.3 under some versions of IRIX (e.g. + 4.0.5), DBL_MAX is defined too large for gcc and Tcl complains + about all floating-point values being too large to represent. + If this happens, redefining DBL_MAX to 9.99e299. + +2. Add "-D_BSD_TIME" to CFLAGS in Makefile. This avoids type conflicts +in the prototype for the gettimeofday procedure. + +2. If you're running under Irix 6.x and tclsh dumps core, try +removing -O from the CFLAGS in Makefile and recompiling; compiler +optimizations seem to cause problems on some machines. + +-------------------------------------------- +IBM RTs, AOS +-------------------------------------------- + +1. Steal fmod from 4.4BSD +2. Add a #define to tclExpr such that: +extern double fmod(); +is defined conditionally on ibm032 + +-------------------------------------------- +QNX 4.22 +-------------------------------------------- + +tclPort.h + - commented out 2 lines containing #include <sys/param.h> + +tcl.h + - changed #define VARARGS () + - to #ifndef __QNX__ + #define VARARGS () + #else + #define VARARGS (void *, ...) + #endif + +-------------------------------------------- +Interactive UNIX +-------------------------------------------- + +Add the switch -Xp to LIBS in Makefile; otherwise strftime will not +be found when linking. + +-------------------------------------------- +Motorola SVR4 V4.2 (m88k) +-------------------------------------------- + +For Motorola Unix R40V4.2 (m88k architechure), use /usr/ucb/cc instead of +/usr/bin/cc. Otherwise, the compile will fail because of conflicts over +the gettimeofday() call. + +Also, -DNO_DIRENT_H=1 is required for the "glob" command to work. + +-------------------------------------------- +NeXTSTEP 3.x +-------------------------------------------- + +Here's the set of changes I made to make 7.5b3 compile cleanly on +NeXTSTEP3.x. + +Here are a couple lines from unix/Makefile: + +# Added utsname.o, which implements a uname() emulation for NeXTSTEP. +COMPAT_OBJS = getcwd.o strtod.o tmpnam.o utsname.o + +TCL_NAMES=\ + -Dstrtod=tcl_strtod -Dtmpnam=tcl_tmpnam -Dgetcwd=tcl_getcwd \ + -Dpanic=tcl_panic -Dmatherr=tcl_matherr \ + -Duname=tcl_uname -Dutsname=tcl_utsname + +# Added mode_t, pid_t, and O_NONBLOCK definitions. +AC_FLAGS = -DNO_DIRENT_H=1 -DHAVE_UNISTD_H=1 -DHAVE_SYS_TIME_H=1 +-DTIME_WITH_SYS_TIME=1 -DHAVE_TM_ZONE=1 -DHAVE_TM_GMTOFF=1 -DHAVE_TIMEZONE_VAR=1 +-DSTDC_HEADERS=1 -Dmode_t=int -Dpid_t=int -DO_NONBLOCK=O_NDELAY ${TCL_NAMES} + + +Here are diffs for other files. utsname.[hc] are a couple files I added +to compat/ I'm not clear whether that's where they legitimately belong +- I considered stashing them in tclLoadNext.c instead. The tclIO.c +change was a bug, I believe, which I reported on comp.lang.tcl and +has apparently been noted and fixed. The objc_loadModules() change +allows "load" to load object code containing Objective-C code in +addition to plain C code. + +--- +scott hess <shess@winternet.com> (WWW to "http://www.winternet.com/~shess/") +Work: 12550 Portland Avenue South #121, Burnsville, MN 55337 (612)895-1208 + + +diff -rc tcl7.5b3.orig/compat/utsname.c tcl7.5b3/compat/utsname.c +*** tcl7.5b3.orig/compat/utsname.c Tue Apr 2 13:57:23 1996 +--- tcl7.5b3/compat/utsname.c Mon Mar 18 11:05:54 1996 +*************** +*** 0 **** +--- 1,27 ---- ++ /* ++ * utsname.c -- ++ * ++ * This file is an emulation of the POSIX uname() function ++ * under NeXTSTEP 3.x. ++ * ++ */ ++ + ++ #include "utsname.h" ++ #include <mach-o/arch.h> ++ #include <stdio.h> ++ + ++ int uname( struct utsname *name) ++ { ++ const NXArchInfo *arch; ++ if( gethostname( name->nodename, sizeof( name->nodename))==-1) { ++ return -1; ++ } ++ if( (arch=NXGetLocalArchInfo())==NULL) { ++ return -1; ++ } ++ strncpy( name->machine, arch->description, sizeof( name->machine)); ++ strcpy( name->sysname, "NEXTSTEP"); ++ strcpy( name->release, "0"); ++ strcpy( name->version, "3"); ++ return 0; ++ } +diff -rc tcl7.5b3.orig/compat/utsname.h tcl7.5b3/compat/utsname.h +*** tcl7.5b3.orig/compat/utsname.h Tue Apr 2 13:57:26 1996 +--- tcl7.5b3/compat/utsname.h Mon Mar 18 10:34:05 1996 +*************** +*** 0 **** +--- 1,22 ---- ++ /* ++ * utsname.h -- ++ * ++ * This file is an emulation of the POSIX uname() function ++ * under NeXTSTEP. ++ * ++ */ ++ + ++ #ifndef _UTSNAME ++ #define _UTSNAME ++ + ++ struct utsname { ++ char sysname[ 32]; ++ char nodename[ 32]; ++ char release[ 32]; ++ char version[ 32]; ++ char machine[ 32]; ++ }; ++ + ++ extern int uname( struct utsname *name); ++ + ++ #endif /* _UTSNAME */ +diff -rc tcl7.5b3.orig/generic/tclIO.c tcl7.5b3/generic/tclIO.c +*** tcl7.5b3.orig/generic/tclIO.c Fri Mar 8 12:59:53 1996 +--- tcl7.5b3/generic/tclIO.c Mon Mar 18 11:38:57 1996 +*************** +*** 2542,2548 **** + } + result = GetInput(chanPtr); + if (result != 0) { +! if (result == EWOULDBLOCK) { + chanPtr->flags |= CHANNEL_BLOCKED; + return copied; + } +--- 2542,2548 ---- + } + result = GetInput(chanPtr); + if (result != 0) { +! if (result == EAGAIN) { + chanPtr->flags |= CHANNEL_BLOCKED; + return copied; + } +diff -rc tcl7.5b3.orig/unix/tclLoadNext.c tcl7.5b3/unix/tclLoadNext.c +*** tcl7.5b3.orig/unix/tclLoadNext.c Sat Feb 17 16:16:42 1996 +--- tcl7.5b3/unix/tclLoadNext.c Mon Mar 18 10:02:36 1996 +*************** +*** 55,61 **** + char *files[]={fileName,NULL}; + NXStream *errorStream=NXOpenMemory(0,0,NX_READWRITE); + + +! if(!rld_load(errorStream,&header,files,NULL)) { + NXGetMemoryBuffer(errorStream,&data,&len,&maxlen); + Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL); + NXCloseMemory(errorStream,NX_FREEBUFFER); +--- 55,61 ---- + char *files[]={fileName,NULL}; + NXStream *errorStream=NXOpenMemory(0,0,NX_READWRITE); + + +! if(objc_loadModules(files,errorStream,NULL,&header,NULL)) { + NXGetMemoryBuffer(errorStream,&data,&len,&maxlen); + Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL); + NXCloseMemory(errorStream,NX_FREEBUFFER); +diff -rc tcl7.5b3.orig/unix/tclUnixFile.c tcl7.5b3/unix/tclUnixFile.c +*** tcl7.5b3.orig/unix/tclUnixFile.c Thu Mar 7 18:16:34 1996 +--- tcl7.5b3/unix/tclUnixFile.c Mon Mar 18 11:10:03 1996 +*************** +*** 31,37 **** +--- 31,41 ---- + + + static int executableNameExitHandlerSet = 0; + + ++ #if NeXT ++ #define waitpid( p, s, o) wait4( p, s, o, NULL) ++ #else + extern pid_t waitpid _ANSI_ARGS_((pid_t pid, int *stat_loc, int options)); ++ #endif + + + /* + * Static routines for this file: +diff -rc tcl7.5b3.orig/unix/tclUnixInit.c tcl7.5b3/unix/tclUnixInit.c +*** tcl7.5b3.orig/unix/tclUnixInit.c Sat Feb 17 16:16:39 1996 +--- tcl7.5b3/unix/tclUnixInit.c Mon Mar 18 11:50:28 1996 +*************** +*** 14,20 **** + #include "tclInt.h" + #include "tclPort.h" + #ifndef NO_UNAME +! # include <sys/utsname.h> + #endif + #if defined(__FreeBSD__) + #include <floatingpoint.h> +--- 14,24 ---- + #include "tclInt.h" + #include "tclPort.h" + #ifndef NO_UNAME +! # if NeXT +! # include "../compat/utsname.h" +! # else +! # include <sys/utsname.h> +! # endif + #endif + #if defined(__FreeBSD__) + #include <floatingpoint.h> +diff -rc tcl7.5b3.orig/unix/tclUnixPort.h tcl7.5b3/unix/tclUnixPort.h +*** tcl7.5b3.orig/unix/tclUnixPort.h Thu Mar 7 18:16:31 1996 +--- tcl7.5b3/unix/tclUnixPort.h Mon Mar 18 11:53:14 1996 +*************** +*** 76,82 **** + */ + + + #include <sys/socket.h> /* struct sockaddr, SOCK_STREAM, ... */ +! #include <sys/utsname.h> /* uname system call. */ + #include <netinet/in.h> /* struct in_addr, struct sockaddr_in */ + #include <arpa/inet.h> /* inet_ntoa() */ + #include <netdb.h> /* gethostbyname() */ +--- 76,88 ---- + */ + + + #include <sys/socket.h> /* struct sockaddr, SOCK_STREAM, ... */ +! #ifndef NO_UNAME +! # if NeXT +! # include "../compat/utsname.h" +! # else +! # include <sys/utsname.h> /* uname system call. */ +! # endif +! #endif + #include <netinet/in.h> /* struct in_addr, struct sockaddr_in */ + #include <arpa/inet.h> /* inet_ntoa() */ + #include <netdb.h> /* gethostbyname() */ + +-------------------------------------------- +SCO Unix 3.2.4 (ODT 3.0) +-------------------------------------------- + +The macro va_start in /usr/include/stdarg.h is incorrectly terminated by +a semi-colon. This causes compile of generic/tclBasic.c to fail. The +best solution is to edit the definition of va_start to remove the `;'. +This will fix this file for anything you want to compile. If you don't have +permission to edit /usr/include/stdarg.h in place, copy it to the tcl unix +directory and change it there. + +Contact me directly if you have problems on SCO systems. +Mark Diekhans <markd@grizzly.com> + +-------------------------------------------- +SCO Unix 3.2.5 (ODT 5.0) +-------------------------------------------- + +Expect failures from socket tests 2.9 and 3.1. + +Contact me directly if you have problems on SCO systems. +Mark Diekhans <markd@grizzly.com> + +-------------------------------------------- +Linux 1.2.13 (gcc 2.7.0, libc.so.5.0.9) +-------------------------------------------- + +Symptoms: + +* Some extensions could not be loaded dynamically, most + prominently Blt 2.0 + + The given error message essentially said: + Could not resolve symbol '__eprintf'. + + (This procedure is used by the macro 'assert') + +Cause + +* '__eprintf' is defined in 'libgcc.a', not 'libc.so.x.y'. + It is therefore impossible to load it dynamically. + +* Neither tcl nor tk make use of 'assert', thereby + preventing a static linkage. + +Workaround + +* I included <assert.h> in 'tclAppInit.c' / 'tkAppInit.c' + and then executed 'assert (argc)' just before the call + to Tcl_Main / Tk_Main. + + This forced the static linkage of '__eprintf' and + everything went fine from then on. + + (Something like 'assert (1)', 'assert (a==a)' is not + sufficient, it will be optimized away). + diff --git a/unix/porting.old b/unix/porting.old new file mode 100644 index 0000000..e312de0 --- /dev/null +++ b/unix/porting.old @@ -0,0 +1,384 @@ +This is an old version of the file "porting.notes". It contains +porting information that people submitted for Tcl releases numbered +7.3 and earlier. You may find information in this file useful if +there is no information available for your machine in the current +version of "porting.notes". + +I don't have personal access to any of these machines, so I make +no guarantees that the notes are correct, complete, or up-to-date. +If you see the word "I" in any explanations, it refers to the person +who contributed the information, not to me; this means that I +probably can't answer any questions about any of this stuff. In +some cases, a person has volunteered to act as a contact point for +questions about porting Tcl to a particular machine; in these +cases the person's name and e-mail address are listed. + +sccsid = SCCS: @(#) porting.old 1.3 96/02/16 08:56:07 + +--------------------------------------------- +Cray machines running UNICOS: +Contact: John Freeman (jlf@cray.com) +--------------------------------------------- + +1. There is an error in the strstr function in UNICOS such that if the +string to be searched is empty (""), the search will continue past the +end of the string. Because of this, the history substitution loop +will sometimes run past the end of its target string and trash +malloc's free list, resulting in a core dump some time later. (As you +can probably guess, this took a while to diagnose.) I've submitted a +problem report to the C library maintainers, but in the meantime here +is a workaround. + +----------------------------------------------------------------- +diff -c1 -r1.1 tclHistory.c +*** 1.1 1991/11/12 16:01:58 +--- tclHistory.c 1991/11/12 16:14:22 +*************** +*** 23,24 **** +--- 23,29 ---- + #include "tclInt.h" ++ ++ #ifdef _CRAY ++ /* There is a bug in strstr in UNICOS; this works around it. */ ++ #define strstr(s1,s2) ((s1)?(*(s1)?strstr((s1),(s2)):0):0) ++ #endif _CRAY + +--------------------------------------------- +MIPS systems runing EP/IX: +--------------------------------------------- + +1. Need to add a line "#include <bsd/sys/time.h>" in tclUnix.h. + +2. Need to add "-lbsd" into the line that makes tclTest: + + ${CC} ${CFLAGS} tclTest.o libtcl.a -lbsd -o tclTest + +--------------------------------------------- +IBM RS/6000 systems running AIX: +--------------------------------------------- + +1. The system version of strtoul is buggy, at least under some +versions of AIX. If the expression tests fail, try forcing Tcl +to use its own version of strtoul instead of the system version. +To do this, first copy strtoul.c from the compat subdirectory up +to the main Tcl directory. Then modify the Makefile so that +the definition for COMPAT_OBJS includes "strtoul.o". Note: the +"config" script should now detect the buggy strtoul and substitute +Tcl's version automatically. + +2. You may have to comment out the declaration of open in tclUnix.h. + +3. You may need to add "-D_BSD -lbsd" to the CFLAGS definition. This +causes the system include files to look like BSD include files and +causes C library routines to act like bsd library routines. Without +this, the system may choke on "struct wait". + +--------------------------------------------- +AT&T 4.03 OS: +--------------------------------------------- + +Machine: i386/33Mhz i387 32k Cache 16MByte +OS: AT&T SYSV Release 4 Version 3 +X: X11R5 fixlevel 9 +Xserver: X386 1.2 + +1. Change the Tk Makefile as follows: +XLIB = -lX11 + should be changed to: +XLIB = -lX11 -lsocket -lnsl + +------------------------------------------------------- +Silicon Graphics systems: +------------------------------------------------------- + +1. Change the CC variable in the Makefile to: + +CC = cc -xansi -D__STDC__ -signed + +2. In Irix releases 4.0.1 or earlier the C compiler has a buggy optimizer. + If Tcl fails its test suite or generates inexplicable errors, + compile tclVar.c with -O0 instead of -O. + +3. For IRIX 5.1 or later, comments 1 and 2 are no longer relevant, +but you must add -D_BSD_SIGNALS to CFLAGS to get the proper signal +routines. + +4. Add a "-lsun" switch in the targets for tclsh and tcltest, +just before ${MATH_LIBS}. + +5. Rumor has it that you also need to add the "-lmalloc" library switch +in the targets for tclsh and tcltest. + +6. In IRIX 5.2 you'll have to modify Makefile to fix the following problems: + - The "-c" option is illegal with this version of install, but + the "-F" switch is needed instead. Change this in the "INSTALL =" + definition line. + - The order of file and directory have to be changed in all the + invocations of INSTALL_DATA or INSTALL_PROGRAM. + +--------------------------------------------- +NeXT machines running NeXTStep 3.1: +--------------------------------------------- + +1. Run configure with predefined CPP: + CPP='cc -E' ./configure + (If your shell is [t]csh, do a "setenv CPP 'cc -E' ") + +2. Edit Makefile: + -add tmpnam.o to COMPAT_OBJS: + COMPAT_OBJS = getcwd.o waitpid.o strtod.o tmpnam.o + -add the following to AC_FLAGS: + -Dstrtod=tcl_strtod + +3. Edit compat/tmpnam.c and replace "/usr/tmp" with "/tmp" + +After this, tcl7.0 will be build fine on NeXT (ignore linker warning) +and run all the tests. There are some formatting problems in printf() or +scanf() which come from NeXT's lacking POSIX conformance. Ignore those +errors, they don't matter much. + +4. Additional information that may apply to NeXTStep 3.2 only: + + The problem on NEXTSTEP 3.2 is that the configure script makes some + bad assumptions about the uid_t and gid_t types. Actually, the may + have been valid for NEXTSTEP 3.0, or it may be NEXTSTEP's rudimentary + attempt at POSIX support under 3.2, but no matter what the reason, the + configure script sets up the Makefile with CFLAGS '-Duid_t=int' and + '-Dgid_t=int', which are, unfortunately, incorrect, since they shoudl + actually be (I think) unsigned shorts. This causes problems when the + 'stat' structure is included, since it throws off the field offsets + from what the 'fstat' function thinks they should be. + + Anyway, the quick fix is to run configure and then edit the Makefile + to remove the uid_t and gid_t defines. This will allow tcl and Tk to + compile and run. There are some other problems on NEXTSTEP, + specifically with %g in the printf family of functions, but making the + uid_t and gid_t change will get it up and running. + +--------------------------------------------- +NeXT machines running NeXTStep 3.2: +--------------------------------------------- + +1. Run configure with predefined CPP: + CPP='cc -E' ./configure + (If your shell is [t]csh, do a "setenv CPP 'cc -E' ") + +2. Edit Makefile: + -add tmpnam.o to COMPAT_OBJS: + COMPAT_OBJS = getcwd.o waitpid.o strtod.o tmpnam.o + -add the following to AC_FLAGS: + -Dstrtod=tcl_strtod + -add '-m' to MATH_LIBS: + MATH_LIBS = -m -lm + -add '-O2 -arch m68k -arch i386' to CFLAGS: + CFLAGS = -O2 -arch m68k -arch i386 + +------------------------------------------------- +ISC 2.2 UNIX (using standard ATT SYSV compiler): +------------------------------------------------- + +In Makefile, change + +CFLAGS = -g -I. -DTCL_LIBRARY=\"${TCL_LIBRARY}\" + +to + +CFLAGS = -g -I. -DPOSIX_JC -DTCL_LIBRARY=\"${TCL_LIBRARY}\" + +This brings in the typedef for pid_t, which is needed for +/usr/include/sys/wait.h in tclUnix.h. + +--------------------------------------------- +DEC Alphas: +--------------------------------------------- + +1. There appears to be a compiler/library bug that causes core-dumps +unless you compile tclVar.c without optimization (remove the -O compiler +switch). The problem appears to have been fixed in the 1.3-4 version +of the compiler. + +--------------------------------------------- +CDC 4680MP, EP/IX 1.4.3: +--------------------------------------------- + +The installation was done in the System V environment (-systype sysv) +with the BSD extensions available (-I/usr/include/bsd and -lbsd). It was +built with the 2.20 level C compiler. The 2.11 level should not be used +because it has a problem with detecting NaN values in lines like: + if (x != x) ... +which appear in the TCL code. + +To make the configure script find the BSD extensions, I set environment +variable DEFS to "-I/usr/include/bsd" and LIBS to "-lbsd" before +running it. I would have also set CC to "cc2.20", but that compiler +driver has a bug that loader errors (e.g. not finding a library routine, +which the script uses to tell what is available) do not cause an error +status to be returned to the shell (but see the comments about "-non_shared" +below in the 2.1.1 notes). + +There is a bug in the <sys/wait.h> include file that mis-defines the +structure fields and causes WIFEXITED and WIFSIGNALED to return incorrect +values. My solution was to create a subdirectory "sys" of the main TCL +source directory and put a corrected wait.h in it. The "-I." already on +all the compile lines causes it to be used instead of the system version. +To fix this, compare the structure definition in /usr/include/bsd/sys/wait.h +with /bsd43/include/sys/wait.h (or mail to John Jackson, jrj@cc.purdue.edu, +and he'll send you a context diff). + +After running configure, I made the following changes to Makefile: + + 1) In AC_FLAGS, change: + -DNO_WAIT3=1 + to + -DNO_WAIT3=0 -Dwait3=wait2 + EP/IX (in the System V environment) provides a wait2() system + call with what TCL needs (the WNOHANG flag). The extra parameter + TCL passes to what it thinks is wait3() (the resources used by + the child process) is always zero and will be safely ignored. + + 2) Change: + CC=cc + to + CC=cc2.20 + because of the NaN problem mentioned earlier. Skip this if the + default compiler is already 2.20 (or later). + + 3) Add "-lbsd" to the commands that create tclsh and tcltest + (look for "-o"). + +--------------------------------------------- +CDC 4680MP, EP/IX 2.1.1: +--------------------------------------------- + +The installation was done in the System V environment (-systype sysv) +with the BSD extensions available (-I/usr/include/bsd and -lbsd). It was +built with the 3.11 level C compiler. The 2.11 level should not be used +because it has a problem with detecting NaN values in lines like: + if (x != x) ... +which appear in the TCL code. The 2.20 compiler does not have this +problem. + +To make the configure script find the BSD extensions, I set environment +variable DEFS to: + + "-I/usr/include/bsd -D__STDC__=0 -non_shared" + +and LIBS to: + + "-lbsd" + +before running it. The "-non_shared" is needed because with shared +libraries, the compiler (actually, the loader) does not report an +error for "missing" routines. The configuration script depends on this +error to know what routines are available. This is the real problem +I reported above for EP/IX 1.4.3 that I incorrectly attributed to a +compiler driver bug. I don't have 1.4.3 available any more, but it's +possible using "-non_shared" on it would have solved the problem. + +The same <sys/wait.h> bug exists at 2.1.1 (yes, I have reported it to +CDC), and the same fix as described in the 1.4.3 porting notes works. + +In addition to the three Makefile changes described in the 1.4.3 notes, +you can remove the "-non_shared" flag from AC_FLAGS. It is only needed +for the configuration step, not the build. + +You will get duplicate definition compilation warnings of: + + DBL_MIN + DBL_MAX + FLT_MIN + FLT_MAX + +during tclExpr.c. These can be ignored. + +During expr.test, you will get a failure for one of the "fmod" tests +unless you have CDC patch CC40038311 installed. + +--------------------------------------------- +Convex systems, OS 10.1 and 10.2: +Contact: Lennart Sorth (ls@dmi.min.dk) +--------------------------------------------- + +1. tcl7.0b2 compiles on Convex systems (OS 10.1 and 10.2) by just running + configure, typing make, except tclUnixUtil.c needs to be compiled + with option "-pcc" (portable cc, =!ANSI) due to: + cc: Error on line 1111 of tclUnixUtil.c: 'waitpid' redeclared: + incompatible types. + +------------------------------------------------- +Pyramid, OSx 5.1a (UCB universe, GCC installed): +------------------------------------------------- + +1. The procedures memcpy, strchr, fmod, and strrchr are all missing, +so you'll need to provide substitutes for them. After you do that +everything should compile fine. There will be one error in a scan +test, but it's an obscure one because of a non-ANSI implementation +of sscanf on the machine; you can ignore it. + +2. You may also have to add "tmpnam.o" to COMPAT_OBJS in Makefile: +the system version appears to be bad. + +------------------------------------------------- +Encore 91, UMAX V 3.0.9.3: +------------------------------------------------- + +1. Modify the CFLAGS assignment in file Makefile.in to include the +-DENCORE flag in Makefile: + + CFLAGS = -O -DENCORE + +2. "mkdir" does not by default create the parent directories. The mkdir +directives should be modified to "midir -p". + +------------------------------------------------- +Sequent machines running Dynix: +Contact: Andrew Swan (aswan@soda.berkeley.edu) +------------------------------------------------- + +1. Use gcc instead of the cc distributed by Sequent + +2. The distributed math library does not include the fmod + function. Source for fmod can be retrieved from a BSD + source archive (such as ftp.uu.net) and included in the + compat directory. Add fmod.o to the COMPAT_OBJS variable + in the Makefile. You may need to comment out references + to 'isnan' and 'finite' in fmod.c + +3. If the linker complains that there are two copies of the + 'tanh' function, use the ar command to extract the objects + from the math library and build a new one without tanh.o + +4. The *scanf functions in the Sequent libraries are apparently + broken, which will cause the scanning tests to fail. The + cases that fail are fairly obscure. Using GNU libc apparently + solves this problem. + +------------------------------------------------- +Systems running Interactive 4.0: +------------------------------------------------- + +1. Add "-posix -D_SYSV3" to CFLAGS in Makefile (or Makefile.in). + +------------------------------------------------- +Systems running FreeBSD 1.1.5.1: +------------------------------------------------- + +The following changes comprise the entire porting effort of tcl7.3 to +FreeBSD (i.e. these were the changes to tclTest.c) and should probably +be made part of the tcl distribution. The changes only effect the way that +floating point exceptions are reported. I've choosen to move the changes +out of tclTest.c and into tclBasic.c. + +in tclBasic.c at top-of-file: + +#ifdef BSD_NET2 +#include <floatingpoint.h> +#endif + +in tclBasic.c in Tcl_Init(): + +#ifdef BSD_NET2 + fpsetround(FP_RN); + fpsetmask(0L); +#endif + diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c new file mode 100644 index 0000000..fafa31e --- /dev/null +++ b/unix/tclAppInit.c @@ -0,0 +1,136 @@ +/* + * tclAppInit.c -- + * + * Provides a default version of the main program and Tcl_AppInit + * procedure for Tcl applications (without Tk). + * + * Copyright (c) 1993 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclAppInit.c 1.20 97/03/24 14:29:43 + */ + +#ifdef TCL_XT_TEST +#include <X11/Intrinsic.h> +#endif + +#include "tcl.h" + +/* + * The following variable is a special hack that is needed in order for + * Sun shared libraries to be used for Tcl. + */ + +extern int matherr(); +int *tclDummyMathPtr = (int *) matherr; + + +#ifdef TCL_TEST +EXTERN int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +#endif /* TCL_TEST */ +#ifdef TCL_XT_TEST +EXTERN int Tclxttest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +#endif + +/* + *---------------------------------------------------------------------- + * + * main -- + * + * This is the main program for the application. + * + * Results: + * None: Tcl_Main never returns here, so this procedure never + * returns either. + * + * Side effects: + * Whatever the application does. + * + *---------------------------------------------------------------------- + */ + +int +main(argc, argv) + int argc; /* Number of command-line arguments. */ + char **argv; /* Values of command-line arguments. */ +{ +#ifdef TCL_XT_TEST + XtToolkitInitialize(); +#endif + Tcl_Main(argc, argv, Tcl_AppInit); + return 0; /* Needed only to prevent compiler warning. */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppInit -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AppInit(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + if (Tcl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + +#ifdef TCL_TEST +#ifdef TCL_XT_TEST + if (Tclxttest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } +#endif + if (Tcltest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, + (Tcl_PackageInitProc *) NULL); + if (TclObjTest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } +#endif /* TCL_TEST */ + + /* + * Call the init procedures for included packages. Each call should + * look like this: + * + * if (Mod_Init(interp) == TCL_ERROR) { + * return TCL_ERROR; + * } + * + * where "Mod" is the name of the module. + */ + + /* + * Call Tcl_CreateCommand for application-specific commands, if + * they weren't already created by the init procedures called above. + */ + + /* + * Specify a user-specific startup file to invoke if the application + * is run interactively. Typically the startup file is "~/.apprc" + * where "app" is the name of the application. If this line is deleted + * then no user-specific startup file will be run under any conditions. + */ + + Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY); + return TCL_OK; +} diff --git a/unix/tclConfig.sh.in b/unix/tclConfig.sh.in new file mode 100644 index 0000000..905aa84 --- /dev/null +++ b/unix/tclConfig.sh.in @@ -0,0 +1,116 @@ +# tclConfig.sh -- +# +# This shell script (for sh) is generated automatically by Tcl's +# configure script. It will create shell variables for most of +# the configuration options discovered by the configure script. +# This script is intended to be included by the configure scripts +# for Tcl extensions so that they don't have to figure this all +# out for themselves. +# +# The information in this file is specific to a single platform. +# +# SCCS: @(#) tclConfig.sh.in 1.20 97/07/01 11:40:19 + +# Tcl's version number. +TCL_VERSION='@TCL_VERSION@' +TCL_MAJOR_VERSION='@TCL_MAJOR_VERSION@' +TCL_MINOR_VERSION='@TCL_MINOR_VERSION@' +TCL_PATCH_LEVEL='@TCL_PATCH_LEVEL@' + +# C compiler to use for compilation. +TCL_CC='@CC@' + +# -D flags for use with the C compiler. +TCL_DEFS='@DEFS@' + +# Flag, 1: we built a shared lib, 0 we didn't +TCL_SHARED_BUILD=@TCL_SHARED_BUILD@ + +# The name of the Tcl library (may be either a .a file or a shared library): +TCL_LIB_FILE=@TCL_LIB_FILE@ + +# Additional libraries to use when linking Tcl. +TCL_LIBS='@DL_LIBS@ @LIBS@ @MATH_LIBS@' + +# Top-level directory in which Tcl's platform-independent files are +# installed. +TCL_PREFIX='@prefix@' + +# Top-level directory in which Tcl's platform-specific files (e.g. +# executables) are installed. +TCL_EXEC_PREFIX='@exec_prefix@' + +# Flags to pass to cc when compiling the components of a shared library: +TCL_SHLIB_CFLAGS='@SHLIB_CFLAGS@' + +# Base command to use for combining object files into a shared library: +TCL_SHLIB_LD='@SHLIB_LD@' + +# Either '$LIBS' (if dependent libraries should be included when linking +# shared libraries) or an empty string. See Tcl's configure.in for more +# explanation. +TCL_SHLIB_LD_LIBS='@SHLIB_LD_LIBS@' + +# Suffix to use for the name of a shared library. +TCL_SHLIB_SUFFIX='@SHLIB_SUFFIX@' + +# Library file(s) to include in tclsh and other base applications +# in order to provide facilities needed by DLOBJ above. +TCL_DL_LIBS='@DL_LIBS@' + +# Flags to pass to the compiler when linking object files into +# an executable tclsh or tcltest binary. +TCL_LD_FLAGS='@LD_FLAGS@' + +# Flags to pass to ld, such as "-R /usr/local/tcl/lib", that tell the +# run-time dynamic linker where to look for shared libraries such as +# libtcl.so. Used when linking applications. Only works if there +# is a variable "LIB_RUNTIME_DIR" defined in the Makefile. +TCL_LD_SEARCH_FLAGS='@TCL_LD_SEARCH_FLAGS@' + +# Additional object files linked with Tcl to provide compatibility +# with standard facilities from ANSI C or POSIX. +TCL_COMPAT_OBJS='@LIBOBJS@' + +# Name of the ranlib program to use. +TCL_RANLIB='@RANLIB@' + +# String to pass to linker to pick up the Tcl library from its +# build directory. +TCL_BUILD_LIB_SPEC='@TCL_BUILD_LIB_SPEC@' + +# String to pass to linker to pick up the Tcl library from its +# installed directory. +TCL_LIB_SPEC='@TCL_LIB_SPEC@' + +# Indicates whether a version numbers should be used in -l switches +# ("ok" means it's safe to use switches like -ltcl7.5; "nodots" means +# use switches like -ltcl75). SunOS and FreeBSD require "nodots", for +# example. +TCL_LIB_VERSIONS_OK='@TCL_LIB_VERSIONS_OK@' + +# String that can be evaluated to generate the part of a shared library +# name that comes after the "libxxx" (includes version number, if any, +# extension, and anything else needed). May depend on the variables +# VERSION and SHLIB_SUFFIX. On most UNIX systems this is +# ${VERSION}${SHLIB_SUFFIX}. +TCL_SHARED_LIB_SUFFIX='@TCL_SHARED_LIB_SUFFIX@' + +# String that can be evaluated to generate the part of an unshared library +# name that comes after the "libxxx" (includes version number, if any, +# extension, and anything else needed). May depend on the variable +# VERSION. On most UNIX systems this is ${VERSION}.a. +TCL_UNSHARED_LIB_SUFFIX='@TCL_UNSHARED_LIB_SUFFIX@' + +# Location of the top-level source directory from which Tcl was built. +# This is the directory that contains a README file as well as +# subdirectories such as generic, unix, etc. If Tcl was compiled in a +# different place than the directory containing the source files, this +# points to the location of the sources, not the location where Tcl was +# compiled. +TCL_SRC_DIR='@TCL_SRC_DIR@' + +# List of standard directories in which to look for packages during +# "package require" commands. Contains the "prefix" directory plus also +# the "exec_prefix" directory, if it is different. +TCL_PACKAGE_PATH='@TCL_PACKAGE_PATH@' diff --git a/unix/tclLoadAix.c b/unix/tclLoadAix.c new file mode 100644 index 0000000..edf33d6 --- /dev/null +++ b/unix/tclLoadAix.c @@ -0,0 +1,549 @@ +/* + * tclLoadAix.c -- + * + * This file implements the dlopen and dlsym APIs under the + * AIX operating system, to enable the Tcl "load" command to + * work. This code was provided by Jens-Uwe Mager. + * + * This file is subject to the following copyright notice, which is + * different from the notice used elsewhere in Tcl. The file has + * been modified to incorporate the file dlfcn.h in-line. + * + * Copyright (c) 1992,1993,1995,1996, Jens-Uwe Mager, Helios Software GmbH + * Not derived from licensed software. + + * Permission is granted to freely use, copy, modify, and redistribute + * this software, provided that the author is not construed to be liable + * for any results of using the software, alterations are clearly marked + * as such, and this notice is not modified. + * + * SCCS: @(#) tclLoadAix.c 1.11 96/10/07 10:41:24 + * + * Note: this file has been altered from the original in a few + * ways in order to work properly with Tcl. + */ + +/* + * @(#)dlfcn.c 1.7 revision of 95/08/14 19:08:38 + * This is an unpublished work copyright (c) 1992 HELIOS Software GmbH + * 30159 Hannover, Germany + */ + +#include <stdio.h> +#include <errno.h> +#include <string.h> +#include <stdlib.h> +#include <sys/types.h> +#include <sys/ldr.h> +#include <a.out.h> +#include <ldfcn.h> +#include "../compat/dlfcn.h" + +/* + * We simulate dlopen() et al. through a call to load. Because AIX has + * no call to find an exported symbol we read the loader section of the + * loaded module and build a list of exported symbols and their virtual + * address. + */ + +typedef struct { + char *name; /* the symbols's name */ + void *addr; /* its relocated virtual address */ +} Export, *ExportPtr; + +/* + * xlC uses the following structure to list its constructors and + * destructors. This is gleaned from the output of munch. + */ +typedef struct { + void (*init)(void); /* call static constructors */ + void (*term)(void); /* call static destructors */ +} Cdtor, *CdtorPtr; + +/* + * The void * handle returned from dlopen is actually a ModulePtr. + */ +typedef struct Module { + struct Module *next; + char *name; /* module name for refcounting */ + int refCnt; /* the number of references */ + void *entry; /* entry point from load */ + struct dl_info *info; /* optional init/terminate functions */ + CdtorPtr cdtors; /* optional C++ constructors */ + int nExports; /* the number of exports found */ + ExportPtr exports; /* the array of exports */ +} Module, *ModulePtr; + +/* + * We keep a list of all loaded modules to be able to call the fini + * handlers and destructors at atexit() time. + */ +static ModulePtr modList; + +/* + * The last error from one of the dl* routines is kept in static + * variables here. Each error is returned only once to the caller. + */ +static char errbuf[BUFSIZ]; +static int errvalid; + +static void caterr(char *); +static int readExports(ModulePtr); +static void terminate(void); +static void *findMain(void); + +VOID *dlopen(const char *path, int mode) +{ + register ModulePtr mp; + static void *mainModule; + + /* + * Upon the first call register a terminate handler that will + * close all libraries. Also get a reference to the main module + * for use with loadbind. + */ + if (!mainModule) { + if ((mainModule = findMain()) == NULL) + return NULL; + atexit(terminate); + } + /* + * Scan the list of modules if we have the module already loaded. + */ + for (mp = modList; mp; mp = mp->next) + if (strcmp(mp->name, path) == 0) { + mp->refCnt++; + return (VOID *) mp; + } + if ((mp = (ModulePtr)calloc(1, sizeof(*mp))) == NULL) { + errvalid++; + strcpy(errbuf, "calloc: "); + strcat(errbuf, strerror(errno)); + return (VOID *) NULL; + } + mp->name = malloc((unsigned) (strlen(path) + 1)); + strcpy(mp->name, path); + /* + * load should be declared load(const char *...). Thus we + * cast the path to a normal char *. Ugly. + */ + if ((mp->entry = (void *)load((char *)path, L_NOAUTODEFER, NULL)) == NULL) { + free(mp->name); + free(mp); + errvalid++; + strcpy(errbuf, "dlopen: "); + strcat(errbuf, path); + strcat(errbuf, ": "); + /* + * If AIX says the file is not executable, the error + * can be further described by querying the loader about + * the last error. + */ + if (errno == ENOEXEC) { + char *tmp[BUFSIZ/sizeof(char *)]; + if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1) + strcpy(errbuf, strerror(errno)); + else { + char **p; + for (p = tmp; *p; p++) + caterr(*p); + } + } else + strcat(errbuf, strerror(errno)); + return (VOID *) NULL; + } + mp->refCnt = 1; + mp->next = modList; + modList = mp; + if (loadbind(0, mainModule, mp->entry) == -1) { + dlclose(mp); + errvalid++; + strcpy(errbuf, "loadbind: "); + strcat(errbuf, strerror(errno)); + return (VOID *) NULL; + } + /* + * If the user wants global binding, loadbind against all other + * loaded modules. + */ + if (mode & RTLD_GLOBAL) { + register ModulePtr mp1; + for (mp1 = mp->next; mp1; mp1 = mp1->next) + if (loadbind(0, mp1->entry, mp->entry) == -1) { + dlclose(mp); + errvalid++; + strcpy(errbuf, "loadbind: "); + strcat(errbuf, strerror(errno)); + return (VOID *) NULL; + } + } + if (readExports(mp) == -1) { + dlclose(mp); + return (VOID *) NULL; + } + /* + * If there is a dl_info structure, call the init function. + */ + if (mp->info = (struct dl_info *)dlsym(mp, "dl_info")) { + if (mp->info->init) + (*mp->info->init)(); + } else + errvalid = 0; + /* + * If the shared object was compiled using xlC we will need + * to call static constructors (and later on dlclose destructors). + */ + if (mp->cdtors = (CdtorPtr)dlsym(mp, "__cdtors")) { + while (mp->cdtors->init) { + (*mp->cdtors->init)(); + mp->cdtors++; + } + } else + errvalid = 0; + return (VOID *) mp; +} + +/* + * Attempt to decipher an AIX loader error message and append it + * to our static error message buffer. + */ +static void caterr(char *s) +{ + register char *p = s; + + while (*p >= '0' && *p <= '9') + p++; + switch(atoi(s)) { + case L_ERROR_TOOMANY: + strcat(errbuf, "to many errors"); + break; + case L_ERROR_NOLIB: + strcat(errbuf, "can't load library"); + strcat(errbuf, p); + break; + case L_ERROR_UNDEF: + strcat(errbuf, "can't find symbol"); + strcat(errbuf, p); + break; + case L_ERROR_RLDBAD: + strcat(errbuf, "bad RLD"); + strcat(errbuf, p); + break; + case L_ERROR_FORMAT: + strcat(errbuf, "bad exec format in"); + strcat(errbuf, p); + break; + case L_ERROR_ERRNO: + strcat(errbuf, strerror(atoi(++p))); + break; + default: + strcat(errbuf, s); + break; + } +} + +VOID *dlsym(void *handle, const char *symbol) +{ + register ModulePtr mp = (ModulePtr)handle; + register ExportPtr ep; + register int i; + + /* + * Could speed up the search, but I assume that one assigns + * the result to function pointers anyways. + */ + for (ep = mp->exports, i = mp->nExports; i; i--, ep++) + if (strcmp(ep->name, symbol) == 0) + return ep->addr; + errvalid++; + strcpy(errbuf, "dlsym: undefined symbol "); + strcat(errbuf, symbol); + return NULL; +} + +char *dlerror(void) +{ + if (errvalid) { + errvalid = 0; + return errbuf; + } + return NULL; +} + +int dlclose(void *handle) +{ + register ModulePtr mp = (ModulePtr)handle; + int result; + register ModulePtr mp1; + + if (--mp->refCnt > 0) + return 0; + if (mp->info && mp->info->fini) + (*mp->info->fini)(); + if (mp->cdtors) + while (mp->cdtors->term) { + (*mp->cdtors->term)(); + mp->cdtors++; + } + result = unload(mp->entry); + if (result == -1) { + errvalid++; + strcpy(errbuf, strerror(errno)); + } + if (mp->exports) { + register ExportPtr ep; + register int i; + for (ep = mp->exports, i = mp->nExports; i; i--, ep++) + if (ep->name) + free(ep->name); + free(mp->exports); + } + if (mp == modList) + modList = mp->next; + else { + for (mp1 = modList; mp1; mp1 = mp1->next) + if (mp1->next == mp) { + mp1->next = mp->next; + break; + } + } + free(mp->name); + free(mp); + return result; +} + +static void terminate(void) +{ + while (modList) + dlclose(modList); +} + +/* + * Build the export table from the XCOFF .loader section. + */ +static int readExports(ModulePtr mp) +{ + LDFILE *ldp = NULL; + SCNHDR sh, shdata; + LDHDR *lhp; + char *ldbuf; + LDSYM *ls; + int i; + ExportPtr ep; + + if ((ldp = ldopen(mp->name, ldp)) == NULL) { + struct ld_info *lp; + char *buf; + int size = 4*1024; + if (errno != ENOENT) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + /* + * The module might be loaded due to the LIBPATH + * environment variable. Search for the loaded + * module using L_GETINFO. + */ + if ((buf = malloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { + free(buf); + size += 4*1024; + if ((buf = malloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + } + if (i == -1) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + free(buf); + return -1; + } + /* + * Traverse the list of loaded modules. The entry point + * returned by load() does actually point to the data + * segment origin. + */ + lp = (struct ld_info *)buf; + while (lp) { + if (lp->ldinfo_dataorg == mp->entry) { + ldp = ldopen(lp->ldinfo_filename, ldp); + break; + } + if (lp->ldinfo_next == 0) + lp = NULL; + else + lp = (struct ld_info *)((char *)lp + lp->ldinfo_next); + } + free(buf); + if (!ldp) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + } + if (TYPE(ldp) != U802TOCMAGIC) { + errvalid++; + strcpy(errbuf, "readExports: bad magic"); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + /* + * Get the padding for the data section. This is needed for + * AIX 4.1 compilers. This is used when building the final + * function pointer to the exported symbol. + */ + if (ldnshread(ldp, _DATA, &shdata) != SUCCESS) { + errvalid++; + strcpy(errbuf, "readExports: cannot read data section header"); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) { + errvalid++; + strcpy(errbuf, "readExports: cannot read loader section header"); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + /* + * We read the complete loader section in one chunk, this makes + * finding long symbol names residing in the string table easier. + */ + if ((ldbuf = (char *)malloc(sh.s_size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) { + errvalid++; + strcpy(errbuf, "readExports: cannot seek to loader section"); + free(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { + errvalid++; + strcpy(errbuf, "readExports: cannot read loader section"); + free(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + lhp = (LDHDR *)ldbuf; + ls = (LDSYM *)(ldbuf+LDHDRSZ); + /* + * Count the number of exports to include in our export table. + */ + for (i = lhp->l_nsyms; i; i--, ls++) { + if (!LDR_EXPORT(*ls)) + continue; + mp->nExports++; + } + if ((mp->exports = (ExportPtr)calloc(mp->nExports, sizeof(*mp->exports))) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + free(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + /* + * Fill in the export table. All entries are relative to + * the entry point we got from load. + */ + ep = mp->exports; + ls = (LDSYM *)(ldbuf+LDHDRSZ); + for (i = lhp->l_nsyms; i; i--, ls++) { + char *symname; + char tmpsym[SYMNMLEN+1]; + if (!LDR_EXPORT(*ls)) + continue; + if (ls->l_zeroes == 0) + symname = ls->l_offset+lhp->l_stoff+ldbuf; + else { + /* + * The l_name member is not zero terminated, we + * must copy the first SYMNMLEN chars and make + * sure we have a zero byte at the end. + */ + strncpy(tmpsym, ls->l_name, SYMNMLEN); + tmpsym[SYMNMLEN] = '\0'; + symname = tmpsym; + } + ep->name = malloc((unsigned) (strlen(symname) + 1)); + strcpy(ep->name, symname); + ep->addr = (void *)((unsigned long)mp->entry + + ls->l_value - shdata.s_vaddr); + ep++; + } + free(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return 0; +} + +/* + * Find the main modules entry point. This is used as export pointer + * for loadbind() to be able to resolve references to the main part. + */ +static void * findMain(void) +{ + struct ld_info *lp; + char *buf; + int size = 4*1024; + int i; + void *ret; + + if ((buf = malloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "findMain: "); + strcat(errbuf, strerror(errno)); + return NULL; + } + while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { + free(buf); + size += 4*1024; + if ((buf = malloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "findMain: "); + strcat(errbuf, strerror(errno)); + return NULL; + } + } + if (i == -1) { + errvalid++; + strcpy(errbuf, "findMain: "); + strcat(errbuf, strerror(errno)); + free(buf); + return NULL; + } + /* + * The first entry is the main module. The entry point + * returned by load() does actually point to the data + * segment origin. + */ + lp = (struct ld_info *)buf; + ret = lp->ldinfo_dataorg; + free(buf); + return ret; +} + diff --git a/unix/tclLoadAout.c b/unix/tclLoadAout.c new file mode 100644 index 0000000..ade7161 --- /dev/null +++ b/unix/tclLoadAout.c @@ -0,0 +1,470 @@ +/* + * tclLoadAout.c -- + * + * This procedure provides a version of the TclLoadFile that + * provides pseudo-static linking using version-7 compatible + * a.out files described in either sys/exec.h or sys/a.out.h. + * + * Copyright (c) 1995, by General Electric Company. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * This work was supported in part by the ARPA Manufacturing Automation + * and Design Engineering (MADE) Initiative through ARPA contract + * F33615-94-C-4400. + * + * SCCS: @(#) tclLoadAout.c 1.9 97/02/22 14:05:01 + */ + +#include "tclInt.h" +#include <fcntl.h> +#ifdef HAVE_EXEC_AOUT_H +# include <sys/exec_aout.h> +#endif + +/* + * Some systems describe the a.out header in sys/exec.h, and some in + * a.out.h. + */ + +#ifdef USE_SYS_EXEC_H +#include <sys/exec.h> +#endif +#ifdef USE_A_OUT_H +#include <a.out.h> +#endif +#ifdef USE_SYS_EXEC_AOUT_H +#include <sys/exec_aout.h> +#define a_magic a_midmag +#endif + +/* + * TCL_LOADSHIM is the amount by which to shim the break when loading + */ + +#ifndef TCL_LOADSHIM +#define TCL_LOADSHIM 0x4000L +#endif + +/* + * TCL_LOADALIGN must be a power of 2, and is the alignment to which + * to force the origin of load modules + */ + +#ifndef TCL_LOADALIGN +#define TCL_LOADALIGN 0x4000L +#endif + +/* + * TCL_LOADMAX is the maximum size of a load module, and is used as + * a sanity check when loading + */ + +#ifndef TCL_LOADMAX +#define TCL_LOADMAX 2000000L +#endif + +/* + * Kernel calls that appear to be missing from the system .h files: + */ + +extern char * brk _ANSI_ARGS_((char *)); +extern char * sbrk _ANSI_ARGS_((size_t)); + +/* + * The static variable SymbolTableFile contains the file name where the + * result of the last link was stored. The file is kept because doing so + * allows one load module to use the symbols defined in another. + */ + +static char * SymbolTableFile = NULL; + +/* + * Type of the dictionary function that begins each load module. + */ + +typedef Tcl_PackageInitProc * (* DictFn) _ANSI_ARGS_ ((char * symbol)); + +/* + * Prototypes for procedures referenced only in this file: + */ + +static int FindLibraries _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, + Tcl_DString * buf)); +static void UnlinkSymbolTable _ANSI_ARGS_((void)); + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they + * are defined. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in interp->result. *proc1Ptr and *proc2Ptr + * are filled in with the addresses of the symbols given by + * *sym1 and *sym2, or NULL if those symbols can't be found. + * + * Side effects: + * New code suddenly appears in memory. + * + * + * Bugs: + * This function does not attempt to handle the case where the + * BSS segment is not executable. It will therefore fail on + * Encore Multimax, Pyramid 90x, and similar machines. The + * reason is that the mprotect() kernel call, which would + * otherwise be employed to mark the newly-loaded text segment + * executable, results in a system crash on BSD/386. + * + * In an effort to make it fast, this function eschews the + * technique of linking the load module once, reading its header + * to determine its size, allocating memory for it, and linking + * it again. Instead, it `shims out' memory allocation by + * placing the module TCL_LOADSHIM bytes beyond the break, + * and assuming that any malloc() calls required to run the + * linker will not advance the break beyond that point. If + * the break is advanced beyonnd that point, the load will + * fail with an `inconsistent memory allocation' error. + * It perhaps ought to retry the link, but the failure has + * not been observed in two years of daily use of this function. + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + char * inputSymbolTable; /* Name of the file containing the + * symbol table from the last link. */ + Tcl_DString linkCommandBuf; /* Command to do the run-time relocation + * of the module.*/ + char * linkCommand; + char relocatedFileName [L_tmpnam]; + /* Name of the file holding the relocated */ + /* text of the module */ + int relocatedFd; /* File descriptor of the file holding + * relocated text */ + struct exec relocatedHead; /* Header of the relocated text */ + unsigned long relocatedSize; /* Size of the relocated text */ + char * startAddress; /* Starting address of the module */ + DictFn dictionary; /* Dictionary function in the load module */ + int status; /* Status return from Tcl_ calls */ + char * p; + + /* Find the file that contains the symbols for the run-time link. */ + + if (SymbolTableFile != NULL) { + inputSymbolTable = SymbolTableFile; + } else if (tclExecutableName == NULL) { + Tcl_SetResult (interp, "can't find the tclsh executable", TCL_STATIC); + return TCL_ERROR; + } else { + inputSymbolTable = tclExecutableName; + } + + /* Construct the `ld' command that builds the relocated module */ + + tmpnam (relocatedFileName); + Tcl_DStringInit (&linkCommandBuf); + Tcl_DStringAppend (&linkCommandBuf, "exec ld -o ", -1); + Tcl_DStringAppend (&linkCommandBuf, relocatedFileName, -1); +#if defined(__mips) || defined(mips) + Tcl_DStringAppend (&linkCommandBuf, " -G 0 ", -1); +#endif + Tcl_DStringAppend (&linkCommandBuf, " -u TclLoadDictionary_", -1); + TclGuessPackageName(fileName, &linkCommandBuf); + Tcl_DStringAppend (&linkCommandBuf, " -A ", -1); + Tcl_DStringAppend (&linkCommandBuf, inputSymbolTable, -1); + Tcl_DStringAppend (&linkCommandBuf, " -N -T XXXXXXXX ", -1); + Tcl_DStringAppend (&linkCommandBuf, fileName, -1); + Tcl_DStringAppend (&linkCommandBuf, " ", -1); + if (FindLibraries (interp, fileName, &linkCommandBuf) != TCL_OK) { + Tcl_DStringFree (&linkCommandBuf); + return TCL_ERROR; + } + linkCommand = Tcl_DStringValue (&linkCommandBuf); + + /* Determine the starting address, and plug it into the command */ + + startAddress = (char *) (((unsigned long) sbrk (0) + + TCL_LOADSHIM + TCL_LOADALIGN - 1) + & (- TCL_LOADALIGN)); + p = strstr (linkCommand, "-T") + 3; + sprintf (p, "%08lx", (long) startAddress); + p [8] = ' '; + + /* Run the linker */ + + status = Tcl_Eval (interp, linkCommand); + Tcl_DStringFree (&linkCommandBuf); + if (status != 0) { + return TCL_ERROR; + } + + /* Open the linker's result file and read the header */ + + relocatedFd = open (relocatedFileName, O_RDONLY); + if (relocatedFd < 0) { + goto ioError; + } + status= read (relocatedFd, (char *) & relocatedHead, sizeof relocatedHead); + if (status < sizeof relocatedHead) { + goto ioError; + } + + /* Check the magic number */ + + if (relocatedHead.a_magic != OMAGIC) { + Tcl_AppendResult (interp, "bad magic number in intermediate file \"", + relocatedFileName, "\"", (char *) NULL); + goto failure; + } + + /* Make sure that memory allocation is still consistent */ + + if ((unsigned long) sbrk (0) > (unsigned long) startAddress) { + Tcl_SetResult (interp, "can't load, memory allocation is inconsistent.", + TCL_STATIC); + goto failure; + } + + /* Make sure that the relocated module's size is reasonable */ + + relocatedSize = relocatedHead.a_text + relocatedHead.a_data + + relocatedHead.a_bss; + if (relocatedSize > TCL_LOADMAX) { + Tcl_SetResult (interp, "module too big to load", TCL_STATIC); + goto failure; + } + + /* Advance the break to protect the loaded module */ + + (void) brk (startAddress + relocatedSize); + + /* Seek to the start of the module's text */ + +#if defined(__mips) || defined(mips) + status = lseek (relocatedFd, + N_TXTOFF (relocatedHead.ex_f, relocatedHead.ex_o), + SEEK_SET); +#else + status = lseek (relocatedFd, N_TXTOFF (relocatedHead), SEEK_SET); +#endif + if (status < 0) { + goto ioError; + } + + /* Read in the module's text and data */ + + relocatedSize = relocatedHead.a_text + relocatedHead.a_data; + if (read (relocatedFd, startAddress, relocatedSize) < relocatedSize) { + brk (startAddress); + ioError: + Tcl_AppendResult (interp, "error on intermediate file \"", + relocatedFileName, "\": ", Tcl_PosixError (interp), + (char *) NULL); + failure: + (void) unlink (relocatedFileName); + return TCL_ERROR; + } + + /* Close the intermediate file. */ + + (void) close (relocatedFd); + + /* Arrange things so that intermediate symbol tables eventually get + * deleted. */ + + if (SymbolTableFile != NULL) { + UnlinkSymbolTable (); + } else { + atexit (UnlinkSymbolTable); + } + SymbolTableFile = ckalloc (strlen (relocatedFileName) + 1); + strcpy (SymbolTableFile, relocatedFileName); + + /* Look up the entry points in the load module's dictionary. */ + + dictionary = (DictFn) startAddress; + *proc1Ptr = dictionary (sym1); + *proc2Ptr = dictionary (sym2); + + return TCL_OK; +} + +/* + *------------------------------------------------------------------------ + * + * FindLibraries -- + * + * Find the libraries needed to link a load module at run time. + * + * Results: + * A standard Tcl completion code. If an error occurs, + * an error message is left in interp->result. The -l and -L flags + * are concatenated onto the dynamic string `buf'. + * + *------------------------------------------------------------------------ + */ + +static int +FindLibraries (interp, fileName, buf) + Tcl_Interp * interp; /* Used for error reporting */ + char * fileName; /* Name of the load module */ + Tcl_DString * buf; /* Buffer where the -l an -L flags */ +{ + FILE * f; /* The load module */ + int c; /* Byte from the load module */ + char * p; + + /* Open the load module */ + + if ((f = fopen (fileName, "rb")) == NULL) { + Tcl_AppendResult (interp, "couldn't open \"", fileName, "\": ", + Tcl_PosixError (interp), (char *) NULL); + return TCL_ERROR; + } + + /* Search for the library list in the load module */ + + p = "@LIBS: "; + while (*p != '\0' && (c = getc (f)) != EOF) { + if (c == *p) { + ++p; + } + else { + p = "@LIBS: "; + if (c == *p) { + ++p; + } + } + } + + /* No library list -- this must be an ill-formed module */ + + if (c == EOF) { + Tcl_AppendResult (interp, "File \"", fileName, + "\" is not a Tcl load module.", (char *) NULL); + (void) fclose (f); + return TCL_ERROR; + } + + /* Accumulate the library list */ + + while ((c = getc (f)) != '\0' && c != EOF) { + char cc = c; + Tcl_DStringAppend (buf, &cc, 1); + } + (void) fclose (f); + + if (c == EOF) { + Tcl_AppendResult (interp, "Library directory in \"", fileName, + "\" ends prematurely.", (char *) NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *------------------------------------------------------------------------ + * + * UnlinkSymbolTable -- + * + * Remove the symbol table file from the last dynamic link. + * + * Results: + * None. + * + * Side effects: + * The symbol table file from the last dynamic link is removed. + * This function is called when (a) a new symbol table is present + * because another dynamic link is complete, or (b) the process + * is exiting. + *------------------------------------------------------------------------ + */ + +static void +UnlinkSymbolTable () +{ + (void) unlink (SymbolTableFile); + ckfree (SymbolTableFile); + SymbolTableFile = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + char *p, *q, *r; + + if (q = strrchr(fileName,'/')) { + q++; + } else { + q = fileName; + } + if (!strncmp(q,"lib",3)) { + q+=3; + } + p = q; + while ((*p) && (*p != '.') && ((*p<'0') || (*p>'9'))) { + p++; + } + if ((p>q+2) && !strncmp(p-2,"_G0.",4)) { + p-=2; + } + if (p<q) { + return 0; + } + + Tcl_DStringAppend(bufPtr,q, p-q); + + r = Tcl_DStringValue(bufPtr); + r += strlen(r) - (p-q); + + if (islower(UCHAR(*r))) { + *r = (char) toupper(UCHAR(*r)); + } + while (*(++r)) { + if (isupper(UCHAR(*r))) { + *r = (char) tolower(UCHAR(*r)); + } + } + + return 1; +} diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c new file mode 100644 index 0000000..2619bfd --- /dev/null +++ b/unix/tclLoadDl.c @@ -0,0 +1,135 @@ +/* + * tclLoadDl.c -- + * + * This procedure provides a version of the TclLoadFile that + * works with the "dlopen" and "dlsym" library procedures for + * dynamic loading. + * + * Copyright (c) 1995 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: @(#) tclLoadDl.c 1.8 96/12/03 16:57:00 + */ + +#include "tclInt.h" +#ifdef NO_DLFCN_H +# include "../compat/dlfcn.h" +#else +# include <dlfcn.h> +#endif + +/* + * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined + * and this argument to dlopen must always be 1. The RTLD_GLOBAL + * flag is needed on some systems (e.g. SCO and UnixWare) but doesn't + * exist on others; if it doesn't exist, set it to 0 so it has no effect. + */ + +#ifndef RTLD_NOW +# define RTLD_NOW 1 +#endif + +#ifndef RTLD_GLOBAL +# define RTLD_GLOBAL 0 +#endif + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they + * are defined. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in interp->result. *proc1Ptr and *proc2Ptr + * are filled in with the addresses of the symbols given by + * *sym1 and *sym2, or NULL if those symbols can't be found. + * + * Side effects: + * New code suddenly appears in memory. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + VOID *handle; + Tcl_DString newName; + + handle = dlopen(fileName, RTLD_NOW | RTLD_GLOBAL); + if (handle == NULL) { + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", dlerror(), (char *) NULL); + return TCL_ERROR; + } + + /* + * Some platforms still add an underscore to the beginning of symbol + * names. If we can't find a name without an underscore, try again + * with the underscore. + */ + + *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, (char *) sym1); + if (*proc1Ptr == NULL) { + Tcl_DStringInit(&newName); + Tcl_DStringAppend(&newName, "_", 1); + Tcl_DStringAppend(&newName, sym1, -1); + *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, + Tcl_DStringValue(&newName)); + Tcl_DStringFree(&newName); + } + *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, (char *) sym2); + if (*proc2Ptr == NULL) { + Tcl_DStringInit(&newName); + Tcl_DStringAppend(&newName, "_", 1); + Tcl_DStringAppend(&newName, sym2, -1); + *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, + Tcl_DStringValue(&newName)); + Tcl_DStringFree(&newName); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/unix/tclLoadDld.c b/unix/tclLoadDld.c new file mode 100644 index 0000000..0ef994a --- /dev/null +++ b/unix/tclLoadDld.c @@ -0,0 +1,125 @@ +/* + * tclLoadDld.c -- + * + * This procedure provides a version of the TclLoadFile that + * works with the "dld_link" and "dld_get_func" library procedures + * for dynamic loading. It has been tested on Linux 1.1.95 and + * dld-3.2.7. This file probably isn't needed anymore, since it + * makes more sense to use "dl_open" etc. + * + * Copyright (c) 1995 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: @(#) tclLoadDld.c 1.5 97/05/14 13:24:22 + */ + +#include "tclInt.h" +#include "dld.h" + +/* + * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined + * and this argument to dlopen must always be 1. + */ + +#ifndef RTLD_NOW +# define RTLD_NOW 1 +#endif + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they + * are defined. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in interp->result. *proc1Ptr and *proc2Ptr + * are filled in with the addresses of the symbols given by + * *sym1 and *sym2, or NULL if those symbols can't be found. + * + * Side effects: + * New code suddenly appears in memory. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + static int firstTime = 1; + int returnCode; + + /* + * The dld package needs to know the pathname to the tcl binary. + * If that's not know, return an error. + */ + + if (firstTime) { + if (tclExecutableName == NULL) { + Tcl_SetResult(interp, + "don't know name of application binary file, so can't initialize dynamic loader", + TCL_STATIC); + return TCL_ERROR; + } + returnCode = dld_init(tclExecutableName); + if (returnCode != 0) { + Tcl_AppendResult(interp, + "initialization failed for dynamic loader: ", + dld_strerror(returnCode), (char *) NULL); + return TCL_ERROR; + } + firstTime = 0; + } + + if ((returnCode = dld_link(fileName)) != 0) { + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", dld_strerror(returnCode), (char *) NULL); + return TCL_ERROR; + } + *proc1Ptr = (Tcl_PackageInitProc *) dld_get_func(sym1); + *proc2Ptr = (Tcl_PackageInitProc *) dld_get_func(sym2); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c new file mode 100644 index 0000000..ed4b823 --- /dev/null +++ b/unix/tclLoadNext.c @@ -0,0 +1,111 @@ +/* + * tclLoadNext.c -- + * + * This procedure provides a version of the TclLoadFile that + * works with NeXTs rld_* dynamic loading. This file provided + * by Pedja Bogdanovich. + * + * Copyright (c) 1995 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: @(#) tclLoadNext.c 1.4 96/02/15 11:58:55 + */ + +#include "tclInt.h" +#include <mach-o/rld.h> +#include <streams/streams.h> + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they + * are defined. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in interp->result. *proc1Ptr and *proc2Ptr + * are filled in with the addresses of the symbols given by + * *sym1 and *sym2, or NULL if those symbols can't be found. + * + * Side effects: + * New code suddenly appears in memory. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + struct mach_header *header; + char *data; + int len, maxlen; + char *files[]={fileName,NULL}; + NXStream *errorStream=NXOpenMemory(0,0,NX_READWRITE); + + if(!rld_load(errorStream,&header,files,NULL)) { + NXGetMemoryBuffer(errorStream,&data,&len,&maxlen); + Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL); + NXCloseMemory(errorStream,NX_FREEBUFFER); + return TCL_ERROR; + } + NXCloseMemory(errorStream,NX_FREEBUFFER); + + *proc1Ptr=NULL; + if(sym1) { + char sym[strlen(sym1)+2]; + sym[0]='_'; sym[1]=0; strcat(sym,sym1); + rld_lookup(NULL,sym,(unsigned long *)proc1Ptr); + } + + *proc2Ptr=NULL; + if(sym2) { + char sym[strlen(sym2)+2]; + sym[0]='_'; sym[1]=0; strcat(sym,sym2); + rld_lookup(NULL,sym,(unsigned long *)proc2Ptr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c new file mode 100644 index 0000000..ca8c8fc --- /dev/null +++ b/unix/tclLoadOSF.c @@ -0,0 +1,128 @@ +/* + * tclLoadOSF.c -- + * + * This procedure provides a version of the TclLoadFile that works + * under OSF/1 1.0/1.1/1.2 and related systems, utilizing the old OSF/1 + * /sbin/loader and /usr/include/loader.h. OSF/1 versions from 1.3 and + * on use ELF, rtld, and dlopen()[/usr/include/ldfcn.h]. + * + * This is useful for: + * OSF/1 1.0, 1.1, 1.2 (from OSF) + * includes: MK4 and AD1 (from OSF RI) + * OSF/1 1.3 (from OSF) using ROSE + * HP OSF/1 1.0 ("Acorn") using COFF + * + * This is likely to be useful for: + * Paragon OSF/1 (from Intel) + * HI-OSF/1 (from Hitachi) + * + * This is NOT to be used on: + * Digitial Alpha OSF/1 systems + * OSF/1 1.3 or later (from OSF) using ELF + * includes: MK6, MK7, AD2, AD3 (from OSF RI) + * + * This approach to things was utter @&^#; thankfully, + * OSF/1 eventually supported dlopen(). + * + * John Robert LoVerso <loverso@freebsd.osf.org> + * + * Copyright (c) 1995 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: @(#) tclLoadOSF.c 1.2 96/02/15 11:58:40 + */ + +#include "tclInt.h" +#include <sys/types.h> +#include <loader.h> + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they + * are defined. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in interp->result. *proc1Ptr and *proc2Ptr + * are filled in with the addresses of the symbols given by + * *sym1 and *sym2, or NULL if those symbols can't be found. + * + * Side effects: + * New code suddenly appears in memory. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + ldr_module_t lm; + char *pkg; + + lm = (Tcl_PackageInitProc *) load(fileName, LDR_NOFLAGS); + if (lm == LDR_NULL_MODULE) { + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", Tcl_PosixError (interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * My convention is to use a [OSF loader] package name the same as shlib, + * since the idiots never implemented ldr_lookup() and it is otherwise + * impossible to get a package name given a module. + * + * I build loadable modules with a makefile rule like + * ld ... -export $@: -o $@ $(OBJS) + */ + if ((pkg = strrchr(fileName, '/')) == NULL) + pkg = fileName; + else + pkg++; + *proc1Ptr = ldr_lookup_package(pkg, sym1); + *proc2Ptr = ldr_lookup_package(pkg, sym2); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c new file mode 100644 index 0000000..2f290ab --- /dev/null +++ b/unix/tclLoadShl.c @@ -0,0 +1,129 @@ +/* + * tclLoadShl.c -- + * + * This procedure provides a version of the TclLoadFile that works + * with the "shl_load" and "shl_findsym" library procedures for + * dynamic loading (e.g. for HP machines). + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclLoadShl.c 1.5 96/03/15 15:01:44 + */ + +#include <dl.h> + +/* + * On some HP machines, dl.h defines EXTERN; remove that definition. + */ + +#ifdef EXTERN +# undef EXTERN +#endif + +#include "tcl.h" + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they + * are defined. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in interp->result. *proc1Ptr and *proc2Ptr + * are filled in with the addresses of the symbols given by + * *sym1 and *sym2, or NULL if those symbols can't be found. + * + * Side effects: + * New code suddenly appears in memory. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + shl_t handle; + Tcl_DString newName; + + handle = shl_load(fileName, BIND_IMMEDIATE, 0L); + if (handle == NULL) { + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * Some versions of the HP system software still use "_" at the + * beginning of exported symbols while others don't; try both + * forms of each name. + */ + + if (shl_findsym(&handle, sym1, (short) TYPE_PROCEDURE, (void *) proc1Ptr) + != 0) { + Tcl_DStringInit(&newName); + Tcl_DStringAppend(&newName, "_", 1); + Tcl_DStringAppend(&newName, sym1, -1); + if (shl_findsym(&handle, Tcl_DStringValue(&newName), + (short) TYPE_PROCEDURE, (void *) proc1Ptr) != 0) { + *proc1Ptr = NULL; + } + Tcl_DStringFree(&newName); + } + if (shl_findsym(&handle, sym2, (short) TYPE_PROCEDURE, (void *) proc2Ptr) + != 0) { + Tcl_DStringInit(&newName); + Tcl_DStringAppend(&newName, "_", 1); + Tcl_DStringAppend(&newName, sym2, -1); + if (shl_findsym(&handle, Tcl_DStringValue(&newName), + (short) TYPE_PROCEDURE, (void *) proc2Ptr) != 0) { + *proc2Ptr = NULL; + } + Tcl_DStringFree(&newName); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/unix/tclMtherr.c b/unix/tclMtherr.c new file mode 100644 index 0000000..24b815d --- /dev/null +++ b/unix/tclMtherr.c @@ -0,0 +1,86 @@ +/* + * tclMatherr.c -- + * + * This function provides a default implementation of the + * "matherr" function, for SYS-V systems where it's needed. + * + * Copyright (c) 1993-1994 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: @(#) tclMtherr.c 1.12 96/06/22 16:36:57 + */ + +#include "tclInt.h" +#include <math.h> + +#ifndef TCL_GENERIC_ONLY +#include "tclPort.h" +#else +#define NO_ERRNO_H +#endif + +#ifdef NO_ERRNO_H +extern int errno; /* Use errno from tclExecute.c. */ +#define EDOM 33 +#define ERANGE 34 +#endif + +/* + * The following variable is secretly shared with Tcl so we can + * tell if expression evaluation is in progress. If not, matherr + * just emulates the default behavior, which includes printing + * a message. + */ + +extern int tcl_MathInProgress; + +/* + * The following definitions allow matherr to compile on systems + * that don't really support it. The compiled procedure is bogus, + * but it will never be executed on these systems anyway. + */ + +#ifndef NEED_MATHERR +struct exception { + int type; +}; +#define DOMAIN 0 +#define SING 0 +#endif + +/* + *---------------------------------------------------------------------- + * + * matherr -- + * + * This procedure is invoked on Sys-V systems when certain + * errors occur in mathematical functions. Type "man matherr" + * for more information on how this function works. + * + * Results: + * Returns 1 to indicate that we've handled the error + * locally. + * + * Side effects: + * Sets errno based on what's in xPtr. + * + *---------------------------------------------------------------------- + */ + +int +matherr(xPtr) + struct exception *xPtr; /* Describes error that occurred. */ +{ + if (!tcl_MathInProgress) { + return 0; + } + if ((xPtr->type == DOMAIN) || (xPtr->type == SING)) { + errno = EDOM; + } else { + errno = ERANGE; + } + return 1; +} diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c new file mode 100644 index 0000000..2c0e996 --- /dev/null +++ b/unix/tclUnixChan.c @@ -0,0 +1,2565 @@ +/* + * tclUnixChan.c + * + * Common channel driver for Unix channels based on files, command + * pipes and TCP sockets. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixChan.c 1.207 97/11/04 14:45:29 + */ + +#include "tclInt.h" /* Internal definitions for Tcl. */ +#include "tclPort.h" /* Portability features for Tcl. */ + +/* + * sys/ioctl.h has already been included by tclPort.h. Including termios.h + * or termio.h causes a bunch of warning messages because some duplicate + * (but not contradictory) #defines exist in termios.h and/or termio.h + */ +#undef NL0 +#undef NL1 +#undef CR0 +#undef CR1 +#undef CR2 +#undef CR3 +#undef TAB0 +#undef TAB1 +#undef TAB2 +#undef XTABS +#undef BS0 +#undef BS1 +#undef FF0 +#undef FF1 +#undef ECHO +#undef NOFLSH +#undef TOSTOP +#undef FLUSHO +#undef PENDIN + +#ifdef USE_TERMIOS +# include <termios.h> +#else /* !USE_TERMIOS */ +#ifdef USE_TERMIO +# include <termio.h> +#else /* !USE_TERMIO */ +#ifdef USE_SGTTY +# include <sgtty.h> +#endif /* USE_SGTTY */ +#endif /* !USE_TERMIO */ +#endif /* !USE_TERMIOS */ + +/* + * The following structure is used to set or get the serial port + * attributes in a platform-independant manner. + */ + +typedef struct TtyAttrs { + int baud; + int parity; + int data; + int stop; +} TtyAttrs; + +/* + * This structure describes per-instance state of a file based channel. + */ + +typedef struct FileState { + Tcl_Channel channel; /* Channel associated with this file. */ + int fd; /* File handle. */ + int validMask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION: indicates + * which operations are valid on the file. */ + struct FileState *nextPtr; /* Pointer to next file in list of all + * file channels. */ +} FileState; + +/* + * List of all file channels currently open. + */ + +static FileState *firstFilePtr = NULL; + +/* + * This structure describes per-instance state of a tcp based channel. + */ + +typedef struct TcpState { + Tcl_Channel channel; /* Channel associated with this file. */ + int fd; /* The socket itself. */ + int flags; /* ORed combination of the bitfields + * defined below. */ + Tcl_TcpAcceptProc *acceptProc; + /* Proc to call on accept. */ + ClientData acceptProcData; /* The data for the accept proc. */ +} TcpState; + +/* + * These bits may be ORed together into the "flags" field of a TcpState + * structure. + */ + +#define TCP_ASYNC_SOCKET (1<<0) /* Asynchronous socket. */ +#define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ + +/* + * The following defines the maximum length of the listen queue. This is + * the number of outstanding yet-to-be-serviced requests for a connection + * on a server socket, more than this number of outstanding requests and + * the connection request will fail. + */ + +#ifndef SOMAXCONN +#define SOMAXCONN 100 +#endif + +#if (SOMAXCONN < 100) +#undef SOMAXCONN +#define SOMAXCONN 100 +#endif + +/* + * The following defines how much buffer space the kernel should maintain + * for a socket. + */ + +#define SOCKET_BUFSIZE 4096 + +/* + * Static routines for this file: + */ + +static TcpState * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp, + int port, char *host, int server, + char *myaddr, int myport, int async)); +static int CreateSocketAddress _ANSI_ARGS_( + (struct sockaddr_in *sockaddrPtr, + char *host, int port)); +static int FileBlockModeProc _ANSI_ARGS_(( + ClientData instanceData, int mode)); +static int FileCloseProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static int FileGetHandleProc _ANSI_ARGS_((ClientData instanceData, + int direction, ClientData *handlePtr)); +static int FileInputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int FileOutputProc _ANSI_ARGS_(( + ClientData instanceData, char *buf, int toWrite, + int *errorCode)); +static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, + long offset, int mode, int *errorCode)); +static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, + int mask)); +static void TcpAccept _ANSI_ARGS_((ClientData data, int mask)); +static int TcpBlockModeProc _ANSI_ARGS_((ClientData data, + int mode)); +static int TcpCloseProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static int TcpGetHandleProc _ANSI_ARGS_((ClientData instanceData, + int direction, ClientData *handlePtr)); +static int TcpGetOptionProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp, char *optionName, + Tcl_DString *dsPtr)); +static int TcpInputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int TcpOutputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toWrite, int *errorCode)); +static void TcpWatchProc _ANSI_ARGS_((ClientData instanceData, + int mask)); +static int TtyParseMode _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *mode, int *speedPtr, int *parityPtr, + int *dataPtr, int *stopPtr)); +static void TtyGetAttributes _ANSI_ARGS_((int fd, + TtyAttrs *ttyPtr)); +static int TtyGetOptionProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp, char *optionName, + Tcl_DString *dsPtr)); +static void TtyInit _ANSI_ARGS_((int fd)); +static void TtySetAttributes _ANSI_ARGS_((int fd, + TtyAttrs *ttyPtr)); +static int TtySetOptionProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp, char *optionName, + char *value)); +static int WaitForConnect _ANSI_ARGS_((TcpState *statePtr, + int *errorCodePtr)); + +/* + * This structure describes the channel type structure for file based IO: + */ + +static Tcl_ChannelType fileChannelType = { + "file", /* Type name. */ + FileBlockModeProc, /* Set blocking/nonblocking mode.*/ + FileCloseProc, /* Close proc. */ + FileInputProc, /* Input proc. */ + FileOutputProc, /* Output proc. */ + FileSeekProc, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ + FileWatchProc, /* Initialize notifier. */ + FileGetHandleProc, /* Get OS handles out of channel. */ +}; + +/* + * This structure describes the channel type structure for serial IO. + * Note that this type is a subclass of the "file" type. + */ + +static Tcl_ChannelType ttyChannelType = { + "tty", /* Type name. */ + FileBlockModeProc, /* Set blocking/nonblocking mode.*/ + FileCloseProc, /* Close proc. */ + FileInputProc, /* Input proc. */ + FileOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + TtySetOptionProc, /* Set option proc. */ + TtyGetOptionProc, /* Get option proc. */ + FileWatchProc, /* Initialize notifier. */ + FileGetHandleProc, /* Get OS handles out of channel. */ +}; + +/* + * This structure describes the channel type structure for TCP socket + * based IO: + */ + +static Tcl_ChannelType tcpChannelType = { + "tcp", /* Type name. */ + TcpBlockModeProc, /* Set blocking/nonblocking mode.*/ + TcpCloseProc, /* Close proc. */ + TcpInputProc, /* Input proc. */ + TcpOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + NULL, /* Set option proc. */ + TcpGetOptionProc, /* Get option proc. */ + TcpWatchProc, /* Initialize notifier. */ + TcpGetHandleProc, /* Get OS handles out of channel. */ +}; + + +/* + *---------------------------------------------------------------------- + * + * FileBlockModeProc -- + * + * Helper procedure to set blocking and nonblocking modes on a + * file based channel. Invoked by generic IO level code. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +FileBlockModeProc(instanceData, mode) + ClientData instanceData; /* File state. */ + int mode; /* The mode to set. Can be one of + * TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + FileState *fsPtr = (FileState *) instanceData; + int curStatus; + +#ifndef USE_FIONBIO + curStatus = fcntl(fsPtr->fd, F_GETFL); + if (mode == TCL_MODE_BLOCKING) { + curStatus &= (~(O_NONBLOCK)); + } else { + curStatus |= O_NONBLOCK; + } + if (fcntl(fsPtr->fd, F_SETFL, curStatus) < 0) { + return errno; + } + curStatus = fcntl(fsPtr->fd, F_GETFL); +#else + if (mode == TCL_MODE_BLOCKING) { + curStatus = 0; + } else { + curStatus = 1; + } + if (ioctl(fsPtr->fd, (int) FIONBIO, &curStatus) < 0) { + return errno; + } +#endif + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * FileInputProc -- + * + * This procedure is invoked from the generic IO level to read + * input from a file based channel. + * + * Results: + * The number of bytes read is returned or -1 on error. An output + * argument contains a POSIX error code if an error occurs, or zero. + * + * Side effects: + * Reads input from the input device of the channel. + * + *---------------------------------------------------------------------- + */ + +static int +FileInputProc(instanceData, buf, toRead, errorCodePtr) + ClientData instanceData; /* File state. */ + char *buf; /* Where to store data read. */ + int toRead; /* How much space is available + * in the buffer? */ + int *errorCodePtr; /* Where to store error code. */ +{ + FileState *fsPtr = (FileState *) instanceData; + int bytesRead; /* How many bytes were actually + * read from the input device? */ + + *errorCodePtr = 0; + + /* + * Assume there is always enough input available. This will block + * appropriately, and read will unblock as soon as a short read is + * possible, if the channel is in blocking mode. If the channel is + * nonblocking, the read will never block. + */ + + bytesRead = read(fsPtr->fd, buf, (size_t) toRead); + if (bytesRead > -1) { + return bytesRead; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * FileOutputProc-- + * + * This procedure is invoked from the generic IO level to write + * output to a file channel. + * + * Results: + * The number of bytes written is returned or -1 on error. An + * output argument contains a POSIX error code if an error occurred, + * or zero. + * + * Side effects: + * Writes output on the output device of the channel. + * + *---------------------------------------------------------------------- + */ + +static int +FileOutputProc(instanceData, buf, toWrite, errorCodePtr) + ClientData instanceData; /* File state. */ + char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCodePtr; /* Where to store error code. */ +{ + FileState *fsPtr = (FileState *) instanceData; + int written; + + *errorCodePtr = 0; + written = write(fsPtr->fd, buf, (size_t) toWrite); + if (written > -1) { + return written; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * FileCloseProc -- + * + * This procedure is called from the generic IO level to perform + * channel-type-specific cleanup when a file based channel is closed. + * + * Results: + * 0 if successful, errno if failed. + * + * Side effects: + * Closes the device of the channel. + * + *---------------------------------------------------------------------- + */ + +static int +FileCloseProc(instanceData, interp) + ClientData instanceData; /* File state. */ + Tcl_Interp *interp; /* For error reporting - unused. */ +{ + FileState *fsPtr = (FileState *) instanceData; + FileState **nextPtrPtr; + int errorCode = 0; + + Tcl_DeleteFileHandler(fsPtr->fd); + if (!TclInExit() + || ((fsPtr->fd != 0) && (fsPtr->fd != 1) && (fsPtr->fd != 2))) { + if (close(fsPtr->fd) < 0) { + errorCode = errno; + } + } + for (nextPtrPtr = &firstFilePtr; (*nextPtrPtr) != NULL; + nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { + if ((*nextPtrPtr) == fsPtr) { + (*nextPtrPtr) = fsPtr->nextPtr; + break; + } + } + ckfree((char *) fsPtr); + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * FileSeekProc -- + * + * This procedure is called by the generic IO level to move the + * access point in a file based channel. + * + * Results: + * -1 if failed, the new position if successful. An output + * argument contains the POSIX error code if an error occurred, + * or zero. + * + * Side effects: + * Moves the location at which the channel will be accessed in + * future operations. + * + *---------------------------------------------------------------------- + */ + +static int +FileSeekProc(instanceData, offset, mode, errorCodePtr) + ClientData instanceData; /* File state. */ + long offset; /* Offset to seek to. */ + int mode; /* Relative to where + * should we seek? Can be + * one of SEEK_START, + * SEEK_SET or SEEK_END. */ + int *errorCodePtr; /* To store error code. */ +{ + FileState *fsPtr = (FileState *) instanceData; + int newLoc; + + newLoc = lseek(fsPtr->fd, offset, mode); + + *errorCodePtr = (newLoc == -1) ? errno : 0; + return newLoc; +} + +/* + *---------------------------------------------------------------------- + * + * FileWatchProc -- + * + * Initialize the notifier to watch the fd from this channel. + * + * Results: + * None. + * + * Side effects: + * Sets up the notifier so that a future event on the channel will + * be seen by Tcl. + * + *---------------------------------------------------------------------- + */ + +static void +FileWatchProc(instanceData, mask) + ClientData instanceData; /* The file state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + FileState *fsPtr = (FileState *) instanceData; + + /* + * Make sure we only register for events that are valid on this file. + * Note that we are passing Tcl_NotifyChannel directly to + * Tcl_CreateFileHandler with the channel pointer as the client data. + */ + + mask &= fsPtr->validMask; + if (mask) { + Tcl_CreateFileHandler(fsPtr->fd, mask, + (Tcl_FileProc *) Tcl_NotifyChannel, + (ClientData) fsPtr->channel); + } else { + Tcl_DeleteFileHandler(fsPtr->fd); + } +} + +/* + *---------------------------------------------------------------------- + * + * FileGetHandleProc -- + * + * Called from Tcl_GetChannelFile to retrieve OS handles from + * a file based channel. + * + * Results: + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if + * there is no handle for the specified direction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileGetHandleProc(instanceData, direction, handlePtr) + ClientData instanceData; /* The file state. */ + int direction; /* TCL_READABLE or TCL_WRITABLE */ + ClientData *handlePtr; /* Where to store the handle. */ +{ + FileState *fsPtr = (FileState *) instanceData; + + if (direction & fsPtr->validMask) { + *handlePtr = (ClientData) fsPtr->fd; + return TCL_OK; + } else { + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * TtySetOptionProc -- + * + * Sets an option on a channel. + * + * Results: + * A standard Tcl result. Also sets interp->result on error if + * interp is not NULL. + * + * Side effects: + * May modify an option on a device. + * Sets Error message if needed (by calling Tcl_BadChannelOption). + * + *---------------------------------------------------------------------- + */ + +static int +TtySetOptionProc(instanceData, interp, optionName, value) + ClientData instanceData; /* File state. */ + Tcl_Interp *interp; /* For error reporting - can be NULL. */ + char *optionName; /* Which option to set? */ + char *value; /* New value for option. */ +{ + FileState *fsPtr = (FileState *) instanceData; + unsigned int len; + TtyAttrs tty; + + len = strlen(optionName); + if ((len > 1) && (strncmp(optionName, "-mode", len) == 0)) { + if (TtyParseMode(interp, value, &tty.baud, &tty.parity, &tty.data, + &tty.stop) != TCL_OK) { + return TCL_ERROR; + } + /* + * system calls results should be checked there. -- dl + */ + + TtySetAttributes(fsPtr->fd, &tty); + return TCL_OK; + } else { + return Tcl_BadChannelOption(interp, optionName, "mode"); + } +} + +/* + *---------------------------------------------------------------------- + * + * TtyGetOptionProc -- + * + * Gets a mode associated with an IO channel. If the optionName arg + * is non NULL, retrieves the value of that option. If the optionName + * arg is NULL, retrieves a list of alternating option names and + * values for the given channel. + * + * Results: + * A standard Tcl result. Also sets the supplied DString to the + * string value of the option(s) returned. + * + * Side effects: + * The string returned by this function is in static storage and + * may be reused at any time subsequent to the call. + * Sets Error message if needed (by calling Tcl_BadChannelOption). + * + *---------------------------------------------------------------------- + */ + +static int +TtyGetOptionProc(instanceData, interp, optionName, dsPtr) + ClientData instanceData; /* File state. */ + Tcl_Interp *interp; /* For error reporting - can be NULL. */ + char *optionName; /* Option to get. */ + Tcl_DString *dsPtr; /* Where to store value(s). */ +{ + FileState *fsPtr = (FileState *) instanceData; + unsigned int len; + char buf[32]; + TtyAttrs tty; + + if (optionName == NULL) { + Tcl_DStringAppendElement(dsPtr, "-mode"); + len = 0; + } else { + len = strlen(optionName); + } + if ((len == 0) || + ((len > 1) && (strncmp(optionName, "-mode", len) == 0))) { + TtyGetAttributes(fsPtr->fd, &tty); + sprintf(buf, "%d,%c,%d,%d", tty.baud, tty.parity, tty.data, tty.stop); + Tcl_DStringAppendElement(dsPtr, buf); + return TCL_OK; + } else { + return Tcl_BadChannelOption(interp, optionName, "mode"); + } +} + +#undef DIRECT_BAUD +#ifdef B4800 +# if (B4800 == 4800) +# define DIRECT_BAUD +# endif +#endif + +#ifdef DIRECT_BAUD +# define TtyGetSpeed(baud) ((unsigned) (baud)) +# define TtyGetBaud(speed) ((int) (speed)) +#else + +static struct {int baud; unsigned long speed;} speeds[] = { +#ifdef B0 + {0, B0}, +#endif +#ifdef B50 + {50, B50}, +#endif +#ifdef B75 + {75, B75}, +#endif +#ifdef B110 + {110, B110}, +#endif +#ifdef B134 + {134, B134}, +#endif +#ifdef B150 + {150, B150}, +#endif +#ifdef B200 + {200, B200}, +#endif +#ifdef B300 + {300, B300}, +#endif +#ifdef B600 + {600, B600}, +#endif +#ifdef B1200 + {1200, B1200}, +#endif +#ifdef B1800 + {1800, B1800}, +#endif +#ifdef B2400 + {2400, B2400}, +#endif +#ifdef B4800 + {4800, B4800}, +#endif +#ifdef B9600 + {9600, B9600}, +#endif +#ifdef B14400 + {14400, B14400}, +#endif +#ifdef B19200 + {19200, B19200}, +#endif +#ifdef EXTA + {19200, EXTA}, +#endif +#ifdef B28800 + {28800, B28800}, +#endif +#ifdef B38400 + {38400, B38400}, +#endif +#ifdef EXTB + {38400, EXTB}, +#endif +#ifdef B57600 + {57600, B57600}, +#endif +#ifdef _B57600 + {57600, _B57600}, +#endif +#ifdef B76800 + {76800, B76800}, +#endif +#ifdef B115200 + {115200, B115200}, +#endif +#ifdef _B115200 + {115200, _B115200}, +#endif +#ifdef B153600 + {153600, B153600}, +#endif +#ifdef B230400 + {230400, B230400}, +#endif +#ifdef B307200 + {307200, B307200}, +#endif +#ifdef B460800 + {460800, B460800}, +#endif + {-1, 0} +}; + +/* + *--------------------------------------------------------------------------- + * + * TtyGetSpeed -- + * + * Given a baud rate, get the mask value that should be stored in + * the termios, termio, or sgttyb structure in order to select that + * baud rate. + * + * Results: + * As above. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static unsigned long +TtyGetSpeed(baud) + int baud; /* The baud rate to look up. */ +{ + int bestIdx, bestDiff, i, diff; + + bestIdx = 0; + bestDiff = 1000000; + + /* + * If the baud rate does not correspond to one of the known mask values, + * choose the mask value whose baud rate is closest to the specified + * baud rate. + */ + + for (i = 0; speeds[i].baud >= 0; i++) { + diff = speeds[i].baud - baud; + if (diff < 0) { + diff = -diff; + } + if (diff < bestDiff) { + bestIdx = i; + bestDiff = diff; + } + } + return speeds[bestIdx].speed; +} + +/* + *--------------------------------------------------------------------------- + * + * TtyGetBaud -- + * + * Given a speed mask value from a termios, termio, or sgttyb + * structure, get the baus rate that corresponds to that mask value. + * + * Results: + * As above. If the mask value was not recognized, 0 is returned. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +TtyGetBaud(speed) + unsigned long speed; /* Speed mask value to look up. */ +{ + int i; + + for (i = 0; speeds[i].baud >= 0; i++) { + if (speeds[i].speed == speed) { + return speeds[i].baud; + } + } + return 0; +} + +#endif /* !DIRECT_BAUD */ + + +/* + *--------------------------------------------------------------------------- + * + * TtyInit -- + * + * Given file descriptor that refers to a serial port, + * initialize the serial port to a set of sane values so that + * Tcl can talk to a device located on the serial port. + * + * Results: + * None. + * + * Side effects: + * Serial device initialized. + * + *--------------------------------------------------------------------------- + */ + +static void +TtyInit(fd) + int fd; /* Open file descriptor for serial port to + * be initialized. */ +{ +#ifdef USE_TERMIOS + struct termios termios; + + tcgetattr(fd, &termios); + termios.c_iflag = IGNBRK; + termios.c_oflag = 0; + termios.c_lflag = 0; + termios.c_cflag |= CREAD; + termios.c_cc[VMIN] = 60; + termios.c_cc[VTIME] = 2; + tcsetattr(fd, TCSANOW, &termios); +#else /* !USE_TERMIOS */ +#ifdef USE_TERMIO + struct termio termio; + + ioctl(fd, TCGETA, &termio); + termio.c_iflag = IGNBRK; + termio.c_oflag = 0; + termio.c_lflag = 0; + termio.c_cflag |= CREAD; + termio.c_cc[VMIN] = 60; + termio.c_cc[VTIME] = 2; + ioctl(fd, TCSETAW, &termio); +#else /* !USE_TERMIO */ +#ifdef USE_SGTTY + struct sgttyb sgttyb; + + ioctl(fd, TIOCGETP, &sgttyb); + sgttyb.sg_flags &= (EVENP | ODDP); + sgttyb.sg_flags |= RAW; + ioctl(fd, TIOCSETP, &sgttyb); +#endif /* USE_SGTTY */ +#endif /* !USE_TERMIO */ +#endif /* !USE_TERMIOS */ +} + +/* + *--------------------------------------------------------------------------- + * + * TtyGetAttributes -- + * + * Get the current attributes of the specified serial device. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static void +TtyGetAttributes(fd, ttyPtr) + int fd; /* Open file descriptor for serial port to + * be queried. */ + TtyAttrs *ttyPtr; /* Buffer filled with serial port + * attributes. */ +{ +#ifdef USE_TERMIOS + int parity, data; + struct termios termios; + + tcgetattr(fd, &termios); + ttyPtr->baud = TtyGetBaud(cfgetospeed(&termios)); + + parity = 'n'; +#ifdef PAREXT + switch ((int) (termios.c_cflag & (PARENB | PARODD | PAREXT))) { + case PARENB : parity = 'e'; break; + case PARENB | PARODD : parity = 'o'; break; + case PARENB | PAREXT : parity = 's'; break; + case PARENB | PARODD | PAREXT : parity = 'm'; break; + } +#else /* !PAREXT */ + switch ((int) (termios.c_cflag & (PARENB | PARODD))) { + case PARENB : parity = 'e'; break; + case PARENB | PARODD : parity = 'o'; break; + } +#endif /* !PAREXT */ + ttyPtr->parity = parity; + + data = termios.c_cflag & CSIZE; + ttyPtr->data = (data == CS5) ? 5 : (data == CS6) ? 6 : + (data == CS7) ? 7 : 8; + + ttyPtr->stop = (termios.c_cflag & CSTOPB) ? 2 : 1; +#else /* !USE_TERMIOS */ +#ifdef USE_TERMIO + int parity, data; + struct termio termio; + + ioctl(fd, TCGETA, &termio); + ttyPtr->baud = TtyGetBaud(termio.c_cflag & CBAUD); + parity = 'n'; + switch (termio.c_cflag & (PARENB | PARODD | PAREXT)) { + case PARENB : parity = 'e'; break; + case PARENB | PARODD : parity = 'o'; break; + case PARENB | PAREXT : parity = 's'; break; + case PARENB | PARODD | PAREXT : parity = 'm'; break; + } + ttyPtr->parity = parity; + + data = termio.c_cflag & CSIZE; + ttyPtr->data = (data == CS5) ? 5 : (data == CS6) ? 6 : + (data == CS7) ? 7 : 8; + + ttyPtr->stop = (termio.c_cflag & CSTOPB) ? 2 : 1; +#else /* !USE_TERMIO */ +#ifdef USE_SGTTY + int parity; + struct sgttyb sgttyb; + + ioctl(fd, TIOCGETP, &sgttyb); + ttyPtr->baud = TtyGetBaud(sgttyb.sg_ospeed); + parity = 'n'; + if (sgttyb.sg_flags & EVENP) { + parity = 'e'; + } else if (sgttyb.sg_flags & ODDP) { + parity = 'o'; + } + ttyPtr->parity = parity; + ttyPtr->data = (sgttyb.sg_flags & (EVENP | ODDP)) ? 7 : 8; + ttyPtr->stop = 1; +#else /* !USE_SGTTY */ + ttyPtr->baud = 0; + ttyPtr->parity = 'n'; + ttyPtr->data = 0; + ttyPtr->stop = 0; +#endif /* !USE_SGTTY */ +#endif /* !USE_TERMIO */ +#endif /* !USE_TERMIOS */ +} + +/* + *--------------------------------------------------------------------------- + * + * TtySetAttributes -- + * + * Set the current attributes of the specified serial device. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static void +TtySetAttributes(fd, ttyPtr) + int fd; /* Open file descriptor for serial port to + * be modified. */ + TtyAttrs *ttyPtr; /* Buffer containing new attributes for + * serial port. */ +{ +#ifdef USE_TERMIOS + int parity, data, flag; + struct termios termios; + + tcgetattr(fd, &termios); + cfsetospeed(&termios, TtyGetSpeed(ttyPtr->baud)); + cfsetispeed(&termios, TtyGetSpeed(ttyPtr->baud)); + + flag = 0; + parity = ttyPtr->parity; + if (parity != 'n') { + flag |= PARENB; +#ifdef PAREXT + termios.c_cflag &= ~PAREXT; + if ((parity == 'm') || (parity == 's')) { + flag |= PAREXT; + } +#endif + if ((parity == 'm') || (parity == 'o')) { + flag |= PARODD; + } + } + data = ttyPtr->data; + flag |= (data == 5) ? CS5 : (data == 6) ? CS6 : (data == 7) ? CS7 : CS8; + if (ttyPtr->stop == 2) { + flag |= CSTOPB; + } + + termios.c_cflag &= ~(PARENB | PARODD | CSIZE | CSTOPB); + termios.c_cflag |= flag; + tcsetattr(fd, TCSANOW, &termios); + +#else /* !USE_TERMIOS */ +#ifdef USE_TERMIO + int parity, data, flag; + struct termio termio; + + ioctl(fd, TCGETA, &termio); + termio.c_cflag &= ~CBAUD; + termio.c_cflag |= TtyGetSpeed(ttyPtr->baud); + + flag = 0; + parity = ttyPtr->parity; + if (parity != 'n') { + flag |= PARENB; + if ((parity == 'm') || (parity == 's')) { + flag |= PAREXT; + } + if ((parity == 'm') || (parity == 'o')) { + flag |= PARODD; + } + } + data = ttyPtr->data; + flag |= (data == 5) ? CS5 : (data == 6) ? CS6 : (data == 7) ? CS7 : CS8; + if (ttyPtr->stop == 2) { + flag |= CSTOPB; + } + + termio.c_cflag &= ~(PARENB | PARODD | PAREXT | CSIZE | CSTOPB); + termio.c_cflag |= flag; + ioctl(fd, TCSETAW, &termio); + +#else /* !USE_TERMIO */ +#ifdef USE_SGTTY + int parity; + struct sgttyb sgttyb; + + ioctl(fd, TIOCGETP, &sgttyb); + sgttyb.sg_ospeed = TtyGetSpeed(ttyPtr->baud); + sgttyb.sg_ispeed = TtyGetSpeed(ttyPtr->baud); + + parity = ttyPtr->parity; + if (parity == 'e') { + sgttyb.sg_flags &= ~ODDP; + sgttyb.sg_flags |= EVENP; + } else if (parity == 'o') { + sgttyb.sg_flags &= ~EVENP; + sgttyb.sg_flags |= ODDP; + } + ioctl(fd, TIOCSETP, &sgttyb); +#endif /* USE_SGTTY */ +#endif /* !USE_TERMIO */ +#endif /* !USE_TERMIOS */ +} + +/* + *--------------------------------------------------------------------------- + * + * TtyParseMode -- + * + * Parse the "-mode" argument to the fconfigure command. The argument + * is of the form baud,parity,data,stop. + * + * Results: + * The return value is TCL_OK if the argument was successfully + * parsed, TCL_ERROR otherwise. If TCL_ERROR is returned, an + * error message is left in interp->result (if interp is non-NULL). + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +TtyParseMode(interp, mode, speedPtr, parityPtr, dataPtr, stopPtr) + Tcl_Interp *interp; /* If non-NULL, interp for error return. */ + CONST char *mode; /* Mode string to be parsed. */ + int *speedPtr; /* Filled with baud rate from mode string. */ + int *parityPtr; /* Filled with parity from mode string. */ + int *dataPtr; /* Filled with data bits from mode string. */ + int *stopPtr; /* Filled with stop bits from mode string. */ +{ + int i, end; + char parity; + static char *bad = "bad value for -mode"; + + i = sscanf(mode, "%d,%c,%d,%d%n", speedPtr, &parity, dataPtr, + stopPtr, &end); + if ((i != 4) || (mode[end] != '\0')) { + if (interp != NULL) { + Tcl_AppendResult(interp, bad, ": should be baud,parity,data,stop", + NULL); + } + return TCL_ERROR; + } + if (strchr("noems", parity) == NULL) { + if (interp != NULL) { + Tcl_AppendResult(interp, bad, + " parity: should be n, o, e, m, or s", NULL); + } + return TCL_ERROR; + } + *parityPtr = parity; + if ((*dataPtr < 5) || (*dataPtr > 8)) { + if (interp != NULL) { + Tcl_AppendResult(interp, bad, " data: should be 5, 6, 7, or 8", + NULL); + } + return TCL_ERROR; + } + if ((*stopPtr < 0) || (*stopPtr > 2)) { + if (interp != NULL) { + Tcl_AppendResult(interp, bad, " stop: should be 1 or 2", NULL); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenFileChannel -- + * + * Open an file based channel on Unix systems. + * + * Results: + * The new channel or NULL. If NULL, the output argument + * errorCodePtr is set to a POSIX error and an error message is + * left in interp->result if interp is not NULL. + * + * Side effects: + * May open the channel and may cause creation of a file on the + * file system. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenFileChannel(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *fileName; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + int fd, seekFlag, mode, channelPermissions; + FileState *fsPtr; + char *nativeName, channelName[20]; + Tcl_DString buffer; + Tcl_ChannelType *channelTypePtr; + + mode = TclGetOpenMode(interp, modeString, &seekFlag); + if (mode == -1) { + return NULL; + } + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { + case O_RDONLY: + channelPermissions = TCL_READABLE; + break; + case O_WRONLY: + channelPermissions = TCL_WRITABLE; + break; + case O_RDWR: + channelPermissions = (TCL_READABLE | TCL_WRITABLE); + break; + default: + /* + * This may occurr if modeString was "", for example. + */ + panic("Tcl_OpenFileChannel: invalid mode value"); + return NULL; + } + + nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (nativeName == NULL) { + return NULL; + } + fd = open(nativeName, mode, permissions); + + /* + * If nativeName is not NULL, the buffer is valid and we must free + * the storage. + */ + + Tcl_DStringFree(&buffer); + + if (fd < 0) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + } + return NULL; + } + + /* + * Set close-on-exec flag on the fd so that child processes will not + * inherit this fd. + */ + + fcntl(fd, F_SETFD, FD_CLOEXEC); + + sprintf(channelName, "file%d", fd); + + fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); + fsPtr->nextPtr = firstFilePtr; + firstFilePtr = fsPtr; + fsPtr->validMask = channelPermissions | TCL_EXCEPTION; + fsPtr->fd = fd; + + if (isatty(fd)) { + /* + * Initialize the serial port to a set of sane parameters. + * Especially important if the remote device is set to echo and + * the serial port driver was also set to echo -- as soon as a char + * were sent to the serial port, the remote device would echo it, + * then the serial driver would echo it back to the device, etc. + */ + + TtyInit(fd); + channelTypePtr = &ttyChannelType; + } else { + channelTypePtr = &fileChannelType; + } + + fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName, + (ClientData) fsPtr, channelPermissions); + + if (seekFlag) { + if (Tcl_Seek(fsPtr->channel, 0, SEEK_END) < 0) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't seek to end of file on \"", + channelName, "\": ", Tcl_PosixError(interp), NULL); + } + Tcl_Close(NULL, fsPtr->channel); + return NULL; + } + } + + if (channelTypePtr == &ttyChannelType) { + /* + * Gotcha. Most modems need a "\r" at the end of the command + * sequence. If you just send "at\n", the modem will not respond + * with "OK" because it never got a "\r" to actually invoke the + * command. So, by default, newlines are translated to "\r\n" on + * output to avoid "bug" reports that the serial port isn't working. + */ + + if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation", + "auto crlf") != TCL_OK) { + Tcl_Close(NULL, fsPtr->channel); + return NULL; + } + } + + return fsPtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeFileChannel -- + * + * Makes a Tcl_Channel from an existing OS level file handle. + * + * Results: + * The Tcl_Channel created around the preexisting OS level file handle. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_MakeFileChannel(handle, mode) + ClientData handle; /* OS level handle. */ + int mode; /* ORed combination of TCL_READABLE and + * TCL_WRITABLE to indicate file mode. */ +{ + FileState *fsPtr; + char channelName[20]; + int fd = (int) handle; + + if (mode == 0) { + return NULL; + } + + sprintf(channelName, "file%d", fd); + + /* + * Look to see if a channel with this fd and the same mode already exists. + * If the fd is used, but the mode doesn't match, return NULL. + */ + + for (fsPtr = firstFilePtr; fsPtr != NULL; fsPtr = fsPtr->nextPtr) { + if (fsPtr->fd == fd) { + return (mode == fsPtr->validMask) ? fsPtr->channel : NULL; + } + } + + fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); + fsPtr->nextPtr = firstFilePtr; + firstFilePtr = fsPtr; + fsPtr->fd = fd; + fsPtr->validMask = mode | TCL_EXCEPTION; + fsPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName, + (ClientData) fsPtr, mode); + + return fsPtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * TcpBlockModeProc -- + * + * This procedure is invoked by the generic IO level to set blocking + * and nonblocking mode on a TCP socket based channel. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or nonblocking mode. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TcpBlockModeProc(instanceData, mode) + ClientData instanceData; /* Socket state. */ + int mode; /* The mode to set. Can be one of + * TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + int setting; + +#ifndef USE_FIONBIO + setting = fcntl(statePtr->fd, F_GETFL); + if (mode == TCL_MODE_BLOCKING) { + statePtr->flags &= (~(TCP_ASYNC_SOCKET)); + setting &= (~(O_NONBLOCK)); + } else { + statePtr->flags |= TCP_ASYNC_SOCKET; + setting |= O_NONBLOCK; + } + if (fcntl(statePtr->fd, F_SETFL, setting) < 0) { + return errno; + } +#endif + +#ifdef USE_FIONBIO + if (mode == TCL_MODE_BLOCKING) { + statePtr->flags &= (~(TCP_ASYNC_SOCKET)); + setting = 0; + if (ioctl(statePtr->fd, (int) FIONBIO, &setting) == -1) { + return errno; + } + } else { + statePtr->flags |= TCP_ASYNC_SOCKET; + setting = 1; + if (ioctl(statePtr->fd, (int) FIONBIO, &setting) == -1) { + return errno; + } + } +#endif + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * WaitForConnect -- + * + * Waits for a connection on an asynchronously opened socket to + * be completed. + * + * Results: + * None. + * + * Side effects: + * The socket is connected after this function returns. + * + *---------------------------------------------------------------------- + */ + +static int +WaitForConnect(statePtr, errorCodePtr) + TcpState *statePtr; /* State of the socket. */ + int *errorCodePtr; /* Where to store errors? */ +{ + int timeOut; /* How long to wait. */ + int state; /* Of calling TclWaitForFile. */ + int flags; /* fcntl flags for the socket. */ + + /* + * If an asynchronous connect is in progress, attempt to wait for it + * to complete before reading. + */ + + if (statePtr->flags & TCP_ASYNC_CONNECT) { + if (statePtr->flags & TCP_ASYNC_SOCKET) { + timeOut = 0; + } else { + timeOut = -1; + } + errno = 0; + state = TclUnixWaitForFile(statePtr->fd, + TCL_WRITABLE | TCL_EXCEPTION, timeOut); + if (!(statePtr->flags & TCP_ASYNC_SOCKET)) { +#ifndef USE_FIONBIO + flags = fcntl(statePtr->fd, F_GETFL); + flags &= (~(O_NONBLOCK)); + (void) fcntl(statePtr->fd, F_SETFL, flags); +#endif + +#ifdef USE_FIONBIO + flags = 0; + (void) ioctl(statePtr->fd, FIONBIO, &flags); +#endif + } + if (state & TCL_EXCEPTION) { + return -1; + } + if (state & TCL_WRITABLE) { + statePtr->flags &= (~(TCP_ASYNC_CONNECT)); + } else if (timeOut == 0) { + *errorCodePtr = errno = EWOULDBLOCK; + return -1; + } + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TcpInputProc -- + * + * This procedure is invoked by the generic IO level to read input + * from a TCP socket based channel. + * + * NOTE: We cannot share code with FilePipeInputProc because here + * we must use recv to obtain the input from the channel, not read. + * + * Results: + * The number of bytes read is returned or -1 on error. An output + * argument contains the POSIX error code on error, or zero if no + * error occurred. + * + * Side effects: + * Reads input from the input device of the channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TcpInputProc(instanceData, buf, bufSize, errorCodePtr) + ClientData instanceData; /* Socket state. */ + char *buf; /* Where to store data read. */ + int bufSize; /* How much space is available + * in the buffer? */ + int *errorCodePtr; /* Where to store error code. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + int bytesRead, state; + + *errorCodePtr = 0; + state = WaitForConnect(statePtr, errorCodePtr); + if (state != 0) { + return -1; + } + bytesRead = recv(statePtr->fd, buf, bufSize, 0); + if (bytesRead > -1) { + return bytesRead; + } + if (errno == ECONNRESET) { + + /* + * Turn ECONNRESET into a soft EOF condition. + */ + + return 0; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * TcpOutputProc -- + * + * This procedure is invoked by the generic IO level to write output + * to a TCP socket based channel. + * + * NOTE: We cannot share code with FilePipeOutputProc because here + * we must use send, not write, to get reliable error reporting. + * + * Results: + * The number of bytes written is returned. An output argument is + * set to a POSIX error code if an error occurred, or zero. + * + * Side effects: + * Writes output on the output device of the channel. + * + *---------------------------------------------------------------------- + */ + +static int +TcpOutputProc(instanceData, buf, toWrite, errorCodePtr) + ClientData instanceData; /* Socket state. */ + char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCodePtr; /* Where to store error code. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + int written; + int state; /* Of waiting for connection. */ + + *errorCodePtr = 0; + state = WaitForConnect(statePtr, errorCodePtr); + if (state != 0) { + return -1; + } + written = send(statePtr->fd, buf, toWrite, 0); + if (written > -1) { + return written; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * TcpCloseProc -- + * + * This procedure is invoked by the generic IO level to perform + * channel-type-specific cleanup when a TCP socket based channel + * is closed. + * + * Results: + * 0 if successful, the value of errno if failed. + * + * Side effects: + * Closes the socket of the channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TcpCloseProc(instanceData, interp) + ClientData instanceData; /* The socket to close. */ + Tcl_Interp *interp; /* For error reporting - unused. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + int errorCode = 0; + + /* + * Delete a file handler that may be active for this socket if this + * is a server socket - the file handler was created automatically + * by Tcl as part of the mechanism to accept new client connections. + * Channel handlers are already deleted in the generic IO channel + * closing code that called this function, so we do not have to + * delete them here. + */ + + Tcl_DeleteFileHandler(statePtr->fd); + + if (close(statePtr->fd) < 0) { + errorCode = errno; + } + ckfree((char *) statePtr); + + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * TcpGetOptionProc -- + * + * Computes an option value for a TCP socket based channel, or a + * list of all options and their values. + * + * Note: This code is based on code contributed by John Haxby. + * + * Results: + * A standard Tcl result. The value of the specified option or a + * list of all options and their values is returned in the + * supplied DString. Sets Error message if needed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TcpGetOptionProc(instanceData, interp, optionName, dsPtr) + ClientData instanceData; /* Socket state. */ + Tcl_Interp *interp; /* For error reporting - can be NULL. */ + char *optionName; /* Name of the option to + * retrieve the value for, or + * NULL to get all options and + * their values. */ + Tcl_DString *dsPtr; /* Where to store the computed + * value; initialized by caller. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + struct sockaddr_in sockname; + struct sockaddr_in peername; + struct hostent *hostEntPtr; + int size = sizeof(struct sockaddr_in); + size_t len = 0; + char buf[128]; + + if (optionName != (char *) NULL) { + len = strlen(optionName); + } + + if ((len == 0) || + ((len > 1) && (optionName[1] == 'p') && + (strncmp(optionName, "-peername", len) == 0))) { + if (getpeername(statePtr->fd, (struct sockaddr *) &peername, &size) + >= 0) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-peername"); + Tcl_DStringStartSublist(dsPtr); + } + Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); + hostEntPtr = gethostbyaddr((char *) &(peername.sin_addr), + sizeof(peername.sin_addr), AF_INET); + if (hostEntPtr != (struct hostent *) NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); + } + sprintf(buf, "%d", ntohs(peername.sin_port)); + Tcl_DStringAppendElement(dsPtr, buf); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } else { + /* + * getpeername failed - but if we were asked for all the options + * (len==0), don't flag an error at that point because it could + * be an fconfigure request on a server socket. (which have + * no peer). same must be done on win&mac. + */ + + if (len) { + if (interp) { + Tcl_AppendResult(interp, "can't get peername: ", + Tcl_PosixError(interp), + (char *) NULL); + } + return TCL_ERROR; + } + } + } + + if ((len == 0) || + ((len > 1) && (optionName[1] == 's') && + (strncmp(optionName, "-sockname", len) == 0))) { + if (getsockname(statePtr->fd, (struct sockaddr *) &sockname, &size) + >= 0) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-sockname"); + Tcl_DStringStartSublist(dsPtr); + } + Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); + hostEntPtr = gethostbyaddr((char *) &(sockname.sin_addr), + sizeof(sockname.sin_addr), AF_INET); + if (hostEntPtr != (struct hostent *) NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); + } + sprintf(buf, "%d", ntohs(sockname.sin_port)); + Tcl_DStringAppendElement(dsPtr, buf); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } else { + if (interp) { + Tcl_AppendResult(interp, "can't get sockname: ", + Tcl_PosixError(interp), + (char *) NULL); + } + return TCL_ERROR; + } + } + + if (len > 0) { + return Tcl_BadChannelOption(interp, optionName, "peername sockname"); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TcpWatchProc -- + * + * Initialize the notifier to watch the fd from this channel. + * + * Results: + * None. + * + * Side effects: + * Sets up the notifier so that a future event on the channel will + * be seen by Tcl. + * + *---------------------------------------------------------------------- + */ + +static void +TcpWatchProc(instanceData, mask) + ClientData instanceData; /* The socket state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + + if (mask) { + Tcl_CreateFileHandler(statePtr->fd, mask, + (Tcl_FileProc *) Tcl_NotifyChannel, + (ClientData) statePtr->channel); + } else { + Tcl_DeleteFileHandler(statePtr->fd); + } +} + +/* + *---------------------------------------------------------------------- + * + * TcpGetHandleProc -- + * + * Called from Tcl_GetChannelFile to retrieve OS handles from inside + * a TCP socket based channel. + * + * Results: + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if + * there is no handle for the specified direction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TcpGetHandleProc(instanceData, direction, handlePtr) + ClientData instanceData; /* The socket state. */ + int direction; /* Not used. */ + ClientData *handlePtr; /* Where to store the handle. */ +{ + TcpState *statePtr = (TcpState *) instanceData; + + *handlePtr = (ClientData)statePtr->fd; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSocket -- + * + * This function opens a new socket in client or server mode + * and initializes the TcpState structure. + * + * Results: + * Returns a new TcpState, or NULL with an error in interp->result, + * if interp is not NULL. + * + * Side effects: + * Opens a socket. + * + *---------------------------------------------------------------------- + */ + +static TcpState * +CreateSocket(interp, port, host, server, myaddr, myport, async) + Tcl_Interp *interp; /* For error reporting; can be NULL. */ + int port; /* Port number to open. */ + char *host; /* Name of host on which to open port. + * NULL implies INADDR_ANY */ + int server; /* 1 if socket should be a server socket, + * else 0 for a client socket. */ + char *myaddr; /* Optional client-side address */ + int myport; /* Optional client-side port */ + int async; /* If nonzero and creating a client socket, + * attempt to do an async connect. Otherwise + * do a synchronous connect or bind. */ +{ + int status, sock, asyncConnect, curState, origState; + struct sockaddr_in sockaddr; /* socket address */ + struct sockaddr_in mysockaddr; /* Socket address for client */ + TcpState *statePtr; + + sock = -1; + origState = 0; + if (! CreateSocketAddress(&sockaddr, host, port)) { + goto addressError; + } + if ((myaddr != NULL || myport != 0) && + ! CreateSocketAddress(&mysockaddr, myaddr, myport)) { + goto addressError; + } + + sock = socket(AF_INET, SOCK_STREAM, 0); + if (sock < 0) { + goto addressError; + } + + /* + * Set the close-on-exec flag so that the socket will not get + * inherited by child processes. + */ + + fcntl(sock, F_SETFD, FD_CLOEXEC); + + /* + * Set kernel space buffering + */ + + TclSockMinimumBuffers(sock, SOCKET_BUFSIZE); + + asyncConnect = 0; + status = 0; + if (server) { + + /* + * Set up to reuse server addresses automatically and bind to the + * specified port. + */ + + status = 1; + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &status, + sizeof(status)); + status = bind(sock, (struct sockaddr *) &sockaddr, + sizeof(struct sockaddr)); + if (status != -1) { + status = listen(sock, SOMAXCONN); + } + } else { + if (myaddr != NULL || myport != 0) { + curState = 1; + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, + (char *) &curState, sizeof(curState)); + status = bind(sock, (struct sockaddr *) &mysockaddr, + sizeof(struct sockaddr)); + if (status < 0) { + goto bindError; + } + } + + /* + * Attempt to connect. The connect may fail at present with an + * EINPROGRESS but at a later time it will complete. The caller + * will set up a file handler on the socket if she is interested in + * being informed when the connect completes. + */ + + if (async) { +#ifndef USE_FIONBIO + origState = fcntl(sock, F_GETFL); + curState = origState | O_NONBLOCK; + status = fcntl(sock, F_SETFL, curState); +#endif + +#ifdef USE_FIONBIO + curState = 1; + status = ioctl(sock, FIONBIO, &curState); +#endif + } else { + status = 0; + } + if (status > -1) { + status = connect(sock, (struct sockaddr *) &sockaddr, + sizeof(sockaddr)); + if (status < 0) { + if (errno == EINPROGRESS) { + asyncConnect = 1; + status = 0; + } + } + } + } + +bindError: + if (status < 0) { + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't open socket: ", + Tcl_PosixError(interp), (char *) NULL); + } + if (sock != -1) { + close(sock); + } + return NULL; + } + + /* + * Allocate a new TcpState for this socket. + */ + + statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); + statePtr->flags = 0; + if (asyncConnect) { + statePtr->flags = TCP_ASYNC_CONNECT; + } + statePtr->fd = sock; + + return statePtr; + +addressError: + if (sock != -1) { + close(sock); + } + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't open socket: ", + Tcl_PosixError(interp), (char *) NULL); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSocketAddress -- + * + * This function initializes a sockaddr structure for a host and port. + * + * Results: + * 1 if the host was valid, 0 if the host could not be converted to + * an IP address. + * + * Side effects: + * Fills in the *sockaddrPtr structure. + * + *---------------------------------------------------------------------- + */ + +static int +CreateSocketAddress(sockaddrPtr, host, port) + struct sockaddr_in *sockaddrPtr; /* Socket address */ + char *host; /* Host. NULL implies INADDR_ANY */ + int port; /* Port number */ +{ + struct hostent *hostent; /* Host database entry */ + struct in_addr addr; /* For 64/32 bit madness */ + + (void) memset((VOID *) sockaddrPtr, '\0', sizeof(struct sockaddr_in)); + sockaddrPtr->sin_family = AF_INET; + sockaddrPtr->sin_port = htons((unsigned short) (port & 0xFFFF)); + if (host == NULL) { + addr.s_addr = INADDR_ANY; + } else { + addr.s_addr = inet_addr(host); + if (addr.s_addr == -1) { + hostent = gethostbyname(host); + if (hostent != NULL) { + memcpy((VOID *) &addr, + (VOID *) hostent->h_addr_list[0], + (size_t) hostent->h_length); + } else { +#ifdef EHOSTUNREACH + errno = EHOSTUNREACH; +#else +#ifdef ENXIO + errno = ENXIO; +#endif +#endif + return 0; /* error */ + } + } + } + + /* + * NOTE: On 64 bit machines the assignment below is rumored to not + * do the right thing. Please report errors related to this if you + * observe incorrect behavior on 64 bit machines such as DEC Alphas. + * Should we modify this code to do an explicit memcpy? + */ + + sockaddrPtr->sin_addr.s_addr = addr.s_addr; + return 1; /* Success. */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpClient -- + * + * Opens a TCP client socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. An error message is returned + * in the interpreter on failure. + * + * Side effects: + * Opens a client socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async) + Tcl_Interp *interp; /* For error reporting; can be NULL. */ + int port; /* Port number to open. */ + char *host; /* Host on which to open port. */ + char *myaddr; /* Client-side address */ + int myport; /* Client-side port */ + int async; /* If nonzero, attempt to do an + * asynchronous connect. Otherwise + * we do a blocking connect. */ +{ + TcpState *statePtr; + char channelName[20]; + + /* + * Create a new client socket and wrap it in a channel. + */ + + statePtr = CreateSocket(interp, port, host, 0, myaddr, myport, async); + if (statePtr == NULL) { + return NULL; + } + + statePtr->acceptProc = NULL; + statePtr->acceptProcData = (ClientData) NULL; + + sprintf(channelName, "sock%d", statePtr->fd); + + statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE)); + if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation", + "auto crlf") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, statePtr->channel); + return NULL; + } + return statePtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeTcpClientChannel -- + * + * Creates a Tcl_Channel from an existing client TCP socket. + * + * Results: + * The Tcl_Channel wrapped around the preexisting TCP socket. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_MakeTcpClientChannel(sock) + ClientData sock; /* The socket to wrap up into a channel. */ +{ + TcpState *statePtr; + char channelName[20]; + + statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); + statePtr->fd = (int) sock; + statePtr->acceptProc = NULL; + statePtr->acceptProcData = (ClientData) NULL; + + sprintf(channelName, "sock%d", statePtr->fd); + + statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE)); + if (Tcl_SetChannelOption((Tcl_Interp *) NULL, statePtr->channel, + "-translation", "auto crlf") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, statePtr->channel); + return NULL; + } + return statePtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpServer -- + * + * Opens a TCP server socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. If an error occurred, an + * error message is left in interp->result if interp is + * not NULL. + * + * Side effects: + * Opens a server socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpServer(interp, port, myHost, acceptProc, acceptProcData) + Tcl_Interp *interp; /* For error reporting - may be + * NULL. */ + int port; /* Port number to open. */ + char *myHost; /* Name of local host. */ + Tcl_TcpAcceptProc *acceptProc; /* Callback for accepting connections + * from new clients. */ + ClientData acceptProcData; /* Data for the callback. */ +{ + TcpState *statePtr; + char channelName[20]; + + /* + * Create a new client socket and wrap it in a channel. + */ + + statePtr = CreateSocket(interp, port, myHost, 1, NULL, 0, 0); + if (statePtr == NULL) { + return NULL; + } + + statePtr->acceptProc = acceptProc; + statePtr->acceptProcData = acceptProcData; + + /* + * Set up the callback mechanism for accepting connections + * from new clients. + */ + + Tcl_CreateFileHandler(statePtr->fd, TCL_READABLE, TcpAccept, + (ClientData) statePtr); + sprintf(channelName, "sock%d", statePtr->fd); + statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) statePtr, 0); + return statePtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * TcpAccept -- + * Accept a TCP socket connection. This is called by the event loop. + * + * Results: + * None. + * + * Side effects: + * Creates a new connection socket. Calls the registered callback + * for the connection acceptance mechanism. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +TcpAccept(data, mask) + ClientData data; /* Callback token. */ + int mask; /* Not used. */ +{ + TcpState *sockState; /* Client data of server socket. */ + int newsock; /* The new client socket */ + TcpState *newSockState; /* State for new socket. */ + struct sockaddr_in addr; /* The remote address */ + int len; /* For accept interface */ + char channelName[20]; + + sockState = (TcpState *) data; + + len = sizeof(struct sockaddr_in); + newsock = accept(sockState->fd, (struct sockaddr *)&addr, &len); + if (newsock < 0) { + return; + } + + /* + * Set close-on-exec flag to prevent the newly accepted socket from + * being inherited by child processes. + */ + + (void) fcntl(newsock, F_SETFD, FD_CLOEXEC); + + newSockState = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); + + newSockState->flags = 0; + newSockState->fd = newsock; + newSockState->acceptProc = (Tcl_TcpAcceptProc *) NULL; + newSockState->acceptProcData = (ClientData) NULL; + + sprintf(channelName, "sock%d", newsock); + newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) newSockState, (TCL_READABLE | TCL_WRITABLE)); + + Tcl_SetChannelOption((Tcl_Interp *) NULL, newSockState->channel, + "-translation", "auto crlf"); + + if (sockState->acceptProc != (Tcl_TcpAcceptProc *) NULL) { + (sockState->acceptProc) (sockState->acceptProcData, + newSockState->channel, inet_ntoa(addr.sin_addr), + ntohs(addr.sin_port)); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetDefaultStdChannel -- + * + * Creates channels for standard input, standard output or standard + * error output if they do not already exist. + * + * Results: + * Returns the specified default standard channel, or NULL. + * + * Side effects: + * May cause the creation of a standard channel and the underlying + * file. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclGetDefaultStdChannel(type) + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ +{ + Tcl_Channel channel = NULL; + int fd = 0; /* Initializations needed to prevent */ + int mode = 0; /* compiler warning (used before set). */ + char *bufMode = NULL; + + switch (type) { + case TCL_STDIN: + if ((lseek(0, (off_t) 0, SEEK_CUR) == -1) && + (errno == EBADF)) { + return (Tcl_Channel) NULL; + } + fd = 0; + mode = TCL_READABLE; + bufMode = "line"; + break; + case TCL_STDOUT: + if ((lseek(1, (off_t) 0, SEEK_CUR) == -1) && + (errno == EBADF)) { + return (Tcl_Channel) NULL; + } + fd = 1; + mode = TCL_WRITABLE; + bufMode = "line"; + break; + case TCL_STDERR: + if ((lseek(2, (off_t) 0, SEEK_CUR) == -1) && + (errno == EBADF)) { + return (Tcl_Channel) NULL; + } + fd = 2; + mode = TCL_WRITABLE; + bufMode = "none"; + break; + default: + panic("TclGetDefaultStdChannel: Unexpected channel type"); + break; + } + + channel = Tcl_MakeFileChannel((ClientData) fd, mode); + + /* + * Set up the normal channel options for stdio handles. + */ + + Tcl_SetChannelOption(NULL, channel, "-translation", "auto"); + Tcl_SetChannelOption(NULL, channel, "-buffering", bufMode); + return channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetOpenFile -- + * + * Given a name of a channel registered in the given interpreter, + * returns a FILE * for it. + * + * Results: + * A standard Tcl result. If the channel is registered in the given + * interpreter and it is managed by the "file" channel driver, and + * it is open for the requested mode, then the output parameter + * filePtr is set to a FILE * for the underlying file. On error, the + * filePtr is not set, TCL_ERROR is returned and an error message is + * left in interp->result. + * + * Side effects: + * May invoke fdopen to create the FILE * for the requested file. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr) + Tcl_Interp *interp; /* Interpreter in which to find file. */ + char *string; /* String that identifies file. */ + int forWriting; /* 1 means the file is going to be used + * for writing, 0 means for reading. */ + int checkUsage; /* 1 means verify that the file was opened + * in a mode that allows the access specified + * by "forWriting". Ignored, we always + * check that the channel is open for the + * requested mode. */ + ClientData *filePtr; /* Store pointer to FILE structure here. */ +{ + Tcl_Channel chan; + int chanMode; + Tcl_ChannelType *chanTypePtr; + ClientData data; + int fd; + FILE *f; + + chan = Tcl_GetChannel(interp, string, &chanMode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((forWriting) && ((chanMode & TCL_WRITABLE) == 0)) { + Tcl_AppendResult(interp, + "\"", string, "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } else if ((!(forWriting)) && ((chanMode & TCL_READABLE) == 0)) { + Tcl_AppendResult(interp, + "\"", string, "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + + /* + * We allow creating a FILE * out of file based, pipe based and socket + * based channels. We currently do not allow any other channel types, + * because it is likely that stdio will not know what to do with them. + */ + + chanTypePtr = Tcl_GetChannelType(chan); + if ((chanTypePtr == &fileChannelType) || (chanTypePtr == &tcpChannelType) + || (strcmp(chanTypePtr->typeName, "pipe") == 0)) { + if (Tcl_GetChannelHandle(chan, + (forWriting ? TCL_WRITABLE : TCL_READABLE), + (ClientData*) &data) == TCL_OK) { + fd = (int) data; + + /* + * The call to fdopen below is probably dangerous, since it will + * truncate an existing file if the file is being opened + * for writing.... + */ + + f = fdopen(fd, (forWriting ? "w" : "r")); + if (f == NULL) { + Tcl_AppendResult(interp, "cannot get a FILE * for \"", string, + "\"", (char *) NULL); + return TCL_ERROR; + } + *filePtr = (ClientData) f; + return TCL_OK; + } + } + + Tcl_AppendResult(interp, "\"", string, + "\" cannot be used to get a FILE *", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclUnixWaitForFile -- + * + * This procedure waits synchronously for a file to become readable + * or writable, with an optional timeout. + * + * Results: + * The return value is an OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions + * that are present on file at the time of the return. This + * procedure will not return until either "timeout" milliseconds + * have elapsed or at least one of the conditions given by mask + * has occurred for file (a return value of 0 means that a timeout + * occurred). No normal events will be serviced during the + * execution of this procedure. + * + * Side effects: + * Time passes. + * + *---------------------------------------------------------------------- + */ + +int +TclUnixWaitForFile(fd, mask, timeout) + int fd; /* Handle for file on which to wait. */ + int mask; /* What to wait for: OR'ed combination of + * TCL_READABLE, TCL_WRITABLE, and + * TCL_EXCEPTION. */ + int timeout; /* Maximum amount of time to wait for one + * of the conditions in mask to occur, in + * milliseconds. A value of 0 means don't + * wait at all, and a value of -1 means + * wait forever. */ +{ + Tcl_Time abortTime, now; + struct timeval blockTime, *timeoutPtr; + int index, bit, numFound, result = 0; + static fd_mask readyMasks[3*MASK_SIZE]; + /* This array reflects the readable/writable + * conditions that were found to exist by the + * last call to select. */ + + /* + * If there is a non-zero finite timeout, compute the time when + * we give up. + */ + + if (timeout > 0) { + TclpGetTime(&now); + abortTime.sec = now.sec + timeout/1000; + abortTime.usec = now.usec + (timeout%1000)*1000; + if (abortTime.usec >= 1000000) { + abortTime.usec -= 1000000; + abortTime.sec += 1; + } + timeoutPtr = &blockTime; + } else if (timeout == 0) { + timeoutPtr = &blockTime; + blockTime.tv_sec = 0; + blockTime.tv_usec = 0; + } else { + timeoutPtr = NULL; + } + + /* + * Initialize the ready masks and compute the mask offsets. + */ + + if (fd >= FD_SETSIZE) { + panic("TclWaitForFile can't handle file id %d", fd); + } + memset((VOID *) readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); + index = fd/(NBBY*sizeof(fd_mask)); + bit = 1 << (fd%(NBBY*sizeof(fd_mask))); + + /* + * Loop in a mini-event loop of our own, waiting for either the + * file to become ready or a timeout to occur. + */ + + while (1) { + if (timeout > 0) { + blockTime.tv_sec = abortTime.sec - now.sec; + blockTime.tv_usec = abortTime.usec - now.usec; + if (blockTime.tv_usec < 0) { + blockTime.tv_sec -= 1; + blockTime.tv_usec += 1000000; + } + if (blockTime.tv_sec < 0) { + blockTime.tv_sec = 0; + blockTime.tv_usec = 0; + } + } + + /* + * Set the appropriate bit in the ready masks for the fd. + */ + + if (mask & TCL_READABLE) { + readyMasks[index] |= bit; + } + if (mask & TCL_WRITABLE) { + (readyMasks+MASK_SIZE)[index] |= bit; + } + if (mask & TCL_EXCEPTION) { + (readyMasks+2*(MASK_SIZE))[index] |= bit; + } + + /* + * Wait for the event or a timeout. + */ + + numFound = select(fd+1, (SELECT_MASK *) &readyMasks[0], + (SELECT_MASK *) &readyMasks[MASK_SIZE], + (SELECT_MASK *) &readyMasks[2*MASK_SIZE], timeoutPtr); + if (numFound == 1) { + if (readyMasks[index] & bit) { + result |= TCL_READABLE; + } + if ((readyMasks+MASK_SIZE)[index] & bit) { + result |= TCL_WRITABLE; + } + if ((readyMasks+2*(MASK_SIZE))[index] & bit) { + result |= TCL_EXCEPTION; + } + result &= mask; + if (result) { + break; + } + } + if (timeout == 0) { + break; + } + + /* + * The select returned early, so we need to recompute the timeout. + */ + + TclpGetTime(&now); + if ((abortTime.sec < now.sec) + || ((abortTime.sec == now.sec) + && (abortTime.usec <= now.usec))) { + break; + } + } + return result; +} diff --git a/unix/tclUnixEvent.c b/unix/tclUnixEvent.c new file mode 100644 index 0000000..24841ca --- /dev/null +++ b/unix/tclUnixEvent.c @@ -0,0 +1,76 @@ +/* + * tclUnixEvent.c -- + * + * This file implements Unix specific event related routines. + * + * 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: @(#) tclUnixEvent.c 1.1 97/03/04 14:19:34 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + *---------------------------------------------------------------------- + * + * Tcl_Sleep -- + * + * Delay execution for the specified number of milliseconds. + * + * Results: + * None. + * + * Side effects: + * Time passes. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Sleep(ms) + int ms; /* Number of milliseconds to sleep. */ +{ + static struct timeval delay; + Tcl_Time before, after; + + /* + * The only trick here is that select appears to return early + * under some conditions, so we have to check to make sure that + * the right amount of time really has elapsed. If it's too + * early, go back to sleep again. + */ + + TclpGetTime(&before); + after = before; + after.sec += ms/1000; + after.usec += (ms%1000)*1000; + if (after.usec > 1000000) { + after.usec -= 1000000; + after.sec += 1; + } + while (1) { + delay.tv_sec = after.sec - before.sec; + delay.tv_usec = after.usec - before.usec; + if (delay.tv_usec < 0) { + delay.tv_usec += 1000000; + delay.tv_sec -= 1; + } + + /* + * Special note: must convert delay.tv_sec to int before comparing + * to zero, since delay.tv_usec is unsigned on some platforms. + */ + + if ((((int) delay.tv_sec) < 0) + || ((delay.tv_usec == 0) && (delay.tv_sec == 0))) { + break; + } + (void) select(0, (SELECT_MASK *) 0, (SELECT_MASK *) 0, + (SELECT_MASK *) 0, &delay); + TclpGetTime(&before); + } +} diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c new file mode 100644 index 0000000..3ec1a69 --- /dev/null +++ b/unix/tclUnixFCmd.c @@ -0,0 +1,1224 @@ +/* + * tclUnixFCmd.c + * + * This file implements the unix specific portion of file manipulation + * subcommands of the "file" command. All filename arguments should + * already be translated to native format. + * + * 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: @(#) tclUnixFCmd.c 1.31 97/10/13 16:51:14 + * + * Portions of this code were derived from NetBSD source code which has + * the following copyright notice: + * + * Copyright (c) 1988, 1993, 1994 + * The Regents of the University of California. All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. All advertising materials mentioning features or use of this software + * must display the following acknowledgement: + * This product includes software developed by the University of + * California, Berkeley and its contributors. + * 4. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +#include "tclInt.h" +#include "tclPort.h" +#include <utime.h> +#include <grp.h> + +/* + * The following constants specify the type of callback when + * TraverseUnixTree() calls the traverseProc() + */ + +#define DOTREE_PRED 1 /* pre-order directory */ +#define DOTREE_POSTD 2 /* post-order directory */ +#define DOTREE_F 3 /* regular file */ + +/* + * Callbacks for file attributes code. + */ + +static int GetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, + Tcl_Obj **attributePtrPtr)); +static int GetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, + Tcl_Obj **attributePtrPtr)); +static int GetPermissionsAttribute _ANSI_ARGS_(( + Tcl_Interp *interp, int objIndex, char *fileName, + Tcl_Obj **attributePtrPtr)); +static int SetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, + Tcl_Obj *attributePtr)); +static int SetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, + Tcl_Obj *attributePtr)); +static int SetPermissionsAttribute _ANSI_ARGS_(( + Tcl_Interp *interp, int objIndex, char *fileName, + Tcl_Obj *attributePtr)); + +/* + * Prototype for the TraverseUnixTree callback function. + */ + +typedef int (TraversalProc) _ANSI_ARGS_((char *src, char *dst, + struct stat *sb, int type, Tcl_DString *errorPtr)); + +/* + * Constants and variables necessary for file attributes subcommand. + */ + +enum { + UNIX_GROUP_ATTRIBUTE, + UNIX_OWNER_ATTRIBUTE, + UNIX_PERMISSIONS_ATTRIBUTE +}; + +char *tclpFileAttrStrings[] = {"-group", "-owner", "-permissions", + (char *) NULL}; +CONST TclFileAttrProcs tclpFileAttrProcs[] = { + {GetGroupAttribute, SetGroupAttribute}, + {GetOwnerAttribute, SetOwnerAttribute}, + {GetPermissionsAttribute, SetPermissionsAttribute}}; + +/* + * Declarations for local procedures defined in this file: + */ + +static int CopyFile _ANSI_ARGS_((char *src, char *dst, + struct stat *srcStatBufPtr)); +static int CopyFileAtts _ANSI_ARGS_((char *src, char *dst, + struct stat *srcStatBufPtr)); +static int TraversalCopy _ANSI_ARGS_((char *src, char *dst, + struct stat *sbPtr, int type, + Tcl_DString *errorPtr)); +static int TraversalDelete _ANSI_ARGS_((char *src, char *dst, + struct stat *sbPtr, int type, + Tcl_DString *errorPtr)); +static int TraverseUnixTree _ANSI_ARGS_(( + TraversalProc *traversalProc, + Tcl_DString *sourcePath, Tcl_DString *destPath, + Tcl_DString *errorPtr)); + +/* + *--------------------------------------------------------------------------- + * + * TclpRenameFile -- + * + * Changes the name of an existing file or directory, from src to dst. + * If src and dst refer to the same file or directory, does nothing + * and returns success. Otherwise if dst already exists, it will be + * deleted and replaced by src subject to the following conditions: + * If src is a directory, dst may be an empty directory. + * If src is a file, dst may be a file. + * In any other situation where dst already exists, the rename will + * fail. + * + * Results: + * If the directory was successfully created, returns TCL_OK. + * Otherwise the return value is TCL_ERROR and errno is set to + * indicate the error. Some possible values for errno are: + * + * EACCES: src or dst parent directory can't be read and/or written. + * EEXIST: dst is a non-empty directory. + * EINVAL: src is a root directory or dst is a subdirectory of src. + * EISDIR: dst is a directory, but src is not. + * ENOENT: src doesn't exist, or src or dst is "". + * ENOTDIR: src is a directory, but dst is not. + * EXDEV: src and dst are on different filesystems. + * + * Side effects: + * The implementation of rename may allow cross-filesystem renames, + * but the caller should be prepared to emulate it with copy and + * delete if errno is EXDEV. + * + *--------------------------------------------------------------------------- + */ + +int +TclpRenameFile(src, dst) + char *src; /* Pathname of file or dir to be renamed. */ + char *dst; /* New pathname of file or directory. */ +{ + if (rename(src, dst) == 0) { + return TCL_OK; + } + if (errno == ENOTEMPTY) { + errno = EEXIST; + } + +#ifdef sparc + /* + * SunOS 4.1.4 reports overwriting a non-empty directory with a + * directory as EINVAL instead of EEXIST (first rule out the correct + * EINVAL result code for moving a directory into itself). Must be + * conditionally compiled because realpath() is only defined on SunOS. + */ + + if (errno == EINVAL) { + char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN]; + DIR *dirPtr; + struct dirent *dirEntPtr; + + if ((realpath(src, srcPath) != NULL) + && (realpath(dst, dstPath) != NULL) + && (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) { + dirPtr = opendir(dst); + if (dirPtr != NULL) { + while ((dirEntPtr = readdir(dirPtr)) != NULL) { + if ((strcmp(dirEntPtr->d_name, ".") != 0) && + (strcmp(dirEntPtr->d_name, "..") != 0)) { + errno = EEXIST; + closedir(dirPtr); + return TCL_ERROR; + } + } + closedir(dirPtr); + } + } + errno = EINVAL; + } +#endif /* sparc */ + + if (strcmp(src, "/") == 0) { + /* + * Alpha reports renaming / as EBUSY and Linux reports it as EACCES, + * instead of EINVAL. + */ + + errno = EINVAL; + } + + /* + * DEC Alpha OSF1 V3.0 returns EACCES when attempting to move a + * file across filesystems and the parent directory of that file is + * not writable. Most other systems return EXDEV. Does nothing to + * correct this behavior. + */ + + return TCL_ERROR; +} + + +/* + *--------------------------------------------------------------------------- + * + * TclpCopyFile -- + * + * Copy a single file (not a directory). If dst already exists and + * is not a directory, it is removed. + * + * Results: + * If the file was successfully copied, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the + * error. Some possible values for errno are: + * + * EACCES: src or dst parent directory can't be read and/or written. + * EISDIR: src or dst is a directory. + * ENOENT: src doesn't exist. src or dst is "". + * + * Side effects: + * This procedure will also copy symbolic links, block, and + * character devices, and fifos. For symbolic links, the links + * themselves will be copied and not what they point to. For the + * other special file types, the directory entry will be copied and + * not the contents of the device that it refers to. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCopyFile(src, dst) + char *src; /* Pathname of file to be copied. */ + char *dst; /* Pathname of file to copy to. */ +{ + struct stat srcStatBuf, dstStatBuf; + char link[MAXPATHLEN]; + int length; + + /* + * Have to do a stat() to determine the filetype. + */ + + if (lstat(src, &srcStatBuf) != 0) { + return TCL_ERROR; + } + if (S_ISDIR(srcStatBuf.st_mode)) { + errno = EISDIR; + return TCL_ERROR; + } + + /* + * symlink, and some of the other calls will fail if the target + * exists, so we remove it first + */ + + if (lstat(dst, &dstStatBuf) == 0) { + if (S_ISDIR(dstStatBuf.st_mode)) { + errno = EISDIR; + return TCL_ERROR; + } + } + if (unlink(dst) != 0) { + if (errno != ENOENT) { + return TCL_ERROR; + } + } + + switch ((int) (srcStatBuf.st_mode & S_IFMT)) { + case S_IFLNK: + length = readlink(src, link, sizeof(link)); + if (length == -1) { + return TCL_ERROR; + } + link[length] = '\0'; + if (symlink(link, dst) < 0) { + return TCL_ERROR; + } + break; + + case S_IFBLK: + case S_IFCHR: + if (mknod(dst, srcStatBuf.st_mode, srcStatBuf.st_rdev) < 0) { + return TCL_ERROR; + } + return CopyFileAtts(src, dst, &srcStatBuf); + + case S_IFIFO: + if (mkfifo(dst, srcStatBuf.st_mode) < 0) { + return TCL_ERROR; + } + return CopyFileAtts(src, dst, &srcStatBuf); + + default: + return CopyFile(src, dst, &srcStatBuf); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CopyFile - + * + * Helper function for TclpCopyFile. Copies one regular file, + * using read() and write(). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A file is copied. Dst will be overwritten if it exists. + * + *---------------------------------------------------------------------- + */ + +static int +CopyFile(src, dst, srcStatBufPtr) + char *src; /* Pathname of file to copy. */ + char *dst; /* Pathname of file to create/overwrite. */ + struct stat *srcStatBufPtr; /* Used to determine mode and blocksize */ +{ + int srcFd; + int dstFd; + u_int blockSize; /* Optimal I/O blocksize for filesystem */ + char *buffer; /* Data buffer for copy */ + size_t nread; + + if ((srcFd = open(src, O_RDONLY, 0)) < 0) { + return TCL_ERROR; + } + + dstFd = open(dst, O_CREAT | O_TRUNC | O_WRONLY, srcStatBufPtr->st_mode); + if (dstFd < 0) { + close(srcFd); + return TCL_ERROR; + } + +#if HAVE_ST_BLKSIZE + blockSize = srcStatBufPtr->st_blksize; +#else + blockSize = 4096; +#endif + + buffer = ckalloc(blockSize); + while (1) { + nread = read(srcFd, buffer, blockSize); + if ((nread == -1) || (nread == 0)) { + break; + } + if (write(dstFd, buffer, nread) != nread) { + nread = (size_t) -1; + break; + } + } + + ckfree(buffer); + close(srcFd); + if ((close(dstFd) != 0) || (nread == -1)) { + unlink(dst); + return TCL_ERROR; + } + if (CopyFileAtts(src, dst, srcStatBufPtr) == TCL_ERROR) { + /* + * The copy succeeded, but setting the permissions failed, so be in + * a consistent state, we remove the file that was created by the + * copy. + */ + + unlink(dst); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpDeleteFile -- + * + * Removes a single file (not a directory). + * + * Results: + * If the file was successfully deleted, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the + * error. Some possible values for errno are: + * + * EACCES: a parent directory can't be read and/or written. + * EISDIR: path is a directory. + * ENOENT: path doesn't exist or is "". + * + * Side effects: + * The file is deleted, even if it is read-only. + * + *--------------------------------------------------------------------------- + */ + +int +TclpDeleteFile(path) + char *path; /* Pathname of file to be removed. */ +{ + if (unlink(path) != 0) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpCreateDirectory -- + * + * Creates the specified directory. All parent directories of the + * specified directory must already exist. The directory is + * automatically created with permissions so that user can access + * the new directory and create new files or subdirectories in it. + * + * Results: + * If the directory was successfully created, returns TCL_OK. + * Otherwise the return value is TCL_ERROR and errno is set to + * indicate the error. Some possible values for errno are: + * + * EACCES: a parent directory can't be read and/or written. + * EEXIST: path already exists. + * ENOENT: a parent directory doesn't exist. + * + * Side effects: + * A directory is created with the current umask, except that + * permission for u+rwx will always be added. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCreateDirectory(path) + char *path; /* Pathname of directory to create. */ +{ + mode_t mode; + + mode = umask(0); + umask(mode); + + /* + * umask return value is actually the inverse of the permissions. + */ + + mode = (0777 & ~mode); + + if (mkdir(path, mode | S_IRUSR | S_IWUSR | S_IXUSR) != 0) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpCopyDirectory -- + * + * Recursively copies a directory. The target directory dst must + * not already exist. Note that this function does not merge two + * directory hierarchies, even if the target directory is an an + * empty directory. + * + * Results: + * If the directory was successfully copied, returns TCL_OK. + * Otherwise the return value is TCL_ERROR, errno is set to indicate + * the error, and the pathname of the file that caused the error + * is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile + * for a description of possible values for errno. + * + * Side effects: + * An exact copy of the directory hierarchy src will be created + * with the name dst. If an error occurs, the error will + * be returned immediately, and remaining files will not be + * processed. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCopyDirectory(src, dst, errorPtr) + char *src; /* Pathname of directory to be copied. */ + char *dst; /* Pathname of target directory. */ + Tcl_DString *errorPtr; /* If non-NULL, initialized DString for + * error reporting. */ +{ + int result; + Tcl_DString srcBuffer; + Tcl_DString dstBuffer; + + Tcl_DStringInit(&srcBuffer); + Tcl_DStringInit(&dstBuffer); + Tcl_DStringAppend(&srcBuffer, src, -1); + Tcl_DStringAppend(&dstBuffer, dst, -1); + result = TraverseUnixTree(TraversalCopy, &srcBuffer, &dstBuffer, + errorPtr); + Tcl_DStringFree(&srcBuffer); + Tcl_DStringFree(&dstBuffer); + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpRemoveDirectory -- + * + * Removes directory (and its contents, if the recursive flag is set). + * + * Results: + * If the directory was successfully removed, returns TCL_OK. + * Otherwise the return value is TCL_ERROR, errno is set to indicate + * the error, and the pathname of the file that caused the error + * is stored in errorPtr. Some possible values for errno are: + * + * EACCES: path directory can't be read and/or written. + * EEXIST: path is a non-empty directory. + * EINVAL: path is a root directory. + * ENOENT: path doesn't exist or is "". + * ENOTDIR: path is not a directory. + * + * Side effects: + * Directory removed. If an error occurs, the error will be returned + * immediately, and remaining files will not be deleted. + * + *--------------------------------------------------------------------------- + */ + +int +TclpRemoveDirectory(path, recursive, errorPtr) + char *path; /* Pathname of directory to be removed. */ + int recursive; /* If non-zero, removes directories that + * are nonempty. Otherwise, will only remove + * empty directories. */ + Tcl_DString *errorPtr; /* If non-NULL, initialized DString for + * error reporting. */ +{ + int result; + Tcl_DString buffer; + + if (rmdir(path) == 0) { + return TCL_OK; + } + if (errno == ENOTEMPTY) { + errno = EEXIST; + } + if ((errno != EEXIST) || (recursive == 0)) { + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, path, -1); + } + return TCL_ERROR; + } + + /* + * The directory is nonempty, but the recursive flag has been + * specified, so we recursively remove all the files in the directory. + */ + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, path, -1); + result = TraverseUnixTree(TraversalDelete, &buffer, NULL, errorPtr); + Tcl_DStringFree(&buffer); + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * TraverseUnixTree -- + * + * Traverse directory tree specified by sourcePtr, calling the function + * traverseProc for each file and directory encountered. If destPtr + * is non-null, each of name in the sourcePtr directory is appended to + * the directory specified by destPtr and passed as the second argument + * to traverseProc() . + * + * Results: + * Standard Tcl result. + * + * Side effects: + * None caused by TraverseUnixTree, however the user specified + * traverseProc() may change state. If an error occurs, the error will + * be returned immediately, and remaining files will not be processed. + * + *--------------------------------------------------------------------------- + */ + +static int +TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr) + TraversalProc *traverseProc;/* Function to call for every file and + * directory in source hierarchy. */ + Tcl_DString *sourcePtr; /* Pathname of source directory to be + * traversed. */ + Tcl_DString *targetPtr; /* Pathname of directory to traverse in + * parallel with source directory. */ + Tcl_DString *errorPtr; /* If non-NULL, an initialized DString for + * error reporting. */ +{ + struct stat statbuf; + char *source, *target, *errfile; + int result, sourceLen; + int targetLen = 0; /* Initialization needed only to prevent + * warning in gcc. */ + struct dirent *dirp; + DIR *dp; + + result = TCL_OK; + source = Tcl_DStringValue(sourcePtr); + if (targetPtr != NULL) { + target = Tcl_DStringValue(targetPtr); + } else { + target = NULL; + } + + errfile = NULL; + if (lstat(source, &statbuf) != 0) { + errfile = source; + goto end; + } + if (!S_ISDIR(statbuf.st_mode)) { + /* + * Process the regular file + */ + + return (*traverseProc)(source, target, &statbuf, DOTREE_F, errorPtr); + } + + dp = opendir(source); + if (dp == NULL) { + /* + * Can't read directory + */ + + errfile = source; + goto end; + } + result = (*traverseProc)(source, target, &statbuf, DOTREE_PRED, errorPtr); + if (result != TCL_OK) { + closedir(dp); + return result; + } + + Tcl_DStringAppend(sourcePtr, "/", 1); + source = Tcl_DStringValue(sourcePtr); + sourceLen = Tcl_DStringLength(sourcePtr); + + if (targetPtr != NULL) { + Tcl_DStringAppend(targetPtr, "/", 1); + target = Tcl_DStringValue(targetPtr); + targetLen = Tcl_DStringLength(targetPtr); + } + + while ((dirp = readdir(dp)) != NULL) { + if ((strcmp(dirp->d_name, ".") == 0) + || (strcmp(dirp->d_name, "..") == 0)) { + continue; + } + + /* + * Append name after slash, and recurse on the file. + */ + + Tcl_DStringAppend(sourcePtr, dirp->d_name, -1); + if (targetPtr != NULL) { + Tcl_DStringAppend(targetPtr, dirp->d_name, -1); + } + result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr, + errorPtr); + if (result != TCL_OK) { + break; + } + + /* + * Remove name after slash. + */ + + Tcl_DStringSetLength(sourcePtr, sourceLen); + if (targetPtr != NULL) { + Tcl_DStringSetLength(targetPtr, targetLen); + } + } + closedir(dp); + + /* + * Strip off the trailing slash we added + */ + + Tcl_DStringSetLength(sourcePtr, sourceLen - 1); + source = Tcl_DStringValue(sourcePtr); + if (targetPtr != NULL) { + Tcl_DStringSetLength(targetPtr, targetLen - 1); + target = Tcl_DStringValue(targetPtr); + } + + if (result == TCL_OK) { + /* + * Call traverseProc() on a directory after visiting all the + * files in that directory. + */ + + result = (*traverseProc)(source, target, &statbuf, DOTREE_POSTD, + errorPtr); + } + end: + if (errfile != NULL) { + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, errfile, -1); + } + result = TCL_ERROR; + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TraversalCopy + * + * Called from TraverseUnixTree in order to execute a recursive copy of a + * directory. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * The file or directory src may be copied to dst, depending on + * the value of type. + * + *---------------------------------------------------------------------- + */ + +static int +TraversalCopy(src, dst, sbPtr, type, errorPtr) + char *src; /* Source pathname to copy. */ + char *dst; /* Destination pathname of copy. */ + struct stat *sbPtr; /* Stat info for file specified by src. */ + int type; /* Reason for call - see TraverseUnixTree(). */ + Tcl_DString *errorPtr; /* If non-NULL, initialized DString for + * error return. */ +{ + switch (type) { + case DOTREE_F: + if (TclpCopyFile(src, dst) == TCL_OK) { + return TCL_OK; + } + break; + + case DOTREE_PRED: + if (TclpCreateDirectory(dst) == TCL_OK) { + return TCL_OK; + } + break; + + case DOTREE_POSTD: + if (CopyFileAtts(src, dst, sbPtr) == TCL_OK) { + return TCL_OK; + } + break; + + } + + /* + * There shouldn't be a problem with src, because we already + * checked it to get here. + */ + + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, dst, -1); + } + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TraversalDelete -- + * + * Called by procedure TraverseUnixTree for every file and directory + * that it encounters in a directory hierarchy. This procedure unlinks + * files, and removes directories after all the containing files + * have been processed. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Files or directory specified by src will be deleted. + * + *---------------------------------------------------------------------- + */ + +static int +TraversalDelete(src, ignore, sbPtr, type, errorPtr) + char *src; /* Source pathname. */ + char *ignore; /* Destination pathname (not used). */ + struct stat *sbPtr; /* Stat info for file specified by src. */ + int type; /* Reason for call - see TraverseUnixTree(). */ + Tcl_DString *errorPtr; /* If non-NULL, initialized DString for + * error return. */ +{ + switch (type) { + case DOTREE_F: + if (unlink(src) == 0) { + return TCL_OK; + } + break; + + case DOTREE_PRED: + return TCL_OK; + + case DOTREE_POSTD: + if (rmdir(src) == 0) { + return TCL_OK; + } + break; + + } + + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, src, -1); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * CopyFileAtts + * + * Copy the file attributes such as owner, group, permissions, and + * modification date from one file to another. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * user id, group id, permission bits, last modification time, and + * last access time are updated in the new file to reflect the old + * file. + * + *---------------------------------------------------------------------- + */ + +static int +CopyFileAtts(src, dst, statBufPtr) + char *src; /* Path name of source file */ + char *dst; /* Path name of target file */ + struct stat *statBufPtr; /* ptr to stat info for source file */ +{ + struct utimbuf tval; + mode_t newMode; + + newMode = statBufPtr->st_mode + & (S_ISUID | S_ISGID | S_IRWXU | S_IRWXG | S_IRWXO); + + /* + * Note that if you copy a setuid file that is owned by someone + * else, and you are not root, then the copy will be setuid to you. + * The most correct implementation would probably be to have the + * copy not setuid to anyone if the original file was owned by + * someone else, but this corner case isn't currently handled. + * It would require another lstat(), or getuid(). + */ + + if (chmod(dst, newMode)) { + newMode &= ~(S_ISUID | S_ISGID); + if (chmod(dst, newMode)) { + return TCL_ERROR; + } + } + + tval.actime = statBufPtr->st_atime; + tval.modtime = statBufPtr->st_mtime; + + if (utime(dst, &tval)) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetGroupAttribute + * + * Gets the group attribute of a file. + * + * Results: + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr + * if there is no error. + * + * Side effects: + * A new object is allocated. + * + *---------------------------------------------------------------------- + */ + +static int +GetGroupAttribute(interp, objIndex, fileName, attributePtrPtr) + Tcl_Interp *interp; /* The interp we are using for errors. */ + int objIndex; /* The index of the attribute. */ + char *fileName; /* The name of the file. */ + Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ +{ + struct stat statBuf; + struct group *groupPtr; + + if (stat(fileName, &statBuf) != 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not stat file \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + groupPtr = getgrgid(statBuf.st_gid); + if (groupPtr == NULL) { + *attributePtrPtr = Tcl_NewIntObj(statBuf.st_gid); + } else { + *attributePtrPtr = Tcl_NewStringObj(groupPtr->gr_name, -1); + } + endgrent(); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetOwnerAttribute + * + * Gets the owner attribute of a file. + * + * Results: + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr + * if there is no error. + * + * Side effects: + * A new object is allocated. + * + *---------------------------------------------------------------------- + */ + +static int +GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr) + Tcl_Interp *interp; /* The interp we are using for errors. */ + int objIndex; /* The index of the attribute. */ + char *fileName; /* The name of the file. */ + Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ +{ + struct stat statBuf; + struct passwd *pwPtr; + + if (stat(fileName, &statBuf) != 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not stat file \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + pwPtr = getpwuid(statBuf.st_uid); + if (pwPtr == NULL) { + *attributePtrPtr = Tcl_NewIntObj(statBuf.st_uid); + } else { + *attributePtrPtr = Tcl_NewStringObj(pwPtr->pw_name, -1); + } + endpwent(); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetPermissionsAttribute + * + * Gets the group attribute of a file. + * + * Results: + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr + * if there is no error. The object will have ref count 0. + * + * Side effects: + * A new object is allocated. + * + *---------------------------------------------------------------------- + */ + +static int +GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr) + Tcl_Interp *interp; /* The interp we are using for errors. */ + int objIndex; /* The index of the attribute. */ + char *fileName; /* The name of the file. */ + Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ +{ + struct stat statBuf; + char returnString[6]; + + if (stat(fileName, &statBuf) != 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not stat file \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + sprintf(returnString, "%0#5lo", (statBuf.st_mode & 0x00007FFF)); + + *attributePtrPtr = Tcl_NewStringObj(returnString, -1); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SetGroupAttribute + * + * Sets the file to the given group. + * + * Results: + * Standard TCL result. + * + * Side effects: + * The group of the file is changed. + * + *---------------------------------------------------------------------- + */ + +static int +SetGroupAttribute(interp, objIndex, fileName, attributePtr) + Tcl_Interp *interp; /* The interp we are using for errors. */ + int objIndex; /* The index of the attribute. */ + char *fileName; /* The name of the file. */ + Tcl_Obj *attributePtr; /* The attribute to set. */ +{ + gid_t groupNumber; + long placeHolder; + + if (Tcl_GetLongFromObj(interp, attributePtr, &placeHolder) != TCL_OK) { + struct group *groupPtr; + char *groupString = Tcl_GetStringFromObj(attributePtr, NULL); + + Tcl_ResetResult(interp); + groupPtr = getgrnam(groupString); + if (groupPtr == NULL) { + endgrent(); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not set group for file \"", fileName, + "\": group \"", groupString, "\" does not exist", + (char *) NULL); + return TCL_ERROR; + } + groupNumber = groupPtr->gr_gid; + } else { + groupNumber = (gid_t) placeHolder; + } + + if (chown(fileName, -1, groupNumber) != 0) { + endgrent(); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not set group for file \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + endgrent(); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SetOwnerAttribute + * + * Sets the file to the given owner. + * + * Results: + * Standard TCL result. + * + * Side effects: + * The group of the file is changed. + * + *---------------------------------------------------------------------- + */ + +static int +SetOwnerAttribute(interp, objIndex, fileName, attributePtr) + Tcl_Interp *interp; /* The interp we are using for errors. */ + int objIndex; /* The index of the attribute. */ + char *fileName; /* The name of the file. */ + Tcl_Obj *attributePtr; /* The attribute to set. */ +{ + uid_t userNumber; + long placeHolder; + + if (Tcl_GetLongFromObj(interp, attributePtr, &placeHolder) != TCL_OK) { + struct passwd *pwPtr; + char *ownerString = Tcl_GetStringFromObj(attributePtr, NULL); + + Tcl_ResetResult(interp); + pwPtr = getpwnam(ownerString); + if (pwPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not set owner for file \"", fileName, + "\": user \"", ownerString, "\" does not exist", + (char *) NULL); + return TCL_ERROR; + } + userNumber = pwPtr->pw_uid; + } else { + userNumber = (uid_t) placeHolder; + } + + if (chown(fileName, userNumber, -1) != 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not set owner for file \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SetPermissionsAttribute + * + * Sets the file to the given group. + * + * Results: + * Standard TCL result. + * + * Side effects: + * The group of the file is changed. + * + *---------------------------------------------------------------------- + */ + +static int +SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) + Tcl_Interp *interp; /* The interp we are using for errors. */ + int objIndex; /* The index of the attribute. */ + char *fileName; /* The name of the file. */ + Tcl_Obj *attributePtr; /* The attribute to set. */ +{ + long modeInt; + mode_t newMode; + + /* + * mode_t is a long under SPARC; an int under SunOS. Since we do not + * know how big it really is, we get the long and then cast it + * down to a mode_t. + */ + + if (Tcl_GetLongFromObj(interp, attributePtr, &modeInt) + != TCL_OK) { + return TCL_ERROR; + } + + newMode = (mode_t) modeInt; + + if (chmod(fileName, newMode) != 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not set permissions for file \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} +/* + *--------------------------------------------------------------------------- + * + * TclpListVolumes -- + * + * Lists the currently mounted volumes, which on UNIX is just /. + * + * Results: + * A standard Tcl result. Will always be TCL_OK, since there is no way + * that this command can fail. Also, the interpreter's result is set to + * the list of volumes. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +TclpListVolumes(interp) + Tcl_Interp *interp; /* Interpreter to which to pass + * the volume list. */ +{ + Tcl_Obj *resultPtr; + + resultPtr = Tcl_GetObjResult(interp); + Tcl_SetStringObj(resultPtr, "/", 1); + return TCL_OK; +} + diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c new file mode 100644 index 0000000..eb11006 --- /dev/null +++ b/unix/tclUnixFile.c @@ -0,0 +1,528 @@ +/* + * tclUnixFile.c -- + * + * This file contains wrappers around UNIX file handling functions. + * These wrappers mask differences between Windows and UNIX. + * + * Copyright (c) 1995 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: @(#) tclUnixFile.c 1.48 97/07/07 16:38:11 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The variable below caches the name of the current working directory + * in order to avoid repeated calls to getcwd. The string is malloc-ed. + * NULL means the cache needs to be refreshed. + */ + +static char *currentDir = NULL; +static int currentDirExitHandlerSet = 0; + +/* + * The variable below is set if the exit routine for deleting the string + * containing the executable name has been registered. + */ + +static int executableNameExitHandlerSet = 0; + +extern pid_t waitpid _ANSI_ARGS_((pid_t pid, int *stat_loc, int options)); + +/* + * Static routines for this file: + */ + +static void FreeCurrentDir _ANSI_ARGS_((ClientData clientData)); +static void FreeExecutableName _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * FreeCurrentDir -- + * + * Frees the string stored in the currentDir variable. This routine + * is registered as an exit handler and will be called during shutdown. + * + * Results: + * None. + * + * Side effects: + * Frees the memory occuppied by the currentDir value. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +FreeCurrentDir(clientData) + ClientData clientData; /* Not used. */ +{ + if (currentDir != (char *) NULL) { + ckfree(currentDir); + currentDir = (char *) NULL; + currentDirExitHandlerSet = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * FreeExecutableName -- + * + * Frees the string stored in the tclExecutableName variable. This + * routine is registered as an exit handler and will be called + * during shutdown. + * + * Results: + * None. + * + * Side effects: + * Frees the memory occuppied by the tclExecutableName value. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +FreeExecutableName(clientData) + ClientData clientData; /* Not used. */ +{ + if (tclExecutableName != (char *) NULL) { + ckfree(tclExecutableName); + tclExecutableName = (char *) NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclChdir -- + * + * Change the current working directory. + * + * Results: + * The result is a standard Tcl result. If an error occurs and + * interp isn't NULL, an error message is left in interp->result. + * + * Side effects: + * The working directory for this application is changed. Also + * the cache maintained used by TclGetCwd is deallocated and + * set to NULL. + * + *---------------------------------------------------------------------- + */ + +int +TclChdir(interp, dirName) + Tcl_Interp *interp; /* If non NULL, used for error reporting. */ + char *dirName; /* Path to new working directory. */ +{ + if (currentDir != NULL) { + ckfree(currentDir); + currentDir = NULL; + } + if (chdir(dirName) != 0) { + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't change working directory to \"", + dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetCwd -- + * + * Return the path name of the current working directory. + * + * Results: + * The result is the full path name of the current working + * directory, or NULL if an error occurred while figuring it out. + * The returned string is owned by the TclGetCwd routine and must + * not be freed by the caller. If an error occurs and interp + * isn't NULL, an error message is left in interp->result. + * + * Side effects: + * The path name is cached to avoid having to recompute it + * on future calls; if it is already cached, the cached + * value is returned. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetCwd(interp) + Tcl_Interp *interp; /* If non NULL, used for error reporting. */ +{ + char buffer[MAXPATHLEN+1]; + + if (currentDir == NULL) { + if (!currentDirExitHandlerSet) { + currentDirExitHandlerSet = 1; + Tcl_CreateExitHandler(FreeCurrentDir, (ClientData) NULL); + } +#ifdef USEGETWD + if ((int)getwd(buffer) == (int)NULL) { + if (interp != NULL) { + Tcl_AppendResult(interp, + "error getting working directory name: ", + buffer, (char *)NULL); + } + return NULL; + } +#else + if (getcwd(buffer, MAXPATHLEN+1) == NULL) { + if (interp != NULL) { + if (errno == ERANGE) { + Tcl_SetResult(interp, + "working directory name is too long", + TCL_STATIC); + } else { + Tcl_AppendResult(interp, + "error getting working directory name: ", + Tcl_PosixError(interp), (char *) NULL); + } + } + return NULL; + } +#endif + currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1)); + strcpy(currentDir, buffer); + } + return currentDir; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindExecutable -- + * + * This procedure computes the absolute path name of the current + * application, given its argv[0] value. + * + * Results: + * None. + * + * Side effects: + * The variable tclExecutableName gets filled in with the file + * name for the application, if we figured it out. If we couldn't + * figure it out, Tcl_FindExecutable is set to NULL. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FindExecutable(argv0) + char *argv0; /* The value of the application's argv[0]. */ +{ + char *name, *p, *cwd; + Tcl_DString buffer; + int length; + struct stat statBuf; + + Tcl_DStringInit(&buffer); + if (tclExecutableName != NULL) { + ckfree(tclExecutableName); + tclExecutableName = NULL; + } + + name = argv0; + for (p = name; *p != 0; p++) { + if (*p == '/') { + /* + * The name contains a slash, so use the name directly + * without doing a path search. + */ + + goto gotName; + } + } + + p = getenv("PATH"); + if (p == NULL) { + /* + * There's no PATH environment variable; use the default that + * is used by sh. + */ + + p = ":/bin:/usr/bin"; + } + + /* + * Search through all the directories named in the PATH variable + * to see if argv[0] is in one of them. If so, use that file + * name. + */ + + while (*p != 0) { + while (isspace(UCHAR(*p))) { + p++; + } + name = p; + while ((*p != ':') && (*p != 0)) { + p++; + } + Tcl_DStringSetLength(&buffer, 0); + if (p != name) { + Tcl_DStringAppend(&buffer, name, p-name); + if (p[-1] != '/') { + Tcl_DStringAppend(&buffer, "/", 1); + } + } + Tcl_DStringAppend(&buffer, argv0, -1); + if ((access(Tcl_DStringValue(&buffer), X_OK) == 0) + && (stat(Tcl_DStringValue(&buffer), &statBuf) == 0) + && S_ISREG(statBuf.st_mode)) { + name = Tcl_DStringValue(&buffer); + goto gotName; + } + if (*p == 0) { + break; + } + p++; + } + goto done; + + /* + * If the name starts with "/" then just copy it to tclExecutableName. + */ + + gotName: + if (name[0] == '/') { + tclExecutableName = (char *) ckalloc((unsigned) (strlen(name) + 1)); + strcpy(tclExecutableName, name); + goto done; + } + + /* + * The name is relative to the current working directory. First + * strip off a leading "./", if any, then add the full path name of + * the current working directory. + */ + + if ((name[0] == '.') && (name[1] == '/')) { + name += 2; + } + cwd = TclGetCwd((Tcl_Interp *) NULL); + if (cwd == NULL) { + tclExecutableName = NULL; + goto done; + } + length = strlen(cwd); + tclExecutableName = (char *) ckalloc((unsigned) + (length + strlen(name) + 2)); + strcpy(tclExecutableName, cwd); + tclExecutableName[length] = '/'; + strcpy(tclExecutableName + length + 1, name); + + done: + Tcl_DStringFree(&buffer); + + if (!executableNameExitHandlerSet) { + executableNameExitHandlerSet = 1; + Tcl_CreateExitHandler(FreeExecutableName, (ClientData) NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetUserHome -- + * + * This function takes the passed in user name and finds the + * corresponding home directory specified in the password file. + * + * Results: + * The result is a pointer to a static string containing + * the new name. If there was an error in processing the + * user name then the return value is NULL. Otherwise the + * result is stored in bufferPtr, and the caller must call + * Tcl_DStringFree(bufferPtr) to free the result. + * + * Side effects: + * Information may be left in bufferPtr. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetUserHome(name, bufferPtr) + char *name; /* User name to use to find home directory. */ + Tcl_DString *bufferPtr; /* May be used to hold result. Must not hold + * anything at the time of the call, and need + * not even be initialized. */ +{ + struct passwd *pwPtr; + + pwPtr = getpwnam(name); + if (pwPtr == NULL) { + endpwent(); + return NULL; + } + Tcl_DStringInit(bufferPtr); + Tcl_DStringAppend(bufferPtr, pwPtr->pw_dir, -1); + endpwent(); + return bufferPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * TclMatchFiles -- + * + * This routine is used by the globbing code to search a + * directory for all files which match a given pattern. + * + * Results: + * If the tail argument is NULL, then the matching files are + * added to the interp->result. Otherwise, TclDoGlob is called + * recursively for each matching subdirectory. The return value + * is a standard Tcl result indicating whether an error occurred + * in globbing. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclMatchFiles(interp, separators, dirPtr, pattern, tail) + Tcl_Interp *interp; /* Interpreter to receive results. */ + char *separators; /* Path separators to pass to TclDoGlob. */ + Tcl_DString *dirPtr; /* Contains path to directory to search. */ + char *pattern; /* Pattern to match against. */ + char *tail; /* Pointer to end of pattern. */ +{ + char *dirName, *patternEnd = tail; + char savedChar = 0; /* Initialization needed only to prevent + * compiler warning from gcc. */ + DIR *d; + struct stat statBuf; + struct dirent *entryPtr; + int matchHidden; + int result = TCL_OK; + int baseLength = Tcl_DStringLength(dirPtr); + + /* + * Make sure that the directory part of the name really is a + * directory. If the directory name is "", use the name "." + * instead, because some UNIX systems don't treat "" like "." + * automatically. Keep the "" for use in generating file names, + * otherwise "glob foo.c" would return "./foo.c". + */ + + if (dirPtr->string[0] == '\0') { + dirName = "."; + } else { + dirName = dirPtr->string; + } + if ((stat(dirName, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { + return TCL_OK; + } + + /* + * Check to see if the pattern needs to compare with hidden files. + */ + + if ((pattern[0] == '.') + || ((pattern[0] == '\\') && (pattern[1] == '.'))) { + matchHidden = 1; + } else { + matchHidden = 0; + } + + /* + * Now open the directory for reading and iterate over the contents. + */ + + d = opendir(dirName); + if (d == NULL) { + Tcl_ResetResult(interp); + + /* + * Strip off a trailing '/' if necessary, before reporting the error. + */ + + if (baseLength > 0) { + savedChar = dirPtr->string[baseLength-1]; + if (savedChar == '/') { + dirPtr->string[baseLength-1] = '\0'; + } + } + Tcl_AppendResult(interp, "couldn't read directory \"", + dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL); + if (baseLength > 0) { + dirPtr->string[baseLength-1] = savedChar; + } + return TCL_ERROR; + } + + /* + * Clean up the end of the pattern and the tail pointer. Leave + * the tail pointing to the first character after the path separator + * following the pattern, or NULL. Also, ensure that the pattern + * is null-terminated. + */ + + if (*tail == '\\') { + tail++; + } + if (*tail == '\0') { + tail = NULL; + } else { + tail++; + } + savedChar = *patternEnd; + *patternEnd = '\0'; + + while (1) { + entryPtr = readdir(d); + if (entryPtr == NULL) { + break; + } + + /* + * Don't match names starting with "." unless the "." is + * present in the pattern. + */ + + if (!matchHidden && (*entryPtr->d_name == '.')) { + continue; + } + + /* + * Now check to see if the file matches. If there are more + * characters to be processed, then ensure matching files are + * directories before calling TclDoGlob. Otherwise, just add + * the file to the result. + */ + + if (Tcl_StringMatch(entryPtr->d_name, pattern)) { + Tcl_DStringSetLength(dirPtr, baseLength); + Tcl_DStringAppend(dirPtr, entryPtr->d_name, -1); + if (tail == NULL) { + Tcl_AppendElement(interp, dirPtr->string); + } else if ((stat(dirPtr->string, &statBuf) == 0) + && S_ISDIR(statBuf.st_mode)) { + Tcl_DStringAppend(dirPtr, "/", 1); + result = TclDoGlob(interp, separators, dirPtr, tail); + if (result != TCL_OK) { + break; + } + } + } + } + *patternEnd = savedChar; + + closedir(d); + return result; +} diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c new file mode 100644 index 0000000..91d866f --- /dev/null +++ b/unix/tclUnixInit.c @@ -0,0 +1,317 @@ +/* + * tclUnixInit.c -- + * + * Contains the Unix-specific interpreter initialization functions. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixInit.c 1.26 97/08/05 20:09:25 + */ + +#include "tclInt.h" +#include "tclPort.h" +#if defined(__FreeBSD__) +# include <floatingpoint.h> +#endif +#if defined(__bsdi__) +# include <sys/param.h> +# if _BSDI_VERSION > 199501 +# include <dlfcn.h> +# endif +#endif + +/* + * Default directory in which to look for Tcl library scripts. The + * symbol is defined by Makefile. + */ + +static char defaultLibraryDir[200] = TCL_LIBRARY; + +/* + * Directory in which to look for packages (each package is typically + * installed as a subdirectory of this directory). The symbol is + * defined by Makefile. + */ + +static char pkgPath[200] = TCL_PACKAGE_PATH; + +/* + * Is this module initialized? + */ + +static int initialized = 0; + +/* + * The following string is the startup script executed in new + * interpreters. It looks on disk in several different directories + * for a script "init.tcl" that is compatible with this version + * of Tcl. The init.tcl script does all of the real work of + * initialization. + */ + +static char initScript[] = +"proc tclInit {} {\n\ + global tcl_library tcl_version tcl_patchLevel env errorInfo\n\ + global tcl_pkgPath\n\ + rename tclInit {}\n\ + set errors {}\n\ + set dirs {}\n\ + if [info exists env(TCL_LIBRARY)] {\n\ + lappend dirs $env(TCL_LIBRARY)\n\ + }\n\ + lappend dirs [info library]\n\ + set parentDir [file dirname [file dirname [info nameofexecutable]]]\n\ + lappend dirs $parentDir/lib/tcl$tcl_version\n\ + if [string match {*[ab]*} $tcl_patchLevel] {\n\ + set lib tcl$tcl_patchLevel\n\ + } else {\n\ + set lib tcl$tcl_version\n\ + }\n\ + lappend dirs [file dirname $parentDir]/$lib/library\n\ + lappend dirs $parentDir/library\n\ + foreach i $dirs {\n\ + set tcl_library $i\n\ + set tclfile [file join $i init.tcl]\n\ + if {[file exists $tclfile]} {\n\ + lappend tcl_pkgPath [file dirname $i]\n\ + if ![catch {uplevel #0 [list source $tclfile]} msg] {\n\ + return\n\ + } else {\n\ + append errors \"$tclfile: $msg\n$errorInfo\n\"\n\ + }\n\ + }\n\ + }\n\ + set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\ + append msg \" $dirs\n\n\"\n\ + append msg \"$errors\n\n\"\n\ + append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\ + error $msg\n\ +}\n\ +tclInit"; + +/* + * Static routines in this file: + */ + +static void PlatformInitExitHandler _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * PlatformInitExitHandler -- + * + * Uninitializes all values on unload, so that this module can + * be later reinitialized. + * + * Results: + * None. + * + * Side effects: + * Returns the module to uninitialized state. + * + *---------------------------------------------------------------------- + */ + +static void +PlatformInitExitHandler(clientData) + ClientData clientData; /* Unused. */ +{ + strcpy(defaultLibraryDir, TCL_LIBRARY); + strcpy(pkgPath, TCL_PACKAGE_PATH); + initialized = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclPlatformInit -- + * + * Performs Unix-specific interpreter initialization related to the + * tcl_library and tcl_platform variables, and other platform- + * specific things. + * + * Results: + * None. + * + * Side effects: + * Sets "tcl_library" and "tcl_platform" Tcl variables. + * + *---------------------------------------------------------------------- + */ + +void +TclPlatformInit(interp) + Tcl_Interp *interp; +{ +#ifndef NO_UNAME + struct utsname name; +#endif + int unameOK; + + tclPlatform = TCL_PLATFORM_UNIX; + Tcl_SetVar(interp, "tcl_library", defaultLibraryDir, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY); + unameOK = 0; +#ifndef NO_UNAME + if (uname(&name) >= 0) { + unameOK = 1; + Tcl_SetVar2(interp, "tcl_platform", "os", name.sysname, + TCL_GLOBAL_ONLY); + /* + * The following code is a special hack to handle differences in + * the way version information is returned by uname. On most + * systems the full version number is available in name.release. + * However, under AIX the major version number is in + * name.version and the minor version number is in name.release. + */ + + if ((strchr(name.release, '.') != NULL) || !isdigit(name.version[0])) { + Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, + TCL_GLOBAL_ONLY); + } else { + Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version, + TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".", + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); + Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); + } + Tcl_SetVar2(interp, "tcl_platform", "machine", name.machine, + TCL_GLOBAL_ONLY); + } +#endif + if (!unameOK) { + Tcl_SetVar2(interp, "tcl_platform", "os", "", TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY); + } + + if (!initialized) { + + /* + * Create an exit handler so that uninitialization will be done + * on unload. + */ + + Tcl_CreateExitHandler(PlatformInitExitHandler, NULL); + + /* + * The code below causes SIGPIPE (broken pipe) errors to + * be ignored. This is needed so that Tcl processes don't + * die if they create child processes (e.g. using "exec" or + * "open") that terminate prematurely. The signal handler + * is only set up when the first interpreter is created; + * after this the application can override the handler with + * a different one of its own, if it wants. + */ + +#ifdef SIGPIPE + (void) signal(SIGPIPE, SIG_IGN); +#endif /* SIGPIPE */ + +#ifdef __FreeBSD__ + fpsetround(FP_RN); + fpsetmask(0L); +#endif + +#if defined(__bsdi__) && (_BSDI_VERSION > 199501) + /* + * Find local symbols. Don't report an error if we fail. + */ + (void) dlopen (NULL, RTLD_NOW); +#endif + initialized = 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Init -- + * + * This procedure is typically invoked by Tcl_AppInit procedures + * to perform additional initialization for a Tcl interpreter, + * such as sourcing the "init.tcl" script. + * + * Results: + * Returns a standard Tcl completion code and sets interp->result + * if there is an error. + * + * Side effects: + * Depends on what's in the init.tcl script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Init(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ +{ + return Tcl_Eval(interp, initScript); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SourceRCFile -- + * + * This procedure is typically invoked by Tcl_Main of Tk_Main + * procedure to source an application specific rc file into the + * interpreter at startup time. + * + * Results: + * None. + * + * Side effects: + * Depends on what's in the rc script. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SourceRCFile(interp) + Tcl_Interp *interp; /* Interpreter to source rc file into. */ +{ + Tcl_DString temp; + char *fileName; + Tcl_Channel errChannel; + + fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); + + if (fileName != NULL) { + Tcl_Channel c; + char *fullName; + + Tcl_DStringInit(&temp); + fullName = Tcl_TranslateFileName(interp, fileName, &temp); + if (fullName == NULL) { + /* + * Couldn't translate the file name (e.g. it referred to a + * bogus user or there was no HOME environment variable). + * Just do nothing. + */ + } else { + + /* + * Test for the existence of the rc file before trying to read it. + */ + + c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); + if (c != (Tcl_Channel) NULL) { + Tcl_Close(NULL, c); + if (Tcl_EvalFile(interp, fullName) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } + } + } + Tcl_DStringFree(&temp); + } +} diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c new file mode 100644 index 0000000..1a86680 --- /dev/null +++ b/unix/tclUnixNotfy.c @@ -0,0 +1,518 @@ +/* + * tclUnixNotify.c -- + * + * This file contains the implementation of the select-based + * Unix-specific notifier, which is the lowest-level part of the + * Tcl event loop. This file works together with + * ../generic/tclNotify.c. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixNotfy.c 1.44 97/11/05 13:02:20 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include <signal.h> + +/* + * This structure is used to keep track of the notifier info for a + * a registered file. + */ + +typedef struct FileHandler { + int fd; + int mask; /* Mask of desired events: TCL_READABLE, + * etc. */ + int readyMask; /* Mask of events that have been seen since the + * last time file handlers were invoked for + * this file. */ + Tcl_FileProc *proc; /* Procedure to call, in the style of + * Tcl_CreateFileHandler. */ + ClientData clientData; /* Argument to pass to proc. */ + struct FileHandler *nextPtr;/* Next in list of all files we care about. */ +} FileHandler; + +/* + * The following structure is what is added to the Tcl event queue when + * file handlers are ready to fire. + */ + +typedef struct FileHandlerEvent { + Tcl_Event header; /* Information that is standard for + * all events. */ + int fd; /* File descriptor that is ready. Used + * to find the FileHandler structure for + * the file (can't point directly to the + * FileHandler structure because it could + * go away while the event is queued). */ +} FileHandlerEvent; + +/* + * The following static structure contains the state information for the + * select based implementation of the Tcl notifier. + */ + +static struct { + FileHandler *firstFileHandlerPtr; + /* Pointer to head of file handler list. */ + fd_mask checkMasks[3*MASK_SIZE]; + /* This array is used to build up the masks + * to be used in the next call to select. + * Bits are set in response to calls to + * Tcl_CreateFileHandler. */ + fd_mask readyMasks[3*MASK_SIZE]; + /* This array reflects the readable/writable + * conditions that were found to exist by the + * last call to select. */ + int numFdBits; /* Number of valid bits in checkMasks + * (one more than highest fd for which + * Tcl_WatchFile has been called). */ +} notifier; + +/* + * The following static indicates whether this module has been initialized. + */ + +static int initialized = 0; + +/* + * Static routines defined in this file. + */ + +static void InitNotifier _ANSI_ARGS_((void)); +static void NotifierExitHandler _ANSI_ARGS_(( + ClientData clientData)); +static int FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); + +/* + *---------------------------------------------------------------------- + * + * InitNotifier -- + * + * Initializes the notifier state. + * + * Results: + * None. + * + * Side effects: + * Creates a new exit handler. + * + *---------------------------------------------------------------------- + */ + +static void +InitNotifier() +{ + initialized = 1; + memset(¬ifier, 0, sizeof(notifier)); + Tcl_CreateExitHandler(NotifierExitHandler, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * NotifierExitHandler -- + * + * This function is called to cleanup the notifier state before + * Tcl is unloaded. + * + * Results: + * None. + * + * Side effects: + * Destroys the notifier window. + * + *---------------------------------------------------------------------- + */ + +static void +NotifierExitHandler(clientData) + ClientData clientData; /* Not used. */ +{ + initialized = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetTimer -- + * + * This procedure sets the current notifier timer value. This + * interface is not implemented in this notifier because we are + * always running inside of Tcl_DoOneEvent. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetTimer(timePtr) + Tcl_Time *timePtr; /* Timeout value, may be NULL. */ +{ + /* + * The interval timer doesn't do anything in this implementation, + * because the only event loop is via Tcl_DoOneEvent, which passes + * timeout values to Tcl_WaitForEvent. + */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateFileHandler -- + * + * This procedure registers a file handler with the Xt notifier. + * + * Results: + * None. + * + * Side effects: + * Creates a new file handler structure and registers one or more + * input procedures with Xt. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateFileHandler(fd, mask, proc, clientData) + int fd; /* Handle of stream to watch. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions under which + * proc should be called. */ + Tcl_FileProc *proc; /* Procedure to call for each + * selected event. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + FileHandler *filePtr; + int index, bit; + + if (!initialized) { + InitNotifier(); + } + + for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->fd == fd) { + break; + } + } + if (filePtr == NULL) { + filePtr = (FileHandler*) ckalloc(sizeof(FileHandler)); /* MLK */ + filePtr->fd = fd; + filePtr->readyMask = 0; + filePtr->nextPtr = notifier.firstFileHandlerPtr; + notifier.firstFileHandlerPtr = filePtr; + } + filePtr->proc = proc; + filePtr->clientData = clientData; + filePtr->mask = mask; + + /* + * Update the check masks for this file. + */ + + index = fd/(NBBY*sizeof(fd_mask)); + bit = 1 << (fd%(NBBY*sizeof(fd_mask))); + if (mask & TCL_READABLE) { + notifier.checkMasks[index] |= bit; + } else { + notifier.checkMasks[index] &= ~bit; + } + if (mask & TCL_WRITABLE) { + (notifier.checkMasks+MASK_SIZE)[index] |= bit; + } else { + (notifier.checkMasks+MASK_SIZE)[index] &= ~bit; + } + if (mask & TCL_EXCEPTION) { + (notifier.checkMasks+2*(MASK_SIZE))[index] |= bit; + } else { + (notifier.checkMasks+2*(MASK_SIZE))[index] &= ~bit; + } + if (notifier.numFdBits <= fd) { + notifier.numFdBits = fd+1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteFileHandler -- + * + * Cancel a previously-arranged callback arrangement for + * a file. + * + * Results: + * None. + * + * Side effects: + * If a callback was previously registered on file, remove it. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteFileHandler(fd) + int fd; /* Stream id for which to remove callback procedure. */ +{ + FileHandler *filePtr, *prevPtr; + int index, bit, i; + unsigned long flags; + + if (!initialized) { + InitNotifier(); + } + + /* + * Find the entry for the given file (and return if there + * isn't one). + */ + + for (prevPtr = NULL, filePtr = notifier.firstFileHandlerPtr; ; + prevPtr = filePtr, filePtr = filePtr->nextPtr) { + if (filePtr == NULL) { + return; + } + if (filePtr->fd == fd) { + break; + } + } + + /* + * Update the check masks for this file. + */ + + index = fd/(NBBY*sizeof(fd_mask)); + bit = 1 << (fd%(NBBY*sizeof(fd_mask))); + + if (filePtr->mask & TCL_READABLE) { + notifier.checkMasks[index] &= ~bit; + } + if (filePtr->mask & TCL_WRITABLE) { + (notifier.checkMasks+MASK_SIZE)[index] &= ~bit; + } + if (filePtr->mask & TCL_EXCEPTION) { + (notifier.checkMasks+2*(MASK_SIZE))[index] &= ~bit; + } + + /* + * Find current max fd. + */ + + if (fd+1 == notifier.numFdBits) { + for (notifier.numFdBits = 0; index >= 0; index--) { + flags = notifier.checkMasks[index] + | (notifier.checkMasks+MASK_SIZE)[index] + | (notifier.checkMasks+2*(MASK_SIZE))[index]; + if (flags) { + for (i = (NBBY*sizeof(fd_mask)); i > 0; i--) { + if (flags & (((unsigned long)1) << (i-1))) { + break; + } + } + notifier.numFdBits = index * (NBBY*sizeof(fd_mask)) + i; + break; + } + } + } + + /* + * Clean up information in the callback record. + */ + + if (prevPtr == NULL) { + notifier.firstFileHandlerPtr = filePtr->nextPtr; + } else { + prevPtr->nextPtr = filePtr->nextPtr; + } + ckfree((char *) filePtr); +} + +/* + *---------------------------------------------------------------------- + * + * FileHandlerEventProc -- + * + * This procedure is called by Tcl_ServiceEvent when a file event + * reaches the front of the event queue. This procedure is + * responsible for actually handling the event by invoking the + * callback for the file handler. + * + * Results: + * Returns 1 if the event was handled, meaning it should be removed + * from the queue. Returns 0 if the event was not handled, meaning + * it should stay on the queue. The only time the event isn't + * handled is if the TCL_FILE_EVENTS flag bit isn't set. + * + * Side effects: + * Whatever the file handler's callback procedure does. + * + *---------------------------------------------------------------------- + */ + +static int +FileHandlerEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_FILE_EVENTS. */ +{ + FileHandler *filePtr; + FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr; + int mask; + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } + + /* + * Search through the file handlers to find the one whose handle matches + * the event. We do this rather than keeping a pointer to the file + * handler directly in the event, so that the handler can be deleted + * while the event is queued without leaving a dangling pointer. + */ + + for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->fd != fileEvPtr->fd) { + continue; + } + + /* + * The code is tricky for two reasons: + * 1. The file handler's desired events could have changed + * since the time when the event was queued, so AND the + * ready mask with the desired mask. + * 2. The file could have been closed and re-opened since + * the time when the event was queued. This is why the + * ready mask is stored in the file handler rather than + * the queued event: it will be zeroed when a new + * file handler is created for the newly opened file. + */ + + mask = filePtr->readyMask & filePtr->mask; + filePtr->readyMask = 0; + if (mask != 0) { + (*filePtr->proc)(filePtr->clientData, mask); + } + break; + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitForEvent -- + * + * This function is called by Tcl_DoOneEvent to wait for new + * events on the message queue. If the block time is 0, then + * Tcl_WaitForEvent just polls without blocking. + * + * Results: + * Returns -1 if the select would block forever, otherwise + * returns 0. + * + * Side effects: + * Queues file events that are detected by the select. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitForEvent(timePtr) + Tcl_Time *timePtr; /* Maximum block time, or NULL. */ +{ + FileHandler *filePtr; + FileHandlerEvent *fileEvPtr; + struct timeval timeout, *timeoutPtr; + int bit, index, mask, numFound; + + if (!initialized) { + InitNotifier(); + } + + /* + * Set up the timeout structure. Note that if there are no events to + * check for, we return with a negative result rather than blocking + * forever. + */ + + if (timePtr) { + timeout.tv_sec = timePtr->sec; + timeout.tv_usec = timePtr->usec; + timeoutPtr = &timeout; + } else if (notifier.numFdBits == 0) { + return -1; + } else { + timeoutPtr = NULL; + } + + memcpy((VOID *) notifier.readyMasks, (VOID *) notifier.checkMasks, + 3*MASK_SIZE*sizeof(fd_mask)); + numFound = select(notifier.numFdBits, + (SELECT_MASK *) ¬ifier.readyMasks[0], + (SELECT_MASK *) ¬ifier.readyMasks[MASK_SIZE], + (SELECT_MASK *) ¬ifier.readyMasks[2*MASK_SIZE], timeoutPtr); + + /* + * Some systems don't clear the masks after an error, so + * we have to do it here. + */ + + if (numFound == -1) { + memset((VOID *) notifier.readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); + } + + /* + * Queue all detected file events before returning. + */ + + for (filePtr = notifier.firstFileHandlerPtr; + (filePtr != NULL) && (numFound > 0); + filePtr = filePtr->nextPtr) { + index = filePtr->fd / (NBBY*sizeof(fd_mask)); + bit = 1 << (filePtr->fd % (NBBY*sizeof(fd_mask))); + mask = 0; + + if (notifier.readyMasks[index] & bit) { + mask |= TCL_READABLE; + } + if ((notifier.readyMasks+MASK_SIZE)[index] & bit) { + mask |= TCL_WRITABLE; + } + if ((notifier.readyMasks+2*(MASK_SIZE))[index] & bit) { + mask |= TCL_EXCEPTION; + } + + if (!mask) { + continue; + } else { + numFound--; + } + + /* + * Don't bother to queue an event if the mask was previously + * non-zero since an event must still be on the queue. + */ + + if (filePtr->readyMask == 0) { + fileEvPtr = (FileHandlerEvent *) ckalloc( + sizeof(FileHandlerEvent)); + fileEvPtr->header.proc = FileHandlerEventProc; + fileEvPtr->fd = filePtr->fd; + Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); + } + filePtr->readyMask = mask; + } + return 0; +} diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c new file mode 100644 index 0000000..83aa4e8 --- /dev/null +++ b/unix/tclUnixPipe.c @@ -0,0 +1,1149 @@ +/* + * tclUnixPipe.c -- + * + * This file implements the UNIX-specific exec pipeline functions, + * the "pipe" channel driver, and the "pid" Tcl command. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUnixPipe.c 1.37 97/10/31 17:23:37 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following macros convert between TclFile's and fd's. The conversion + * simple involves shifting fd's up by one to ensure that no valid fd is ever + * the same as NULL. + */ + +#define MakeFile(fd) ((TclFile)(((int)fd)+1)) +#define GetFd(file) (((int)file)-1) + +/* + * This structure describes per-instance state of a pipe based channel. + */ + +typedef struct PipeState { + Tcl_Channel channel;/* Channel associated with this file. */ + TclFile inFile; /* Output from pipe. */ + TclFile outFile; /* Input to pipe. */ + TclFile errorFile; /* Error output from pipe. */ + int numPids; /* How many processes are attached to this pipe? */ + Tcl_Pid *pidPtr; /* The process IDs themselves. Allocated by + * the creator of the pipe. */ + int isNonBlocking; /* Nonzero when the pipe is in nonblocking mode. + * Used to decide whether to wait for the children + * at close time. */ +} PipeState; + +/* + * Declarations for local procedures defined in this file: + */ + +static int PipeBlockModeProc _ANSI_ARGS_((ClientData instanceData, + int mode)); +static int PipeCloseProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static int PipeGetHandleProc _ANSI_ARGS_((ClientData instanceData, + int direction, ClientData *handlePtr)); +static int PipeInputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int PipeOutputProc _ANSI_ARGS_(( + ClientData instanceData, char *buf, int toWrite, + int *errorCode)); +static void PipeWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); +static void RestoreSignals _ANSI_ARGS_((void)); +static int SetupStdFile _ANSI_ARGS_((TclFile file, int type)); + +/* + * This structure describes the channel type structure for command pipe + * based IO: + */ + +static Tcl_ChannelType pipeChannelType = { + "pipe", /* Type name. */ + PipeBlockModeProc, /* Set blocking/nonblocking mode.*/ + PipeCloseProc, /* Close proc. */ + PipeInputProc, /* Input proc. */ + PipeOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ + PipeWatchProc, /* Initialize notifier. */ + PipeGetHandleProc, /* Get OS handles out of channel. */ +}; + +/* + *---------------------------------------------------------------------- + * + * TclpMakeFile -- + * + * Make a TclFile from a channel. + * + * Results: + * Returns a new TclFile or NULL on failure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclFile +TclpMakeFile(channel, direction) + Tcl_Channel channel; /* Channel to get file from. */ + int direction; /* Either TCL_READABLE or TCL_WRITABLE. */ +{ + ClientData data; + + if (Tcl_GetChannelHandle(channel, direction, (ClientData *) &data) + == TCL_OK) { + return MakeFile((int)data); + } else { + return (TclFile) NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpOpenFile -- + * + * Open a file for use in a pipeline. + * + * Results: + * Returns a new TclFile handle or NULL on failure. + * + * Side effects: + * May cause a file to be created on the file system. + * + *---------------------------------------------------------------------- + */ + +TclFile +TclpOpenFile(fname, mode) + char *fname; /* The name of the file to open. */ + int mode; /* In what mode to open the file? */ +{ + int fd; + + fd = open(fname, mode, 0666); + if (fd != -1) { + fcntl(fd, F_SETFD, FD_CLOEXEC); + + /* + * If the file is being opened for writing, seek to the end + * so we can append to any data already in the file. + */ + + if (mode & O_WRONLY) { + lseek(fd, 0, SEEK_END); + } + + /* + * Increment the fd so it can't be 0, which would conflict with + * the NULL return for errors. + */ + + return MakeFile(fd); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclpCreateTempFile -- + * + * This function creates a temporary file initialized with an + * optional string, and returns a file handle with the file pointer + * at the beginning of the file. + * + * Results: + * A handle to a file. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclFile +TclpCreateTempFile(contents, namePtr) + char *contents; /* String to write into temp file, or NULL. */ + Tcl_DString *namePtr; /* If non-NULL, pointer to initialized + * DString that is filled with the name of + * the temp file that was created. */ +{ + char fileName[L_tmpnam]; + TclFile file; + size_t length = (contents == NULL) ? 0 : strlen(contents); + + tmpnam(fileName); + file = TclpOpenFile(fileName, O_RDWR|O_CREAT|O_TRUNC); + unlink(fileName); + + if ((file != NULL) && (length > 0)) { + int fd = GetFd(file); + while (1) { + if (write(fd, contents, length) != -1) { + break; + } else if (errno != EINTR) { + close(fd); + return NULL; + } + } + lseek(fd, 0, SEEK_SET); + } + if (namePtr != NULL) { + Tcl_DStringAppend(namePtr, fileName, -1); + } + return file; +} + +/* + *---------------------------------------------------------------------- + * + * TclpCreatePipe -- + * + * Creates a pipe - simply calls the pipe() function. + * + * Results: + * Returns 1 on success, 0 on failure. + * + * Side effects: + * Creates a pipe. + * + *---------------------------------------------------------------------- + */ + +int +TclpCreatePipe(readPipe, writePipe) + TclFile *readPipe; /* Location to store file handle for + * read side of pipe. */ + TclFile *writePipe; /* Location to store file handle for + * write side of pipe. */ +{ + int pipeIds[2]; + + if (pipe(pipeIds) != 0) { + return 0; + } + + fcntl(pipeIds[0], F_SETFD, FD_CLOEXEC); + fcntl(pipeIds[1], F_SETFD, FD_CLOEXEC); + + *readPipe = MakeFile(pipeIds[0]); + *writePipe = MakeFile(pipeIds[1]); + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclpCloseFile -- + * + * Implements a mechanism to close a UNIX file. + * + * Results: + * Returns 0 on success, or -1 on error, setting errno. + * + * Side effects: + * The file is closed. + * + *---------------------------------------------------------------------- + */ + +int +TclpCloseFile(file) + TclFile file; /* The file to close. */ +{ + int fd = GetFd(file); + + /* + * Refuse to close the fds for stdin, stdout and stderr. + */ + + if ((fd == 0) || (fd == 1) || (fd == 2)) { + return 0; + } + + Tcl_DeleteFileHandler(fd); + return close(fd); +} + +/* + *---------------------------------------------------------------------- + * + * TclpCreateProcess -- + * + * Create a child process that has the specified files as its + * standard input, output, and error. The child process runs + * asynchronously and runs with the same environment variables + * as the creating process. + * + * The path is searched to find the specified executable. + * + * Results: + * The return value is TCL_ERROR and an error message is left in + * interp->result if there was a problem creating the child + * process. Otherwise, the return value is TCL_OK and *pidPtr is + * filled with the process id of the child process. + * + * Side effects: + * A process is created. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, + pidPtr) + Tcl_Interp *interp; /* Interpreter in which to leave errors that + * occurred when creating the child process. + * Error messages from the child process + * itself are sent to errorFile. */ + int argc; /* Number of arguments in following array. */ + char **argv; /* Array of argument strings. argv[0] + * contains the name of the executable + * converted to native format (using the + * Tcl_TranslateFileName call). Additional + * arguments have not been converted. */ + TclFile inputFile; /* If non-NULL, gives the file to use as + * input for the child process. If inputFile + * file is not readable or is NULL, the child + * will receive no standard input. */ + TclFile outputFile; /* If non-NULL, gives the file that + * receives output from the child process. If + * outputFile file is not writeable or is + * NULL, output from the child will be + * discarded. */ + TclFile errorFile; /* If non-NULL, gives the file that + * receives errors from the child process. If + * errorFile file is not writeable or is NULL, + * errors from the child will be discarded. + * errorFile may be the same as outputFile. */ + Tcl_Pid *pidPtr; /* If this procedure is successful, pidPtr + * is filled with the process id of the child + * process. */ +{ + TclFile errPipeIn, errPipeOut; + int joinThisError, count, status, fd; + char errSpace[200]; + int pid; + + errPipeIn = NULL; + errPipeOut = NULL; + pid = -1; + + /* + * Create a pipe that the child can use to return error + * information if anything goes wrong. + */ + + if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) { + Tcl_AppendResult(interp, "couldn't create pipe: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + + joinThisError = (errorFile == outputFile); + pid = vfork(); + if (pid == 0) { + fd = GetFd(errPipeOut); + + /* + * Set up stdio file handles for the child process. + */ + + if (!SetupStdFile(inputFile, TCL_STDIN) + || !SetupStdFile(outputFile, TCL_STDOUT) + || (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR)) + || (joinThisError && + ((dup2(1,2) == -1) || + (fcntl(2, F_SETFD, 0) != 0)))) { + sprintf(errSpace, + "%dforked process couldn't set up input/output: ", + errno); + write(fd, errSpace, (size_t) strlen(errSpace)); + _exit(1); + } + + /* + * Close the input side of the error pipe. + */ + + RestoreSignals(); + execvp(argv[0], &argv[0]); + sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, + argv[0]); + write(fd, errSpace, (size_t) strlen(errSpace)); + _exit(1); + } + if (pid == -1) { + Tcl_AppendResult(interp, "couldn't fork child process: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + + /* + * Read back from the error pipe to see if the child started + * up OK. The info in the pipe (if any) consists of a decimal + * errno value followed by an error message. + */ + + TclpCloseFile(errPipeOut); + errPipeOut = NULL; + + fd = GetFd(errPipeIn); + count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1)); + if (count > 0) { + char *end; + errSpace[count] = 0; + errno = strtol(errSpace, &end, 10); + Tcl_AppendResult(interp, end, Tcl_PosixError(interp), + (char *) NULL); + goto error; + } + + TclpCloseFile(errPipeIn); + *pidPtr = (Tcl_Pid) pid; + return TCL_OK; + + error: + if (pid != -1) { + /* + * Reap the child process now if an error occurred during its + * startup. + */ + + Tcl_WaitPid((Tcl_Pid) pid, &status, WNOHANG); + } + + if (errPipeIn) { + TclpCloseFile(errPipeIn); + } + if (errPipeOut) { + TclpCloseFile(errPipeOut); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * RestoreSignals -- + * + * This procedure is invoked in a forked child process just before + * exec-ing a new program to restore all signals to their default + * settings. + * + * Results: + * None. + * + * Side effects: + * Signal settings get changed. + * + *---------------------------------------------------------------------- + */ + +static void +RestoreSignals() +{ +#ifdef SIGABRT + signal(SIGABRT, SIG_DFL); +#endif +#ifdef SIGALRM + signal(SIGALRM, SIG_DFL); +#endif +#ifdef SIGFPE + signal(SIGFPE, SIG_DFL); +#endif +#ifdef SIGHUP + signal(SIGHUP, SIG_DFL); +#endif +#ifdef SIGILL + signal(SIGILL, SIG_DFL); +#endif +#ifdef SIGINT + signal(SIGINT, SIG_DFL); +#endif +#ifdef SIGPIPE + signal(SIGPIPE, SIG_DFL); +#endif +#ifdef SIGQUIT + signal(SIGQUIT, SIG_DFL); +#endif +#ifdef SIGSEGV + signal(SIGSEGV, SIG_DFL); +#endif +#ifdef SIGTERM + signal(SIGTERM, SIG_DFL); +#endif +#ifdef SIGUSR1 + signal(SIGUSR1, SIG_DFL); +#endif +#ifdef SIGUSR2 + signal(SIGUSR2, SIG_DFL); +#endif +#ifdef SIGCHLD + signal(SIGCHLD, SIG_DFL); +#endif +#ifdef SIGCONT + signal(SIGCONT, SIG_DFL); +#endif +#ifdef SIGTSTP + signal(SIGTSTP, SIG_DFL); +#endif +#ifdef SIGTTIN + signal(SIGTTIN, SIG_DFL); +#endif +#ifdef SIGTTOU + signal(SIGTTOU, SIG_DFL); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * SetupStdFile -- + * + * Set up stdio file handles for the child process, using the + * current standard channels if no other files are specified. + * If no standard channel is defined, or if no file is associated + * with the channel, then the corresponding standard fd is closed. + * + * Results: + * Returns 1 on success, or 0 on failure. + * + * Side effects: + * Replaces stdio fds. + * + *---------------------------------------------------------------------- + */ + +static int +SetupStdFile(file, type) + TclFile file; /* File to dup, or NULL. */ + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR */ +{ + Tcl_Channel channel; + int fd; + int targetFd = 0; /* Initializations here needed only to */ + int direction = 0; /* prevent warnings about using uninitialized + * variables. */ + + switch (type) { + case TCL_STDIN: + targetFd = 0; + direction = TCL_READABLE; + break; + case TCL_STDOUT: + targetFd = 1; + direction = TCL_WRITABLE; + break; + case TCL_STDERR: + targetFd = 2; + direction = TCL_WRITABLE; + break; + } + + if (!file) { + channel = Tcl_GetStdChannel(type); + if (channel) { + file = TclpMakeFile(channel, direction); + } + } + if (file) { + fd = GetFd(file); + if (fd != targetFd) { + if (dup2(fd, targetFd) == -1) { + return 0; + } + + /* + * Must clear the close-on-exec flag for the target FD, since + * some systems (e.g. Ultrix) do not clear the CLOEXEC flag on + * the target FD. + */ + + fcntl(targetFd, F_SETFD, 0); + } else { + int result; + + /* + * Since we aren't dup'ing the file, we need to explicitly clear + * the close-on-exec flag. + */ + + result = fcntl(fd, F_SETFD, 0); + } + } else { + close(targetFd); + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclpCreateCommandChannel -- + * + * This function is called by the generic IO level to perform + * the platform specific channel initialization for a command + * channel. + * + * Results: + * Returns a new channel or NULL on failure. + * + * Side effects: + * Allocates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) + TclFile readFile; /* If non-null, gives the file for reading. */ + TclFile writeFile; /* If non-null, gives the file for writing. */ + TclFile errorFile; /* If non-null, gives the file where errors + * can be read. */ + int numPids; /* The number of pids in the pid array. */ + Tcl_Pid *pidPtr; /* An array of process identifiers. + * Allocated by the caller, freed when + * the channel is closed or the processes + * are detached (in a background exec). */ +{ + char channelName[20]; + int channelId; + PipeState *statePtr = (PipeState *) ckalloc((unsigned) sizeof(PipeState)); + int mode; + + statePtr->inFile = readFile; + statePtr->outFile = writeFile; + statePtr->errorFile = errorFile; + statePtr->numPids = numPids; + statePtr->pidPtr = pidPtr; + statePtr->isNonBlocking = 0; + + mode = 0; + if (readFile) { + mode |= TCL_READABLE; + } + if (writeFile) { + mode |= TCL_WRITABLE; + } + + /* + * Use one of the fds associated with the channel as the + * channel id. + */ + + if (readFile) { + channelId = GetFd(readFile); + } else if (writeFile) { + channelId = GetFd(writeFile); + } else if (errorFile) { + channelId = GetFd(errorFile); + } else { + channelId = 0; + } + + /* + * For backward compatibility with previous versions of Tcl, we + * use "file%d" as the base name for pipes even though it would + * be more natural to use "pipe%d". + */ + + sprintf(channelName, "file%d", channelId); + statePtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, + (ClientData) statePtr, mode); + return statePtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetAndDetachPids -- + * + * This procedure is invoked in the generic implementation of a + * background "exec" (An exec when invoked with a terminating "&") + * to store a list of the PIDs for processes in a command pipeline + * in interp->result and to detach the processes. + * + * Results: + * None. + * + * Side effects: + * Modifies interp->result. Detaches processes. + * + *---------------------------------------------------------------------- + */ + +void +TclGetAndDetachPids(interp, chan) + Tcl_Interp *interp; + Tcl_Channel chan; +{ + PipeState *pipePtr; + Tcl_ChannelType *chanTypePtr; + int i; + char buf[20]; + + /* + * Punt if the channel is not a command channel. + */ + + chanTypePtr = Tcl_GetChannelType(chan); + if (chanTypePtr != &pipeChannelType) { + return; + } + + pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); + for (i = 0; i < pipePtr->numPids; i++) { + sprintf(buf, "%ld", TclpGetPid(pipePtr->pidPtr[i])); + Tcl_AppendElement(interp, buf); + Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); + } + if (pipePtr->numPids > 0) { + ckfree((char *) pipePtr->pidPtr); + pipePtr->numPids = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * PipeBlockModeProc -- + * + * Helper procedure to set blocking and nonblocking modes on a + * pipe based channel. Invoked by generic IO level code. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +PipeBlockModeProc(instanceData, mode) + ClientData instanceData; /* Pipe state. */ + int mode; /* The mode to set. Can be one of + * TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + PipeState *psPtr = (PipeState *) instanceData; + int curStatus; + int fd; + +#ifndef USE_FIONBIO + if (psPtr->inFile) { + fd = GetFd(psPtr->inFile); + curStatus = fcntl(fd, F_GETFL); + if (mode == TCL_MODE_BLOCKING) { + curStatus &= (~(O_NONBLOCK)); + } else { + curStatus |= O_NONBLOCK; + } + if (fcntl(fd, F_SETFL, curStatus) < 0) { + return errno; + } + curStatus = fcntl(fd, F_GETFL); + } + if (psPtr->outFile) { + fd = GetFd(psPtr->outFile); + curStatus = fcntl(fd, F_GETFL); + if (mode == TCL_MODE_BLOCKING) { + curStatus &= (~(O_NONBLOCK)); + } else { + curStatus |= O_NONBLOCK; + } + if (fcntl(fd, F_SETFL, curStatus) < 0) { + return errno; + } + } +#endif /* !FIONBIO */ + +#ifdef USE_FIONBIO + if (psPtr->inFile) { + fd = GetFd(psPtr->inFile); + if (mode == TCL_MODE_BLOCKING) { + curStatus = 0; + } else { + curStatus = 1; + } + if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) { + return errno; + } + } + if (psPtr->outFile != NULL) { + fd = GetFd(psPtr->outFile); + if (mode == TCL_MODE_BLOCKING) { + curStatus = 0; + } else { + curStatus = 1; + } + if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) { + return errno; + } + } +#endif /* USE_FIONBIO */ + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * PipeCloseProc -- + * + * This procedure is invoked by the generic IO level to perform + * channel-type-specific cleanup when a command pipeline channel + * is closed. + * + * Results: + * 0 on success, errno otherwise. + * + * Side effects: + * Closes the command pipeline channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +PipeCloseProc(instanceData, interp) + ClientData instanceData; /* The pipe to close. */ + Tcl_Interp *interp; /* For error reporting. */ +{ + PipeState *pipePtr; + Tcl_Channel errChan; + int errorCode, result; + + errorCode = 0; + result = 0; + pipePtr = (PipeState *) instanceData; + if (pipePtr->inFile) { + if (TclpCloseFile(pipePtr->inFile) < 0) { + errorCode = errno; + } + } + if (pipePtr->outFile) { + if ((TclpCloseFile(pipePtr->outFile) < 0) && (errorCode == 0)) { + errorCode = errno; + } + } + + if (pipePtr->isNonBlocking || TclInExit()) { + + /* + * If the channel is non-blocking or Tcl is being cleaned up, just + * detach the children PIDs, reap them (important if we are in a + * dynamic load module), and discard the errorFile. + */ + + Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr); + Tcl_ReapDetachedProcs(); + + if (pipePtr->errorFile) { + TclpCloseFile(pipePtr->errorFile); + } + } else { + + /* + * Wrap the error file into a channel and give it to the cleanup + * routine. + */ + + if (pipePtr->errorFile) { + errChan = Tcl_MakeFileChannel( + (ClientData) GetFd(pipePtr->errorFile), TCL_READABLE); + } else { + errChan = NULL; + } + result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, + errChan); + } + + if (pipePtr->numPids != 0) { + ckfree((char *) pipePtr->pidPtr); + } + ckfree((char *) pipePtr); + if (errorCode == 0) { + return result; + } + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * PipeInputProc -- + * + * This procedure is invoked from the generic IO level to read + * input from a command pipeline based channel. + * + * Results: + * The number of bytes read is returned or -1 on error. An output + * argument contains a POSIX error code if an error occurs, or zero. + * + * Side effects: + * Reads input from the input device of the channel. + * + *---------------------------------------------------------------------- + */ + +static int +PipeInputProc(instanceData, buf, toRead, errorCodePtr) + ClientData instanceData; /* Pipe state. */ + char *buf; /* Where to store data read. */ + int toRead; /* How much space is available + * in the buffer? */ + int *errorCodePtr; /* Where to store error code. */ +{ + PipeState *psPtr = (PipeState *) instanceData; + int bytesRead; /* How many bytes were actually + * read from the input device? */ + + *errorCodePtr = 0; + + /* + * Assume there is always enough input available. This will block + * appropriately, and read will unblock as soon as a short read is + * possible, if the channel is in blocking mode. If the channel is + * nonblocking, the read will never block. + */ + + bytesRead = read(GetFd(psPtr->inFile), buf, (size_t) toRead); + if (bytesRead > -1) { + return bytesRead; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * PipeOutputProc-- + * + * This procedure is invoked from the generic IO level to write + * output to a command pipeline based channel. + * + * Results: + * The number of bytes written is returned or -1 on error. An + * output argument contains a POSIX error code if an error occurred, + * or zero. + * + * Side effects: + * Writes output on the output device of the channel. + * + *---------------------------------------------------------------------- + */ + +static int +PipeOutputProc(instanceData, buf, toWrite, errorCodePtr) + ClientData instanceData; /* Pipe state. */ + char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCodePtr; /* Where to store error code. */ +{ + PipeState *psPtr = (PipeState *) instanceData; + int written; + + *errorCodePtr = 0; + written = write(GetFd(psPtr->outFile), buf, (size_t) toWrite); + if (written > -1) { + return written; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * PipeWatchProc -- + * + * Initialize the notifier to watch the fds from this channel. + * + * Results: + * None. + * + * Side effects: + * Sets up the notifier so that a future event on the channel will + * be seen by Tcl. + * + *---------------------------------------------------------------------- + */ + +static void +PipeWatchProc(instanceData, mask) + ClientData instanceData; /* The pipe state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABEL and TCL_EXCEPTION. */ +{ + PipeState *psPtr = (PipeState *) instanceData; + int newmask; + + if (psPtr->inFile) { + newmask = mask & (TCL_READABLE | TCL_EXCEPTION); + if (newmask) { + Tcl_CreateFileHandler(GetFd(psPtr->inFile), mask, + (Tcl_FileProc *) Tcl_NotifyChannel, + (ClientData) psPtr->channel); + } else { + Tcl_DeleteFileHandler(GetFd(psPtr->inFile)); + } + } + if (psPtr->outFile) { + newmask = mask & (TCL_WRITABLE | TCL_EXCEPTION); + if (newmask) { + Tcl_CreateFileHandler(GetFd(psPtr->outFile), mask, + (Tcl_FileProc *) Tcl_NotifyChannel, + (ClientData) psPtr->channel); + } else { + Tcl_DeleteFileHandler(GetFd(psPtr->outFile)); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * PipeGetHandleProc -- + * + * Called from Tcl_GetChannelHandle to retrieve OS handles from + * inside a command pipeline based channel. + * + * Results: + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if + * there is no handle for the specified direction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +PipeGetHandleProc(instanceData, direction, handlePtr) + ClientData instanceData; /* The pipe state. */ + int direction; /* TCL_READABLE or TCL_WRITABLE */ + ClientData *handlePtr; /* Where to store the handle. */ +{ + PipeState *psPtr = (PipeState *) instanceData; + + if (direction == TCL_READABLE && psPtr->inFile) { + *handlePtr = (ClientData) GetFd(psPtr->inFile); + return TCL_OK; + } + if (direction == TCL_WRITABLE && psPtr->outFile) { + *handlePtr = (ClientData) GetFd(psPtr->outFile); + return TCL_OK; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitPid -- + * + * Implements the waitpid system call on Unix systems. + * + * Results: + * Result of calling waitpid. + * + * Side effects: + * Waits for a process to terminate. + * + *---------------------------------------------------------------------- + */ + +Tcl_Pid +Tcl_WaitPid(pid, statPtr, options) + Tcl_Pid pid; + int *statPtr; + int options; +{ + int result; + pid_t real_pid; + + real_pid = (pid_t) pid; + while (1) { + result = (int) waitpid(real_pid, statPtr, options); + if ((result != -1) || (errno != EINTR)) { + return (Tcl_Pid) result; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PidObjCmd -- + * + * This procedure is invoked to process the "pid" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PidObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST *objv; /* Argument strings. */ +{ + Tcl_Channel chan; + Tcl_ChannelType *chanTypePtr; + PipeState *pipePtr; + int i; + Tcl_Obj *resultPtr, *longObjPtr; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); + return TCL_ERROR; + } + if (objc == 1) { + Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) getpid()); + } else { + chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), + NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + chanTypePtr = Tcl_GetChannelType(chan); + if (chanTypePtr != &pipeChannelType) { + return TCL_OK; + } + pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); + resultPtr = Tcl_GetObjResult(interp); + for (i = 0; i < pipePtr->numPids; i++) { + longObjPtr = Tcl_NewLongObj((long) TclpGetPid(pipePtr->pidPtr[i])); + Tcl_ListObjAppendElement(NULL, resultPtr, longObjPtr); + } + } + return TCL_OK; +} diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h new file mode 100644 index 0000000..186de21 --- /dev/null +++ b/unix/tclUnixPort.h @@ -0,0 +1,480 @@ +/* + * tclUnixPort.h -- + * + * This header file handles porting issues that occur because + * of differences between systems. It reads in UNIX-related + * header files and sets up UNIX-related macros for Tcl's UNIX + * core. It should be the only file that contains #ifdefs to + * handle different flavors of UNIX. This file sets up the + * union of all UNIX-related things needed by any of the Tcl + * core files. This file depends on configuration #defines such + * as NO_DIRENT_H that are set up by the "configure" script. + * + * Much of the material in this file was originally contributed + * by Karl Lehenbauer, Mark Diekhans and Peter da Silva. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 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: @(#) tclUnixPort.h 1.49 97/07/30 14:11:59 + */ + +#ifndef _TCLUNIXPORT +#define _TCLUNIXPORT + +#ifndef _TCLINT +# include "tclInt.h" +#endif +#include <errno.h> +#include <fcntl.h> +#ifdef HAVE_NET_ERRNO_H +# include <net/errno.h> +#endif +#include <pwd.h> +#include <signal.h> +#include <sys/param.h> +#include <sys/types.h> +#ifdef USE_DIRENT2_H +# include "../compat/dirent2.h" +#else +# ifdef NO_DIRENT_H +# include "../compat/dirent.h" +# else +# include <dirent.h> +# endif +#endif +#include <sys/file.h> +#ifdef HAVE_SYS_SELECT_H +# include <sys/select.h> +#endif +#include <sys/stat.h> +#if TIME_WITH_SYS_TIME +# include <sys/time.h> +# include <time.h> +#else +# if HAVE_SYS_TIME_H +# include <sys/time.h> +# else +# include <time.h> +# endif +#endif +#ifndef NO_SYS_WAIT_H +# include <sys/wait.h> +#endif +#ifdef HAVE_UNISTD_H +# include <unistd.h> +#else +# include "../compat/unistd.h" +#endif +#ifdef USE_FIONBIO + + /* + * Not using the Posix fcntl(...,O_NONBLOCK,...) interface, instead + * we are using ioctl(..,FIONBIO,..). + */ + +# ifdef HAVE_SYS_FILIO_H +# include <sys/filio.h> /* For FIONBIO. */ +# endif + +# ifdef HAVE_SYS_IOCTL_H +# include <sys/ioctl.h> /* For FIONBIO. */ +# endif +#endif /* USE_FIONBIO */ + +/* + * Socket support stuff: This likely needs more work to parameterize for + * each system. + */ + +#include <sys/socket.h> /* struct sockaddr, SOCK_STREAM, ... */ +#ifndef NO_UNAME +# include <sys/utsname.h> /* uname system call. */ +#endif +#include <netinet/in.h> /* struct in_addr, struct sockaddr_in */ +#include <arpa/inet.h> /* inet_ntoa() */ +#include <netdb.h> /* gethostbyname() */ + +/* + * Some platforms (e.g. SunOS) don't define FLT_MAX and FLT_MIN, so we + * look for an alternative definition. If no other alternative is available + * we use a reasonable guess. + */ + +#ifndef NO_FLOAT_H +#include <float.h> +#else +# ifndef NO_VALUES_H +# include <values.h> +# endif +#endif + +#ifndef FLT_MAX +# ifdef MAXFLOAT +# define FLT_MAX MAXFLOAT +# else +# define FLT_MAX 3.402823466E+38F +# endif +#endif +#ifndef FLT_MIN +# ifdef MINFLOAT +# define FLT_MIN MINFLOAT +# else +# define FLT_MIN 1.175494351E-38F +# endif +#endif + +/* + * NeXT doesn't define O_NONBLOCK, so #define it here if necessary. + */ + +#ifndef O_NONBLOCK +# define O_NONBLOCK 0x80 +#endif + +/* + * HPUX needs the flag O_NONBLOCK to get the right non-blocking I/O + * semantics, while most other systems need O_NDELAY. Define the + * constant NBIO_FLAG to be one of these + */ + +#ifdef HPUX +# define NBIO_FLAG O_NONBLOCK +#else +# define NBIO_FLAG O_NDELAY +#endif + +/* + * The following defines denote malloc and free as the system calls + * used to allocate new memory. These defines are only used in the + * file tclCkalloc.c. + */ + +#define TclpAlloc(size) malloc(size) +#define TclpFree(ptr) free(ptr) +#define TclpRealloc(ptr, size) realloc(ptr, size) + +/* + * The default platform eol translation on Unix is TCL_TRANSLATE_LF: + */ + +#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_LF + +/* + * Not all systems declare the errno variable in errno.h. so this + * file does it explicitly. The list of system error messages also + * isn't generally declared in a header file anywhere. + */ + +extern int errno; + +/* + * The type of the status returned by wait varies from UNIX system + * to UNIX system. The macro below defines it: + */ + +#ifdef _AIX +# define WAIT_STATUS_TYPE pid_t +#else +#ifndef NO_UNION_WAIT +# define WAIT_STATUS_TYPE union wait +#else +# define WAIT_STATUS_TYPE int +#endif +#endif + +/* + * Supply definitions for macros to query wait status, if not already + * defined in header files above. + */ + +#ifndef WIFEXITED +# define WIFEXITED(stat) (((*((int *) &(stat))) & 0xff) == 0) +#endif + +#ifndef WEXITSTATUS +# define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xff) +#endif + +#ifndef WIFSIGNALED +# define WIFSIGNALED(stat) (((*((int *) &(stat)))) && ((*((int *) &(stat))) == ((*((int *) &(stat))) & 0x00ff))) +#endif + +#ifndef WTERMSIG +# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f) +#endif + +#ifndef WIFSTOPPED +# define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xff) == 0177) +#endif + +#ifndef WSTOPSIG +# define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xff) +#endif + +/* + * Define constants for waitpid() system call if they aren't defined + * by a system header file. + */ + +#ifndef WNOHANG +# define WNOHANG 1 +#endif +#ifndef WUNTRACED +# define WUNTRACED 2 +#endif + +/* + * Supply macros for seek offsets, if they're not already provided by + * an include file. + */ + +#ifndef SEEK_SET +# define SEEK_SET 0 +#endif + +#ifndef SEEK_CUR +# define SEEK_CUR 1 +#endif + +#ifndef SEEK_END +# define SEEK_END 2 +#endif + +/* + * The stuff below is needed by the "time" command. If this + * system has no gettimeofday call, then must use times and the + * CLK_TCK #define (from sys/param.h) to compute elapsed time. + * Unfortunately, some systems only have HZ and no CLK_TCK, and + * some might not even have HZ. + */ + +#ifdef NO_GETTOD +# include <sys/times.h> +# include <sys/param.h> +# ifndef CLK_TCK +# ifdef HZ +# define CLK_TCK HZ +# else +# define CLK_TCK 60 +# endif +# endif +#else +# ifdef HAVE_BSDGETTIMEOFDAY +# define gettimeofday BSDgettimeofday +# endif +#endif + +#ifdef GETTOD_NOT_DECLARED +EXTERN int gettimeofday _ANSI_ARGS_((struct timeval *tp, + struct timezone *tzp)); +#endif + +/* + * Define access mode constants if they aren't already defined. + */ + +#ifndef F_OK +# define F_OK 00 +#endif +#ifndef X_OK +# define X_OK 01 +#endif +#ifndef W_OK +# define W_OK 02 +#endif +#ifndef R_OK +# define R_OK 04 +#endif + +/* + * Define FD_CLOEEXEC (the close-on-exec flag bit) if it isn't + * already defined. + */ + +#ifndef FD_CLOEXEC +# define FD_CLOEXEC 1 +#endif + +/* + * On systems without symbolic links (i.e. S_IFLNK isn't defined) + * define "lstat" to use "stat" instead. + */ + +#ifndef S_IFLNK +# define lstat stat +#endif + +/* + * Define macros to query file type bits, if they're not already + * defined. + */ + +#ifndef S_ISREG +# ifdef S_IFREG +# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) +# else +# define S_ISREG(m) 0 +# endif +# endif +#ifndef S_ISDIR +# ifdef S_IFDIR +# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) +# else +# define S_ISDIR(m) 0 +# endif +# endif +#ifndef S_ISCHR +# ifdef S_IFCHR +# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR) +# else +# define S_ISCHR(m) 0 +# endif +# endif +#ifndef S_ISBLK +# ifdef S_IFBLK +# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK) +# else +# define S_ISBLK(m) 0 +# endif +# endif +#ifndef S_ISFIFO +# ifdef S_IFIFO +# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) +# else +# define S_ISFIFO(m) 0 +# endif +# endif +#ifndef S_ISLNK +# ifdef S_IFLNK +# define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) +# else +# define S_ISLNK(m) 0 +# endif +# endif +#ifndef S_ISSOCK +# ifdef S_IFSOCK +# define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK) +# else +# define S_ISSOCK(m) 0 +# endif +# endif + +/* + * Make sure that MAXPATHLEN is defined. + */ + +#ifndef MAXPATHLEN +# ifdef PATH_MAX +# define MAXPATHLEN PATH_MAX +# else +# define MAXPATHLEN 2048 +# endif +#endif + +/* + * Make sure that L_tmpnam is defined. + */ + +#ifndef L_tmpnam +# define L_tmpnam 100 +#endif + +/* + * The following macro defines the type of the mask arguments to + * select: + */ + +#ifndef NO_FD_SET +# define SELECT_MASK fd_set +#else +# ifndef _AIX + typedef long fd_mask; +# endif +# if defined(_IBMR2) +# define SELECT_MASK void +# else +# define SELECT_MASK int +# endif +#endif + +/* + * Define "NBBY" (number of bits per byte) if it's not already defined. + */ + +#ifndef NBBY +# define NBBY 8 +#endif + +/* + * The following macro defines the number of fd_masks in an fd_set: + */ + +#ifndef FD_SETSIZE +# ifdef OPEN_MAX +# define FD_SETSIZE OPEN_MAX +# else +# define FD_SETSIZE 256 +# endif +#endif +#if !defined(howmany) +# define howmany(x, y) (((x)+((y)-1))/(y)) +#endif +#ifndef NFDBITS +# define NFDBITS NBBY*sizeof(fd_mask) +#endif +#define MASK_SIZE howmany(FD_SETSIZE, NFDBITS) + +/* + * The following implements the Unix method for exiting the process. + */ +#define TclPlatformExit(status) exit(status) + +/* + * The following functions always succeeds under Unix. + */ + +#define TclHasSockets(interp) (TCL_OK) +#define TclHasPipes() (1) + +/* + * Variables provided by the C library: + */ + +#if defined(_sgi) || defined(__sgi) +#define environ _environ +#endif +extern char **environ; + +/* + * At present (12/91) not all stdlib.h implementations declare strtod. + * The declaration below is here to ensure that it's declared, so that + * the compiler won't take the default approach of assuming it returns + * an int. There's no ANSI prototype for it because there would end + * up being too many conflicts with slightly-different prototypes. + */ + +extern double strtod(); + +/* + * The following macros define time related functions in terms of + * standard Unix routines. + */ + +#define TclpGetDate(t,u) ((u) ? gmtime((t)) : localtime((t))) +#define TclStrftime(s,m,f,t) (strftime((s),(m),(f),(t))) +#define TclpGetPid(pid) ((unsigned long) (pid)) + +#define TclpReleaseFile(file) + +/* + * The following routine is only exported for testing purposes. + */ + +EXTERN int TclUnixWaitForFile _ANSI_ARGS_((int fd, int mask, + int timeout)); + +#endif /* _TCLUNIXPORT */ diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c new file mode 100644 index 0000000..c532993 --- /dev/null +++ b/unix/tclUnixSock.c @@ -0,0 +1,100 @@ +/* + * tclUnixSock.c -- + * + * This file contains Unix-specific socket related code. + * + * Copyright (c) 1995 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: @(#) tclUnixSock.c 1.9 97/10/09 18:24:49 + */ + +#include "tcl.h" +#include "tclPort.h" + +/* + * There is no portable macro for the maximum length + * of host names returned by gethostbyname(). We should only + * trust SYS_NMLN if it is at least 255 + 1 bytes to comply with DNS + * host name limits. + * + * Note: SYS_NMLN is a restriction on "uname" not on gethostbyname! + * + * For example HP-UX 10.20 has SYS_NMLN == 9, while gethostbyname() + * can return a fully qualified name from DNS of up to 255 bytes. + * + * Fix suggested by Viktor Dukhovni (viktor@esm.com) + */ + +#if defined(SYS_NMLN) && SYS_NMLEN >= 256 +#define TCL_HOSTNAME_LEN SYS_NMLEN +#else +#define TCL_HOSTNAME_LEN 256 +#endif + + +/* + * The following variable holds the network name of this host. + */ + +static char hostname[TCL_HOSTNAME_LEN + 1]; +static int hostnameInited = 0; + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetHostName -- + * + * Returns the name of the local host. + * + * Results: + * A string containing the network name for this machine, or + * an empty string if we can't figure out the name. The caller + * must not modify or free this string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetHostName() +{ +#ifndef NO_UNAME + struct utsname u; + struct hostent *hp; +#endif + + if (hostnameInited) { + return hostname; + } + +#ifndef NO_UNAME + (VOID *) memset((VOID *) &u, (int) 0, sizeof(struct utsname)); + if (uname(&u) > -1) { + hp = gethostbyname(u.nodename); + if (hp != NULL) { + strcpy(hostname, hp->h_name); + } else { + strcpy(hostname, u.nodename); + } + hostnameInited = 1; + return hostname; + } +#else + /* + * Uname doesn't exist; try gethostname instead. + */ + + if (gethostname(hostname, sizeof(hostname)) > -1) { + hostnameInited = 1; + return hostname; + } +#endif + + hostname[0] = 0; + return hostname; +} diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c new file mode 100644 index 0000000..b1d1676 --- /dev/null +++ b/unix/tclUnixTest.c @@ -0,0 +1,431 @@ +/* + * tclUnixTest.c -- + * + * Contains platform specific test commands for the Unix platform. + * + * 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: @(#) tclUnixTest.c 1.5 97/10/31 17:23:42 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following macros convert between TclFile's and fd's. The conversion + * simple involves shifting fd's up by one to ensure that no valid fd is ever + * the same as NULL. Note that this code is duplicated from tclUnixPipe.c + */ + +#define MakeFile(fd) ((TclFile)((fd)+1)) +#define GetFd(file) (((int)file)-1) + +/* + * The stuff below is used to keep track of file handlers created and + * exercised by the "testfilehandler" command. + */ + +typedef struct Pipe { + TclFile readFile; /* File handle for reading from the + * pipe. NULL means pipe doesn't exist yet. */ + TclFile writeFile; /* File handle for writing from the + * pipe. */ + int readCount; /* Number of times the file handler for + * this file has triggered and the file + * was readable. */ + int writeCount; /* Number of times the file handler for + * this file has triggered and the file + * was writable. */ +} Pipe; + +#define MAX_PIPES 10 +static Pipe testPipes[MAX_PIPES]; + +/* + * Forward declarations of procedures defined later in this file: + */ + +static void TestFileHandlerProc _ANSI_ARGS_((ClientData clientData, + int mask)); +static int TestfilehandlerCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestfilewaitCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestgetopenfileCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); + +/* + *---------------------------------------------------------------------- + * + * TclplatformtestInit -- + * + * Defines commands that test platform specific functionality for + * Unix platforms. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Defines new commands. + * + *---------------------------------------------------------------------- + */ + +int +TclplatformtestInit(interp) + Tcl_Interp *interp; /* Interpreter to add commands to. */ +{ + Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestfilehandlerCmd -- + * + * This procedure implements the "testfilehandler" command. It is + * used to test Tcl_CreateFileHandler, Tcl_DeleteFileHandler, and + * TclWaitForFile. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestfilehandlerCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Pipe *pipePtr; + int i, mask, timeout; + static int initialized = 0; + char buffer[4000]; + TclFile file; + + /* + * NOTE: When we make this code work on Windows also, the following + * variable needs to be made Unix-only. + */ + + if (!initialized) { + for (i = 0; i < MAX_PIPES; i++) { + testPipes[i].readFile = NULL; + } + initialized = 1; + } + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " option ... \"", (char *) NULL); + return TCL_ERROR; + } + pipePtr = NULL; + if (argc >= 3) { + if (Tcl_GetInt(interp, argv[2], &i) != TCL_OK) { + return TCL_ERROR; + } + if (i >= MAX_PIPES) { + Tcl_AppendResult(interp, "bad index ", argv[2], (char *) NULL); + return TCL_ERROR; + } + pipePtr = &testPipes[i]; + } + + if (strcmp(argv[1], "close") == 0) { + for (i = 0; i < MAX_PIPES; i++) { + if (testPipes[i].readFile != NULL) { + TclpCloseFile(testPipes[i].readFile); + testPipes[i].readFile = NULL; + TclpCloseFile(testPipes[i].writeFile); + testPipes[i].writeFile = NULL; + } + } + } else if (strcmp(argv[1], "clear") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " clear index\"", (char *) NULL); + return TCL_ERROR; + } + pipePtr->readCount = pipePtr->writeCount = 0; + } else if (strcmp(argv[1], "counts") == 0) { + char buf[30]; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " counts index\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(buf, "%d %d", pipePtr->readCount, pipePtr->writeCount); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } else if (strcmp(argv[1], "create") == 0) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " create index readMode writeMode\"", + (char *) NULL); + return TCL_ERROR; + } + if (pipePtr->readFile == NULL) { + if (!TclpCreatePipe(&pipePtr->readFile, &pipePtr->writeFile)) { + Tcl_AppendResult(interp, "couldn't open pipe: ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } +#ifdef O_NONBLOCK + fcntl(GetFd(pipePtr->readFile), F_SETFL, O_NONBLOCK); + fcntl(GetFd(pipePtr->writeFile), F_SETFL, O_NONBLOCK); +#else + Tcl_SetResult(interp, "can't make pipes non-blocking", + TCL_STATIC); + return TCL_ERROR; +#endif + } + pipePtr->readCount = 0; + pipePtr->writeCount = 0; + + if (strcmp(argv[3], "readable") == 0) { + Tcl_CreateFileHandler(GetFd(pipePtr->readFile), TCL_READABLE, + TestFileHandlerProc, (ClientData) pipePtr); + } else if (strcmp(argv[3], "off") == 0) { + Tcl_DeleteFileHandler(GetFd(pipePtr->readFile)); + } else if (strcmp(argv[3], "disabled") == 0) { + Tcl_CreateFileHandler(GetFd(pipePtr->readFile), 0, + TestFileHandlerProc, (ClientData) pipePtr); + } else { + Tcl_AppendResult(interp, "bad read mode \"", argv[3], "\"", + (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[4], "writable") == 0) { + Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), TCL_WRITABLE, + TestFileHandlerProc, (ClientData) pipePtr); + } else if (strcmp(argv[4], "off") == 0) { + Tcl_DeleteFileHandler(GetFd(pipePtr->writeFile)); + } else if (strcmp(argv[4], "disabled") == 0) { + Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), 0, + TestFileHandlerProc, (ClientData) pipePtr); + } else { + Tcl_AppendResult(interp, "bad read mode \"", argv[4], "\"", + (char *) NULL); + return TCL_ERROR; + } + } else if (strcmp(argv[1], "empty") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " empty index\"", (char *) NULL); + return TCL_ERROR; + } + + while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) { + /* Empty loop body. */ + } + } else if (strcmp(argv[1], "fill") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " empty index\"", (char *) NULL); + return TCL_ERROR; + } + + memset((VOID *) buffer, 'a', 4000); + while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) { + /* Empty loop body. */ + } + } else if (strcmp(argv[1], "fillpartial") == 0) { + char buf[30]; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " empty index\"", (char *) NULL); + return TCL_ERROR; + } + + memset((VOID *) buffer, 'b', 10); + sprintf(buf, "%d", write(GetFd(pipePtr->writeFile), buffer, 10)); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } else if (strcmp(argv[1], "oneevent") == 0) { + Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT); + } else if (strcmp(argv[1], "wait") == 0) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " wait index readable/writable timeout\"", + (char *) NULL); + return TCL_ERROR; + } + if (pipePtr->readFile == NULL) { + Tcl_AppendResult(interp, "pipe ", argv[2], " doesn't exist", + (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[3], "readable") == 0) { + mask = TCL_READABLE; + file = pipePtr->readFile; + } else { + mask = TCL_WRITABLE; + file = pipePtr->writeFile; + } + if (Tcl_GetInt(interp, argv[4], &timeout) != TCL_OK) { + return TCL_ERROR; + } + i = TclUnixWaitForFile(GetFd(file), mask, timeout); + if (i & TCL_READABLE) { + Tcl_AppendElement(interp, "readable"); + } + if (i & TCL_WRITABLE) { + Tcl_AppendElement(interp, "writable"); + } + } else if (strcmp(argv[1], "windowevent") == 0) { + Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be close, clear, counts, create, empty, fill, ", + "fillpartial, oneevent, wait, or windowevent", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static void TestFileHandlerProc(clientData, mask) + ClientData clientData; /* Points to a Pipe structure. */ + int mask; /* Indicates which events happened: + * TCL_READABLE or TCL_WRITABLE. */ +{ + Pipe *pipePtr = (Pipe *) clientData; + + if (mask & TCL_READABLE) { + pipePtr->readCount++; + } + if (mask & TCL_WRITABLE) { + pipePtr->writeCount++; + } +} + +/* + *---------------------------------------------------------------------- + * + * TestfilewaitCmd -- + * + * This procedure implements the "testfilewait" command. It is + * used to test TclUnixWaitForFile. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestfilewaitCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int mask, result, timeout; + Tcl_Channel channel; + int fd; + ClientData data; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " file readable|writable|both timeout\"", (char *) NULL); + return TCL_ERROR; + } + channel = Tcl_GetChannel(interp, argv[1], NULL); + if (channel == NULL) { + return TCL_ERROR; + } + if (strcmp(argv[2], "readable") == 0) { + mask = TCL_READABLE; + } else if (strcmp(argv[2], "writable") == 0){ + mask = TCL_WRITABLE; + } else if (strcmp(argv[2], "both") == 0){ + mask = TCL_WRITABLE|TCL_READABLE; + } else { + Tcl_AppendResult(interp, "bad argument \"", argv[2], + "\": must be readable, writable, or both", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetChannelHandle(channel, + (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE, + (ClientData*) &data) != TCL_OK) { + Tcl_SetResult(interp, "couldn't get channel file", TCL_STATIC); + return TCL_ERROR; + } + fd = (int) data; + if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) { + return TCL_ERROR; + } + result = TclUnixWaitForFile(fd, mask, timeout); + if (result & TCL_READABLE) { + Tcl_AppendElement(interp, "readable"); + } + if (result & TCL_WRITABLE) { + Tcl_AppendElement(interp, "writable"); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestgetopenfileCmd -- + * + * This procedure implements the "testgetopenfile" command. It is + * used to get a FILE * value from a registered channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestgetopenfileCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + ClientData filePtr; + + if (argc != 3) { + Tcl_AppendResult(interp, + "wrong # args: should be \"", argv[0], + " channelName forWriting\"", + (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetOpenFile(interp, argv[1], atoi(argv[2]), 1, &filePtr) + == TCL_ERROR) { + return TCL_ERROR; + } + if (filePtr == (ClientData) NULL) { + Tcl_AppendResult(interp, + "Tcl_GetOpenFile succeeded but FILE * NULL!", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c new file mode 100644 index 0000000..ba8d984 --- /dev/null +++ b/unix/tclUnixTime.c @@ -0,0 +1,236 @@ +/* + * tclUnixTime.c -- + * + * Contains Unix specific versions of Tcl functions that + * obtain time values from the operating system. + * + * Copyright (c) 1995 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: @(#) tclUnixTime.c 1.13 97/10/31 15:04:58 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + *----------------------------------------------------------------------------- + * + * TclpGetSeconds -- + * + * This procedure returns the number of seconds from the epoch. On + * most Unix systems the epoch is Midnight Jan 1, 1970 GMT. + * + * Results: + * Number of seconds from the epoch. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +unsigned long +TclpGetSeconds() +{ + return time((time_t *) NULL); +} + +/* + *----------------------------------------------------------------------------- + * + * TclpGetClicks -- + * + * This procedure returns a value that represents the highest resolution + * clock available on the system. There are no garantees on what the + * resolution will be. In Tcl we will call this value a "click". The + * start time is also system dependant. + * + * Results: + * Number of clicks from some start time. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +unsigned long +TclpGetClicks() +{ + unsigned long now; +#ifdef NO_GETTOD + struct tms dummy; +#else + struct timeval date; + struct timezone tz; +#endif + +#ifdef NO_GETTOD + now = (unsigned long) times(&dummy); +#else + gettimeofday(&date, &tz); + now = date.tv_sec*1000000 + date.tv_usec; +#endif + + return now; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetTimeZone -- + * + * Determines the current timezone. The method varies wildly + * between different platform implementations, so its hidden in + * this function. + * + * Results: + * The return value is the local time zone, measured in + * minutes away from GMT (-ve for east, +ve for west). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclpGetTimeZone (currentTime) + unsigned long currentTime; +{ + /* + * Determine how a timezone is obtained from "struct tm". If there is no + * time zone in this struct (very lame) then use the timezone variable. + * This is done in a way to make the timezone variable the method of last + * resort, as some systems have it in addition to a field in "struct tm". + * The gettimeofday system call can also be used to determine the time + * zone. + */ + +#if defined(HAVE_TM_TZADJ) +# define TCL_GOT_TIMEZONE + time_t curTime = (time_t) currentTime; + struct tm *timeDataPtr = localtime(&curTime); + int timeZone; + + timeZone = timeDataPtr->tm_tzadj / 60; + if (timeDataPtr->tm_isdst) { + timeZone += 60; + } + + return timeZone; +#endif + +#if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE) +# define TCL_GOT_TIMEZONE + time_t curTime = (time_t) currentTime; + struct tm *timeDataPtr = localtime(&curTime); + int timeZone; + + timeZone = -(timeDataPtr->tm_gmtoff / 60); + if (timeDataPtr->tm_isdst) { + timeZone += 60; + } + + return timeZone; +#endif + +#if defined(USE_DELTA_FOR_TZ) +#define TCL_GOT_TIMEZONE 1 + /* + * This hack replaces using global var timezone or gettimeofday + * in situations where they are buggy such as on AIX when libbsd.a + * is linked in. + */ + + int timeZone; + time_t tt; + struct tm *stm; + tt = 849268800L; /* 1996-11-29 12:00:00 GMT */ + stm = localtime(&tt); /* eg 1996-11-29 6:00:00 CST6CDT */ + /* The calculation below assumes a max of +12 or -12 hours from GMT */ + timeZone = (12 - stm->tm_hour)*60 + (0 - stm->tm_min); + return timeZone; /* eg +360 for CST6CDT */ +#endif + + /* + * Must prefer timezone variable over gettimeofday, as gettimeofday does + * not return timezone information on many systems that have moved this + * information outside of the kernel. + */ + +#if defined(HAVE_TIMEZONE_VAR) && !defined (TCL_GOT_TIMEZONE) +# define TCL_GOT_TIMEZONE + static int setTZ = 0; + int timeZone; + + if (!setTZ) { + tzset(); + setTZ = 1; + } + + /* + * Note: this is not a typo in "timezone" below! See tzset + * documentation for details. + */ + + timeZone = timezone / 60; + + return timeZone; +#endif + +#if !defined(NO_GETTOD) && !defined (TCL_GOT_TIMEZONE) +# define TCL_GOT_TIMEZONE + struct timeval tv; + struct timezone tz; + int timeZone; + + gettimeofday(&tv, &tz); + timeZone = tz.tz_minuteswest; + if (tz.tz_dsttime) { + timeZone += 60; + } + + return timeZone; +#endif + +#ifndef TCL_GOT_TIMEZONE + /* + * Cause compile error, we don't know how to get timezone. + */ + error: autoconf did not figure out how to determine the timezone. +#endif + +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetTime -- + * + * Gets the current system time in seconds and microseconds + * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * Results: + * Returns the current time in timePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclpGetTime(timePtr) + Tcl_Time *timePtr; /* Location to store time information. */ +{ + struct timeval tv; + struct timezone tz; + + (void) gettimeofday(&tv, &tz); + timePtr->sec = tv.tv_sec; + timePtr->usec = tv.tv_usec; +} diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c new file mode 100644 index 0000000..1479412 --- /dev/null +++ b/unix/tclXtTest.c @@ -0,0 +1,113 @@ +/* + * tclXtTest.c -- + * + * Contains commands for Xt notifier specific tests on Unix. + * + * 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: @(#) tclXtTest.c 1.2 97/09/15 15:26:52 + */ + +#include <X11/Intrinsic.h> +#include "tcl.h" + +static int TesteventloopCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Tclxttest_Init -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tclxttest_Init(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TesteventloopCmd -- + * + * This procedure implements the "testeventloop" command. It is + * used to test the Tcl notifier from an "external" event loop + * (i.e. not Tcl_DoOneEvent()). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TesteventloopCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static int *framePtr = NULL; /* Pointer to integer on stack frame of + * innermost invocation of the "wait" + * subcommand. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " option ... \"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "done") == 0) { + *framePtr = 1; + } else if (strcmp(argv[1], "wait") == 0) { + int *oldFramePtr; + int done; + int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL); + + /* + * Save the old stack frame pointer and set up the current frame. + */ + + oldFramePtr = framePtr; + framePtr = &done; + + /* + * Enter an Xt event loop until the flag changes. + * Note that we do not explicitly call Tcl_ServiceEvent(). + */ + + done = 0; + while (!done) { + XtAppProcessEvent(TclSetAppContext(NULL), XtIMAll); + } + (void) Tcl_SetServiceMode(oldMode); + framePtr = oldFramePtr; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be done or wait", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} diff --git a/win/README b/win/README new file mode 100644 index 0000000..0e3550b --- /dev/null +++ b/win/README @@ -0,0 +1,109 @@ +Tcl 8.0p2 for Windows + +by Scott Stanton +Sun Microsystems Laboratories +scott.stanton@eng.sun.com + +SCCS: @(#) README 1.25 97/11/21 15:15:40 + +1. Introduction +--------------- + +This is the directory where you configure and compile the Windows +version of Tcl. This directory also contains source files for Tcl +that are specific to Microsoft Windows. The rest of this file +contains information specific to the Windows version of Tcl. + +2. Distribution notes +--------------------- + +Tcl 8.0 for Windows is distributed in binary form in addition to the +common source release. The binary distribution is a self-extracting +archive with a built-in installation script. + +Look for the binary release in the same location as the source release +(ftp.smli.com:/pub/tcl or any of the mirror sites). For most users, +the binary release will be much easier to install and use. You only +need the source release if you plan to modify the core of Tcl, or if +you need to compile with a different compiler. With the addition of +the dynamic loading interface, it is no longer necessary to have the +source distribution in order to build and use extensions. + +3. Compiling Tcl +---------------- + +In order to compile Tcl for Windows, you need the following items: + + Tcl 8.0 Source Distribution (plus any patches) + + Borland C++ 4.52 (both 16-bit and 32-bit compilers) + or + Visual C++ 2.x/4.x + Visual C++ 1.5 (to build tcl1680.dll for Win32s support of exec) + +In the "win" subdirectory of the source release, you will find two +files called "makefile.bc" and "makefile.vc". These are the makefiles +for the Borland and Visual C++ compilers respectively. You should +copy the appropriate one to "makefile" and update the paths at the +top of the file to reflect your system configuration. Now you can use +"make" (or "nmake" for VC++) to build the tcl libraries and the tclsh +executable. + +In order to use the binaries generated by these makefiles, you will +need to place the Tcl script library files someplace where Tcl can +find them. Tcl looks in one of three places for the library files: + + 1) The path specified in the environment variable "TCL_LIBRARY". + + 2) In the lib\tcl8.0 directory under the installation directory + as specified in the registry: + + For Windows NT & 95: + HKEY_LOCAL_MACHINE\SOFTWARE\Sun\Tcl\8.0 + Value Name is "Root" + + For Win32s: + HKEY_CLASSES_ROOT\SOFTWARE\Sun\Tcl\8.0\ + + 3) Relative to the directory containing the current .exe. + Tcl will look for a directory "..\lib\tcl8.0" relative to the + directory containing the currently running .exe. + +Note that in order to run tclsh80.exe, you must ensure that tcl80.dll +and tclpip80.dll (plus tcl1680.dll under Win32s) are on your path, in +the system directory, or in the directory containing tclsh80.exe. + +4. Test suite +------------- + +This distribution contains an extensive test suite for Tcl. Some of +the tests are timing dependent and will fail from time to time. If a +test is failing consistently, please send us a bug report with as much +detail as you can manage. + +In order to run the test suite, you build the "test" target using the +appropriate makefile for your compiler. + + +5. Known Bugs +------------- + +Here is the current list of known bugs/missing features for the +Windows version of Tcl: + +- Blocking "after" commands (e.g. "after 3000") don't work on Win32s. +- Clock command fails to handle daylight savings time boundaries for + things like "last week". +- Background processes aren't properly detached on NT. +- File events only work on sockets. +- Pipes/files/console/serial ports don't support nonblocking I/O. +- The library cannot be used by two processes at the same time under + Win32s. + +If you have comments or bug reports for the Windows version of Tcl, +please direct them to: + +Scott Stanton +scott.stanton@eng.sun.com + +or post them to the comp.lang.tcl newsgroup. diff --git a/win/cat.c b/win/cat.c new file mode 100644 index 0000000..0ce550f --- /dev/null +++ b/win/cat.c @@ -0,0 +1,37 @@ +/* + * cat.c -- + * + * Program used when testing tclWinPipe.c + * + * Copyright (c) 1996 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: @(#) cat.c 1.3 96/09/18 15:15:32 + */ + +#include <stdio.h> +#include <io.h> +#include <string.h> + +int +main() +{ + char buf[1024]; + int n; + char *err; + + while (1) { + n = read(0, buf, sizeof(buf)); + if (n <= 0) { + break; + } + write(1, buf, n); + } + err = (sizeof(int) == 2) ? "stderr16" : "stderr32"; + write(2, err, strlen(err)); + + return 0; +} + diff --git a/win/makefile.bc b/win/makefile.bc new file mode 100644 index 0000000..c0c9740 --- /dev/null +++ b/win/makefile.bc @@ -0,0 +1,387 @@ +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# SCCS: @(#) makefile.bc 1.82 97/11/20 15:52:39 +# +# Borland C++ 4.5 makefile +# + +# +# Project directories +# +# ROOT = top of source tree +# TMPDIR = location where .obj files should be stored during build +# TOOLS = location of compiler and other development tools +# + +ROOT = .. +TMPDIR = . +TOOLS = c:\bc45 + +# uncomment the following line to compile with symbols +#DEBUG=1 + +# uncomment one of the following lines to compile with TCL_MEM_DEBUG, +# TCL_COMPILE_DEBUG, or TCL_COMPILE_STATS +#DEBUGDEFINES =TCL_MEM_DEBUG +#DEBUGDEFINES =TCL_MEM_DEBUG;TCL_COMPILE_DEBUG +#DEBUGDEFINES =TCL_MEM_DEBUG;TCL_COMPILE_STATS +#DEBUGDEFINES =TCL_MEM_DEBUG;TCL_COMPILE_DEBUG;TCL_COMPILE_STATS + + +###################################################################### +# Do not modify below this line +###################################################################### + +STACKSIZE = 1f0001 + +VERSION = 80 + +TCLLIB = tcl$(VERSION).lib +TCLDLL = tcl$(VERSION).dll +TCL16DLL = tcl16$(VERSION).dll +TCLSH = tclsh$(VERSION).exe +TCLTEST = tcltest.exe +DUMPEXTS = dumpexts.exe +TCLPIPEDLL = tclpip$(VERSION).dll +TCLREGDLL = tclreg$(VERSION).dll +CAT16 = cat16.exe +CAT32 = cat32.exe + +TCLSHOBJS = \ + $(TMPDIR)\tclAppInit.obj + +TCLTESTOBJS = \ + $(TMPDIR)\tclTest.obj \ + $(TMPDIR)\tclTestObj.obj \ + $(TMPDIR)\tclWinTest.obj \ + $(TMPDIR)\testMain.obj + +TCLOBJS = \ + $(TMPDIR)\panic.obj \ + $(TMPDIR)\regexp.obj \ + $(TMPDIR)\strftime.obj \ + $(TMPDIR)\tclAlloc.obj \ + $(TMPDIR)\tclAsync.obj \ + $(TMPDIR)\tclBasic.obj \ + $(TMPDIR)\tclBinary.obj \ + $(TMPDIR)\tclCkalloc.obj \ + $(TMPDIR)\tclClock.obj \ + $(TMPDIR)\tclCmdAH.obj \ + $(TMPDIR)\tclCmdIL.obj \ + $(TMPDIR)\tclCmdMZ.obj \ + $(TMPDIR)\tclCompExpr.obj \ + $(TMPDIR)\tclCompile.obj \ + $(TMPDIR)\tclDate.obj \ + $(TMPDIR)\tclEnv.obj \ + $(TMPDIR)\tclEvent.obj \ + $(TMPDIR)\tclExecute.obj \ + $(TMPDIR)\tclFCmd.obj \ + $(TMPDIR)\tclFileName.obj \ + $(TMPDIR)\tclGet.obj \ + $(TMPDIR)\tclHash.obj \ + $(TMPDIR)\tclHistory.obj \ + $(TMPDIR)\tclIndexObj.obj \ + $(TMPDIR)\tclInterp.obj \ + $(TMPDIR)\tclIO.obj \ + $(TMPDIR)\tclIOCmd.obj \ + $(TMPDIR)\tclIOSock.obj \ + $(TMPDIR)\tclIOUtil.obj \ + $(TMPDIR)\tclLink.obj \ + $(TMPDIR)\tclListObj.obj \ + $(TMPDIR)\tclLoad.obj \ + $(TMPDIR)\tclMain.obj \ + $(TMPDIR)\tclNamesp.obj \ + $(TMPDIR)\tclNotify.obj \ + $(TMPDIR)\tclObj.obj \ + $(TMPDIR)\tclParse.obj \ + $(TMPDIR)\tclPipe.obj \ + $(TMPDIR)\tclPkg.obj \ + $(TMPDIR)\tclPosixStr.obj \ + $(TMPDIR)\tclPreserve.obj \ + $(TMPDIR)\tclProc.obj \ + $(TMPDIR)\tclStringObj.obj \ + $(TMPDIR)\tclTimer.obj \ + $(TMPDIR)\tclUtil.obj \ + $(TMPDIR)\tclVar.obj \ + $(TMPDIR)\tclWin32Dll.obj \ + $(TMPDIR)\tclWinChan.obj \ + $(TMPDIR)\tclWinError.obj \ + $(TMPDIR)\tclWinFCmd.obj \ + $(TMPDIR)\tclWinFile.obj \ + $(TMPDIR)\tclWinInit.obj \ + $(TMPDIR)\tclWinLoad.obj \ + $(TMPDIR)\tclWinMtherr.obj \ + $(TMPDIR)\tclWinNotify.obj \ + $(TMPDIR)\tclWinPipe.obj \ + $(TMPDIR)\tclWinSock.obj \ + $(TMPDIR)\tclWinTime.obj + +cc32 = $(TOOLS)\bin\bcc32.exe +link32 = $(TOOLS)\bin\tlink32.exe +rc32 = $(TOOLS)\bin\brcc32.exe +implib = $(TOOLS)\bin\implib.exe + +cc16 = $(TOOLS)\bin\bcc.exe +link16 = $(TOOLS)\bin\tlink.exe +rc16 = $(TOOLS)\bin\brcc32.exe -31 + +CP = copy +RM = del + +WINDIR = $(ROOT)\win +GENERICDIR = $(ROOT)\generic + +INCLUDES = $(TOOLS)\include;$(WINDIR);$(GENERICDIR) +LIBDIRS = $(TOOLS)\lib;$(WINDIR) + +CON_CFLAGS = +cfgexe.cfg -WC +TEST_CFLAGS = +cfgtest.cfg +DLL16_CFLAGS = $(PROJECTCCFLAGS) -I$(INCLUDES) -D$(DEFINES) -WD -ml -c \ + -3 -d -w +TCL_CFLAGS = +cfgdll.cfg + +CON_LFLAGS = -Tpe -ap -c $(DEBUGLDFLAGS) $(TOOLS)\lib\c0x32 +DLL_LFLAGS = -Tpd -aa -c $(DEBUGLDFLAGS) $(TOOLS)\lib\c0d32 +GUI_LFLAGS = -Tpe -aa -c $(DEBUGLDFLAGS) $(TOOLS)\lib\c0w32 +DLL16_LFLAGS = -Twd -c -C -A=16 $(DEBUGLDFLAGS16) $(TOOLS)\lib\c0dl + +DLL_LIBS = import32 cw32mti +CON_LIBS = $(TCLLIB) import32 cw32mti +DLL16_LIBS = import cwl + +!ifndef DEBUG + +# these macros cause maximum optimization and no symbols +DEBUGLDFLAGS = +DEBUGCCFLAGS = -v- -vi- -O2 +DEBUGLDFLAGS16 = -Oc -Oi -Oa -Or +!else + +# these macros enable debugging +DEBUGLDFLAGS = -v +DEBUGCCFLAGS = -k -Od -v +DEBUGLDFLAGS16 = + +!endif + +DEFINES = MT;_RTLDLL;$(DEBUGDEFINES) +PROJECTCCFLAGS = $(DEBUGCCFLAGS) -w-par -w-stu + + +# +# Global makefile settings +# + +.AUTODEPEND +.CACHEAUTODEPEND + +.suffixes: + +#.path.c=$(ROOT)\win;$(ROOT)\generic;$(ROOT)\compat +#.path.obj=$(TMPDIR) +#.path.dll=$(ROOT)\win + +# +# Targets +# + +release: $(TCLSH) dlls +all: $(TCLSH) dlls $(CAT16) $(CAT32) +tcltest: $(TCLTEST) dlls $(CAT16) $(CAT32) +dlls: $(TCL16DLL) $(TCLPIPEDLL) $(TCLREGDLL) + +test: tcltest + $(TCLTEST) &&| + cd ../tests + source all +| + + +$(DUMPEXTS): cfgexe.cfg $(WINDIR)\winDumpExts.c + $(cc32) $(CON_CFLAGS) $(WINDIR)\winDumpExts.c + $(link32) $(CON_LFLAGS) \ + $(TMPDIR)\winDumpExts.obj,$@,,import32 cw32mti,, + +$(TCLLIB): $(TCLDLL) + $(implib) -c $@ $(TCLDLL) + +$(TCLDLL): cfgdll.cfg $(TCLOBJS) $(TMPDIR)\tcl.def $(TMPDIR)\tcl.res + $(link32) $(DLL_LFLAGS) @&&| + $(TCLOBJS) +$@ +-x +$(DLL_LIBS) +|, $(TMPDIR)\tcl.def, $(TMPDIR)\tcl.res + + +$(TCLSH): cfgexe.cfg $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res + $(link32) -S:$(STACKSIZE) $(CON_LFLAGS) @&&| + $(TCLSHOBJS) +$@ +-x +$(CON_LIBS) +|, &&| +EXETYPE WINDOWS +CODE PRELOAD MOVEABLE DISCARDABLE +DATA PRELOAD MOVEABLE MULTIPLE +|, $(TMPDIR)\tclsh.res + +$(TCLTEST): cfgtest.cfg $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res + $(link32) -S:$(STACKSIZE) $(CON_LFLAGS) @&&| + $(TCLTESTOBJS) +$@ +-x +$(CON_LIBS) +|, &&| +EXETYPE WINDOWS +CODE PRELOAD MOVEABLE DISCARDABLE +DATA PRELOAD MOVEABLE MULTIPLE +|, $(TMPDIR)\tclsh.res + + +$(TCL16DLL): tcl16.rc $(ROOT)\win\tclWin16.c + $(cc16) @&&| +$(DLL16_CFLAGS) -n$(TMPDIR) +| $(ROOT)\win\tclWin16.c + $(rc16) @&&| +-i$(INCLUDES) -d__WIN32__;$(DEFINES) -fo$(TMPDIR)\tcl16.res +| tcl16.rc + @copy >nul &&| +LIBRARY $&;dll +EXETYPE WINDOWS +CODE PRELOAD MOVEABLE DISCARDABLE +DATA PRELOAD MOVEABLE SINGLE +HEAPSIZE 1024 +EXPORTS + WEP @1 RESIDENTNAME + UTPROC @2 +| $(TMPDIR)\tclWin16.def + $(link16) $(DLL16_LFLAGS) @&&| +$(TMPDIR)\tclWin16.obj +$@ +nul +$(DLL16_LIBS) +$(TMPDIR)\tclWin16.def +| + $(TOOLS)\bin\rlink $(TMPDIR)\tcl16.res $@ + +$(TCLPIPEDLL): cfgexe.cfg stub16.c + $(cc32) -c -tWC stub16.c + $(link32) $(CON_LFLAGS) -L$(TOOLS)\lib \ + stub16.obj,$@,,import32 cw32,, + +$(TCLREGDLL): extdll.cfg $(TMPDIR)\tclWinReg.obj + $(link32) $(DLL_LFLAGS) @&&| + $(TMPDIR)\tclWinReg.obj +$@ +-x +$(DLL_LIBS) $(TCLLIB) +|,, + +# +# Special test targets +# + +$(CAT32): cat.c + $(cc32) -c -Ox -tWC -ocat32.obj cat.c + $(link32) $(CON_LFLAGS) -L$(TOOLS)\lib \ + cat32.obj,$@,,import32 cw32,, + +$(CAT16): cat.c + $(cc16) -W- -ml -Ox -c -ocat16.obj cat.c + $(link16) -Tde -c -L$(TOOLS)\lib $(TOOLS)\lib\c0l.obj cat16.obj,cat16.exe,,cl.lib,, + +####################################################################### +# Implicit Targets +####################################################################### + + +{$(WINDIR)}.c{$(TMPDIR)}.obj: + @$(cc32) $(TCL_CFLAGS) {$< } + +{$(GENERICDIR)}.c{$(TMPDIR)}.obj: + @$(cc32) $(TCL_CFLAGS) {$< } + +{$(ROOT)\compat}.c{$(TMPDIR)}.obj: + @$(cc32) $(TCL_CFLAGS) {$< } + +{$(WINDIR)}.rc{$(TMPDIR)}.res: + $(rc32) -i$(INCLUDES) -fo$@ @&&| +-d__WIN32__;$(DEFINES) $< +| + +# +# Special case object file targets +# + +$(TMPDIR)\tclWinReg.obj : extdll.cfg $(ROOT)\win\tclWinReg.c + $(cc32) +extdll.cfg -o$@ $(ROOT)\win\tclWinReg.c + +$(TMPDIR)\tclAppInit.obj : cfgexe.cfg $(ROOT)\win\tclAppInit.c + $(cc32) $(CON_CFLAGS) -o$@ $(ROOT)\win\tclAppInit.c + +$(TMPDIR)\testMain.obj : cfgexe.cfg $(ROOT)\win\tclAppInit.c + $(cc32) $(TEST_CFLAGS) -o$@ $(ROOT)\win\tclAppInit.c + +$(TMPDIR)\tclWin16.obj : $(ROOT)\win\tclWin16.c + $(cc16) $(DLL16_CFLAGS) -o$@ $(ROOT)\win\tclWin16.c + +# +# Configuration file targets - these files are implicitly used by the compiler +# + +cfgdll.cfg: + @$(CP) &&| + -n$(TMPDIR) -I$(INCLUDES) -c -WM + -D$(DEFINES) -3 -d -w $(PROJECTCCFLAGS) +| cfgdll.cfg >NUL + +extdll.cfg: + @$(CP) &&| + -n$(TMPDIR) -I$(INCLUDES) -c -WD + -D_RTLDLL;$(DEBUGDEFINES) -3 -d -w $(PROJECTCCFLAGS) +| extdll.cfg >NUL + +cfgexe.cfg: + @$(CP) &&| + -n$(TMPDIR) -I$(INCLUDES) -c -W + -D$(DEFINES) -3 -d -w $(PROJECTCCFLAGS) +| cfgexe.cfg >NUL + +cfgtest.cfg: + @$(CP) &&| + -n$(TMPDIR) -I$(INCLUDES) -c -W + -D$(DEFINES);TCL_TEST -3 -d -w $(PROJECTCCFLAGS) +| cfgtest.cfg >NUL + +cfgcln: + -@$(RM) *.cfg + + +# The following rule automatically generates a tcl.def file containing +# an export entry for every public symbol in the tcl.dll library. + +$(TMPDIR)\tcl.def: $(TCLOBJS) $(DUMPEXTS) + $(DUMPEXTS) -o $(TMPDIR)\tcl.def $(TCLDLL) @&&| + $(TCLOBJS) +| + + +# the following two rules are a hack to get around the fact that the +# 16-bit compiler doesn't handle long file names :-( + +$(ROOT)\win\tclWinIn.h: $(ROOT)\win\tclWinInt.h + $(CP) $(ROOT)\win\tclWinInt.h $(ROOT)\win\tclWinIn.h + +$(ROOT)\win\tclWin16.c: $(ROOT)\win\tclWinIn.h + +# remove all generated files + +clean: + -@$(RM) *.exe + -@$(RM) *.lib + -@$(RM) *.dll + -@$(RM) $(TMPDIR)\*.res + -@$(RM) $(TMPDIR)\*.def + -@$(RM) $(TMPDIR)\*.obj + -@$(RM) $(TMPDIR)\*.cfg + -@$(RM) $(ROOT)\win\tclWinIn.h diff --git a/win/makefile.vc b/win/makefile.vc new file mode 100644 index 0000000..12eda6f --- /dev/null +++ b/win/makefile.vc @@ -0,0 +1,377 @@ +# Visual C++ 2.x and 4.0 makefile +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# SCCS: @(#) makefile.vc 1.82 97/11/20 15:14:01 + +# Does not depend on the presence of any environment variables in +# order to compile tcl; all needed information is derived from +# location of the compiler directories. + +# +# Project directories +# +# ROOT = top of source tree +# +# TMPDIR = location where .obj files should be stored during build +# +# TOOLS32 = location of VC++ 32-bit development tools. Note that the +# VC++ 2.0 header files are broken, so you need to use the +# ones that come with the developer network CD's, or later +# versions of VC++. +# +# TOOLS16 = location of VC++ 1.5 16-bit tools, needed to build thunking +# library. This information is optional; if the 16-bit compiler +# is not available, then the 16-bit code will not be built. +# Tcl will still run without the 16-bit code, but... +# A. Under Windows 3.X you will any calls to the exec command +# will return an error. +# B. A 16-bit program to test the behavior of the exec +# command under NT and 95 will not be built. +# + +ROOT = .. +TMPDIR = . +TOOLS32 = c:\msdev +TOOLS16 = c:\msvc + +# Set this to the appropriate value of /MACHINE: for your platform +MACHINE = IX86 + +# Comment the following line to compile with symbols +NODEBUG=1 + +# uncomment one of the following lines to compile with TCL_MEM_DEBUG, +# TCL_MEM_DEBUG, or TCL_COMPILE_DEBUG +#DEBUGDEFINES = -DTCL_MEM_DEBUG +#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG +#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_STATS +#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS + +###################################################################### +# Do not modify below this line +###################################################################### + +VERSION = 80 + +TCLLIB = tcl$(VERSION).lib +TCLDLL = tcl$(VERSION).dll +TCLPLUGINLIB = tcl$(VERSION)p.lib +TCLPLUGINDLL = tcl$(VERSION)p.dll +TCL16DLL = tcl16$(VERSION).dll +TCLSH = tclsh$(VERSION).exe +TCLSHP = tclshp$(VERSION).exe +TCLTEST = tcltest.exe +DUMPEXTS = $(TMPDIR)\dumpexts.exe +TCLPIPEDLL = tclpip$(VERSION).dll +TCLREGDLL = tclreg$(VERSION).dll +CAT16 = cat16.exe +CAT32 = cat32.exe + +TCLSHOBJS = \ + $(TMPDIR)\tclAppInit.obj + +TCLTESTOBJS = \ + $(TMPDIR)\tclTest.obj \ + $(TMPDIR)\tclTestObj.obj \ + $(TMPDIR)\tclWinTest.obj \ + $(TMPDIR)\testMain.obj + +TCLOBJS = \ + $(TMPDIR)\panic.obj \ + $(TMPDIR)\regexp.obj \ + $(TMPDIR)\strftime.obj \ + $(TMPDIR)\tclAlloc.obj \ + $(TMPDIR)\tclAsync.obj \ + $(TMPDIR)\tclBasic.obj \ + $(TMPDIR)\tclBinary.obj \ + $(TMPDIR)\tclCkalloc.obj \ + $(TMPDIR)\tclClock.obj \ + $(TMPDIR)\tclCmdAH.obj \ + $(TMPDIR)\tclCmdIL.obj \ + $(TMPDIR)\tclCmdMZ.obj \ + $(TMPDIR)\tclCompExpr.obj \ + $(TMPDIR)\tclCompile.obj \ + $(TMPDIR)\tclDate.obj \ + $(TMPDIR)\tclEnv.obj \ + $(TMPDIR)\tclEvent.obj \ + $(TMPDIR)\tclExecute.obj \ + $(TMPDIR)\tclFCmd.obj \ + $(TMPDIR)\tclFileName.obj \ + $(TMPDIR)\tclGet.obj \ + $(TMPDIR)\tclHash.obj \ + $(TMPDIR)\tclHistory.obj \ + $(TMPDIR)\tclIndexObj.obj \ + $(TMPDIR)\tclInterp.obj \ + $(TMPDIR)\tclIO.obj \ + $(TMPDIR)\tclIOCmd.obj \ + $(TMPDIR)\tclIOSock.obj \ + $(TMPDIR)\tclIOUtil.obj \ + $(TMPDIR)\tclLink.obj \ + $(TMPDIR)\tclListObj.obj \ + $(TMPDIR)\tclLoad.obj \ + $(TMPDIR)\tclMain.obj \ + $(TMPDIR)\tclNamesp.obj \ + $(TMPDIR)\tclNotify.obj \ + $(TMPDIR)\tclObj.obj \ + $(TMPDIR)\tclParse.obj \ + $(TMPDIR)\tclPipe.obj \ + $(TMPDIR)\tclPkg.obj \ + $(TMPDIR)\tclPosixStr.obj \ + $(TMPDIR)\tclPreserve.obj \ + $(TMPDIR)\tclProc.obj \ + $(TMPDIR)\tclStringObj.obj \ + $(TMPDIR)\tclTimer.obj \ + $(TMPDIR)\tclUtil.obj \ + $(TMPDIR)\tclVar.obj \ + $(TMPDIR)\tclWin32Dll.obj \ + $(TMPDIR)\tclWinChan.obj \ + $(TMPDIR)\tclWinError.obj \ + $(TMPDIR)\tclWinFCmd.obj \ + $(TMPDIR)\tclWinFile.obj \ + $(TMPDIR)\tclWinInit.obj \ + $(TMPDIR)\tclWinLoad.obj \ + $(TMPDIR)\tclWinMtherr.obj \ + $(TMPDIR)\tclWinNotify.obj \ + $(TMPDIR)\tclWinPipe.obj \ + $(TMPDIR)\tclWinSock.obj \ + $(TMPDIR)\tclWinTime.obj + +cc32 = $(TOOLS32)\bin\cl.exe +link32 = $(TOOLS32)\bin\link.exe +rc32 = $(TOOLS32)\bin\rc.exe +include32 = -I$(TOOLS32)\include + +cc16 = $(TOOLS16)\bin\cl.exe +link16 = $(TOOLS16)\bin\link.exe +rc16 = $(TOOLS16)\bin\rc.exe +include16 = -I$(TOOLS16)\include + +WINDIR = $(ROOT)\win +GENERICDIR = $(ROOT)\generic + +TCL_INCLUDES = -I$(WINDIR) -I$(GENERICDIR) +TCL_DEFINES = -D__WIN32__ $(DEBUGDEFINES) + +TCL_CFLAGS = $(cdebug) $(cflags) $(cvarsdll) $(include32) \ + $(TCL_INCLUDES) $(TCL_DEFINES) +CON_CFLAGS = $(cdebug) $(cflags) $(cvars) $(include32) -DCONSOLE +DOS_CFLAGS = $(cdebug) $(cflags) $(include16) -AL +DLL16_CFLAGS = $(cdebug) $(cflags) $(include16) -ALw + +###################################################################### +# Link flags +###################################################################### + +!IFDEF NODEBUG +ldebug = /RELEASE +!ELSE +ldebug = -debug:full -debugtype:cv +!ENDIF + +# declarations common to all linker options +lcommon = /NODEFAULTLIB /RELEASE /NOLOGO + +# declarations for use on Intel i386, i486, and Pentium systems +!IF "$(MACHINE)" == "IX86" +DLLENTRY = @12 +lflags = $(lcommon) -align:0x1000 /MACHINE:$(MACHINE) +!ELSE +lflags = $(lcommon) /MACHINE:$(MACHINE) +!ENDIF + +conlflags = $(lflags) -subsystem:console -entry:mainCRTStartup +guilflags = $(lflags) -subsystem:windows -entry:WinMainCRTStartup +dlllflags = $(lflags) -entry:_DllMainCRTStartup$(DLLENTRY) -dll + +!IF "$(MACHINE)" == "PPC" +libc = libc.lib +libcdll = crtdll.lib +!ELSE +libc = libc.lib oldnames.lib +libcdll = msvcrt.lib oldnames.lib +!ENDIF + +baselibs = kernel32.lib $(optlibs) advapi32.lib user32.lib +winlibs = $(baselibs) gdi32.lib comdlg32.lib winspool.lib + +guilibs = $(libc) $(winlibs) +conlibs = $(libc) $(baselibs) +guilibsdll = $(libcdll) $(winlibs) +conlibsdll = $(libcdll) $(baselibs) + +###################################################################### +# Compile flags +###################################################################### + +!IFDEF NODEBUG +cdebug = -Oti -Gs -GD +!ELSE +cdebug = -Z7 -Od -WX +!ENDIF + +# declarations common to all compiler options +ccommon = -c -W3 -nologo -YX -Dtry=__try -Dexcept=__except + +!IF "$(MACHINE)" == "IX86" +cflags = $(ccommon) -D_X86_=1 +!ELSE +!IF "$(MACHINE)" == "MIPS" +cflags = $(ccommon) -D_MIPS_=1 +!ELSE +!IF "$(MACHINE)" == "PPC" +cflags = $(ccommon) -D_PPC_=1 +!ELSE +!IF "$(MACHINE)" == "ALPHA" +cflags = $(ccommon) -D_ALPHA_=1 +!ENDIF +!ENDIF +!ENDIF +!ENDIF + +cvars = -DWIN32 -D_WIN32 +cvarsmt = $(cvars) -D_MT +cvarsdll = $(cvarsmt) -D_DLL + +###################################################################### +# Project specific targets +###################################################################### + +release: $(TCLSH) dlls +dlls: $(TCL16DLL) $(TCLPIPEDLL) $(TCLREGDLL) +all: $(TCLSH) dlls $(CAT16) $(CAT32) +tcltest: $(TCLTEST) dlls $(CAT16) $(CAT32) +plugin: $(TCLPLUGINDLL) $(TCLSHP) +test: $(TCLTEST) dlls $(CAT16) $(CAT32) + $(TCLTEST) << + cd ../tests + source all +<< + +$(DUMPEXTS): $(WINDIR)\winDumpExts.c + $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $? + set LIB=$(TOOLS32)\lib + $(link32) $(ldebug) $(conlflags) $(guilibs) -out:$@ \ + $(TMPDIR)\winDumpExts.obj + +$(TCLLIB): $(TCLDLL) + +$(TCLDLL): $(TCLOBJS) $(TMPDIR)\tcl.def $(TMPDIR)\tcl.res + set LIB=$(TOOLS32)\lib + $(link32) $(ldebug) $(dlllflags) -def:$(TMPDIR)\tcl.def \ + -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @<< +$(TCLOBJS) +<< + +$(TCLPLUGINLIB): $(TCLPLUGINDLL) + +$(TCLPLUGINDLL): $(TCLOBJS) $(TMPDIR)\plugin.def $(TMPDIR)\tcl.res + set LIB=$(TOOLS32)\lib + $(link32) $(ldebug) $(dlllflags) -def:$(TMPDIR)\plugin.def \ + -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @<< +$(TCLOBJS) +<< + +$(TCLSH): $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res + set LIB=$(TOOLS32)\lib + $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \ + -out:$@ $(conlibsdll) $(TCLLIB) $(TCLSHOBJS) + +$(TCLSHP): $(TCLSHOBJS) $(TCLPLUGINLIB) $(TMPDIR)\tclsh.res + set LIB=$(TOOLS32)\lib + $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \ + -out:$@ $(conlibsdll) $(TCLPLUGINLIB) $(TCLSHOBJS) + +$(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res + set LIB=$(TOOLS32)\lib + $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \ + -out:$@ $(conlibsdll) $(TCLLIB) $(TCLTESTOBJS) + +$(TCL16DLL): $(WINDIR)\tcl16.rc $(WINDIR)\tclWin16.c + if exist $(cc16) $(cc16) @<< +$(DLL16_CFLAGS) -Fo$(TMPDIR)\ $(WINDIR)\tclWin16.c +<< + @copy << $(TMPDIR)\tclWin16.def > nul +LIBRARY $(@B);dll +EXETYPE WINDOWS +CODE PRELOAD MOVEABLE DISCARDABLE +DATA PRELOAD MOVEABLE SINGLE +HEAPSIZE 1024 +EXPORTS + WEP @1 RESIDENTNAME + UTPROC @2 +<< + if exist $(cc16) $(link16) /NOLOGO /ONERROR:NOEXE /NOE @<< +$(TMPDIR)\tclWin16.obj +$@ +nul +$(TOOLS16)\lib\ ldllcew oldnames libw toolhelp +$(TMPDIR)\tclWin16.def +<< + if exist $(cc16) $(rc16) -i $(GENERICDIR) $(TCL_DEFINES) $(WINDIR)\tcl16.rc $@ + +$(TCLPIPEDLL): $(WINDIR)\stub16.c + $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $(WINDIR)\stub16.c + set LIB=$(TOOLS32)\lib + $(link32) $(ldebug) $(conlflags) -out:$@ $(TMPDIR)\stub16.obj $(guilibs) + +$(TCLREGDLL): $(TMPDIR)\tclWinReg.obj + set LIB=$(TOOLS32)\lib + $(link32) $(ldebug) $(dlllflags) -out:$@ $(TMPDIR)\tclWinReg.obj \ + $(conlibsdll) $(TCLLIB) + +$(CAT32): $(WINDIR)\cat.c + $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $? + set LIB=$(TOOLS32)\lib + $(link32) $(conlflags) -out:$@ -stack:16384 $(TMPDIR)\cat.obj $(conlibs) + +$(CAT16): $(WINDIR)\cat.c + if exist $(cc16) $(cc16) $(DOS_CFLAGS) -Fo$(TMPDIR)\ $? + set LIB=$(TOOLS16)\lib + if exist $(cc16) $(link16) /NOLOGO /ONERROR:NOEXE /NOI /STACK:16384 \ + $(TMPDIR)\cat.obj,$@,nul,llibce.lib,nul + +$(TMPDIR)\tcl.def: $(DUMPEXTS) $(TCLOBJS) + $(DUMPEXTS) -o $@ $(TCLDLL) @<< +$(TCLOBJS) +<< + +$(TMPDIR)\plugin.def: $(DUMPEXTS) $(TCLOBJS) + $(DUMPEXTS) -o $@ $(TCLPLUGINDLL) @<< +$(TCLOBJS) +<< + +# +# Special case object file targets +# + +$(TMPDIR)\testMain.obj: $(WINDIR)\tclAppInit.c + $(cc32) $(TCL_CFLAGS) -DTCL_TEST -Fo$(TMPDIR)\testMain.obj $? + +# +# Implicit rules +# + +{$(WINDIR)}.c{$(TMPDIR)}.obj: + $(cc32) $(TCL_CFLAGS) -Fo$(TMPDIR)\ $< + +{$(GENERICDIR)}.c{$(TMPDIR)}.obj: + $(cc32) $(TCL_CFLAGS) -Fo$(TMPDIR)\ $< + +{$(ROOT)\compat}.c{$(TMPDIR)}.obj: + $(cc32) $(TCL_CFLAGS) -Fo$(TMPDIR)\ $< + +{$(WINDIR)}.rc{$(TMPDIR)}.res: + $(rc32) -fo $@ -r -i $(GENERICDIR) -i $(WINDIR) -D__WIN32__ \ + $(TCL_DEFINES) $< + +clean: + -@del *.exp + -@del *.lib + -@del *.dll + -@del *.exe + -@del $(TMPDIR)\*.obj + -@del $(TMPDIR)\*.res + -@del $(TMPDIR)\*.def diff --git a/win/pkgIndex.tcl b/win/pkgIndex.tcl new file mode 100644 index 0000000..6847aa8 --- /dev/null +++ b/win/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.0 +# This file contains package information for Windows-specific extensions. +# +# 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: @(#) pkgIndex.tcl 1.1 97/06/23 14:25:47 + +package ifneeded registry 1.0 [list tclPkgSetup $dir registry 1.0 {{tclreg80.dll load registry}}] diff --git a/win/stub16.c b/win/stub16.c new file mode 100644 index 0000000..5fafd29 --- /dev/null +++ b/win/stub16.c @@ -0,0 +1,198 @@ +/* + * stub16.c + * + * A helper program used for running 16-bit DOS applications under + * Windows 95. + * + * Copyright (c) 1996 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: @(#) stub16.c 1.5 96/12/11 20:01:58 + */ + +#define STRICT + +#include <windows.h> +#include <stdio.h> + +static HANDLE CreateTempFile(void); + +/* + *--------------------------------------------------------------------------- + * + * main + * + * Entry point for the 32-bit console mode app used by Windows 95 to + * help run the 16-bit program specified on the command line. + * + * 1. EOF on a pipe that connects a detached 16-bit process and a + * 32-bit process is never seen. So, this process runs the 16-bit + * process _attached_, and then it is run detached from the calling + * 32-bit process. + * + * 2. If a 16-bit process blocks reading from or writing to a pipe, + * it never wakes up, and eventually brings the whole system down + * with it if you try to kill the process. This app simulates + * pipes. If any of the stdio handles is a pipe, this program + * accumulates information into temp files and forwards it to or + * from the DOS application as appropriate. This means that this + * program must receive EOF from a stdin pipe before it will actually + * start the DOS app, and the DOS app must finish generating stdout + * or stderr before the data will be sent to the next stage of the + * pipe. If the stdio handles are not pipes, no accumulation occurs + * and the data is passed straight through to and from the DOS + * application. + * + * Results: + * None. + * + * Side effects: + * The child process is created and this process waits for it to + * complete. + * + *--------------------------------------------------------------------------- + */ + +int +main() +{ + DWORD dwRead, dwWrite; + char *cmdLine; + HANDLE hStdInput, hStdOutput, hStdError; + HANDLE hFileInput, hFileOutput, hFileError; + STARTUPINFO si; + PROCESS_INFORMATION pi; + char buf[8192]; + DWORD result; + + hFileInput = INVALID_HANDLE_VALUE; + hFileOutput = INVALID_HANDLE_VALUE; + hFileError = INVALID_HANDLE_VALUE; + result = 1; + + /* + * Don't get command line from argc, argv, because the command line + * tokenizer will have stripped off all the escape sequences needed + * for quotes and backslashes, and then we'd have to put them all + * back in again. Get the raw command line and parse off what we + * want ourselves. The command line should be of the form: + * + * stub16.exe program arg1 arg2 ... + */ + + cmdLine = strchr(GetCommandLine(), ' '); + if (cmdLine == NULL) { + return 1; + } + cmdLine++; + + hStdInput = GetStdHandle(STD_INPUT_HANDLE); + hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE); + hStdError = GetStdHandle(STD_ERROR_HANDLE); + + if (GetFileType(hStdInput) == FILE_TYPE_PIPE) { + hFileInput = CreateTempFile(); + if (hFileInput == INVALID_HANDLE_VALUE) { + goto cleanup; + } + while (ReadFile(hStdInput, buf, sizeof(buf), &dwRead, NULL) != FALSE) { + if (dwRead == 0) { + break; + } + if (WriteFile(hFileInput, buf, dwRead, &dwWrite, NULL) == FALSE) { + goto cleanup; + } + } + SetFilePointer(hFileInput, 0, 0, FILE_BEGIN); + SetStdHandle(STD_INPUT_HANDLE, hFileInput); + } + if (GetFileType(hStdOutput) == FILE_TYPE_PIPE) { + hFileOutput = CreateTempFile(); + if (hFileOutput == INVALID_HANDLE_VALUE) { + goto cleanup; + } + SetStdHandle(STD_OUTPUT_HANDLE, hFileOutput); + } + if (GetFileType(hStdError) == FILE_TYPE_PIPE) { + hFileError = CreateTempFile(); + if (hFileError == INVALID_HANDLE_VALUE) { + goto cleanup; + } + SetStdHandle(STD_ERROR_HANDLE, hFileError); + } + + ZeroMemory(&si, sizeof(si)); + si.cb = sizeof(si); + if (CreateProcess(NULL, cmdLine, NULL, NULL, TRUE, 0, NULL, NULL, &si, + &pi) == FALSE) { + goto cleanup; + } + + WaitForInputIdle(pi.hProcess, 5000); + WaitForSingleObject(pi.hProcess, INFINITE); + CloseHandle(pi.hProcess); + CloseHandle(pi.hThread); + result = 0; + + if (hFileOutput != INVALID_HANDLE_VALUE) { + SetFilePointer(hFileOutput, 0, 0, FILE_BEGIN); + while (ReadFile(hFileOutput, buf, sizeof(buf), &dwRead, NULL) != FALSE) { + if (dwRead == 0) { + break; + } + if (WriteFile(hStdOutput, buf, dwRead, &dwWrite, NULL) == FALSE) { + break; + } + } + } + if (hFileError != INVALID_HANDLE_VALUE) { + SetFilePointer(hFileError, 0, 0, FILE_BEGIN); + while (ReadFile(hFileError, buf, sizeof(buf), &dwRead, NULL) != FALSE) { + if (dwRead == 0) { + break; + } + if (WriteFile(hStdError, buf, dwRead, &dwWrite, NULL) == FALSE) { + break; + } + } + } + +cleanup: + if (hFileInput != INVALID_HANDLE_VALUE) { + CloseHandle(hFileInput); + } + if (hFileOutput != INVALID_HANDLE_VALUE) { + CloseHandle(hFileOutput); + } + if (hFileError != INVALID_HANDLE_VALUE) { + CloseHandle(hFileError); + } + CloseHandle(hStdInput); + CloseHandle(hStdOutput); + CloseHandle(hStdError); + ExitProcess(result); + return 1; +} + +static HANDLE +CreateTempFile() +{ + char name[MAX_PATH]; + SECURITY_ATTRIBUTES sa; + + if (GetTempPath(sizeof(name), name) == 0) { + return INVALID_HANDLE_VALUE; + } + if (GetTempFileName(name, "tcl", 0, name) == 0) { + return INVALID_HANDLE_VALUE; + } + + sa.nLength = sizeof(sa); + sa.lpSecurityDescriptor = NULL; + sa.bInheritHandle = TRUE; + return CreateFile(name, GENERIC_READ | GENERIC_WRITE, 0, &sa, + CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY | FILE_FLAG_DELETE_ON_CLOSE, + NULL); +} diff --git a/win/tcl.rc b/win/tcl.rc new file mode 100644 index 0000000..e7eabd1 --- /dev/null +++ b/win/tcl.rc @@ -0,0 +1,42 @@ +// SCCS: @(#) tcl.rc 1.24 97/04/01 19:19:43 +// +// Version +// + +#define RESOURCE_INCLUDED +#include <tcl.h> + +VS_VERSION_INFO VERSIONINFO + FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + FILEFLAGSMASK 0x3fL + FILEFLAGS 0x0L + FILEOS 0x4L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" + BEGIN + VALUE "FileDescription", "Tcl DLL\0" + VALUE "OriginalFilename", "tcl" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".dll\0" + VALUE "CompanyName", "Sun Microsystems, Inc\0" + VALUE "FileVersion", TCL_PATCH_LEVEL + VALUE "LegalCopyright", "Copyright \251 1995-1997\0" + VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" + VALUE "ProductVersion", TCL_PATCH_LEVEL + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END + + + + + + + diff --git a/win/tcl16.rc b/win/tcl16.rc new file mode 100644 index 0000000..5e4498e --- /dev/null +++ b/win/tcl16.rc @@ -0,0 +1,37 @@ +// SCCS: @(#) tcl16.rc 1.17 96/09/18 18:19:00 +// +// Version +// + +#define RESOURCE_INCLUDED +#include <tcl.h> + +VS_VERSION_INFO VERSIONINFO + FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + FILEFLAGSMASK 0x3fL + FILEFLAGS 0x0L + FILEOS 0x1L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" + BEGIN + VALUE "FileDescription", "Tcl16 DLL, 16-bit thunking module\0" + VALUE "OriginalFilename", "tcl16" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".dll\0" + VALUE "CompanyName", "Sun Microsystems, Inc\0" + VALUE "FileVersion", TCL_PATCH_LEVEL + VALUE "LegalCopyright", "Copyright \251 1995-1996\0" + VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" + VALUE "ProductVersion", TCL_PATCH_LEVEL + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END + + diff --git a/win/tclAppInit.c b/win/tclAppInit.c new file mode 100644 index 0000000..10a77cb --- /dev/null +++ b/win/tclAppInit.c @@ -0,0 +1,259 @@ +/* + * tclAppInit.c -- + * + * Provides a default version of the main program and Tcl_AppInit + * procedure for Tcl applications (without Tk). Note that this + * program must be built in Win32 console mode to work properly. + * + * Copyright (c) 1996 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: @(#) tclAppInit.c 1.12 97/04/30 11:04:50 + */ + +#include "tcl.h" +#include <windows.h> +#include <locale.h> + +#ifdef TCL_TEST +EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +#endif /* TCL_TEST */ + +static void setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr)); + + +/* + *---------------------------------------------------------------------- + * + * main -- + * + * This is the main program for the application. + * + * Results: + * None: Tcl_Main never returns here, so this procedure never + * returns either. + * + * Side effects: + * Whatever the application does. + * + *---------------------------------------------------------------------- + */ + +int +main(argc, argv) + int argc; /* Number of command-line arguments. */ + char **argv; /* Values of command-line arguments. */ +{ + char *p; + char buffer[MAX_PATH]; + + /* + * Set up the default locale to be standard "C" locale so parsing + * is performed correctly. + */ + + setlocale(LC_ALL, "C"); + + setargv(&argc, &argv); + + /* + * Replace argv[0] with full pathname of executable, and forward + * slashes substituted for backslashes. + */ + + GetModuleFileName(NULL, buffer, sizeof(buffer)); + argv[0] = buffer; + for (p = buffer; *p != '\0'; p++) { + if (*p == '\\') { + *p = '/'; + } + } + + Tcl_Main(argc, argv, Tcl_AppInit); + return 0; /* Needed only to prevent compiler warning. */ +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppInit -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AppInit(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + if (Tcl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + +#ifdef TCL_TEST + if (Tcltest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, + (Tcl_PackageInitProc *) NULL); + if (TclObjTest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } +#endif /* TCL_TEST */ + + /* + * Call the init procedures for included packages. Each call should + * look like this: + * + * if (Mod_Init(interp) == TCL_ERROR) { + * return TCL_ERROR; + * } + * + * where "Mod" is the name of the module. + */ + + /* + * Call Tcl_CreateCommand for application-specific commands, if + * they weren't already created by the init procedures called above. + */ + + /* + * Specify a user-specific startup file to invoke if the application + * is run interactively. Typically the startup file is "~/.apprc" + * where "app" is the name of the application. If this line is deleted + * then no user-specific startup file will be run under any conditions. + */ + + Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * setargv -- + * + * Parse the Windows command line string into argc/argv. Done here + * because we don't trust the builtin argument parser in crt0. + * Windows applications are responsible for breaking their command + * line into arguments. + * + * 2N backslashes + quote -> N backslashes + begin quoted string + * 2N + 1 backslashes + quote -> literal + * N backslashes + non-quote -> literal + * quote + quote in a quoted string -> single quote + * quote + quote not in quoted string -> empty string + * quote -> begin quoted string + * + * Results: + * Fills argcPtr with the number of arguments and argvPtr with the + * array of arguments. + * + * Side effects: + * Memory allocated. + * + *-------------------------------------------------------------------------- + */ + +static void +setargv(argcPtr, argvPtr) + int *argcPtr; /* Filled with number of argument strings. */ + char ***argvPtr; /* Filled with argument strings (malloc'd). */ +{ + char *cmdLine, *p, *arg, *argSpace; + char **argv; + int argc, size, inquote, copy, slashes; + + cmdLine = GetCommandLine(); + + /* + * Precompute an overly pessimistic guess at the number of arguments + * in the command line by counting non-space spans. + */ + + size = 2; + for (p = cmdLine; *p != '\0'; p++) { + if (isspace(*p)) { + size++; + while (isspace(*p)) { + p++; + } + if (*p == '\0') { + break; + } + } + } + argSpace = (char *) ckalloc((unsigned) (size * sizeof(char *) + + strlen(cmdLine) + 1)); + argv = (char **) argSpace; + argSpace += size * sizeof(char *); + size--; + + p = cmdLine; + for (argc = 0; argc < size; argc++) { + argv[argc] = arg = argSpace; + while (isspace(*p)) { + p++; + } + if (*p == '\0') { + break; + } + + inquote = 0; + slashes = 0; + while (1) { + copy = 1; + while (*p == '\\') { + slashes++; + p++; + } + if (*p == '"') { + if ((slashes & 1) == 0) { + copy = 0; + if ((inquote) && (p[1] == '"')) { + p++; + copy = 1; + } else { + inquote = !inquote; + } + } + slashes >>= 1; + } + + while (slashes) { + *arg = '\\'; + arg++; + slashes--; + } + + if ((*p == '\0') || (!inquote && isspace(*p))) { + break; + } + if (copy != 0) { + *arg = *p; + arg++; + } + p++; + } + *arg = '\0'; + argSpace = arg + 1; + } + argv[argc] = NULL; + + *argcPtr = argc; + *argvPtr = argv; +} diff --git a/win/tclWin16.c b/win/tclWin16.c new file mode 100644 index 0000000..d8ea801 --- /dev/null +++ b/win/tclWin16.c @@ -0,0 +1,347 @@ +/* + * tclWin16.c -- + * + * This file contains code for a 16-bit DLL to handle 32-to-16 bit + * thunking. This is necessary for the Win32s SynchSpawn() call. + * + * 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: @(#) tclWin16.c 1.18 97/05/23 13:13:32 + */ + +#define STRICT + +#include <windows.h> +#include <toolhelp.h> + +#include <stdio.h> +#include <string.h> + +static int WinSpawn(char *command); +static int DosSpawn(char *command, char *fromFileName, + char *toFileName); +static int WaitForExit(int inst); + +/* + * The following data is used to construct a .pif file that wraps the + * .bat file that runs the 16-bit application (that Jack built). + * The .pif file causes the .bat file to run in an iconified window. + * Otherwise, when we try to exec something, a DOS box pops up, + * obscuring everything, and then almost immediately flickers out of + * existence, which is rather disconcerting. + */ + +static char pifData[545] = { +'\000', '\013', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\200', '\000', '\200', '\000', '\103', '\117', '\115', '\115', +'\101', '\116', '\104', '\056', '\103', '\117', '\115', '\000', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\020', '\000', '\000', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\177', '\001', '\000', +'\377', '\031', '\120', '\000', '\000', '\007', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\340', +'\040', '\115', '\111', '\103', '\122', '\117', '\123', '\117', +'\106', '\124', '\040', '\120', '\111', '\106', '\105', '\130', +'\000', '\207', '\001', '\000', '\000', '\161', '\001', '\127', +'\111', '\116', '\104', '\117', '\127', '\123', '\040', '\063', +'\070', '\066', '\040', '\063', '\056', '\060', '\000', '\005', +'\002', '\235', '\001', '\150', '\000', '\200', '\002', '\200', +'\000', '\144', '\000', '\062', '\000', '\000', '\004', '\000', +'\000', '\000', '\004', '\000', '\000', '\002', '\020', '\002', +'\000', '\037', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000', +'\000', '\000', '\000', '\000', '\000', '\057', '\143', '\040', +'\146', '\157', '\157', '\056', '\142', '\141', '\164', '\000', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040', +'\040', '\040', '\040', '\040', '\040', '\127', '\111', '\116', +'\104', '\117', '\127', '\123', '\040', '\062', '\070', '\066', +'\040', '\063', '\056', '\060', '\000', '\377', '\377', '\033', +'\002', '\006', '\000', '\000', '\000', '\000', '\000', '\000', +'\000' +}; + +static HINSTANCE hInstance; + + +/* + *---------------------------------------------------------------------- + * + * LibMain -- + * + * 16-bit DLL entry point. + * + * Results: + * Returns 1. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int CALLBACK +LibMain( + HINSTANCE hinst, + WORD wDS, + WORD cbHeap, + LPSTR unused) +{ + hInstance = hinst; + wDS = wDS; /* lint. */ + cbHeap = cbHeap; /* lint. */ + unused = unused; /* lint. */ + + return TRUE; +} + +/* + *---------------------------------------------------------------------- + * + * UTProc -- + * + * Universal Thunk dispatch routine. Executes a 16-bit DOS + * application or a 16-bit or 32-bit Windows application and + * waits for it to complete. + * + * Results: + * 1 if the application could be run, 0 or -1 on failure. + * + * Side effects: + * Executes 16-bit code. + * + *---------------------------------------------------------------------- + */ + +int WINAPI +UTProc(buf, func) + void *buf; + DWORD func; +{ + char **args; + + args = (char **) buf; + if (func == 0) { + return DosSpawn(args[0], args[1], args[2]); + } else { + return WinSpawn(args[0]); + } +} + +/* + *------------------------------------------------------------------------- + * + * WinSpawn -- + * + * Start a 16-bit or 32-bit Windows application with optional + * command line arguments and wait for it to finish. Windows + * applications do not handle input/output redirection. + * + * Results: + * The return value is 1 if the application could be run, 0 otherwise. + * + * Side effects: + * Whatever the application does. + * + *------------------------------------------------------------------------- + */ + +static int +WinSpawn(command) + char *command; /* The command line, consisting of the name + * of the executable to run followed by any + * number of arguments to the executable. */ +{ + return WaitForExit(WinExec(command, SW_SHOW)); +} + +/* + *--------------------------------------------------------------------------- + * + * DosSpawn -- + * + * Start a 16-bit DOS program with optional command line arguments + * and wait for it to finish. Input and output can be redirected + * from the specified files, but there is no such thing as stderr + * under Win32s. + * + * This procedure to constructs a temporary .pif file that wraps a + * temporary .bat file that runs the 16-bit application. The .bat + * file is necessary to get the redirection symbols '<' and '>' to + * work, because WinExec() doesn't accept them. The .pif file is + * necessary to cause the .bat file to run in an iconified window, + * to avoid having a large DOS box pop up, obscuring everything, and + * then almost immediately flicker out of existence, which is rather + * disconcerting. + * + * Results: + * The return value is 1 if the application could be run, 0 otherwise. + * + * Side effects: + * Whatever the application does. + * + *--------------------------------------------------------------------------- + */ + +static int +DosSpawn(command, fromFileName, toFileName) + char *command; /* The name of the program, plus any + * arguments, to be run. */ + char *fromFileName; /* Standard input for the program is to be + * redirected from this file, or NULL for no + * standard input. */ + char *toFileName; /* Standard output for the program is to be + * redirected to this file, or NULL to + * discard standard output. */ +{ + int result; + HFILE batFile, pifFile; + char batFileName[144], pifFileName[144]; + + GetTempFileName(0, "tcl", 0, batFileName); + unlink(batFileName); + strcpy(strrchr(batFileName, '.'), ".bat"); + batFile = _lcreat(batFileName, 0); + + GetTempFileName(0, "tcl", 0, pifFileName); + unlink(pifFileName); + strcpy(strrchr(pifFileName, '.'), ".pif"); + pifFile = _lcreat(pifFileName, 0); + + _lwrite(batFile, command, strlen(command)); + if (fromFileName == NULL) { + _lwrite(batFile, " < nul", 6); + } else { + _lwrite(batFile, " < ", 3); + _lwrite(batFile, fromFileName, strlen(fromFileName)); + } + if (toFileName == NULL) { + _lwrite(batFile, " > nul", 6); + } else { + _lwrite(batFile, " > ", 3); + _lwrite(batFile, toFileName, strlen(toFileName)); + } + _lwrite(batFile, "\r\n\032", 3); + _lclose(batFile); + + strcpy(pifData + 0x1c8, batFileName); + _lwrite(pifFile, pifData, sizeof(pifData)); + _lclose(pifFile); + + result = WaitForExit(WinExec(pifFileName, SW_MINIMIZE)); + + unlink(pifFileName); + unlink(batFileName); + + return result; +} + +/* + *------------------------------------------------------------------------- + * + * WaitForExit -- + * + * Wait until the application with the given instance handle has + * finished. PeekMessage() is used to yield the processor; + * otherwise, nothing else could execute on the system. + * + * Results: + * The return value is 1 if the process exited successfully, + * or 0 otherwise. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +WaitForExit(inst) + int inst; /* Identifies the instance handle of the + * process to wait for. */ +{ + TASKENTRY te; + MSG msg; + UINT timer; + + if (inst < 32) { + return 0; + } + + te.dwSize = sizeof(te); + te.hInst = 0; + TaskFirst(&te); + do { + if (te.hInst == (HINSTANCE) inst) { + break; + } + } while (TaskNext(&te) != FALSE); + + if (te.hInst != (HINSTANCE) inst) { + return 0; + } + + timer = SetTimer(NULL, 0, 0, NULL); + while (1) { + if (GetMessage(&msg, NULL, 0, 0) != 0) { + TranslateMessage(&msg); + DispatchMessage(&msg); + } + TaskFirst(&te); + do { + if (te.hInst == (HINSTANCE) inst) { + break; + } + } while (TaskNext(&te) != FALSE); + + if (te.hInst != (HINSTANCE) inst) { + KillTimer(NULL, timer); + return 1; + } + } +} diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c new file mode 100644 index 0000000..3abc97e --- /dev/null +++ b/win/tclWin32Dll.c @@ -0,0 +1,362 @@ +/* + * tclWin32Dll.c -- + * + * This file contains the DLL entry point which sets up the 32-to-16-bit + * thunking code for SynchSpawn if the library is running under Win32s. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWin32Dll.c 1.21 97/08/05 11:47:10 + */ + +#include "tclWinInt.h" + +typedef DWORD (WINAPI * UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined, + LPVOID *lpTranslationList); + +typedef BOOL (WINAPI * PUTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL, + LPCSTR InitName, LPCSTR ProcName, UT32PROC* ThirtyTwoBitThunk, + FARPROC UT32Callback, LPVOID Buff); + +typedef VOID (WINAPI * PUTUNREGISTER)(HANDLE hModule); + +static PUTUNREGISTER UTUnRegister = NULL; +static int tclProcessesAttached = 0; + +/* + * The following data structure is used to keep track of all of the DLL's + * opened by Tcl so that they can be freed with the Tcl.dll is unloaded. + */ + +typedef struct LibraryList { + HINSTANCE handle; + struct LibraryList *nextPtr; +} LibraryList; + +static LibraryList *libraryList = NULL; /* List of currently loaded DLL's. */ + +static HINSTANCE tclInstance; /* Global library instance handle. */ +static int tclPlatformId; /* Running under NT, 95, or Win32s? */ + +/* + * Declarations for functions that are only used in this file. + */ + +static void UnloadLibraries _ANSI_ARGS_((void)); + +/* + * The following declaration is for the VC++ DLL entry point. + */ + +BOOL APIENTRY DllMain _ANSI_ARGS_((HINSTANCE hInst, + DWORD reason, LPVOID reserved)); + +/* + *---------------------------------------------------------------------- + * + * DllEntryPoint -- + * + * This wrapper function is used by Borland to invoke the + * initialization code for Tcl. It simply calls the DllMain + * routine. + * + * Results: + * See DllMain. + * + * Side effects: + * See DllMain. + * + *---------------------------------------------------------------------- + */ + +BOOL APIENTRY +DllEntryPoint(hInst, reason, reserved) + HINSTANCE hInst; /* Library instance handle. */ + DWORD reason; /* Reason this function is being called. */ + LPVOID reserved; /* Not used. */ +{ + return DllMain(hInst, reason, reserved); +} + +/* + *---------------------------------------------------------------------- + * + * DllMain -- + * + * This routine is called by the VC++ C run time library init + * code, or the DllEntryPoint routine. It is responsible for + * initializing various dynamically loaded libraries. + * + * Results: + * TRUE on sucess, FALSE on failure. + * + * Side effects: + * Establishes 32-to-16 bit thunk and initializes sockets library. + * + *---------------------------------------------------------------------- + */ +BOOL APIENTRY +DllMain(hInst, reason, reserved) + HINSTANCE hInst; /* Library instance handle. */ + DWORD reason; /* Reason this function is being called. */ + LPVOID reserved; /* Not used. */ +{ + OSVERSIONINFO os; + + switch (reason) { + case DLL_PROCESS_ATTACH: + + /* + * Registration of UT need to be done only once for first + * attaching process. At that time set the tclWin32s flag + * to indicate if the DLL is executing under Win32s or not. + */ + + if (tclProcessesAttached++) { + return FALSE; /* Not the first initialization. */ + } + + tclInstance = hInst; + os.dwOSVersionInfoSize = sizeof(os); + GetVersionEx(&os); + tclPlatformId = os.dwPlatformId; + + /* + * The following code stops Windows 3.x from automatically putting + * up Sharing Violation dialogs, e.g, when someone tries to + * access a file that is locked or a drive with no disk in it. + * Tcl already returns the appropriate error to the caller, and they + * can decide to put up their own dialog in response to that failure. + * + * Under 95 and NT, the system doesn't automatically put up dialogs + * when the above operations fail. + */ + + if (tclPlatformId == VER_PLATFORM_WIN32s) { + SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS); + } + + return TRUE; + + case DLL_PROCESS_DETACH: + + tclProcessesAttached--; + if (tclProcessesAttached == 0) { + + /* + * Unregister the Tcl thunk. + */ + + if (UTUnRegister != NULL) { + UTUnRegister(hInst); + } + + /* + * Cleanup any dynamically loaded libraries. + */ + + UnloadLibraries(); + + /* + * And finally finalize our use of Tcl. + */ + + Tcl_Finalize(); + } + break; + } + + return TRUE; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinLoadLibrary -- + * + * This function is a wrapper for the system LoadLibrary. It is + * responsible for adding library handles to the library list so + * the libraries can be freed when tcl.dll is unloaded. + * + * Results: + * Returns the handle of the newly loaded library, or NULL on + * failure. + * + * Side effects: + * Loads the specified library into the process. + * + *---------------------------------------------------------------------- + */ + +HINSTANCE +TclWinLoadLibrary(name) + char *name; /* Library file to load. */ +{ + HINSTANCE handle; + LibraryList *ptr; + + handle = LoadLibrary(name); + if (handle != NULL) { + ptr = (LibraryList*) ckalloc(sizeof(LibraryList)); + ptr->handle = handle; + ptr->nextPtr = libraryList; + libraryList = ptr; + } else { + TclWinConvertError(GetLastError()); + } + return handle; +} + +/* + *---------------------------------------------------------------------- + * + * UnloadLibraries -- + * + * Frees any dynamically allocated libraries loaded by Tcl. + * + * Results: + * None. + * + * Side effects: + * Frees the libraries on the library list as well as the list. + * + *---------------------------------------------------------------------- + */ + +static void +UnloadLibraries() +{ + LibraryList *ptr; + + while (libraryList != NULL) { + FreeLibrary(libraryList->handle); + ptr = libraryList->nextPtr; + ckfree((char*)libraryList); + libraryList = ptr; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclWinSynchSpawn -- + * + * 32-bit entry point to the 16-bit SynchSpawn code. + * + * Results: + * 1 on success, 0 on failure. + * + * Side effects: + * Spawns a command and waits for it to complete. + * + *---------------------------------------------------------------------- + */ +int +TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) +{ + static UT32PROC UTProc = NULL; + static int utErrorCode; + + if (UTUnRegister == NULL) { + /* + * Load the Universal Thunking routines from kernel32.dll. + */ + + HINSTANCE hKernel; + PUTREGISTER UTRegister; + char buffer[] = "TCL16xx.DLL"; + + hKernel = TclWinLoadLibrary("Kernel32.Dll"); + if (hKernel == NULL) { + return 0; + } + + UTRegister = (PUTREGISTER) GetProcAddress(hKernel, "UTRegister"); + UTUnRegister = (PUTUNREGISTER) GetProcAddress(hKernel, "UTUnRegister"); + if (!UTRegister || !UTUnRegister) { + UnloadLibraries(); + return 0; + } + + /* + * Construct the complete name of tcl16xx.dll. + */ + + buffer[5] = '0' + TCL_MAJOR_VERSION; + buffer[6] = '0' + TCL_MINOR_VERSION; + + /* + * Register the Tcl thunk. + */ + + if (UTRegister(tclInstance, buffer, NULL, "UTProc", &UTProc, NULL, + NULL) == FALSE) { + utErrorCode = GetLastError(); + } + } + + if (UTProc == NULL) { + /* + * The 16-bit thunking DLL wasn't found. Return error code that + * indicates this problem. + */ + + SetLastError(utErrorCode); + return 0; + } + + UTProc(args, type, trans); + *pidPtr = 0; + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinGetTclInstance -- + * + * Retrieves the global library instance handle. + * + * Results: + * Returns the global library instance handle. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +HINSTANCE +TclWinGetTclInstance() +{ + return tclInstance; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinGetPlatformId -- + * + * Determines whether running under NT, 95, or Win32s, to allow + * runtime conditional code. + * + * Results: + * The return value is one of: + * VER_PLATFORM_WIN32s Win32s on Windows 3.1. + * VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95. + * VER_PLATFORM_WIN32_NT Win32 on Windows NT + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclWinGetPlatformId() +{ + return tclPlatformId; +} diff --git a/win/tclWinChan.c b/win/tclWinChan.c new file mode 100644 index 0000000..248e14b --- /dev/null +++ b/win/tclWinChan.c @@ -0,0 +1,1185 @@ +/* + * tclWinChan.c + * + * Channel drivers for Windows channels based on files, command + * pipes and TCP sockets. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinChan.c 1.75 97/09/26 16:17:46 + */ + +#include "tclWinInt.h" + +/* + * This is the size of the channel name for File based channels + */ + +#define CHANNEL_NAME_SIZE 64 +static char channelName[CHANNEL_NAME_SIZE+1]; + +/* + * The following variable is used to tell whether this module has been + * initialized. + */ + +static int initialized = 0; + +/* + * State flags used in the info structures below. + */ + +#define FILE_PENDING (1<<0) /* Message is pending in the queue. */ +#define FILE_ASYNC (1<<1) /* Channel is non-blocking. */ +#define FILE_APPEND (1<<2) /* File is in append mode. */ + +/* + * The following structure contains per-instance data for a file based channel. + */ + +typedef struct FileInfo { + Tcl_Channel channel; /* Pointer to channel structure. */ + int validMask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION: indicates + * which operations are valid on the file. */ + int watchMask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION: indicates + * which events should be reported. */ + int flags; /* State flags, see above for a list. */ + HANDLE handle; /* Input/output file. */ + struct FileInfo *nextPtr; /* Pointer to next registered file. */ +} FileInfo; + +/* + * List of all file channels currently open. + */ + +static FileInfo *firstFilePtr; + +/* + * The following structure is what is added to the Tcl event queue when + * file events are generated. + */ + +typedef struct FileEvent { + Tcl_Event header; /* Information that is standard for + * all events. */ + FileInfo *infoPtr; /* Pointer to file info structure. Note + * that we still have to verify that the + * file exists before dereferencing this + * pointer. */ +} FileEvent; + +/* + * Static routines for this file: + */ + +static int ComGetOptionProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp, char *optionName, + Tcl_DString *dsPtr)); +static int ComInputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int ComSetOptionProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp, char *optionName, + char *value)); +static int FileBlockProc _ANSI_ARGS_((ClientData instanceData, + int mode)); +static void FileChannelExitHandler _ANSI_ARGS_(( + ClientData clientData)); +static void FileCheckProc _ANSI_ARGS_((ClientData clientData, + int flags)); +static int FileCloseProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static int FileEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); +static int FileGetHandleProc _ANSI_ARGS_((ClientData instanceData, + int direction, ClientData *handlePtr)); +static void FileInit _ANSI_ARGS_((void)); +static int FileInputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int FileOutputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toWrite, int *errorCode)); +static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, + long offset, int mode, int *errorCode)); +static void FileSetupProc _ANSI_ARGS_((ClientData clientData, + int flags)); +static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, + int mask)); + + +/* + * This structure describes the channel type structure for file based IO. + */ + +static Tcl_ChannelType fileChannelType = { + "file", /* Type name. */ + FileBlockProc, /* Set blocking or non-blocking mode.*/ + FileCloseProc, /* Close proc. */ + FileInputProc, /* Input proc. */ + FileOutputProc, /* Output proc. */ + FileSeekProc, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ + FileWatchProc, /* Set up the notifier to watch the channel. */ + FileGetHandleProc, /* Get an OS handle from channel. */ +}; + +static Tcl_ChannelType comChannelType = { + "com", /* Type name. */ + FileBlockProc, /* Set blocking or non-blocking mode.*/ + FileCloseProc, /* Close proc. */ + ComInputProc, /* Input proc. */ + FileOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + ComSetOptionProc, /* Set option proc. */ + ComGetOptionProc, /* Get option proc. */ + FileWatchProc, /* Set up notifier to watch the channel. */ + FileGetHandleProc /* Get an OS handle from channel. */ +}; + +/* + *---------------------------------------------------------------------- + * + * FileInit -- + * + * This function creates the window used to simulate file events. + * + * Results: + * None. + * + * Side effects: + * Creates a new window and creates an exit handler. + * + *---------------------------------------------------------------------- + */ + +static void +FileInit() +{ + initialized = 1; + firstFilePtr = NULL; + Tcl_CreateEventSource(FileSetupProc, FileCheckProc, NULL); + Tcl_CreateExitHandler(FileChannelExitHandler, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * FileChannelExitHandler -- + * + * This function is called to cleanup the channel driver before + * Tcl is unloaded. + * + * Results: + * None. + * + * Side effects: + * Destroys the communication window. + * + *---------------------------------------------------------------------- + */ + +static void +FileChannelExitHandler(clientData) + ClientData clientData; /* Old window proc */ +{ + Tcl_DeleteEventSource(FileSetupProc, FileCheckProc, NULL); + initialized = 0; +} + +/* + *---------------------------------------------------------------------- + * + * FileSetupProc -- + * + * This procedure is invoked before Tcl_DoOneEvent blocks waiting + * for an event. + * + * Results: + * None. + * + * Side effects: + * Adjusts the block time if needed. + * + *---------------------------------------------------------------------- + */ + +void +FileSetupProc(data, flags) + ClientData data; /* Not used. */ + int flags; /* Event flags as passed to Tcl_DoOneEvent. */ +{ + FileInfo *infoPtr; + Tcl_Time blockTime = { 0, 0 }; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + /* + * Check to see if there is a ready file. If so, poll. + */ + + for (infoPtr = firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (infoPtr->watchMask) { + Tcl_SetMaxBlockTime(&blockTime); + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FileCheckProc -- + * + * This procedure is called by Tcl_DoOneEvent to check the file + * event source for events. + * + * Results: + * None. + * + * Side effects: + * May queue an event. + * + *---------------------------------------------------------------------- + */ + +static void +FileCheckProc(data, flags) + ClientData data; /* Not used. */ + int flags; /* Event flags as passed to Tcl_DoOneEvent. */ +{ + FileEvent *evPtr; + FileInfo *infoPtr; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + /* + * Queue events for any ready files that don't already have events + * queued (caused by persistent states that won't generate WinSock + * events). + */ + + for (infoPtr = firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (infoPtr->watchMask && !(infoPtr->flags & FILE_PENDING)) { + infoPtr->flags |= FILE_PENDING; + evPtr = (FileEvent *) ckalloc(sizeof(FileEvent)); + evPtr->header.proc = FileEventProc; + evPtr->infoPtr = infoPtr; + Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); + } + } +} + +/*---------------------------------------------------------------------- + * + * FileEventProc -- + * + * This function is invoked by Tcl_ServiceEvent when a file event + * reaches the front of the event queue. This procedure invokes + * Tcl_NotifyChannel on the file. + * + * Results: + * Returns 1 if the event was handled, meaning it should be removed + * from the queue. Returns 0 if the event was not handled, meaning + * it should stay on the queue. The only time the event isn't + * handled is if the TCL_FILE_EVENTS flag bit isn't set. + * + * Side effects: + * Whatever the notifier callback does. + * + *---------------------------------------------------------------------- + */ + +static int +FileEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_FILE_EVENTS. */ +{ + FileEvent *fileEvPtr = (FileEvent *)evPtr; + FileInfo *infoPtr; + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } + + /* + * Search through the list of watched files for the one whose handle + * matches the event. We do this rather than simply dereferencing + * the handle in the event so that files can be deleted while the + * event is in the queue. + */ + + for (infoPtr = firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (fileEvPtr->infoPtr == infoPtr) { + infoPtr->flags &= ~(FILE_PENDING); + Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask); + break; + } + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * FileBlockProc -- + * + * Set blocking or non-blocking mode on channel. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + +static int +FileBlockProc(instanceData, mode) + ClientData instanceData; /* Instance data for channel. */ + int mode; /* TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + FileInfo *infoPtr = (FileInfo *) instanceData; + + /* + * Files on Windows can not be switched between blocking and nonblocking, + * hence we have to emulate the behavior. This is done in the input + * function by checking against a bit in the state. We set or unset the + * bit here to cause the input function to emulate the correct behavior. + */ + + if (mode == TCL_MODE_NONBLOCKING) { + infoPtr->flags |= FILE_ASYNC; + } else { + infoPtr->flags &= ~(FILE_ASYNC); + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * FileCloseProc -- + * + * Closes the IO channel. + * + * Results: + * 0 if successful, the value of errno if failed. + * + * Side effects: + * Closes the physical channel + * + *---------------------------------------------------------------------- + */ + +static int +FileCloseProc(instanceData, interp) + ClientData instanceData; /* Pointer to FileInfo structure. */ + Tcl_Interp *interp; /* Not used. */ +{ + FileInfo *fileInfoPtr = (FileInfo *) instanceData; + FileInfo **nextPtrPtr; + int errorCode = 0; + + /* + * Remove the file from the watch list. + */ + + FileWatchProc(instanceData, 0); + + if (CloseHandle(fileInfoPtr->handle) == FALSE) { + TclWinConvertError(GetLastError()); + errorCode = errno; + } + for (nextPtrPtr = &firstFilePtr; (*nextPtrPtr) != NULL; + nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { + if ((*nextPtrPtr) == fileInfoPtr) { + (*nextPtrPtr) = fileInfoPtr->nextPtr; + break; + } + } + ckfree((char *)fileInfoPtr); + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * FileSeekProc -- + * + * Seeks on a file-based channel. Returns the new position. + * + * Results: + * -1 if failed, the new position if successful. If failed, it + * also sets *errorCodePtr to the error code. + * + * Side effects: + * Moves the location at which the channel will be accessed in + * future operations. + * + *---------------------------------------------------------------------- + */ + +static int +FileSeekProc(instanceData, offset, mode, errorCodePtr) + ClientData instanceData; /* File state. */ + long offset; /* Offset to seek to. */ + int mode; /* Relative to where + * should we seek? */ + int *errorCodePtr; /* To store error code. */ +{ + FileInfo *infoPtr = (FileInfo *) instanceData; + DWORD moveMethod; + DWORD newPos; + + *errorCodePtr = 0; + if (mode == SEEK_SET) { + moveMethod = FILE_BEGIN; + } else if (mode == SEEK_CUR) { + moveMethod = FILE_CURRENT; + } else { + moveMethod = FILE_END; + } + + newPos = SetFilePointer(infoPtr->handle, offset, NULL, moveMethod); + if (newPos == 0xFFFFFFFF) { + TclWinConvertError(GetLastError()); + return -1; + } + return newPos; +} + +/* + *---------------------------------------------------------------------- + * + * FileInputProc -- + * + * Reads input from the IO channel into the buffer given. Returns + * count of how many bytes were actually read, and an error indication. + * + * Results: + * A count of how many bytes were read is returned and an error + * indication is returned in an output argument. + * + * Side effects: + * Reads input from the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +FileInputProc(instanceData, buf, bufSize, errorCode) + ClientData instanceData; /* File state. */ + char *buf; /* Where to store data read. */ + int bufSize; /* How much space is available + * in the buffer? */ + int *errorCode; /* Where to store error code. */ +{ + FileInfo *infoPtr; + DWORD bytesRead; + + *errorCode = 0; + infoPtr = (FileInfo *) instanceData; + + /* + * Note that we will block on reads from a console buffer until a + * full line has been entered. The only way I know of to get + * around this is to write a console driver. We should probably + * do this at some point, but for now, we just block. The same + * problem exists for files being read over the network. + */ + + if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead, + (LPOVERLAPPED) NULL) != FALSE) { + return bytesRead; + } + + TclWinConvertError(GetLastError()); + *errorCode = errno; + if (errno == EPIPE) { + return 0; + } + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * FileOutputProc -- + * + * Writes the given output on the IO channel. Returns count of how + * many characters were actually written, and an error indication. + * + * Results: + * A count of how many characters were written is returned and an + * error indication is returned in an output argument. + * + * Side effects: + * Writes output on the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +FileOutputProc(instanceData, buf, toWrite, errorCode) + ClientData instanceData; /* File state. */ + char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCode; /* Where to store error code. */ +{ + FileInfo *infoPtr = (FileInfo *) instanceData; + DWORD bytesWritten; + + *errorCode = 0; + + /* + * If we are writing to a file that was opened with O_APPEND, we need to + * seek to the end of the file before writing the current buffer. + */ + + if (infoPtr->flags & FILE_APPEND) { + SetFilePointer(infoPtr->handle, 0, NULL, FILE_END); + } + + if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite, &bytesWritten, + (LPOVERLAPPED) NULL) == FALSE) { + TclWinConvertError(GetLastError()); + *errorCode = errno; + return -1; + } + FlushFileBuffers(infoPtr->handle); + return bytesWritten; +} + +/* + *---------------------------------------------------------------------- + * + * FileWatchProc -- + * + * Called by the notifier to set up to watch for events on this + * channel. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +FileWatchProc(instanceData, mask) + ClientData instanceData; /* File state. */ + int mask; /* What events to watch for; OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + FileInfo *infoPtr = (FileInfo *) instanceData; + Tcl_Time blockTime = { 0, 0 }; + + /* + * Since the file is always ready for events, we set the block time + * to zero so we will poll. + */ + + infoPtr->watchMask = mask & infoPtr->validMask; + if (infoPtr->watchMask) { + Tcl_SetMaxBlockTime(&blockTime); + } +} + +/* + *---------------------------------------------------------------------- + * + * FileGetHandleProc -- + * + * Called from Tcl_GetChannelFile to retrieve OS handles from + * a file based channel. + * + * Results: + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if + * there is no handle for the specified direction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileGetHandleProc(instanceData, direction, handlePtr) + ClientData instanceData; /* The file state. */ + int direction; /* TCL_READABLE or TCL_WRITABLE */ + ClientData *handlePtr; /* Where to store the handle. */ +{ + FileInfo *infoPtr = (FileInfo *) instanceData; + + if (direction & infoPtr->validMask) { + *handlePtr = (ClientData) infoPtr->handle; + return TCL_OK; + } else { + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * ComInputProc -- + * + * Reads input from the IO channel into the buffer given. Returns + * count of how many bytes were actually read, and an error indication. + * + * Results: + * A count of how many bytes were read is returned and an error + * indication is returned in an output argument. + * + * Side effects: + * Reads input from the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +ComInputProc(instanceData, buf, bufSize, errorCode) + ClientData instanceData; /* File state. */ + char *buf; /* Where to store data read. */ + int bufSize; /* How much space is available + * in the buffer? */ + int *errorCode; /* Where to store error code. */ +{ + FileInfo *infoPtr; + DWORD bytesRead; + DWORD dw; + COMSTAT cs; + + *errorCode = 0; + infoPtr = (FileInfo *) instanceData; + + if (ClearCommError(infoPtr->handle, &dw, &cs)) { + if (dw != 0) { + *errorCode = EIO; + return -1; + } + if (cs.cbInQue != 0) { + if ((DWORD) bufSize > cs.cbInQue) { + bufSize = cs.cbInQue; + } + } else { + if (infoPtr->flags & FILE_ASYNC) { + errno = *errorCode = EAGAIN; + return -1; + } else { + bufSize = 1; + } + } + } + + if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead, + (LPOVERLAPPED) NULL) == FALSE) { + TclWinConvertError(GetLastError()); + *errorCode = errno; + return -1; + } + + return bytesRead; +} + +/* + *---------------------------------------------------------------------- + * + * ComSetOptionProc -- + * + * Sets an option on a channel. + * + * Results: + * A standard Tcl result. Also sets interp->result on error if + * interp is not NULL. + * + * Side effects: + * May modify an option on a device. + * + *---------------------------------------------------------------------- + */ + +static int +ComSetOptionProc(instanceData, interp, optionName, value) + ClientData instanceData; /* File state. */ + Tcl_Interp *interp; /* For error reporting - can be NULL. */ + char *optionName; /* Which option to set? */ + char *value; /* New value for option. */ +{ + FileInfo *infoPtr; + DCB dcb; + int len; + + infoPtr = (FileInfo *) instanceData; + + len = strlen(optionName); + if ((len > 1) && (strncmp(optionName, "-mode", len) == 0)) { + if (GetCommState(infoPtr->handle, &dcb)) { + if ((BuildCommDCB(value, &dcb) == FALSE) || + (SetCommState(infoPtr->handle, &dcb) == FALSE)) { + /* + * one should separate the 2 errors... + */ + if (interp) { + Tcl_AppendResult(interp, "bad value for -mode: should be ", + "baud,parity,data,stop", NULL); + } + return TCL_ERROR; + } else { + return TCL_OK; + } + } else { + if (interp) { + Tcl_AppendResult(interp, "can't get comm state", NULL); + } + return TCL_ERROR; + } + } else { + return Tcl_BadChannelOption(interp, optionName, "mode"); + } +} + +/* + *---------------------------------------------------------------------- + * + * ComGetOptionProc -- + * + * Gets a mode associated with an IO channel. If the optionName arg + * is non NULL, retrieves the value of that option. If the optionName + * arg is NULL, retrieves a list of alternating option names and + * values for the given channel. + * + * Results: + * A standard Tcl result. Also sets the supplied DString to the + * string value of the option(s) returned. + * + * Side effects: + * The string returned by this function is in static storage and + * may be reused at any time subsequent to the call. + * + *---------------------------------------------------------------------- + */ + +static int +ComGetOptionProc(instanceData, interp, optionName, dsPtr) + ClientData instanceData; /* File state. */ + Tcl_Interp *interp; /* For error reporting - can be NULL. */ + char *optionName; /* Option to get. */ + Tcl_DString *dsPtr; /* Where to store value(s). */ +{ + FileInfo *infoPtr; + DCB dcb; + int len; + + infoPtr = (FileInfo *) instanceData; + + if (optionName == NULL) { + Tcl_DStringAppendElement(dsPtr, "-mode"); + len = 0; + } else { + len = strlen(optionName); + } + if ((len == 0) || + ((len > 1) && (strncmp(optionName, "-mode", len) == 0))) { + if (GetCommState(infoPtr->handle, &dcb) == 0) { + /* + * shouldn't we flag an error instead ? + */ + Tcl_DStringAppendElement(dsPtr, ""); + } else { + char parity; + char *stop; + char buf[32]; + + parity = 'n'; + if (dcb.Parity < 4) { + parity = "noems"[dcb.Parity]; + } + + stop = (dcb.StopBits == ONESTOPBIT) ? "1" : + (dcb.StopBits == ONE5STOPBITS) ? "1.5" : "2"; + + wsprintf(buf, "%d,%c,%d,%s", dcb.BaudRate, parity, dcb.ByteSize, + stop); + Tcl_DStringAppendElement(dsPtr, buf); + } + return TCL_OK; + } else { + return Tcl_BadChannelOption(interp, optionName, "mode"); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenFileChannel -- + * + * Open an File based channel on Unix systems. + * + * Results: + * The new channel or NULL. If NULL, the output argument + * errorCodePtr is set to a POSIX error. + * + * Side effects: + * May open the channel and may cause creation of a file on the + * file system. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenFileChannel(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *fileName; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + FileInfo *infoPtr; + int seekFlag, mode, channelPermissions; + DWORD accessMode, createMode, shareMode, flags; + char *nativeName; + Tcl_DString buffer; + DCB dcb; + Tcl_ChannelType *channelTypePtr; + HANDLE handle; + + if (!initialized) { + FileInit(); + } + + mode = TclGetOpenMode(interp, modeString, &seekFlag); + if (mode == -1) { + return NULL; + } + + nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (nativeName == NULL) { + return NULL; + } + + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { + case O_RDONLY: + accessMode = GENERIC_READ; + channelPermissions = TCL_READABLE; + break; + case O_WRONLY: + accessMode = GENERIC_WRITE; + channelPermissions = TCL_WRITABLE; + break; + case O_RDWR: + accessMode = (GENERIC_READ | GENERIC_WRITE); + channelPermissions = (TCL_READABLE | TCL_WRITABLE); + break; + default: + panic("Tcl_OpenFileChannel: invalid mode value"); + break; + } + + /* + * Map the creation flags to the NT create mode. + */ + + switch (mode & (O_CREAT | O_EXCL | O_TRUNC)) { + case (O_CREAT | O_EXCL): + case (O_CREAT | O_EXCL | O_TRUNC): + createMode = CREATE_NEW; + break; + case (O_CREAT | O_TRUNC): + createMode = CREATE_ALWAYS; + break; + case O_CREAT: + createMode = OPEN_ALWAYS; + break; + case O_TRUNC: + case (O_TRUNC | O_EXCL): + createMode = TRUNCATE_EXISTING; + break; + default: + createMode = OPEN_EXISTING; + break; + } + + /* + * If the file is being created, get the file attributes from the + * permissions argument, else use the existing file attributes. + */ + + if (mode & O_CREAT) { + if (permissions & S_IWRITE) { + flags = FILE_ATTRIBUTE_NORMAL; + } else { + flags = FILE_ATTRIBUTE_READONLY; + } + } else { + flags = GetFileAttributes(nativeName); + if (flags == 0xFFFFFFFF) { + flags = 0; + } + } + + /* + * Set up the file sharing mode. We want to allow simultaneous access. + */ + + shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE; + + /* + * Now we get to create the file. + */ + + handle = CreateFile(nativeName, accessMode, shareMode, NULL, createMode, + flags, (HANDLE) NULL); + + if (handle == INVALID_HANDLE_VALUE) { + DWORD err; + + openerr: + err = GetLastError(); + if ((err & 0xffffL) == ERROR_OPEN_FAILED) { + err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND; + } + TclWinConvertError(err); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + } + Tcl_DStringFree(&buffer); + return NULL; + } + + if (GetFileType(handle) == FILE_TYPE_CHAR) { + dcb.DCBlength = sizeof( DCB ) ; + if (GetCommState(handle, &dcb)) { + /* + * This is a com port. Reopen it with the correct modes. + */ + + COMMTIMEOUTS cto; + + CloseHandle(handle); + handle = CreateFile(nativeName, accessMode, 0, NULL, OPEN_EXISTING, + flags, NULL); + if (handle == INVALID_HANDLE_VALUE) { + goto openerr; + } + + /* + * FileInit the com port. + */ + + SetCommMask(handle, EV_RXCHAR); + SetupComm(handle, 4096, 4096); + PurgeComm(handle, PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR + | PURGE_RXCLEAR); + cto.ReadIntervalTimeout = MAXDWORD; + cto.ReadTotalTimeoutMultiplier = 0; + cto.ReadTotalTimeoutConstant = 0; + cto.WriteTotalTimeoutMultiplier = 0; + cto.WriteTotalTimeoutConstant = 0; + SetCommTimeouts(handle, &cto); + + GetCommState(handle, &dcb); + SetCommState(handle, &dcb); + channelTypePtr = &comChannelType; + } else { + channelTypePtr = &fileChannelType; + } + } else { + channelTypePtr = &fileChannelType; + } + Tcl_DStringFree(&buffer); + + infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo)); + infoPtr->nextPtr = firstFilePtr; + firstFilePtr = infoPtr; + infoPtr->validMask = channelPermissions; + infoPtr->watchMask = 0; + infoPtr->flags = (mode & O_APPEND) ? FILE_APPEND : 0; + infoPtr->handle = handle; + + sprintf(channelName, "file%d", (int) handle); + + infoPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName, + (ClientData) infoPtr, channelPermissions); + + if (seekFlag) { + if (Tcl_Seek(infoPtr->channel, 0, SEEK_END) < 0) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "could not seek to end of file on \"", + channelName, "\": ", Tcl_PosixError(interp), + (char *) NULL); + } + Tcl_Close(NULL, infoPtr->channel); + return NULL; + } + } + + /* + * Files have default translation of AUTO and ^Z eof char, which + * means that a ^Z will be appended to them at close. + */ + + Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); + Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); + return infoPtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeFileChannel -- + * + * Creates a Tcl_Channel from an existing platform specific file + * handle. + * + * Results: + * The Tcl_Channel created around the preexisting file. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_MakeFileChannel(handle, mode) + ClientData handle; /* OS level handle */ + int mode; /* ORed combination of TCL_READABLE and + * TCL_WRITABLE to indicate file mode. */ +{ + char channelName[20]; + FileInfo *infoPtr; + + if (!initialized) { + FileInit(); + } + + if (mode == 0) { + return NULL; + } + + sprintf(channelName, "file%d", (int) handle); + + /* + * See if a channel with this handle already exists. + */ + + for (infoPtr = firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (infoPtr->handle == (HANDLE) handle) { + return (mode == infoPtr->validMask) ? infoPtr->channel : NULL; + } + } + + infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo)); + infoPtr->nextPtr = firstFilePtr; + firstFilePtr = infoPtr; + infoPtr->validMask = mode; + infoPtr->watchMask = 0; + infoPtr->flags = 0; + infoPtr->handle = (HANDLE) handle; + infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName, + (ClientData) infoPtr, mode); + + /* + * Windows files have AUTO translation mode and ^Z eof char on input. + */ + + Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); + Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); + return infoPtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetDefaultStdChannel -- + * + * Constructs a channel for the specified standard OS handle. + * + * Results: + * Returns the specified default standard channel, or NULL. + * + * Side effects: + * May cause the creation of a standard channel and the underlying + * file. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclGetDefaultStdChannel(type) + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ +{ + Tcl_Channel channel; + HANDLE handle; + int mode; + char *bufMode; + DWORD handleId; /* Standard handle to retrieve. */ + + switch (type) { + case TCL_STDIN: + handleId = STD_INPUT_HANDLE; + mode = TCL_READABLE; + bufMode = "line"; + break; + case TCL_STDOUT: + handleId = STD_OUTPUT_HANDLE; + mode = TCL_WRITABLE; + bufMode = "line"; + break; + case TCL_STDERR: + handleId = STD_ERROR_HANDLE; + mode = TCL_WRITABLE; + bufMode = "none"; + break; + default: + panic("TclGetDefaultStdChannel: Unexpected channel type"); + break; + } + handle = GetStdHandle(handleId); + + /* + * Note that we need to check for 0 because Windows will return 0 if this + * is not a console mode application, even though this is not a valid + * handle. + */ + + if ((handle == INVALID_HANDLE_VALUE) || (handle == 0)) { + return NULL; + } + + channel = Tcl_MakeFileChannel(handle, mode); + + /* + * Set up the normal channel options for stdio handles. + */ + + if ((Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, "-translation", + "auto") == TCL_ERROR) + || (Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, "-eofchar", + "\032 {}") == TCL_ERROR) + || (Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, + "-buffering", bufMode) == TCL_ERROR)) { + Tcl_Close((Tcl_Interp *) NULL, channel); + return (Tcl_Channel) NULL; + } + return channel; +} diff --git a/win/tclWinError.c b/win/tclWinError.c new file mode 100644 index 0000000..5361174 --- /dev/null +++ b/win/tclWinError.c @@ -0,0 +1,393 @@ +/* + * tclWinError.c -- + * + * This file contains code for converting from Win32 errors to + * errno errors. + * + * Copyright (c) 1995-1996 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: @(#) tclWinError.c 1.7 97/10/28 17:30:33 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following table contains the mapping from Win32 errors to + * errno errors. + */ + +static char errorTable[] = { + 0, + EINVAL, /* ERROR_INVALID_FUNCTION 1 */ + ENOENT, /* ERROR_FILE_NOT_FOUND 2 */ + ENOENT, /* ERROR_PATH_NOT_FOUND 3 */ + EMFILE, /* ERROR_TOO_MANY_OPEN_FILES 4 */ + EACCES, /* ERROR_ACCESS_DENIED 5 */ + EBADF, /* ERROR_INVALID_HANDLE 6 */ + ENOMEM, /* ERROR_ARENA_TRASHED 7 */ + ENOMEM, /* ERROR_NOT_ENOUGH_MEMORY 8 */ + ENOMEM, /* ERROR_INVALID_BLOCK 9 */ + E2BIG, /* ERROR_BAD_ENVIRONMENT 10 */ + ENOEXEC, /* ERROR_BAD_FORMAT 11 */ + EACCES, /* ERROR_INVALID_ACCESS 12 */ + EINVAL, /* ERROR_INVALID_DATA 13 */ + EFAULT, /* ERROR_OUT_OF_MEMORY 14 */ + ENOENT, /* ERROR_INVALID_DRIVE 15 */ + EACCES, /* ERROR_CURRENT_DIRECTORY 16 */ + EXDEV, /* ERROR_NOT_SAME_DEVICE 17 */ + ENOENT, /* ERROR_NO_MORE_FILES 18 */ + EROFS, /* ERROR_WRITE_PROTECT 19 */ + ENXIO, /* ERROR_BAD_UNIT 20 */ + EBUSY, /* ERROR_NOT_READY 21 */ + EIO, /* ERROR_BAD_COMMAND 22 */ + EIO, /* ERROR_CRC 23 */ + EIO, /* ERROR_BAD_LENGTH 24 */ + EIO, /* ERROR_SEEK 25 */ + EIO, /* ERROR_NOT_DOS_DISK 26 */ + ENXIO, /* ERROR_SECTOR_NOT_FOUND 27 */ + EBUSY, /* ERROR_OUT_OF_PAPER 28 */ + EIO, /* ERROR_WRITE_FAULT 29 */ + EIO, /* ERROR_READ_FAULT 30 */ + EIO, /* ERROR_GEN_FAILURE 31 */ + EACCES, /* ERROR_SHARING_VIOLATION 32 */ + EACCES, /* ERROR_LOCK_VIOLATION 33 */ + ENXIO, /* ERROR_WRONG_DISK 34 */ + ENFILE, /* ERROR_FCB_UNAVAILABLE 35 */ + ENFILE, /* ERROR_SHARING_BUFFER_EXCEEDED 36 */ + EINVAL, /* 37 */ + EINVAL, /* 38 */ + ENOSPC, /* ERROR_HANDLE_DISK_FULL 39 */ + EINVAL, /* 40 */ + EINVAL, /* 41 */ + EINVAL, /* 42 */ + EINVAL, /* 43 */ + EINVAL, /* 44 */ + EINVAL, /* 45 */ + EINVAL, /* 46 */ + EINVAL, /* 47 */ + EINVAL, /* 48 */ + EINVAL, /* 49 */ + ENODEV, /* ERROR_NOT_SUPPORTED 50 */ + EBUSY, /* ERROR_REM_NOT_LIST 51 */ + EEXIST, /* ERROR_DUP_NAME 52 */ + ENOENT, /* ERROR_BAD_NETPATH 53 */ + EBUSY, /* ERROR_NETWORK_BUSY 54 */ + ENODEV, /* ERROR_DEV_NOT_EXIST 55 */ + EAGAIN, /* ERROR_TOO_MANY_CMDS 56 */ + EIO, /* ERROR_ADAP_HDW_ERR 57 */ + EIO, /* ERROR_BAD_NET_RESP 58 */ + EIO, /* ERROR_UNEXP_NET_ERR 59 */ + EINVAL, /* ERROR_BAD_REM_ADAP 60 */ + EFBIG, /* ERROR_PRINTQ_FULL 61 */ + ENOSPC, /* ERROR_NO_SPOOL_SPACE 62 */ + ENOENT, /* ERROR_PRINT_CANCELLED 63 */ + ENOENT, /* ERROR_NETNAME_DELETED 64 */ + EACCES, /* ERROR_NETWORK_ACCESS_DENIED 65 */ + ENODEV, /* ERROR_BAD_DEV_TYPE 66 */ + ENOENT, /* ERROR_BAD_NET_NAME 67 */ + ENFILE, /* ERROR_TOO_MANY_NAMES 68 */ + EIO, /* ERROR_TOO_MANY_SESS 69 */ + EAGAIN, /* ERROR_SHARING_PAUSED 70 */ + EINVAL, /* ERROR_REQ_NOT_ACCEP 71 */ + EAGAIN, /* ERROR_REDIR_PAUSED 72 */ + EINVAL, /* 73 */ + EINVAL, /* 74 */ + EINVAL, /* 75 */ + EINVAL, /* 76 */ + EINVAL, /* 77 */ + EINVAL, /* 78 */ + EINVAL, /* 79 */ + EEXIST, /* ERROR_FILE_EXISTS 80 */ + EINVAL, /* 81 */ + ENOSPC, /* ERROR_CANNOT_MAKE 82 */ + EIO, /* ERROR_FAIL_I24 83 */ + ENFILE, /* ERROR_OUT_OF_STRUCTURES 84 */ + EEXIST, /* ERROR_ALREADY_ASSIGNED 85 */ + EPERM, /* ERROR_INVALID_PASSWORD 86 */ + EINVAL, /* ERROR_INVALID_PARAMETER 87 */ + EIO, /* ERROR_NET_WRITE_FAULT 88 */ + EAGAIN, /* ERROR_NO_PROC_SLOTS 89 */ + EINVAL, /* 90 */ + EINVAL, /* 91 */ + EINVAL, /* 92 */ + EINVAL, /* 93 */ + EINVAL, /* 94 */ + EINVAL, /* 95 */ + EINVAL, /* 96 */ + EINVAL, /* 97 */ + EINVAL, /* 98 */ + EINVAL, /* 99 */ + EINVAL, /* 100 */ + EINVAL, /* 101 */ + EINVAL, /* 102 */ + EINVAL, /* 103 */ + EINVAL, /* 104 */ + EINVAL, /* 105 */ + EINVAL, /* 106 */ + EXDEV, /* ERROR_DISK_CHANGE 107 */ + EAGAIN, /* ERROR_DRIVE_LOCKED 108 */ + EPIPE, /* ERROR_BROKEN_PIPE 109 */ + ENOENT, /* ERROR_OPEN_FAILED 110 */ + EINVAL, /* ERROR_BUFFER_OVERFLOW 111 */ + ENOSPC, /* ERROR_DISK_FULL 112 */ + EMFILE, /* ERROR_NO_MORE_SEARCH_HANDLES 113 */ + EBADF, /* ERROR_INVALID_TARGET_HANDLE 114 */ + EFAULT, /* ERROR_PROTECTION_VIOLATION 115 */ + EINVAL, /* 116 */ + EINVAL, /* 117 */ + EINVAL, /* 118 */ + EINVAL, /* 119 */ + EINVAL, /* 120 */ + EINVAL, /* 121 */ + EINVAL, /* 122 */ + ENOENT, /* ERROR_INVALID_NAME 123 */ + EINVAL, /* 124 */ + EINVAL, /* 125 */ + EINVAL, /* 126 */ + ESRCH, /* ERROR_PROC_NOT_FOUND 127 */ + ECHILD, /* ERROR_WAIT_NO_CHILDREN 128 */ + ECHILD, /* ERROR_CHILD_NOT_COMPLETE 129 */ + EBADF, /* ERROR_DIRECT_ACCESS_HANDLE 130 */ + EINVAL, /* 131 */ + ESPIPE, /* ERROR_SEEK_ON_DEVICE 132 */ + EINVAL, /* 133 */ + EINVAL, /* 134 */ + EINVAL, /* 135 */ + EINVAL, /* 136 */ + EINVAL, /* 137 */ + EINVAL, /* 138 */ + EINVAL, /* 139 */ + EINVAL, /* 140 */ + EINVAL, /* 141 */ + EAGAIN, /* ERROR_BUSY_DRIVE 142 */ + EINVAL, /* 143 */ + EINVAL, /* 144 */ + EEXIST, /* ERROR_DIR_NOT_EMPTY 145 */ + EINVAL, /* 146 */ + EINVAL, /* 147 */ + EINVAL, /* 148 */ + EINVAL, /* 149 */ + EINVAL, /* 150 */ + EINVAL, /* 151 */ + EINVAL, /* 152 */ + EINVAL, /* 153 */ + EINVAL, /* 154 */ + EINVAL, /* 155 */ + EINVAL, /* 156 */ + EINVAL, /* 157 */ + EACCES, /* ERROR_NOT_LOCKED 158 */ + EINVAL, /* 159 */ + EINVAL, /* 160 */ + ENOENT, /* ERROR_BAD_PATHNAME 161 */ + EINVAL, /* 162 */ + EINVAL, /* 163 */ + EINVAL, /* 164 */ + EINVAL, /* 165 */ + EINVAL, /* 166 */ + EACCES, /* ERROR_LOCK_FAILED 167 */ + EINVAL, /* 168 */ + EINVAL, /* 169 */ + EINVAL, /* 170 */ + EINVAL, /* 171 */ + EINVAL, /* 172 */ + EINVAL, /* 173 */ + EINVAL, /* 174 */ + EINVAL, /* 175 */ + EINVAL, /* 176 */ + EINVAL, /* 177 */ + EINVAL, /* 178 */ + EINVAL, /* 179 */ + EINVAL, /* 180 */ + EINVAL, /* 181 */ + EINVAL, /* 182 */ + EEXIST, /* ERROR_ALREADY_EXISTS 183 */ + ECHILD, /* ERROR_NO_CHILD_PROCESS 184 */ + EINVAL, /* 185 */ + EINVAL, /* 186 */ + EINVAL, /* 187 */ + EINVAL, /* 188 */ + EINVAL, /* 189 */ + EINVAL, /* 190 */ + EINVAL, /* 191 */ + EINVAL, /* 192 */ + EINVAL, /* 193 */ + EINVAL, /* 194 */ + EINVAL, /* 195 */ + EINVAL, /* 196 */ + EINVAL, /* 197 */ + EINVAL, /* 198 */ + EINVAL, /* 199 */ + EINVAL, /* 200 */ + EINVAL, /* 201 */ + EINVAL, /* 202 */ + EINVAL, /* 203 */ + EINVAL, /* 204 */ + EINVAL, /* 205 */ + ENAMETOOLONG,/* ERROR_FILENAME_EXCED_RANGE 206 */ + EINVAL, /* 207 */ + EINVAL, /* 208 */ + EINVAL, /* 209 */ + EINVAL, /* 210 */ + EINVAL, /* 211 */ + EINVAL, /* 212 */ + EINVAL, /* 213 */ + EINVAL, /* 214 */ + EINVAL, /* 215 */ + EINVAL, /* 216 */ + EINVAL, /* 217 */ + EINVAL, /* 218 */ + EINVAL, /* 219 */ + EINVAL, /* 220 */ + EINVAL, /* 221 */ + EINVAL, /* 222 */ + EINVAL, /* 223 */ + EINVAL, /* 224 */ + EINVAL, /* 225 */ + EINVAL, /* 226 */ + EINVAL, /* 227 */ + EINVAL, /* 228 */ + EINVAL, /* 229 */ + EPIPE, /* ERROR_BAD_PIPE 230 */ + EAGAIN, /* ERROR_PIPE_BUSY 231 */ + EPIPE, /* ERROR_NO_DATA 232 */ + EPIPE, /* ERROR_PIPE_NOT_CONNECTED 233 */ + EINVAL, /* 234 */ + EINVAL, /* 235 */ + EINVAL, /* 236 */ + EINVAL, /* 237 */ + EINVAL, /* 238 */ + EINVAL, /* 239 */ + EINVAL, /* 240 */ + EINVAL, /* 241 */ + EINVAL, /* 242 */ + EINVAL, /* 243 */ + EINVAL, /* 244 */ + EINVAL, /* 245 */ + EINVAL, /* 246 */ + EINVAL, /* 247 */ + EINVAL, /* 248 */ + EINVAL, /* 249 */ + EINVAL, /* 250 */ + EINVAL, /* 251 */ + EINVAL, /* 252 */ + EINVAL, /* 253 */ + EINVAL, /* 254 */ + EINVAL, /* 255 */ + EINVAL, /* 256 */ + EINVAL, /* 257 */ + EINVAL, /* 258 */ + EINVAL, /* 259 */ + EINVAL, /* 260 */ + EINVAL, /* 261 */ + EINVAL, /* 262 */ + EINVAL, /* 263 */ + EINVAL, /* 264 */ + EINVAL, /* 265 */ + EINVAL, /* 266 */ + ENOTDIR, /* ERROR_DIRECTORY 267 */ +}; + +static const unsigned int tableLen = sizeof(errorTable); + +/* + * The following table contains the mapping from WinSock errors to + * errno errors. + */ + +static int wsaErrorTable[] = { + EWOULDBLOCK, /* WSAEWOULDBLOCK */ + EINPROGRESS, /* WSAEINPROGRESS */ + EALREADY, /* WSAEALREADY */ + ENOTSOCK, /* WSAENOTSOCK */ + EDESTADDRREQ, /* WSAEDESTADDRREQ */ + EMSGSIZE, /* WSAEMSGSIZE */ + EPROTOTYPE, /* WSAEPROTOTYPE */ + ENOPROTOOPT, /* WSAENOPROTOOPT */ + EPROTONOSUPPORT, /* WSAEPROTONOSUPPORT */ + ESOCKTNOSUPPORT, /* WSAESOCKTNOSUPPORT */ + EOPNOTSUPP, /* WSAEOPNOTSUPP */ + EPFNOSUPPORT, /* WSAEPFNOSUPPORT */ + EAFNOSUPPORT, /* WSAEAFNOSUPPORT */ + EADDRINUSE, /* WSAEADDRINUSE */ + EADDRNOTAVAIL, /* WSAEADDRNOTAVAIL */ + ENETDOWN, /* WSAENETDOWN */ + ENETUNREACH, /* WSAENETUNREACH */ + ENETRESET, /* WSAENETRESET */ + ECONNABORTED, /* WSAECONNABORTED */ + ECONNRESET, /* WSAECONNRESET */ + ENOBUFS, /* WSAENOBUFS */ + EISCONN, /* WSAEISCONN */ + ENOTCONN, /* WSAENOTCONN */ + ESHUTDOWN, /* WSAESHUTDOWN */ + ETOOMANYREFS, /* WSAETOOMANYREFS */ + ETIMEDOUT, /* WSAETIMEDOUT */ + ECONNREFUSED, /* WSAECONNREFUSED */ + ELOOP, /* WSAELOOP */ + ENAMETOOLONG, /* WSAENAMETOOLONG */ + EHOSTDOWN, /* WSAEHOSTDOWN */ + EHOSTUNREACH, /* WSAEHOSTUNREACH */ + ENOTEMPTY, /* WSAENOTEMPTY */ + EAGAIN, /* WSAEPROCLIM */ + EUSERS, /* WSAEUSERS */ + EDQUOT, /* WSAEDQUOT */ + ESTALE, /* WSAESTALE */ + EREMOTE, /* WSAEREMOTE */ +}; + +/* + *---------------------------------------------------------------------- + * + * TclWinConvertError -- + * + * This routine converts a Win32 error into an errno value. + * + * Results: + * None. + * + * Side effects: + * Sets the errno global variable. + * + *---------------------------------------------------------------------- + */ + +void +TclWinConvertError(errCode) + DWORD errCode; /* Win32 error code. */ +{ + if (errCode >= tableLen) { + Tcl_SetErrno(EINVAL); + } else { + Tcl_SetErrno(errorTable[errCode]); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclWinConvertWSAError -- + * + * This routine converts a WinSock error into an errno value. + * + * Results: + * None. + * + * Side effects: + * Sets the errno global variable. + * + *---------------------------------------------------------------------- + */ + +void +TclWinConvertWSAError(errCode) + DWORD errCode; /* Win32 error code. */ +{ + if ((errCode >= WSAEWOULDBLOCK) && (errCode <= WSAEREMOTE)) { + Tcl_SetErrno(wsaErrorTable[errCode - WSAEWOULDBLOCK]); + } else { + Tcl_SetErrno(EINVAL); + } +} diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c new file mode 100644 index 0000000..f2df779 --- /dev/null +++ b/win/tclWinFCmd.c @@ -0,0 +1,1401 @@ +/* + * tclWinFCmd.c + * + * This file implements the Windows specific portion of file manipulation + * subcommands of the "file" command. + * + * 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: @(#) tclWinFCmd.c 1.20 97/10/10 11:50:14 + */ + +#include "tclWinInt.h" + +/* + * The following constants specify the type of callback when + * TraverseWinTree() calls the traverseProc() + */ + +#define DOTREE_PRED 1 /* pre-order directory */ +#define DOTREE_POSTD 2 /* post-order directory */ +#define DOTREE_F 3 /* regular file */ + +/* + * Callbacks for file attributes code. + */ + +static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, + Tcl_Obj **attributePtrPtr)); +static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, + Tcl_Obj **attributePtrPtr)); +static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, + Tcl_Obj **attributePtrPtr)); +static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, + Tcl_Obj *attributePtr)); +static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, + Tcl_Obj *attributePtr)); + +/* + * Constants and variables necessary for file attributes subcommand. + */ + +enum { + WIN_ARCHIVE_ATTRIBUTE, + WIN_HIDDEN_ATTRIBUTE, + WIN_LONGNAME_ATTRIBUTE, + WIN_READONLY_ATTRIBUTE, + WIN_SHORTNAME_ATTRIBUTE, + WIN_SYSTEM_ATTRIBUTE +}; + +static int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN, + 0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM}; + + +char *tclpFileAttrStrings[] = {"-archive", "-hidden", "-longname", "-readonly", + "-shortname", "-system", (char *) NULL}; +CONST TclFileAttrProcs tclpFileAttrProcs[] = { + {GetWinFileAttributes, SetWinFileAttributes}, + {GetWinFileAttributes, SetWinFileAttributes}, + {GetWinFileLongName, CannotSetAttribute}, + {GetWinFileAttributes, SetWinFileAttributes}, + {GetWinFileShortName, CannotSetAttribute}, + {GetWinFileAttributes, SetWinFileAttributes}}; + +/* + * Prototype for the TraverseWinTree callback function. + */ + +typedef int (TraversalProc)(char *src, char *dst, DWORD attr, int type, + Tcl_DString *errorPtr); + +/* + * Declarations for local procedures defined in this file: + */ + +static void AttributesPosixError _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, int getOrSet)); +static int ConvertFileNameFormat _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, int longShort, + Tcl_Obj **attributePtrPtr)); +static int TraversalCopy(char *src, char *dst, DWORD attr, + int type, Tcl_DString *errorPtr); +static int TraversalDelete(char *src, char *dst, DWORD attr, + int type, Tcl_DString *errorPtr); +static int TraverseWinTree(TraversalProc *traverseProc, + Tcl_DString *sourcePtr, Tcl_DString *destPtr, + Tcl_DString *errorPtr); + + +/* + *--------------------------------------------------------------------------- + * + * TclpRenameFile -- + * + * Changes the name of an existing file or directory, from src to dst. + * If src and dst refer to the same file or directory, does nothing + * and returns success. Otherwise if dst already exists, it will be + * deleted and replaced by src subject to the following conditions: + * If src is a directory, dst may be an empty directory. + * If src is a file, dst may be a file. + * In any other situation where dst already exists, the rename will + * fail. + * + * Results: + * If the directory was successfully created, returns TCL_OK. + * Otherwise the return value is TCL_ERROR and errno is set to + * indicate the error. Some possible values for errno are: + * + * EACCES: src or dst parent directory can't be read and/or written. + * EEXIST: dst is a non-empty directory. + * EINVAL: src is a root directory or dst is a subdirectory of src. + * EISDIR: dst is a directory, but src is not. + * ENOENT: src doesn't exist. src or dst is "". + * ENOTDIR: src is a directory, but dst is not. + * EXDEV: src and dst are on different filesystems. + * + * EACCES: exists an open file already referring to src or dst. + * EACCES: src or dst specify the current working directory (NT). + * EACCES: src specifies a char device (nul:, com1:, etc.) + * EEXIST: dst specifies a char device (nul:, com1:, etc.) (NT) + * EACCES: dst specifies a char device (nul:, com1:, etc.) (95) + * + * Side effects: + * The implementation supports cross-filesystem renames of files, + * but the caller should be prepared to emulate cross-filesystem + * renames of directories if errno is EXDEV. + * + *--------------------------------------------------------------------------- + */ + +int +TclpRenameFile( + char *src, /* Pathname of file or dir to be renamed. */ + char *dst) /* New pathname for file or directory. */ +{ + DWORD srcAttr, dstAttr; + + /* + * Would throw an exception under NT if one of the arguments is a + * char block device. + */ + + try { + if (MoveFile(src, dst) != FALSE) { + return TCL_OK; + } + } except (-1) {} + + TclWinConvertError(GetLastError()); + + srcAttr = GetFileAttributes(src); + dstAttr = GetFileAttributes(dst); + if (srcAttr == (DWORD) -1) { + srcAttr = 0; + } + if (dstAttr == (DWORD) -1) { + dstAttr = 0; + } + + if (errno == EBADF) { + errno = EACCES; + return TCL_ERROR; + } + if ((errno == EACCES) && (TclWinGetPlatformId() == VER_PLATFORM_WIN32s)) { + if ((srcAttr != 0) && (dstAttr != 0)) { + /* + * Win32s reports trying to overwrite an existing file or directory + * as EACCES. + */ + + errno = EEXIST; + } + } + if (errno == EACCES) { + decode: + if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { + char srcPath[MAX_PATH], dstPath[MAX_PATH]; + int srcArgc, dstArgc; + char **srcArgv, **dstArgv; + char *srcRest, *dstRest; + int size; + + size = GetFullPathName(src, sizeof(srcPath), srcPath, &srcRest); + if ((size == 0) || (size > sizeof(srcPath))) { + return TCL_ERROR; + } + size = GetFullPathName(dst, sizeof(dstPath), dstPath, &dstRest); + if ((size == 0) || (size > sizeof(dstPath))) { + return TCL_ERROR; + } + if (srcRest == NULL) { + srcRest = srcPath + strlen(srcPath); + } + if (strnicmp(srcPath, dstPath, srcRest - srcPath) == 0) { + /* + * Trying to move a directory into itself. + */ + + errno = EINVAL; + return TCL_ERROR; + } + Tcl_SplitPath(srcPath, &srcArgc, &srcArgv); + Tcl_SplitPath(dstPath, &dstArgc, &dstArgv); + if (srcArgc == 1) { + /* + * They are trying to move a root directory. Whether + * or not it is across filesystems, this cannot be + * done. + */ + + errno = EINVAL; + } else if ((srcArgc > 0) && (dstArgc > 0) && + (stricmp(srcArgv[0], dstArgv[0]) != 0)) { + /* + * If src is a directory and dst filesystem != src + * filesystem, errno should be EXDEV. It is very + * important to get this behavior, so that the caller + * can respond to a cross filesystem rename by + * simulating it with copy and delete. The MoveFile + * system call already handles the case of moving a + * file between filesystems. + */ + + errno = EXDEV; + } + + ckfree((char *) srcArgv); + ckfree((char *) dstArgv); + } + + /* + * Other types of access failure is that dst is a read-only + * filesystem, that an open file referred to src or dest, or that + * src or dest specified the current working directory on the + * current filesystem. EACCES is returned for those cases. + */ + + } else if (errno == EEXIST) { + /* + * Reports EEXIST any time the target already exists. If it makes + * sense, remove the old file and try renaming again. + */ + + if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { + if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { + /* + * Overwrite empty dst directory with src directory. The + * following call will remove an empty directory. If it + * fails, it's because it wasn't empty. + */ + + if (TclpRemoveDirectory(dst, 0, NULL) == TCL_OK) { + /* + * Now that that empty directory is gone, we can try + * renaming again. If that fails, we'll put this empty + * directory back, for completeness. + */ + + if (MoveFile(src, dst) != FALSE) { + return TCL_OK; + } + + /* + * Some new error has occurred. Don't know what it + * could be, but report this one. + */ + + TclWinConvertError(GetLastError()); + CreateDirectory(dst, NULL); + SetFileAttributes(dst, dstAttr); + if (errno == EACCES) { + /* + * Decode the EACCES to a more meaningful error. + */ + + goto decode; + } + } + } else { /* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ + errno = ENOTDIR; + } + } else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ + if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { + errno = EISDIR; + } else { + /* + * Overwrite existing file by: + * + * 1. Rename existing file to temp name. + * 2. Rename old file to new name. + * 3. If success, delete temp file. If failure, + * put temp file back to old name. + */ + + char tempName[MAX_PATH]; + int result, size; + char *rest; + + size = GetFullPathName(dst, sizeof(tempName), tempName, &rest); + if ((size == 0) || (size > sizeof(tempName)) || (rest == NULL)) { + return TCL_ERROR; + } + *rest = '\0'; + result = TCL_ERROR; + if (GetTempFileName(tempName, "tclr", 0, tempName) != 0) { + /* + * Strictly speaking, need the following DeleteFile and + * MoveFile to be joined as an atomic operation so no + * other app comes along in the meantime and creates the + * same temp file. + */ + + DeleteFile(tempName); + if (MoveFile(dst, tempName) != FALSE) { + if (MoveFile(src, dst) != FALSE) { + SetFileAttributes(tempName, FILE_ATTRIBUTE_NORMAL); + DeleteFile(tempName); + return TCL_OK; + } else { + DeleteFile(dst); + MoveFile(tempName, dst); + } + } + + /* + * Can't backup dst file or move src file. Return that + * error. Could happen if an open file refers to dst. + */ + + TclWinConvertError(GetLastError()); + if (errno == EACCES) { + /* + * Decode the EACCES to a more meaningful error. + */ + + goto decode; + } + } + return result; + } + } + } + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpCopyFile -- + * + * Copy a single file (not a directory). If dst already exists and + * is not a directory, it is removed. + * + * Results: + * If the file was successfully copied, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the + * error. Some possible values for errno are: + * + * EACCES: src or dst parent directory can't be read and/or written. + * EISDIR: src or dst is a directory. + * ENOENT: src doesn't exist. src or dst is "". + * + * EACCES: exists an open file already referring to dst (95). + * EACCES: src specifies a char device (nul:, com1:, etc.) (NT) + * ENOENT: src specifies a char device (nul:, com1:, etc.) (95) + * + * Side effects: + * It is not an error to copy to a char device. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCopyFile( + char *src, /* Pathname of file to be copied. */ + char *dst) /* Pathname of file to copy to. */ +{ + /* + * Would throw an exception under NT if one of the arguments is a char + * block device. + */ + + try { + if (CopyFile(src, dst, 0) != FALSE) { + return TCL_OK; + } + } except (-1) {} + + TclWinConvertError(GetLastError()); + if (errno == EBADF) { + errno = EACCES; + return TCL_ERROR; + } + if (errno == EACCES) { + DWORD srcAttr, dstAttr; + + srcAttr = GetFileAttributes(src); + dstAttr = GetFileAttributes(dst); + if (srcAttr != (DWORD) -1) { + if (dstAttr == (DWORD) -1) { + dstAttr = 0; + } + if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) || + (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) { + errno = EISDIR; + } + if (dstAttr & FILE_ATTRIBUTE_READONLY) { + SetFileAttributes(dst, dstAttr & ~FILE_ATTRIBUTE_READONLY); + if (CopyFile(src, dst, 0) != FALSE) { + return TCL_OK; + } + /* + * Still can't copy onto dst. Return that error, and + * restore attributes of dst. + */ + + TclWinConvertError(GetLastError()); + SetFileAttributes(dst, dstAttr); + } + } + } + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpDeleteFile -- + * + * Removes a single file (not a directory). + * + * Results: + * If the file was successfully deleted, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the + * error. Some possible values for errno are: + * + * EACCES: a parent directory can't be read and/or written. + * EISDIR: path is a directory. + * ENOENT: path doesn't exist or is "". + * + * EACCES: exists an open file already referring to path. + * EACCES: path is a char device (nul:, com1:, etc.) + * + * Side effects: + * The file is deleted, even if it is read-only. + * + *--------------------------------------------------------------------------- + */ + +int +TclpDeleteFile( + char *path) /* Pathname of file to be removed. */ +{ + DWORD attr; + + if (DeleteFile(path) != FALSE) { + return TCL_OK; + } + TclWinConvertError(GetLastError()); + if (path[0] == '\0') { + /* + * Win32s thinks that "" is the same as "." and then reports EISDIR + * instead of ENOENT. + */ + + errno = ENOENT; + } else if (errno == EACCES) { + attr = GetFileAttributes(path); + if (attr != (DWORD) -1) { + if (attr & FILE_ATTRIBUTE_DIRECTORY) { + /* + * Windows NT reports removing a directory as EACCES instead + * of EISDIR. + */ + + errno = EISDIR; + } else if (attr & FILE_ATTRIBUTE_READONLY) { + SetFileAttributes(path, attr & ~FILE_ATTRIBUTE_READONLY); + if (DeleteFile(path) != FALSE) { + return TCL_OK; + } + TclWinConvertError(GetLastError()); + SetFileAttributes(path, attr); + } + } + } else if (errno == ENOENT) { + attr = GetFileAttributes(path); + if (attr != (DWORD) -1) { + if (attr & FILE_ATTRIBUTE_DIRECTORY) { + /* + * Windows 95 reports removing a directory as ENOENT instead + * of EISDIR. + */ + + errno = EISDIR; + } + } + } else if (errno == EINVAL) { + /* + * Windows NT reports removing a char device as EINVAL instead of + * EACCES. + */ + + errno = EACCES; + } + + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpCreateDirectory -- + * + * Creates the specified directory. All parent directories of the + * specified directory must already exist. The directory is + * automatically created with permissions so that user can access + * the new directory and create new files or subdirectories in it. + * + * Results: + * If the directory was successfully created, returns TCL_OK. + * Otherwise the return value is TCL_ERROR and errno is set to + * indicate the error. Some possible values for errno are: + * + * EACCES: a parent directory can't be read and/or written. + * EEXIST: path already exists. + * ENOENT: a parent directory doesn't exist. + * + * Side effects: + * A directory is created. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCreateDirectory( + char *path) /* Pathname of directory to create */ +{ + int error; + + if (CreateDirectory(path, NULL) == 0) { + error = GetLastError(); + if (TclWinGetPlatformId() == VER_PLATFORM_WIN32s) { + if ((error == ERROR_ACCESS_DENIED) + && (GetFileAttributes(path) != (DWORD) -1)) { + error = ERROR_FILE_EXISTS; + } + } + TclWinConvertError(error); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpCopyDirectory -- + * + * Recursively copies a directory. The target directory dst must + * not already exist. Note that this function does not merge two + * directory hierarchies, even if the target directory is an an + * empty directory. + * + * Results: + * If the directory was successfully copied, returns TCL_OK. + * Otherwise the return value is TCL_ERROR, errno is set to indicate + * the error, and the pathname of the file that caused the error + * is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile + * for a description of possible values for errno. + * + * Side effects: + * An exact copy of the directory hierarchy src will be created + * with the name dst. If an error occurs, the error will + * be returned immediately, and remaining files will not be + * processed. + * + *--------------------------------------------------------------------------- + */ + +int +TclpCopyDirectory( + char *src, /* Pathname of directory to be copied. */ + char *dst, /* Pathname of target directory. */ + Tcl_DString *errorPtr) /* If non-NULL, initialized DString for + * error reporting. */ +{ + int result; + Tcl_DString srcBuffer; + Tcl_DString dstBuffer; + + Tcl_DStringInit(&srcBuffer); + Tcl_DStringInit(&dstBuffer); + Tcl_DStringAppend(&srcBuffer, src, -1); + Tcl_DStringAppend(&dstBuffer, dst, -1); + result = TraverseWinTree(TraversalCopy, &srcBuffer, &dstBuffer, + errorPtr); + Tcl_DStringFree(&srcBuffer); + Tcl_DStringFree(&dstBuffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclpRemoveDirectory -- + * + * Removes directory (and its contents, if the recursive flag is set). + * + * Results: + * If the directory was successfully removed, returns TCL_OK. + * Otherwise the return value is TCL_ERROR, errno is set to indicate + * the error, and the pathname of the file that caused the error + * is stored in errorPtr. Some possible values for errno are: + * + * EACCES: path directory can't be read and/or written. + * EEXIST: path is a non-empty directory. + * EINVAL: path is root directory or current directory. + * ENOENT: path doesn't exist or is "". + * ENOTDIR: path is not a directory. + * + * EACCES: path is a char device (nul:, com1:, etc.) (95) + * EINVAL: path is a char device (nul:, com1:, etc.) (NT) + * + * Side effects: + * Directory removed. If an error occurs, the error will be returned + * immediately, and remaining files will not be deleted. + * + *---------------------------------------------------------------------- + */ + +int +TclpRemoveDirectory( + char *path, /* Pathname of directory to be removed. */ + int recursive, /* If non-zero, removes directories that + * are nonempty. Otherwise, will only remove + * empty directories. */ + Tcl_DString *errorPtr) /* If non-NULL, initialized DString for + * error reporting. */ +{ + int result; + Tcl_DString buffer; + DWORD attr; + + if (RemoveDirectory(path) != FALSE) { + return TCL_OK; + } + TclWinConvertError(GetLastError()); + if (path[0] == '\0') { + /* + * Win32s thinks that "" is the same as "." and then reports EACCES + * instead of ENOENT. + */ + + errno = ENOENT; + } + if (errno == EACCES) { + attr = GetFileAttributes(path); + if (attr != (DWORD) -1) { + if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { + /* + * Windows 95 reports calling RemoveDirectory on a file as an + * EACCES, not an ENOTDIR. + */ + + errno = ENOTDIR; + goto end; + } + + if (attr & FILE_ATTRIBUTE_READONLY) { + attr &= ~FILE_ATTRIBUTE_READONLY; + if (SetFileAttributes(path, attr) == FALSE) { + goto end; + } + if (RemoveDirectory(path) != FALSE) { + return TCL_OK; + } + TclWinConvertError(GetLastError()); + SetFileAttributes(path, attr | FILE_ATTRIBUTE_READONLY); + } + + /* + * Windows 95 and Win32s report removing a non-empty directory + * as EACCES, not EEXIST. If the directory is not empty, + * change errno so caller knows what's going on. + */ + + if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) { + HANDLE handle; + WIN32_FIND_DATA data; + Tcl_DString buffer; + char *find; + int len; + + Tcl_DStringInit(&buffer); + find = Tcl_DStringAppend(&buffer, path, -1); + len = Tcl_DStringLength(&buffer); + if ((len > 0) && (find[len - 1] != '\\')) { + Tcl_DStringAppend(&buffer, "\\", 1); + } + find = Tcl_DStringAppend(&buffer, "*.*", 3); + handle = FindFirstFile(find, &data); + if (handle != INVALID_HANDLE_VALUE) { + while (1) { + if ((strcmp(data.cFileName, ".") != 0) + && (strcmp(data.cFileName, "..") != 0)) { + /* + * Found something in this directory. + */ + + errno = EEXIST; + break; + } + if (FindNextFile(handle, &data) == FALSE) { + break; + } + } + FindClose(handle); + } + Tcl_DStringFree(&buffer); + } + } + } + if (errno == ENOTEMPTY) { + /* + * The caller depends on EEXIST to signify that the directory is + * not empty, not ENOTEMPTY. + */ + + errno = EEXIST; + } + if ((recursive != 0) && (errno == EEXIST)) { + /* + * The directory is nonempty, but the recursive flag has been + * specified, so we recursively remove all the files in the directory. + */ + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, path, -1); + result = TraverseWinTree(TraversalDelete, &buffer, NULL, errorPtr); + Tcl_DStringFree(&buffer); + return result; + } + + end: + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, path, -1); + } + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TraverseWinTree -- + * + * Traverse directory tree specified by sourcePtr, calling the function + * traverseProc for each file and directory encountered. If destPtr + * is non-null, each of name in the sourcePtr directory is appended to + * the directory specified by destPtr and passed as the second argument + * to traverseProc() . + * + * Results: + * Standard Tcl result. + * + * Side effects: + * None caused by TraverseWinTree, however the user specified + * traverseProc() may change state. If an error occurs, the error will + * be returned immediately, and remaining files will not be processed. + * + *--------------------------------------------------------------------------- + */ + +static int +TraverseWinTree( + TraversalProc *traverseProc,/* Function to call for every file and + * directory in source hierarchy. */ + Tcl_DString *sourcePtr, /* Pathname of source directory to be + * traversed. */ + Tcl_DString *targetPtr, /* Pathname of directory to traverse in + * parallel with source directory. */ + Tcl_DString *errorPtr) /* If non-NULL, an initialized DString for + * error reporting. */ +{ + DWORD sourceAttr; + char *source, *target, *errfile; + int result, sourceLen, targetLen, sourceLenOriginal, targetLenOriginal; + HANDLE handle; + WIN32_FIND_DATA data; + + result = TCL_OK; + source = Tcl_DStringValue(sourcePtr); + sourceLenOriginal = Tcl_DStringLength(sourcePtr); + if (targetPtr != NULL) { + target = Tcl_DStringValue(targetPtr); + targetLenOriginal = Tcl_DStringLength(targetPtr); + } else { + target = NULL; + targetLenOriginal = 0; + } + + errfile = NULL; + + sourceAttr = GetFileAttributes(source); + if (sourceAttr == (DWORD) -1) { + errfile = source; + goto end; + } + if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) { + /* + * Process the regular file + */ + + return (*traverseProc)(source, target, sourceAttr, DOTREE_F, errorPtr); + } + + /* + * When given the pathname of the form "c:\" (one that already ends + * with a backslash), must make sure not to add another "\" to the end + * otherwise it will try to access a network drive. + */ + + sourceLen = sourceLenOriginal; + if ((sourceLen > 0) && (source[sourceLen - 1] != '\\')) { + Tcl_DStringAppend(sourcePtr, "\\", 1); + sourceLen++; + } + source = Tcl_DStringAppend(sourcePtr, "*.*", 3); + handle = FindFirstFile(source, &data); + Tcl_DStringSetLength(sourcePtr, sourceLen); + if (handle == INVALID_HANDLE_VALUE) { + /* + * Can't read directory + */ + + TclWinConvertError(GetLastError()); + errfile = source; + goto end; + } + + result = (*traverseProc)(source, target, sourceAttr, DOTREE_PRED, errorPtr); + if (result != TCL_OK) { + FindClose(handle); + return result; + } + + if (targetPtr != NULL) { + targetLen = targetLenOriginal; + if ((targetLen > 0) && (target[targetLen - 1] != '\\')) { + target = Tcl_DStringAppend(targetPtr, "\\", 1); + targetLen++; + } + } + + while (1) { + if ((strcmp(data.cFileName, ".") != 0) + && (strcmp(data.cFileName, "..") != 0)) { + /* + * Append name after slash, and recurse on the file. + */ + + Tcl_DStringAppend(sourcePtr, data.cFileName, -1); + if (targetPtr != NULL) { + Tcl_DStringAppend(targetPtr, data.cFileName, -1); + } + result = TraverseWinTree(traverseProc, sourcePtr, targetPtr, + errorPtr); + if (result != TCL_OK) { + break; + } + + /* + * Remove name after slash. + */ + + Tcl_DStringSetLength(sourcePtr, sourceLen); + if (targetPtr != NULL) { + Tcl_DStringSetLength(targetPtr, targetLen); + } + } + if (FindNextFile(handle, &data) == FALSE) { + break; + } + } + FindClose(handle); + + /* + * Strip off the trailing slash we added + */ + + Tcl_DStringSetLength(sourcePtr, sourceLenOriginal); + source = Tcl_DStringValue(sourcePtr); + if (targetPtr != NULL) { + Tcl_DStringSetLength(targetPtr, targetLenOriginal); + target = Tcl_DStringValue(targetPtr); + } + + if (result == TCL_OK) { + /* + * Call traverseProc() on a directory after visiting all the + * files in that directory. + */ + + result = (*traverseProc)(source, target, sourceAttr, + DOTREE_POSTD, errorPtr); + } + end: + if (errfile != NULL) { + TclWinConvertError(GetLastError()); + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, errfile, -1); + } + result = TCL_ERROR; + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TraversalCopy + * + * Called from TraverseUnixTree in order to execute a recursive + * copy of a directory. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Depending on the value of type, src may be copied to dst. + * + *---------------------------------------------------------------------- + */ + +static int +TraversalCopy( + char *src, /* Source pathname to copy. */ + char *dst, /* Destination pathname of copy. */ + DWORD srcAttr, /* File attributes for src. */ + int type, /* Reason for call - see TraverseWinTree() */ + Tcl_DString *errorPtr) /* If non-NULL, initialized DString for + * error return. */ +{ + switch (type) { + case DOTREE_F: + if (TclpCopyFile(src, dst) == TCL_OK) { + return TCL_OK; + } + break; + + case DOTREE_PRED: + if (TclpCreateDirectory(dst) == TCL_OK) { + if (SetFileAttributes(dst, srcAttr) != FALSE) { + return TCL_OK; + } + TclWinConvertError(GetLastError()); + } + break; + + case DOTREE_POSTD: + return TCL_OK; + + } + + /* + * There shouldn't be a problem with src, because we already + * checked it to get here. + */ + + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, dst, -1); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TraversalDelete -- + * + * Called by procedure TraverseWinTree for every file and + * directory that it encounters in a directory hierarchy. This + * procedure unlinks files, and removes directories after all the + * containing files have been processed. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Files or directory specified by src will be deleted. If an + * error occurs, the windows error is converted to a Posix error + * and errno is set accordingly. + * + *---------------------------------------------------------------------- + */ + +static int +TraversalDelete( + char *src, /* Source pathname. */ + char *ignore, /* Destination pathname (not used). */ + DWORD srcAttr, /* File attributes for src (not used). */ + int type, /* Reason for call - see TraverseWinTree(). */ + Tcl_DString *errorPtr) /* If non-NULL, initialized DString for + * error return. */ +{ + switch (type) { + case DOTREE_F: + if (TclpDeleteFile(src) == TCL_OK) { + return TCL_OK; + } + break; + + case DOTREE_PRED: + return TCL_OK; + + case DOTREE_POSTD: + if (TclpRemoveDirectory(src, 0, NULL) == TCL_OK) { + return TCL_OK; + } + break; + + } + + if (errorPtr != NULL) { + Tcl_DStringAppend(errorPtr, src, -1); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * AttributesPosixError -- + * + * Sets the object result with the appropriate error. + * + * Results: + * None. + * + * Side effects: + * The interp's object result is set with an error message + * based on the objIndex, fileName and errno. + * + *---------------------------------------------------------------------- + */ + +static void +AttributesPosixError( + Tcl_Interp *interp, /* The interp that has the error */ + int objIndex, /* The attribute which caused the problem. */ + char *fileName, /* The name of the file which caused the + * error. */ + int getOrSet) /* 0 for get; 1 for set */ +{ + TclWinConvertError(GetLastError()); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot ", getOrSet ? "set" : "get", " attribute \"", + tclpFileAttrStrings[objIndex], "\" for file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); +} + +/* + *---------------------------------------------------------------------- + * + * GetWinFileAttributes -- + * + * Returns a Tcl_Obj containing the value of a file attribute. + * This routine gets the -hidden, -readonly or -system attribute. + * + * Results: + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object + * will have ref count 0. If the return value is not TCL_OK, + * attributePtrPtr is not touched. + * + * Side effects: + * A new object is allocated if the file is valid. + * + *---------------------------------------------------------------------- + */ + +static int +GetWinFileAttributes( + Tcl_Interp *interp, /* The interp we are using for errors. */ + int objIndex, /* The index of the attribute. */ + char *fileName, /* The name of the file. */ + Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ +{ + DWORD result = GetFileAttributes(fileName); + + if (result == 0xFFFFFFFF) { + AttributesPosixError(interp, objIndex, fileName, 0); + return TCL_ERROR; + } + + *attributePtrPtr = Tcl_NewBooleanObj(result & attributeArray[objIndex]); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ConvertFileNameFormat -- + * + * Returns a Tcl_Obj containing either the long or short version of the + * file name. + * + * Results: + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object + * will have ref count 0. If the return value is not TCL_OK, + * attributePtrPtr is not touched. + * + * Side effects: + * A new object is allocated if the file is valid. + * + *---------------------------------------------------------------------- + */ + +static int +ConvertFileNameFormat( + Tcl_Interp *interp, /* The interp we are using for errors. */ + int objIndex, /* The index of the attribute. */ + char *fileName, /* The name of the file. */ + int longShort, /* 0 to short name, 1 to long name. */ + Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ +{ + HANDLE findHandle; + WIN32_FIND_DATA findData; + int pathArgc, i; + char **pathArgv, **newPathArgv; + char *currentElement, *resultStr; + Tcl_DString resultDString; + int result = TCL_OK; + + Tcl_SplitPath(fileName, &pathArgc, &pathArgv); + newPathArgv = (char **) ckalloc(pathArgc * sizeof(char *)); + + i = 0; + if ((pathArgv[0][0] == '/') + || ((strlen(pathArgv[0]) == 3) && (pathArgv[0][1] == ':'))) { + newPathArgv[0] = (char *) ckalloc(strlen(pathArgv[0]) + 1); + strcpy(newPathArgv[0], pathArgv[0]); + i = 1; + } + for ( ; i < pathArgc; i++) { + if (strcmp(pathArgv[i], ".") == 0) { + currentElement = ckalloc(2); + strcpy(currentElement, "."); + } else if (strcmp(pathArgv[i], "..") == 0) { + currentElement = ckalloc(3); + strcpy(currentElement, ".."); + } else { + int useLong; + + Tcl_DStringInit(&resultDString); + resultStr = Tcl_JoinPath(i + 1, pathArgv, &resultDString); + findHandle = FindFirstFile(resultStr, &findData); + if (findHandle == INVALID_HANDLE_VALUE) { + pathArgc = i - 1; + AttributesPosixError(interp, objIndex, fileName, 0); + result = TCL_ERROR; + Tcl_DStringFree(&resultDString); + goto cleanup; + } + if (longShort) { + if (findData.cFileName[0] != '\0') { + useLong = 1; + } else { + useLong = 0; + } + } else { + if (findData.cAlternateFileName[0] == '\0') { + useLong = 1; + } else { + useLong = 0; + } + } + if (useLong) { + currentElement = ckalloc(strlen(findData.cFileName) + 1); + strcpy(currentElement, findData.cFileName); + } else { + currentElement = ckalloc(strlen(findData.cAlternateFileName) + + 1); + strcpy(currentElement, findData.cAlternateFileName); + } + Tcl_DStringFree(&resultDString); + FindClose(findHandle); + } + newPathArgv[i] = currentElement; + } + + Tcl_DStringInit(&resultDString); + resultStr = Tcl_JoinPath(pathArgc, newPathArgv, &resultDString); + *attributePtrPtr = Tcl_NewStringObj(resultStr, Tcl_DStringLength(&resultDString)); + Tcl_DStringFree(&resultDString); + +cleanup: + for (i = 0; i < pathArgc; i++) { + ckfree(newPathArgv[i]); + } + ckfree((char *) newPathArgv); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * GetWinFileLongName -- + * + * Returns a Tcl_Obj containing the short version of the file + * name. + * + * Results: + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object + * will have ref count 0. If the return value is not TCL_OK, + * attributePtrPtr is not touched. + * + * Side effects: + * A new object is allocated if the file is valid. + * + *---------------------------------------------------------------------- + */ + +static int +GetWinFileLongName( + Tcl_Interp *interp, /* The interp we are using for errors. */ + int objIndex, /* The index of the attribute. */ + char *fileName, /* The name of the file. */ + Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ +{ + return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr); +} + +/* + *---------------------------------------------------------------------- + * + * GetWinFileShortName -- + * + * Returns a Tcl_Obj containing the short version of the file + * name. + * + * Results: + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object + * will have ref count 0. If the return value is not TCL_OK, + * attributePtrPtr is not touched. + * + * Side effects: + * A new object is allocated if the file is valid. + * + *---------------------------------------------------------------------- + */ + +static int +GetWinFileShortName( + Tcl_Interp *interp, /* The interp we are using for errors. */ + int objIndex, /* The index of the attribute. */ + char *fileName, /* The name of the file. */ + Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ +{ + return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr); +} + +/* + *---------------------------------------------------------------------- + * + * SetWinFileAttributes -- + * + * Set the file attributes to the value given by attributePtr. + * This routine sets the -hidden, -readonly, or -system attributes. + * + * Results: + * Standard TCL error. + * + * Side effects: + * The file's attribute is set. + * + *---------------------------------------------------------------------- + */ + +static int +SetWinFileAttributes( + Tcl_Interp *interp, /* The interp we are using for errors. */ + int objIndex, /* The index of the attribute. */ + char *fileName, /* The name of the file. */ + Tcl_Obj *attributePtr) /* The new value of the attribute. */ +{ + DWORD fileAttributes = GetFileAttributes(fileName); + int yesNo; + int result; + + if (fileAttributes == 0xFFFFFFFF) { + AttributesPosixError(interp, objIndex, fileName, 1); + return TCL_ERROR; + } + + result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo); + if (result != TCL_OK) { + return result; + } + + if (yesNo) { + fileAttributes |= (attributeArray[objIndex]); + } else { + fileAttributes &= ~(attributeArray[objIndex]); + } + + if (!SetFileAttributes(fileName, fileAttributes)) { + AttributesPosixError(interp, objIndex, fileName, 1); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SetWinFileLongName -- + * + * The attribute in question is a readonly attribute and cannot + * be set. + * + * Results: + * TCL_ERROR + * + * Side effects: + * The object result is set to a pertinant error message. + * + *---------------------------------------------------------------------- + */ + +static int +CannotSetAttribute( + Tcl_Interp *interp, /* The interp we are using for errors. */ + int objIndex, /* The index of the attribute. */ + char *fileName, /* The name of the file. */ + Tcl_Obj *attributePtr) /* The new value of the attribute. */ +{ + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot set attribute \"", tclpFileAttrStrings[objIndex], + "\" for file \"", fileName, "\" : attribute is readonly", + (char *) NULL); + return TCL_ERROR; +} + + +/* + *--------------------------------------------------------------------------- + * + * TclpListVolumes -- + * + * Lists the currently mounted volumes + * + * Results: + * A standard Tcl result. Will always be TCL_OK, since there is no way + * that this command can fail. Also, the interpreter's result is set to + * the list of volumes. + * + * Side effects: + * None + * + *--------------------------------------------------------------------------- + */ + +int +TclpListVolumes( + Tcl_Interp *interp) /* Interpreter to which to pass the volume list */ +{ + Tcl_Obj *resultPtr, *elemPtr; + char buf[4]; + int i; + + resultPtr = Tcl_GetObjResult(interp); + + buf[1] = ':'; + buf[2] = '/'; + buf[3] = '\0'; + + /* + * On Win32s: + * GetLogicalDriveStrings() isn't implemented. + * GetLogicalDrives() returns incorrect information. + */ + + for (i = 0; i < 26; i++) { + buf[0] = (char) ('a' + i); + if (GetVolumeInformation(buf, NULL, 0, NULL, NULL, NULL, NULL, 0) + || (GetLastError() == ERROR_NOT_READY)) { + elemPtr = Tcl_NewStringObj(buf, -1); + Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); + } + } + return TCL_OK; +} diff --git a/win/tclWinFile.c b/win/tclWinFile.c new file mode 100644 index 0000000..9d97b02 --- /dev/null +++ b/win/tclWinFile.c @@ -0,0 +1,647 @@ +/* + * tclWinFile.c -- + * + * This file contains temporary wrappers around UNIX file handling + * functions. These wrappers map the UNIX functions to Win32 HANDLE-style + * files, which can be manipulated through the Win32 console redirection + * interfaces. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinFile.c 1.45 97/10/29 19:08:35 + */ + +#include "tclWinInt.h" +#include <sys/stat.h> +#include <shlobj.h> + +/* + * The variable below caches the name of the current working directory + * in order to avoid repeated calls to getcwd. The string is malloc-ed. + * NULL means the cache needs to be refreshed. + */ + +static char *currentDir = NULL; + + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindExecutable -- + * + * This procedure computes the absolute path name of the current + * application, given its argv[0] value. + * + * Results: + * None. + * + * Side effects: + * The variable tclExecutableName gets filled in with the file + * name for the application, if we figured it out. If we couldn't + * figure it out, Tcl_FindExecutable is set to NULL. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FindExecutable(argv0) + char *argv0; /* The value of the application's argv[0]. */ +{ + Tcl_DString buffer; + int length; + + Tcl_DStringInit(&buffer); + + if (tclExecutableName != NULL) { + ckfree(tclExecutableName); + tclExecutableName = NULL; + } + + /* + * Under Windows we ignore argv0, and return the path for the file used to + * create this process. + */ + + Tcl_DStringSetLength(&buffer, MAX_PATH+1); + length = GetModuleFileName(NULL, Tcl_DStringValue(&buffer), MAX_PATH+1); + if (length > 0) { + tclExecutableName = (char *) ckalloc((unsigned) (length + 1)); + strcpy(tclExecutableName, Tcl_DStringValue(&buffer)); + } + Tcl_DStringFree(&buffer); +} + +/* + *---------------------------------------------------------------------- + * + * TclMatchFiles -- + * + * This routine is used by the globbing code to search a + * directory for all files which match a given pattern. + * + * Results: + * If the tail argument is NULL, then the matching files are + * added to the interp->result. Otherwise, TclDoGlob is called + * recursively for each matching subdirectory. The return value + * is a standard Tcl result indicating whether an error occurred + * in globbing. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- */ + +int +TclMatchFiles(interp, separators, dirPtr, pattern, tail) + Tcl_Interp *interp; /* Interpreter to receive results. */ + char *separators; /* Directory separators to pass to TclDoGlob. */ + Tcl_DString *dirPtr; /* Contains path to directory to search. */ + char *pattern; /* Pattern to match against. */ + char *tail; /* Pointer to end of pattern. Tail must + * point to a location in pattern. */ +{ + char drivePattern[4] = "?:\\"; + char *newPattern, *p, *dir, *root, c; + char *src, *dest; + int length, matchDotFiles; + int result = TCL_OK; + int baseLength = Tcl_DStringLength(dirPtr); + Tcl_DString buffer; + DWORD atts, volFlags; + HANDLE handle; + WIN32_FIND_DATA data; + BOOL found; + + /* + * Convert the path to normalized form since some interfaces only + * accept backslashes. Also, ensure that the directory ends with a + * separator character. + */ + + Tcl_DStringInit(&buffer); + if (baseLength == 0) { + Tcl_DStringAppend(&buffer, ".", 1); + } else { + Tcl_DStringAppend(&buffer, Tcl_DStringValue(dirPtr), + Tcl_DStringLength(dirPtr)); + } + for (p = Tcl_DStringValue(&buffer); *p != '\0'; p++) { + if (*p == '/') { + *p = '\\'; + } + } + p--; + if (*p != '\\' && *p != ':') { + Tcl_DStringAppend(&buffer, "\\", 1); + } + dir = Tcl_DStringValue(&buffer); + + /* + * First verify that the specified path is actually a directory. + */ + + atts = GetFileAttributes(dir); + if ((atts == 0xFFFFFFFF) || ((atts & FILE_ATTRIBUTE_DIRECTORY) == 0)) { + Tcl_DStringFree(&buffer); + return TCL_OK; + } + + /* + * Next check the volume information for the directory to see whether + * comparisons should be case sensitive or not. If the root is null, then + * we use the root of the current directory. If the root is just a drive + * specifier, we use the root directory of the given drive. + */ + + switch (Tcl_GetPathType(dir)) { + case TCL_PATH_RELATIVE: + found = GetVolumeInformation(NULL, NULL, 0, NULL, + NULL, &volFlags, NULL, 0); + break; + case TCL_PATH_VOLUME_RELATIVE: + if (*dir == '\\') { + root = NULL; + } else { + root = drivePattern; + *root = *dir; + } + found = GetVolumeInformation(root, NULL, 0, NULL, + NULL, &volFlags, NULL, 0); + break; + case TCL_PATH_ABSOLUTE: + if (dir[1] == ':') { + root = drivePattern; + *root = *dir; + found = GetVolumeInformation(root, NULL, 0, NULL, + NULL, &volFlags, NULL, 0); + } else if (dir[1] == '\\') { + p = strchr(dir+2, '\\'); + p = strchr(p+1, '\\'); + p++; + c = *p; + *p = 0; + found = GetVolumeInformation(dir, NULL, 0, NULL, + NULL, &volFlags, NULL, 0); + *p = c; + } + break; + } + + if (!found) { + Tcl_DStringFree(&buffer); + TclWinConvertError(GetLastError()); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read volume information for \"", + dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * In Windows, although some volumes may support case sensitivity, Windows + * doesn't honor case. So in globbing we need to ignore the case + * of file names. + */ + + length = tail - pattern; + newPattern = ckalloc(length+1); + for (src = pattern, dest = newPattern; src < tail; src++, dest++) { + *dest = (char) tolower(*src); + } + *dest = '\0'; + + /* + * We need to check all files in the directory, so append a *.* + * to the path. + */ + + + dir = Tcl_DStringAppend(&buffer, "*.*", 3); + + /* + * Now open the directory for reading and iterate over the contents. + */ + + handle = FindFirstFile(dir, &data); + Tcl_DStringFree(&buffer); + + if (handle == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read directory \"", + dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL); + ckfree(newPattern); + return TCL_ERROR; + } + + /* + * Clean up the tail pointer. Leave the tail pointing to the + * first character after the path separator or NULL. + */ + + if (*tail == '\\') { + tail++; + } + if (*tail == '\0') { + tail = NULL; + } else { + tail++; + } + + /* + * Check to see if the pattern needs to compare with dot files. + */ + + if ((newPattern[0] == '.') + || ((pattern[0] == '\\') && (pattern[1] == '.'))) { + matchDotFiles = 1; + } else { + matchDotFiles = 0; + } + + /* + * Now iterate over all of the files in the directory. + */ + + Tcl_DStringInit(&buffer); + for (found = 1; found; found = FindNextFile(handle, &data)) { + char *matchResult; + + /* + * Ignore hidden files. + */ + + if (!matchDotFiles && (data.cFileName[0] == '.')) { + continue; + } + + /* + * Check to see if the file matches the pattern. We need to convert + * the file name to lower case for comparison purposes. Note that we + * are ignoring the case sensitivity flag because Windows doesn't honor + * case even if the volume is case sensitive. If the volume also + * doesn't preserve case, then we return the lower case form of the + * name, otherwise we return the system form. + */ + + matchResult = NULL; + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, data.cFileName, -1); + for (p = buffer.string; *p != '\0'; p++) { + *p = (char) tolower(*p); + } + if (Tcl_StringMatch(buffer.string, newPattern)) { + if (volFlags & FS_CASE_IS_PRESERVED) { + matchResult = data.cFileName; + } else { + matchResult = buffer.string; + } + } + + if (matchResult == NULL) { + continue; + } + + /* + * If the file matches, then we need to process the remainder of the + * path. If there are more characters to process, then ensure matching + * files are directories and call TclDoGlob. Otherwise, just add the + * file to the result. + */ + + Tcl_DStringSetLength(dirPtr, baseLength); + Tcl_DStringAppend(dirPtr, matchResult, -1); + if (tail == NULL) { + Tcl_AppendElement(interp, dirPtr->string); + } else { + atts = GetFileAttributes(dirPtr->string); + if (atts & FILE_ATTRIBUTE_DIRECTORY) { + Tcl_DStringAppend(dirPtr, "/", 1); + result = TclDoGlob(interp, separators, dirPtr, tail); + if (result != TCL_OK) { + break; + } + } + } + } + + Tcl_DStringFree(&buffer); + FindClose(handle); + ckfree(newPattern); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclChdir -- + * + * Change the current working directory. + * + * Results: + * The result is a standard Tcl result. If an error occurs and + * interp isn't NULL, an error message is left in interp->result. + * + * Side effects: + * The working directory for this application is changed. Also + * the cache maintained used by TclGetCwd is deallocated and + * set to NULL. + * + *---------------------------------------------------------------------- + */ + +int +TclChdir(interp, dirName) + Tcl_Interp *interp; /* If non NULL, used for error reporting. */ + char *dirName; /* Path to new working directory. */ +{ + if (currentDir != NULL) { + ckfree(currentDir); + currentDir = NULL; + } + if (!SetCurrentDirectory(dirName)) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't change working directory to \"", + dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetCwd -- + * + * Return the path name of the current working directory. + * + * Results: + * The result is the full path name of the current working + * directory, or NULL if an error occurred while figuring it + * out. If an error occurs and interp isn't NULL, an error + * message is left in interp->result. + * + * Side effects: + * The path name is cached to avoid having to recompute it + * on future calls; if it is already cached, the cached + * value is returned. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetCwd(interp) + Tcl_Interp *interp; /* If non NULL, used for error reporting. */ +{ + static char buffer[MAXPATHLEN+1]; + char *bufPtr, *p; + + if (currentDir == NULL) { + if (GetCurrentDirectory(MAXPATHLEN+1, buffer) == 0) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + if (errno == ERANGE) { + Tcl_SetResult(interp, + "working directory name is too long", + TCL_STATIC); + } else { + Tcl_AppendResult(interp, + "error getting working directory name: ", + Tcl_PosixError(interp), (char *) NULL); + } + } + return NULL; + } + /* + * Watch for the wierd Windows '95 c:\\UNC syntax. + */ + + if (buffer[0] != '\0' && buffer[1] == ':' && buffer[2] == '\\' + && buffer[3] == '\\') { + bufPtr = &buffer[2]; + } else { + bufPtr = buffer; + } + + /* + * Convert to forward slashes for easier use in scripts. + */ + + for (p = bufPtr; *p != '\0'; p++) { + if (*p == '\\') { + *p = '/'; + } + } + } + return bufPtr; +} + +#if 0 +/* + *------------------------------------------------------------------------- + * + * TclWinResolveShortcut -- + * + * Resolve a potential Windows shortcut to get the actual file or + * directory in question. + * + * Results: + * Returns 1 if the shortcut could be resolved, or 0 if there was + * an error or if the filename was not a shortcut. + * If bufferPtr did hold the name of a shortcut, it is modified to + * hold the resolved target of the shortcut instead. + * + * Side effects: + * Loads and unloads OLE package to determine if filename refers to + * a shortcut. + * + *------------------------------------------------------------------------- + */ + +int +TclWinResolveShortcut(bufferPtr) + Tcl_DString *bufferPtr; /* Holds name of file to resolve. On + * return, holds resolved file name. */ +{ + HRESULT hres; + IShellLink *psl; + IPersistFile *ppf; + WIN32_FIND_DATA wfd; + WCHAR wpath[MAX_PATH]; + char *path, *ext; + char realFileName[MAX_PATH]; + + /* + * Windows system calls do not automatically resolve + * shortcuts like UNIX automatically will with symbolic links. + */ + + path = Tcl_DStringValue(bufferPtr); + ext = strrchr(path, '.'); + if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) { + return 0; + } + + CoInitialize(NULL); + path = Tcl_DStringValue(bufferPtr); + realFileName[0] = '\0'; + hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER, + &IID_IShellLink, &psl); + if (SUCCEEDED(hres)) { + hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf); + if (SUCCEEDED(hres)) { + MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath)); + hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ); + if (SUCCEEDED(hres)) { + hres = psl->lpVtbl->Resolve(psl, NULL, + SLR_ANY_MATCH | SLR_NO_UI); + if (SUCCEEDED(hres)) { + hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH, + &wfd, 0); + } + } + ppf->lpVtbl->Release(ppf); + } + psl->lpVtbl->Release(psl); + } + CoUninitialize(); + + if (realFileName[0] != '\0') { + Tcl_DStringSetLength(bufferPtr, 0); + Tcl_DStringAppend(bufferPtr, realFileName, -1); + return 1; + } + return 0; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * TclWinStat, TclWinLstat -- + * + * These functions replace the library versions of stat and lstat. + * + * The stat and lstat functions provided by some Windows compilers + * are incomplete. Ideally, a complete rewrite of stat would go + * here; now, the only fix is that stat("c:") used to return an + * error instead infor for current dir on specified drive. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *---------------------------------------------------------------------- + */ + +int +TclWinStat(path, buf) + CONST char *path; /* Path of file to stat (in current CP). */ + struct stat *buf; /* Filled with results of stat call. */ +{ + char name[4]; + int result; + + if ((strlen(path) == 2) && (path[1] == ':')) { + strcpy(name, path); + name[2] = '.'; + name[3] = '\0'; + path = name; + } + +#undef stat + + result = stat(path, buf); + +#ifndef _MSC_VER + + /* + * Borland's stat doesn't take into account localtime. + */ + + if ((result == 0) && (buf->st_mtime != 0)) { + TIME_ZONE_INFORMATION tz; + int time, bias; + + time = GetTimeZoneInformation(&tz); + bias = tz.Bias; + if (time == TIME_ZONE_ID_DAYLIGHT) { + bias += tz.DaylightBias; + } + bias *= 60; + buf->st_atime -= bias; + buf->st_ctime -= bias; + buf->st_mtime -= bias; + } + +#endif + + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * TclWinAccess -- + * + * This function replaces the library version of access. + * + * The library version of access returns that all files have execute + * permission. + * + * Results: + * See access documentation. + * + * Side effects: + * See access documentation. + * + *--------------------------------------------------------------------------- + */ + +int +TclWinAccess( + CONST char *path, /* Path of file to access (in current CP). */ + int mode) /* Permission setting. */ +{ + int result; + CONST char *p; + +#undef access + + result = access(path, mode); + + if (result == 0) { + if (mode & 1) { + if (GetFileAttributes(path) & FILE_ATTRIBUTE_DIRECTORY) { + /* + * Directories are always executable. + */ + + return 0; + } + p = strrchr(path, '.'); + if (p != NULL) { + p++; + if ((stricmp(p, "exe") == 0) + || (stricmp(p, "com") == 0) + || (stricmp(p, "bat") == 0)) { + /* + * File that ends with .exe, .com, or .bat is executable. + */ + + return 0; + } + } + errno = EACCES; + return -1; + } + } + return result; +} + diff --git a/win/tclWinInit.c b/win/tclWinInit.c new file mode 100644 index 0000000..be8dbbd --- /dev/null +++ b/win/tclWinInit.c @@ -0,0 +1,394 @@ +/* + * tclWinInit.c -- + * + * Contains the Windows-specific interpreter initialization functions. + * + * 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: @(#) tclWinInit.c 1.32 97/06/24 17:28:26 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include <winreg.h> +#include <winnt.h> +#include <winbase.h> + +/* + * The following declaration is a workaround for some Microsoft brain damage. + * The SYSTEM_INFO structure is different in various releases, even though the + * layout is the same. So we overlay our own structure on top of it so we + * can access the interesting slots in a uniform way. + */ + +typedef struct { + WORD wProcessorArchitecture; + WORD wReserved; +} OemId; + +/* + * The following macros are missing from some versions of winnt.h. + */ + +#ifndef PROCESSOR_ARCHITECTURE_INTEL +#define PROCESSOR_ARCHITECTURE_INTEL 0 +#endif +#ifndef PROCESSOR_ARCHITECTURE_MIPS +#define PROCESSOR_ARCHITECTURE_MIPS 1 +#endif +#ifndef PROCESSOR_ARCHITECTURE_ALPHA +#define PROCESSOR_ARCHITECTURE_ALPHA 2 +#endif +#ifndef PROCESSOR_ARCHITECTURE_PPC +#define PROCESSOR_ARCHITECTURE_PPC 3 +#endif +#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN +#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF +#endif + +/* + * The following arrays contain the human readable strings for the Windows + * platform and processor values. + */ + + +#define NUMPLATFORMS 3 +static char* platforms[NUMPLATFORMS] = { + "Win32s", "Windows 95", "Windows NT" +}; + +#define NUMPROCESSORS 4 +static char* processors[NUMPROCESSORS] = { + "intel", "mips", "alpha", "ppc" +}; + +/* + * The following string is the startup script executed in new + * interpreters. It looks on disk in several different directories + * for a script "init.tcl" that is compatible with this version + * of Tcl. The init.tcl script does all of the real work of + * initialization. + */ + +static char *initScript = +"proc init {} {\n\ + global tcl_library tcl_platform tcl_version tcl_patchLevel env errorInfo\n\ + global tcl_pkgPath\n\ + rename init {}\n\ + set errors {}\n\ + proc tcl_envTraceProc {lo n1 n2 op} {\n\ + global env\n\ + set x $env($n2)\n\ + set env($lo) $x\n\ + set env([string toupper $lo]) $x\n\ + }\n\ + foreach p [array names env] {\n\ + set u [string toupper $p]\n\ + if {$u != $p} {\n\ + switch -- $u {\n\ + COMSPEC -\n\ + PATH {\n\ + if {![info exists env($u)]} {\n\ + set env($u) $env($p)\n\ + }\n\ + trace variable env($p) w [list tcl_envTraceProc $p]\n\ + trace variable env($u) w [list tcl_envTraceProc $p]\n\ + }\n\ + }\n\ + }\n\ + }\n\ + if {![info exists env(COMSPEC)]} {\n\ + if {$tcl_platform(os) == {Windows NT}} {\n\ + set env(COMSPEC) cmd.exe\n\ + } else {\n\ + set env(COMSPEC) command.com\n\ + }\n\ + } \n\ + set dirs {}\n\ + if {[info exists env(TCL_LIBRARY)]} {\n\ + lappend dirs $env(TCL_LIBRARY)\n\ + }\n\ + lappend dirs $tcl_library\n\ + lappend dirs [file join [file dirname [file dirname [info nameofexecutable]]] lib/tcl$tcl_version]\n\ + if [string match {*[ab]*} $tcl_patchLevel] {\n\ + set lib tcl$tcl_patchLevel\n\ + } else {\n\ + set lib tcl$tcl_version\n\ + }\n\ + lappend dirs [file join [file dirname [file dirname [pwd]]] $lib/library]\n\ + lappend dirs [file join [file dirname [pwd]] library]\n\ + foreach i $dirs {\n\ + set tcl_library $i\n\ + set tclfile [file join $i init.tcl]\n\ + if {[file exists $tclfile]} {\n\ + lappend tcl_pkgPath [file dirname $i]\n\ + if ![catch {uplevel #0 [list source $tclfile]} msg] {\n\ + return\n\ + } else {\n\ + append errors \"$tclfile: $msg\n$errorInfo\n\"\n\ + }\n\ + }\n\ + }\n\ + set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\ + append msg \" $dirs\n\n\"\n\ + append msg \"$errors\n\n\"\n\ + append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\ + error $msg\n\ +}\n\ +init\n"; + +/* + *---------------------------------------------------------------------- + * + * TclPlatformInit -- + * + * Performs Windows-specific interpreter initialization related to the + * tcl_library variable. Also sets up the HOME environment variable + * if it is not already set. + * + * Results: + * None. + * + * Side effects: + * Sets "tcl_library" and "env(HOME)" Tcl variables + * + *---------------------------------------------------------------------- + */ + +void +TclPlatformInit(interp) + Tcl_Interp *interp; +{ + char *ptr; + char buffer[13]; + Tcl_DString ds; + OSVERSIONINFO osInfo; + SYSTEM_INFO sysInfo; + int isWin32s; /* True if we are running under Win32s. */ + OemId *oemId; + HKEY key; + DWORD size; + + tclPlatform = TCL_PLATFORM_WINDOWS; + + Tcl_DStringInit(&ds); + + /* + * Find out what kind of system we are running on. + */ + + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + GetVersionEx(&osInfo); + + isWin32s = (osInfo.dwPlatformId == VER_PLATFORM_WIN32s); + + /* + * Since Win32s doesn't support GetSystemInfo, we use a default value. + */ + + oemId = (OemId *) &sysInfo; + if (!isWin32s) { + GetSystemInfo(&sysInfo); + } else { + oemId->wProcessorArchitecture = PROCESSOR_ARCHITECTURE_INTEL; + } + + /* + * Initialize the tcl_library variable from the registry. + */ + + if (!isWin32s) { + if ((RegOpenKeyEx(HKEY_LOCAL_MACHINE, + "Software\\Sun\\Tcl\\" TCL_VERSION, 0, KEY_READ, &key) + == ERROR_SUCCESS) + && (RegQueryValueEx(key, "Root", NULL, NULL, NULL, &size) + == ERROR_SUCCESS)) { + Tcl_DStringSetLength(&ds, size); + RegQueryValueEx(key, "Root", NULL, NULL, + (LPBYTE)Tcl_DStringValue(&ds), &size); + } + } else { + if ((RegOpenKeyEx(HKEY_CLASSES_ROOT, + "Software\\Sun\\Tcl\\" TCL_VERSION, 0, KEY_READ, &key) + == ERROR_SUCCESS) + && (RegQueryValueEx(key, "", NULL, NULL, NULL, &size) + == ERROR_SUCCESS)) { + Tcl_DStringSetLength(&ds, size); + RegQueryValueEx(key, "", NULL, NULL, + (LPBYTE) Tcl_DStringValue(&ds), &size); + } + } + Tcl_SetVar(interp, "tcl_library", Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY); + if (Tcl_DStringLength(&ds) > 0) { + char *argv[3]; + argv[0] = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); + argv[1] = "lib"; + argv[2] = NULL; + Tcl_DStringSetLength(&ds, 0); + Tcl_SetVar(interp, "tcl_pkgPath", Tcl_JoinPath(2, argv, &ds), + TCL_GLOBAL_ONLY|TCL_LIST_ELEMENT); + argv[1] = "lib/tcl" TCL_VERSION; + Tcl_DStringSetLength(&ds, 0); + Tcl_SetVar(interp, "tcl_library", Tcl_JoinPath(2, argv, &ds), + TCL_GLOBAL_ONLY); + } + + /* + * Define the tcl_platform array. + */ + + Tcl_SetVar2(interp, "tcl_platform", "platform", "windows", + TCL_GLOBAL_ONLY); + if (osInfo.dwPlatformId < NUMPLATFORMS) { + Tcl_SetVar2(interp, "tcl_platform", "os", + platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY); + } + sprintf(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); + Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY); + if (oemId->wProcessorArchitecture < NUMPROCESSORS) { + Tcl_SetVar2(interp, "tcl_platform", "machine", + processors[oemId->wProcessorArchitecture], + TCL_GLOBAL_ONLY); + } + + /* + * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH + * environment variables, if necessary. + */ + + ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY); + if (ptr == NULL) { + Tcl_DStringSetLength(&ds, 0); + ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY); + if (ptr != NULL) { + Tcl_DStringAppend(&ds, ptr, -1); + } + ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY); + if (ptr != NULL) { + Tcl_DStringAppend(&ds, ptr, -1); + } + if (Tcl_DStringLength(&ds) > 0) { + Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds), + TCL_GLOBAL_ONLY); + } else { + Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY); + } + } + + Tcl_DStringFree(&ds); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Init -- + * + * This procedure is typically invoked by Tcl_AppInit procedures + * to perform additional initialization for a Tcl interpreter, + * such as sourcing the "init.tcl" script. + * + * Results: + * Returns a standard Tcl completion code and sets interp->result + * if there is an error. + * + * Side effects: + * Depends on what's in the init.tcl script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Init(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ +{ + return Tcl_Eval(interp, initScript); + +} + +/* + *---------------------------------------------------------------------- + * + * TclWinGetPlatform -- + * + * This is a kludge that allows the test library to get access + * the internal tclPlatform variable. + * + * Results: + * Returns a pointer to the tclPlatform variable. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclPlatformType * +TclWinGetPlatform() +{ + return &tclPlatform; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SourceRCFile -- + * + * This procedure is typically invoked by Tcl_Main of Tk_Main + * procedure to source an application specific rc file into the + * interpreter at startup time. + * + * Results: + * None. + * + * Side effects: + * Depends on what's in the rc script. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SourceRCFile(interp) + Tcl_Interp *interp; /* Interpreter to source rc file into. */ +{ + Tcl_DString temp; + char *fileName; + Tcl_Channel errChannel; + + fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); + + if (fileName != NULL) { + Tcl_Channel c; + char *fullName; + + Tcl_DStringInit(&temp); + fullName = Tcl_TranslateFileName(interp, fileName, &temp); + if (fullName == NULL) { + /* + * Couldn't translate the file name (e.g. it referred to a + * bogus user or there was no HOME environment variable). + * Just do nothing. + */ + } else { + + /* + * Test for the existence of the rc file before trying to read it. + */ + + c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); + if (c != (Tcl_Channel) NULL) { + Tcl_Close(NULL, c); + if (Tcl_EvalFile(interp, fullName) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } + } + } + Tcl_DStringFree(&temp); + } +} diff --git a/win/tclWinInt.h b/win/tclWinInt.h new file mode 100644 index 0000000..04e84d6 --- /dev/null +++ b/win/tclWinInt.h @@ -0,0 +1,38 @@ +/* + * tclWinInt.h -- + * + * Declarations of Windows-specific shared variables and procedures. + * + * 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: @(#) tclWinInt.h 1.7 97/06/25 10:56:14 + */ + +#ifndef _TCLWININT +#define _TCLWININT + +#ifndef _TCLINT +#include "tclInt.h" +#endif +#ifndef _TCLPORT +#include "tclPort.h" +#endif + +/* + * Some versions of Borland C have a define for the OSVERSIONINFO for + * Win32s and for NT, but not for Windows 95. + */ + +#ifndef VER_PLATFORM_WIN32_WINDOWS +#define VER_PLATFORM_WIN32_WINDOWS 1 +#endif + +EXTERN int TclWinSynchSpawn(void *args, int type, void **trans, + Tcl_Pid *pidPtr); +EXTERN int TclWinGetPlatformId(void); + + +#endif /* _TCLWININT */ diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c new file mode 100644 index 0000000..8106671 --- /dev/null +++ b/win/tclWinLoad.c @@ -0,0 +1,114 @@ +/* + * tclWinLoad.c -- + * + * This procedure provides a version of the TclLoadFile that + * works with the Windows "LoadLibrary" and "GetProcAddress" + * API for dynamic loading. + * + * Copyright (c) 1995 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: @(#) tclWinLoad.c 1.6 96/02/15 11:54:07 + */ + +#include "tclInt.h" +#include "tclPort.h" + + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they + * are defined. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in interp->result. + * + * Side effects: + * New code suddenly appears in memory. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + HINSTANCE handle; + char *buffer; + + handle = TclWinLoadLibrary(fileName); + if (handle == NULL) { + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * For each symbol, check for both Symbol and _Symbol, since Borland + * generates C symbols with a leading '_' by default. + */ + + *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym1); + if (*proc1Ptr == NULL) { + buffer = ckalloc(strlen(sym1)+2); + buffer[0] = '_'; + strcpy(buffer+1, sym1); + *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, buffer); + ckfree(buffer); + } + + *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2); + if (*proc2Ptr == NULL) { + buffer = ckalloc(strlen(sym2)+2); + buffer[0] = '_'; + strcpy(buffer+1, sym2); + *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, buffer); + ckfree(buffer); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/win/tclWinMtherr.c b/win/tclWinMtherr.c new file mode 100644 index 0000000..98c528d --- /dev/null +++ b/win/tclWinMtherr.c @@ -0,0 +1,61 @@ +/* + * tclWinMtherr.c -- + * + * This function provides a default implementation of the + * _matherr function for Borland C++. + * + * Copyright (c) 1995 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: @(#) tclWinMtherr.c 1.2 96/02/15 11:54:05 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include <math.h> + +/* + * The following variable is secretly shared with Tcl so we can + * tell if expression evaluation is in progress. If not, matherr + * just emulates the default behavior, which includes printing + * a message. + */ + +extern int tcl_MathInProgress; + +/* + *---------------------------------------------------------------------- + * + * _matherr -- + * + * This procedure is invoked by Borland C++ when certain + * errors occur in mathematical functions. This procedure + * replaces the default implementation which generates pop-up + * warnings. + * + * Results: + * Returns 1 to indicate that we've handled the error + * locally. + * + * Side effects: + * Sets errno based on what's in xPtr. + * + *---------------------------------------------------------------------- + */ + +int +_matherr(xPtr) + struct exception *xPtr; /* Describes error that occurred. */ +{ + if (!tcl_MathInProgress) { + return 0; + } + if ((xPtr->type == DOMAIN) || (xPtr->type == SING)) { + errno = EDOM; + } else { + errno = ERANGE; + } + return 1; +} diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c new file mode 100644 index 0000000..8df95e3 --- /dev/null +++ b/win/tclWinNotify.c @@ -0,0 +1,325 @@ +/* + * tclWinNotify.c -- + * + * This file contains Windows-specific procedures for the notifier, + * which is the lowest-level part of the Tcl event loop. This file + * works together with ../generic/tclNotify.c. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinNotify.c 1.17 97/05/23 10:48:44 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include <winsock.h> + +/* + * The follwing static indicates whether this module has been initialized. + */ + +static int initialized = 0; + +#define INTERVAL_TIMER 1 /* Handle of interval timer. */ + +/* + * The following static structure contains the state information for the + * Windows implementation of the Tcl notifier. + */ + +static struct { + HWND hwnd; /* Messaging window. */ + int timeout; /* Current timeout value. */ + int timerActive; /* 1 if interval timer is running. */ +} notifier; + +/* + * Static routines defined in this file. + */ + +static void InitNotifier(void); +static void NotifierExitHandler(ClientData clientData); +static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message, + WPARAM wParam, LPARAM lParam); +static void UpdateTimer(int timeout); + +/* + *---------------------------------------------------------------------- + * + * InitNotifier -- + * + * Initializes the notifier window. + * + * Results: + * None. + * + * Side effects: + * Creates a new notifier window and window class. + * + *---------------------------------------------------------------------- + */ + +static void +InitNotifier(void) +{ + WNDCLASS class; + + initialized = 1; + notifier.timerActive = 0; + class.style = 0; + class.cbClsExtra = 0; + class.cbWndExtra = 0; + class.hInstance = TclWinGetTclInstance(); + class.hbrBackground = NULL; + class.lpszMenuName = NULL; + class.lpszClassName = "TclNotifier"; + class.lpfnWndProc = NotifierProc; + class.hIcon = NULL; + class.hCursor = NULL; + + if (!RegisterClass(&class)) { + panic("Unable to register TclNotifier window class"); + } + notifier.hwnd = CreateWindow("TclNotifier", "TclNotifier", WS_TILED, + 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL); + Tcl_CreateExitHandler(NotifierExitHandler, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * NotifierExitHandler -- + * + * This function is called to cleanup the notifier state before + * Tcl is unloaded. + * + * Results: + * None. + * + * Side effects: + * Destroys the notifier window. + * + *---------------------------------------------------------------------- + */ + +static void +NotifierExitHandler( + ClientData clientData) /* Old window proc */ +{ + initialized = 0; + if (notifier.hwnd) { + KillTimer(notifier.hwnd, INTERVAL_TIMER); + DestroyWindow(notifier.hwnd); + UnregisterClass("TclNotifier", TclWinGetTclInstance()); + notifier.hwnd = NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * UpdateTimer -- + * + * This function starts or stops the notifier interval timer. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +UpdateTimer( + int timeout) /* ms timeout, 0 means cancel timer */ +{ + notifier.timeout = timeout; + if (timeout != 0) { + notifier.timerActive = 1; + SetTimer(notifier.hwnd, INTERVAL_TIMER, + (unsigned long) notifier.timeout, NULL); + } else { + notifier.timerActive = 0; + KillTimer(notifier.hwnd, INTERVAL_TIMER); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetTimer -- + * + * This procedure sets the current notifier timer value. The + * notifier will ensure that Tcl_ServiceAll() is called after + * the specified interval, even if no events have occurred. + * + * Results: + * None. + * + * Side effects: + * Replaces any previous timer. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetTimer( + Tcl_Time *timePtr) /* Maximum block time, or NULL. */ +{ + UINT timeout; + + if (!initialized) { + InitNotifier(); + } + + if (!timePtr) { + timeout = 0; + } else { + /* + * Make sure we pass a non-zero value into the timeout argument. + * Windows seems to get confused by zero length timers. + */ + timeout = timePtr->sec * 1000 + timePtr->usec / 1000; + if (timeout == 0) { + timeout = 1; + } + } + UpdateTimer(timeout); +} + +/* + *---------------------------------------------------------------------- + * + * NotifierProc -- + * + * This procedure is invoked by Windows to process the timer + * message whenever we are using an external dispatch loop. + * + * Results: + * A standard windows result. + * + * Side effects: + * Services any pending events. + * + *---------------------------------------------------------------------- + */ + +static LRESULT CALLBACK +NotifierProc( + HWND hwnd, + UINT message, + WPARAM wParam, + LPARAM lParam) +{ + + if (message != WM_TIMER) { + return DefWindowProc(hwnd, message, wParam, lParam); + } + + /* + * Process all of the runnable events. + */ + + Tcl_ServiceAll(); + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitForEvent -- + * + * This function is called by Tcl_DoOneEvent to wait for new + * events on the message queue. If the block time is 0, then + * Tcl_WaitForEvent just polls the event queue without blocking. + * + * Results: + * Returns -1 if a WM_QUIT message is detected, returns 1 if + * a message was dispatched, otherwise returns 0. + * + * Side effects: + * Dispatches a message to a window procedure, which could do + * anything. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitForEvent( + Tcl_Time *timePtr) /* Maximum block time, or NULL. */ +{ + MSG msg; + int timeout; + + if (!initialized) { + InitNotifier(); + } + + /* + * Only use the interval timer for non-zero timeouts. This avoids + * generating useless messages when we really just want to poll. + */ + + if (timePtr) { + timeout = timePtr->sec * 1000 + timePtr->usec / 1000; + } else { + timeout = 0; + } + UpdateTimer(timeout); + + if (!timePtr || (timeout != 0) + || PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { + if (!GetMessage(&msg, NULL, 0, 0)) { + + /* + * The application is exiting, so repost the quit message + * and start unwinding. + */ + + PostQuitMessage(msg.wParam); + return -1; + } + + /* + * Handle timer expiration as a special case so we don't + * claim to be doing work when we aren't. + */ + + if (msg.message == WM_TIMER && msg.hwnd == notifier.hwnd) { + return 0; + } + + TranslateMessage(&msg); + DispatchMessage(&msg); + return 1; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Sleep -- + * + * Delay execution for the specified number of milliseconds. + * + * Results: + * None. + * + * Side effects: + * Time passes. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Sleep(ms) + int ms; /* Number of milliseconds to sleep. */ +{ + Sleep(ms); +} diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c new file mode 100644 index 0000000..a7aeaf4 --- /dev/null +++ b/win/tclWinPipe.c @@ -0,0 +1,2470 @@ +/* + * tclWinPipe.c -- + * + * This file implements the Windows-specific exec pipeline functions, + * the "pipe" channel driver, and the "pid" Tcl command. + * + * Copyright (c) 1996-1997 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinPipe.c 1.49 97/11/06 17:33:03 + */ + +#include "tclWinInt.h" + +#include <dos.h> +#include <fcntl.h> +#include <io.h> +#include <sys/stat.h> + +/* + * The following variable is used to tell whether this module has been + * initialized. + */ + +static int initialized = 0; + +/* + * The following defines identify the various types of applications that + * run under windows. There is special case code for the various types. + */ + +#define APPL_NONE 0 +#define APPL_DOS 1 +#define APPL_WIN3X 2 +#define APPL_WIN32 3 + +/* + * The following constants and structures are used to encapsulate the state + * of various types of files used in a pipeline. + */ + +#define WIN32S_PIPE 1 /* Win32s emulated pipe. */ +#define WIN32S_TMPFILE 2 /* Win32s emulated temporary file. */ +#define WIN_FILE 3 /* Basic Win32 file. */ + +/* + * This structure encapsulates the common state associated with all file + * types used in a pipeline. + */ + +typedef struct WinFile { + int type; /* One of the file types defined above. */ + HANDLE handle; /* Open file handle. */ +} WinFile; + +/* + * The following structure is used to keep track of temporary files under + * Win32s and delete the disk file when the open handle is closed. + * The type field will be WIN32S_TMPFILE. + */ + +typedef struct TmpFile { + WinFile file; /* Common part. */ + char name[MAX_PATH]; /* Name of temp file. */ +} TmpFile; + +/* + * The following structure represents a synchronous pipe under Win32s. + * The type field will be WIN32S_PIPE. The handle field will refer to + * an open file when Tcl is reading from the "pipe", otherwise it is + * INVALID_HANDLE_VALUE. + */ + +typedef struct WinPipe { + WinFile file; /* Common part. */ + struct WinPipe *otherPtr; /* Pointer to the WinPipe structure that + * corresponds to the other end of this + * pipe. */ + char *fileName; /* The name of the staging file that gets + * the data written to this pipe. Malloc'd. + * and shared by both ends of the pipe. Only + * when both ends are freed will fileName be + * freed and the file it refers to deleted. */ +} WinPipe; + +/* + * This list is used to map from pids to process handles. + */ + +typedef struct ProcInfo { + HANDLE hProcess; + DWORD dwProcessId; + struct ProcInfo *nextPtr; +} ProcInfo; + +static ProcInfo *procList; + +/* + * State flags used in the PipeInfo structure below. + */ + +#define PIPE_PENDING (1<<0) /* Message is pending in the queue. */ +#define PIPE_ASYNC (1<<1) /* Channel is non-blocking. */ + +/* + * This structure describes per-instance data for a pipe based channel. + */ + +typedef struct PipeInfo { + Tcl_Channel channel; /* Pointer to channel structure. */ + int validMask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION: indicates + * which operations are valid on the file. */ + int watchMask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION: indicates + * which events should be reported. */ + int flags; /* State flags, see above for a list. */ + TclFile readFile; /* Output from pipe. */ + TclFile writeFile; /* Input from pipe. */ + TclFile errorFile; /* Error output from pipe. */ + int numPids; /* Number of processes attached to pipe. */ + Tcl_Pid *pidPtr; /* Pids of attached processes. */ + struct PipeInfo *nextPtr; /* Pointer to next registered pipe. */ +} PipeInfo; + +/* + * The following pointer refers to the head of the list of pipes + * that are being watched for file events. + */ + +static PipeInfo *firstPipePtr; + +/* + * The following structure is what is added to the Tcl event queue when + * pipe events are generated. + */ + +typedef struct PipeEvent { + Tcl_Event header; /* Information that is standard for + * all events. */ + PipeInfo *infoPtr; /* Pointer to pipe info structure. Note + * that we still have to verify that the + * pipe exists before dereferencing this + * pointer. */ +} PipeEvent; + +/* + * Declarations for functions used only in this file. + */ + +static int ApplicationType(Tcl_Interp *interp, const char *fileName, + char *fullName); +static void BuildCommandLine(int argc, char **argv, Tcl_DString *linePtr); +static void CopyChannel(HANDLE dst, HANDLE src); +static BOOL HasConsole(void); +static TclFile MakeFile(HANDLE handle); +static char * MakeTempFile(Tcl_DString *namePtr); +static int PipeBlockModeProc(ClientData instanceData, int mode); +static void PipeCheckProc _ANSI_ARGS_((ClientData clientData, + int flags)); +static int PipeCloseProc(ClientData instanceData, Tcl_Interp *interp); +static int PipeEventProc(Tcl_Event *evPtr, int flags); +static void PipeExitHandler(ClientData clientData); +static int PipeGetHandleProc(ClientData instanceData, int direction, + ClientData *handlePtr); +static void PipeInit(void); +static int PipeInputProc(ClientData instanceData, char *buf, int toRead, + int *errorCode); +static int PipeOutputProc(ClientData instanceData, char *buf, int toWrite, + int *errorCode); +static void PipeWatchProc(ClientData instanceData, int mask); +static void PipeSetupProc _ANSI_ARGS_((ClientData clientData, + int flags)); +static int TempFileName(char name[MAX_PATH]); + +/* + * This structure describes the channel type structure for command pipe + * based IO. + */ + +static Tcl_ChannelType pipeChannelType = { + "pipe", /* Type name. */ + PipeBlockModeProc, /* Set blocking or non-blocking mode.*/ + PipeCloseProc, /* Close proc. */ + PipeInputProc, /* Input proc. */ + PipeOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ + PipeWatchProc, /* Set up notifier to watch the channel. */ + PipeGetHandleProc, /* Get an OS handle from channel. */ +}; + +/* + *---------------------------------------------------------------------- + * + * PipeInit -- + * + * This function initializes the static variables for this file. + * + * Results: + * None. + * + * Side effects: + * Creates a new event source. + * + *---------------------------------------------------------------------- + */ + +static void +PipeInit() +{ + initialized = 1; + firstPipePtr = NULL; + procList = NULL; + Tcl_CreateEventSource(PipeSetupProc, PipeCheckProc, NULL); + Tcl_CreateExitHandler(PipeExitHandler, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * PipeExitHandler -- + * + * This function is called to cleanup the pipe module before + * Tcl is unloaded. + * + * Results: + * None. + * + * Side effects: + * Removes the pipe event source. + * + *---------------------------------------------------------------------- + */ + +static void +PipeExitHandler(clientData) + ClientData clientData; /* Old window proc */ +{ + Tcl_DeleteEventSource(PipeSetupProc, PipeCheckProc, NULL); + initialized = 0; +} + +/* + *---------------------------------------------------------------------- + * + * PipeSetupProc -- + * + * This procedure is invoked before Tcl_DoOneEvent blocks waiting + * for an event. + * + * Results: + * None. + * + * Side effects: + * Adjusts the block time if needed. + * + *---------------------------------------------------------------------- + */ + +void +PipeSetupProc(data, flags) + ClientData data; /* Not used. */ + int flags; /* Event flags as passed to Tcl_DoOneEvent. */ +{ + PipeInfo *infoPtr; + Tcl_Time blockTime = { 0, 0 }; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + /* + * Check to see if there is a watched pipe. If so, poll. + */ + + for (infoPtr = firstPipePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (infoPtr->watchMask) { + Tcl_SetMaxBlockTime(&blockTime); + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * PipeCheckProc -- + * + * This procedure is called by Tcl_DoOneEvent to check the pipe + * event source for events. + * + * Results: + * None. + * + * Side effects: + * May queue an event. + * + *---------------------------------------------------------------------- + */ + +static void +PipeCheckProc(data, flags) + ClientData data; /* Not used. */ + int flags; /* Event flags as passed to Tcl_DoOneEvent. */ +{ + PipeInfo *infoPtr; + PipeEvent *evPtr; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + /* + * Queue events for any watched pipes that don't already have events + * queued. + */ + + for (infoPtr = firstPipePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (infoPtr->watchMask && !(infoPtr->flags & PIPE_PENDING)) { + infoPtr->flags |= PIPE_PENDING; + evPtr = (PipeEvent *) ckalloc(sizeof(PipeEvent)); + evPtr->header.proc = PipeEventProc; + evPtr->infoPtr = infoPtr; + Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * MakeFile -- + * + * This function constructs a new TclFile from a given data and + * type value. + * + * Results: + * Returns a newly allocated WinFile as a TclFile. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static TclFile +MakeFile(handle) + HANDLE handle; /* Type-specific data. */ +{ + WinFile *filePtr; + + filePtr = (WinFile *) ckalloc(sizeof(WinFile)); + filePtr->type = WIN_FILE; + filePtr->handle = handle; + + return (TclFile)filePtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclpMakeFile -- + * + * Make a TclFile from a channel. + * + * Results: + * Returns a new TclFile or NULL on failure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclFile +TclpMakeFile(channel, direction) + Tcl_Channel channel; /* Channel to get file from. */ + int direction; /* Either TCL_READABLE or TCL_WRITABLE. */ +{ + HANDLE handle; + + if (Tcl_GetChannelHandle(channel, direction, + (ClientData *) &handle) == TCL_OK) { + return MakeFile(handle); + } else { + return (TclFile) NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * TempFileName -- + * + * Gets a temporary file name and deals with the fact that the + * temporary file path provided by Windows may not actually exist + * if the TMP or TEMP environment variables refer to a + * non-existent directory. + * + * Results: + * 0 if error, non-zero otherwise. If non-zero is returned, the + * name buffer will be filled with a name that can be used to + * construct a temporary file. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TempFileName(name) + char name[MAX_PATH]; /* Buffer in which name for temporary + * file gets stored. */ +{ + if ((GetTempPath(MAX_PATH, name) == 0) || + (GetTempFileName(name, "TCL", 0, name) == 0)) { + name[0] = '.'; + name[1] = '\0'; + if (GetTempFileName(name, "TCL", 0, name) == 0) { + return 0; + } + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclpCreateTempFile -- + * + * This function opens a unique file with the property that it + * will be deleted when its file handle is closed. The temporary + * file is created in the system temporary directory. + * + * Results: + * Returns a valid TclFile, or NULL on failure. + * + * Side effects: + * Creates a new temporary file. + * + *---------------------------------------------------------------------- + */ + +TclFile +TclpCreateTempFile(contents, namePtr) + char *contents; /* String to write into temp file, or NULL. */ + Tcl_DString *namePtr; /* If non-NULL, pointer to initialized + * DString that is filled with the name of + * the temp file that was created. */ +{ + char name[MAX_PATH]; + HANDLE handle; + + if (TempFileName(name) == 0) { + return NULL; + } + + handle = CreateFile(name, GENERIC_READ | GENERIC_WRITE, 0, NULL, + CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE, + NULL); + if (handle == INVALID_HANDLE_VALUE) { + goto error; + } + + /* + * Write the file out, doing line translations on the way. + */ + + if (contents != NULL) { + DWORD result, length; + char *p; + + for (p = contents; *p != '\0'; p++) { + if (*p == '\n') { + length = p - contents; + if (length > 0) { + if (!WriteFile(handle, contents, length, &result, NULL)) { + goto error; + } + } + if (!WriteFile(handle, "\r\n", 2, &result, NULL)) { + goto error; + } + contents = p+1; + } + } + length = p - contents; + if (length > 0) { + if (!WriteFile(handle, contents, length, &result, NULL)) { + goto error; + } + } + } + + if (SetFilePointer(handle, 0, NULL, FILE_BEGIN) == 0xFFFFFFFF) { + goto error; + } + + if (namePtr != NULL) { + Tcl_DStringAppend(namePtr, name, -1); + } + + /* + * Under Win32s a file created with FILE_FLAG_DELETE_ON_CLOSE won't + * actually be deleted when it is closed, so we have to do it ourselves. + */ + + if (TclWinGetPlatformId() == VER_PLATFORM_WIN32s) { + TmpFile *tmpFilePtr = (TmpFile *) ckalloc(sizeof(TmpFile)); + tmpFilePtr->file.type = WIN32S_TMPFILE; + tmpFilePtr->file.handle = handle; + strcpy(tmpFilePtr->name, name); + return (TclFile)tmpFilePtr; + } else { + return MakeFile(handle); + } + + error: + TclWinConvertError(GetLastError()); + CloseHandle(handle); + DeleteFile(name); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclpOpenFile -- + * + * This function opens files for use in a pipeline. + * + * Results: + * Returns a newly allocated TclFile structure containing the + * file handle. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclFile +TclpOpenFile(path, mode) + char *path; + int mode; +{ + HANDLE handle; + DWORD accessMode, createMode, shareMode, flags; + SECURITY_ATTRIBUTES sec; + + /* + * Map the access bits to the NT access mode. + */ + + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { + case O_RDONLY: + accessMode = GENERIC_READ; + break; + case O_WRONLY: + accessMode = GENERIC_WRITE; + break; + case O_RDWR: + accessMode = (GENERIC_READ | GENERIC_WRITE); + break; + default: + TclWinConvertError(ERROR_INVALID_FUNCTION); + return NULL; + } + + /* + * Map the creation flags to the NT create mode. + */ + + switch (mode & (O_CREAT | O_EXCL | O_TRUNC)) { + case (O_CREAT | O_EXCL): + case (O_CREAT | O_EXCL | O_TRUNC): + createMode = CREATE_NEW; + break; + case (O_CREAT | O_TRUNC): + createMode = CREATE_ALWAYS; + break; + case O_CREAT: + createMode = OPEN_ALWAYS; + break; + case O_TRUNC: + case (O_TRUNC | O_EXCL): + createMode = TRUNCATE_EXISTING; + break; + default: + createMode = OPEN_EXISTING; + break; + } + + /* + * If the file is not being created, use the existing file attributes. + */ + + flags = 0; + if (!(mode & O_CREAT)) { + flags = GetFileAttributes(path); + if (flags == 0xFFFFFFFF) { + flags = 0; + } + } + + /* + * Set up the security attributes so this file is not inherited by + * child processes. + */ + + sec.nLength = sizeof(sec); + sec.lpSecurityDescriptor = NULL; + sec.bInheritHandle = 0; + + /* + * Set up the file sharing mode. We want to allow simultaneous access. + */ + + shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE; + + /* + * Now we get to create the file. + */ + + handle = CreateFile(path, accessMode, shareMode, &sec, createMode, flags, + (HANDLE) NULL); + if (handle == INVALID_HANDLE_VALUE) { + DWORD err = GetLastError(); + if ((err & 0xffffL) == ERROR_OPEN_FAILED) { + err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND; + } + TclWinConvertError(err); + return NULL; + } + + /* + * Seek to the end of file if we are writing. + */ + + if (mode & O_WRONLY) { + SetFilePointer(handle, 0, NULL, FILE_END); + } + + return MakeFile(handle); +} + +/* + *---------------------------------------------------------------------- + * + * TclpCreatePipe -- + * + * Creates an anonymous pipe. Under Win32s, creates a temp file + * that is used to simulate a pipe. + * + * Results: + * Returns 1 on success, 0 on failure. + * + * Side effects: + * Creates a pipe. + * + *---------------------------------------------------------------------- + */ + +int +TclpCreatePipe(readPipe, writePipe) + TclFile *readPipe; /* Location to store file handle for + * read side of pipe. */ + TclFile *writePipe; /* Location to store file handle for + * write side of pipe. */ +{ + HANDLE readHandle, writeHandle; + + if (CreatePipe(&readHandle, &writeHandle, NULL, 0) != 0) { + *readPipe = MakeFile(readHandle); + *writePipe = MakeFile(writeHandle); + return 1; + } + + if (TclWinGetPlatformId() == VER_PLATFORM_WIN32s) { + WinPipe *readPipePtr, *writePipePtr; + char buf[MAX_PATH]; + + if (TempFileName(buf) != 0) { + readPipePtr = (WinPipe *) ckalloc(sizeof(WinPipe)); + writePipePtr = (WinPipe *) ckalloc(sizeof(WinPipe)); + + readPipePtr->file.type = WIN32S_PIPE; + readPipePtr->otherPtr = writePipePtr; + readPipePtr->fileName = strcpy(ckalloc(strlen(buf) + 1), buf); + readPipePtr->file.handle = INVALID_HANDLE_VALUE; + writePipePtr->file.type = WIN32S_PIPE; + writePipePtr->otherPtr = readPipePtr; + writePipePtr->fileName = readPipePtr->fileName; + writePipePtr->file.handle = INVALID_HANDLE_VALUE; + + *readPipe = (TclFile)readPipePtr; + *writePipe = (TclFile)writePipePtr; + + return 1; + } + } + + TclWinConvertError(GetLastError()); + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclpCloseFile -- + * + * Closes a pipeline file handle. These handles are created by + * TclpOpenFile, TclpCreatePipe, or TclpMakeFile. + * + * Results: + * 0 on success, -1 on failure. + * + * Side effects: + * The file is closed and deallocated. + * + *---------------------------------------------------------------------- + */ + +int +TclpCloseFile(file) + TclFile file; /* The file to close. */ +{ + WinFile *filePtr = (WinFile *) file; + WinPipe *pipePtr; + + switch (filePtr->type) { + case WIN_FILE: + case WIN32S_TMPFILE: + if (CloseHandle(filePtr->handle) == FALSE) { + TclWinConvertError(GetLastError()); + ckfree((char *) filePtr); + return -1; + } + /* + * Simulate deleting the file on close for Win32s. + */ + + if (filePtr->type == WIN32S_TMPFILE) { + DeleteFile(((TmpFile*)filePtr)->name); + } + break; + + case WIN32S_PIPE: + pipePtr = (WinPipe *) file; + + if (pipePtr->otherPtr != NULL) { + pipePtr->otherPtr->otherPtr = NULL; + } else { + if (pipePtr->file.handle != INVALID_HANDLE_VALUE) { + CloseHandle(pipePtr->file.handle); + } + DeleteFile(pipePtr->fileName); + ckfree((char *) pipePtr->fileName); + } + break; + + default: + panic("Tcl_CloseFile: unexpected file type"); + } + + ckfree((char *) filePtr); + return 0; +} + +/* + *-------------------------------------------------------------------------- + * + * TclpGetPid -- + * + * Given a HANDLE to a child process, return the process id for that + * child process. + * + * Results: + * Returns the process id for the child process. If the pid was not + * known by Tcl, either because the pid was not created by Tcl or the + * child process has already been reaped, -1 is returned. + * + * Side effects: + * None. + * + *-------------------------------------------------------------------------- + */ + +unsigned long +TclpGetPid(pid) + Tcl_Pid pid; /* The HANDLE of the child process. */ +{ + ProcInfo *infoPtr; + + for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (infoPtr->hProcess == (HANDLE) pid) { + return infoPtr->dwProcessId; + } + } + return (unsigned long) -1; +} + +/* + *---------------------------------------------------------------------- + * + * TclpCreateProcess -- + * + * Create a child process that has the specified files as its + * standard input, output, and error. The child process runs + * synchronously under Win32s and asynchronously under Windows NT + * and Windows 95, and runs with the same environment variables + * as the creating process. + * + * The complete Windows search path is searched to find the specified + * executable. If an executable by the given name is not found, + * automatically tries appending ".com", ".exe", and ".bat" to the + * executable name. + * + * Results: + * The return value is TCL_ERROR and an error message is left in + * interp->result if there was a problem creating the child + * process. Otherwise, the return value is TCL_OK and *pidPtr is + * filled with the process id of the child process. + * + * Side effects: + * A process is created. + * + *---------------------------------------------------------------------- + */ + +int +TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, + pidPtr) + Tcl_Interp *interp; /* Interpreter in which to leave errors that + * occurred when creating the child process. + * Error messages from the child process + * itself are sent to errorFile. */ + int argc; /* Number of arguments in following array. */ + char **argv; /* Array of argument strings. argv[0] + * contains the name of the executable + * converted to native format (using the + * Tcl_TranslateFileName call). Additional + * arguments have not been converted. */ + TclFile inputFile; /* If non-NULL, gives the file to use as + * input for the child process. If inputFile + * file is not readable or is NULL, the child + * will receive no standard input. */ + TclFile outputFile; /* If non-NULL, gives the file that + * receives output from the child process. If + * outputFile file is not writeable or is + * NULL, output from the child will be + * discarded. */ + TclFile errorFile; /* If non-NULL, gives the file that + * receives errors from the child process. If + * errorFile file is not writeable or is NULL, + * errors from the child will be discarded. + * errorFile may be the same as outputFile. */ + Tcl_Pid *pidPtr; /* If this procedure is successful, pidPtr + * is filled with the process id of the child + * process. */ +{ + int result, applType, createFlags; + Tcl_DString cmdLine; + STARTUPINFO startInfo; + PROCESS_INFORMATION procInfo; + SECURITY_ATTRIBUTES secAtts; + HANDLE hProcess, h, inputHandle, outputHandle, errorHandle; + char execPath[MAX_PATH]; + char *originalName; + WinFile *filePtr; + + if (!initialized) { + PipeInit(); + } + + applType = ApplicationType(interp, argv[0], execPath); + if (applType == APPL_NONE) { + return TCL_ERROR; + } + originalName = argv[0]; + argv[0] = execPath; + + result = TCL_ERROR; + Tcl_DStringInit(&cmdLine); + + if (TclWinGetPlatformId() == VER_PLATFORM_WIN32s) { + /* + * Under Win32s, there are no pipes. In order to simulate pipe + * behavior, the child processes are run synchronously and their + * I/O is redirected from/to temporary files before the next + * stage of the pipeline is started. + */ + + MSG msg; + DWORD status; + DWORD args[4]; + void *trans[5]; + char *inputFileName, *outputFileName; + Tcl_DString inputTempFile, outputTempFile; + + BuildCommandLine(argc, argv, &cmdLine); + + ZeroMemory(&startInfo, sizeof(startInfo)); + startInfo.cb = sizeof(startInfo); + + Tcl_DStringInit(&inputTempFile); + Tcl_DStringInit(&outputTempFile); + outputHandle = INVALID_HANDLE_VALUE; + + inputFileName = NULL; + outputFileName = NULL; + if (inputFile != NULL) { + filePtr = (WinFile *) inputFile; + switch (filePtr->type) { + case WIN_FILE: + case WIN32S_TMPFILE: { + h = INVALID_HANDLE_VALUE; + inputFileName = MakeTempFile(&inputTempFile); + if (inputFileName != NULL) { + h = CreateFile(inputFileName, GENERIC_WRITE, 0, + NULL, CREATE_ALWAYS, 0, NULL); + } + if (h == INVALID_HANDLE_VALUE) { + Tcl_AppendResult(interp, "couldn't duplicate input handle: ", + Tcl_PosixError(interp), (char *) NULL); + goto end32s; + } + CopyChannel(h, filePtr->handle); + CloseHandle(h); + break; + } + case WIN32S_PIPE: { + inputFileName = ((WinPipe*)inputFile)->fileName; + break; + } + } + } + if (inputFileName == NULL) { + inputFileName = "nul"; + } + if (outputFile != NULL) { + filePtr = (WinFile *)outputFile; + if (filePtr->type == WIN_FILE) { + outputFileName = MakeTempFile(&outputTempFile); + if (outputFileName == NULL) { + Tcl_AppendResult(interp, "couldn't duplicate output handle: ", + Tcl_PosixError(interp), (char *) NULL); + goto end32s; + } + outputHandle = filePtr->handle; + } else if (filePtr->type == WIN32S_PIPE) { + outputFileName = ((WinPipe*)outputFile)->fileName; + } + } + if (outputFileName == NULL) { + outputFileName = "nul"; + } + + if (applType == APPL_DOS) { + args[0] = (DWORD) Tcl_DStringValue(&cmdLine); + args[1] = (DWORD) inputFileName; + args[2] = (DWORD) outputFileName; + trans[0] = &args[0]; + trans[1] = &args[1]; + trans[2] = &args[2]; + trans[3] = NULL; + if (TclWinSynchSpawn(args, 0, trans, pidPtr) != 0) { + result = TCL_OK; + } + } else if (applType == APPL_WIN3X) { + args[0] = (DWORD) Tcl_DStringValue(&cmdLine); + trans[0] = &args[0]; + trans[1] = NULL; + if (TclWinSynchSpawn(args, 1, trans, pidPtr) != 0) { + result = TCL_OK; + } + } else { + if (CreateProcess(NULL, Tcl_DStringValue(&cmdLine), NULL, NULL, + FALSE, DETACHED_PROCESS, NULL, NULL, &startInfo, + &procInfo) != 0) { + CloseHandle(procInfo.hThread); + while (1) { + if (GetExitCodeProcess(procInfo.hProcess, &status) == FALSE) { + break; + } + if (status != STILL_ACTIVE) { + break; + } + if (PeekMessage(&msg, NULL, 0, 0, PM_REMOVE) == TRUE) { + TranslateMessage(&msg); + DispatchMessage(&msg); + } + } + *pidPtr = (Tcl_Pid) procInfo.hProcess; + if (*pidPtr != 0) { + ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo)); + procPtr->hProcess = procInfo.hProcess; + procPtr->dwProcessId = procInfo.dwProcessId; + procPtr->nextPtr = procList; + procList = procPtr; + } + result = TCL_OK; + } + } + if (result != TCL_OK) { + TclWinConvertError(GetLastError()); + Tcl_AppendResult(interp, "couldn't execute \"", originalName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + } + + end32s: + if (outputHandle != INVALID_HANDLE_VALUE) { + /* + * Now copy stuff from temp file to actual output handle. Don't + * close outputHandle because it is associated with the output + * file owned by the caller. + */ + + h = CreateFile(outputFileName, GENERIC_READ, 0, NULL, OPEN_ALWAYS, + 0, NULL); + if (h != INVALID_HANDLE_VALUE) { + CopyChannel(outputHandle, h); + } + CloseHandle(h); + } + + if (inputFileName == Tcl_DStringValue(&inputTempFile)) { + DeleteFile(inputFileName); + } + + if (outputFileName == Tcl_DStringValue(&outputTempFile)) { + DeleteFile(outputFileName); + } + + Tcl_DStringFree(&inputTempFile); + Tcl_DStringFree(&outputTempFile); + Tcl_DStringFree(&cmdLine); + return result; + } + hProcess = GetCurrentProcess(); + + /* + * STARTF_USESTDHANDLES must be used to pass handles to child process. + * Using SetStdHandle() and/or dup2() only works when a console mode + * parent process is spawning an attached console mode child process. + */ + + ZeroMemory(&startInfo, sizeof(startInfo)); + startInfo.cb = sizeof(startInfo); + startInfo.dwFlags = STARTF_USESTDHANDLES; + startInfo.hStdInput = INVALID_HANDLE_VALUE; + startInfo.hStdOutput= INVALID_HANDLE_VALUE; + startInfo.hStdError = INVALID_HANDLE_VALUE; + + secAtts.nLength = sizeof(SECURITY_ATTRIBUTES); + secAtts.lpSecurityDescriptor = NULL; + secAtts.bInheritHandle = TRUE; + + /* + * We have to check the type of each file, since we cannot duplicate + * some file types. + */ + + inputHandle = INVALID_HANDLE_VALUE; + if (inputFile != NULL) { + filePtr = (WinFile *)inputFile; + if (filePtr->type == WIN_FILE) { + inputHandle = filePtr->handle; + } + } + outputHandle = INVALID_HANDLE_VALUE; + if (outputFile != NULL) { + filePtr = (WinFile *)outputFile; + if (filePtr->type == WIN_FILE) { + outputHandle = filePtr->handle; + } + } + errorHandle = INVALID_HANDLE_VALUE; + if (errorFile != NULL) { + filePtr = (WinFile *)errorFile; + if (filePtr->type == WIN_FILE) { + errorHandle = filePtr->handle; + } + } + + /* + * Duplicate all the handles which will be passed off as stdin, stdout + * and stderr of the child process. The duplicate handles are set to + * be inheritable, so the child process can use them. + */ + + if (inputHandle == INVALID_HANDLE_VALUE) { + /* + * If handle was not set, stdin should return immediate EOF. + * Under Windows95, some applications (both 16 and 32 bit!) + * cannot read from the NUL device; they read from console + * instead. When running tk, this is fatal because the child + * process would hang forever waiting for EOF from the unmapped + * console window used by the helper application. + * + * Fortunately, the helper application detects a closed pipe + * as an immediate EOF and can pass that information to the + * child process. + */ + + if (CreatePipe(&startInfo.hStdInput, &h, &secAtts, 0) != FALSE) { + CloseHandle(h); + } + } else { + DuplicateHandle(hProcess, inputHandle, hProcess, &startInfo.hStdInput, + 0, TRUE, DUPLICATE_SAME_ACCESS); + } + if (startInfo.hStdInput == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + Tcl_AppendResult(interp, "couldn't duplicate input handle: ", + Tcl_PosixError(interp), (char *) NULL); + goto end; + } + + if (outputHandle == INVALID_HANDLE_VALUE) { + /* + * If handle was not set, output should be sent to an infinitely + * deep sink. Under Windows 95, some 16 bit applications cannot + * have stdout redirected to NUL; they send their output to + * the console instead. Some applications, like "more" or "dir /p", + * when outputting multiple pages to the console, also then try and + * read from the console to go the next page. When running tk, this + * is fatal because the child process would hang forever waiting + * for input from the unmapped console window used by the helper + * application. + * + * Fortunately, the helper application will detect a closed pipe + * as a sink. + */ + + if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) + && (applType == APPL_DOS)) { + if (CreatePipe(&h, &startInfo.hStdOutput, &secAtts, 0) != FALSE) { + CloseHandle(h); + } + } else { + startInfo.hStdOutput = CreateFile("NUL:", GENERIC_WRITE, 0, + &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); + } + } else { + DuplicateHandle(hProcess, outputHandle, hProcess, &startInfo.hStdOutput, + 0, TRUE, DUPLICATE_SAME_ACCESS); + } + if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + Tcl_AppendResult(interp, "couldn't duplicate output handle: ", + Tcl_PosixError(interp), (char *) NULL); + goto end; + } + + if (errorHandle == INVALID_HANDLE_VALUE) { + /* + * If handle was not set, errors should be sent to an infinitely + * deep sink. + */ + + startInfo.hStdError = CreateFile("NUL:", GENERIC_WRITE, 0, + &secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + } else { + DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError, + 0, TRUE, DUPLICATE_SAME_ACCESS); + } + if (startInfo.hStdError == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + Tcl_AppendResult(interp, "couldn't duplicate error handle: ", + Tcl_PosixError(interp), (char *) NULL); + goto end; + } + /* + * If we do not have a console window, then we must run DOS and + * WIN32 console mode applications as detached processes. This tells + * the loader that the child application should not inherit the + * console, and that it should not create a new console window for + * the child application. The child application should get its stdio + * from the redirection handles provided by this application, and run + * in the background. + * + * If we are starting a GUI process, they don't automatically get a + * console, so it doesn't matter if they are started as foreground or + * detached processes. The GUI window will still pop up to the + * foreground. + */ + + if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) { + if (HasConsole()) { + createFlags = 0; + } else if (applType == APPL_DOS) { + /* + * Under NT, 16-bit DOS applications will not run unless they + * can be attached to a console. If we are running without a + * console, run the 16-bit program as an normal process inside + * of a hidden console application, and then run that hidden + * console as a detached process. + */ + + startInfo.wShowWindow = SW_HIDE; + startInfo.dwFlags |= STARTF_USESHOWWINDOW; + createFlags = CREATE_NEW_CONSOLE; + Tcl_DStringAppend(&cmdLine, "cmd.exe /c ", -1); + } else { + createFlags = DETACHED_PROCESS; + } + } else { + if (HasConsole()) { + createFlags = 0; + } else { + createFlags = DETACHED_PROCESS; + } + + if (applType == APPL_DOS) { + /* + * Under Windows 95, 16-bit DOS applications do not work well + * with pipes: + * + * 1. EOF on a pipe between a detached 16-bit DOS application + * and another application is not seen at the other + * end of the pipe, so the listening process blocks forever on + * reads. This inablity to detect EOF happens when either a + * 16-bit app or the 32-bit app is the listener. + * + * 2. If a 16-bit DOS application (detached or not) blocks when + * writing to a pipe, it will never wake up again, and it + * eventually brings the whole system down around it. + * + * The 16-bit application is run as a normal process inside + * of a hidden helper console app, and this helper may be run + * as a detached process. If any of the stdio handles is + * a pipe, the helper application accumulates information + * into temp files and forwards it to or from the DOS + * application as appropriate. This means that DOS apps + * must receive EOF from a stdin pipe before they will actually + * begin, and must finish generating stdout or stderr before + * the data will be sent to the next stage of the pipe. + * + * The helper app should be located in the same directory as + * the tcl dll. + */ + + if (createFlags != 0) { + startInfo.wShowWindow = SW_HIDE; + startInfo.dwFlags |= STARTF_USESHOWWINDOW; + createFlags = CREATE_NEW_CONSOLE; + } + Tcl_DStringAppend(&cmdLine, "tclpip" STRINGIFY(TCL_MAJOR_VERSION) + STRINGIFY(TCL_MINOR_VERSION) ".dll ", -1); + } + } + + /* + * cmdLine gets the full command line used to invoke the executable, + * including the name of the executable itself. The command line + * arguments in argv[] are stored in cmdLine separated by spaces. + * Special characters in individual arguments from argv[] must be + * quoted when being stored in cmdLine. + * + * When calling any application, bear in mind that arguments that + * specify a path name are not converted. If an argument contains + * forward slashes as path separators, it may or may not be + * recognized as a path name, depending on the program. In general, + * most applications accept forward slashes only as option + * delimiters and backslashes only as paths. + * + * Additionally, when calling a 16-bit dos or windows application, + * all path names must use the short, cryptic, path format (e.g., + * using ab~1.def instead of "a b.default"). + */ + + BuildCommandLine(argc, argv, &cmdLine); + + if (!CreateProcess(NULL, Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE, + createFlags, NULL, NULL, &startInfo, &procInfo)) { + TclWinConvertError(GetLastError()); + Tcl_AppendResult(interp, "couldn't execute \"", originalName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto end; + } + + if (applType == APPL_DOS) { + WaitForSingleObject(hProcess, 50); + } + + /* + * "When an application spawns a process repeatedly, a new thread + * instance will be created for each process but the previous + * instances may not be cleaned up. This results in a significant + * virtual memory loss each time the process is spawned. If there + * is a WaitForInputIdle() call between CreateProcess() and + * CloseHandle(), the problem does not occur." PSS ID Number: Q124121 + */ + + WaitForInputIdle(procInfo.hProcess, 5000); + CloseHandle(procInfo.hThread); + + *pidPtr = (Tcl_Pid) procInfo.hProcess; + if (*pidPtr != 0) { + ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo)); + procPtr->hProcess = procInfo.hProcess; + procPtr->dwProcessId = procInfo.dwProcessId; + procPtr->nextPtr = procList; + procList = procPtr; + } + result = TCL_OK; + + end: + Tcl_DStringFree(&cmdLine); + if (startInfo.hStdInput != INVALID_HANDLE_VALUE) { + CloseHandle(startInfo.hStdInput); + } + if (startInfo.hStdOutput != INVALID_HANDLE_VALUE) { + CloseHandle(startInfo.hStdOutput); + } + if (startInfo.hStdError != INVALID_HANDLE_VALUE) { + CloseHandle(startInfo.hStdError); + } + return result; +} + + +/* + *---------------------------------------------------------------------- + * + * HasConsole -- + * + * Determines whether the current application is attached to a + * console. + * + * Results: + * Returns TRUE if this application has a console, else FALSE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static BOOL +HasConsole() +{ + HANDLE handle = CreateFile("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, + NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + + if (handle != INVALID_HANDLE_VALUE) { + CloseHandle(handle); + return TRUE; + } else { + return FALSE; + } +} + +/* + *-------------------------------------------------------------------- + * + * ApplicationType -- + * + * Search for the specified program and identify if it refers to a DOS, + * Windows 3.X, or Win32 program. Used to determine how to invoke + * a program, or if it can even be invoked. + * + * It is possible to almost positively identify DOS and Windows + * applications that contain the appropriate magic numbers. However, + * DOS .com files do not seem to contain a magic number; if the program + * name ends with .com and could not be identified as a Windows .com + * file, it will be assumed to be a DOS application, even if it was + * just random data. If the program name does not end with .com, no + * such assumption is made. + * + * The Win32 procedure GetBinaryType incorrectly identifies any + * junk file that ends with .exe as a dos executable and some + * executables that don't end with .exe as not executable. Plus it + * doesn't exist under win95, so I won't feel bad about reimplementing + * functionality. + * + * Results: + * The return value is one of APPL_DOS, APPL_WIN3X, or APPL_WIN32 + * if the filename referred to the corresponding application type. + * If the file name could not be found or did not refer to any known + * application type, APPL_NONE is returned and an error message is + * left in interp. .bat files are identified as APPL_DOS. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ApplicationType(interp, originalName, fullPath) + Tcl_Interp *interp; /* Interp, for error message. */ + const char *originalName; /* Name of the application to find. */ + char fullPath[MAX_PATH]; /* Filled with complete path to + * application. */ +{ + int applType, i; + HANDLE hFile; + char *ext, *rest; + char buf[2]; + DWORD read; + IMAGE_DOS_HEADER header; + static char extensions[][5] = {"", ".com", ".exe", ".bat"}; + + /* Look for the program as an external program. First try the name + * as it is, then try adding .com, .exe, and .bat, in that order, to + * the name, looking for an executable. + * + * Using the raw SearchPath() procedure doesn't do quite what is + * necessary. If the name of the executable already contains a '.' + * character, it will not try appending the specified extension when + * searching (in other words, SearchPath will not find the program + * "a.b.exe" if the arguments specified "a.b" and ".exe"). + * So, first look for the file as it is named. Then manually append + * the extensions, looking for a match. + */ + + applType = APPL_NONE; + for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) { + lstrcpyn(fullPath, originalName, MAX_PATH - 5); + lstrcat(fullPath, extensions[i]); + + SearchPath(NULL, fullPath, NULL, MAX_PATH, fullPath, &rest); + + /* + * Ignore matches on directories or data files, return if identified + * a known type. + */ + + if (GetFileAttributes(fullPath) & FILE_ATTRIBUTE_DIRECTORY) { + continue; + } + + ext = strrchr(fullPath, '.'); + if ((ext != NULL) && (strcmpi(ext, ".bat") == 0)) { + applType = APPL_DOS; + break; + } + + hFile = CreateFile(fullPath, GENERIC_READ, FILE_SHARE_READ, NULL, + OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + if (hFile == INVALID_HANDLE_VALUE) { + continue; + } + + header.e_magic = 0; + ReadFile(hFile, (void *) &header, sizeof(header), &read, NULL); + if (header.e_magic != IMAGE_DOS_SIGNATURE) { + /* + * Doesn't have the magic number for relocatable executables. If + * filename ends with .com, assume it's a DOS application anyhow. + * Note that we didn't make this assumption at first, because some + * supposed .com files are really 32-bit executables with all the + * magic numbers and everything. + */ + + CloseHandle(hFile); + if ((ext != NULL) && (strcmpi(ext, ".com") == 0)) { + applType = APPL_DOS; + break; + } + continue; + } + if (header.e_lfarlc != sizeof(header)) { + /* + * All Windows 3.X and Win32 and some DOS programs have this value + * set here. If it doesn't, assume that since it already had the + * other magic number it was a DOS application. + */ + + CloseHandle(hFile); + applType = APPL_DOS; + break; + } + + /* + * The DWORD at header.e_lfanew points to yet another magic number. + */ + + buf[0] = '\0'; + SetFilePointer(hFile, header.e_lfanew, NULL, FILE_BEGIN); + ReadFile(hFile, (void *) buf, 2, &read, NULL); + CloseHandle(hFile); + + if ((buf[0] == 'N') && (buf[1] == 'E')) { + applType = APPL_WIN3X; + } else if ((buf[0] == 'P') && (buf[1] == 'E')) { + applType = APPL_WIN32; + } else { + /* + * Strictly speaking, there should be a test that there + * is an 'L' and 'E' at buf[0..1], to identify the type as + * DOS, but of course we ran into a DOS executable that + * _doesn't_ have the magic number -- specifically, one + * compiled using the Lahey Fortran90 compiler. + */ + + applType = APPL_DOS; + } + break; + } + + if (applType == APPL_NONE) { + TclWinConvertError(GetLastError()); + Tcl_AppendResult(interp, "couldn't execute \"", originalName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + return APPL_NONE; + } + + if ((applType == APPL_DOS) || (applType == APPL_WIN3X)) { + /* + * Replace long path name of executable with short path name for + * 16-bit applications. Otherwise the application may not be able + * to correctly parse its own command line to separate off the + * application name from the arguments. + */ + + GetShortPathName(fullPath, fullPath, MAX_PATH); + } + return applType; +} + +/* + *---------------------------------------------------------------------- + * + * BuildCommandLine -- + * + * The command line arguments are stored in linePtr separated + * by spaces, in a form that CreateProcess() understands. Special + * characters in individual arguments from argv[] must be quoted + * when being stored in cmdLine. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +BuildCommandLine(argc, argv, linePtr) + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ + Tcl_DString *linePtr; /* Initialized Tcl_DString that receives the + * command line. */ +{ + char *start, *special; + int quote, i; + + for (i = 0; i < argc; i++) { + if (i > 0) { + Tcl_DStringAppend(linePtr, " ", 1); + } + + quote = 0; + for (start = argv[i]; *start != '\0'; start++) { + if (isspace(*start)) { + quote = 1; + Tcl_DStringAppend(linePtr, "\"", 1); + break; + } + } + + start = argv[i]; + for (special = argv[i]; ; ) { + if ((*special == '\\') && + (special[1] == '\\' || special[1] == '"')) { + Tcl_DStringAppend(linePtr, start, special - start); + start = special; + while (1) { + special++; + if (*special == '"') { + /* + * N backslashes followed a quote -> insert + * N * 2 + 1 backslashes then a quote. + */ + + Tcl_DStringAppend(linePtr, start, special - start); + break; + } + if (*special != '\\') { + break; + } + } + Tcl_DStringAppend(linePtr, start, special - start); + start = special; + } + if (*special == '"') { + Tcl_DStringAppend(linePtr, start, special - start); + Tcl_DStringAppend(linePtr, "\\\"", 2); + start = special + 1; + } + if (*special == '\0') { + break; + } + special++; + } + Tcl_DStringAppend(linePtr, start, special - start); + if (quote) { + Tcl_DStringAppend(linePtr, "\"", 1); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * MakeTempFile -- + * + * Helper function for TclpCreateProcess under Win32s. Makes a + * temporary file that _won't_ go away automatically when it's file + * handle is closed. Used for simulated pipes, which are written + * in one pass and reopened and read in the next pass. + * + * Results: + * namePtr is filled with the name of the temporary file. + * + * Side effects: + * A temporary file with the name specified by namePtr is created. + * The caller is responsible for deleting this temporary file. + * + *---------------------------------------------------------------------- + */ + +static char * +MakeTempFile(namePtr) + Tcl_DString *namePtr; /* Initialized Tcl_DString that is filled + * with the name of the temporary file that + * was created. */ +{ + char name[MAX_PATH]; + + if (TempFileName(name) == 0) { + return NULL; + } + + Tcl_DStringAppend(namePtr, name, -1); + return Tcl_DStringValue(namePtr); +} + +/* + *---------------------------------------------------------------------- + * + * CopyChannel -- + * + * Helper function used by TclpCreateProcess under Win32s. Copies + * what remains of source file to destination file; source file + * pointer need not be positioned at the beginning of the file if + * all of source file is not desired, but data is copied up to end + * of source file. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +CopyChannel(dst, src) + HANDLE dst; /* Destination file. */ + HANDLE src; /* Source file. */ +{ + char buf[8192]; + DWORD dwRead, dwWrite; + + while (ReadFile(src, buf, sizeof(buf), &dwRead, NULL) != FALSE) { + if (dwRead == 0) { + break; + } + if (WriteFile(dst, buf, dwRead, &dwWrite, NULL) == FALSE) { + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpCreateCommandChannel -- + * + * This function is called by Tcl_OpenCommandChannel to perform + * the platform specific channel initialization for a command + * channel. + * + * Results: + * Returns a new channel or NULL on failure. + * + * Side effects: + * Allocates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) + TclFile readFile; /* If non-null, gives the file for reading. */ + TclFile writeFile; /* If non-null, gives the file for writing. */ + TclFile errorFile; /* If non-null, gives the file where errors + * can be read. */ + int numPids; /* The number of pids in the pid array. */ + Tcl_Pid *pidPtr; /* An array of process identifiers. */ +{ + char channelName[20]; + int channelId; + PipeInfo *infoPtr = (PipeInfo *) ckalloc((unsigned) sizeof(PipeInfo)); + + if (!initialized) { + PipeInit(); + } + + infoPtr->watchMask = 0; + infoPtr->flags = 0; + infoPtr->readFile = readFile; + infoPtr->writeFile = writeFile; + infoPtr->errorFile = errorFile; + infoPtr->numPids = numPids; + infoPtr->pidPtr = pidPtr; + + /* + * Use one of the fds associated with the channel as the + * channel id. + */ + + if (readFile) { + WinPipe *pipePtr = (WinPipe *) readFile; + if (pipePtr->file.type == WIN32S_PIPE + && pipePtr->file.handle == INVALID_HANDLE_VALUE) { + pipePtr->file.handle = CreateFile(pipePtr->fileName, GENERIC_READ, + 0, NULL, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); + } + channelId = (int) pipePtr->file.handle; + } else if (writeFile) { + channelId = (int) ((WinFile*)writeFile)->handle; + } else if (errorFile) { + channelId = (int) ((WinFile*)errorFile)->handle; + } else { + channelId = 0; + } + + infoPtr->validMask = 0; + if (readFile != NULL) { + infoPtr->validMask |= TCL_READABLE; + } + if (writeFile != NULL) { + infoPtr->validMask |= TCL_WRITABLE; + } + + /* + * For backward compatibility with previous versions of Tcl, we + * use "file%d" as the base name for pipes even though it would + * be more natural to use "pipe%d". + */ + + sprintf(channelName, "file%d", channelId); + infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, + (ClientData) infoPtr, infoPtr->validMask); + + /* + * Pipes have AUTO translation mode on Windows and ^Z eof char, which + * means that a ^Z will be appended to them at close. This is needed + * for Windows programs that expect a ^Z at EOF. + */ + + Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel, + "-translation", "auto"); + Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel, + "-eofchar", "\032 {}"); + return infoPtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetAndDetachPids -- + * + * Stores a list of the command PIDs for a command channel in + * interp->result. + * + * Results: + * None. + * + * Side effects: + * Modifies interp->result. + * + *---------------------------------------------------------------------- + */ + +void +TclGetAndDetachPids(interp, chan) + Tcl_Interp *interp; + Tcl_Channel chan; +{ + PipeInfo *pipePtr; + Tcl_ChannelType *chanTypePtr; + int i; + char buf[20]; + + /* + * Punt if the channel is not a command channel. + */ + + chanTypePtr = Tcl_GetChannelType(chan); + if (chanTypePtr != &pipeChannelType) { + return; + } + + pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); + for (i = 0; i < pipePtr->numPids; i++) { + sprintf(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i])); + Tcl_AppendElement(interp, buf); + Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); + } + if (pipePtr->numPids > 0) { + ckfree((char *) pipePtr->pidPtr); + pipePtr->numPids = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * PipeBlockModeProc -- + * + * Set blocking or non-blocking mode on channel. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + +static int +PipeBlockModeProc(instanceData, mode) + ClientData instanceData; /* Instance data for channel. */ + int mode; /* TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + PipeInfo *infoPtr = (PipeInfo *) instanceData; + + /* + * Pipes on Windows can not be switched between blocking and nonblocking, + * hence we have to emulate the behavior. This is done in the input + * function by checking against a bit in the state. We set or unset the + * bit here to cause the input function to emulate the correct behavior. + */ + + if (mode == TCL_MODE_NONBLOCKING) { + infoPtr->flags |= PIPE_ASYNC; + } else { + infoPtr->flags &= ~(PIPE_ASYNC); + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * PipeCloseProc -- + * + * Closes a pipe based IO channel. + * + * Results: + * 0 on success, errno otherwise. + * + * Side effects: + * Closes the physical channel. + * + *---------------------------------------------------------------------- + */ + +static int +PipeCloseProc(instanceData, interp) + ClientData instanceData; /* Pointer to PipeInfo structure. */ + Tcl_Interp *interp; /* For error reporting. */ +{ + PipeInfo *pipePtr = (PipeInfo *) instanceData; + Tcl_Channel errChan; + int errorCode, result; + PipeInfo *infoPtr, **nextPtrPtr; + + /* + * Remove the file from the list of watched files. + */ + + for (nextPtrPtr = &firstPipePtr, infoPtr = *nextPtrPtr; infoPtr != NULL; + nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) { + if (infoPtr == (PipeInfo *)pipePtr) { + *nextPtrPtr = infoPtr->nextPtr; + break; + } + } + + errorCode = 0; + if (pipePtr->readFile != NULL) { + if (TclpCloseFile(pipePtr->readFile) != 0) { + errorCode = errno; + } + } + if (pipePtr->writeFile != NULL) { + if (TclpCloseFile(pipePtr->writeFile) != 0) { + if (errorCode == 0) { + errorCode = errno; + } + } + } + + /* + * Wrap the error file into a channel and give it to the cleanup + * routine. If we are running in Win32s, just delete the error file + * immediately, because it was never used. + */ + + if (pipePtr->errorFile) { + WinFile *filePtr; + OSVERSIONINFO os; + + os.dwOSVersionInfoSize = sizeof(os); + GetVersionEx(&os); + if (os.dwPlatformId == VER_PLATFORM_WIN32s) { + TclpCloseFile(pipePtr->errorFile); + errChan = NULL; + } else { + filePtr = (WinFile*)pipePtr->errorFile; + errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle, + TCL_READABLE); + } + } else { + errChan = NULL; + } + result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, + errChan); + if (pipePtr->numPids > 0) { + ckfree((char *) pipePtr->pidPtr); + } + ckfree((char*) pipePtr); + + if (errorCode == 0) { + return result; + } + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * PipeInputProc -- + * + * Reads input from the IO channel into the buffer given. Returns + * count of how many bytes were actually read, and an error indication. + * + * Results: + * A count of how many bytes were read is returned and an error + * indication is returned in an output argument. + * + * Side effects: + * Reads input from the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +PipeInputProc(instanceData, buf, bufSize, errorCode) + ClientData instanceData; /* Pipe state. */ + char *buf; /* Where to store data read. */ + int bufSize; /* How much space is available + * in the buffer? */ + int *errorCode; /* Where to store error code. */ +{ + PipeInfo *infoPtr = (PipeInfo *) instanceData; + WinFile *filePtr = (WinFile*) infoPtr->readFile; + DWORD count; + DWORD bytesRead; + + *errorCode = 0; + if (filePtr->type == WIN32S_PIPE) { + if (((WinPipe *)filePtr)->otherPtr != NULL) { + panic("PipeInputProc: child process isn't finished writing"); + } + if (filePtr->handle == INVALID_HANDLE_VALUE) { + filePtr->handle = CreateFile(((WinPipe *)filePtr)->fileName, + GENERIC_READ, 0, NULL, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, + NULL); + } + if (filePtr->handle == INVALID_HANDLE_VALUE) { + goto error; + } + } else { + /* + * Pipes will block until the requested number of bytes has been + * read. To avoid blocking unnecessarily, we look ahead and only + * read as much as is available. + */ + + if (PeekNamedPipe(filePtr->handle, (LPVOID) NULL, (DWORD) 0, + (LPDWORD) NULL, &count, (LPDWORD) NULL) == TRUE) { + if ((count != 0) && ((DWORD) bufSize > count)) { + bufSize = (int) count; + + /* + * This code is commented out because on Win95 we don't get + * notifier of eof on a pipe unless we try to read it. + * The correct solution is to move to threads. + */ + +/* } else if ((count == 0) && (infoPtr->flags & PIPE_ASYNC)) { */ +/* errno = *errorCode = EAGAIN; */ +/* return -1; */ + } else if ((count == 0) && !(infoPtr->flags & PIPE_ASYNC)) { + bufSize = 1; + } + } else { + goto error; + } + } + + /* + * Note that we will block on reads from a console buffer until a + * full line has been entered. The only way I know of to get + * around this is to write a console driver. We should probably + * do this at some point, but for now, we just block. + */ + + if (ReadFile(filePtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead, + (LPOVERLAPPED) NULL) == FALSE) { + goto error; + } + + return bytesRead; + + error: + TclWinConvertError(GetLastError()); + if (errno == EPIPE) { + return 0; + } + *errorCode = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * PipeOutputProc -- + * + * Writes the given output on the IO channel. Returns count of how + * many characters were actually written, and an error indication. + * + * Results: + * A count of how many characters were written is returned and an + * error indication is returned in an output argument. + * + * Side effects: + * Writes output on the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +PipeOutputProc(instanceData, buf, toWrite, errorCode) + ClientData instanceData; /* Pipe state. */ + char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCode; /* Where to store error code. */ +{ + PipeInfo *infoPtr = (PipeInfo *) instanceData; + WinFile *filePtr = (WinFile*) infoPtr->writeFile; + DWORD bytesWritten; + + *errorCode = 0; + if (WriteFile(filePtr->handle, (LPVOID) buf, (DWORD) toWrite, + &bytesWritten, (LPOVERLAPPED) NULL) == FALSE) { + TclWinConvertError(GetLastError()); + if (errno == EPIPE) { + return 0; + } + *errorCode = errno; + return -1; + } + return bytesWritten; +} + +/* + *---------------------------------------------------------------------- + * + * PipeEventProc -- + * + * This function is invoked by Tcl_ServiceEvent when a file event + * reaches the front of the event queue. This procedure invokes + * Tcl_NotifyChannel on the pipe. + * + * Results: + * Returns 1 if the event was handled, meaning it should be removed + * from the queue. Returns 0 if the event was not handled, meaning + * it should stay on the queue. The only time the event isn't + * handled is if the TCL_FILE_EVENTS flag bit isn't set. + * + * Side effects: + * Whatever the notifier callback does. + * + *---------------------------------------------------------------------- + */ + +static int +PipeEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_FILE_EVENTS. */ +{ + PipeEvent *pipeEvPtr = (PipeEvent *)evPtr; + PipeInfo *infoPtr; + WinFile *filePtr; + int mask; +/* DWORD count;*/ + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } + + /* + * Search through the list of watched pipes for the one whose handle + * matches the event. We do this rather than simply dereferencing + * the handle in the event so that pipes can be deleted while the + * event is in the queue. + */ + + for (infoPtr = firstPipePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (pipeEvPtr->infoPtr == infoPtr) { + infoPtr->flags &= ~(PIPE_PENDING); + break; + } + } + + /* + * Remove stale events. + */ + + if (!infoPtr) { + return 1; + } + + /* + * If we aren't on Win32s, check to see if the pipe is readable. Note + * that we can't tell if a pipe is writable, so we always report it + * as being writable. + */ + + filePtr = (WinFile*) ((PipeInfo*)infoPtr)->readFile; + if (filePtr->type != WIN32S_PIPE) { + + /* + * On windows 95, PeekNamedPipe returns 0 on eof so we can't + * distinguish underflow from eof. The correct solution is to + * switch to the threaded implementation. + */ + mask = TCL_WRITABLE|TCL_READABLE; +/* if (PeekNamedPipe(filePtr->handle, (LPVOID) NULL, (DWORD) 0, */ +/* (LPDWORD) NULL, &count, (LPDWORD) NULL) == TRUE) { */ +/* if (count != 0) { */ +/* mask |= TCL_READABLE; */ +/* } */ +/* } else { */ + + /* + * If the pipe has been closed by the other side, then + * mark the pipe as readable, but not writable. + */ + +/* if (GetLastError() == ERROR_BROKEN_PIPE) { */ +/* mask = TCL_READABLE; */ +/* } */ +/* } */ + } else { + mask = TCL_READABLE | TCL_WRITABLE; + } + + /* + * Inform the channel of the events. + */ + + Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask); + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * PipeWatchProc -- + * + * Called by the notifier to set up to watch for events on this + * channel. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +PipeWatchProc(instanceData, mask) + ClientData instanceData; /* Pipe state. */ + int mask; /* What events to watch for; OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + PipeInfo **nextPtrPtr, *ptr; + PipeInfo *infoPtr = (PipeInfo *) instanceData; + int oldMask = infoPtr->watchMask; + + /* + * For now, we just send a message to ourselves so we can poll the + * channel for readable events. + */ + + infoPtr->watchMask = mask & infoPtr->validMask; + if (infoPtr->watchMask) { + Tcl_Time blockTime = { 0, 0 }; + if (!oldMask) { + infoPtr->nextPtr = firstPipePtr; + firstPipePtr = infoPtr; + } + Tcl_SetMaxBlockTime(&blockTime); + } else { + if (oldMask) { + /* + * Remove the pipe from the list of watched pipes. + */ + + for (nextPtrPtr = &firstPipePtr, ptr = *nextPtrPtr; + ptr != NULL; + nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) { + if (infoPtr == ptr) { + *nextPtrPtr = ptr->nextPtr; + break; + } + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * PipeGetHandleProc -- + * + * Called from Tcl_GetChannelHandle to retrieve OS handles from + * inside a command pipeline based channel. + * + * Results: + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if + * there is no handle for the specified direction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +PipeGetHandleProc(instanceData, direction, handlePtr) + ClientData instanceData; /* The pipe state. */ + int direction; /* TCL_READABLE or TCL_WRITABLE */ + ClientData *handlePtr; /* Where to store the handle. */ +{ + PipeInfo *infoPtr = (PipeInfo *) instanceData; + WinFile *filePtr; + + if (direction == TCL_READABLE && infoPtr->readFile) { + filePtr = (WinFile*) infoPtr->readFile; + if (filePtr->type == WIN32S_PIPE) { + if (filePtr->handle == INVALID_HANDLE_VALUE) { + filePtr->handle = CreateFile(((WinPipe *)filePtr)->fileName, + GENERIC_READ, 0, NULL, OPEN_ALWAYS, + FILE_ATTRIBUTE_NORMAL, NULL); + } + if (filePtr->handle == INVALID_HANDLE_VALUE) { + return TCL_ERROR; + } + } + *handlePtr = (ClientData) filePtr->handle; + return TCL_OK; + } + if (direction == TCL_WRITABLE && infoPtr->writeFile) { + filePtr = (WinFile*) infoPtr->writeFile; + *handlePtr = (ClientData) filePtr->handle; + return TCL_OK; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitPid -- + * + * Emulates the waitpid system call. + * + * Results: + * Returns 0 if the process is still alive, -1 on an error, or + * the pid on a clean close. + * + * Side effects: + * Unless WNOHANG is set and the wait times out, the process + * information record will be deleted and the process handle + * will be closed. + * + *---------------------------------------------------------------------- + */ + +Tcl_Pid +Tcl_WaitPid(pid, statPtr, options) + Tcl_Pid pid; + int *statPtr; + int options; +{ + ProcInfo *infoPtr, **prevPtrPtr; + int flags; + Tcl_Pid result; + DWORD ret; + + if (!initialized) { + PipeInit(); + } + + /* + * If no pid is specified, do nothing. + */ + + if (pid == 0) { + *statPtr = 0; + return 0; + } + + /* + * Find the process on the process list. + */ + + prevPtrPtr = &procList; + for (infoPtr = procList; infoPtr != NULL; + prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { + if (infoPtr->hProcess == (HANDLE) pid) { + break; + } + } + + /* + * If the pid is not one of the processes we know about (we started it) + * then do nothing. + */ + + if (infoPtr == NULL) { + *statPtr = 0; + return 0; + } + + /* + * Officially "wait" for it to finish. We either poll (WNOHANG) or + * wait for an infinite amount of time. + */ + + if (options & WNOHANG) { + flags = 0; + } else { + flags = INFINITE; + } + ret = WaitForSingleObject(infoPtr->hProcess, flags); + if (ret == WAIT_TIMEOUT) { + *statPtr = 0; + if (options & WNOHANG) { + return 0; + } else { + result = 0; + } + } else if (ret != WAIT_FAILED) { + GetExitCodeProcess(infoPtr->hProcess, (DWORD*)statPtr); + *statPtr = ((*statPtr << 8) & 0xff00); + result = pid; + } else { + errno = ECHILD; + *statPtr = ECHILD; + result = (Tcl_Pid) -1; + } + + /* + * Remove the process from the process list and close the process handle. + */ + + CloseHandle(infoPtr->hProcess); + *prevPtrPtr = infoPtr->nextPtr; + ckfree((char*)infoPtr); + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PidObjCmd -- + * + * This procedure is invoked to process the "pid" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PidObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST *objv; /* Argument strings. */ +{ + Tcl_Channel chan; + Tcl_ChannelType *chanTypePtr; + PipeInfo *pipePtr; + int i; + Tcl_Obj *resultPtr; + char buf[20]; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); + return TCL_ERROR; + } + if (objc == 1) { + resultPtr = Tcl_GetObjResult(interp); + sprintf(buf, "%lu", (unsigned long) getpid()); + Tcl_SetStringObj(resultPtr, buf, -1); + } else { + chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), + NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + chanTypePtr = Tcl_GetChannelType(chan); + if (chanTypePtr != &pipeChannelType) { + return TCL_OK; + } + + pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); + resultPtr = Tcl_GetObjResult(interp); + for (i = 0; i < pipePtr->numPids; i++) { + sprintf(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i])); + Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr, + Tcl_NewStringObj(buf, -1)); + } + } + return TCL_OK; +} diff --git a/win/tclWinPort.h b/win/tclWinPort.h new file mode 100644 index 0000000..99183cd --- /dev/null +++ b/win/tclWinPort.h @@ -0,0 +1,399 @@ +/* + * tclWinPort.h -- + * + * This header file handles porting issues that occur because of + * differences between Windows and Unix. It should be the only + * file that contains #ifdefs to handle different flavors of OS. + * + * 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: @(#) tclWinPort.h 1.53 97/07/30 14:12:17 + */ + +#ifndef _TCLWINPORT +#define _TCLWINPORT + +#include <malloc.h> +#include <stdio.h> + +#include <stdlib.h> +#include <string.h> +#include <errno.h> +#include <process.h> +#include <signal.h> +#include <winsock.h> +#include <sys/stat.h> +#include <sys/timeb.h> +#include <time.h> +#include <io.h> +#include <fcntl.h> +#include <float.h> + +#define WIN32_LEAN_AND_MEAN +#include <windows.h> +#undef WIN32_LEAN_AND_MEAN + +/* + * Define EINPROGRESS in terms of WSAEINPROGRESS. + */ + +#ifndef EINPROGRESS +#define EINPROGRESS WSAEINPROGRESS +#endif + +/* + * If ENOTSUP is not defined, define it to a value that will never occur. + */ + +#ifndef ENOTSUP +#define ENOTSUP -1030507 +#endif + +/* + * The following defines wrap the system memory allocation routines for + * use by tclAlloc.c. + */ + +#define TclpSysAlloc(size, isBin) ((void*)GlobalAlloc(GMEM_FIXED, \ + (DWORD)size)) +#define TclpSysFree(ptr) (GlobalFree((HGLOBAL)ptr)) +#define TclpSysRealloc(ptr, size) ((void*)GlobalReAlloc((HGLOBAL)ptr, \ + (DWORD)size, 0)) + +/* + * The default platform eol translation on Windows is TCL_TRANSLATE_CRLF: + */ + +#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_CRLF + +/* + * Declare dynamic loading extension macro. + */ + +#define TCL_SHLIB_EXT ".dll" + +/* + * Supply definitions for macros to query wait status, if not already + * defined in header files above. + */ + +#if TCL_UNION_WAIT +# define WAIT_STATUS_TYPE union wait +#else +# define WAIT_STATUS_TYPE int +#endif + +#ifndef WIFEXITED +# define WIFEXITED(stat) (((*((int *) &(stat))) & 0xff) == 0) +#endif + +#ifndef WEXITSTATUS +# define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xff) +#endif + +#ifndef WIFSIGNALED +# define WIFSIGNALED(stat) (((*((int *) &(stat)))) && ((*((int *) &(stat))) == ((*((int *) &(stat))) & 0x00ff))) +#endif + +#ifndef WTERMSIG +# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f) +#endif + +#ifndef WIFSTOPPED +# define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xff) == 0177) +#endif + +#ifndef WSTOPSIG +# define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xff) +#endif + +/* + * Define constants for waitpid() system call if they aren't defined + * by a system header file. + */ + +#ifndef WNOHANG +# define WNOHANG 1 +#endif +#ifndef WUNTRACED +# define WUNTRACED 2 +#endif + +/* + * Define MAXPATHLEN in terms of MAXPATH if available + */ + +#ifndef MAXPATH +#define MAXPATH MAX_PATH +#endif /* MAXPATH */ + +#ifndef MAXPATHLEN +#define MAXPATHLEN MAXPATH +#endif /* MAXPATHLEN */ + +#ifndef F_OK +# define F_OK 00 +#endif +#ifndef X_OK +# define X_OK 01 +#endif +#ifndef W_OK +# define W_OK 02 +#endif +#ifndef R_OK +# define R_OK 04 +#endif + +/* + * Define macros to query file type bits, if they're not already + * defined. + */ + +#ifndef S_ISREG +# ifdef S_IFREG +# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) +# else +# define S_ISREG(m) 0 +# endif +# endif +#ifndef S_ISDIR +# ifdef S_IFDIR +# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) +# else +# define S_ISDIR(m) 0 +# endif +# endif +#ifndef S_ISCHR +# ifdef S_IFCHR +# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR) +# else +# define S_ISCHR(m) 0 +# endif +# endif +#ifndef S_ISBLK +# ifdef S_IFBLK +# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK) +# else +# define S_ISBLK(m) 0 +# endif +# endif +#ifndef S_ISFIFO +# ifdef S_IFIFO +# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) +# else +# define S_ISFIFO(m) 0 +# endif +# endif + +/* + * Define pid_t and uid_t if they're not already defined. + */ + +#if ! TCL_PID_T +# define pid_t int +#endif +#if ! TCL_UID_T +# define uid_t int +#endif + +/* + * Provide a stub definition for TclGetUserHome(). + */ + +#define TclGetUserHome(name,bufferPtr) (NULL) + +/* + * Visual C++ has some odd names for common functions, so we need to + * define a few macros to handle them. Also, it defines EDEADLOCK and + * EDEADLK as the same value, which confuses Tcl_ErrnoId(). + */ + +#ifdef _MSC_VER +# define environ _environ +# define hypot _hypot +# define exception _exception +# undef EDEADLOCK +#endif /* _MSC_VER */ + +/* + * The following defines redefine the Windows Socket errors as + * BSD errors so Tcl_PosixError can do the right thing. + */ + +#ifndef EWOULDBLOCK +#define EWOULDBLOCK EAGAIN +#endif +#ifndef EALREADY +#define EALREADY 149 /* operation already in progress */ +#endif +#ifndef ENOTSOCK +#define ENOTSOCK 95 /* Socket operation on non-socket */ +#endif +#ifndef EDESTADDRREQ +#define EDESTADDRREQ 96 /* Destination address required */ +#endif +#ifndef EMSGSIZE +#define EMSGSIZE 97 /* Message too long */ +#endif +#ifndef EPROTOTYPE +#define EPROTOTYPE 98 /* Protocol wrong type for socket */ +#endif +#ifndef ENOPROTOOPT +#define ENOPROTOOPT 99 /* Protocol not available */ +#endif +#ifndef EPROTONOSUPPORT +#define EPROTONOSUPPORT 120 /* Protocol not supported */ +#endif +#ifndef ESOCKTNOSUPPORT +#define ESOCKTNOSUPPORT 121 /* Socket type not supported */ +#endif +#ifndef EOPNOTSUPP +#define EOPNOTSUPP 122 /* Operation not supported on socket */ +#endif +#ifndef EPFNOSUPPORT +#define EPFNOSUPPORT 123 /* Protocol family not supported */ +#endif +#ifndef EAFNOSUPPORT +#define EAFNOSUPPORT 124 /* Address family not supported */ +#endif +#ifndef EADDRINUSE +#define EADDRINUSE 125 /* Address already in use */ +#endif +#ifndef EADDRNOTAVAIL +#define EADDRNOTAVAIL 126 /* Can't assign requested address */ +#endif +#ifndef ENETDOWN +#define ENETDOWN 127 /* Network is down */ +#endif +#ifndef ENETUNREACH +#define ENETUNREACH 128 /* Network is unreachable */ +#endif +#ifndef ENETRESET +#define ENETRESET 129 /* Network dropped connection on reset */ +#endif +#ifndef ECONNABORTED +#define ECONNABORTED 130 /* Software caused connection abort */ +#endif +#ifndef ECONNRESET +#define ECONNRESET 131 /* Connection reset by peer */ +#endif +#ifndef ENOBUFS +#define ENOBUFS 132 /* No buffer space available */ +#endif +#ifndef EISCONN +#define EISCONN 133 /* Socket is already connected */ +#endif +#ifndef ENOTCONN +#define ENOTCONN 134 /* Socket is not connected */ +#endif +#ifndef ESHUTDOWN +#define ESHUTDOWN 143 /* Can't send after socket shutdown */ +#endif +#ifndef ETOOMANYREFS +#define ETOOMANYREFS 144 /* Too many references: can't splice */ +#endif +#ifndef ETIMEDOUT +#define ETIMEDOUT 145 /* Connection timed out */ +#endif +#ifndef ECONNREFUSED +#define ECONNREFUSED 146 /* Connection refused */ +#endif +#ifndef ELOOP +#define ELOOP 90 /* Symbolic link loop */ +#endif +#ifndef EHOSTDOWN +#define EHOSTDOWN 147 /* Host is down */ +#endif +#ifndef EHOSTUNREACH +#define EHOSTUNREACH 148 /* No route to host */ +#endif +#ifndef ENOTEMPTY +#define ENOTEMPTY 93 /* directory not empty */ +#endif +#ifndef EUSERS +#define EUSERS 94 /* Too many users (for UFS) */ +#endif +#ifndef EDQUOT +#define EDQUOT 49 /* Disc quota exceeded */ +#endif +#ifndef ESTALE +#define ESTALE 151 /* Stale NFS file handle */ +#endif +#ifndef EREMOTE +#define EREMOTE 66 /* The object is remote */ +#endif + +/* + * The following define ensures that we use the native putenv + * implementation to modify the environment array. This keeps + * the C level environment in synch with the system level environment. + */ + +#define USE_PUTENV 1 + +/* + * The following defines map from standard socket names to our internal + * wrappers that redirect through the winSock function table (see the + * file tclWinSock.c). + */ + +#define getservbyname TclWinGetServByName +#define getsockopt TclWinGetSockOpt +#define ntohs TclWinNToHS +#define setsockopt TclWinSetSockOpt + +/* + * The following implements the Windows method for exiting the process. + */ +#define TclPlatformExit(status) exit(status) + + +/* + * The following declarations belong in tclInt.h, but depend on platform + * specific types (e.g. struct tm). + */ + +EXTERN struct tm * TclpGetDate _ANSI_ARGS_((const time_t *tp, + int useGMT)); +EXTERN unsigned long TclpGetPid _ANSI_ARGS_((Tcl_Pid pid)); +EXTERN size_t TclStrftime _ANSI_ARGS_((char *s, size_t maxsize, + const char *format, const struct tm *t)); + +/* + * The following prototypes and defines replace the Windows versions + * of POSIX function that various compilier vendors didn't implement + * well or consistantly. + */ + +#define stat(path, buf) TclWinStat(path, buf) +#define lstat stat +#define access(path, mode) TclWinAccess(path, mode) + +EXTERN int TclWinStat _ANSI_ARGS_((CONST char *path, + struct stat *buf)); +EXTERN int TclWinAccess _ANSI_ARGS_((CONST char *path, + int mode)); + +#define TclpReleaseFile(file) ckfree((char *) file) + +/* + * Declarations for Windows specific functions. + */ + +EXTERN void TclWinConvertError _ANSI_ARGS_((DWORD errCode)); +EXTERN void TclWinConvertWSAError _ANSI_ARGS_((DWORD errCode)); +EXTERN struct servent * PASCAL FAR + TclWinGetServByName _ANSI_ARGS_((const char FAR *nm, + const char FAR *proto)); +EXTERN int PASCAL FAR TclWinGetSockOpt _ANSI_ARGS_((SOCKET s, int level, + int optname, char FAR * optval, int FAR *optlen)); +EXTERN HINSTANCE TclWinGetTclInstance _ANSI_ARGS_((void)); +EXTERN HINSTANCE TclWinLoadLibrary _ANSI_ARGS_((char *name)); +EXTERN u_short PASCAL FAR + TclWinNToHS _ANSI_ARGS_((u_short ns)); +EXTERN int PASCAL FAR TclWinSetSockOpt _ANSI_ARGS_((SOCKET s, int level, + int optname, const char FAR * optval, int optlen)); +#endif /* _TCLWINPORT */ diff --git a/win/tclWinReg.c b/win/tclWinReg.c new file mode 100644 index 0000000..5e5d450 --- /dev/null +++ b/win/tclWinReg.c @@ -0,0 +1,1212 @@ +/* + * tclWinReg.c -- + * + * This file contains the implementation of the "registry" Tcl + * built-in command. This command is built as a dynamically + * loadable extension in a separate DLL. + * + * 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: @(#) tclWinReg.c 1.8 97/08/01 11:17:49 + */ + +#include <tcl.h> +#include <stdlib.h> + +#define WIN32_LEAN_AND_MEAN +#include <windows.h> +#undef WIN32_LEAN_AND_MEAN + +/* + * VC++ has an alternate entry point called DllMain, so we need to rename + * our entry point. + */ + +#ifndef STATIC_BUILD +#if defined(_MSC_VER) +# define EXPORT(a,b) __declspec(dllexport) a b +# define DllEntryPoint DllMain +#else +# if defined(__BORLANDC__) +# define EXPORT(a,b) a _export b +# else +# define EXPORT(a,b) a b +# endif +#endif +#endif + +/* + * The following macros convert between different endian ints. + */ + +#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x)) +#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x))) + +/* + * The following flag is used in OpenKeys to indicate that the specified + * key should be created if it doesn't currently exist. + */ + +#define REG_CREATE 1 + +/* + * The following tables contain the mapping from registry root names + * to the system predefined keys. + */ + +static char *rootKeyNames[] = { + "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT", + "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", NULL +}; + +static HKEY rootKeys[] = { + HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, + HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA +}; + +/* + * The following table maps from registry types to strings. Note that + * the indices for this array are the same as the constants for the + * known registry types so we don't need a separate table to hold the + * mapping. + */ + +static char *typeNames[] = { + "none", "sz", "expand_sz", "binary", "dword", + "dword_big_endian", "link", "multi_sz", "resource_list", NULL +}; + +static DWORD lastType = REG_RESOURCE_REQUIREMENTS_LIST; + + +/* + * Declarations for functions defined in this file. + */ + +static void AppendSystemError(Tcl_Interp *interp, DWORD error); +static DWORD ConvertDWORD(DWORD type, DWORD value); +static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj); +static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + Tcl_Obj *valueNameObj); +static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + Tcl_Obj *patternObj); +static int GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + Tcl_Obj *valueNameObj); +static int GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + Tcl_Obj *valueNameObj); +static int GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + Tcl_Obj *patternObj); +static int OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + REGSAM mode, int flags, HKEY *keyPtr); +static DWORD OpenSubKey(char *hostName, HKEY rootKey, + char *keyName, REGSAM mode, int flags, + HKEY *keyPtr); +static int ParseKeyName(Tcl_Interp *interp, char *name, + char **hostNamePtr, HKEY *rootKeyPtr, + char **keyNamePtr); +static DWORD RecursiveDeleteKey(HKEY hStartKey, LPTSTR pKeyName); +static int RegistryObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]); +static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + Tcl_Obj *valueNameObj, Tcl_Obj *dataObj, + Tcl_Obj *typeObj); + +EXTERN EXPORT(int,Registry_Init)(Tcl_Interp *interp); + +/* + *---------------------------------------------------------------------- + * + * DllEntryPoint -- + * + * This wrapper function is used by Windows to invoke the + * initialization code for the DLL. If we are compiling + * with Visual C++, this routine will be renamed to DllMain. + * routine. + * + * Results: + * Returns TRUE; + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef __WIN32__ +#ifndef STATIC_BUILD +BOOL APIENTRY +DllEntryPoint( + HINSTANCE hInst, /* Library instance handle. */ + DWORD reason, /* Reason this function is being called. */ + LPVOID reserved) /* Not used. */ +{ + return TRUE; +} +#endif +#endif + +/* + *---------------------------------------------------------------------- + * + * Registry_Init -- + * + * This procedure initializes the registry command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +EXPORT(int,Registry_Init)( + Tcl_Interp *interp) +{ + Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL); + return Tcl_PkgProvide(interp, "registry", "1.0"); +} + +/* + *---------------------------------------------------------------------- + * + * RegistryObjCmd -- + * + * This function implements the Tcl "registry" command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +RegistryObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj * CONST objv[]) /* Argument values. */ +{ + int index; + char *errString; + + static char *subcommands[] = { "delete", "get", "keys", "set", "type", + "values", (char *) NULL }; + enum SubCmdIdx { DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index) + != TCL_OK) { + return TCL_ERROR; + } + + switch (index) { + case DeleteIdx: /* delete */ + if (objc == 3) { + return DeleteKey(interp, objv[2]); + } else if (objc == 4) { + return DeleteValue(interp, objv[2], objv[3]); + } + errString = "keyName ?valueName?"; + break; + case GetIdx: /* get */ + if (objc == 4) { + return GetValue(interp, objv[2], objv[3]); + } + errString = "keyName valueName"; + break; + case KeysIdx: /* keys */ + if (objc == 3) { + return GetKeyNames(interp, objv[2], NULL); + } else if (objc == 4) { + return GetKeyNames(interp, objv[2], objv[3]); + } + errString = "keyName ?pattern?"; + break; + case SetIdx: /* set */ + if (objc == 3) { + HKEY key; + + /* + * Create the key and then close it immediately. + */ + + if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) + != TCL_OK) { + return TCL_ERROR; + } + RegCloseKey(key); + return TCL_OK; + } else if (objc == 5 || objc == 6) { + Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5]; + return SetValue(interp, objv[2], objv[3], objv[4], typeObj); + } + errString = "keyName ?valueName data ?type??"; + break; + case TypeIdx: /* type */ + if (objc == 4) { + return GetType(interp, objv[2], objv[3]); + } + errString = "keyName valueName"; + break; + case ValuesIdx: /* values */ + if (objc == 3) { + return GetValueNames(interp, objv[2], NULL); + } else if (objc == 4) { + return GetValueNames(interp, objv[2], objv[3]); + } + errString = "keyName ?pattern?"; + break; + } + Tcl_WrongNumArgs(interp, 2, objv, errString); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteKey -- + * + * This function deletes a registry key. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteKey( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj) /* Name of key to delete. */ +{ + char *tail, *buffer, *hostName, *keyName; + HKEY rootKey, subkey; + DWORD result; + int length; + Tcl_Obj *resultPtr; + + /* + * Find the parent of the key being deleted and open it. + */ + + keyName = Tcl_GetStringFromObj(keyNameObj, &length); + buffer = ckalloc(length + 1); + strcpy(buffer, keyName); + + if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName) + != TCL_OK) { + ckfree(buffer); + return TCL_ERROR; + } + + resultPtr = Tcl_GetObjResult(interp); + if (*keyName == '\0') { + Tcl_AppendToObj(resultPtr, "bad key: cannot delete root keys", -1); + ckfree(buffer); + return TCL_ERROR; + } + + tail = strrchr(keyName, '\\'); + if (tail) { + *tail++ = '\0'; + } else { + tail = keyName; + keyName = NULL; + } + + result = OpenSubKey(hostName, rootKey, keyName, + KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey); + if (result != ERROR_SUCCESS) { + ckfree(buffer); + if (result == ERROR_FILE_NOT_FOUND) { + return TCL_OK; + } else { + Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1); + AppendSystemError(interp, result); + return TCL_ERROR; + } + } + + /* + * Now we recursively delete the key and everything below it. + */ + + result = RecursiveDeleteKey(subkey, tail); + + if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) { + Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1); + AppendSystemError(interp, result); + result = TCL_ERROR; + } else { + result = TCL_OK; + } + + RegCloseKey(subkey); + ckfree(buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteValue -- + * + * This function deletes a value from a registry key. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteValue( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj, /* Name of key. */ + Tcl_Obj *valueNameObj) /* Name of value to delete. */ +{ + HKEY key; + char *valueName; + int length; + DWORD result; + Tcl_Obj *resultPtr; + + /* + * Attempt to open the key for deletion. + */ + + if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key) + != TCL_OK) { + return TCL_ERROR; + } + + resultPtr = Tcl_GetObjResult(interp); + valueName = Tcl_GetStringFromObj(valueNameObj, &length); + result = RegDeleteValue(key, valueName); + if (result != ERROR_SUCCESS) { + Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"", + Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"", + Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL); + AppendSystemError(interp, result); + result = TCL_ERROR; + } else { + result = TCL_OK; + } + RegCloseKey(key); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * GetKeyNames -- + * + * This function enumerates the subkeys of a given key. If the + * optional pattern is supplied, then only keys that match the + * pattern will be returned. + * + * Results: + * Returns the list of subkeys in the result object of the + * interpreter, or an error message on failure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +GetKeyNames( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj, /* Key to enumerate. */ + Tcl_Obj *patternObj) /* Optional match pattern. */ +{ + HKEY key; + DWORD index; + char buffer[MAX_PATH+1], *pattern; + Tcl_Obj *resultPtr; + int result = TCL_OK; + + /* + * Attempt to open the key for enumeration. + */ + + if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key) + != TCL_OK) { + return TCL_ERROR; + } + + if (patternObj) { + pattern = Tcl_GetStringFromObj(patternObj, NULL); + } else { + pattern = NULL; + } + + /* + * Enumerate over the subkeys until we get an error, indicating the + * end of the list. + */ + + resultPtr = Tcl_GetObjResult(interp); + for (index = 0; RegEnumKey(key, index, buffer, MAX_PATH+1) + == ERROR_SUCCESS; index++) { + if (pattern && !Tcl_StringMatch(buffer, pattern)) { + continue; + } + result = Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj(buffer, -1)); + if (result != TCL_OK) { + break; + } + } + + RegCloseKey(key); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * GetType -- + * + * This function gets the type of a given registry value and + * places it in the interpreter result. + * + * Results: + * Returns a normal Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +GetType( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj, /* Name of key. */ + Tcl_Obj *valueNameObj) /* Name of value to get. */ +{ + HKEY key; + Tcl_Obj *resultPtr; + DWORD result; + DWORD type; + + /* + * Attempt to open the key for reading. + */ + + if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) + != TCL_OK) { + return TCL_ERROR; + } + + /* + * Get the type of the value. + */ + + resultPtr = Tcl_GetObjResult(interp); + + result = RegQueryValueEx(key, Tcl_GetStringFromObj(valueNameObj, NULL), + NULL, &type, NULL, NULL); + RegCloseKey(key); + + if (result != ERROR_SUCCESS) { + Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"", + Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"", + Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL); + AppendSystemError(interp, result); + return TCL_ERROR; + } + + /* + * Set the type into the result. Watch out for unknown types. + * If we don't know about the type, just use the numeric value. + */ + + if (type > lastType) { + Tcl_SetIntObj(resultPtr, type); + } else { + Tcl_SetStringObj(resultPtr, typeNames[type], -1); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetValue -- + * + * This function gets the contents of a registry value and places + * a list containing the data and the type in the interpreter + * result. + * + * Results: + * Returns a normal Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +GetValue( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj, /* Name of key. */ + Tcl_Obj *valueNameObj) /* Name of value to get. */ +{ + HKEY key; + char *valueName; + DWORD result, length, type; + Tcl_Obj *resultPtr; + Tcl_DString data; + + /* + * Attempt to open the key for reading. + */ + + if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) + != TCL_OK) { + return TCL_ERROR; + } + + /* + * Get the value once to determine the length then again to store + * the data in the buffer. + */ + + Tcl_DStringInit(&data); + resultPtr = Tcl_GetObjResult(interp); + + valueName = Tcl_GetStringFromObj(valueNameObj, (int*) &length); + result = RegQueryValueEx(key, valueName, NULL, &type, NULL, &length); + if (result == ERROR_SUCCESS) { + Tcl_DStringSetLength(&data, length); + result = RegQueryValueEx(key, valueName, NULL, &type, + (LPBYTE) Tcl_DStringValue(&data), &length); + } + RegCloseKey(key); + if (result != ERROR_SUCCESS) { + Tcl_AppendStringsToObj(resultPtr, "unable to get value \"", + Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"", + Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL); + AppendSystemError(interp, result); + Tcl_DStringFree(&data); + return TCL_ERROR; + } + + /* + * If the data is a 32-bit quantity, store it as an integer object. If it + * is a multi-string, store it as a list of strings. For null-terminated + * strings, append up the to first null. Otherwise, store it as a binary + * string. + */ + + if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { + Tcl_SetIntObj(resultPtr, ConvertDWORD(type, + *((DWORD*) Tcl_DStringValue(&data)))); + } else if (type == REG_MULTI_SZ) { + char *p = Tcl_DStringValue(&data); + char *lastChar = Tcl_DStringValue(&data) + Tcl_DStringLength(&data); + + /* + * Multistrings are stored as an array of null-terminated strings, + * terminated by two null characters. Also do a bounds check in + * case we get bogus data. + */ + + while (p < lastChar && *p != '\0') { + Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj(p, -1)); + while (*p++ != '\0') {} + } + } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) { + Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&data), -1); + } else { + Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&data), length); + } + Tcl_DStringFree(&data); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * GetValueNames -- + * + * This function enumerates the values of the a given key. If + * the optional pattern is supplied, then only value names that + * match the pattern will be returned. + * + * Results: + * Returns the list of value names in the result object of the + * interpreter, or an error message on failure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +GetValueNames( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj, /* Key to enumerate. */ + Tcl_Obj *patternObj) /* Optional match pattern. */ +{ + HKEY key; + Tcl_Obj *resultPtr; + DWORD index, size, result; + Tcl_DString buffer; + char *pattern; + + /* + * Attempt to open the key for enumeration. + */ + + if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) + != TCL_OK) { + return TCL_ERROR; + } + + resultPtr = Tcl_GetObjResult(interp); + + /* + * Query the key to determine the appropriate buffer size to hold the + * largest value name plus the terminating null. + */ + + result = RegQueryInfoKey(key, NULL, NULL, NULL, NULL, NULL, NULL, &index, + &size, NULL, NULL, NULL); + if (result != ERROR_SUCCESS) { + Tcl_AppendStringsToObj(resultPtr, "unable to query key \"", + Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL); + AppendSystemError(interp, result); + RegCloseKey(key); + result = TCL_ERROR; + goto done; + } + size++; + + + Tcl_DStringInit(&buffer); + Tcl_DStringSetLength(&buffer, size); + index = 0; + result = TCL_OK; + + if (patternObj) { + pattern = Tcl_GetStringFromObj(patternObj, NULL); + } else { + pattern = NULL; + } + + /* + * Enumerate the values under the given subkey until we get an error, + * indicating the end of the list. Note that we need to reset size + * after each iteration because RegEnumValue smashes the old value. + */ + + while (RegEnumValue(key, index, Tcl_DStringValue(&buffer), &size, NULL, + NULL, NULL, NULL) == ERROR_SUCCESS) { + if (!pattern || Tcl_StringMatch(Tcl_DStringValue(&buffer), pattern)) { + result = Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj(Tcl_DStringValue(&buffer), size)); + if (result != TCL_OK) { + break; + } + } + index++; + size = Tcl_DStringLength(&buffer); + } + Tcl_DStringFree(&buffer); + + done: + RegCloseKey(key); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * OpenKey -- + * + * This function opens the specified key. This function is a + * simple wrapper around ParseKeyName and OpenSubKey. + * + * Results: + * Returns the opened key in the keyPtr argument and a Tcl + * result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +OpenKey( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj, /* Key to open. */ + REGSAM mode, /* Access mode. */ + int flags, /* 0 or REG_CREATE. */ + HKEY *keyPtr) /* Returned HKEY. */ +{ + char *keyName, *buffer, *hostName; + int length; + HKEY rootKey; + DWORD result; + + keyName = Tcl_GetStringFromObj(keyNameObj, &length); + buffer = ckalloc(length + 1); + strcpy(buffer, keyName); + + result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); + if (result == TCL_OK) { + result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr); + if (result != ERROR_SUCCESS) { + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + Tcl_AppendToObj(resultPtr, "unable to open key: ", -1); + AppendSystemError(interp, result); + result = TCL_ERROR; + } else { + result = TCL_OK; + } + } + + ckfree(buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * OpenSubKey -- + * + * This function opens a given subkey of a root key on the + * specified host. + * + * Results: + * Returns the opened key in the keyPtr and a Windows error code + * as the return value. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static DWORD +OpenSubKey( + char *hostName, /* Host to access, or NULL for local. */ + HKEY rootKey, /* Root registry key. */ + char *keyName, /* Subkey name. */ + REGSAM mode, /* Access mode. */ + int flags, /* 0 or REG_CREATE. */ + HKEY *keyPtr) /* Returned HKEY. */ +{ + DWORD result; + + /* + * Attempt to open the root key on a remote host if necessary. + */ + + if (hostName) { + result = RegConnectRegistry(hostName, rootKey, &rootKey); + if (result != ERROR_SUCCESS) { + return result; + } + } + + /* + * Now open the specified key with the requested permissions. Note + * that this key must be closed by the caller. + */ + + if (flags & REG_CREATE) { + DWORD create; + result = RegCreateKeyEx(rootKey, keyName, 0, "", + REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create); + } else { + result = RegOpenKeyEx(rootKey, keyName, 0, mode, keyPtr); + } + + /* + * Be sure to close the root key since we are done with it now. + */ + + if (hostName) { + RegCloseKey(rootKey); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * ParseKeyName -- + * + * This function parses a key name into the host, root, and subkey + * parts. + * + * Results: + * The pointers to the start of the host and subkey names are + * returned in the hostNamePtr and keyNamePtr variables. The + * specified root HKEY is returned in rootKeyPtr. Returns + * a standard Tcl result. + * + * + * Side effects: + * Modifies the name string by inserting nulls. + * + *---------------------------------------------------------------------- + */ + +static int +ParseKeyName( + Tcl_Interp *interp, /* Current interpreter. */ + char *name, + char **hostNamePtr, + HKEY *rootKeyPtr, + char **keyNamePtr) +{ + char *rootName; + int result, index; + Tcl_Obj *rootObj, *resultPtr = Tcl_GetObjResult(interp); + + /* + * Split the key into host and root portions. + */ + + *hostNamePtr = *keyNamePtr = rootName = NULL; + if (name[0] == '\\') { + if (name[1] == '\\') { + *hostNamePtr = name; + for (rootName = name+2; *rootName != '\0'; rootName++) { + if (*rootName == '\\') { + *rootName++ = '\0'; + break; + } + } + } + } else { + rootName = name; + } + if (!rootName) { + Tcl_AppendStringsToObj(resultPtr, "bad key \"", name, + "\": must start with a valid root", NULL); + return TCL_ERROR; + } + + /* + * Split the root into root and subkey portions. + */ + + for (*keyNamePtr = rootName; **keyNamePtr != '\0'; (*keyNamePtr)++) { + if (**keyNamePtr == '\\') { + **keyNamePtr = '\0'; + (*keyNamePtr)++; + break; + } + } + + /* + * Look for a matching root name. + */ + + rootObj = Tcl_NewStringObj(rootName, -1); + result = Tcl_GetIndexFromObj(interp, rootObj, rootKeyNames, "root name", + TCL_EXACT, &index); + Tcl_DecrRefCount(rootObj); + if (result != TCL_OK) { + return TCL_ERROR; + } + *rootKeyPtr = rootKeys[index]; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * RecursiveDeleteKey -- + * + * This function recursively deletes all the keys below a starting + * key. Although Windows 95 does this automatically, we still need + * to do this for Windows NT. + * + * Results: + * Returns a Windows error code. + * + * Side effects: + * Deletes all of the keys and values below the given key. + * + *---------------------------------------------------------------------- + */ + +static DWORD +RecursiveDeleteKey( + HKEY startKey, /* Parent of key to be deleted. */ + char *keyName) /* Name of key to be deleted. */ +{ + DWORD result, subKeyLength; + Tcl_DString subkey; + HKEY hKey; + + /* + * Do not allow NULL or empty key name. + */ + + if (!keyName || lstrlen(keyName) == '\0') { + return ERROR_BADKEY; + } + + result = RegOpenKeyEx(startKey, keyName, 0, + KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey); + if (result != ERROR_SUCCESS) { + return result; + } + result = RegQueryInfoKey(hKey, NULL, NULL, NULL, NULL, &subKeyLength, + NULL, NULL, NULL, NULL, NULL, NULL); + subKeyLength++; + if (result != ERROR_SUCCESS) { + return result; + } + + Tcl_DStringInit(&subkey); + Tcl_DStringSetLength(&subkey, subKeyLength); + + while (result == ERROR_SUCCESS) { + /* + * Always get index 0 because key deletion changes ordering. + */ + + subKeyLength = Tcl_DStringLength(&subkey); + result=RegEnumKeyEx(hKey, 0, Tcl_DStringValue(&subkey), &subKeyLength, + NULL, NULL, NULL, NULL); + if (result == ERROR_NO_MORE_ITEMS) { + result = RegDeleteKey(startKey, keyName); + break; + } else if (result == ERROR_SUCCESS) { + result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey)); + } + } + Tcl_DStringFree(&subkey); + RegCloseKey(hKey); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * SetValue -- + * + * This function sets the contents of a registry value. If + * the key or value does not exist, it will be created. If it + * does exist, then the data and type will be replaced. + * + * Results: + * Returns a normal Tcl result. + * + * Side effects: + * May create new keys or values. + * + *---------------------------------------------------------------------- + */ + +static int +SetValue( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj, /* Name of key. */ + Tcl_Obj *valueNameObj, /* Name of value to set. */ + Tcl_Obj *dataObj, /* Data to be written. */ + Tcl_Obj *typeObj) /* Type of data to be written. */ +{ + DWORD type, result; + HKEY key; + int length; + char *valueName; + Tcl_Obj *resultPtr; + + if (typeObj == NULL) { + type = REG_SZ; + } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type", + 0, (int *) &type) != TCL_OK) { + if (Tcl_GetIntFromObj(NULL, typeObj, (int*) &type) != TCL_OK) { + return TCL_ERROR; + } + Tcl_ResetResult(interp); + } + if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) { + return TCL_ERROR; + } + + valueName = Tcl_GetStringFromObj(valueNameObj, &length); + resultPtr = Tcl_GetObjResult(interp); + + if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { + DWORD value; + if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) { + RegCloseKey(key); + return TCL_ERROR; + } + + value = ConvertDWORD(type, value); + result = RegSetValueEx(key, valueName, 0, type, (BYTE*) &value, + sizeof(DWORD)); + } else if (type == REG_MULTI_SZ) { + Tcl_DString data; + int objc, i; + Tcl_Obj **objv; + char *element; + + if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) { + RegCloseKey(key); + return TCL_ERROR; + } + + /* + * Append the elements as null terminated strings. Note that + * we must not assume the length of the string in case there are + * embedded nulls, which aren't allowed in REG_MULTI_SZ values. + */ + + Tcl_DStringInit(&data); + for (i = 0; i < objc; i++) { + element = Tcl_GetStringFromObj(objv[i], NULL); + Tcl_DStringAppend(&data, element, -1); + Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1); + } + result = RegSetValueEx(key, valueName, 0, type, + (LPBYTE) Tcl_DStringValue(&data), + (DWORD) (Tcl_DStringLength(&data)+1)); + Tcl_DStringFree(&data); + } else { + char *data = Tcl_GetStringFromObj(dataObj, &length); + + /* + * Include the null in the length if we are storing a null terminated + * string. Note that we also need to call strlen to find the first + * null so we don't pass bad data to the registry. + */ + + if (type == REG_SZ || type == REG_EXPAND_SZ) { + length = strlen(data) + 1; + } + + result = RegSetValueEx(key, valueName, 0, type, (LPBYTE)data, length); + } + RegCloseKey(key); + if (result != ERROR_SUCCESS) { + Tcl_AppendToObj(resultPtr, "unable to set value: ", -1); + AppendSystemError(interp, result); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AppendSystemError -- + * + * This routine formats a Windows system error message and places + * it into the interpreter result. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AppendSystemError( + Tcl_Interp *interp, /* Current interpreter. */ + DWORD error) /* Result code from error. */ +{ + int length; + char *msgbuf, id[10]; + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + + sprintf(id, "%d", error); + length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM + | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPTSTR)&msgbuf, + 0, NULL); + if (length == 0) { + if (error == ERROR_CALL_NOT_IMPLEMENTED) { + msgbuf = "function not supported under Win32s"; + } else { + msgbuf = id; + } + } else { + /* + * Trim the trailing CR/LF from the system message. + */ + if (msgbuf[length-1] == '\n') { + msgbuf[--length] = 0; + } + if (msgbuf[length-1] == '\r') { + msgbuf[--length] = 0; + } + } + Tcl_SetErrorCode(interp, "WINDOWS", id, msgbuf, (char *) NULL); + Tcl_AppendToObj(resultPtr, msgbuf, -1); + + if (length != 0) { + LocalFree(msgbuf); + } +} + +/* + *---------------------------------------------------------------------- + * + * ConvertDWORD -- + * + * This function determines whether a DWORD needs to be byte + * swapped, and returns the appropriately swapped value. + * + * Results: + * Returns a converted DWORD. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static DWORD +ConvertDWORD( + DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */ + DWORD value) /* The value to be converted. */ +{ + DWORD order = 1; + DWORD localType; + + /* + * Check to see if the low bit is in the first byte. + */ + + localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN; + return (type != localType) ? SWAPLONG(value) : value; +} diff --git a/win/tclWinSock.c b/win/tclWinSock.c new file mode 100644 index 0000000..bd81d2d --- /dev/null +++ b/win/tclWinSock.c @@ -0,0 +1,2113 @@ +/* + * tclWinSock.c -- + * + * This file contains Windows-specific socket related code. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclWinSock.c 1.80 97/10/09 18:24:59 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following variable is used to tell whether this module has been + * initialized. + */ + +static int initialized = 0; + +static int hostnameInitialized = 0; +static char hostname[255]; /* This buffer should be big enough for + * hostname plus domain name. */ + +/* + * The following structure contains pointers to all of the WinSock API entry + * points used by Tcl. It is initialized by InitSockets. Since we + * dynamically load Winsock.dll on demand, we must use this function table + * to refer to functions in the socket API. + */ + +static struct { + HINSTANCE hInstance; /* Handle to WinSock library. */ + HWND hwnd; /* Handle to window for socket messages. */ + SOCKET (PASCAL FAR *accept)(SOCKET s, struct sockaddr FAR *addr, + int FAR *addrlen); + int (PASCAL FAR *bind)(SOCKET s, const struct sockaddr FAR *addr, + int namelen); + int (PASCAL FAR *closesocket)(SOCKET s); + int (PASCAL FAR *connect)(SOCKET s, const struct sockaddr FAR *name, + int namelen); + int (PASCAL FAR *ioctlsocket)(SOCKET s, long cmd, u_long FAR *argp); + int (PASCAL FAR *getsockopt)(SOCKET s, int level, int optname, + char FAR * optval, int FAR *optlen); + u_short (PASCAL FAR *htons)(u_short hostshort); + unsigned long (PASCAL FAR *inet_addr)(const char FAR * cp); + char FAR * (PASCAL FAR *inet_ntoa)(struct in_addr in); + int (PASCAL FAR *listen)(SOCKET s, int backlog); + u_short (PASCAL FAR *ntohs)(u_short netshort); + int (PASCAL FAR *recv)(SOCKET s, char FAR * buf, int len, int flags); + int (PASCAL FAR *send)(SOCKET s, const char FAR * buf, int len, int flags); + int (PASCAL FAR *setsockopt)(SOCKET s, int level, int optname, + const char FAR * optval, int optlen); + int (PASCAL FAR *shutdown)(SOCKET s, int how); + SOCKET (PASCAL FAR *socket)(int af, int type, int protocol); + struct hostent FAR * (PASCAL FAR *gethostbyname)(const char FAR * name); + struct hostent FAR * (PASCAL FAR *gethostbyaddr)(const char FAR *addr, + int addrlen, int addrtype); + int (PASCAL FAR *gethostname)(char FAR * name, int namelen); + int (PASCAL FAR *getpeername)(SOCKET sock, struct sockaddr FAR *name, + int FAR *namelen); + struct servent FAR * (PASCAL FAR *getservbyname)(const char FAR * name, + const char FAR * proto); + int (PASCAL FAR *getsockname)(SOCKET sock, struct sockaddr FAR *name, + int FAR *namelen); + int (PASCAL FAR *WSAStartup)(WORD wVersionRequired, LPWSADATA lpWSAData); + int (PASCAL FAR *WSACleanup)(void); + int (PASCAL FAR *WSAGetLastError)(void); + int (PASCAL FAR *WSAAsyncSelect)(SOCKET s, HWND hWnd, u_int wMsg, + long lEvent); +} winSock; + +/* + * The following defines declare the messages used on socket windows. + */ + +#define SOCKET_MESSAGE WM_USER+1 + +/* + * The following structure is used to store the data associated with + * each socket. + */ + +typedef struct SocketInfo { + Tcl_Channel channel; /* Channel associated with this socket. */ + SOCKET socket; /* Windows SOCKET handle. */ + int flags; /* Bit field comprised of the flags + * described below. */ + int watchEvents; /* OR'ed combination of FD_READ, FD_WRITE, + * FD_CLOSE, FD_ACCEPT and FD_CONNECT that + * indicate which events are interesting. */ + int readyEvents; /* OR'ed combination of FD_READ, FD_WRITE, + * FD_CLOSE, FD_ACCEPT and FD_CONNECT that + * indicate which events have occurred. */ + int selectEvents; /* OR'ed combination of FD_READ, FD_WRITE, + * FD_CLOSE, FD_ACCEPT and FD_CONNECT that + * indicate which events are currently + * being selected. */ + Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ + ClientData acceptProcData; /* The data for the accept proc. */ + int lastError; /* Error code from last message. */ + struct SocketInfo *nextPtr; /* The next socket on the global socket + * list. */ +} SocketInfo; + +/* + * The following structure is what is added to the Tcl event queue when + * a socket event occurs. + */ + +typedef struct SocketEvent { + Tcl_Event header; /* Information that is standard for + * all events. */ + SOCKET socket; /* Socket descriptor that is ready. Used + * to find the SocketInfo structure for + * the file (can't point directly to the + * SocketInfo structure because it could + * go away while the event is queued). */ +} SocketEvent; + +/* + * This defines the minimum buffersize maintained by the kernel. + */ + +#define TCP_BUFFER_SIZE 4096 + +/* + * The following macros may be used to set the flags field of + * a SocketInfo structure. + */ + +#define SOCKET_ASYNC (1<<0) /* The socket is in blocking mode. */ +#define SOCKET_EOF (1<<1) /* A zero read happened on + * the socket. */ +#define SOCKET_ASYNC_CONNECT (1<<2) /* This socket uses async connect. */ +#define SOCKET_PENDING (1<<3) /* A message has been sent + * for this socket */ + +/* + * Every open socket has an entry on the following list. + */ + +static SocketInfo *socketList; + +/* + * Static functions defined in this file. + */ + +static SocketInfo * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp, + int port, char *host, int server, char *myaddr, + int myport, int async)); +static int CreateSocketAddress _ANSI_ARGS_( + (struct sockaddr_in *sockaddrPtr, + char *host, int port)); +static void InitSockets _ANSI_ARGS_((void)); +static SocketInfo * NewSocketInfo _ANSI_ARGS_((SOCKET socket)); +static void SocketCheckProc _ANSI_ARGS_((ClientData clientData, + int flags)); +static int SocketEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); +static void SocketExitHandler _ANSI_ARGS_((ClientData clientData)); +static LRESULT CALLBACK SocketProc _ANSI_ARGS_((HWND hwnd, UINT message, + WPARAM wParam, LPARAM lParam)); +static void SocketSetupProc _ANSI_ARGS_((ClientData clientData, + int flags)); +static void TcpAccept _ANSI_ARGS_((SocketInfo *infoPtr)); +static int TcpBlockProc _ANSI_ARGS_((ClientData instanceData, + int mode)); +static int TcpCloseProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static int TcpGetOptionProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp, char *optionName, + Tcl_DString *optionValue)); +static int TcpInputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int TcpOutputProc _ANSI_ARGS_((ClientData instanceData, + char *buf, int toWrite, int *errorCode)); +static void TcpWatchProc _ANSI_ARGS_((ClientData instanceData, + int mask)); +static int TcpGetHandleProc _ANSI_ARGS_((ClientData instanceData, + int direction, ClientData *handlePtr)); +static int WaitForSocketEvent _ANSI_ARGS_((SocketInfo *infoPtr, + int events, int *errorCodePtr)); + +/* + * This structure describes the channel type structure for TCP socket + * based IO. + */ + +static Tcl_ChannelType tcpChannelType = { + "tcp", /* Type name. */ + TcpBlockProc, /* Set socket into blocking/non-blocking mode. */ + TcpCloseProc, /* Close proc. */ + TcpInputProc, /* Input proc. */ + TcpOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + NULL, /* Set option proc. */ + TcpGetOptionProc, /* Get option proc. */ + TcpWatchProc, /* Initialize notifier to watch this channel. */ + TcpGetHandleProc, /* Get an OS handle from channel. */ +}; + +/* + * Define version of Winsock required by Tcl. + */ + +#define WSA_VERSION_REQD MAKEWORD(1,1) + +/* + *---------------------------------------------------------------------- + * + * InitSockets -- + * + * Initialize the socket module. Attempts to load the wsock32.dll + * library and set up the winSock function table. If successful, + * registers the event window for the socket notifier code. + * + * Results: + * None. + * + * Side effects: + * Dynamically loads wsock32.dll, and registers a new window + * class and creates a window for use in asynchronous socket + * notification. + * + *---------------------------------------------------------------------- + */ + +static void +InitSockets() +{ + WSADATA wsaData; + OSVERSIONINFO info; + WNDCLASS class; + + initialized = 1; + Tcl_CreateExitHandler(SocketExitHandler, (ClientData) NULL); + + /* + * Find out if we're running on Win32s. + */ + + info.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + GetVersionEx(&info); + + /* + * Check to see if Sockets are supported on this system. Since + * win32s panics if we call WSAStartup on a system that doesn't + * have winsock.dll, we need to look for it on the system first. + * If we find winsock, then load the library and initialize the + * stub table. + */ + + if ((info.dwPlatformId != VER_PLATFORM_WIN32s) + || (SearchPath(NULL, "WINSOCK", ".DLL", 0, NULL, NULL) != 0)) { + winSock.hInstance = LoadLibrary("wsock32.dll"); + } else { + winSock.hInstance = NULL; + } + + /* + * Initialize the function table. + */ + + if (winSock.hInstance == NULL) { + return; + } + + winSock.accept = (SOCKET (PASCAL FAR *)(SOCKET s, + struct sockaddr FAR *addr, int FAR *addrlen)) + GetProcAddress(winSock.hInstance, "accept"); + winSock.bind = (int (PASCAL FAR *)(SOCKET s, + const struct sockaddr FAR *addr, int namelen)) + GetProcAddress(winSock.hInstance, "bind"); + winSock.closesocket = (int (PASCAL FAR *)(SOCKET s)) + GetProcAddress(winSock.hInstance, "closesocket"); + winSock.connect = (int (PASCAL FAR *)(SOCKET s, + const struct sockaddr FAR *name, int namelen)) + GetProcAddress(winSock.hInstance, "connect"); + winSock.ioctlsocket = (int (PASCAL FAR *)(SOCKET s, long cmd, + u_long FAR *argp)) GetProcAddress(winSock.hInstance, "ioctlsocket"); + winSock.getsockopt = (int (PASCAL FAR *)(SOCKET s, + int level, int optname, char FAR * optval, int FAR *optlen)) + GetProcAddress(winSock.hInstance, "getsockopt"); + winSock.htons = (u_short (PASCAL FAR *)(u_short hostshort)) + GetProcAddress(winSock.hInstance, "htons"); + winSock.inet_addr = (unsigned long (PASCAL FAR *)(const char FAR *cp)) + GetProcAddress(winSock.hInstance, "inet_addr"); + winSock.inet_ntoa = (char FAR * (PASCAL FAR *)(struct in_addr in)) + GetProcAddress(winSock.hInstance, "inet_ntoa"); + winSock.listen = (int (PASCAL FAR *)(SOCKET s, int backlog)) + GetProcAddress(winSock.hInstance, "listen"); + winSock.ntohs = (u_short (PASCAL FAR *)(u_short netshort)) + GetProcAddress(winSock.hInstance, "ntohs"); + winSock.recv = (int (PASCAL FAR *)(SOCKET s, char FAR * buf, + int len, int flags)) GetProcAddress(winSock.hInstance, "recv"); + winSock.send = (int (PASCAL FAR *)(SOCKET s, const char FAR * buf, + int len, int flags)) GetProcAddress(winSock.hInstance, "send"); + winSock.setsockopt = (int (PASCAL FAR *)(SOCKET s, int level, + int optname, const char FAR * optval, int optlen)) + GetProcAddress(winSock.hInstance, "setsockopt"); + winSock.shutdown = (int (PASCAL FAR *)(SOCKET s, int how)) + GetProcAddress(winSock.hInstance, "shutdown"); + winSock.socket = (SOCKET (PASCAL FAR *)(int af, int type, + int protocol)) GetProcAddress(winSock.hInstance, "socket"); + winSock.gethostbyaddr = (struct hostent FAR * (PASCAL FAR *) + (const char FAR *addr, int addrlen, int addrtype)) + GetProcAddress(winSock.hInstance, "gethostbyaddr"); + winSock.gethostbyname = (struct hostent FAR * (PASCAL FAR *) + (const char FAR *name)) + GetProcAddress(winSock.hInstance, "gethostbyname"); + winSock.gethostname = (int (PASCAL FAR *)(char FAR * name, + int namelen)) GetProcAddress(winSock.hInstance, "gethostname"); + winSock.getpeername = (int (PASCAL FAR *)(SOCKET sock, + struct sockaddr FAR *name, int FAR *namelen)) + GetProcAddress(winSock.hInstance, "getpeername"); + winSock.getservbyname = (struct servent FAR * (PASCAL FAR *) + (const char FAR * name, const char FAR * proto)) + GetProcAddress(winSock.hInstance, "getservbyname"); + winSock.getsockname = (int (PASCAL FAR *)(SOCKET sock, + struct sockaddr FAR *name, int FAR *namelen)) + GetProcAddress(winSock.hInstance, "getsockname"); + winSock.WSAStartup = (int (PASCAL FAR *)(WORD wVersionRequired, + LPWSADATA lpWSAData)) GetProcAddress(winSock.hInstance, "WSAStartup"); + winSock.WSACleanup = (int (PASCAL FAR *)(void)) + GetProcAddress(winSock.hInstance, "WSACleanup"); + winSock.WSAGetLastError = (int (PASCAL FAR *)(void)) + GetProcAddress(winSock.hInstance, "WSAGetLastError"); + winSock.WSAAsyncSelect = (int (PASCAL FAR *)(SOCKET s, HWND hWnd, + u_int wMsg, long lEvent)) + GetProcAddress(winSock.hInstance, "WSAAsyncSelect"); + + /* + * Now check that all fields are properly initialized. If not, return + * zero to indicate that we failed to initialize properly. + */ + + if ((winSock.hInstance == NULL) || + (winSock.accept == NULL) || + (winSock.bind == NULL) || + (winSock.closesocket == NULL) || + (winSock.connect == NULL) || + (winSock.ioctlsocket == NULL) || + (winSock.getsockopt == NULL) || + (winSock.htons == NULL) || + (winSock.inet_addr == NULL) || + (winSock.inet_ntoa == NULL) || + (winSock.listen == NULL) || + (winSock.ntohs == NULL) || + (winSock.recv == NULL) || + (winSock.send == NULL) || + (winSock.setsockopt == NULL) || + (winSock.socket == NULL) || + (winSock.gethostbyname == NULL) || + (winSock.gethostbyaddr == NULL) || + (winSock.gethostname == NULL) || + (winSock.getpeername == NULL) || + (winSock.getservbyname == NULL) || + (winSock.getsockname == NULL) || + (winSock.WSAStartup == NULL) || + (winSock.WSACleanup == NULL) || + (winSock.WSAGetLastError == NULL) || + (winSock.WSAAsyncSelect == NULL)) { + goto unloadLibrary; + } + + /* + * Initialize the winsock library and check the version number. + */ + + if ((*winSock.WSAStartup)(WSA_VERSION_REQD, &wsaData) != 0) { + goto unloadLibrary; + } + if (wsaData.wVersion != WSA_VERSION_REQD) { + (*winSock.WSACleanup)(); + goto unloadLibrary; + } + + /* + * Create the async notification window with a new class. We + * must create a new class to avoid a Windows 95 bug that causes + * us to get the wrong message number for socket events if the + * message window is a subclass of a static control. + */ + + class.style = 0; + class.cbClsExtra = 0; + class.cbWndExtra = 0; + class.hInstance = TclWinGetTclInstance(); + class.hbrBackground = NULL; + class.lpszMenuName = NULL; + class.lpszClassName = "TclSocket"; + class.lpfnWndProc = SocketProc; + class.hIcon = NULL; + class.hCursor = NULL; + + if (RegisterClass(&class)) { + winSock.hwnd = CreateWindow("TclSocket", "TclSocket", WS_TILED, 0, 0, + 0, 0, NULL, NULL, class.hInstance, NULL); + } else { + winSock.hwnd = NULL; + } + if (winSock.hwnd == NULL) { + TclWinConvertError(GetLastError()); + (*winSock.WSACleanup)(); + goto unloadLibrary; + } + Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); + return; + +unloadLibrary: + FreeLibrary(winSock.hInstance); + winSock.hInstance = NULL; + return; +} + +/* + *---------------------------------------------------------------------- + * + * SocketExitHandler -- + * + * Callback invoked during exit clean up to delete the socket + * communication window and to release the WinSock DLL. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +SocketExitHandler(clientData) + ClientData clientData; /* Not used. */ +{ + if (winSock.hInstance) { + DestroyWindow(winSock.hwnd); + UnregisterClass("TclSocket", TclWinGetTclInstance()); + (*winSock.WSACleanup)(); + FreeLibrary(winSock.hInstance); + winSock.hInstance = NULL; + } + Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL); + initialized = 0; + hostnameInitialized = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclHasSockets -- + * + * This function determines whether sockets are available on the + * current system and returns an error in interp if they are not. + * Note that interp may be NULL. + * + * Results: + * Returns TCL_OK if the system supports sockets, or TCL_ERROR with + * an error in interp. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclHasSockets(interp) + Tcl_Interp *interp; +{ + if (!initialized) { + InitSockets(); + } + + if (winSock.hInstance != NULL) { + return TCL_OK; + } + if (interp != NULL) { + Tcl_AppendResult(interp, "sockets are not available on this system", + NULL); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * SocketSetupProc -- + * + * This procedure is invoked before Tcl_DoOneEvent blocks waiting + * for an event. + * + * Results: + * None. + * + * Side effects: + * Adjusts the block time if needed. + * + *---------------------------------------------------------------------- + */ + +void +SocketSetupProc(data, flags) + ClientData data; /* Not used. */ + int flags; /* Event flags as passed to Tcl_DoOneEvent. */ +{ + SocketInfo *infoPtr; + Tcl_Time blockTime = { 0, 0 }; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + /* + * Check to see if there is a ready socket. If so, poll. + */ + + for (infoPtr = socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (infoPtr->readyEvents & infoPtr->watchEvents) { + Tcl_SetMaxBlockTime(&blockTime); + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * SocketCheckProc -- + * + * This procedure is called by Tcl_DoOneEvent to check the socket + * event source for events. + * + * Results: + * None. + * + * Side effects: + * May queue an event. + * + *---------------------------------------------------------------------- + */ + +static void +SocketCheckProc(data, flags) + ClientData data; /* Not used. */ + int flags; /* Event flags as passed to Tcl_DoOneEvent. */ +{ + SocketInfo *infoPtr; + SocketEvent *evPtr; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + /* + * Queue events for any ready sockets that don't already have events + * queued (caused by persistent states that won't generate WinSock + * events). + */ + + for (infoPtr = socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if ((infoPtr->readyEvents & infoPtr->watchEvents) + && !(infoPtr->flags & SOCKET_PENDING)) { + infoPtr->flags |= SOCKET_PENDING; + evPtr = (SocketEvent *) ckalloc(sizeof(SocketEvent)); + evPtr->header.proc = SocketEventProc; + evPtr->socket = infoPtr->socket; + Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * SocketEventProc -- + * + * This procedure is called by Tcl_ServiceEvent when a socket event + * reaches the front of the event queue. This procedure is + * responsible for notifying the generic channel code. + * + * Results: + * Returns 1 if the event was handled, meaning it should be removed + * from the queue. Returns 0 if the event was not handled, meaning + * it should stay on the queue. The only time the event isn't + * handled is if the TCL_FILE_EVENTS flag bit isn't set. + * + * Side effects: + * Whatever the channel callback procedures do. + * + *---------------------------------------------------------------------- + */ + +static int +SocketEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_FILE_EVENTS. */ +{ + SocketInfo *infoPtr; + SocketEvent *eventPtr = (SocketEvent *) evPtr; + int mask = 0; + u_long nBytes; + int status, events; + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } + + /* + * Find the specified socket on the socket list. + */ + + for (infoPtr = socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (infoPtr->socket == eventPtr->socket) { + break; + } + } + + /* + * Discard events that have gone stale. + */ + + if (!infoPtr) { + return 1; + } + + infoPtr->flags &= ~SOCKET_PENDING; + + /* + * Handle connection requests directly. + */ + + if (infoPtr->readyEvents & FD_ACCEPT) { + TcpAccept(infoPtr); + return 1; + } + + + /* + * Mask off unwanted events and compute the read/write mask so + * we can notify the channel. + */ + + events = infoPtr->readyEvents & infoPtr->watchEvents; + + if (events & FD_CLOSE) { + /* + * If the socket was closed and the channel is still interested + * in read events, then we need to ensure that we keep polling + * for this event until someone does something with the channel. + * Note that we do this before calling Tcl_NotifyChannel so we don't + * have to watch out for the channel being deleted out from under + * us. This may cause a redundant trip through the event loop, but + * it's simpler than trying to do unwind protection. + */ + + Tcl_Time blockTime = { 0, 0 }; + Tcl_SetMaxBlockTime(&blockTime); + mask |= TCL_READABLE; + } else if (events & FD_READ) { + /* + * We must check to see if data is really available, since someone + * could have consumed the data in the meantime. + */ + + status = (*winSock.ioctlsocket)(infoPtr->socket, FIONREAD, + &nBytes); + if (status != SOCKET_ERROR && nBytes > 0) { + mask |= TCL_READABLE; + } else { + /* + * We are in a strange state, probably because someone + * besides Tcl is reading from this socket. Try to + * recover by clearing the read event. + */ + + infoPtr->readyEvents &= ~(FD_READ); + + /* + * Re-issue WSAAsyncSelect() since we are gobbling up an + * event, without letting the reader do any I/O to re-enable + * the notification. + */ + + (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd, + SOCKET_MESSAGE, infoPtr->selectEvents); + } + } + if (events & FD_WRITE) { + mask |= TCL_WRITABLE; + } + + if (mask) { + Tcl_NotifyChannel(infoPtr->channel, mask); + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TcpBlockProc -- + * + * Sets a socket into blocking or non-blocking mode. + * + * Results: + * 0 if successful, errno if there was an error. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TcpBlockProc(instanceData, mode) + ClientData instanceData; /* The socket to block/un-block. */ + int mode; /* TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + SocketInfo *infoPtr = (SocketInfo *) instanceData; + + if (mode == TCL_MODE_NONBLOCKING) { + infoPtr->flags |= SOCKET_ASYNC; + } else { + infoPtr->flags &= ~(SOCKET_ASYNC); + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TcpCloseProc -- + * + * This procedure is called by the generic IO level to perform + * channel type specific cleanup on a socket based channel + * when the channel is closed. + * + * Results: + * 0 if successful, the value of errno if failed. + * + * Side effects: + * Closes the socket. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TcpCloseProc(instanceData, interp) + ClientData instanceData; /* The socket to close. */ + Tcl_Interp *interp; /* Unused. */ +{ + SocketInfo *infoPtr = (SocketInfo *) instanceData; + SocketInfo **nextPtrPtr; + int errorCode = 0; + + /* + * Check that WinSock is initialized; do not call it if not, to + * prevent system crashes. This can happen at exit time if the exit + * handler for WinSock ran before other exit handlers that want to + * use sockets. + */ + + if (winSock.hInstance != NULL) { + + /* + * Clean up the OS socket handle. The default Windows setting + * for a socket is SO_DONTLINGER, which does a graceful shutdown + * in the background. + */ + + if ((*winSock.closesocket)(infoPtr->socket) == SOCKET_ERROR) { + TclWinConvertWSAError((*winSock.WSAGetLastError)()); + errorCode = Tcl_GetErrno(); + } + } + + /* + * Remove the socket from socketList. + */ + + for (nextPtrPtr = &socketList; (*nextPtrPtr) != NULL; + nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { + if ((*nextPtrPtr) == infoPtr) { + (*nextPtrPtr) = infoPtr->nextPtr; + break; + } + } + ckfree((char *) infoPtr); + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * NewSocketInfo -- + * + * This function allocates and initializes a new SocketInfo + * structure. + * + * Results: + * Returns a newly allocated SocketInfo. + * + * Side effects: + * Adds the socket to the global socket list. + * + *---------------------------------------------------------------------- + */ + +static SocketInfo * +NewSocketInfo(socket) + SOCKET socket; +{ + SocketInfo *infoPtr; + + infoPtr = (SocketInfo *) ckalloc((unsigned) sizeof(SocketInfo)); + infoPtr->socket = socket; + infoPtr->flags = 0; + infoPtr->watchEvents = 0; + infoPtr->readyEvents = 0; + infoPtr->selectEvents = 0; + infoPtr->acceptProc = NULL; + infoPtr->lastError = 0; + infoPtr->nextPtr = socketList; + socketList = infoPtr; + return infoPtr; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSocket -- + * + * This function opens a new socket and initializes the + * SocketInfo structure. + * + * Results: + * Returns a new SocketInfo, or NULL with an error in interp. + * + * Side effects: + * Adds a new socket to the socketList. + * + *---------------------------------------------------------------------- + */ + +static SocketInfo * +CreateSocket(interp, port, host, server, myaddr, myport, async) + Tcl_Interp *interp; /* For error reporting; can be NULL. */ + int port; /* Port number to open. */ + char *host; /* Name of host on which to open port. */ + int server; /* 1 if socket should be a server socket, + * else 0 for a client socket. */ + char *myaddr; /* Optional client-side address */ + int myport; /* Optional client-side port */ + int async; /* If nonzero, connect client socket + * asynchronously. */ +{ + u_long flag = 1; /* Indicates nonblocking mode. */ + int asyncConnect = 0; /* Will be 1 if async connect is + * in progress. */ + struct sockaddr_in sockaddr; /* Socket address */ + struct sockaddr_in mysockaddr; /* Socket address for client */ + SOCKET sock; + SocketInfo *infoPtr; /* The returned value. */ + + /* + * Check that WinSock is initialized; do not call it if not, to + * prevent system crashes. This can happen at exit time if the exit + * handler for WinSock ran before other exit handlers that want to + * use sockets. + */ + + if (winSock.hInstance == NULL) { + return NULL; + } + + if (! CreateSocketAddress(&sockaddr, host, port)) { + goto error; + } + if ((myaddr != NULL || myport != 0) && + ! CreateSocketAddress(&mysockaddr, myaddr, myport)) { + goto error; + } + + sock = (*winSock.socket)(AF_INET, SOCK_STREAM, 0); + if (sock == INVALID_SOCKET) { + goto error; + } + + /* + * Set kernel space buffering + */ + + TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE); + + if (server) { + /* + * Bind to the specified port. Note that we must not call setsockopt + * with SO_REUSEADDR because Microsoft allows addresses to be reused + * even if they are still in use. + * + * Bind should not be affected by the socket having already been + * set into nonblocking mode. If there is trouble, this is one place + * to look for bugs. + */ + + if ((*winSock.bind)(sock, (struct sockaddr *) &sockaddr, + sizeof(sockaddr)) == SOCKET_ERROR) { + goto error; + } + + /* + * Set the maximum number of pending connect requests to the + * max value allowed on each platform (Win32 and Win32s may be + * different, and there may be differences between TCP/IP stacks). + */ + + if ((*winSock.listen)(sock, SOMAXCONN) == SOCKET_ERROR) { + goto error; + } + + /* + * Add this socket to the global list of sockets. + */ + + infoPtr = NewSocketInfo(sock); + + /* + * Set up the select mask for connection request events. + */ + + infoPtr->selectEvents = FD_ACCEPT; + infoPtr->watchEvents |= FD_ACCEPT; + + } else { + + /* + * Try to bind to a local port, if specified. + */ + + if (myaddr != NULL || myport != 0) { + if ((*winSock.bind)(sock, (struct sockaddr *) &mysockaddr, + sizeof(struct sockaddr)) == SOCKET_ERROR) { + goto error; + } + } + + /* + * Set the socket into nonblocking mode if the connect should be + * done in the background. + */ + + if (async) { + if ((*winSock.ioctlsocket)(sock, FIONBIO, &flag) == SOCKET_ERROR) { + goto error; + } + } + + /* + * Attempt to connect to the remote socket. + */ + + if ((*winSock.connect)(sock, (struct sockaddr *) &sockaddr, + sizeof(sockaddr)) == SOCKET_ERROR) { + TclWinConvertWSAError((*winSock.WSAGetLastError)()); + if (Tcl_GetErrno() != EWOULDBLOCK) { + goto error; + } + + /* + * The connection is progressing in the background. + */ + + asyncConnect = 1; + } + + /* + * Add this socket to the global list of sockets. + */ + + infoPtr = NewSocketInfo(sock); + + /* + * Set up the select mask for read/write events. If the connect + * attempt has not completed, include connect events. + */ + + infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; + if (asyncConnect) { + infoPtr->flags |= SOCKET_ASYNC_CONNECT; + infoPtr->selectEvents |= FD_CONNECT; + } + } + + /* + * Register for interest in events in the select mask. Note that this + * automatically places the socket into non-blocking mode. + */ + + (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd, + SOCKET_MESSAGE, infoPtr->selectEvents); + + return infoPtr; + +error: + TclWinConvertWSAError((*winSock.WSAGetLastError)()); + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't open socket: ", + Tcl_PosixError(interp), (char *) NULL); + } + if (sock != INVALID_SOCKET) { + (*winSock.closesocket)(sock); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSocketAddress -- + * + * This function initializes a sockaddr structure for a host and port. + * + * Results: + * 1 if the host was valid, 0 if the host could not be converted to + * an IP address. + * + * Side effects: + * Fills in the *sockaddrPtr structure. + * + *---------------------------------------------------------------------- + */ + +static int +CreateSocketAddress(sockaddrPtr, host, port) + struct sockaddr_in *sockaddrPtr; /* Socket address */ + char *host; /* Host. NULL implies INADDR_ANY */ + int port; /* Port number */ +{ + struct hostent *hostent; /* Host database entry */ + struct in_addr addr; /* For 64/32 bit madness */ + + /* + * Check that WinSock is initialized; do not call it if not, to + * prevent system crashes. This can happen at exit time if the exit + * handler for WinSock ran before other exit handlers that want to + * use sockets. + */ + + if (winSock.hInstance == NULL) { + Tcl_SetErrno(EFAULT); + return 0; + } + + (void) memset((char *) sockaddrPtr, '\0', sizeof(struct sockaddr_in)); + sockaddrPtr->sin_family = AF_INET; + sockaddrPtr->sin_port = (*winSock.htons)((short) (port & 0xFFFF)); + if (host == NULL) { + addr.s_addr = INADDR_ANY; + } else { + addr.s_addr = (*winSock.inet_addr)(host); + if (addr.s_addr == INADDR_NONE) { + hostent = (*winSock.gethostbyname)(host); + if (hostent != NULL) { + memcpy((char *) &addr, + (char *) hostent->h_addr_list[0], + (size_t) hostent->h_length); + } else { +#ifdef EHOSTUNREACH + Tcl_SetErrno(EHOSTUNREACH); +#else +#ifdef ENXIO + Tcl_SetErrno(ENXIO); +#endif +#endif + return 0; /* Error. */ + } + } + } + + /* + * NOTE: On 64 bit machines the assignment below is rumored to not + * do the right thing. Please report errors related to this if you + * observe incorrect behavior on 64 bit machines such as DEC Alphas. + * Should we modify this code to do an explicit memcpy? + */ + + sockaddrPtr->sin_addr.s_addr = addr.s_addr; + return 1; /* Success. */ +} + +/* + *---------------------------------------------------------------------- + * + * WaitForSocketEvent -- + * + * Waits until one of the specified events occurs on a socket. + * + * Results: + * Returns 1 on success or 0 on failure, with an error code in + * errorCodePtr. + * + * Side effects: + * Processes socket events off the system queue. + * + *---------------------------------------------------------------------- + */ + +static int +WaitForSocketEvent(infoPtr, events, errorCodePtr) + SocketInfo *infoPtr; /* Information about this socket. */ + int events; /* Events to look for. */ + int *errorCodePtr; /* Where to store errors? */ +{ + MSG msg; + int result = 1; + int oldMode; + + /* + * Be sure to disable event servicing so we are truly modal. + */ + + oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); + + while (!(infoPtr->readyEvents & events)) { + if (infoPtr->flags & SOCKET_ASYNC) { + if (!PeekMessage(&msg, winSock.hwnd, SOCKET_MESSAGE, + SOCKET_MESSAGE, PM_REMOVE)) { + *errorCodePtr = EWOULDBLOCK; + result = 0; + break; + } + } else { + /* + * Look for a socket event. Note that we will be getting + * events for all of Tcl's sockets, not just the one we wanted. + */ + + result = GetMessage(&msg, winSock.hwnd, SOCKET_MESSAGE, + SOCKET_MESSAGE); + if (result == -1) { + TclWinConvertError(GetLastError()); + *errorCodePtr = Tcl_GetErrno(); + result = 0; + break; + } + + /* + * I don't think we can get a WM_QUIT during a tight modal + * loop, but just in case... + */ + + if (result == 0) { + panic("WaitForSocketEvent: Got WM_QUIT during modal loop!"); + } + } + + /* + * Dispatch the message and then check for an error on the socket. + */ + + infoPtr->lastError = 0; + DispatchMessage(&msg); + if (infoPtr->lastError) { + *errorCodePtr = infoPtr->lastError; + result = 0; + break; + } + } + + (void) Tcl_SetServiceMode(oldMode); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpClient -- + * + * Opens a TCP client socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. An error message is returned + * in the interpreter on failure. + * + * Side effects: + * Opens a client socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async) + Tcl_Interp *interp; /* For error reporting; can be NULL. */ + int port; /* Port number to open. */ + char *host; /* Host on which to open port. */ + char *myaddr; /* Client-side address */ + int myport; /* Client-side port */ + int async; /* If nonzero, should connect + * client socket asynchronously. */ +{ + SocketInfo *infoPtr; + char channelName[20]; + + if (TclHasSockets(interp) != TCL_OK) { + return NULL; + } + + /* + * Create a new client socket and wrap it in a channel. + */ + + infoPtr = CreateSocket(interp, port, host, 0, myaddr, myport, async); + if (infoPtr == NULL) { + return NULL; + } + + sprintf(channelName, "sock%d", infoPtr->socket); + + infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE)); + if (Tcl_SetChannelOption(interp, infoPtr->channel, "-translation", + "auto crlf") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); + return (Tcl_Channel) NULL; + } + if (Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "") + == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); + return (Tcl_Channel) NULL; + } + return infoPtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeTcpClientChannel -- + * + * Creates a Tcl_Channel from an existing client TCP socket. + * + * Results: + * The Tcl_Channel wrapped around the preexisting TCP socket. + * + * Side effects: + * None. + * + * NOTE: Code contributed by Mark Diekhans (markd@grizzly.com) + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_MakeTcpClientChannel(sock) + ClientData sock; /* The socket to wrap up into a channel. */ +{ + SocketInfo *infoPtr; + char channelName[20]; + + if (TclHasSockets(NULL) != TCL_OK) { + return NULL; + } + + /* + * Set kernel space buffering and non-blocking. + */ + + TclSockMinimumBuffers((SOCKET) sock, TCP_BUFFER_SIZE); + + infoPtr = NewSocketInfo((SOCKET) sock); + + /* + * Start watching for read/write events on the socket. + */ + + infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE; + (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd, + SOCKET_MESSAGE, infoPtr->selectEvents); + + sprintf(channelName, "sock%d", infoPtr->socket); + infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE)); + Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto crlf"); + return infoPtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpServer -- + * + * Opens a TCP server socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. An error message is returned + * in the interpreter on failure. + * + * Side effects: + * Opens a server socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpServer(interp, port, host, acceptProc, acceptProcData) + Tcl_Interp *interp; /* For error reporting - may be + * NULL. */ + int port; /* Port number to open. */ + char *host; /* Name of local host. */ + Tcl_TcpAcceptProc *acceptProc; /* Callback for accepting connections + * from new clients. */ + ClientData acceptProcData; /* Data for the callback. */ +{ + SocketInfo *infoPtr; + char channelName[20]; + + if (TclHasSockets(interp) != TCL_OK) { + return NULL; + } + + /* + * Create a new client socket and wrap it in a channel. + */ + + infoPtr = CreateSocket(interp, port, host, 1, NULL, 0, 0); + if (infoPtr == NULL) { + return NULL; + } + + infoPtr->acceptProc = acceptProc; + infoPtr->acceptProcData = acceptProcData; + + sprintf(channelName, "sock%d", infoPtr->socket); + + infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) infoPtr, 0); + if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "") + == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); + return (Tcl_Channel) NULL; + } + + return infoPtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * TcpAccept -- + * Accept a TCP socket connection. This is called by + * SocketEventProc and it in turns calls the registered accept + * procedure. + * + * Results: + * None. + * + * Side effects: + * Invokes the accept proc which may invoke arbitrary Tcl code. + * + *---------------------------------------------------------------------- + */ + +static void +TcpAccept(infoPtr) + SocketInfo *infoPtr; /* Socket to accept. */ +{ + SOCKET newSocket; + SocketInfo *newInfoPtr; + struct sockaddr_in addr; + int len; + char channelName[20]; + + /* + * Accept the incoming connection request. + */ + + len = sizeof(struct sockaddr_in); + newSocket = (*winSock.accept)(infoPtr->socket, (struct sockaddr *)&addr, + &len); + + /* + * Clear the ready mask so we can detect the next connection request. + * Note that connection requests are level triggered, so if there is + * a request already pending, a new event will be generated. + */ + + infoPtr->readyEvents &= ~(FD_ACCEPT); + + if (newSocket == INVALID_SOCKET) { + return; + } + + /* + * Add this socket to the global list of sockets. + */ + + newInfoPtr = NewSocketInfo(newSocket); + + /* + * Select on read/write events and create the channel. + */ + + newInfoPtr->selectEvents = (FD_READ | FD_WRITE | FD_CLOSE); + (void) (*winSock.WSAAsyncSelect)(newInfoPtr->socket, winSock.hwnd, + SOCKET_MESSAGE, newInfoPtr->selectEvents); + + sprintf(channelName, "sock%d", newInfoPtr->socket); + newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) newInfoPtr, (TCL_READABLE | TCL_WRITABLE)); + if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation", + "auto crlf") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel); + return; + } + if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "") + == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel); + return; + } + + /* + * Invoke the accept callback procedure. + */ + + if (infoPtr->acceptProc != NULL) { + (infoPtr->acceptProc) (infoPtr->acceptProcData, newInfoPtr->channel, + (*winSock.inet_ntoa)(addr.sin_addr), + (*winSock.ntohs)(addr.sin_port)); + } +} + +/* + *---------------------------------------------------------------------- + * + * TcpInputProc -- + * + * This procedure is called by the generic IO level to read data from + * a socket based channel. + * + * Results: + * The number of bytes read or -1 on error. + * + * Side effects: + * Consumes input from the socket. + * + *---------------------------------------------------------------------- + */ + +static int +TcpInputProc(instanceData, buf, toRead, errorCodePtr) + ClientData instanceData; /* The socket state. */ + char *buf; /* Where to store data. */ + int toRead; /* Maximum number of bytes to read. */ + int *errorCodePtr; /* Where to store error codes. */ +{ + SocketInfo *infoPtr = (SocketInfo *) instanceData; + int bytesRead; + int error; + + *errorCodePtr = 0; + + /* + * Check that WinSock is initialized; do not call it if not, to + * prevent system crashes. This can happen at exit time if the exit + * handler for WinSock ran before other exit handlers that want to + * use sockets. + */ + + if (winSock.hInstance == NULL) { + *errorCodePtr = EFAULT; + return -1; + } + + /* + * First check to see if EOF was already detected, to prevent + * calling the socket stack after the first time EOF is detected. + */ + + if (infoPtr->flags & SOCKET_EOF) { + return 0; + } + + /* + * Check to see if the socket is connected before trying to read. + */ + + if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) + && ! WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { + return -1; + } + + /* + * No EOF, and it is connected, so try to read more from the socket. + * Note that we clear the FD_READ bit because read events are level + * triggered so a new event will be generated if there is still data + * available to be read. We have to simulate blocking behavior here + * since we are always using non-blocking sockets. + */ + + while (1) { + if (infoPtr->readyEvents & (FD_CLOSE|FD_READ)) { + bytesRead = (*winSock.recv)(infoPtr->socket, buf, toRead, 0); + infoPtr->readyEvents &= ~(FD_READ); + + /* + * Check for end-of-file condition or successful read. + */ + + if (bytesRead == 0) { + infoPtr->flags |= SOCKET_EOF; + } + if (bytesRead != SOCKET_ERROR) { + return bytesRead; + } + + /* + * If an error occurs after the FD_CLOSE has arrived, + * then ignore the error and report an EOF. + */ + + if (infoPtr->readyEvents & FD_CLOSE) { + infoPtr->flags |= SOCKET_EOF; + return 0; + } + + /* + * Check for error condition or underflow in non-blocking case. + */ + + error = (*winSock.WSAGetLastError)(); + if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) { + TclWinConvertWSAError(error); + *errorCodePtr = Tcl_GetErrno(); + return -1; + } + + } else if (infoPtr->flags & SOCKET_ASYNC) { + *errorCodePtr = EWOULDBLOCK; + return -1; + } + + /* + * In the blocking case, wait until the file becomes readable + * or closed and try again. + */ + + if (!WaitForSocketEvent(infoPtr, FD_READ|FD_CLOSE, errorCodePtr)) { + return -1; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TcpOutputProc -- + * + * This procedure is called by the generic IO level to write data + * to a socket based channel. + * + * Results: + * The number of bytes written or -1 on failure. + * + * Side effects: + * Produces output on the socket. + * + *---------------------------------------------------------------------- + */ + +static int +TcpOutputProc(instanceData, buf, toWrite, errorCodePtr) + ClientData instanceData; /* The socket state. */ + char *buf; /* Where to get data. */ + int toWrite; /* Maximum number of bytes to write. */ + int *errorCodePtr; /* Where to store error codes. */ +{ + SocketInfo *infoPtr = (SocketInfo *) instanceData; + int bytesWritten; + int error; + + *errorCodePtr = 0; + + /* + * Check that WinSock is initialized; do not call it if not, to + * prevent system crashes. This can happen at exit time if the exit + * handler for WinSock ran before other exit handlers that want to + * use sockets. + */ + + if (winSock.hInstance == NULL) { + *errorCodePtr = EFAULT; + return -1; + } + + /* + * Check to see if the socket is connected before trying to write. + */ + + if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) + && ! WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { + return -1; + } + + while (1) { + bytesWritten = (*winSock.send)(infoPtr->socket, buf, toWrite, 0); + if (bytesWritten != SOCKET_ERROR) { + /* + * Since Windows won't generate a new write event until we hit + * an overflow condition, we need to force the event loop to + * poll until the condition changes. + */ + + if (infoPtr->watchEvents & FD_WRITE) { + Tcl_Time blockTime = { 0, 0 }; + Tcl_SetMaxBlockTime(&blockTime); + } + break; + } + + /* + * Check for error condition or overflow. In the event of overflow, we + * need to clear the FD_WRITE flag so we can detect the next writable + * event. Note that Windows only sends a new writable event after a + * send fails with WSAEWOULDBLOCK. + */ + + error = (*winSock.WSAGetLastError)(); + if (error == WSAEWOULDBLOCK) { + infoPtr->readyEvents &= ~(FD_WRITE); + if (infoPtr->flags & SOCKET_ASYNC) { + *errorCodePtr = EWOULDBLOCK; + return -1; + } + } else { + TclWinConvertWSAError(error); + *errorCodePtr = Tcl_GetErrno(); + return -1; + } + + /* + * In the blocking case, wait until the file becomes writable + * or closed and try again. + */ + + if (!WaitForSocketEvent(infoPtr, FD_WRITE|FD_CLOSE, errorCodePtr)) { + return -1; + } + } + + return bytesWritten; +} + +/* + *---------------------------------------------------------------------- + * + * TcpGetOptionProc -- + * + * Computes an option value for a TCP socket based channel, or a + * list of all options and their values. + * + * Note: This code is based on code contributed by John Haxby. + * + * Results: + * A standard Tcl result. The value of the specified option or a + * list of all options and their values is returned in the + * supplied DString. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TcpGetOptionProc(instanceData, interp, optionName, dsPtr) + ClientData instanceData; /* Socket state. */ + Tcl_Interp *interp; /* For error reporting - can be NULL */ + char *optionName; /* Name of the option to + * retrieve the value for, or + * NULL to get all options and + * their values. */ + Tcl_DString *dsPtr; /* Where to store the computed + * value; initialized by caller. */ +{ + SocketInfo *infoPtr; + struct sockaddr_in sockname; + struct sockaddr_in peername; + struct hostent *hostEntPtr; + SOCKET sock; + int size = sizeof(struct sockaddr_in); + size_t len = 0; + char buf[128]; + + /* + * Check that WinSock is initialized; do not call it if not, to + * prevent system crashes. This can happen at exit time if the exit + * handler for WinSock ran before other exit handlers that want to + * use sockets. + */ + + if (winSock.hInstance == NULL) { + if (interp) { + Tcl_AppendResult(interp, "winsock is not initialized", NULL); + } + return TCL_ERROR; + } + + infoPtr = (SocketInfo *) instanceData; + sock = (int) infoPtr->socket; + if (optionName != (char *) NULL) { + len = strlen(optionName); + } + + if ((len == 0) || + ((len > 1) && (optionName[1] == 'p') && + (strncmp(optionName, "-peername", len) == 0))) { + if ((*winSock.getpeername)(sock, (struct sockaddr *) &peername, &size) + == 0) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-peername"); + Tcl_DStringStartSublist(dsPtr); + } + Tcl_DStringAppendElement(dsPtr, + (*winSock.inet_ntoa)(peername.sin_addr)); + hostEntPtr = (*winSock.gethostbyaddr)( + (char *) &(peername.sin_addr), sizeof(peername.sin_addr), + AF_INET); + if (hostEntPtr != (struct hostent *) NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, + (*winSock.inet_ntoa)(peername.sin_addr)); + } + sprintf(buf, "%d", (*winSock.ntohs)(peername.sin_port)); + Tcl_DStringAppendElement(dsPtr, buf); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } else { + /* + * getpeername failed - but if we were asked for all the options + * (len==0), don't flag an error at that point because it could + * be an fconfigure request on a server socket. (which have + * no peer). {copied from unix/tclUnixChan.c} + */ + if (len) { + TclWinConvertWSAError((*winSock.WSAGetLastError)()); + if (interp) { + Tcl_AppendResult(interp, "can't get peername: ", + Tcl_PosixError(interp), + (char *) NULL); + } + return TCL_ERROR; + } + } + } + + if ((len == 0) || + ((len > 1) && (optionName[1] == 's') && + (strncmp(optionName, "-sockname", len) == 0))) { + if ((*winSock.getsockname)(sock, (struct sockaddr *) &sockname, &size) + == 0) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-sockname"); + Tcl_DStringStartSublist(dsPtr); + } + Tcl_DStringAppendElement(dsPtr, + (*winSock.inet_ntoa)(sockname.sin_addr)); + hostEntPtr = (*winSock.gethostbyaddr)( + (char *) &(sockname.sin_addr), sizeof(peername.sin_addr), + AF_INET); + if (hostEntPtr != (struct hostent *) NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, + (*winSock.inet_ntoa)(sockname.sin_addr)); + } + sprintf(buf, "%d", (*winSock.ntohs)(sockname.sin_port)); + Tcl_DStringAppendElement(dsPtr, buf); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } else { + if (interp) { + TclWinConvertWSAError((*winSock.WSAGetLastError)()); + Tcl_AppendResult(interp, "can't get sockname: ", + Tcl_PosixError(interp), + (char *) NULL); + } + return TCL_ERROR; + } + } + + if (len > 0) { + return Tcl_BadChannelOption(interp, optionName, "peername sockname"); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TcpWatchProc -- + * + * Informs the channel driver of the events that the generic + * channel code wishes to receive on this socket. + * + * Results: + * None. + * + * Side effects: + * May cause the notifier to poll if any of the specified + * conditions are already true. + * + *---------------------------------------------------------------------- + */ + +static void +TcpWatchProc(instanceData, mask) + ClientData instanceData; /* The socket state. */ + int mask; /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + SocketInfo *infoPtr = (SocketInfo *) instanceData; + + /* + * Update the watch events mask. + */ + + infoPtr->watchEvents = 0; + if (mask & TCL_READABLE) { + infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT); + } + if (mask & TCL_WRITABLE) { + infoPtr->watchEvents |= (FD_WRITE); + } + + /* + * If there are any conditions already set, then tell the notifier to poll + * rather than block. + */ + + if (infoPtr->readyEvents & infoPtr->watchEvents) { + Tcl_Time blockTime = { 0, 0 }; + Tcl_SetMaxBlockTime(&blockTime); + } +} + +/* + *---------------------------------------------------------------------- + * + * TcpGetProc -- + * + * Called from Tcl_GetChannelFile to retrieve an OS handle from inside + * a TCP socket based channel. + * + * Results: + * Returns TCL_OK with the socket in handlePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TcpGetHandleProc(instanceData, direction, handlePtr) + ClientData instanceData; /* The socket state. */ + int direction; /* Not used. */ + ClientData *handlePtr; /* Where to store the handle. */ +{ + SocketInfo *statePtr = (SocketInfo *) instanceData; + + *handlePtr = (ClientData) statePtr->socket; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SocketProc -- + * + * This function is called when WSAAsyncSelect has been used + * to register interest in a socket event, and the event has + * occurred. + * + * Results: + * 0 on success. + * + * Side effects: + * The flags for the given socket are updated to reflect the + * event that occured. + * + *---------------------------------------------------------------------- + */ + +static LRESULT CALLBACK +SocketProc(hwnd, message, wParam, lParam) + HWND hwnd; + UINT message; + WPARAM wParam; + LPARAM lParam; +{ + int event, error; + SOCKET socket; + SocketInfo *infoPtr; + + if (message != SOCKET_MESSAGE) { + return DefWindowProc(hwnd, message, wParam, lParam); + } + + event = WSAGETSELECTEVENT(lParam); + error = WSAGETSELECTERROR(lParam); + socket = (SOCKET) wParam; + + /* + * Find the specified socket on the socket list and update its + * eventState flag. + */ + + for (infoPtr = socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (infoPtr->socket == socket) { + /* + * Update the socket state. + */ + + if (event & FD_CLOSE) { + infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); + } + if (event & FD_CONNECT) { + /* + * The socket is now connected, so clear the async connect + * flag. + */ + + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + + /* + * Remember any error that occurred so we can report + * connection failures. + */ + + if (error != ERROR_SUCCESS) { + TclWinConvertWSAError(error); + infoPtr->lastError = Tcl_GetErrno(); + } + + } + infoPtr->readyEvents |= event; + break; + } + } + + /* + * Flush the Tcl event queue before returning to the event loop. + */ + + Tcl_ServiceAll(); + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetHostName -- + * + * Returns the name of the local host. + * + * Results: + * A string containing the network name for this machine, or + * an empty string if we can't figure out the name. The caller + * must not modify or free this string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetHostName() +{ + DWORD length; + char *p; + + if (hostnameInitialized) { + return hostname; + } + + if (TclHasSockets(NULL) == TCL_OK) { + if ((*winSock.gethostname)(hostname, sizeof(hostname)) == 0) { + hostnameInitialized = 1; + return hostname; + } + } + length = sizeof(hostname); + if (GetComputerName(hostname, &length) != 0) { + for (p = hostname; *p != '\0'; p++) { + if (isupper(*((unsigned char *) p))) { + *p = (char) tolower(*((unsigned char *) p)); + } + } + } else { + hostname[0] = '\0'; + } + hostnameInitialized = 1; + return hostname; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinGetSockOpt, et al. -- + * + * These functions are wrappers that let us bind the WinSock + * API dynamically so we can run on systems that don't have + * the wsock32.dll. We need wrappers for these interfaces + * because they are called from the generic Tcl code. + * + * Results: + * As defined for each function. + * + * Side effects: + * As defined for each function. + * + *---------------------------------------------------------------------- + */ + +int PASCAL FAR +TclWinGetSockOpt(SOCKET s, int level, int optname, char FAR * optval, + int FAR *optlen) +{ + /* + * Check that WinSock is initialized; do not call it if not, to + * prevent system crashes. This can happen at exit time if the exit + * handler for WinSock ran before other exit handlers that want to + * use sockets. + */ + + if (winSock.hInstance == NULL) { + return SOCKET_ERROR; + } + + return (*winSock.getsockopt)(s, level, optname, optval, optlen); +} + +int PASCAL FAR +TclWinSetSockOpt(SOCKET s, int level, int optname, const char FAR * optval, + int optlen) +{ + /* + * Check that WinSock is initialized; do not call it if not, to + * prevent system crashes. This can happen at exit time if the exit + * handler for WinSock ran before other exit handlers that want to + * use sockets. + */ + + if (winSock.hInstance == NULL) { + return SOCKET_ERROR; + } + + return (*winSock.setsockopt)(s, level, optname, optval, optlen); +} + +u_short PASCAL FAR +TclWinNToHS(u_short netshort) +{ + /* + * Check that WinSock is initialized; do not call it if not, to + * prevent system crashes. This can happen at exit time if the exit + * handler for WinSock ran before other exit handlers that want to + * use sockets. + */ + + if (winSock.hInstance == NULL) { + return (u_short) -1; + } + + return (*winSock.ntohs)(netshort); +} + +struct servent FAR * PASCAL FAR +TclWinGetServByName(const char FAR * name, const char FAR * proto) +{ + /* + * Check that WinSock is initialized; do not call it if not, to + * prevent system crashes. This can happen at exit time if the exit + * handler for WinSock ran before other exit handlers that want to + * use sockets. + */ + + if (winSock.hInstance == NULL) { + return (struct servent FAR *) NULL; + } + + return (*winSock.getservbyname)(name, proto); +} diff --git a/win/tclWinTest.c b/win/tclWinTest.c new file mode 100644 index 0000000..cb61403 --- /dev/null +++ b/win/tclWinTest.c @@ -0,0 +1,130 @@ +/* + * tclWinTest.c -- + * + * Contains commands for platform specific tests on Windows. + * + * 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: @(#) tclWinTest.c 1.2 97/03/20 15:04:12 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Forward declarations of procedures defined later in this file: + */ +int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); +static int TesteventloopCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * TclplatformtestInit -- + * + * Defines commands that test platform specific functionality for + * Unix platforms. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Defines new commands. + * + *---------------------------------------------------------------------- + */ + +int +TclplatformtestInit(interp) + Tcl_Interp *interp; /* Interpreter to add commands to. */ +{ + /* + * Add commands for platform specific tests for Windows here. + */ + + Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TesteventloopCmd -- + * + * This procedure implements the "testeventloop" command. It is + * used to test the Tcl notifier from an "external" event loop + * (i.e. not Tcl_DoOneEvent()). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TesteventloopCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static int *framePtr = NULL; /* Pointer to integer on stack frame of + * innermost invocation of the "wait" + * subcommand. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " option ... \"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "done") == 0) { + *framePtr = 1; + } else if (strcmp(argv[1], "wait") == 0) { + int *oldFramePtr; + int done; + MSG msg; + int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL); + + /* + * Save the old stack frame pointer and set up the current frame. + */ + + oldFramePtr = framePtr; + framePtr = &done; + + /* + * Enter a standard Windows event loop until the flag changes. + * Note that we do not explicitly call Tcl_ServiceEvent(). + */ + + done = 0; + while (!done) { + if (!GetMessage(&msg, NULL, 0, 0)) { + /* + * The application is exiting, so repost the quit message + * and start unwinding. + */ + + PostQuitMessage(msg.wParam); + break; + } + TranslateMessage(&msg); + DispatchMessage(&msg); + } + (void) Tcl_SetServiceMode(oldMode); + framePtr = oldFramePtr; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be done or wait", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} diff --git a/win/tclWinTime.c b/win/tclWinTime.c new file mode 100644 index 0000000..b59f68d --- /dev/null +++ b/win/tclWinTime.c @@ -0,0 +1,373 @@ +/* + * tclWinTime.c -- + * + * Contains Windows specific versions of Tcl functions that + * obtain time values from the operating system. + * + * Copyright 1995 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: @(#) tclWinTime.c 1.6 97/04/14 17:25:56 + */ + +#include "tclInt.h" +#include "tclPort.h" + +#define SECSPERDAY (60L * 60L * 24L) +#define SECSPERYEAR (SECSPERDAY * 365L) +#define SECSPER4YEAR (SECSPERYEAR * 4L + SECSPERDAY) + +/* + * The following arrays contain the day of year for the last day of + * each month, where index 1 is January. + */ + +static int normalDays[] = { + -1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333, 364 +}; + +static int leapDays[] = { + -1, 30, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 +}; + +/* + * Declarations for functions defined later in this file. + */ + +static struct tm * ComputeGMT _ANSI_ARGS_((const time_t *tp)); + +/* + *---------------------------------------------------------------------- + * + * TclpGetSeconds -- + * + * This procedure returns the number of seconds from the epoch. + * On most Unix systems the epoch is Midnight Jan 1, 1970 GMT. + * + * Results: + * Number of seconds from the epoch. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +unsigned long +TclpGetSeconds() +{ + return (unsigned long) time((time_t *) NULL); +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetClicks -- + * + * This procedure returns a value that represents the highest + * resolution clock available on the system. There are no + * guarantees on what the resolution will be. In Tcl we will + * call this value a "click". The start time is also system + * dependant. + * + * Results: + * Number of clicks from some start time. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +unsigned long +TclpGetClicks() +{ + return GetTickCount(); +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetTimeZone -- + * + * Determines the current timezone. The method varies wildly + * between different Platform implementations, so its hidden in + * this function. + * + * Results: + * Minutes west of GMT. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclpGetTimeZone (currentTime) + unsigned long currentTime; +{ + int timeZone; + + tzset(); + timeZone = _timezone / 60; + + return timeZone; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetTime -- + * + * Gets the current system time in seconds and microseconds + * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * Results: + * Returns the current time in timePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclpGetTime(timePtr) + Tcl_Time *timePtr; /* Location to store time information. */ +{ + struct timeb t; + + ftime(&t); + timePtr->sec = t.time; + timePtr->usec = t.millitm * 1000; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetTZName -- + * + * Gets the current timezone string. + * + * Results: + * Returns a pointer to a static string, or NULL on failure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclpGetTZName() +{ + tzset(); + if (_daylight && _tzname[1] != NULL) { + return _tzname[1]; + } else { + return _tzname[0]; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetDate -- + * + * This function converts between seconds and struct tm. If + * useGMT is true, then the returned date will be in Greenwich + * Mean Time (GMT). Otherwise, it will be in the local time zone. + * + * Results: + * Returns a static tm structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +struct tm * +TclpGetDate(tp, useGMT) + const time_t *tp; + int useGMT; +{ + struct tm *tmPtr; + long time; + + if (!useGMT) { + tzset(); + + /* + * If we are in the valid range, let the C run-time library + * handle it. Otherwise we need to fake it. Note that this + * algorithm ignores daylight savings time before the epoch. + */ + + time = *tp - _timezone; + if (time >= 0) { + return localtime(tp); + } + + /* + * If we aren't near to overflowing the long, just add the bias and + * use the normal calculation. Otherwise we will need to adjust + * the result at the end. + */ + + if (*tp < (LONG_MAX - 2 * SECSPERDAY) + && *tp > (LONG_MIN + 2 * SECSPERDAY)) { + tmPtr = ComputeGMT(&time); + } else { + tmPtr = ComputeGMT(tp); + + tzset(); + + /* + * Add the bias directly to the tm structure to avoid overflow. + * Propagate seconds overflow into minutes, hours and days. + */ + + time = tmPtr->tm_sec - _timezone; + tmPtr->tm_sec = (int)(time % 60); + if (tmPtr->tm_sec < 0) { + tmPtr->tm_sec += 60; + time -= 60; + } + + time = tmPtr->tm_min + time/60; + tmPtr->tm_min = (int)(time % 60); + if (tmPtr->tm_min < 0) { + tmPtr->tm_min += 60; + time -= 60; + } + + time = tmPtr->tm_hour + time/60; + tmPtr->tm_hour = (int)(time % 24); + if (tmPtr->tm_hour < 0) { + tmPtr->tm_hour += 24; + time -= 24; + } + + time /= 24; + tmPtr->tm_mday += time; + tmPtr->tm_yday += time; + tmPtr->tm_wday = (tmPtr->tm_wday + time) % 7; + } + } else { + tmPtr = ComputeGMT(tp); + } + return tmPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ComputeGMT -- + * + * This function computes GMT given the number of seconds since + * the epoch (midnight Jan 1 1970). + * + * Results: + * Returns a statically allocated struct tm. + * + * Side effects: + * Updates the values of the static struct tm. + * + *---------------------------------------------------------------------- + */ + +static struct tm * +ComputeGMT(tp) + const time_t *tp; +{ + static struct tm tm; /* This should be allocated per thread.*/ + long tmp, rem; + int isLeap; + int *days; + + /* + * Compute the 4 year span containing the specified time. + */ + + tmp = *tp / SECSPER4YEAR; + rem = *tp % SECSPER4YEAR; + + /* + * Correct for weird mod semantics so the remainder is always positive. + */ + + if (rem < 0) { + tmp--; + rem += SECSPER4YEAR; + } + + /* + * Compute the year after 1900 by taking the 4 year span and adjusting + * for the remainder. This works because 2000 is a leap year, and + * 1900/2100 are out of the range. + */ + + tmp = (tmp * 4) + 70; + isLeap = 0; + if (rem >= SECSPERYEAR) { /* 1971, etc. */ + tmp++; + rem -= SECSPERYEAR; + if (rem >= SECSPERYEAR) { /* 1972, etc. */ + tmp++; + rem -= SECSPERYEAR; + if (rem >= SECSPERYEAR + SECSPERDAY) { /* 1973, etc. */ + tmp++; + rem -= SECSPERYEAR + SECSPERDAY; + } else { + isLeap = 1; + } + } + } + tm.tm_year = tmp; + + /* + * Compute the day of year and leave the seconds in the current day in + * the remainder. + */ + + tm.tm_yday = rem / SECSPERDAY; + rem %= SECSPERDAY; + + /* + * Compute the time of day. + */ + + tm.tm_hour = rem / 3600; + rem %= 3600; + tm.tm_min = rem / 60; + tm.tm_sec = rem % 60; + + /* + * Compute the month and day of month. + */ + + days = (isLeap) ? leapDays : normalDays; + for (tmp = 1; days[tmp] < tm.tm_yday; tmp++) { + } + tm.tm_mon = --tmp; + tm.tm_mday = tm.tm_yday - days[tmp]; + + /* + * Compute day of week. Epoch started on a Thursday. + */ + + tm.tm_wday = (*tp / SECSPERDAY) + 4; + if ((*tp % SECSPERDAY) < 0) { + tm.tm_wday--; + } + tm.tm_wday %= 7; + if (tm.tm_wday < 0) { + tm.tm_wday += 7; + } + + return &tm; +} diff --git a/win/tclsh.rc b/win/tclsh.rc new file mode 100644 index 0000000..e48c157 --- /dev/null +++ b/win/tclsh.rc @@ -0,0 +1,36 @@ +// SCCS: @(#) tclsh.rc 1.15 96/09/18 18:19:38 +// +// Version +// + +#define RESOURCE_INCLUDED +#include <tcl.h> + +VS_VERSION_INFO VERSIONINFO + FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + FILEFLAGSMASK 0x3fL + FILEFLAGS 0x0L + FILEOS 0x4L + FILETYPE 0x1L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" + BEGIN + VALUE "FileDescription", "Tclsh Application\0" + VALUE "OriginalFilename", "tclsh" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".exe\0" + VALUE "CompanyName", "Sun Microsystems, Inc\0" + VALUE "FileVersion", TCL_PATCH_LEVEL + VALUE "LegalCopyright", "Copyright \251 1995-1996\0" + VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" + VALUE "ProductVersion", TCL_PATCH_LEVEL + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END + diff --git a/win/winDumpExts.c b/win/winDumpExts.c new file mode 100644 index 0000000..8bc496e --- /dev/null +++ b/win/winDumpExts.c @@ -0,0 +1,503 @@ +/* + * winDumpExts.c -- + * Author: Gordon Chaffee, Scott Stanton + * + * History: The real functionality of this file was written by + * Matt Pietrek in 1993 in his pedump utility. I've + * modified it to dump the externals in a bunch of object + * files to create a .def file. + * + * 10/12/95 Modified by Scott Stanton to support Relocatable Object Module + * Format files for Borland C++ 4.5. + * + * Notes: Visual C++ puts an underscore before each exported symbol. + * This file removes them. I don't know if this is a problem + * this other compilers. If _MSC_VER is defined, + * the underscore is removed. If not, it isn't. To get a + * full dump of an object file, use the -f option. This can + * help determine the something that may be different with a + * compiler other than Visual C++. + *---------------------------------------------------------------------- + * + * SCCS: @(#) winDumpExts.c 1.11 96/09/18 15:25:11 + */ + +#include <windows.h> +#include <stdio.h> +#include <string.h> +#include <process.h> + +#ifdef _ALPHA_ +#define e_magic_number IMAGE_FILE_MACHINE_ALPHA +#else +#define e_magic_number IMAGE_FILE_MACHINE_I386 +#endif + +/* + *---------------------------------------------------------------------- + * GetArgcArgv -- + * + * Break up a line into argc argv + *---------------------------------------------------------------------- + */ +int +GetArgcArgv(char *s, char **argv) +{ + int quote = 0; + int argc = 0; + char *bp; + + bp = s; + while (1) { + while (isspace(*bp)) { + bp++; + } + if (*bp == '\n' || *bp == '\0') { + *bp = '\0'; + return argc; + } + if (*bp == '\"') { + quote = 1; + bp++; + } + argv[argc++] = bp; + + while (*bp != '\0') { + if (quote) { + if (*bp == '\"') { + quote = 0; + *bp = '\0'; + bp++; + break; + } + bp++; + continue; + } + if (isspace(*bp)) { + *bp = '\0'; + bp++; + break; + } + bp++; + } + } +} + +/* + * The names of the first group of possible symbol table storage classes + */ +char * SzStorageClass1[] = { + "NULL","AUTOMATIC","EXTERNAL","STATIC","REGISTER","EXTERNAL_DEF","LABEL", + "UNDEFINED_LABEL","MEMBER_OF_STRUCT","ARGUMENT","STRUCT_TAG", + "MEMBER_OF_UNION","UNION_TAG","TYPE_DEFINITION","UNDEFINED_STATIC", + "ENUM_TAG","MEMBER_OF_ENUM","REGISTER_PARAM","BIT_FIELD" +}; + +/* + * The names of the second group of possible symbol table storage classes + */ +char * SzStorageClass2[] = { + "BLOCK","FUNCTION","END_OF_STRUCT","FILE","SECTION","WEAK_EXTERNAL" +}; + +/* + *---------------------------------------------------------------------- + * GetSZStorageClass -- + * + * Given a symbol storage class value, return a descriptive + * ASCII string + *---------------------------------------------------------------------- + */ +PSTR +GetSZStorageClass(BYTE storageClass) +{ + if ( storageClass <= IMAGE_SYM_CLASS_BIT_FIELD ) + return SzStorageClass1[storageClass]; + else if ( (storageClass >= IMAGE_SYM_CLASS_BLOCK) + && (storageClass <= IMAGE_SYM_CLASS_WEAK_EXTERNAL) ) + return SzStorageClass2[storageClass-IMAGE_SYM_CLASS_BLOCK]; + else + return "???"; +} + +/* + *---------------------------------------------------------------------- + * GetSectionName -- + * + * Used by DumpSymbolTable, it gives meaningful names to + * the non-normal section number. + * + * Results: + * A name is returned in buffer + *---------------------------------------------------------------------- + */ +void +GetSectionName(WORD section, PSTR buffer, unsigned cbBuffer) +{ + char tempbuffer[10]; + + switch ( (SHORT)section ) + { + case IMAGE_SYM_UNDEFINED: strcpy(tempbuffer, "UNDEF"); break; + case IMAGE_SYM_ABSOLUTE: strcpy(tempbuffer, "ABS "); break; + case IMAGE_SYM_DEBUG: strcpy(tempbuffer, "DEBUG"); break; + default: wsprintf(tempbuffer, "%-5X", section); + } + + strncpy(buffer, tempbuffer, cbBuffer-1); +} + +/* + *---------------------------------------------------------------------- + * DumpSymbolTable -- + * + * Dumps a COFF symbol table from an EXE or OBJ. We only use + * it to dump tables from OBJs. + *---------------------------------------------------------------------- + */ +void +DumpSymbolTable(PIMAGE_SYMBOL pSymbolTable, FILE *fout, unsigned cSymbols) +{ + unsigned i; + PSTR stringTable; + char sectionName[10]; + + fprintf(fout, "Symbol Table - %X entries (* = auxillary symbol)\n", + cSymbols); + + fprintf(fout, + "Indx Name Value Section cAux Type Storage\n" + "---- -------------------- -------- ---------- ----- ------- --------\n"); + + /* + * The string table apparently starts right after the symbol table + */ + stringTable = (PSTR)&pSymbolTable[cSymbols]; + + for ( i=0; i < cSymbols; i++ ) { + fprintf(fout, "%04X ", i); + if ( pSymbolTable->N.Name.Short != 0 ) + fprintf(fout, "%-20.8s", pSymbolTable->N.ShortName); + else + fprintf(fout, "%-20s", stringTable + pSymbolTable->N.Name.Long); + + fprintf(fout, " %08X", pSymbolTable->Value); + + GetSectionName(pSymbolTable->SectionNumber, sectionName, + sizeof(sectionName)); + fprintf(fout, " sect:%s aux:%X type:%02X st:%s\n", + sectionName, + pSymbolTable->NumberOfAuxSymbols, + pSymbolTable->Type, + GetSZStorageClass(pSymbolTable->StorageClass) ); +#if 0 + if ( pSymbolTable->NumberOfAuxSymbols ) + DumpAuxSymbols(pSymbolTable); +#endif + + /* + * Take into account any aux symbols + */ + i += pSymbolTable->NumberOfAuxSymbols; + pSymbolTable += pSymbolTable->NumberOfAuxSymbols; + pSymbolTable++; + } +} + +/* + *---------------------------------------------------------------------- + * DumpExternals -- + * + * Dumps a COFF symbol table from an EXE or OBJ. We only use + * it to dump tables from OBJs. + *---------------------------------------------------------------------- + */ +void +DumpExternals(PIMAGE_SYMBOL pSymbolTable, FILE *fout, unsigned cSymbols) +{ + unsigned i; + PSTR stringTable; + char *s, *f; + char symbol[1024]; + + /* + * The string table apparently starts right after the symbol table + */ + stringTable = (PSTR)&pSymbolTable[cSymbols]; + + for ( i=0; i < cSymbols; i++ ) { + if (pSymbolTable->SectionNumber > 0 && pSymbolTable->Type == 0x20) { + if (pSymbolTable->StorageClass == IMAGE_SYM_CLASS_EXTERNAL) { + if (pSymbolTable->N.Name.Short != 0) { + strncpy(symbol, pSymbolTable->N.ShortName, 8); + symbol[8] = 0; + } else { + s = stringTable + pSymbolTable->N.Name.Long; + strcpy(symbol, s); + } + s = symbol; + f = strchr(s, '@'); + if (f) { + *f = 0; + } +#if defined(_MSC_VER) && defined(_X86_) + if (symbol[0] == '_') { + s = &symbol[1]; + } +#endif + if ((stricmp(s, "DllEntryPoint") != 0) + && (stricmp(s, "DllMain") != 0)) { + fprintf(fout, "\t%s\n", s); + } + } + } + + /* + * Take into account any aux symbols + */ + i += pSymbolTable->NumberOfAuxSymbols; + pSymbolTable += pSymbolTable->NumberOfAuxSymbols; + pSymbolTable++; + } +} + +/* + *---------------------------------------------------------------------- + * DumpObjFile -- + * + * Dump an object file--either a full listing or just the exported + * symbols. + *---------------------------------------------------------------------- + */ +void +DumpObjFile(PIMAGE_FILE_HEADER pImageFileHeader, FILE *fout, int full) +{ + PIMAGE_SYMBOL PCOFFSymbolTable; + DWORD COFFSymbolCount; + + PCOFFSymbolTable = (PIMAGE_SYMBOL) + ((DWORD)pImageFileHeader + pImageFileHeader->PointerToSymbolTable); + COFFSymbolCount = pImageFileHeader->NumberOfSymbols; + + if (full) { + DumpSymbolTable(PCOFFSymbolTable, fout, COFFSymbolCount); + } else { + DumpExternals(PCOFFSymbolTable, fout, COFFSymbolCount); + } +} + +/* + *---------------------------------------------------------------------- + * SkipToNextRecord -- + * + * Skip over the current ROMF record and return the type of the + * next record. + *---------------------------------------------------------------------- + */ + +BYTE +SkipToNextRecord(BYTE **ppBuffer) +{ + int length; + (*ppBuffer)++; /* Skip over the type.*/ + length = *((WORD*)(*ppBuffer))++; /* Retrieve the length. */ + *ppBuffer += length; /* Skip over the rest. */ + return **ppBuffer; /* Return the type. */ +} + +/* + *---------------------------------------------------------------------- + * DumpROMFObjFile -- + * + * Dump a Relocatable Object Module Format file, displaying only + * the exported symbols. + *---------------------------------------------------------------------- + */ +void +DumpROMFObjFile(LPVOID pBuffer, FILE *fout) +{ + BYTE type, length; + char symbol[1024], *s; + + while (1) { + type = SkipToNextRecord(&(BYTE*)pBuffer); + if (type == 0x90) { /* PUBDEF */ + if (((BYTE*)pBuffer)[4] != 0) { + length = ((BYTE*)pBuffer)[5]; + strncpy(symbol, ((char*)pBuffer) + 6, length); + symbol[length] = '\0'; + s = symbol; + if ((stricmp(s, "DllEntryPoint") != 0) + && (stricmp(s, "DllMain") != 0)) { + if (s[0] == '_') { + s++; + fprintf(fout, "\t_%s\n\t%s=_%s\n", s, s, s); + } else { + fprintf(fout, "\t%s\n", s); + } + } + } + } else if (type == 0x8B || type == 0x8A) { /* MODEND */ + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * DumpFile -- + * + * Open up a file, memory map it, and call the appropriate + * dumping routine + *---------------------------------------------------------------------- + */ +void +DumpFile(LPSTR filename, FILE *fout, int full) +{ + HANDLE hFile; + HANDLE hFileMapping; + LPVOID lpFileBase; + PIMAGE_DOS_HEADER dosHeader; + + hFile = CreateFile(filename, GENERIC_READ, FILE_SHARE_READ, NULL, + OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); + + if (hFile == INVALID_HANDLE_VALUE) { + fprintf(stderr, "Couldn't open file with CreateFile()\n"); + return; + } + + hFileMapping = CreateFileMapping(hFile, NULL, PAGE_READONLY, 0, 0, NULL); + if (hFileMapping == 0) { + CloseHandle(hFile); + fprintf(stderr, "Couldn't open file mapping with CreateFileMapping()\n"); + return; + } + + lpFileBase = MapViewOfFile(hFileMapping, FILE_MAP_READ, 0, 0, 0); + if (lpFileBase == 0) { + CloseHandle(hFileMapping); + CloseHandle(hFile); + fprintf(stderr, "Couldn't map view of file with MapViewOfFile()\n"); + return; + } + + dosHeader = (PIMAGE_DOS_HEADER)lpFileBase; + if (dosHeader->e_magic == IMAGE_DOS_SIGNATURE) { +#if 0 + DumpExeFile( dosHeader ); +#else + fprintf(stderr, "File is an executable. I don't dump those.\n"); + return; +#endif + } + /* Does it look like a i386 COFF OBJ file??? */ + else if ((dosHeader->e_magic == e_magic_number) + && (dosHeader->e_sp == 0)) { + /* + * The two tests above aren't what they look like. They're + * really checking for IMAGE_FILE_HEADER.Machine == i386 (0x14C) + * and IMAGE_FILE_HEADER.SizeOfOptionalHeader == 0; + */ + DumpObjFile((PIMAGE_FILE_HEADER) lpFileBase, fout, full); + } else if (*((BYTE *)lpFileBase) == 0x80) { + /* + * This file looks like it might be a ROMF file. + */ + DumpROMFObjFile(lpFileBase, fout); + } else { + printf("unrecognized file format\n"); + } + UnmapViewOfFile(lpFileBase); + CloseHandle(hFileMapping); + CloseHandle(hFile); +} + +void +main(int argc, char **argv) +{ + char *fargv[1000]; + char cmdline[10000]; + int i, arg; + FILE *fout; + int pos; + int full = 0; + char *outfile = NULL; + + if (argc < 3) { + Usage: + fprintf(stderr, "Usage: %s ?-o outfile? ?-f(ull)? <dllname> <object filenames> ..\n", argv[0]); + exit(1); + } + + arg = 1; + while (argv[arg][0] == '-') { + if (strcmp(argv[arg], "--") == 0) { + arg++; + break; + } else if (strcmp(argv[arg], "-f") == 0) { + full = 1; + } else if (strcmp(argv[arg], "-o") == 0) { + arg++; + if (arg == argc) { + goto Usage; + } + outfile = argv[arg]; + } + arg++; + } + if (arg == argc) { + goto Usage; + } + + if (outfile) { + fout = fopen(outfile, "w+"); + if (fout == NULL) { + fprintf(stderr, "Unable to open \'%s\' for writing:\n", + argv[arg]); + perror(""); + exit(1); + } + } else { + fout = stdout; + } + + if (! full) { + char *dllname = argv[arg]; + arg++; + if (arg == argc) { + goto Usage; + } + fprintf(fout, "LIBRARY %s\n", dllname); + fprintf(fout, "EXETYPE WINDOWS\n"); + fprintf(fout, "CODE PRELOAD MOVEABLE DISCARDABLE\n"); + fprintf(fout, "DATA PRELOAD MOVEABLE MULTIPLE\n\n"); + fprintf(fout, "EXPORTS\n"); + } + + for (; arg < argc; arg++) { + if (argv[arg][0] == '@') { + FILE *fargs = fopen(&argv[arg][1], "r"); + if (fargs == NULL) { + fprintf(stderr, "Unable to open \'%s\' for reading:\n", + argv[arg]); + perror(""); + exit(1); + } + pos = 0; + for (i = 0; i < arg; i++) { + strcpy(&cmdline[pos], argv[i]); + pos += strlen(&cmdline[pos]) + 1; + fargv[i] = argv[i]; + } + fgets(&cmdline[pos], sizeof(cmdline), fargs); + fprintf(stderr, "%s\n", &cmdline[pos]); + fclose(fargs); + i += GetArgcArgv(&cmdline[pos], &fargv[i]); + argc = i; + argv = fargv; + } + DumpFile(argv[arg], fout, full); + } + exit(0); +} |