diff options
| author | stanton <stanton> | 1999-04-16 00:46:29 (GMT) |
|---|---|---|
| committer | stanton <stanton> | 1999-04-16 00:46:29 (GMT) |
| commit | 97464e6cba8eb0008cf2727c15718671992b913f (patch) | |
| tree | ce9959f2747257d98d52ec8d18bf3b0de99b9535 /tests | |
| parent | a8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff) | |
| download | tcl-97464e6cba8eb0008cf2727c15718671992b913f.zip tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.gz tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.bz2 | |
merged tcl 8.1 branch back into the main trunk
Diffstat (limited to 'tests')
126 files changed, 18146 insertions, 4729 deletions
diff --git a/tests/README b/tests/README index 07915c9..fe4bb30 100644 --- a/tests/README +++ b/tests/README @@ -1,96 +1,423 @@ -Tcl Test Suite --------------- +README -- Tcl test suite design document. -RCS: @(#) $Id: README,v 1.2 1998/09/14 18:40:07 stanton Exp $ +RCS: @(#) $Id: README,v 1.3 1999/04/16 00:47:22 stanton Exp $ -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. +Contents: +--------- + + 1. Introduction + 2. Definitions file + 3. Writing a new test + 4. Constraints + 5. Adding a New Test File + 6. Test output + 7. Selecting tests for execution within a file + 8. Selecting files to be sourced by all.tcl + 9. Incompatibilities with prior Tcl versions + +1. Introduction: +---------------- + +This directory contains a set of validation tests for the Tcl commands +and C Library procedures for Tcl. Each of the files whose name ends +in ".test" is intended to fully exercise the functions in the C source +file that corresponds to the file prefix. The C functions and/or Tcl +commands tested by a given file are listed in the first line of the +file. + +You can run the tests in three ways: -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 + + (b) type "tcltest <testFile> ?<option> <value>? + Command line options include: + + -verbose <level> set the level of verbosity to a substring + of "bps". See the "Test output" section + for an explanation of this option. + + -match <matchList> only run tests that match one or more of + the glob patterns in <matchList> + + -skip <skipList> do not run tests that match one or more + of the glob patterns in <skipList> + + -file <globPattern> only source test files that match + <globPattern> (relative to the "tests" + directory). This option only applies + when you run the test suite with the + "all.tcl" file. + + -constraints <list> tests with any constraints in <list> will + not be skipped. Not that elements of + <list> must exactly match the existing + constraints. + + (c) 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: ------------------------------- + of the tests, type "source all.tcl". To use the options in + interactive mode, you can set their corresponding tcltest + namespace variables after sourcing the defs.tcl file. + ::tcltest::match + ::tcltest::skip + ::tcltest::testConfig(nonPortable) + ::tcltest::testConfig(knownBug) + ::tcltest::testConfig(userInteractive) + +In all cases, no output will be generated if all goes well, except for +a listing of the test files and a statistical summary. If there are +errors, then additional messages will appear in the format described +below. Note that some tests will be skipped if you run as superuser. + +This approach to testing was designed and initially implemented by +Mary Ann May-Pumphrey of Sun Microsystems in the early 1990's. Many +thanks to her for donating her work back to the public Tcl release. + + +2. Definitions file: +-------------------- + +The file "defs.tcl" defines the "tcltest" namespace which contains 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. +Currently, the following procedures are exported from the "tcltest" +namespace and automatically imported: + + test Run a test script. + + cleanupTests Print stats and remove files created by tests. + + dotests Source a test file and run tests of the + specified pattern. + + makeFile Create a file--the file will automatically + be removed by cleanupTests. + + removeFile Force a file to be removed. + + makeDirectory Create a directory--the directory will + automatically be removed by cleanupTests. + + removeDirectory Force a directory to be removed. + + viewFile Returns the contents of a file. + + normalizeMsg Remove extra newlines from a string. + + bytestring Construct a string that consists of the + requested sequence of bytes, as opposed to a + string of properly formed UTF-8 characters. + + set_iso8859_1_locale Set the locale to iso8859_1. + + restore_locale Restore the locale to its original setting. + + saveState Save the procedure and global variable names. + + restoreState Restore the procedure and global variable names. + +Please refer to the defs.tcl file for more documentation on these +procedures. + + +3. Writing a new test: +---------------------- + +The test procedure runs a test script and prints an error message if +the script's result does not match the expected result. The following +is the spec for the "test" command: + + test <name> <description> ?<constraint>? <script> <expectedAnswer> + +The <name> argument should follow the pattern, +"<target>-<majorNum>.<minorNum>". For white-box (regression) tests, +the target should be the name of the c function or Tcl procedure being +tested. For black-box tests, the target should be the name of the +feature being tested. Related tests should share a major number. + +The <description> argument is a short textual description of the test, +to help humans understand what it does. + +The optional <constraints> argument is list of one or more keywords, +each of which must be the name of an element in the array +"::tcltest::testConfig". If any of these elements is false or does +not exist, the test is skipped. Add appropriate constraints (e.g., +unixOnly) to any tests that should not always be run. For example, a +test that should only be run on Unix should look like the following: + + test getAttribute-1.1 {testing file permissions} {unixOnly} { + lindex [file attributes foo.tcl] 5 + } {00644} + +See the "Constraints" section for a list of built-in +constraints and information on how to add your own constraints. + +The <script> argument contains the script to run to carry out the +test. It must return a result that can be checked for correctness. +If your script requires that a file be created on the fly, please use +the ::tcltest::makeFile procedure. If your test requires that a small +file (<50 lines) be checked in, please consider creating the file on +the fly using the ::tcltest::makeFile procedure. Files created by the +::tcltest::makeFile procedure will automatically be removed by the +::tcltest::cleanupTests call at the end of each test file. + +The <expectedAnswer> argument will be compared against the result of +evaluating the <script> argument. If they match, the test passes, +otherwise the test fails. + + +4. Constraints: +--------------- + +Constraints are used to determine whether a test should be skipped. +Each constraint is stored as an index in the array +::tcltest::testConfig. For example, the unixOnly constraint is +defined as the following: + + set ::tcltest::testConfig(unixOnly) \ + [expr {$tcl_platform(platform) == "unix"}] + +If a test is constrained by "unixOnly", then it will only be run if +the value of ::tcltest::testConfig(unixOnly) is true. + +The following is a list of constraints defined in the defs.tcl file: + +unix test can only be run on any UNIX platform +pc test can only be run on any Windows platform +nt test can only be run on any Windows NT platform +95 test can only be run on any Windows 95 platform +mac test can only be run on any Mac platform +unixOrPc test can only be run on a UNIX or PC platform +macOrPc test can only be run on a Mac or PC platform +macOrUnix test can only be run on a Mac or UNIX platform +tempNotPc test can not be run on Windows. This flag is used + to temporarily disable a test. +tempNotMac test can not be run on a Mac. This flag is used + to temporarily disable a test. +unixCrash test crashes if it's run on UNIX. This flag is used + to temporarily disable a test. +pcCrash test crashes if it's run on Windows. This flag is + used to temporarily disable a test. +macCrash test crashes if it's run on a Mac. This flag is used + to temporarily disable a test. + +emptyTest test is empty, and so not worth running, but + it remains as a place-holder for a test to be + written in the future. This constraint always + causes tests to be skipped. + +knownBug test is known to fail and the bug is not yet + fixed. This constraint always causes tests to be + skipped unless the user specifies otherwise. See the + "Introduction" section for more details. + +nonPortable test can only be run 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. This constraint always causes tests to be + skipped unless the user specifies otherwise. See the + "Introduction" section for more details. + +userInteraction test requires interaction from the user. This + constraint always causes tests to be skipped unless + the user specifies otherwise. See the "Introduction" + section for more details. + +interactive test can only be run in if the interpreter is in + interactive mode, that is the global tcl_interactive + variable is set to 1. + +nonBlockFiles test can only be run if platform supports setting + files into nonblocking mode + +asyncPipeClose test can only be run if platform supports async + flush and async close on a pipe + +unixExecs test can only be run if this machine has commands + such as 'cat', 'echo', etc. available. + +hasIsoLocale test can only be run if can switch to an ISO locale + +fonts test can only be run if the wish app's fonts can + be controlled by Tk. + +root test can only run if Unix user is root + +notRoot test can only run if Unix user is not root + +eformat test can only run if app has a working version of + sprintf with respect to the "e" format of + floating-point numbers. + +stdio test can only be run if the current app can be + spawned via a pipe + + +5. Adding a new test file: +-------------------------- + +Tests files should begin by sourcing the defs.tcl file: + + if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] + } + +Test files sould end by cleaning up after themselves and calling +::tcltest::cleanupTests. The ::tcltest::cleanupTests procedure prints +statistics about the number of tests that passed, skipped, and failed, +and removes all files that were created using the ::tcltest::makeFile +and ::tcltest::makeDirectory procedures. + + # Remove files created by these tests + # Change to original working directory + # Unset global arrays + ::tcltest::cleanupTests + return + +The all.tcl file will source your new test file if the filename +matches the tests/*.test pattern (as it should). The names of test +files that contain regression (or glass-box) tests should correspond +to the Tcl or C code file that they are testing. For example, the +test file for the C file "tclCmdAH.c" is "cmdAH.test". Test files +that contain black-box tests may not correspond to any Tcl or C code +file so they should match the pattern "*_bb.test". + +Be sure your new test file can be run from any working directory. + +Be sure no temporary files are left behind by your test file. + +Be sure your tests can run cross-platform in both a build environment +as well as an installation environment. If your test file contains +tests that should not be run in one or more of those cases, please use +the constraints mechanism to skip those tests. + + +6. Test output: +--------------- + +After all specified test files are sourced, the number of tests +passed, skipped, and failed is printed to stdout. Aside from this +statistical information, output can be controlled on a per-test basis +by the ::tcltest::verbose variable. + +::tcltest::verbose can be set to any substring or permutation of "bps". +In the string "bps", the 'b' stands for a test's "body", the 'p' +stands for "passed" tests, and the 's' stands for "skipped" tests. +The default value of ::tcltest::verbose is "b". If 'b' is present, then +the entire body of the test is printed for each failed test, otherwise +only the test's name, desired output, and actual output, are printed +for each failed test. If 'p' is present, then a line is printed for +each passed test, otherwise no line is printed for passed tests. If +'s' is present, then a line (containing the consraints that cause the +test to be skipped) is printed for each skipped test, otherwise no +line is printed for skipped tests. + +You can set ::tcltest::verbose either interactively (after the defs.tcl +file has been sourced) or by the command line argument -verbose, for +example: + + tcltest socket.test -verbose bps + + +7. Selecting tests for execution within a file: +----------------------------------------------- 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: +sourced. An individual test will be skipped if one of the following +conditions is met: + + 1) the "name" of the tests does not match (using glob style + matching) one or more elements in the ::tcltest::match + variable + + 2) the "name" of the tests matches (using glob style matching) one + or more elements in the ::tcltest::skip variable + + 3) the "constraints" argument to the "test" call, if given, + contains one or more false elements. + +You can set ::tcltest::match and/or ::tcltest::skip +either interactively (after the defs.tcl file has been sourced), or by +the command line arguments -match and -skip, for example: + + tcltest info.test -match '*-5.* *-7.*' -skip '*-7.1*' + +Be sure to use the proper quoting convention so that your shell does +not perform the glob substitution on the match or skip patterns you +specify. + +The two predefined constraints (knownBug and nonPortable) can be +overridden either interactively (after the defs.tcl file has been +sourced) by setting the ::tcltest::testConfig(<constraint>) variable, +or by using the -constraints command line option with the name of the +constraint in the argument. The following example shows how to run +tests that are constrained by the knownBug and nonPortable +restricions: + + tcltest all.tcl -constraints "knownBug nonPortable" + +See the defs.tcl file for information about each of these constraints. +Other constraints can be added at any time. See the "Writing a new +test" section below for more details about using built-in constraints +and adding new ones. + + +8. Selecting files to be sourced by all.tcl: +-------------------------------------------- + +You can specify the files you want all.tcl to source on the command +line with the -file options. For example, if you call the +following: + + tcltest all.tcl -file 'unix*.test' + +all files in "tests" directory that match the pattern unix*.test will +be sourced by the all.tcl file. Another useful example is if a +particular test hangs, say "get.test", and you just want to run the +remaining tests, then you can call the following: + + tcltest all.tcl -file '[h-z]*.test' + +Note that the argument to -file will be substituted relative to the +"tests" directory. Be sure to use the proper quoting convention so +that your shell does not perform the glob substitution. + - set TESTS {for-[24]*} +9. Incompatibilities with prior Tcl versions: +--------------------------------------------- -TESTS defaults to *, but you can change the default in "defs" if -you wish. +1) Global variables such as VERBOSE, TESTS, and testConfig are now + renamed to use the new "tcltest" namespace. -Saving keystrokes: ------------------- + old name new name + -------- -------- + VERBOSE ::tcltest::verbose + TESTS ::tcltest::match + testConfig ::tcltest::testConfig -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. + The introduction of the "tcltest" namespace is a precursor to using + a "tcltest" package. This next step will be part of a future Tcl + version. -Batch vs. interactive execution: --------------------------------- +2) VERBOSE values are no longer numeric. Please see the section above + on "Test output" for the new usage of the ::tcltest::verbose variable. -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: +3) When you run "make test", the working dir for the test suite is now + the one from which you called "make test", rather than the "tests" + directory. This change allows for both unix and windows test + suites to be run simultaneously without interference with each + other or with existing files. All tests must now run independently + of their working directory. - tclTest < parse.test > parse.test.results +4) The "all", "defs", and "visual" files are now called "all.tcl", + "defs.tcl", and "visual_bb.test", respectively. -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). +5) Instead of creating a doAllTests file in the tests directory, to + run all nonPortable tests, just use the "-constraints nonPortable" + command line flag. If you are running interactively, you can set + the ::tcltest::testConfig(nonPortable) variable to 1 (after + sourcing the defs.tcl file). diff --git a/tests/all b/tests/all deleted file mode 100644 index 04ac435..0000000 --- a/tests/all +++ /dev/null @@ -1,71 +0,0 @@ -# This file contains a top-level script to run all of the Tcl -# tests. Execute it by invoking "source all" when running tclTest -# in this directory. -# -# RCS: @(#) $Id: all,v 1.5 1998/12/07 23:33:53 hershey Exp $ - -set TESTS_DIR [file join [pwd] [file dirname [info script]]] -source [file join $TESTS_DIR defs] -set currentDir [pwd] - -catch {array set flag $argv} -set requiredSourceFiles [list autoMkindex.tcl remote.tcl defs pkg pkg1] - -# -# Set the TMP_DIR to pwd or the arg of -tmpdir, if given. -# - -if {[info exists flag(-tmpdir)]} { - set TMP_DIR $flag(-tmpdir) - if {![file exists $TMP_DIR]} { - if {[catch {file mkdir $TMP_DIR} msg]} { - error "bad argument \"$flag(-tmpdir)\" to -tmpdir:\n$msg" - } - file mkdir $TMP_DIR - } elseif {![file isdir $TMP_DIR]} { - error "bad argument \"$flag(-tmpdir)\" to -tmpdir:\n$TMP_DIR is not a directory" - } - if {[string compare [file pathtype $TMP_DIR] absolute] != 0} { - set TMP_DIR [file join [pwd] $TMP_DIR] - } - cd $TMP_DIR -} - -# -# copy each required source file to the current dir (if it's not already there). -# - -if {[string compare $TESTS_DIR [pwd]] != 0} { - - foreach file $requiredSourceFiles { - if {![file exists $file]} { - catch {file copy [file join $TESTS_DIR $file] .} - } - } -} - -if {$tcl_platform(os) == "Win32s"} { - set globPattern [file join $TESTS_DIR *.tes] -} else { - set globPattern [file join $TESTS_DIR *.test] -} - -foreach file [lsort [glob $globPattern]] { - set tail [file tail $file] - if {[string match l.*.test $tail]} { - # This is an SCCS lockfile; ignore it - continue - } - puts stdout $tail - if {[catch {source $file} msg]} { - puts stdout $msg - } -} - -# remove the required source files from the current dir. -if {[info exists TMP_DIR]} { - foreach file $requiredSourceFiles { - catch {file delete -force $file} - } - cd $currentDir -} diff --git a/tests/all.tcl b/tests/all.tcl new file mode 100644 index 0000000..a6c596a --- /dev/null +++ b/tests/all.tcl @@ -0,0 +1,76 @@ +# all.tcl -- +# +# This file contains a top-level script to run all of the Tcl +# tests. Execute it by invoking "source all.test" when running tcltest +# in this directory. +# +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. +# +# RCS: @(#) $Id: all.tcl,v 1.2 1999/04/16 00:47:23 stanton Exp $ + +if {[lsearch ::tcltest [namespace children]] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} +set ::tcltest::testSingleFile false + +puts stdout "Tcl $tcl_patchLevel tests running in interp: [info nameofexecutable]" +puts stdout "Tests running in working dir: $::tcltest::workingDir" +if {[llength $::tcltest::skip] > 0} { + puts stdout "Skipping tests that match: $::tcltest::skip" +} +if {[llength $::tcltest::match] > 0} { + puts stdout "Only running tests that match: $::tcltest::match" +} + +# Use command line specified glob pattern (specified by -file or -f) +# if one exists. Otherwise use *.test. If given, the file pattern +# should be specified relative to the dir containing this file. If no +# files are found to match the pattern, print an error message and exit. +set fileIndex [expr {[lsearch $argv "-file"] + 1}] +set fIndex [expr {[lsearch $argv "-f"] + 1}] +if {($fileIndex < 1) || ($fIndex > $fileIndex)} { + set fileIndex $fIndex +} +if {$fileIndex > 0} { + set globPattern [file join $::tcltest::testsDir [lindex $argv $fileIndex]] + puts stdout "Sourcing files that match: $globPattern" +} else { + set globPattern [file join $::tcltest::testsDir *.test] +} +set fileList [glob -nocomplain $globPattern] +if {[llength $fileList] < 1} { + puts "Error: no files found matching $globPattern" + exit +} +set timeCmd {clock format [clock seconds]} +puts stdout "Tests began at [eval $timeCmd]" + +# source each of the specified tests +foreach file [lsort $fileList] { + set tail [file tail $file] + if {[string match l.*.test $tail]} { + # This is an SCCS lockfile; ignore it + continue + } + puts stdout $tail + if {[catch {source $file} msg]} { + puts stdout $msg + } +} + +# cleanup +puts stdout "\nTests ended at [eval $timeCmd]" +::tcltest::cleanupTests 1 +return + + + + + + + + + + + diff --git a/tests/append.test b/tests/append.test index d4ccba3..e64df06 100644 --- a/tests/append.test +++ b/tests/append.test @@ -6,15 +6,18 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: append.test,v 1.2 1998/09/14 18:40:07 stanton Exp $ - -if {[string compare test [info procs test]] == 1} then {source defs} +# RCS: @(#) $Id: append.test,v 1.3 1999/04/16 00:47:23 stanton Exp $ +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {unset x} + test append-1.1 {append command} { catch {unset x} list [append x 1 2 abc "long string"] $x @@ -170,5 +173,22 @@ test append-7.1 {lappend-created var and error in trace on that var} { list [info exists x] [catch {set x} msg] $msg } {0 1 {can't read "x": no such variable}} -catch {unset x} +catch {unset i x result y} catch {rename foo ""} +catch {rename check ""} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/assocd.test b/tests/assocd.test index 48ef00b..a618606 100644 --- a/tests/assocd.test +++ b/tests/assocd.test @@ -6,17 +6,21 @@ # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: assocd.test,v 1.2 1998/09/14 18:40:07 stanton Exp $ +# RCS: @(#) $Id: assocd.test,v 1.3 1999/04/16 00:47:23 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} 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." + ::tcltest::cleanupTests return } @@ -55,3 +59,19 @@ test assocd-3.2 {testing deleting assoc data} { test assocd-3.3 {testing deleting assoc data} { list [catch {testdelassocdata nonexistent} msg] $msg } {0 {}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/async.test b/tests/async.test index 9bacf3c..4b4d655 100644 --- a/tests/async.test +++ b/tests/async.test @@ -6,20 +6,24 @@ # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: async.test,v 1.2 1998/09/14 18:40:07 stanton Exp $ +# RCS: @(#) $Id: async.test,v 1.3 1999/04/16 00:47:23 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} 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." + ::tcltest::cleanupTests return } -if {[string compare test [info procs test]] == 1} then {source defs} - proc async1 {result code} { global aresult acode set aresult $result @@ -128,4 +132,19 @@ test async-3.1 {deleting handlers} { list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x } {3 del2 {0 0 0 del1 del2}} +# cleanup testasync delete +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test index 562454b..452eed6 100644 --- a/tests/autoMkindex.test +++ b/tests/autoMkindex.test @@ -4,15 +4,39 @@ # the autoloading index. # # Copyright (c) 1998 Lucent Technologies, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: autoMkindex.test,v 1.4 1999/03/31 18:58:50 welch Exp $ - -if {[string compare test [info procs test]] == 1} then {source defs} +# RCS: @(#) $Id: autoMkindex.test,v 1.5 1999/04/16 00:47:23 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +# temporarily copy the autoMkindex.tcl file from testsDir to tmpDir +set origMkindexFile [file join $::tcltest::testsDir autoMkindex.tcl] +set newMkindexFile [file join $::tcltest::workingDir autoMkindex.tcl] +if {![catch {file copy $origMkindexFile $newMkindexFile}]} { + set removeAutoMkindex 1 +} + +# Save initial state of auto_mkindex_parser + +auto_load auto_mkindex +if {[info exist auto_mkindex_parser::initCommands]} { + set saveCommands $auto_mkindex_parser::initCommands +} +proc AutoMkindexTestReset {} { + global saveCommands + if {[info exist saveCommands]} { + set auto_mkindex_parser::initCommands $saveCommands + } elseif {[info exist auto_mkindex_parser::initCommands]} { + unset auto_mkindex_parser::initCommands + } +} -set saveCommands $auto_mkindex_parser::initCommands set result "" test autoMkindex-1.1 {remove any existing tclIndex file} { @@ -28,6 +52,8 @@ test autoMkindex-1.2 {build tclIndex based on a test file} { set element "{source [file join . autoMkindex.tcl]}" test autoMkindex-1.3 {examine tclIndex} { + file delete tclIndex + auto_mkindex . autoMkindex.tcl namespace eval tcl_autoMkindex_tmp { set dir "." variable auto_index @@ -43,6 +69,8 @@ test autoMkindex-1.3 {examine tclIndex} { test autoMkindex-2.1 {commands on the autoload path can be imported} { + file delete tclIndex + auto_mkindex . autoMkindex.tcl set interp [interp create] set final [$interp eval { namespace eval blt {} @@ -69,11 +97,12 @@ test autoMkindex-3.1 {slaveHook} { } } auto_mkindex_parser::slavehook { _%@namespace import -force ::blt::* } + file delete tclIndex auto_mkindex . autoMkindex.tcl # Reset initCommands to avoid trashing other tests - set auto_mkindex_parser::initCommands $saveCommands + AutoMkindexTestReset file exists tclIndex } 1 @@ -87,6 +116,7 @@ test autoMkindex-3.2 {auto_mkindex_parser::command} { append index [list set auto_index([fullname $name])] \ " \[list source \[file join \$dir [list $scriptFile]\]\]\n" } + file delete tclIndex auto_mkindex . autoMkindex.tcl namespace eval tcl_autoMkindex_tmp { set dir "." @@ -101,7 +131,7 @@ test autoMkindex-3.2 {auto_mkindex_parser::command} { # Reset initCommands to avoid trashing other tests - set auto_mkindex_parser::initCommands $saveCommands + AutoMkindexTestReset set ::result } "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd2 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {indented $element} {mycmd3 $element} {normal $element} {top $element}" @@ -114,6 +144,7 @@ test autoMkindex-3.3 {auto_mkindex_parser::command} {knownBug} { append index [list set auto_index([fullname $name])] \ " \[list source \[file join \$dir [list $scriptFile]\]\]\n" } + file delete tclIndex auto_mkindex . autoMkindex.tcl namespace eval tcl_autoMkindex_tmp { set dir "." @@ -128,7 +159,7 @@ test autoMkindex-3.3 {auto_mkindex_parser::command} {knownBug} { # Reset initCommands to avoid trashing other tests - set auto_mkindex_parser::initCommands $saveCommands + AutoMkindexTestReset proc lvalue {list pattern} { set ix [lsearch $list $pattern] if {$ix >= 0} { @@ -140,12 +171,19 @@ test autoMkindex-3.3 {auto_mkindex_parser::command} {knownBug} { list [lvalue $::result *mycmd4*] [lvalue $::result *mycmd5*] [lvalue $::result *mycmd6*] } "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}" - -# # Clean up. -# -set auto_mkindex_parser::initCommands $saveCommands unset result -unset saveCommands -catch {file delete tclIndex} +AutoMkindexTestReset +if {[info exist saveCommands]} { + unset saveCommands +} +rename AutoMkindexTestReset "" + +if {[info exists removeAutoMkindex]} { + catch {file delete $newMkindexFile} +} +if {[file exists tclIndex]} { + file delete -force tclIndex +} +::tcltest::cleanupTests diff --git a/tests/basic.test b/tests/basic.test index 43f92cb..b6274bf 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -10,14 +10,17 @@ # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: basic.test,v 1.4 1998/09/14 18:40:07 stanton Exp $ +# RCS: @(#) $Id: basic.test,v 1.5 1999/04/16 00:47:23 stanton Exp $ # -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {namespace delete test_ns_basic} catch {interp delete test_interp} @@ -40,7 +43,31 @@ test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} { [interp delete test_interp] } {::test_ns_basic {}} -test basic-2.1 {DeleteInterpProc, destroys interp's global namespace} { +test basic-2.1 {TclHideUnsafeCommands} {emptyTest} { +} {} + +test basic-3.1 {Tcl_CallWhenDeleted: see dcall.test} {emptyTest} { +} {} + +test basic-4.1 {Tcl_DontCallWhenDeleted: see dcall.test} {emptyTest} { +} {} + +test basic-5.1 {Tcl_SetAssocData: see assoc.test} {emptyTest} { +} {} + +test basic-6.1 {Tcl_DeleteAssocData: see assoc.test} {emptyTest} { +} {} + +test basic-7.1 {Tcl_GetAssocData: see assoc.test} {emptyTest} { +} {} + +test basic-8.1 {Tcl_InterpDeleted} {emptyTest} { +} {} + +test basic-9.1 {Tcl_DeleteInterp: see interp.test} {emptyTest} { +} {} + +test basic-10.1 {DeleteInterpProc, destroys interp's global namespace} { catch {interp delete test_interp} interp create test_interp interp eval test_interp { @@ -65,7 +92,7 @@ test basic-2.1 {DeleteInterpProc, destroys interp's global namespace} { [interp delete test_interp] } {{::test_ns_basic 27} {} 1 {invalid command name "set"} {}} -test basic-3.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} { +test basic-11.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} { catch {interp delete test_interp} interp create test_interp interp eval test_interp { @@ -84,7 +111,7 @@ test basic-3.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden c # NB: More tests about hide/expose are found in interp.test -test basic-4.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} { +test basic-12.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} { catch {interp delete test_interp} interp create test_interp interp eval test_interp { @@ -99,7 +126,7 @@ test basic-4.1 {Tcl_HideCommand, names of hidden cmds can't have namespace quali [interp delete test_interp] } {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers as hidden commandtoken (rename)} {}} -test basic-4.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} { +test basic-12.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} { catch {namespace delete test_ns_basic} catch {rename cmd ""} proc cmd {} { ;# note that this is global @@ -124,7 +151,7 @@ test basic-4.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace [namespace delete test_ns_basic] } {:: {} 1 {invalid command name "cmd"} {} :: {}} -test basic-5.1 {Tcl_ExposeCommand, a command stays in the global namespace and can not go to another namespace} { +test basic-13.1 {Tcl_ExposeCommand, a command stays in the global namespace and can not go to another namespace} { catch {namespace delete test_ns_basic} catch {rename cmd ""} proc cmd {} { ;# note that this is global @@ -152,7 +179,7 @@ test basic-5.1 {Tcl_ExposeCommand, a command stays in the global namespace and c [test_ns_basic::newCmd] \ [namespace delete test_ns_basic] } {:: {} 1 {can not expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}} -test basic-5.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} { +test basic-13.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} { catch {rename p ""} catch {rename cmd ""} proc p {} { @@ -170,22 +197,26 @@ test basic-5.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being expos [p] } {42 {} {} Hello {} {} 42} -if {[info commands testcreatecommand] != {}} { - test basic-6.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} { - catch {eval namespace delete [namespace children :: test_ns_*]} - list [testcreatecommand create] \ - [test_ns_basic::createdcommand] \ - [testcreatecommand delete] - } {{} {CreatedCommandProc in ::test_ns_basic} {}} - test basic-6.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} { - catch {eval namespace delete [namespace children :: test_ns_*]} - catch {rename value:at: ""} - list [testcreatecommand create2] \ - [value:at:] \ - [testcreatecommand delete2] - } {{} {CreatedCommandProc2 in ::} {}} +if {[info commands testcreatecommand] == ""} { + puts "This application hasn't been compiled with the testcreatecommand" + puts "command. Skipping affected tests." +} else { +test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} { + catch {eval namespace delete [namespace children :: test_ns_*]} + list [testcreatecommand create] \ + [test_ns_basic::createdcommand] \ + [testcreatecommand delete] +} {{} {CreatedCommandProc in ::test_ns_basic} {}} +test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename value:at: ""} + list [testcreatecommand create2] \ + [value:at:] \ + [testcreatecommand delete2] +} {{} {CreatedCommandProc2 in ::} {}} } -test basic-6.3 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} { + +test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} { catch {eval namespace delete [namespace children :: test_ns_*]} namespace eval test_ns_basic {} proc test_ns_basic::cmd {} { ;# proc requires that ns already exist @@ -195,7 +226,13 @@ test basic-6.3 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in [namespace delete test_ns_basic] } {::test_ns_basic {}} -test basic-7.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} { +test basic-16.1 {TclInvokeStringCommand} {emptyTest} { +} {} + +test basic-17.1 {TclInvokeObjCommand} {emptyTest} { +} {} + +test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename cmd ""} namespace eval test_ns_basic { @@ -207,11 +244,11 @@ test basic-7.1 {TclRenameCommand, name of existing cmd can have namespace qualif [rename test_ns_basic::p test_ns_basic::q] \ [test_ns_basic::q] } {{p in ::test_ns_basic} {} {p in ::test_ns_basic}} -test basic-7.2 {TclRenameCommand, existing cmd must be found} { +test basic-18.2 {TclRenameCommand, existing cmd must be found} { catch {eval namespace delete [namespace children :: test_ns_*]} list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg } {1 {can't rename "test_ns_basic::p": command doesn't exist}} -test basic-7.3 {TclRenameCommand, delete cmd if new name is empty} { +test basic-18.3 {TclRenameCommand, delete cmd if new name is empty} { catch {eval namespace delete [namespace children :: test_ns_*]} namespace eval test_ns_basic { proc p {} { @@ -222,7 +259,7 @@ test basic-7.3 {TclRenameCommand, delete cmd if new name is empty} { [rename test_ns_basic::p ""] \ [info commands test_ns_basic::*] } {::test_ns_basic::p {} {}} -test basic-7.4 {TclRenameCommand, bad new name} { +test basic-18.4 {TclRenameCommand, bad new name} { catch {eval namespace delete [namespace children :: test_ns_*]} namespace eval test_ns_basic { proc p {} { @@ -231,7 +268,7 @@ test basic-7.4 {TclRenameCommand, bad new name} { } rename test_ns_basic::p :::george::martha } {} -test basic-7.5 {TclRenameCommand, new name must not already exist} { +test basic-18.5 {TclRenameCommand, new name must not already exist} { namespace eval test_ns_basic { proc q {} { return 42 @@ -239,7 +276,7 @@ test basic-7.5 {TclRenameCommand, new name must not already exist} { } list [catch {rename test_ns_basic::q :::george::martha} msg] $msg } {1 {can't rename to ":::george::martha": command already exists}} -test basic-7.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} { +test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename p ""} catch {rename q ""} @@ -259,8 +296,14 @@ test basic-7.6 {TclRenameCommand, check for command shadowing by newly renamed c [test_ns_basic::callP] } {{p in ::} {} {q in ::test_ns_basic}} -if {[info command testcmdtoken] != {}} { -test basic-8.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} { +test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} { +} {} + +if {[info commands testcmdtoken] == {}} { + puts "This application hasn't been compiled with the \"testcmdtoken\"" + puts "command, so I can't test Tcl_GetCommandInfo." +} else { +test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename p ""} catch {rename q ""} @@ -273,7 +316,7 @@ test basic-8.1 {Tcl_GetCommandInfo, names for commands created inside namespaces [rename ::p q] \ [testcmdtoken name $x] } {{p ::p} {} {q ::q}} -test basic-8.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} { +test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} { catch {rename q ""} set x [testcmdtoken create test_ns_basic::test_ns_basic2::p] list [testcmdtoken name $x] \ @@ -282,7 +325,10 @@ test basic-8.2 {Tcl_GetCommandInfo, names for commands created outside namespace } {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}} } -test basic-9.1 {Tcl_GetCommandFullName} { +test basic-21.1 {Tcl_GetCommandName} {emptyTest} { +} {} + +test basic-22.1 {Tcl_GetCommandFullName} { catch {eval namespace delete [namespace children :: test_ns_*]} namespace eval test_ns_basic1 { namespace export cmd* @@ -305,7 +351,10 @@ test basic-9.1 {Tcl_GetCommandFullName} { } } {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2} -test basic-10.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} { +test basic-23.1 {Tcl_DeleteCommand} {emptyTest} { +} {} + +test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} { catch {interp delete test_interp} catch {unset x} interp create test_interp @@ -325,7 +374,7 @@ test basic-10.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd [interp eval test_interp {useSet}] \ [interp delete test_interp] } {123 {set called with a 123} {}} -test basic-10.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} { +test basic-24.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename p ""} proc p {} { @@ -343,7 +392,7 @@ test basic-10.2 {Tcl_DeleteCommandFromToken, deleting commands changes command e [rename test_ns_basic::p ""] \ [test_ns_basic::callP] } {{namespace p} {} {global p}} -test basic-10.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} { +test basic-24.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename p ""} namespace eval test_ns_basic { @@ -363,7 +412,54 @@ test basic-10.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to [info commands test_ns_basic2::*] } {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP} -test basic-11.1 {TclObjInvoke, lookup of "unknown" command} { +test basic-25.1 {TclCleanupCommand} {emptyTest} { +} {} + +test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} { + # If object isn't preserved, errorInfo would be set to + # "foo\n while executing\n\"garbage bytes\"" because the object's + # string would have been freed, leaving garbage bytes for the error + # message. + + proc bgerror {args} {set ::x $::errorInfo} + set f [open test1 w] + fileevent $f writable "fileevent $f writable {}; error foo" + set x {} + vwait x + close $f + file delete test1 + rename bgerror {} + set x +} "foo\n while executing\n\"error foo\"" + +test basic-27.1 {Tcl_ExprLong} {emptyTest} { +} {} + +test basic-28.1 {Tcl_ExprDouble} {emptyTest} { +} {} + +test basic-29.1 {Tcl_ExprBoolean} {emptyTest} { +} {} + +test basic-30.1 {Tcl_ExprLongObj} {emptyTest} { +} {} + +test basic-31.1 {Tcl_ExprDoubleObj} {emptyTest} { +} {} + +test basic-32.1 {Tcl_ExprBooleanObj} {emptyTest} { +} {} + +test basic-33.1 {TclInvoke} {emptyTest} { +} {} + +test basic-34.1 {TclGlobalInvoke} {emptyTest} { +} {} + +test basic-35.1 {TclObjInvokeGlobal} {emptyTest} { +} {} + +test basic-36.1 {TclObjInvoke, lookup of "unknown" command} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {interp delete test_interp} interp create test_interp @@ -382,15 +478,49 @@ test basic-11.1 {TclObjInvoke, lookup of "unknown" command} { [interp delete test_interp] } {newAlias 0 {global unknown} {}} -if {[info command testcmdtrace] != {}} { -test basic-12.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} { +test basic-37.1 {Tcl_ExprString: see expr.test} {emptyTest} { +} {} + +test basic-38.1 {Tcl_ExprObj} {emptyTest} { +} {} + +if {[info commands testcmdtrace] == {}} { + puts "This application hasn't been compiled with the \"testcmdtrace\"" + puts "command, so I can't test Tcl_CreateTrace." +} else { +test basic-39.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} { + testcmdtrace tracetest {set stuff [expr 14 + 16]} +} {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}} +test basic-39.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} { testcmdtrace tracetest {set stuff [info tclversion]} -} {{info tclversion} {info tclversion} {set stuff [info tclversion]} {set stuff 8.0}} -test basic-12.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} { +} {{info tclversion} {info tclversion} {set stuff [info tclversion]} {set stuff 8.1}} +test basic-39.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} { testcmdtrace deletetest {set stuff [info tclversion]} -} 8.0 +} 8.1 } +test basic-40.1 {Tcl_DeleteTrace} {emptyTest} { +} {} + +test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} { +} {} + +test basic-42.1 {Tcl_AddObjErrorInfo} {emptyTest} { +} {} + +test basic-43.1 {Tcl_VarEval} {emptyTest} { +} {} + +test basic-44.1 {Tcl_GlobalEval} {emptyTest} { +} {} + +test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} { +} {} + +test basic-46.1 {Tcl_AllowExceptions} {emptyTest} { +} {} + +# cleanup catch {eval namespace delete [namespace children :: test_ns_*]} catch {namespace delete george} catch {interp delete test_interp} @@ -399,5 +529,17 @@ catch {rename q ""} catch {rename cmd ""} catch {rename value:at: ""} catch {unset x} -set x 0 -unset x +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/binary.test b/tests/binary.test index 70ddf0c..1399edd 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -5,20 +5,23 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: binary.test,v 1.2 1998/09/14 18:40:07 stanton Exp $ +# RCS: @(#) $Id: binary.test,v 1.3 1999/04/16 00:47:23 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} 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}} +} {1 {bad option "foo": must be format or scan}} test binary-1.3 {Tcl_BinaryObjCmd: format error} { list [catch {binary f} msg] $msg @@ -1441,3 +1444,19 @@ 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} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/case.test b/tests/case.test index e36b3b3..ee0b97f 100644 --- a/tests/case.test +++ b/tests/case.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: case.test,v 1.2 1998/09/14 18:40:07 stanton Exp $ +# RCS: @(#) $Id: case.test,v 1.3 1999/04/16 00:47:23 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test case-1.1 {simple pattern} { case a in a {format 1} b {format 2} c {format 3} default {format 4} @@ -81,3 +84,19 @@ test case-3.2 {single-argument form for pattern/command pairs} { test case-3.3 {single-argument form for pattern/command pairs} { list [catch {case z in {a 2 b}} msg] $msg } {1 {extra case pattern with no body}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/clock.test b/tests/clock.test index 5fbee3a..d0072ad 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -4,14 +4,17 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# Copyright (c) 1995-1998 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: clock.test,v 1.2 1998/09/14 18:40:07 stanton Exp $ +# RCS: @(#) $Id: clock.test,v 1.3 1999/04/16 00:47:24 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test clock-1.1 {clock tests} { list [catch {clock} msg] $msg @@ -41,29 +44,60 @@ test clock-3.1 {clock format tests} {unixOnly} { clock format $clockval -format {%a %b %d %I:%M:%S %p %Y} -gmt true } {Sun Nov 04 03:02:46 AM 1990} test clock-3.2 {clock format tests} { + # TCL_USE_TIMEZONE_VAR + + catch {set oldtz $env(TZ)} + set env(TZ) PST + set x {} + append x [clock format 863800000 -format %Z -gmt 1] + append x [set env(TZ)] + catch {unset env(TZ); set env(TZ) $oldtz} + set x +} {GMTPST} +test clock-3.3 {clock format tests} { + # tzset() under Borland doesn't seem to set up tzname[] for local + # timezone, which caused "clock format" to think that %Z was an invalid + # string. Don't care about answer, just that test runs w/o error. + + clock format 863800000 -format %Z + set x {} +} {} +test clock-3.4 {clock format tests} { + # tzset() under Borland doesn't seem to set up tzname[] for gmt timezone. + # tzset() under MSVC has the following weird observed behavior: + # First time we call "clock format [clock seconds] -format %Z -gmt 1" + # we get "GMT", but on all subsequent calls we get the current time + # zone string, even though env(TZ) is GMT and the variable _timezone + # is 0. + + set x {} + append x [clock format 863800000 -format %Z -gmt 1] + append x [clock format 863800000 -format %Z -gmt 1] +} {GMTGMT} +test clock-3.5 {clock format tests} { list [catch {clock format} msg] $msg } {1 {wrong # args: should be "clock format clockval ?-format string? ?-gmt boolean?"}} -test clock-3.3 {clock format tests} { +test clock-3.6 {clock format tests} { list [catch {clock format foo} msg] $msg } {1 {expected integer but got "foo"}} -test clock-3.4 {clock format tests} {unixOrPc} { +test clock-3.7 {clock format tests} {unixOrPc} { set clockval 657687766 clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true } "Sun Nov 04 03:02:46 AM 1990" -test clock-3.5 {clock format tests} { +test clock-3.8 {clock format tests} { list [catch {clock format a b c d e g} msg] $msg } {1 {wrong # args: should be "clock format clockval ?-format string? ?-gmt boolean?"}} -test clock-3.6 {clock format tests} {unixOrPc nonPortable} { +test clock-3.9 {clock format tests} {unixOrPc nonPortable} { set clockval -1 clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true } "Wed Dec 31 11:59:59 PM 1969" -test clock-3.7 {clock format tests} { +test clock-3.10 {clock format tests} { list [catch {clock format 123 -bad arg} msg] $msg -} {1 {bad switch "-bad": must be -format, or -gmt}} -test clock-3.8 {clock format tests} { +} {1 {bad switch "-bad": must be -format or -gmt}} +test clock-3.11 {clock format tests} { clock format 123 -format "x" } x -test clock-3.9 {clock format tests} { +test clock-3.12 {clock format tests} { clock format 123 -format "" } "" @@ -101,7 +135,7 @@ test clock-4.8 {clock scan tests} { } {Oct 23,1992 15:00 GMT} test clock-4.9 {clock scan tests} { list [catch {clock scan "Jan 12" -bad arg} msg] $msg -} {1 {bad switch "-bad": must be -base, or -gmt}} +} {1 {bad switch "-bad": must be -base or -gmt}} # The following two two tests test the two year date policy test clock-4.10 {clock scan tests} { set time [clock scan "1/1/71" -gmt true] @@ -173,3 +207,19 @@ 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} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/cmdAH.test b/tests/cmdAH.test index f9251a9..19ef9c4 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -4,35 +4,179 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996-1997 by Sun Microsystems, Inc. +# Copyright (c) 1996-1998 by Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdAH.test,v 1.4 1999/02/03 19:12:27 stanton Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.5 1999/04/16 00:47:24 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} global env +set cmdAHwd [pwd] catch {set platform [testgetplatform]} -test cmdAH-1.1 {Tcl_FileObjCmd} { +test cmdAH-0.1 {Tcl_BreakObjCmd, errors} { + list [catch {break foo} msg] $msg +} {1 {wrong # args: should be "break"}} +test cmdAH-0.2 {Tcl_BreakObjCmd, success} { + list [catch {break} msg] $msg +} {3 {}} + +# Tcl_CaseObjCmd is tested in case.test + +test cmdAH-1.1 {Tcl_CatchObjCmd, errors} { + list [catch {catch} msg] $msg +} {1 {wrong # args: should be "catch command ?varName?"}} +test cmdAH-1.2 {Tcl_CatchObjCmd, errors} { + list [catch {catch foo bar baz} msg] $msg +} {1 {wrong # args: should be "catch command ?varName?"}} + +test cmdAH-2.1 {Tcl_CdObjCmd} { + list [catch {cd foo bar} msg] $msg +} {1 {wrong # args: should be "cd ?dirName?"}} +test cmdAH-2.2 {Tcl_CdObjCmd} { + file delete -force foo + file mkdir foo + cd foo + set result [file tail [pwd]] + cd .. + file delete foo + set result +} foo +test cmdAH-2.3 {Tcl_CdObjCmd} { + global env + set oldpwd [pwd] + set temp $env(HOME) + set env(HOME) $oldpwd + file delete -force foo + file mkdir foo + cd foo + cd ~ + set result [string match [pwd] $oldpwd] + file delete foo + set env(HOME) $temp + set result +} 1 +test cmdAH-2.4 {Tcl_CdObjCmd} { + global env + set oldpwd [pwd] + set temp $env(HOME) + set env(HOME) $oldpwd + file delete -force foo + file mkdir foo + cd foo + cd + set result [string match [pwd] $oldpwd] + file delete foo + set env(HOME) $temp + set result +} 1 +test cmdAH-2.5 {Tcl_CdObjCmd} { + list [catch {cd ~~} msg] $msg +} {1 {user "~" doesn't exist}} +test cmdAH-2.6 {Tcl_CdObjCmd} { + list [catch {cd _foobar} msg] $msg +} {1 {couldn't change working directory to "_foobar": no such file or directory}} + +test cmdAH-2.7 {Tcl_ConcatObjCmd} { + concat +} {} +test cmdAH-2.8 {Tcl_ConcatObjCmd} { + concat a +} a +test cmdAH-2.9 {Tcl_ConcatObjCmd} { + concat a {b c} +} {a b c} + +test cmdAH-3.1 {Tcl_ContinueObjCmd, errors} { + list [catch {continue foo} msg] $msg +} {1 {wrong # args: should be "continue"}} +test cmdAH-3.2 {Tcl_ContinueObjCmd, success} { + list [catch {continue} msg] $msg +} {4 {}} + +test cmdAH-4.1 {Tcl_EncodingObjCmd} { + list [catch {encoding} msg] $msg +} {1 {wrong # args: should be "encoding option ?arg ...?"}} +test cmdAH-4.2 {Tcl_EncodingObjCmd} { + list [catch {encoding foo} msg] $msg +} {1 {bad option "foo": must be convertfrom, convertto, names, or system}} +test cmdAH-4.3 {Tcl_EncodingObjCmd} { + list [catch {encoding convertto} msg] $msg +} {1 {wrong # args: should be "encoding convertto ?encoding? data"}} +test cmdAH-4.4 {Tcl_EncodingObjCmd} { + list [catch {encoding convertto foo bar} msg] $msg +} {1 {unknown encoding "foo"}} +test cmdAH-4.5 {Tcl_EncodingObjCmd} { + set system [encoding system] + encoding system jis0208 + set x [encoding convertto \u4e4e] + encoding system $system + set x +} 8C +test cmdAH-4.6 {Tcl_EncodingObjCmd} { + set system [encoding system] + encoding system identity + set x [encoding convertto jis0208 \u4e4e] + encoding system $system + set x +} 8C +test cmdAH-4.7 {Tcl_EncodingObjCmd} { + list [catch {encoding convertfrom} msg] $msg +} {1 {wrong # args: should be "encoding convertfrom ?encoding? data"}} +test cmdAH-4.8 {Tcl_EncodingObjCmd} { + list [catch {encoding convertfrom foo bar} msg] $msg +} {1 {unknown encoding "foo"}} +test cmdAH-4.9 {Tcl_EncodingObjCmd} { + set system [encoding system] + encoding system jis0208 + set x [encoding convertfrom 8C] + encoding system $system + set x +} \u4e4e +test cmdAH-4.10 {Tcl_EncodingObjCmd} { + set system [encoding system] + encoding system identity + set x [encoding convertfrom jis0208 8C] + encoding system $system + set x +} \u4e4e +test cmdAH-4.11 {Tcl_EncodingObjCmd} { + list [catch {encoding names foo} msg] $msg +} {1 {wrong # args: should be "encoding names"}} +test cmdAH-4.12 {Tcl_EncodingObjCmd} { + list [catch {encoding system foo bar} msg] $msg +} {1 {wrong # args: should be "encoding system ?encoding?"}} +test cmdAH-4.13 {Tcl_EncodingObjCmd} { + set system [encoding system] + encoding system identity + set x [encoding system] + encoding system $system + set x +} identity + +test cmdAH-5.1 {Tcl_FileObjCmd} { list [catch file msg] $msg } {1 {wrong # args: should be "file option ?arg ...?"}} -test cmdAH-1.2 {Tcl_FileObjCmd} { +test cmdAH-5.2 {Tcl_FileObjCmd} { list [catch {file x} msg] $msg } {1 {bad option "x": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-1.3 {Tcl_FileObjCmd} { +test cmdAH-5.3 {Tcl_FileObjCmd} { list [catch {file atime} msg] $msg -} {1 {wrong # args: should be "file atime name ?arg ...?"}} +} {1 {wrong # args: should be "file atime name"}} #volume -test cmdAH-2.1 {Tcl_FileObjCmd: volumes} { +test cmdAH-6.1 {Tcl_FileObjCmd: volumes} { list [catch {file volumes x} msg] $msg } {1 {wrong # args: should be "file volumes"}} -test cmdAH-2.2 {Tcl_FileObjCmd: volumes} { +test cmdAH-6.2 {Tcl_FileObjCmd: volumes} { set volumeList [file volumes] if { [llength $volumeList] == 0 } { set result 0 @@ -40,18 +184,18 @@ test cmdAH-2.2 {Tcl_FileObjCmd: volumes} { set result 1 } } {1} -test cmdAH-2.3 {Tcl_FileObjCmd: volumes} {macOrUnix} { +test cmdAH-6.3 {Tcl_FileObjCmd: volumes} {macOrUnix} { set volumeList [file volumes] catch [list glob -nocomplain [lindex $volumeList 0]*] } {0} -test cmdAH-2.4 {Tcl_FileObjCmd: volumes} {pcOnly} { - set volumeList [file volumes] +test cmdAH-6.4 {Tcl_FileObjCmd: volumes} {pcOnly} { + set volumeList [string tolower [file volumes]] list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}] } {0 1 0} # attributes -test cmdAH-3.1 {Tcl_FileObjCmd - file attrs} { +test cmdAH-7.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] @@ -63,175 +207,175 @@ if {[info commands testsetplatform] == {}} { puts "This application hasn't been compiled with the \"testsetplatform\"" puts "command, so I can't test Tcl_FileObjCmd etc." } else { -test cmdAH-4.1 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.1 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname a b} msg] $msg } {1 {wrong # args: should be "file dirname name"}} -test cmdAH-4.2 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.2 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname /a/b } /a -test cmdAH-4.3 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.3 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname {} } . -test cmdAH-4.4 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.4 {Tcl_FileObjCmd: dirname} { testsetplatform mac file dirname {} } : -test cmdAH-4.5 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.5 {Tcl_FileObjCmd: dirname} { testsetplatform win file dirname {} } . -test cmdAH-4.6 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.6 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname .def } . -test cmdAH-4.7 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.7 {Tcl_FileObjCmd: dirname} { testsetplatform mac file dirname a } : -test cmdAH-4.8 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.8 {Tcl_FileObjCmd: dirname} { testsetplatform win file dirname a } . -test cmdAH-4.9 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.9 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname a/b/c.d } a/b -test cmdAH-4.10 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.10 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname a/b.c/d } a/b.c -test cmdAH-4.11 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.11 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname /. } / -test cmdAH-4.12 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.12 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname /} msg] $msg } {0 /} -test cmdAH-4.13 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.13 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname /foo} msg] $msg } {0 /} -test cmdAH-4.14 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.14 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname //foo} msg] $msg } {0 /} -test cmdAH-4.15 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.15 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname //foo/bar} msg] $msg } {0 /foo} -test cmdAH-4.16 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.16 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname {//foo\/bar/baz}} msg] $msg } {0 {/foo\/bar}} -test cmdAH-4.17 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.17 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname {//foo\/bar/baz/blat}} msg] $msg } {0 {/foo\/bar/baz}} -test cmdAH-4.18 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.18 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname /foo//} msg] $msg } {0 /} -test cmdAH-4.19 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.19 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname ./a} msg] $msg } {0 .} -test cmdAH-4.20 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.20 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname a/.a} msg] $msg } {0 a} -test cmdAH-4.21 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.21 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname c:foo} msg] $msg } {0 c:} -test cmdAH-4.22 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.22 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname c:} msg] $msg } {0 c:} -test cmdAH-4.23 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.23 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname c:/} msg] $msg } {0 c:/} -test cmdAH-4.24 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.24 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname {c:\foo}} msg] $msg } {0 c:/} -test cmdAH-4.25 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.25 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname {//foo/bar/baz}} msg] $msg } {0 //foo/bar} -test cmdAH-4.26 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.26 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname {//foo/bar}} msg] $msg } {0 //foo/bar} -test cmdAH-4.27 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.27 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :} msg] $msg } {0 :} -test cmdAH-4.28 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.28 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :Foo} msg] $msg } {0 :} -test cmdAH-4.29 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.29 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname Foo:} msg] $msg } {0 Foo:} -test cmdAH-4.30 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.30 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname Foo:bar} msg] $msg } {0 Foo:} -test cmdAH-4.31 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.31 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :Foo:bar} msg] $msg } {0 :Foo} -test cmdAH-4.32 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.32 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ::} msg] $msg } {0 :} -test cmdAH-4.33 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.33 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :::} msg] $msg } {0 ::} -test cmdAH-4.34 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.34 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname /foo/bar/} msg] $msg } {0 foo:} -test cmdAH-4.35 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.35 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname /foo/bar} msg] $msg } {0 foo:} -test cmdAH-4.36 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.36 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname /foo} msg] $msg } {0 foo:} -test cmdAH-4.37 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.37 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname foo} msg] $msg } {0 :} -test cmdAH-4.38 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.38 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname ~/foo} msg] $msg } {0 ~} -test cmdAH-4.39 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.39 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname ~bar/foo} msg] $msg } {0 ~bar} -test cmdAH-4.40 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.40 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ~bar/foo} msg] $msg } {0 ~bar:} -test cmdAH-4.41 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.41 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ~/foo} msg] $msg } {0 ~:} -test cmdAH-4.42 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.42 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ~:baz} msg] $msg } {0 ~:} -test cmdAH-4.43 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.43 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -240,7 +384,7 @@ test cmdAH-4.43 {Tcl_FileObjCmd: dirname} { set env(HOME) $temp set result } {0 /home} -test cmdAH-4.44 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.44 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "~" @@ -249,7 +393,7 @@ test cmdAH-4.44 {Tcl_FileObjCmd: dirname} { set env(HOME) $temp set result } {0 ~} -test cmdAH-4.45 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.45 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -258,7 +402,7 @@ test cmdAH-4.45 {Tcl_FileObjCmd: dirname} { set env(HOME) $temp set result } {0 /home} -test cmdAH-4.46 {Tcl_FileObjCmd: dirname} { +test cmdAH-8.46 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -270,171 +414,171 @@ test cmdAH-4.46 {Tcl_FileObjCmd: dirname} { # tail -test cmdAH-5.1 {Tcl_FileObjCmd: tail} { +test cmdAH-9.1 {Tcl_FileObjCmd: tail} { testsetplatform unix list [catch {file tail a b} msg] $msg } {1 {wrong # args: should be "file tail name"}} -test cmdAH-5.2 {Tcl_FileObjCmd: tail} { +test cmdAH-9.2 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /a/b } b -test cmdAH-5.3 {Tcl_FileObjCmd: tail} { +test cmdAH-9.3 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {} } {} -test cmdAH-5.4 {Tcl_FileObjCmd: tail} { +test cmdAH-9.4 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail {} } {} -test cmdAH-5.5 {Tcl_FileObjCmd: tail} { +test cmdAH-9.5 {Tcl_FileObjCmd: tail} { testsetplatform win file tail {} } {} -test cmdAH-5.6 {Tcl_FileObjCmd: tail} { +test cmdAH-9.6 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail .def } .def -test cmdAH-5.7 {Tcl_FileObjCmd: tail} { +test cmdAH-9.7 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail a } a -test cmdAH-5.8 {Tcl_FileObjCmd: tail} { +test cmdAH-9.8 {Tcl_FileObjCmd: tail} { testsetplatform win file tail a } a -test cmdAH-5.9 {Tcl_FileObjCmd: tail} { +test cmdAH-9.9 {Tcl_FileObjCmd: tail} { testsetplatform unix file ta a/b/c.d } c.d -test cmdAH-5.10 {Tcl_FileObjCmd: tail} { +test cmdAH-9.10 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail a/b.c/d } d -test cmdAH-5.11 {Tcl_FileObjCmd: tail} { +test cmdAH-9.11 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /. } . -test cmdAH-5.12 {Tcl_FileObjCmd: tail} { +test cmdAH-9.12 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail / } {} -test cmdAH-5.13 {Tcl_FileObjCmd: tail} { +test cmdAH-9.13 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /foo } foo -test cmdAH-5.14 {Tcl_FileObjCmd: tail} { +test cmdAH-9.14 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail //foo } foo -test cmdAH-5.15 {Tcl_FileObjCmd: tail} { +test cmdAH-9.15 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail //foo/bar } bar -test cmdAH-5.16 {Tcl_FileObjCmd: tail} { +test cmdAH-9.16 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {//foo\/bar/baz} } baz -test cmdAH-5.17 {Tcl_FileObjCmd: tail} { +test cmdAH-9.17 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {//foo\/bar/baz/blat} } blat -test cmdAH-5.18 {Tcl_FileObjCmd: tail} { +test cmdAH-9.18 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /foo// } foo -test cmdAH-5.19 {Tcl_FileObjCmd: tail} { +test cmdAH-9.19 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail ./a } a -test cmdAH-5.20 {Tcl_FileObjCmd: tail} { +test cmdAH-9.20 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail a/.a } .a -test cmdAH-5.21 {Tcl_FileObjCmd: tail} { +test cmdAH-9.21 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:foo } foo -test cmdAH-5.22 {Tcl_FileObjCmd: tail} { +test cmdAH-9.22 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c: } {} -test cmdAH-5.23 {Tcl_FileObjCmd: tail} { +test cmdAH-9.23 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:/ } {} -test cmdAH-5.24 {Tcl_FileObjCmd: tail} { +test cmdAH-9.24 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {c:\foo} } foo -test cmdAH-5.25 {Tcl_FileObjCmd: tail} { +test cmdAH-9.25 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {//foo/bar/baz} } baz -test cmdAH-5.26 {Tcl_FileObjCmd: tail} { +test cmdAH-9.26 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {//foo/bar} } {} -test cmdAH-5.27 {Tcl_FileObjCmd: tail} { +test cmdAH-9.27 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail : } : -test cmdAH-5.28 {Tcl_FileObjCmd: tail} { +test cmdAH-9.28 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail :Foo } Foo -test cmdAH-5.29 {Tcl_FileObjCmd: tail} { +test cmdAH-9.29 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail Foo: } {} -test cmdAH-5.30 {Tcl_FileObjCmd: tail} { +test cmdAH-9.30 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail Foo:bar } bar -test cmdAH-5.31 {Tcl_FileObjCmd: tail} { +test cmdAH-9.31 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail :Foo:bar } bar -test cmdAH-5.32 {Tcl_FileObjCmd: tail} { +test cmdAH-9.32 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail :: } :: -test cmdAH-5.33 {Tcl_FileObjCmd: tail} { +test cmdAH-9.33 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ::: } :: -test cmdAH-5.34 {Tcl_FileObjCmd: tail} { +test cmdAH-9.34 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail /foo/bar/ } bar -test cmdAH-5.35 {Tcl_FileObjCmd: tail} { +test cmdAH-9.35 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail /foo/bar } bar -test cmdAH-5.36 {Tcl_FileObjCmd: tail} { +test cmdAH-9.36 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail /foo } {} -test cmdAH-5.37 {Tcl_FileObjCmd: tail} { +test cmdAH-9.37 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail foo } foo -test cmdAH-5.38 {Tcl_FileObjCmd: tail} { +test cmdAH-9.38 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~:foo } foo -test cmdAH-5.39 {Tcl_FileObjCmd: tail} { +test cmdAH-9.39 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~bar:foo } foo -test cmdAH-5.40 {Tcl_FileObjCmd: tail} { +test cmdAH-9.40 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~bar/foo } foo -test cmdAH-5.41 {Tcl_FileObjCmd: tail} { +test cmdAH-9.41 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~/foo } foo -test cmdAH-5.42 {Tcl_FileObjCmd: tail} { +test cmdAH-9.42 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -443,7 +587,7 @@ test cmdAH-5.42 {Tcl_FileObjCmd: tail} { set env(HOME) $temp set result } test -test cmdAH-5.43 {Tcl_FileObjCmd: tail} { +test cmdAH-9.43 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "~" @@ -452,7 +596,7 @@ test cmdAH-5.43 {Tcl_FileObjCmd: tail} { set env(HOME) $temp set result } {} -test cmdAH-5.44 {Tcl_FileObjCmd: tail} { +test cmdAH-9.44 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -461,7 +605,7 @@ test cmdAH-5.44 {Tcl_FileObjCmd: tail} { set env(HOME) $temp set result } test -test cmdAH-5.45 {Tcl_FileObjCmd: tail} { +test cmdAH-9.45 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -470,166 +614,166 @@ test cmdAH-5.45 {Tcl_FileObjCmd: tail} { set env(HOME) $temp set result } test -test cmdAH-5.46 {Tcl_FileObjCmd: tail} { +test cmdAH-9.46 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {f.oo\bar/baz.bat} } baz.bat -test cmdAH-5.47 {Tcl_FileObjCmd: tail} { +test cmdAH-9.47 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:foo } foo -test cmdAH-5.48 {Tcl_FileObjCmd: tail} { +test cmdAH-9.48 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c: } {} -test cmdAH-5.49 {Tcl_FileObjCmd: tail} { +test cmdAH-9.49 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:/foo } foo -test cmdAH-5.50 {Tcl_FileObjCmd: tail} { +test cmdAH-9.50 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {c:/foo\bar} } bar -test cmdAH-5.51 {Tcl_FileObjCmd: tail} { +test cmdAH-9.51 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {foo\bar} } bar # rootname -test cmdAH-6.1 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.1 {Tcl_FileObjCmd: rootname} { testsetplatform unix list [catch {file rootname a b} msg] $msg } {1 {wrong # args: should be "file rootname name"}} -test cmdAH-6.2 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.2 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname {} } {} -test cmdAH-6.3 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.3 {Tcl_FileObjCmd: rootname} { testsetplatform unix file ro foo } foo -test cmdAH-6.4 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.4 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname foo. } foo -test cmdAH-6.5 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.5 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname .foo } {} -test cmdAH-6.6 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.6 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname abc.def } abc -test cmdAH-6.7 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.7 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname abc.def.ghi } abc.def -test cmdAH-6.8 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.8 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname a/b/c.d } a/b/c -test cmdAH-6.9 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.9 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname a/b.c/d } a/b.c/d -test cmdAH-6.10 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.10 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname a/b.c/ } a/b.c/ -test cmdAH-6.11 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.11 {Tcl_FileObjCmd: rootname} { testsetplatform mac file ro foo } foo -test cmdAH-6.12 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.12 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname {} } {} -test cmdAH-6.13 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.13 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname foo. } foo -test cmdAH-6.14 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.14 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname .foo } {} -test cmdAH-6.15 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.15 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname abc.def } abc -test cmdAH-6.16 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.16 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname abc.def.ghi } abc.def -test cmdAH-6.17 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.17 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a:b:c.d } a:b:c -test cmdAH-6.18 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.18 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a:b.c:d } a:b.c:d -test cmdAH-6.19 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.19 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a/b/c.d } a/b/c -test cmdAH-6.20 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.20 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a/b.c/d } a/b.c/d -test cmdAH-6.21 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.21 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname /a.b } /a -test cmdAH-6.22 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.22 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname foo.c: } foo.c: -test cmdAH-6.23 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.23 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname {} } {} -test cmdAH-6.24 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.24 {Tcl_FileObjCmd: rootname} { testsetplatform windows file ro foo } foo -test cmdAH-6.25 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.25 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname foo. } foo -test cmdAH-6.26 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.26 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname .foo } {} -test cmdAH-6.27 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.27 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname abc.def } abc -test cmdAH-6.28 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.28 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname abc.def.ghi } abc.def -test cmdAH-6.29 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.29 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a/b/c.d } a/b/c -test cmdAH-6.30 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.30 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a/b.c/d } a/b.c/d -test cmdAH-6.31 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.31 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b.c\\ } a\\b.c\\ -test cmdAH-6.32 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.32 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b\\c.d } a\\b\\c -test cmdAH-6.33 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.33 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b.c\\d } a\\b.c\\d -test cmdAH-6.34 {Tcl_FileObjCmd: rootname} { +test cmdAH-10.34 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b.c\\ } a\\b.c\\ @@ -647,139 +791,139 @@ foreach outer { {} a .a a. a.a } { # extension -test cmdAH-7.1 {Tcl_FileObjCmd: extension} { +test cmdAH-11.1 {Tcl_FileObjCmd: extension} { testsetplatform unix list [catch {file extension a b} msg] $msg } {1 {wrong # args: should be "file extension name"}} -test cmdAH-7.2 {Tcl_FileObjCmd: extension} { +test cmdAH-11.2 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension {} } {} -test cmdAH-7.3 {Tcl_FileObjCmd: extension} { +test cmdAH-11.3 {Tcl_FileObjCmd: extension} { testsetplatform unix file ext foo } {} -test cmdAH-7.4 {Tcl_FileObjCmd: extension} { +test cmdAH-11.4 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension foo. } . -test cmdAH-7.5 {Tcl_FileObjCmd: extension} { +test cmdAH-11.5 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension .foo } .foo -test cmdAH-7.6 {Tcl_FileObjCmd: extension} { +test cmdAH-11.6 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension abc.def } .def -test cmdAH-7.7 {Tcl_FileObjCmd: extension} { +test cmdAH-11.7 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension abc.def.ghi } .ghi -test cmdAH-7.8 {Tcl_FileObjCmd: extension} { +test cmdAH-11.8 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension a/b/c.d } .d -test cmdAH-7.9 {Tcl_FileObjCmd: extension} { +test cmdAH-11.9 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension a/b.c/d } {} -test cmdAH-7.10 {Tcl_FileObjCmd: extension} { +test cmdAH-11.10 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension a/b.c/ } {} -test cmdAH-7.11 {Tcl_FileObjCmd: extension} { +test cmdAH-11.11 {Tcl_FileObjCmd: extension} { testsetplatform mac file ext foo } {} -test cmdAH-7.12 {Tcl_FileObjCmd: extension} { +test cmdAH-11.12 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension {} } {} -test cmdAH-7.13 {Tcl_FileObjCmd: extension} { +test cmdAH-11.13 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension foo. } . -test cmdAH-7.14 {Tcl_FileObjCmd: extension} { +test cmdAH-11.14 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension .foo } .foo -test cmdAH-7.15 {Tcl_FileObjCmd: extension} { +test cmdAH-11.15 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension abc.def } .def -test cmdAH-7.16 {Tcl_FileObjCmd: extension} { +test cmdAH-11.16 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension abc.def.ghi } .ghi -test cmdAH-7.17 {Tcl_FileObjCmd: extension} { +test cmdAH-11.17 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a:b:c.d } .d -test cmdAH-7.18 {Tcl_FileObjCmd: extension} { +test cmdAH-11.18 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a:b.c:d } {} -test cmdAH-7.19 {Tcl_FileObjCmd: extension} { +test cmdAH-11.19 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a/b/c.d } .d -test cmdAH-7.20 {Tcl_FileObjCmd: extension} { +test cmdAH-11.20 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a/b.c/d } {} -test cmdAH-7.21 {Tcl_FileObjCmd: extension} { +test cmdAH-11.21 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension /a.b } .b -test cmdAH-7.22 {Tcl_FileObjCmd: extension} { +test cmdAH-11.22 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension foo.c: } {} -test cmdAH-7.23 {Tcl_FileObjCmd: extension} { +test cmdAH-11.23 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension {} } {} -test cmdAH-7.24 {Tcl_FileObjCmd: extension} { +test cmdAH-11.24 {Tcl_FileObjCmd: extension} { testsetplatform windows file ext foo } {} -test cmdAH-7.25 {Tcl_FileObjCmd: extension} { +test cmdAH-11.25 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension foo. } . -test cmdAH-7.26 {Tcl_FileObjCmd: extension} { +test cmdAH-11.26 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension .foo } .foo -test cmdAH-7.27 {Tcl_FileObjCmd: extension} { +test cmdAH-11.27 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension abc.def } .def -test cmdAH-7.28 {Tcl_FileObjCmd: extension} { +test cmdAH-11.28 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension abc.def.ghi } .ghi -test cmdAH-7.29 {Tcl_FileObjCmd: extension} { +test cmdAH-11.29 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a/b/c.d } .d -test cmdAH-7.30 {Tcl_FileObjCmd: extension} { +test cmdAH-11.30 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a/b.c/d } {} -test cmdAH-7.31 {Tcl_FileObjCmd: extension} { +test cmdAH-11.31 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b.c\\ } {} -test cmdAH-7.32 {Tcl_FileObjCmd: extension} { +test cmdAH-11.32 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b\\c.d } .d -test cmdAH-7.33 {Tcl_FileObjCmd: extension} { +test cmdAH-11.33 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b.c\\d } {} -test cmdAH-7.34 {Tcl_FileObjCmd: extension} { +test cmdAH-11.34 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b.c\\ } {} @@ -796,56 +940,56 @@ foreach value {a..b a...b a.c..b ..b} result {.b .b .b .b} { # pathtype -test cmdAH-8.1 {Tcl_FileObjCmd: pathtype} { +test cmdAH-12.1 {Tcl_FileObjCmd: pathtype} { testsetplatform unix list [catch {file pathtype a b} msg] $msg } {1 {wrong # args: should be "file pathtype name"}} -test cmdAH-8.2 {Tcl_FileObjCmd: pathtype} { +test cmdAH-12.2 {Tcl_FileObjCmd: pathtype} { testsetplatform unix file pathtype /a } absolute -test cmdAH-8.3 {Tcl_FileObjCmd: pathtype} { +test cmdAH-12.3 {Tcl_FileObjCmd: pathtype} { testsetplatform unix file p a } relative -test cmdAH-8.4 {Tcl_FileObjCmd: pathtype} { +test cmdAH-12.4 {Tcl_FileObjCmd: pathtype} { testsetplatform windows file pathtype c:a } volumerelative # split -test cmdAH-9.1 {Tcl_FileObjCmd: split} { +test cmdAH-13.1 {Tcl_FileObjCmd: split} { testsetplatform unix list [catch {file split a b} msg] $msg } {1 {wrong # args: should be "file split name"}} -test cmdAH-9.2 {Tcl_FileObjCmd: split} { +test cmdAH-13.2 {Tcl_FileObjCmd: split} { testsetplatform unix file split a } a -test cmdAH-9.3 {Tcl_FileObjCmd: split} { +test cmdAH-13.3 {Tcl_FileObjCmd: split} { testsetplatform unix file split a/b } {a b} # join -test cmdAH-10.1 {Tcl_FileObjCmd: join} { +test cmdAH-14.1 {Tcl_FileObjCmd: join} { testsetplatform unix file join a } a -test cmdAH-10.2 {Tcl_FileObjCmd: join} { +test cmdAH-14.2 {Tcl_FileObjCmd: join} { testsetplatform unix file join a b } a/b -test cmdAH-10.3 {Tcl_FileObjCmd: join} { +test cmdAH-14.3 {Tcl_FileObjCmd: join} { testsetplatform unix file join a b c d } a/b/c/d # error handling of Tcl_TranslateFileName -test cmdAH-11.1 {Tcl_FileObjCmd} { +test cmdAH-15.1 {Tcl_FileObjCmd} { testsetplatform unix list [catch {file atime ~_bad_user} msg] $msg } {1 {user "_bad_user" doesn't exist}} @@ -862,29 +1006,29 @@ if {[info commands testchmod] == {}} { makeFile abcde gorp.file makeDirectory dir.file -test cmdAH-12.1 {Tcl_FileObjCmd: readable} { +test cmdAH-16.1 {Tcl_FileObjCmd: readable} { list [catch {file readable a b} msg] $msg } {1 {wrong # args: should be "file readable name"}} testchmod 444 gorp.file -test cmdAH-12.2 {Tcl_FileObjCmd: readable} { +test cmdAH-16.2 {Tcl_FileObjCmd: readable} { file readable gorp.file } 1 testchmod 333 gorp.file -test cmdAH-12.3 {Tcl_FileObjCmd: readable} {unixOnly && !root} { +test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly notRoot} { file reada gorp.file } 0 # writable -test cmdAH-13.1 {Tcl_FileObjCmd: writable} { +test cmdAH-17.1 {Tcl_FileObjCmd: writable} { list [catch {file writable a b} msg] $msg } {1 {wrong # args: should be "file writable name"}} testchmod 555 gorp.file -test cmdAH-13.2 {Tcl_FileObjCmd: writable} {!root} { +test cmdAH-17.2 {Tcl_FileObjCmd: writable} {notRoot} { file writable gorp.file } 0 testchmod 222 gorp.file -test cmdAH-13.3 {Tcl_FileObjCmd: writable} { +test cmdAH-17.3 {Tcl_FileObjCmd: writable} { file writable gorp.file } 1 @@ -894,13 +1038,13 @@ file delete -force dir.file gorp.file file mkdir dir.file makeFile abcde gorp.file -test cmdAH-14.1 {Tcl_FileObjCmd: executable} { +test cmdAH-18.1 {Tcl_FileObjCmd: executable} { list [catch {file executable a b} msg] $msg } {1 {wrong # args: should be "file executable name"}} -test cmdAH-14.2 {Tcl_FileObjCmd: executable} { +test cmdAH-18.2 {Tcl_FileObjCmd: executable} { file executable gorp.file } 0 -test cmdAH-14.3 {Tcl_FileObjCmd: executable} {unix} { +test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly} { # Only on unix will setting the execute bit on a regular file # cause that file to be executable. @@ -908,14 +1052,14 @@ test cmdAH-14.3 {Tcl_FileObjCmd: executable} {unix} { file exe gorp.file } 1 -test cmdAH-14.4 {Tcl_FileObjCmd: executable} {mac} { +test cmdAH-18.4 {Tcl_FileObjCmd: executable} {macOnly} { # On mac, the only executable files are of type APPL. set x [file exe gorp.file] file attrib gorp.file -type APPL lappend x [file exe gorp.file] } {0 1} -test cmdAH-14.5 {Tcl_FileObjCmd: executable} {pc} { +test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pcOnly} { # On pc, must be a .exe, .com, etc. set x [file exe gorp.file] @@ -924,7 +1068,7 @@ test cmdAH-14.5 {Tcl_FileObjCmd: executable} {pc} { file delete gorp.exe set x } {0 1} -test cmdAH-14.6 {Tcl_FileObjCmd: executable} { +test cmdAH-18.6 {Tcl_FileObjCmd: executable} { # Directories are always executable. file exe dir.file @@ -937,11 +1081,11 @@ file delete link.file # exists -test cmdAH-15.1 {Tcl_FileObjCmd: exists} { +test cmdAH-19.1 {Tcl_FileObjCmd: exists} { list [catch {file exists a b} msg] $msg } {1 {wrong # args: should be "file exists name"}} -test cmdAH-15.2 {Tcl_FileObjCmd: exists} {file exists gorp.file} 0 -test cmdAH-15.3 {Tcl_FileObjCmd: exists} { +test cmdAH-19.2 {Tcl_FileObjCmd: exists} {file exists gorp.file} 0 +test cmdAH-19.3 {Tcl_FileObjCmd: exists} { file exists [file join dir.file gorp.file] } 0 catch { @@ -949,10 +1093,10 @@ catch { makeDirectory dir.file makeFile 12345 [file join dir.file gorp.file] } -test cmdAH-15.4 {Tcl_FileObjCmd: exists} { +test cmdAH-19.4 {Tcl_FileObjCmd: exists} { file exists gorp.file } 1 -test cmdAH-15.5 {Tcl_FileObjCmd: exists} { +test cmdAH-19.5 {Tcl_FileObjCmd: exists} { file exists [file join dir.file gorp.file] } 1 @@ -961,24 +1105,24 @@ if {[info commands testsetplatform] == {}} { puts "This application hasn't been compiled with the \"testsetplatform\"" puts "command, so I can't test Tcl_FileObjCmd etc." } else { -test cmdAH-15.6 {Tcl_FileObjCmd: nativename} { +test cmdAH-19.6 {Tcl_FileObjCmd: nativename} { testsetplatform unix list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] } {0 a/b {}} -test cmdAH-15.7 {Tcl_FileObjCmd: nativename} { +test cmdAH-19.7 {Tcl_FileObjCmd: nativename} { testsetplatform windows list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] } {0 {a\b} {}} -test cmdAH-15.8 {Tcl_FileObjCmd: nativename} { +test cmdAH-19.8 {Tcl_FileObjCmd: nativename} { testsetplatform mac list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] } {0 :a:b {}} } -test cmdAH-15.9 {Tcl_FileObjCmd: ~ : exists} { +test cmdAH-19.9 {Tcl_FileObjCmd: ~ : exists} { file exists ~nOsUcHuSeR } 0 -test cmdAH-15.10 {Tcl_FileObjCmd: ~ : nativename} { +test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} { # should probably be 0 in fact... catch {file nativename ~nOsUcHuSeR} } 1 @@ -987,21 +1131,20 @@ test cmdAH-15.10 {Tcl_FileObjCmd: ~ : nativename} { # 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 +test cmdAH-19.11 {Tcl_FileObjCmd: exists} {unixOnly notRoot} { + removeFile /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 - } + + set result [file exists /tmp/tcl.foo.dir/file] + exec chmod 775 /tmp/tcl.foo.dir - file delete /tmp/tcl.foo.dir/file + removeFile /tmp/tcl.foo.dir/file removeDirectory /tmp/tcl.foo.dir -} + set result +} 0 # Stat related commands @@ -1012,65 +1155,65 @@ catch {exec chmod 765 gorp.file} # atime -test cmdAH-16.1 {Tcl_FileObjCmd: atime} { +test cmdAH-20.1 {Tcl_FileObjCmd: atime} { list [catch {file atime a b} msg] $msg } {1 {wrong # args: should be "file atime name"}} -test cmdAH-16.2 {Tcl_FileObjCmd: atime} { +test cmdAH-20.2 {Tcl_FileObjCmd: atime} { catch {unset stat} file stat gorp.file stat list [expr {[file mtime gorp.file] == $stat(mtime)}] \ [expr {[file atime gorp.file] == $stat(atime)}] } {1 1} -test cmdAH-16.3 {Tcl_FileObjCmd: atime} { +test cmdAH-20.3 {Tcl_FileObjCmd: atime} { string tolower [list [catch {file atime _bogus_} msg] \ $msg $errorCode] -} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} # isdirectory -test cmdAH-17.1 {Tcl_FileObjCmd: isdirectory} { +test cmdAH-21.1 {Tcl_FileObjCmd: isdirectory} { list [catch {file isdirectory a b} msg] $msg } {1 {wrong # args: should be "file isdirectory name"}} -test cmdAH-17.2 {Tcl_FileObjCmd: isdirectory} { +test cmdAH-21.2 {Tcl_FileObjCmd: isdirectory} { file isdirectory gorp.file } 0 -test cmdAH-17.3 {Tcl_FileObjCmd: isdirectory} { +test cmdAH-21.3 {Tcl_FileObjCmd: isdirectory} { file isd dir.file } 1 # isfile -test cmdAH-18.1 {Tcl_FileObjCmd: isfile} { +test cmdAH-22.1 {Tcl_FileObjCmd: isfile} { list [catch {file isfile a b} msg] $msg } {1 {wrong # args: should be "file isfile name"}} -test cmdAH-18.2 {Tcl_FileObjCmd: isfile} {file isfile gorp.file} 1 -test cmdAH-18.3 {Tcl_FileObjCmd: isfile} {file isfile dir.file} 0 +test cmdAH-22.2 {Tcl_FileObjCmd: isfile} {file isfile gorp.file} 1 +test cmdAH-22.3 {Tcl_FileObjCmd: isfile} {file isfile dir.file} 0 # lstat and readlink: don't run these tests everywhere, since not all # sites will have symbolic links catch {exec ln -s gorp.file link.file} -test cmdAH-19.1 {Tcl_FileObjCmd: lstat} { +test cmdAH-23.1 {Tcl_FileObjCmd: lstat} { list [catch {file lstat a} msg] $msg } {1 {wrong # args: should be "file lstat name varName"}} -test cmdAH-19.2 {Tcl_FileObjCmd: lstat} { +test cmdAH-23.2 {Tcl_FileObjCmd: lstat} { list [catch {file lstat a b c} msg] $msg } {1 {wrong # args: should be "file lstat name varName"}} -test cmdAH-19.3 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} { +test cmdAH-23.3 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} { catch {unset stat} file lstat link.file stat lsort [array names stat] } {atime ctime dev gid ino mode mtime nlink size type uid} -test cmdAH-19.4 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} { +test cmdAH-23.4 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} { catch {unset stat} file lstat link.file stat list $stat(nlink) [expr $stat(mode)&0777] $stat(type) } {1 511 link} -test cmdAH-19.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} { +test cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} { string tolower [list [catch {file lstat _bogus_ stat} msg] \ $msg $errorCode] -} {1 {couldn't lstat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} -test cmdAH-19.6 {Tcl_FileObjCmd: lstat errors} { +} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} { catch {unset x} set x 44 list [catch {file lstat gorp.file x} msg] $msg $errorCode @@ -1079,10 +1222,10 @@ catch {unset stat} # mtime -test cmdAH-20.1 {Tcl_FileObjCmd: mtime} { +test cmdAH-24.1 {Tcl_FileObjCmd: mtime} { list [catch {file mtime a b} msg] $msg } {1 {wrong # args: should be "file mtime name"}} -test cmdAH-20.2 {Tcl_FileObjCmd: mtime} { +test cmdAH-24.2 {Tcl_FileObjCmd: mtime} { set old [file mtime gorp.file] after 2000 set f [open gorp.file w] @@ -1091,17 +1234,17 @@ test cmdAH-20.2 {Tcl_FileObjCmd: mtime} { set new [file mtime gorp.file] expr {($new > $old) && ($new <= ($old+5))} } {1} -test cmdAH-20.3 {Tcl_FileObjCmd: mtime} { +test cmdAH-24.3 {Tcl_FileObjCmd: mtime} { catch {unset stat} file stat gorp.file stat list [expr {[file mtime gorp.file] == $stat(mtime)}] \ [expr {[file atime gorp.file] == $stat(atime)}] } {1 1} -test cmdAH-20.4 {Tcl_FileObjCmd: mtime} { +test cmdAH-24.4 {Tcl_FileObjCmd: mtime} { string tolower [list [catch {file mtime _bogus_} msg] $msg \ $errorCode] -} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} -test cmdAH-20.5 {Tcl_FileObjCmd: mtime} { +} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdAH-24.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. @@ -1111,9 +1254,8 @@ test cmdAH-20.5 {Tcl_FileObjCmd: mtime} { set name tf } - # Borland file times were off by timezone. Make sure that a new file's - # time is correct. 10 seconds variance is allowed used due to slow - # networks or clock skew on a network drive. + # Make sure that a new file's time is correct. 10 seconds variance + # is allowed used due to slow networks or clock skew on a network drive. file delete -force $name close [open $name w] @@ -1125,43 +1267,43 @@ test cmdAH-20.5 {Tcl_FileObjCmd: mtime} { # owned -test cmdAH-21.1 {Tcl_FileObjCmd: owned} { +test cmdAH-25.1 {Tcl_FileObjCmd: owned} { list [catch {file owned a b} msg] $msg } {1 {wrong # args: should be "file owned name"}} -test cmdAH-21.2 {Tcl_FileObjCmd: owned} { +test cmdAH-25.2 {Tcl_FileObjCmd: owned} { file owned gorp.file } 1 -test cmdAH-21.3 {Tcl_FileObjCmd: owned} {unixOnly && !root} { +test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unixOnly notRoot} { file owned / } 0 # readlink -test cmdAH-22.1 {Tcl_FileObjCmd: readlink} { +test cmdAH-26.1 {Tcl_FileObjCmd: readlink} { list [catch {file readlink a b} msg] $msg } {1 {wrong # args: should be "file readlink name"}} -test cmdAH-22.2 {Tcl_FileObjCmd: readlink} {unixOnly nonPortable} { +test cmdAH-26.2 {Tcl_FileObjCmd: readlink} {unixOnly nonPortable} { file readlink link.file } gorp.file -test cmdAH-22.3 {Tcl_FileObjCmd: readlink errors} {unixOnly nonPortable} { +test cmdAH-26.3 {Tcl_FileObjCmd: readlink errors} {unixOnly nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] -} {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} -test cmdAH-22.4 {Tcl_FileObjCmd: readlink errors} {macOnly nonPortable} { +} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdAH-26.4 {Tcl_FileObjCmd: readlink errors} {macOnly nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] -} {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} -test cmdAH-22.5 {Tcl_FileObjCmd: readlink errors} {pcOnly nonPortable} { +} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdAH-26.5 {Tcl_FileObjCmd: readlink errors} {pcOnly nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] -} {1 {couldn't readlink "_bogus_": invalid argument} {posix einval {invalid argument}}} +} {1 {could not readlink "_bogus_": invalid argument} {posix einval {invalid argument}}} # size -test cmdAH-23.1 {Tcl_FileObjCmd: size} { +test cmdAH-27.1 {Tcl_FileObjCmd: size} { list [catch {file size a b} msg] $msg } {1 {wrong # args: should be "file size name"}} -test cmdAH-23.2 {Tcl_FileObjCmd: size} { +test cmdAH-27.2 {Tcl_FileObjCmd: size} { set oldsize [file size gorp.file] set f [open gorp.file a] fconfigure $f -translation lf -eofchar {} @@ -1169,10 +1311,10 @@ test cmdAH-23.2 {Tcl_FileObjCmd: size} { close $f expr {[file size gorp.file] - $oldsize} } {10} -test cmdAH-23.3 {Tcl_FileObjCmd: size} { +test cmdAH-27.3 {Tcl_FileObjCmd: size} { string tolower [list [catch {file size _bogus_} msg] $msg \ $errorCode] -} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} # stat @@ -1180,88 +1322,141 @@ catch {testsetplatform $platform} makeFile "Test string" gorp.file catch {exec chmod 765 gorp.file} -test cmdAH-24.1 {Tcl_FileObjCmd: stat} { +test cmdAH-28.1 {Tcl_FileObjCmd: stat} { list [catch {file stat _bogus_} msg] $msg $errorCode } {1 {wrong # args: should be "file stat name varName"} NONE} -test cmdAH-24.2 {Tcl_FileObjCmd: stat} { +test cmdAH-28.2 {Tcl_FileObjCmd: stat} { list [catch {file stat _bogus_ a b} msg] $msg $errorCode } {1 {wrong # args: should be "file stat name varName"} NONE} -test cmdAH-24.3 {Tcl_FileObjCmd: stat} { +test cmdAH-28.3 {Tcl_FileObjCmd: stat} { catch {unset stat} file stat gorp.file stat lsort [array names stat] } {atime ctime dev gid ino mode mtime nlink size type uid} -test cmdAH-24.4 {Tcl_FileObjCmd: stat} { +test cmdAH-28.4 {Tcl_FileObjCmd: stat} { catch {unset stat} file stat gorp.file stat list $stat(nlink) $stat(size) $stat(type) } {1 12 file} -test cmdAH-24.5 {Tcl_FileObjCmd: stat} {unix} { +test cmdAH-28.5 {Tcl_FileObjCmd: stat} {unixOnly} { catch {unset stat} file stat gorp.file stat expr $stat(mode)&0777 } {501} -test cmdAH-24.6 {Tcl_FileObjCmd: stat} { +test cmdAH-28.6 {Tcl_FileObjCmd: stat} { string tolower [list [catch {file stat _bogus_ stat} msg] \ $msg $errorCode] -} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} -test cmdAH-24.7 {Tcl_FileObjCmd: stat} { +} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdAH-28.7 {Tcl_FileObjCmd: stat} { catch {unset x} set x 44 list [catch {file stat gorp.file x} msg] $msg $errorCode } {1 {can't set "x(dev)": variable isn't array} NONE} +test cmdAH-28.8 {Tcl_FileObjCmd: stat} { + # Sign extension of purported unsigned short to int. + + close [open foo.test w] + file stat foo.test stat + set x [expr {$stat(mode) > 0}] + file delete foo.test + set x +} 1 +test cmdAH-28.9 {Tcl_FileObjCmd: stat} {pcOnly} { + # stat of root directory was failing. + # don't care about answer, just that test runs. + + # relative paths that resolve to root + set old [pwd] + cd c:/ + file stat c: stat + file stat c:. stat + file stat . stat + cd $old + + file stat / stat + file stat c:/ stat + file stat c:/. stat +} {} +test cmdAH-28.10 {Tcl_FileObjCmd: stat} {pcOnly nonPortable} { + # stat of root directory was failing. + # don't care about answer, just that test runs. + + file stat //pop/$env(USERNAME) stat + file stat //pop/$env(USERNAME)/ stat + file stat //pop/$env(USERNAME)/. stat +} {} +test cmdAH-28.11 {Tcl_FileObjCmd: stat} {pcOnly nonPortable} { + # stat of network directory was returning id of current local drive. + + set old [pwd] + cd c:/ + + file stat //pop/$env(USERNAME) stat + cd $old + expr {$stat(dev) == 2} +} 0 +test cmdAH-28.12 {Tcl_FileObjCmd: stat} { + # stat(mode) with S_IFREG flag was returned as a negative number + # if mode_t was a short instead of an unsigned short. + + close [open foo.test w] + file stat foo.test stat + file delete foo.test + expr {$stat(mode) > 0} +} 1 catch {unset stat} # type file delete link.file -test cmdAH-25.1 {Tcl_FileObjCmd: type} { +test cmdAH-29.1 {Tcl_FileObjCmd: type} { list [catch {file size a b} msg] $msg } {1 {wrong # args: should be "file size name"}} -test cmdAH-25.2 {Tcl_FileObjCmd: type} { +test cmdAH-29.2 {Tcl_FileObjCmd: type} { file type dir.file } directory -test cmdAH-25.3 {Tcl_FileObjCmd: type} { +test cmdAH-29.3 {Tcl_FileObjCmd: type} { file type gorp.file } file -test cmdAH-25.4 {Tcl_FileObjCmd: type} {unixOnly nonPortable} { +test cmdAH-29.4 {Tcl_FileObjCmd: type} {unixOnly nonPortable} { exec ln -s a/b/c link.file set result [file type link.file] file delete link.file set result } link -test cmdAH-25.5 {Tcl_FileObjCmd: type} { +test cmdAH-29.5 {Tcl_FileObjCmd: type} { string tolower [list [catch {file type _bogus_} msg] $msg $errorCode] -} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} # Error conditions -test cmdAH-26.1 {error conditions} { +test cmdAH-30.1 {error conditions} { list [catch {file gorp x} msg] $msg } {1 {bad option "gorp": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-26.2 {error conditions} { +test cmdAH-30.2 {error conditions} { list [catch {file ex x} msg] $msg } {1 {ambiguous option "ex": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-26.3 {error conditions} { +test cmdAH-30.3 {error conditions} { list [catch {file is x} msg] $msg } {1 {ambiguous option "is": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-26.4 {error conditions} { +test cmdAH-30.4 {error conditions} { list [catch {file z x} msg] $msg } {1 {bad option "z": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-26.5 {error conditions} { +test cmdAH-30.5 {error conditions} { list [catch {file read x} msg] $msg } {1 {ambiguous option "read": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-26.6 {error conditions} { +test cmdAH-30.6 {error conditions} { list [catch {file s x} msg] $msg } {1 {ambiguous option "s": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-26.7 {error conditions} { +test cmdAH-30.7 {error conditions} { list [catch {file t x} msg] $msg } {1 {ambiguous option "t": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} -test cmdAH-26.8 {error conditions} { +test cmdAH-30.8 {error conditions} { list [catch {file dirname ~woohgy} msg] $msg } {1 {user "woohgy" doesn't exist}} +# cleanup catch {testsetplatform $platform} catch {unset platform} @@ -1270,4 +1465,20 @@ file delete -force dir.file file delete gorp.file file delete link.file -concat "" +cd $cmdAHwd + +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tests/cmdIL.test b/tests/cmdIL.test index cd7cf31..ac39ec0 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -3,14 +3,16 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998 by Scriptics Corporation. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdIL.test,v 1.5 1998/10/13 20:30:23 rjohnson Exp $ +# RCS: @(#) $Id: cmdIL.test,v 1.6 1999/04/16 00:47:24 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test cmdIL-1.1 {Tcl_LsortObjCmd procedure} { list [catch {lsort} msg] $msg @@ -255,7 +257,19 @@ test cmdIL-4.22 {DictionaryCompare procedure, case} { test cmdIL-4.23 {DictionaryCompare procedure, case} { lsort -dictionary {ABcd AbCd} } {ABcd AbCd} -test cmdIL-4.24 {DefaultCompare procedure, signed characters} { +test cmdIL-4.24 {DictionaryCompare procedure, international characters} {hasIsoLocale} { + ::tcltest::set_iso8859_1_locale + set result [lsort -dictionary "a b c A B C \xe3 \xc4"] + ::tcltest::restore_locale + set result +} "A a B b C c \xe3 \xc4" +test cmdIL-4.25 {DictionaryCompare procedure, international characters} {hasIsoLocale} { + ::tcltest::set_iso8859_1_locale + set result [lsort -dictionary "a23\xe3 a23\xc5 a23\xe4"] + ::tcltest::restore_locale + set result +} "a23\xe3 a23\xe4 a23\xc5" +test cmdIL-4.26 {DefaultCompare procedure, signed characters} { set l [lsort [list "abc\200" "abc"]] set viewlist {} foreach s $l { @@ -274,7 +288,7 @@ test cmdIL-4.24 {DefaultCompare procedure, signed characters} { } set viewlist } [list "abc" "abc\\200"] -test cmdIL-4.25 {DictionaryCompare procedure, signed characters} { +test cmdIL-4.27 {DictionaryCompare procedure, signed characters} { set l [lsort -dictionary [list "abc\200" "abc"]] set viewlist {} foreach s $l { @@ -293,3 +307,19 @@ test cmdIL-4.25 {DictionaryCompare procedure, signed characters} { } set viewlist } [list "abc" "abc\\200"] + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test index 661caa4..ad18e70 100644 --- a/tests/cmdInfo.test +++ b/tests/cmdInfo.test @@ -8,20 +8,24 @@ # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdInfo.test,v 1.2 1998/09/14 18:40:08 stanton Exp $ +# RCS: @(#) $Id: cmdInfo.test,v 1.3 1999/04/16 00:47:24 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[info commands testcmdinfo] == {}} { puts "This application hasn't been compiled with the \"testcmdinfo\"" puts "command, so I can't test Tcl_GetCommandInfo etc." + ::tcltest::cleanupTests 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 @@ -93,6 +97,20 @@ test cmdinfo-6.1 {Names for commands created when outside namespaces} { eval lappend y [testcmdtoken name $x] } {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2} +# cleanup catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1} catch {rename x1 ""} -concat {} +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test new file mode 100644 index 0000000..4cd72d2 --- /dev/null +++ b/tests/cmdMZ.test @@ -0,0 +1,581 @@ +# The tests in this file cover the procedures in tclCmdMZ.c. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: cmdMZ.test,v 1.2 1999/04/16 00:47:24 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +# Tcl_PwdObjCmd + +test cmdMZ-1.1 {Tcl_PwdObjCmd} { + list [catch {pwd a} msg] $msg +} {1 {wrong # args: should be "pwd"}} +test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} { + catch pwd +} 0 +test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} { + expr [string length pwd]>0 +} 1 +test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unixOnly} { + file delete -force foo + file mkdir foo + set cwd [pwd] + cd foo + file attr . -permissions 000 + set result [list [catch {pwd} msg] $msg] + cd $cwd + file delete -force foo + set result +} {1 {error getting working directory name: permission denied}} + +# The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test + +# Tcl_RenameObjCmd + +test cmdMZ-2.1 {Tcl_RenameObjCmd: error conditions} { + list [catch {rename r1} msg] $msg $errorCode +} {1 {wrong # args: should be "rename oldName newName"} NONE} +test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} { + list [catch {rename r1 r2 r3} msg] $msg $errorCode +} {1 {wrong # args: should be "rename oldName newName"} NONE} +test cmdMZ-2.3 {Tcl_RenameObjCmd: success} { + catch {rename r2 {}} + proc r1 {} {return "r1"} + rename r1 r2 + r2 +} {r1} +test cmdMZ-2.4 {Tcl_RenameObjCmd: success} { + proc r1 {} {return "r1"} + rename r1 {} + list [catch {r1} msg] $msg +} {1 {invalid command name "r1"}} + +# The tests for Tcl_ReturnObjCmd are in proc-old.test +# The tests for Tcl_ScanObjCmd are in scan.test + +# Tcl_SourceObjCmd + +test cmdMZ-3.1 {Tcl_SourceObjCmd: error conditions} {macOnly} { + list [catch {source} msg] $msg +} {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} +test cmdMZ-3.2 {Tcl_SourceObjCmd: error conditions} {macOnly} { + list [catch {source a b} msg] $msg +} {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} +test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} {unixOrPc} { + list [catch {source} msg] $msg +} {1 {wrong # args: should be "source fileName"}} +test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} {unixOrPc} { + list [catch {source a b} msg] $msg +} {1 {wrong # args: should be "source fileName"}} +test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} { + makeFile { + set x 146 + error "error in sourced file" + set y $x + } source.file + list [catch {source source.file} msg] $msg $errorInfo +} {1 {error in sourced file} {error in sourced file + while executing +"error "error in sourced file"" + (file "source.file" line 3) + invoked from within +"source source.file"}} +test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} { + makeFile {list result} source.file + source source.file +} result + +# Tcl_SplitObjCmd + +test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} { + list [catch split msg] $msg $errorCode +} {1 {wrong # args: should be "split string ?splitChars?"} NONE} +test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} { + list [catch {split a b c} msg] $msg $errorCode +} {1 {wrong # args: should be "split string ?splitChars?"} NONE} +test cmdMZ-4.3 {Tcl_SplitObjCmd: basic split commands} { + split "a\n b\t\r c\n " +} {a {} b {} {} c {} {}} +test cmdMZ-4.4 {Tcl_SplitObjCmd: basic split commands} { + split "word 1xyzword 2zword 3" xyz +} {{word 1} {} {} {word 2} {word 3}} +test cmdMZ-4.5 {Tcl_SplitObjCmd: basic split commands} { + split "12345" {} +} {1 2 3 4 5} +test cmdMZ-4.6 {Tcl_SplitObjCmd: basic split commands} { + split "a\}b\[c\{\]\$" +} "a\\}b\\\[c\\{\\\]\\\$" +test cmdMZ-4.7 {Tcl_SplitObjCmd: basic split commands} { + split {} {} +} {} +test cmdMZ-4.8 {Tcl_SplitObjCmd: basic split commands} { + split {} +} {} +test cmdMZ-4.9 {Tcl_SplitObjCmd: basic split commands} { + split { } +} {{} {} {} {}} +test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} { + proc foo {} { + set x {} + foreach f [split {]\n} {}] { + append x $f + } + return $x + } + foo +} {]\n} +test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} { + proc foo {} { + set x ab\000c + set y [split $x {}] + return $y + } + foo +} "a b \000 c" +test cmdMZ-4.12 {Tcl_SplitObjCmd: basic split commands} { + split "a0ab1b2bbb3\000c4" ab\000c +} {{} 0 {} 1 2 {} {} 3 {} 4} +test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} { + # if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq" + split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e" +} "a b qw\u5e4eN wq" + +# Tcl_StringObjCmd + +test cmdMZ-5.1 {Tcl_StringObjCmd: error conditions} { + list [catch {string} msg] $msg +} {1 {wrong # args: should be "string option arg ?arg ...?"}} +test cmdMZ-5.2 {Tcl_StringObjCmd: error conditions} { + list [catch {string gorp a b} msg] $msg +} {1 {bad option "gorp": must be compare, first, index, last, length, match, range, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}} + +test cmdMZ-6.1 {Tcl_StringObjCmd: string compare} { + list [catch {string compare a} msg] $msg +} {1 {wrong # args: should be "string compare string1 string2"}} +test cmdMZ-6.2 {Tcl_StringObjCmd: string compare} { + list [catch {string compare a b c} msg] $msg +} {1 {wrong # args: should be "string compare string1 string2"}} +test cmdMZ-6.3 {Tcl_StringObjCmd: string compare} { + string compare abcde abdef +} -1 +test cmdMZ-6.4 {Tcl_StringObjCmd: string compare} { + string c abcde ABCDE +} 1 +test cmdMZ-6.5 {Tcl_StringObjCmd: string compare} { + string compare abcde abcde +} 0 +test cmdMZ-6.6 {Tcl_StringObjCmd: string compare} { + string compare ab abcde +} -1 +test cmdMZ-6.7 {Tcl_StringObjCmd: string compare} { + string compare abcde ab +} 1 +test cmdMZ-6.8 {Tcl_StringObjCmd: string compare} { + string compare cde ab +} 1 +test cmdMZ-6.9 {Tcl_StringObjCmd: string compare} { + string compare ab cde +} -1 +test cmdMZ-6.10 {Tcl_StringObjCmd: string compare, unicode} { + string compare ab\u7266 ab\u7267 +} -1 +test cmdMZ-6.11 {Tcl_StringObjCmd: string compare, high bit} { + # This test will fail if the underlying comparaison + # is using signed chars instead of unsigned chars. + # (like SunOS's default memcmp thus the compat/memcmp.c) + string compare "\x80" "@" + # Nb this tests works also in utf8 space because \x80 is + # translated into a 2 or more bytes but whose first byte has + # the high bit set. +} 1 + +test cmdMZ-7.1 {Tcl_StringObjCmd: string first} { + list [catch {string first a} msg] $msg +} {1 {wrong # args: should be "string first string1 string2"}} +test cmdMZ-7.2 {Tcl_StringObjCmd: string first} { + list [catch {string first a b c} msg] $msg +} {1 {wrong # args: should be "string first string1 string2"}} +test cmdMZ-7.3 {Tcl_StringObjCmd: string first} { + string first bq abcdefgbcefgbqrs +} 12 +test cmdMZ-7.4 {Tcl_StringObjCmd: string first} { + string fir bcd abcdefgbcefgbqrs +} 1 +test cmdMZ-7.5 {Tcl_StringObjCmd: string first} { + string f b abcdefgbcefgbqrs +} 1 +test cmdMZ-7.6 {Tcl_StringObjCmd: string first} { + string first xxx x123xx345xxx789xxx012 +} 9 +test cmdMZ-7.7 {Tcl_StringObjCmd: string first} { + string first "" x123xx345xxx789xxx012 +} -1 +test cmdMZ-7.8 {Tcl_StringObjCmd: string first, unicode} { + string first x abc\u7266x +} 4 +test cmdMZ-7.9 {Tcl_StringObjCmd: string first, unicode} { + string first \u7266 abc\u7266x +} 3 + +test cmdMZ-8.1 {Tcl_StringObjCmd: string index} { + list [catch {string index} msg] $msg +} {1 {wrong # args: should be "string index string charIndex"}} +test cmdMZ-8.2 {Tcl_StringObjCmd: string index} { + list [catch {string index a b c} msg] $msg +} {1 {wrong # args: should be "string index string charIndex"}} +test cmdMZ-8.3 {Tcl_StringObjCmd: string index} { + list [catch {string index a xyz} msg] $msg +} {1 {expected integer but got "xyz"}} +test cmdMZ-8.4 {Tcl_StringObjCmd: string index} { + string index abcde 0 +} a +test cmdMZ-8.5 {Tcl_StringObjCmd: string index} { + string i abcde 4 +} e +test cmdMZ-8.6 {Tcl_StringObjCmd: string index} { + string index abcde 5 +} {} +test cmdMZ-8.7 {Tcl_StringObjCmd: string index} { + list [catch {string index abcde -10} msg] $msg +} {0 {}} +test cmdMZ-8.8 {Tcl_StringObjCmd: string index, unicode} { + string index abc\u7266d 4 +} d +test cmdMZ-8.9 {Tcl_StringObjCmd: string index, unicode} { + string index abc\u7266d 3 +} \u7266 + +test cmdMZ-9.1 {Tcl_StringObjCmd: string last} { + list [catch {string last a} msg] $msg +} {1 {wrong # args: should be "string last string1 string2"}} +test cmdMZ-9.2 {Tcl_StringObjCmd: string last} { + list [catch {string last a b c} msg] $msg +} {1 {wrong # args: should be "string last string1 string2"}} +test cmdMZ-9.3 {Tcl_StringObjCmd: string last} { + string la xxx xxxx123xx345x678 +} 1 +test cmdMZ-9.4 {Tcl_StringObjCmd: string last} { + string last xx xxxx123xx345x678 +} 7 +test cmdMZ-9.5 {Tcl_StringObjCmd: string last} { + string las x xxxx123xx345x678 +} 12 +test cmdMZ-9.6 {Tcl_StringObjCmd: string last, unicode} { + string las x xxxx12\u7266xx345x678 +} 12 +test cmdMZ-9.7 {Tcl_StringObjCmd: string last, unicode} { + string las \u7266 xxxx12\u7266xx345x678 +} 6 + +test cmdMZ-10.1 {Tcl_StringObjCmd: string length} { + list [catch {string length} msg] $msg +} {1 {wrong # args: should be "string length string"}} +test cmdMZ-10.2 {Tcl_StringObjCmd: string length} { + list [catch {string length a b} msg] $msg +} {1 {wrong # args: should be "string length string"}} +test cmdMZ-10.3 {Tcl_StringObjCmd: string length} { + string length "a little string" +} 15 +test cmdMZ-10.4 {Tcl_StringObjCmd: string length} { + string le "" +} 0 +test cmdMZ-10.5 {Tcl_StringObjCmd: string length, unicode} { + string le "abcd\u7266" +} 5 + +test cmdMZ-11.1 {Tcl_StringObjCmd: string match} { + list [catch {string match a} msg] $msg +} {1 {wrong # args: should be "string match pattern string"}} +test cmdMZ-11.2 {Tcl_StringObjCmd: string match} { + list [catch {string match a b c} msg] $msg +} {1 {wrong # args: should be "string match pattern string"}} +test cmdMZ-11.3 {Tcl_StringObjCmd: string match} { + string match abc abc +} 1 +test cmdMZ-11.4 {Tcl_StringObjCmd: string match} { + string m abc abd +} 0 + +test cmdMZ-12.1 {Tcl_StringObjCmd: string range} { + list [catch {string range} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test cmdMZ-12.2 {Tcl_StringObjCmd: string range} { + list [catch {string range a 1} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test cmdMZ-12.3 {Tcl_StringObjCmd: string range} { + list [catch {string range a 1 2 3} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test cmdMZ-12.4 {Tcl_StringObjCmd: string range} { + list [catch {string range abc abc 1} msg] $msg +} {1 {bad index "abc": must be integer or "end"}} +test cmdMZ-12.5 {Tcl_StringObjCmd: string range} { + list [catch {string range abc 1 eof} msg] $msg +} {1 {bad index "eof": must be integer or "end"}} +test cmdMZ-12.6 {Tcl_StringObjCmd: string range, first < 0} { + string range abcdefghijklmnop -3 2 +} {abc} +test cmdMZ-12.7 {Tcl_StringObjCmd: string range} { + string range abcdefghijklmnop 2 14 +} {cdefghijklmno} +test cmdMZ-12.8 {Tcl_StringObjCmd: string range, last > length} { + string range abcdefghijklmnop 7 1000 +} {hijklmnop} +test cmdMZ-12.9 {Tcl_StringObjCmd: string range} { + string range abcdefghijklmnop 10 e +} {klmnop} +test cmdMZ-12.10 {Tcl_StringObjCmd: string range, last < first} { + string range abcdefghijklmnop 10 9 +} {} +test cmdMZ-12.11 {Tcl_StringObjCmd: string range} { + string range abcdefghijklmnop -3 -2 +} {} +test cmdMZ-12.12 {Tcl_StringObjCmd: string range} { + string range abcdefghijklmnop 1000 1010 +} {} +test cmdMZ-12.13 {Tcl_StringObjCmd: string range} { + string range abcdefghijklmnop -100 end +} {abcdefghijklmnop} +test cmdMZ-12.14 {Tcl_StringObjCmd: string range} { + string range abcdefghijklmnop end end +} {p} +test cmdMZ-12.15 {Tcl_StringObjCmd: string range} { + string range abcdefghijklmnop e 1000 +} {p} +test cmdMZ-12.16 {Tcl_StringObjCmd: string range, unicode} { + string range ab\u7266cdefghijklmnop 5 5 +} e +test cmdMZ-12.17 {Tcl_StringObjCmd: string range, unicode} { + string range ab\u7266cdefghijklmnop 2 3 +} \u7266c + +test cmdMZ-13.1 {Tcl_StringObjCmd: string tolower} { + list [catch {string tolower} msg] $msg +} {1 {wrong # args: should be "string tolower string"}} +test cmdMZ-13.2 {Tcl_StringObjCmd: string tolower} { + list [catch {string tolower a b} msg] $msg +} {1 {wrong # args: should be "string tolower string"}} +test cmdMZ-13.3 {Tcl_StringObjCmd: string tolower} { + string tolower ABCDeF +} {abcdef} +test cmdMZ-13.4 {Tcl_StringObjCmd: string tolower} { + string tolower "ABC XyZ" +} {abc xyz} +test cmdMZ-13.5 {Tcl_StringObjCmd: string tolower} { + string tolower {123#$&*()} +} {123#$&*()} +test cmdMZ-13.6 {Tcl_StringObjCmd: string tolower, unicode} { + string tolower ABCabc\xc7\xe7 +} "abcabc\xe7\xe7" + +test cmdMZ-14.1 {Tcl_StringObjCmd: string toupper} { + list [catch {string toupper} msg] $msg +} {1 {wrong # args: should be "string toupper string"}} +test cmdMZ-14.2 {Tcl_StringObjCmd: string toupper} { + list [catch {string toupper a b} msg] $msg +} {1 {wrong # args: should be "string toupper string"}} +test cmdMZ-14.3 {Tcl_StringObjCmd: string toupper} { + string toupper abCDEf +} {ABCDEF} +test cmdMZ-14.4 {Tcl_StringObjCmd: string toupper} { + string toupper "abc xYz" +} {ABC XYZ} +test cmdMZ-14.5 {Tcl_StringObjCmd: string toupper} { + string toupper {123#$&*()} +} {123#$&*()} +test cmdMZ-14.6 {Tcl_StringObjCmd: string toupper, unicode} { + string toupper ABCabc\xc7\xe7 +} "ABCABC\xc7\xc7" + +test cmdMZ-15.1 {Tcl_StringObjCmd: string totitle} { + list [catch {string totitle} msg] $msg +} {1 {wrong # args: should be "string totitle string"}} +test cmdMZ-15.2 {Tcl_StringObjCmd: string totitle} { + list [catch {string totitle a b} msg] $msg +} {1 {wrong # args: should be "string totitle string"}} +test cmdMZ-15.3 {Tcl_StringObjCmd: string totitle} { + string totitle abCDEf +} {Abcdef} +test cmdMZ-15.4 {Tcl_StringObjCmd: string totitle} { + string totitle "abc xYz" +} {Abc xyz} +test cmdMZ-15.5 {Tcl_StringObjCmd: string totitle} { + string totitle {123#$&*()} +} {123#$&*()} +test cmdMZ-15.6 {Tcl_StringObjCmd: string totitle, unicode} { + string totitle ABCabc\xc7\xe7 +} "Abcabc\xe7\xe7" +test cmdMZ-15.7 {Tcl_StringObjCmd: string totitle, unicode} { + string totitle \u01f3BCabc\xc7\xe7 +} "\u01f2bcabc\xe7\xe7" + +test cmdMZ-16.1 {Tcl_StringObjCmd: string trim} { + list [catch {string trim} msg] $msg +} {1 {wrong # args: should be "string trim string ?chars?"}} +test cmdMZ-16.2 {Tcl_StringObjCmd: string trim} { + list [catch {string trim a b c} msg] $msg +} {1 {wrong # args: should be "string trim string ?chars?"}} +test cmdMZ-16.3 {Tcl_StringObjCmd: string trim} { + string trim " XYZ " +} {XYZ} +test cmdMZ-16.4 {Tcl_StringObjCmd: string trim} { + string trim "\t\nXYZ\t\n\r\n" +} {XYZ} +test cmdMZ-16.5 {Tcl_StringObjCmd: string trim} { + string trim " A XYZ A " +} {A XYZ A} +test cmdMZ-16.6 {Tcl_StringObjCmd: string trim} { + string trim "XXYYZZABC XXYYZZ" ZYX +} {ABC } +test cmdMZ-16.7 {Tcl_StringObjCmd: string trim} { + string trim " \t\r " +} {} +test cmdMZ-16.8 {Tcl_StringObjCmd: string trim} { + string trim {abcdefg} {} +} {abcdefg} +test cmdMZ-16.9 {Tcl_StringObjCmd: string trim} { + string trim {} +} {} +test cmdMZ-16.10 {Tcl_StringObjCmd: string trim} { + string trim ABC DEF +} {ABC} +test cmdMZ-16.11 {Tcl_StringObjCmd: string trim, unicode} { + string trim "\xe7\xe8 AB\xe7C \xe8\xe7" \xe7\xe8 +} " AB\xe7C " + +test cmdMZ-17.1 {Tcl_StringObjCmd: string trimleft} { + string trimleft " XYZ " +} {XYZ } +test cmdMZ-17.2 {Tcl_StringObjCmd: string trimleft} { + list [catch {string trimleft} msg] $msg +} {1 {wrong # args: should be "string trimleft string ?chars?"}} +test cmdMZ-17.3 {Tcl_StringObjCmd: string trimleft} { + string length [string trimleft " "] +} {0} + +test cmdMZ-18.1 {Tcl_StringObjCmd: string trimright} { + string trimright " XYZ " +} { XYZ} +test cmdMZ-18.2 {Tcl_StringObjCmd: string trimright} { + string trimright " " +} {} +test cmdMZ-18.3 {Tcl_StringObjCmd: string trimright} { + string trimright "" +} {} +test cmdMZ-18.4 {Tcl_StringObjCmd: string trimright errors} { + list [catch {string trimright} msg] $msg +} {1 {wrong # args: should be "string trimright string ?chars?"}} +test cmdMZ-18.5 {Tcl_StringObjCmd: string trimright errors} { + list [catch {string trimg a} msg] $msg +} {1 {bad option "trimg": must be compare, first, index, last, length, match, range, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}} + +test cmdMZ-19.1 {Tcl_StringObjCmd: string wordend} { + list [catch {string wordend a} msg] $msg +} {1 {wrong # args: should be "string wordend string index"}} +test cmdMZ-19.2 {Tcl_StringObjCmd: string wordend} { + list [catch {string wordend a b c} msg] $msg +} {1 {wrong # args: should be "string wordend string index"}} +test cmdMZ-19.3 {Tcl_StringObjCmd: string wordend} { + list [catch {string wordend a gorp} msg] $msg +} {1 {expected integer but got "gorp"}} +test cmdMZ-19.4 {Tcl_StringObjCmd: string wordend} { + string wordend abc. -1 +} 3 +test cmdMZ-19.5 {Tcl_StringObjCmd: string wordend} { + string wordend abc. 100 +} 4 +test cmdMZ-19.6 {Tcl_StringObjCmd: string wordend} { + string wordend "word_one two three" 2 +} 8 +test cmdMZ-19.7 {Tcl_StringObjCmd: string wordend} { + string wordend "one .&# three" 5 +} 6 +test cmdMZ-19.8 {Tcl_StringObjCmd: string wordend} { + string worde "x.y" 0 +} 1 +test cmdMZ-19.9 {Tcl_StringObjCmd: string wordend, unicode} { + string wordend "xyz\u00c7de fg" 0 +} 6 +test cmdMZ-19.10 {Tcl_StringObjCmd: string wordend, unicode} { + string wordend "xyz\uc700de fg" 0 +} 6 +test cmdMZ-19.11 {Tcl_StringObjCmd: string wordend, unicode} { + string wordend "xyz\u203fde fg" 0 +} 6 +test cmdMZ-19.12 {Tcl_StringObjCmd: string wordend, unicode} { + string wordend "xyz\u2045de fg" 0 +} 3 +test cmdMZ-19.13 {Tcl_StringObjCmd: string wordend, unicode} { + string wordend "\uc700\uc700 abc" 8 +} 6 + +test cmdMZ-20.1 {Tcl_StringObjCmd: string wordstart} { + list [catch {string word a} msg] $msg +} {1 {ambiguous option "word": must be compare, first, index, last, length, match, range, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}} +test cmdMZ-20.2 {Tcl_StringObjCmd: string wordstart} { + list [catch {string wordstart a} msg] $msg +} {1 {wrong # args: should be "string wordstart string index"}} +test cmdMZ-20.3 {Tcl_StringObjCmd: string wordstart} { + list [catch {string wordstart a b c} msg] $msg +} {1 {wrong # args: should be "string wordstart string index"}} +test cmdMZ-20.4 {Tcl_StringObjCmd: string wordstart} { + list [catch {string wordstart a gorp} msg] $msg +} {1 {expected integer but got "gorp"}} +test cmdMZ-20.5 {Tcl_StringObjCmd: string wordstart} { + string wordstart "one two three_words" 400 +} 8 +test cmdMZ-20.6 {Tcl_StringObjCmd: string wordstart} { + string wordstart "one two three_words" 2 +} 0 +test cmdMZ-20.7 {Tcl_StringObjCmd: string wordstart} { + string wordstart "one two three_words" -2 +} 0 +test cmdMZ-20.8 {Tcl_StringObjCmd: string wordstart} { + string wordstart "one .*&^ three" 6 +} 6 +test cmdMZ-20.9 {Tcl_StringObjCmd: string wordstart} { + string wordstart "one two three" 4 +} 4 +test cmdMZ-20.10 {Tcl_StringObjCmd: string wordstart, unicode} { + string wordstart "one tw\u00c7o three" 7 +} 4 +test cmdMZ-20.11 {Tcl_StringObjCmd: string wordstart, unicode} { + string wordstart "ab\uc700\uc700 cdef ghi" 12 +} 10 +test cmdMZ-20.12 {Tcl_StringObjCmd: string wordstart, unicode} { + string wordstart "\uc700\uc700 abc" 8 +} 3 + +# The tests for Tcl_SubstObjCmd are in subst.test +# The tests for Tcl_SwitchObjCmd are in switch.test +# There are no tests for Tcl_TimeObjCmd +# The tests for Tcl_TraceObjCmd and TraceVarProc are in trace.test +# The tests for Tcl_WhileObjCmd are in while.test + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test new file mode 100644 index 0000000..5e1fa9a --- /dev/null +++ b/tests/compExpr-old.test @@ -0,0 +1,687 @@ +# Commands covered: expr +# +# This file contains the original set of tests for the compilation (and +# indirectly execution) of Tcl's expr command. A new set of tests covering +# the new implementation are in the files "parseExpr.test and +# "compExpr.test". Sourcing this file into Tcl runs the tests and generates +# output for errors. No output means no errors were found. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: compExpr-old.test,v 1.2 1999/04/16 00:47:24 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { + set gotT1 0 + puts "This application hasn't been compiled with the \"T1\" and" + puts "\"T2\" math functions, so I'll skip some of the expr tests." +} else { + set gotT1 1 +} + +# procedures used below + +proc put_hello_char {c} { + global a + append a [format %c $c] + return $c +} +proc hello_world {} { + global a + set a "" + set L1 [set l0 [set h_1 [set q 0]]] + for {put_hello_char [expr [put_hello_char [expr [set h 7]*10+2]]+29]} {$l0?[put_hello_char $l0] + :!$h_1} {put_hello_char $ll;expr {$L1==2?[set ll [expr 32+0-0+[set bar 0]]]:0}} {expr {[incr L1]==[expr 1+([string length "abc"]-[string length "abc"])] + ?[set ll [set l0 [expr 54<<1]]]:$ll==108&&$L1<3? + [incr ll [expr 1|1<<1]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]; set l0; set l0 $l0; set l0; set l0]:$L1==4&&$ll==32?[set ll [expr 19+$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+[set foo [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]]]] + :[set q [expr $q-$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]};expr {$L1==5?[incr ll -8; set ll $ll; set ll]:$q&&$h1&&1};expr {$L1==4+2 + ?[incr ll 3]:[expr ([string length "abc"]-[string length "abc"])+1]};expr {$ll==($h<<4)+2+0&&$L1!=6?[incr ll -6]:[set h1 [expr 100+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]} + expr {$L1!=1<<3?[incr q [expr ([string length "abc"]-[string length "abc"])-1]]:[set h_1 [set ll $h1]]} + } + set a +} + +proc 12days {a b c} { + global xxx + expr {1<$a?[expr {$a<3?[12days -79 -13 [string range $c [12days -87 \ + [expr 1-$b] [string range $c [12days -86 0 [string range $c 1 end]] \ + end]] end]]:1};expr {$a<$b?[12days [expr $a+1] $b $c]:3};expr {[12days \ + -94 [expr $a-27] $c]&&$a==2?$b<13?[12days 2 [expr $b+1] "%s %d %d\n"]:9 + :16}]:$a<0?$a<-72?[12days $b $a "@n'+,#'/*\{\}w+/w#cdnr/+,\{\}r/*de\}+,/*\{*+,/w\{%+,/w#q#n+,/#\{l+,/n\{n+,/+#n+,/#;#q#n+,/+k#;*+,/'r :'d*'3,\}\{w+K w'K:'+\}e#';dq#'l q#'+d'K#!/+k#;q#'r\}eKK#\}w'r\}eKK\{nl\]'/#;#q#n')\{)#\}w')\{)\{nl\]'/+#n';d\}rw' i;# )\{nl\]!/n\{n#'; r\{#w'r nc\{nl\]'/#\{l,+'K \{rw' iK\{;\[\{nl\]'/w#q#n'wk nw' iwk\{KK\{nl\]!/w\{%'l##w#' i; :\{nl\]'/*\{q#'ld;r'\}\{nlwb!/*de\}'c ;;\{nl'-\{\}rw\]'/+,\}##'*\}#nc,',#nw\]'/+kd'+e\}+;#'rdq#w! nr'/ ') \}+\}\{rl#'\{n' ')# \}'+\}##(!!/"] + :$a<-50?[string compare [format %c $b] [string index $c 0]]==0?[append \ + xxx [string index $c 31];scan [string index $c 31] %c x;set x] + :[12days -65 $b [string range $c 1 end]]:[12days [expr ([string compare \ + [string index $c 0] "/"]==0)+$a] $b [string range $c 1 end]]:0<$a + ?[12days 2 2 "%s"]:[string compare [string index $c 0] "/"]==0|| + [12days 0 [12days -61 [scan [string index $c 0] %c x; set x] \ + "!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \ + [string range $c 1 end]]} +} +proc do_twelve_days {} { + global xxx + set xxx "" + 12days 1 1 1 + string length $xxx +} + +# start of tests + +catch {unset a b i x} + +test expr-1.1 {TclCompileExprCmd: no expression} { + list [catch {expr } msg] $msg +} {1 {wrong # args: should be "expr arg ?arg ...?"}} +test expr-1.2 {TclCompileExprCmd: one expression word} { + expr -25 +} -25 +test expr-1.3 {TclCompileExprCmd: two expression words} { + expr -8.2 -6 +} -14.2 +test expr-1.4 {TclCompileExprCmd: five expression words} { + expr 20 - 5 +10 -7 +} 18 +test expr-1.5 {TclCompileExprCmd: quoted expression word} { + expr "0005" +} 5 +test expr-1.6 {TclCompileExprCmd: quoted expression word} { + catch {expr "0005"zxy} msg + set msg +} {extra characters after close-quote} +test expr-1.7 {TclCompileExprCmd: expression word in braces} { + expr {-0005} +} -5 +test expr-1.8 {TclCompileExprCmd: expression word in braces} { + expr {{-0x1234}} +} -4660 +test expr-1.9 {TclCompileExprCmd: expression word in braces} { + catch {expr {-0005}foo} msg + set msg +} {extra characters after close-brace} +test expr-1.10 {TclCompileExprCmd: other expression word in braces} { + expr 4*[llength "6 2"] +} 8 +test expr-1.11 {TclCompileExprCmd: expression word terminated by ;} { + expr 4*[llength "6 2"]; +} 8 +test expr-1.12 {TclCompileExprCmd: inlined expr (in "catch") inside other catch} { + set a xxx + catch { + # Might not be a number + set a [expr 10*$a] + } +} 1 +test expr-1.13 {TclCompileExprCmd: second level of substitutions in expr not in braces with single var reference} { + set a xxx + set x 27; set bool {$x}; if $bool {set a foo} + set a +} foo +test expr-1.14 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} { + set a xxx + set x 2; set b {$x}; set a [expr $b == 2] + set a +} 1 + +test expr-2.1 {TclCompileExpr: are builtin functions registered?} { + expr double(5*[llength "6 2"]) +} 10.0 +test expr-2.2 {TclCompileExpr: error in expr} { + catch {expr 2**3} msg + set msg +} {syntax error in expression "2**3"} +test expr-2.3 {TclCompileExpr: junk after legal expr} { + catch {expr 7*[llength "a b"]foo} msg + set msg +} {syntax error in expression "7*2foo"} +test expr-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} { + expr {0001} +} 1 + +test expr-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1 +test expr-3.2 {CompileCondExpr: error in lor expr} { + catch {expr x||3} msg + set msg +} {syntax error in expression "x||3"} +test expr-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44 +test expr-3.4 {CompileCondExpr: error compiling true arm} { + catch {expr 3>2?2**3:66} msg + set msg +} {syntax error in expression "3>2?2**3:66"} +test expr-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66 +test expr-3.6 {CompileCondExpr: error compiling false arm} { + catch {expr 2>3?44:2**3} msg + set msg +} {syntax error in expression "2>3?44:2**3"} +test expr-3.7 {CompileCondExpr: long arms & nested cond exprs} {nonPortable} { + puts "Note: doing test expr-3.7 which can take several minutes to run" + hello_world +} {Hello world} +catch {unset xxx} +test expr-3.8 {CompileCondExpr: long arms & nested cond exprs} {nonPortable} { + puts "Note: doing test expr-3.8 which can take several minutes to run" + do_twelve_days +} 2358 +catch {unset xxx} + +test expr-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1 +test expr-4.2 {CompileLorExpr: error in land expr} { + catch {expr x&&3} msg + set msg +} {syntax error in expression "x&&3"} +test expr-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1 +test expr-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1 +test expr-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1 +test expr-4.6 {CompileLorExpr: error compiling lor arm} { + catch {expr 2**3||4.0} msg + set msg +} {syntax error in expression "2**3||4.0"} +test expr-4.7 {CompileLorExpr: error compiling lor arm} { + catch {expr 1.3||2**3} msg + set msg +} {syntax error in expression "1.3||2**3"} +test expr-4.8 {CompileLorExpr: error compiling lor arms} { + list [catch {expr {"a"||"b"}} msg] $msg +} {1 {expected boolean value but got "a"}} +test expr-4.9 {CompileLorExpr: long lor arm} { + set a "abcdefghijkl" + set i 7 + expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} +} 1 + +test expr-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23 +test expr-5.2 {CompileLandExpr: error in bitor expr} { + catch {expr x|3} msg + set msg +} {syntax error in expression "x|3"} +test expr-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0 +test expr-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0 +test expr-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1 +test expr-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1 +test expr-5.7 {CompileLandExpr: error compiling land arm} { + catch {expr 2**3&&4.0} msg + set msg +} {syntax error in expression "2**3&&4.0"} +test expr-5.8 {CompileLandExpr: error compiling land arm} { + catch {expr 1.3&&2**3} msg + set msg +} {syntax error in expression "1.3&&2**3"} +test expr-5.9 {CompileLandExpr: error compiling land arm} { + list [catch {expr {"a"&&"b"}} msg] $msg +} {1 {expected boolean value but got "a"}} +test expr-5.10 {CompileLandExpr: long land arms} { + set a "abcdefghijkl" + set i 7 + expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]} +} 1 + +test expr-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3 +test expr-6.2 {CompileBitXorExpr: error in bitand expr} { + catch {expr x|3} msg + set msg +} {syntax error in expression "x|3"} +test expr-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20 +test expr-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19 +test expr-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7 +test expr-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8 +test expr-6.7 {CompileBitXorExpr: error compiling bitxor arm} { + catch {expr 2**3|6} msg + set msg +} {syntax error in expression "2**3|6"} +test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} { + catch {expr 2^x} msg + set msg +} {syntax error in expression "2^x"} +test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { + list [catch {expr {24.0^3}} msg] $msg +} {1 {can't use floating-point value as operand of "^"}} +test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { + list [catch {expr {"a"^"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "^"}} + +test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 +test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 +test expr-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1 +test expr-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0 +test expr-7.5 {CompileBitAndExpr: error in equality expr} { + catch {expr x==3} msg + set msg +} {syntax error in expression "x==3"} +test expr-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3 +test expr-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82 +test expr-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2 +test expr-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7 +test expr-7.10 {CompileBitAndExpr: error compiling bitand arm} { + catch {expr 2**3&6} msg + set msg +} {syntax error in expression "2**3&6"} +test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} { + catch {expr 2&x} msg + set msg +} {syntax error in expression "2&x"} +test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} { + list [catch {expr {24.0&3}} msg] $msg +} {1 {can't use floating-point value as operand of "&"}} +test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} { + list [catch {expr {"a"&"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "&"}} + +test expr-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1 +test expr-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1 +test expr-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1 +test expr-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0 +test expr-8.5 {CompileEqualityExpr: error in relational expr} { + catch {expr x>3} msg + set msg +} {syntax error in expression "x>3"} +test expr-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0 +test expr-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1 +test expr-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1 +test expr-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1 +test expr-8.10 {CompileEqualityExpr: error compiling equality arm} { + catch {expr 2**3==6} msg + set msg +} {syntax error in expression "2**3==6"} +test expr-8.11 {CompileEqualityExpr: error compiling equality arm} { + catch {expr 2!=x} msg + set msg +} {syntax error in expression "2!=x"} + + +test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 +test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 +test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 +test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 + +# The following test is different for 32-bit versus 64-bit +# architectures because LONG_MIN is different + +if {0x80000000 > 0} { + test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} { + expr {1<<63} + } -9223372036854775808 +} else { + test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} { + expr {1<<31} + } -2147483648 +} +test expr-9.6 {CompileRelationalExpr: error in shift expr} { + catch {expr x>>3} msg + set msg +} {syntax error in expression "x>>3"} +test expr-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1 +test expr-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1 +test expr-9.9 {CompileRelationalExpr: error compiling relational arm} { + catch {expr 2**3>6} msg + set msg +} {syntax error in expression "2**3>6"} +test expr-9.10 {CompileRelationalExpr: error compiling relational arm} { + catch {expr 2<x} msg + set msg +} {syntax error in expression "2<x"} + +test expr-10.1 {CompileShiftExpr: just add expr} {expr 4+-2} 2 +test expr-10.2 {CompileShiftExpr: just add expr} {expr 0xff-2} 253 +test expr-10.3 {CompileShiftExpr: just add expr} {expr -1--2} 1 +test expr-10.4 {CompileShiftExpr: just add expr} {expr 1-0123} -82 +test expr-10.5 {CompileShiftExpr: error in add expr} { + catch {expr x+3} msg + set msg +} {syntax error in expression "x+3"} +test expr-10.6 {CompileShiftExpr: simple shift exprs} {expr 0xff>>0x3} 31 +test expr-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936 +test expr-10.8 {CompileShiftExpr: error compiling shift arm} { + catch {expr 2**3>>6} msg + set msg +} {syntax error in expression "2**3>>6"} +test expr-10.9 {CompileShiftExpr: error compiling shift arm} { + catch {expr 2<<x} msg + set msg +} {syntax error in expression "2<<x"} +test expr-10.10 {CompileShiftExpr: runtime error} { + list [catch {expr {24.0>>43}} msg] $msg +} {1 {can't use floating-point value as operand of ">>"}} +test expr-10.11 {CompileShiftExpr: runtime error} { + list [catch {expr {"a"<<"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "<<"}} + +test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 +test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 +test expr-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1 +test expr-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 6 +test expr-11.5 {CompileAddExpr: error in multiply expr} { + catch {expr x*3} msg + set msg +} {syntax error in expression "x*3"} +test expr-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258 +test expr-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239 +test expr-11.8 {CompileAddExpr: error compiling add arm} { + catch {expr 2**3+6} msg + set msg +} {syntax error in expression "2**3+6"} +test expr-11.9 {CompileAddExpr: error compiling add arm} { + catch {expr 2-x} msg + set msg +} {syntax error in expression "2-x"} +test expr-11.10 {CompileAddExpr: runtime error} { + list [catch {expr {24.0+"xx"}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-11.11 {CompileAddExpr: runtime error} { + list [catch {expr {"a"-"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "-"}} +test expr-11.12 {CompileAddExpr: runtime error} { + list [catch {expr {3/0}} msg] $msg +} {1 {divide by zero}} +test expr-11.13 {CompileAddExpr: runtime error} { + list [catch {expr {2.3/0.0}} msg] $msg +} {1 {divide by zero}} + +test expr-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5 +test expr-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5 +test expr-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0 +test expr-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936 +test expr-12.5 {CompileMultiplyExpr: error in unary expr} { + catch {expr ~x} msg + set msg +} {syntax error in expression "~x"} +test expr-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765 +test expr-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2 +test expr-12.8 {CompileMultiplyExpr: error compiling multiply arm} { + catch {expr 2*3%%6} msg + set msg +} {syntax error in expression "2*3%%6"} +test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} { + catch {expr 2*x} msg + set msg +} {syntax error in expression "2*x"} +test expr-12.10 {CompileMultiplyExpr: runtime error} { + list [catch {expr {24.0*"xx"}} msg] $msg +} {1 {can't use non-numeric string as operand of "*"}} +test expr-12.11 {CompileMultiplyExpr: runtime error} { + list [catch {expr {"a"/"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "/"}} + +test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 +test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +000123} 83 +test expr-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36 +test expr-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0 +test expr-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0 +test expr-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1 +test expr-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0 +test expr-13.8 {CompileUnaryExpr: error compiling unary expr} { + catch {expr ~x} msg + set msg +} {syntax error in expression "~x"} +test expr-13.9 {CompileUnaryExpr: error compiling unary expr} { + catch {expr !1.x} msg + set msg +} {syntax error in expression "!1.x"} +test expr-13.10 {CompileUnaryExpr: runtime error} { + list [catch {expr {~"xx"}} msg] $msg +} {1 {can't use non-numeric string as operand of "~"}} +test expr-13.11 {CompileUnaryExpr: runtime error} { + list [catch {expr ~4.0} msg] $msg +} {1 {can't use floating-point value as operand of "~"}} +test expr-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291 +test expr-13.13 {CompileUnaryExpr: just primary expr} { + set a 27 + expr $a +} 27 +test expr-13.14 {CompileUnaryExpr: just primary expr} { + expr double(27) +} 27.0 +test expr-13.15 {CompileUnaryExpr: just primary expr} {expr "123"} 123 +test expr-13.16 {CompileUnaryExpr: error in primary expr} { + catch {expr [set]} msg + set msg +} {wrong # args: should be "set varName ?newValue?"} +test expr-14.1 {CompilePrimaryExpr: literal primary} {expr 1} 1 +test expr-14.2 {CompilePrimaryExpr: literal primary} {expr 123} 123 +test expr-14.3 {CompilePrimaryExpr: literal primary} {expr 0xff} 255 +test expr-14.4 {CompilePrimaryExpr: literal primary} {expr 00010} 8 +test expr-14.5 {CompilePrimaryExpr: literal primary} {expr 62.0} 62.0 +test expr-14.6 {CompilePrimaryExpr: literal primary} { + expr 3.1400000 +} 3.14 +test expr-14.7 {CompilePrimaryExpr: literal primary} {expr {{abcde}<{abcdef}}} 1 +test expr-14.8 {CompilePrimaryExpr: literal primary} {expr {{abc\ +def} < {abcdef}}} 1 +test expr-14.9 {CompilePrimaryExpr: literal primary} {expr {{abc\tde} > {abc\tdef}}} 0 +test expr-14.10 {CompilePrimaryExpr: literal primary} {expr {{123}}} 123 +test expr-14.11 {CompilePrimaryExpr: var reference primary} { + set i 789 + list [expr {$i}] [expr $i] +} {789 789} +test expr-14.12 {CompilePrimaryExpr: var reference primary} { + set i {789} ;# test expr's aggressive conversion to numeric semantics + list [expr {$i}] [expr $i] +} {789 789} +test expr-14.13 {CompilePrimaryExpr: var reference primary} { + catch {unset a} + set a(foo) foo + set a(bar) bar + set a(123) 123 + set result "" + lappend result [expr $a(123)] [expr {$a(bar)<$a(foo)}] + catch {unset a} + set result +} {123 1} +test expr-14.14 {CompilePrimaryExpr: var reference primary} { + set i 123 ;# test "$var.0" floating point conversion hack + list [expr $i] [expr $i.0] [expr $i.0/12.0] +} {123 123.0 10.25} +test expr-14.15 {CompilePrimaryExpr: var reference primary} { + set i 123 + catch {expr $i.2} msg + set msg +} 123.2 +test expr-14.16 {CompilePrimaryExpr: error compiling var reference primary} { + catch {expr {$a(foo}} msg + set errorInfo +} {missing ) + while compiling +"expr {$a(foo}"} +test expr-14.17 {CompilePrimaryExpr: string primary that looks like var ref} { + expr $ +} $ +test expr-14.18 {CompilePrimaryExpr: quoted string primary} { + expr "21" +} 21 +test expr-14.19 {CompilePrimaryExpr: quoted string primary} { + set i 123 + set x 456 + expr "$i+$x" +} 579 +test expr-14.20 {CompilePrimaryExpr: quoted string primary} { + set i 3 + set x 6 + expr 2+"$i.$x" +} 5.6 +test expr-14.21 {CompilePrimaryExpr: error in quoted string primary} { + catch {expr "[set]"} msg + set msg +} {wrong # args: should be "set varName ?newValue?"} +test expr-14.22 {CompilePrimaryExpr: subcommand primary} { + expr {[set i 123; set i]} +} 123 +test expr-14.23 {CompilePrimaryExpr: error in subcommand primary} { + catch {expr {[set]}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + while compiling +"expr {[set]}"} +test expr-14.24 {CompilePrimaryExpr: error in subcommand primary} { + catch {expr {[set i}} msg + set errorInfo +} {missing close-bracket + while compiling +"expr {[set i}"} +test expr-14.25 {CompilePrimaryExpr: math function primary} { + format %.6g [expr exp(1.0)] +} 2.71828 +test expr-14.26 {CompilePrimaryExpr: math function primary} { + format %.6g [expr pow(2.0+0.1,3.0+0.1)] +} 9.97424 +test expr-14.27 {CompilePrimaryExpr: error in math function primary} { + catch {expr sinh::(2.0)} msg + set errorInfo +} {syntax error in expression "sinh::(2.0)" + while compiling +"expr sinh::(2.0)"} +test expr-14.28 {CompilePrimaryExpr: subexpression primary} { + expr 2+(3*4) +} 14 +test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} { + catch {expr 2+(3*[set])} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + while compiling +"expr 2+(3*[set])"} +test expr-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} { + catch {expr 2+(3*(4+5)} msg + set errorInfo +} {syntax error in expression "2+(3*(4+5)" + while compiling +"expr 2+(3*(4+5)"} +test expr-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} { + set i "5+10" + list "[expr $i] == 15" "[expr ($i)] == 15" "[eval expr ($i)] == 15" +} {{15 == 15} {15 == 15} {15 == 15}} +test expr-14.32 {CompilePrimaryExpr: unexpected token} { + catch {expr @} msg + set errorInfo +} {syntax error in expression "@" + while compiling +"expr @"} + +test expr-15.1 {CompileMathFuncCall: missing parenthesis} { + catch {expr sinh2.0)} msg + set errorInfo +} {syntax error in expression "sinh2.0)" + while compiling +"expr sinh2.0)"} +test expr-15.2 {CompileMathFuncCall: unknown math function} { + catch {expr whazzathuh(1)} msg + set errorInfo +} {unknown math function "whazzathuh" + while compiling +"expr whazzathuh(1)"} +test expr-15.3 {CompileMathFuncCall: too many arguments} { + catch {expr sin(1,2,3)} msg + set errorInfo +} {too many arguments for math function + while compiling +"expr sin(1,2,3)"} +test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} { + catch {expr sin()} msg + set errorInfo +} {too few arguments for math function + while compiling +"expr sin()"} +test expr-15.5 {CompileMathFuncCall: too few arguments} { + catch {expr pow(1)} msg + set errorInfo +} {too few arguments for math function + while compiling +"expr pow(1)"} +test expr-15.6 {CompileMathFuncCall: missing ')'} { + catch {expr sin(1} msg + set errorInfo +} {syntax error in expression "sin(1" + while compiling +"expr sin(1"} +if $gotT1 { + test expr-15.7 {CompileMathFuncCall: call registered math function} { + expr 2*T1() + } 246 + test expr-15.8 {CompileMathFuncCall: call registered math function} { + expr T2()*3 + } 1035 + + test expr-15.9 {CompileMathFuncCall: call registered math function} { + expr T3(21, 37) + } 37 + test expr-15.10 {CompileMathFuncCall: call registered math function} { + expr T3(21.2, 37) + } 37.0 + test expr-15.11 {CompileMathFuncCall: call registered math function} { + expr T3(-21.2, -17.5) + } -17.5 +} + +test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { + catch {unset a} + set a(VALUE) ff15 + set i 123 + if {[expr 0x$a(VALUE)] & 16} { + set i {} + } + set i +} {} +test expr-16.2 {GetToken: check for string literal in braces} { + expr {{1}} +} {1} + +# Check "expr" and computed command names. + +test expr-17.1 {expr and computed command names} { + set i 0 + set z expr + $z 1+2 +} 3 + +# Check correct conversion of operands to numbers: If the string looks like +# an integer, convert to integer. Otherwise, if the string looks like a +# double, convert to double. + +test expr-18.1 {expr and conversion of operands to numbers} { + set x [lindex 11 0] + catch {expr int($x)} + expr {$x} +} 11 + +# Check "expr" and interpreter result object resetting before appending +# an error msg during evaluation of exprs not in {}s + +test expr-19.1 {expr and interpreter result object resetting} { + proc p {} { + set t 10.0 + set x 2.0 + set dx 0.2 + set f {$dx-$x/10} + set g {-$x/5} + set center 1.0 + set x [expr $x-$center] + set dx [expr $dx+$g] + set x [expr $x+$f+$center] + set x [expr $x+$f+$center] + set y [expr round($x)] + } + p +} 3 + +# cleanup +unset a +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/compExpr.test b/tests/compExpr.test new file mode 100644 index 0000000..17728b9 --- /dev/null +++ b/tests/compExpr.test @@ -0,0 +1,340 @@ +# This file contains a collection of tests for the procedures in the +# file tclCompExpr.c. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: compExpr.test,v 1.2 1999/04/16 00:47:25 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { + set gotT1 0 + puts "This application hasn't been compiled with the \"T1\" and" + puts "\"T2\" math functions, so I'll skip some of the expr tests." +} else { + set gotT1 1 +} + +catch {unset a} + +test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} { + expr 1+2 +} 3 +test compExpr-1.2 {TclCompileExpr procedure, error parsing expr} { + list [catch {expr 1+2+} msg] $msg +} {1 {syntax error in expression "1+2+"}} +test compExpr-1.3 {TclCompileExpr procedure, error compiling expr} { + list [catch {expr "foo(123)"} msg] $msg +} {1 {unknown math function "foo"}} +test compExpr-1.4 {TclCompileExpr procedure, expr has no operators} { + set a {000123} + expr {$a} +} 83 + +test compExpr-2.1 {CompileSubExpr procedure, TCL_TOKEN_WORD parse token} { + catch {unset a} + set a 27 + expr {"foo$a" < "bar"} +} 0 +test compExpr-2.2 {CompileSubExpr procedure, error compiling TCL_TOKEN_WORD parse token} { + list [catch {expr {"00[expr 1+]" + 17}} msg] $msg +} {1 {syntax error in expression "1+"}} +test compExpr-2.3 {CompileSubExpr procedure, TCL_TOKEN_TEXT parse token} { + expr {{12345}} +} 12345 +test compExpr-2.4 {CompileSubExpr procedure, empty TCL_TOKEN_TEXT parse token} { + expr {{}} +} {} +test compExpr-2.5 {CompileSubExpr procedure, TCL_TOKEN_BS parse token} { + expr "\{ \\ + +123 \}" +} 123 +test compExpr-2.6 {CompileSubExpr procedure, TCL_TOKEN_COMMAND parse token} { + expr {[info tclversion] != ""} +} 1 +test compExpr-2.7 {CompileSubExpr procedure, TCL_TOKEN_COMMAND parse token} { + expr {[]} +} {} +test compExpr-2.8 {CompileSubExpr procedure, error in TCL_TOKEN_COMMAND parse token} { + list [catch {expr {[foo "bar"xxx] + 17}} msg] $msg +} {1 {extra characters after close-quote}} +test compExpr-2.9 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} { + catch {unset a} + set a 123 + expr {$a*2} +} 246 +test compExpr-2.10 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} { + catch {unset a} + catch {unset b} + set a(george) martha + set b geo + expr {$a(${b}rge)} +} martha +test compExpr-2.11 {CompileSubExpr procedure, error in TCL_TOKEN_VARIABLE parse token} { + catch {unset a} + list [catch {expr {$a + 17}} msg] $msg +} {1 {can't read "a": no such variable}} +test compExpr-2.12 {CompileSubExpr procedure, TCL_TOKEN_SUB_EXPR parse token} { + expr {27||3? 3<<(1+4) : 4&&9} +} 96 +test compExpr-2.13 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} { + catch {unset a} + set a 15 + list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg +} {1 {syntax error in expression "1+"}} +test compExpr-2.14 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, op found} { + expr {5*6} +} 30 +test compExpr-2.15 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function found} { + format %.6g [expr {sin(2.0)}] +} 0.909297 +test compExpr-2.16 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function not found} { + list [catch {expr {fred(2.0)}} msg] $msg +} {1 {unknown math function "fred"}} +test compExpr-2.17 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4*2} +} 8 +test compExpr-2.18 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4/2} +} 2 +test compExpr-2.19 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4%2} +} 0 +test compExpr-2.20 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4<<2} +} 16 +test compExpr-2.21 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4>>2} +} 1 +test compExpr-2.22 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4<2} +} 0 +test compExpr-2.23 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4>2} +} 1 +test compExpr-2.24 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4<=2} +} 0 +test compExpr-2.25 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4>=2} +} 1 +test compExpr-2.26 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4==2} +} 0 +test compExpr-2.27 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4!=2} +} 1 +test compExpr-2.28 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4&2} +} 0 +test compExpr-2.29 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4^2} +} 6 +test compExpr-2.30 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { + expr {4|2} +} 6 +test compExpr-2.31 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, 1 operand} { + expr {!4} +} 0 +test compExpr-2.32 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, 1 operand} { + expr {~4} +} -5 +test compExpr-2.33 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, comparison} { + catch {unset a} + set a 15 + expr {$a==15} ;# compiled out-of-line to runtime call on Tcl_ExprObjCmd +} 1 +test compExpr-2.34 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { + expr {+2} +} 2 +test compExpr-2.35 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, error in special operator} { + list [catch {expr {+[expr 1+]}} msg] $msg +} {1 {syntax error in expression "1+"}} +test compExpr-2.36 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { + expr {4+2} +} 6 +test compExpr-2.37 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, error in special operator} { + list [catch {expr {[expr 1+]+5}} msg] $msg +} {1 {syntax error in expression "1+"}} +test compExpr-2.38 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, error in special operator} { + list [catch {expr {5+[expr 1+]}} msg] $msg +} {1 {syntax error in expression "1+"}} +test compExpr-2.39 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { + expr {-2} +} -2 +test compExpr-2.40 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { + expr {4-2} +} 2 +test compExpr-2.41 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { + catch {unset a} + set a true + expr {0||$a} +} 1 +test compExpr-2.42 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} { + catch {unset a} + set a 15 + list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg +} {1 {syntax error in expression "1+"}} +test compExpr-2.43 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { + catch {unset a} + set a false + expr {3&&$a} +} 0 +test compExpr-2.44 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { + catch {unset a} + set a false + expr {$a||1? 1 : 0} +} 1 +test compExpr-2.45 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} { + catch {unset a} + set a 15 + list [catch {expr {1? 54 : "$a[expr 1+]00"}} msg] $msg +} {1 {syntax error in expression "1+"}} + +test compExpr-3.1 {CompileLandOrLorExpr procedure, numeric 1st operand} { + catch {unset a} + set a 2 + expr {[set a]||0} +} 1 +test compExpr-3.2 {CompileLandOrLorExpr procedure, nonnumeric 1st operand} { + catch {unset a} + set a no + expr {$a&&1} +} 0 +test compExpr-3.3 {CompileSubExpr procedure, error in 1st operand} { + list [catch {expr {[expr *2]||0}} msg] $msg +} {1 {syntax error in expression "*2"}} +test compExpr-3.4 {CompileLandOrLorExpr procedure, result is 1 or 0} { + catch {unset a} + catch {unset b} + set a no + set b true + expr {$a || $b} +} 1 +test compExpr-3.5 {CompileLandOrLorExpr procedure, short-circuit semantics} { + catch {unset a} + set a yes + expr {$a || [exit]} +} 1 +test compExpr-3.6 {CompileLandOrLorExpr procedure, short-circuit semantics} { + catch {unset a} + set a no + expr {$a && [exit]} +} 0 +test compExpr-3.7 {CompileLandOrLorExpr procedure, numeric 2nd operand} { + catch {unset a} + set a 2 + expr {0||[set a]} +} 1 +test compExpr-3.8 {CompileLandOrLorExpr procedure, nonnumeric 2nd operand} { + catch {unset a} + set a no + expr {1&&$a} +} 0 +test compExpr-3.9 {CompileLandOrLorExpr procedure, error in 2nd operand} { + list [catch {expr {0||[expr %2]}} msg] $msg +} {1 {syntax error in expression "%2"}} +test compExpr-3.10 {CompileLandOrLorExpr procedure, long lor/land arm} { + set a "abcdefghijkl" + set i 7 + expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} +} 1 + +test compExpr-4.1 {CompileCondExpr procedure, simple test} { + catch {unset a} + set a 2 + expr {($a > 1)? "ok" : "nope"} +} ok +test compExpr-4.2 {CompileCondExpr procedure, complex test, convert to numeric} { + catch {unset a} + set a no + expr {[set a]? 27 : -54} +} -54 +test compExpr-4.3 {CompileCondExpr procedure, error in test} { + list [catch {expr {[expr *2]? +1 : -1}} msg] $msg +} {1 {syntax error in expression "*2"}} +test compExpr-4.4 {CompileCondExpr procedure, simple "true" clause} { + catch {unset a} + set a no + expr {1? (27-2) : -54} +} 25 +test compExpr-4.5 {CompileCondExpr procedure, convert "true" clause to numeric} { + catch {unset a} + set a no + expr {1? $a : -54} +} no +test compExpr-4.6 {CompileCondExpr procedure, error in "true" clause} { + list [catch {expr {1? [expr *2] : -127}} msg] $msg +} {1 {syntax error in expression "*2"}} +test compExpr-4.7 {CompileCondExpr procedure, simple "false" clause} { + catch {unset a} + set a no + expr {(2-2)? -3.14159 : "nope"} +} nope +test compExpr-4.8 {CompileCondExpr procedure, convert "false" clause to numeric} { + catch {unset a} + set a 00123 + expr {0? 42 : $a} +} 83 +test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} { + list [catch {expr {1? 15 : [expr *2]}} msg] $msg +} {1 {syntax error in expression "*2"}} + +test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { + format %.6g [expr atan2(1.0, 2.0)] +} 0.463648 +test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} { + list [catch {expr {do_it()}} msg] $msg +} {1 {unknown math function "do_it"}} +if $gotT1 { + test compExpr-5.3 {CompileMathFuncCall: call registered math function} { + expr 3*T1()-1 + } 368 + test compExpr-5.4 {CompileMathFuncCall: call registered math function} { + expr T2()*3 + } 1035 +} +test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} { + list [catch {expr {atan2(1.0)}} msg] $msg +} {1 {too few arguments for math function}} +test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} { + format %.6g [expr pow(2.1, 27.5-(24.4*(5%2)))] +} 9.97424 +test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} { + list [catch {expr {sinh(2.*)}} msg] $msg +} {1 {syntax error in expression "sinh(2.*)"}} +test compExpr-5.8 {CompileMathFuncCall procedure, too many arguments} { + list [catch {expr {sinh(2.0, 3.0)}} msg] $msg +} {1 {too many arguments for math function}} +test compExpr-5.9 {CompileMathFuncCall procedure, too many arguments} { + list [catch {expr {0 <= rand(5.2)}} msg] $msg +} {1 {too many arguments for math function}} + +test compExpr-6.1 {LogSyntaxError procedure, error in expr longer than 60 chars} { + list [catch {expr {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1 foo 3} msg] $msg +} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012"}} + +# cleanup +catch {unset a} +catch {unset b} +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/compile.test b/tests/compile.test index 14f8864..382e85e 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -5,13 +5,16 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: compile.test,v 1.5 1999/02/02 22:26:12 stanton Exp $ +# RCS: @(#) $Id: compile.test,v 1.6 1999/04/16 00:47:25 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # The following tests are very incomplete, although the rest of the # test suite covers this file fairly well. @@ -69,6 +72,15 @@ test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} { list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] } {1 1 1} +test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} { + catch {unset a} + set a(1) xyzzyx + proc p {} { + global a + catch {set x 123} a(1) + } + list [p] $a(1) +} {0 123} test compile-3.2 {TclCompileCatchCmd: non-local variables} { set ::foo 1 proc catch-test {} { @@ -78,8 +90,7 @@ test compile-3.2 {TclCompileCatchCmd: non-local variables} { set ::foo } 3 - -test compile-1.16 {TclCompileForCmd: command substituted test expression} { +test compile-4.1 {TclCompileForCmd: command substituted test expression} { set i 0 set j 0 # Should be "forever" @@ -90,7 +101,7 @@ test compile-1.16 {TclCompileForCmd: command substituted test expression} { set j } {4} -test compile-3.1 {TclCompileForeachCmd: exception stack} { +test compile-5.1 {TclCompileForeachCmd: exception stack} { proc foreach-exception-test {} { foreach array(index) [list 1 2 3] break foreach array(index) [list 1 2 3] break @@ -98,7 +109,7 @@ test compile-3.1 {TclCompileForeachCmd: exception stack} { } list [catch foreach-exception-test result] $result } {0 {}} -test compile-3.2 {TclCompileForeachCmd: non-local variables} { +test compile-5.2 {TclCompileForeachCmd: non-local variables} { set ::foo 1 proc foreach-test {} { foreach ::foo {1 2 3} {} @@ -107,7 +118,7 @@ test compile-3.2 {TclCompileForeachCmd: non-local variables} { set ::foo } 3 -test compile-4.1 {TclCompileSetCmd: global scalar names with ::s} { +test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} { catch {unset x} catch {unset y} set x 123 @@ -118,7 +129,7 @@ test compile-4.1 {TclCompileSetCmd: global scalar names with ::s} { list $::x [expr {[lsearch -exact [info globals] x] != 0}] \ [p] $::y [expr {[lsearch -exact [info globals] y] != 0}] } {123 1 789 789 1} -test compile-4.2 {TclCompileSetCmd: global array names with ::s} { +test compile-6.2 {TclCompileSetCmd: global array names with ::s} { catch {unset a} set ::a(1) 2 proc p {} { @@ -127,7 +138,7 @@ test compile-4.2 {TclCompileSetCmd: global array names with ::s} { } list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] } {2 1 3 3 1} -test compile-4.3 {TclCompileSetCmd: namespace var names with ::s} { +test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} { catch {namespace delete test_ns_compile} catch {unset x} namespace eval test_ns_compile { @@ -139,7 +150,7 @@ test compile-4.3 {TclCompileSetCmd: namespace var names with ::s} { list $::x $::test_ns_compile::arr(1) } {hello 123} -test compile-1.15 {TclCompileWhileCmd: command substituted test expression} { +test compile-7.1 {TclCompileWhileCmd: command substituted test expression} { set i 0 set j 0 # Should be "forever" @@ -150,17 +161,17 @@ test compile-1.15 {TclCompileWhileCmd: command substituted test expression} { set j } {4} -test compile-5.1 {CollectArgInfo: binary data} { +test compile-8.1 {CollectArgInfo: binary data} { list [catch "string length \000foo" msg] $msg } {0 4} -test compile-5.2 {CollectArgInfo: binary data} { +test compile-8.2 {CollectArgInfo: binary data} { list [catch "string length foo\000" msg] $msg } {0 4} -test compile-5.3 {CollectArgInfo: handle "]" at end of command properly} { +test compile-8.3 {CollectArgInfo: handle "]" at end of command properly} { set x ] } {]} -test compile-6.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} { +test compile-9.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} { proc p {} { set x {} eval $x @@ -170,7 +181,7 @@ test compile-6.1 {UpdateStringOfByteCode: called for duplicate of compiled empty p } {} -test compile-7.1 {BLACKBOX: exception stack overflow} { +test compile-10.1 {BLACKBOX: exception stack overflow} { set x {{0}} set y 0 while {$y < 100} { @@ -179,10 +190,25 @@ test compile-7.1 {BLACKBOX: exception stack overflow} { } {} + +# cleanup catch {rename p ""} catch {namespace delete test_ns_compile} catch {unset x} catch {unset y} catch {unset a} - +::tcltest::cleanupTests return + + + + + + + + + + + + + diff --git a/tests/concat.test b/tests/concat.test index a0d819d..69a4f21 100644 --- a/tests/concat.test +++ b/tests/concat.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: concat.test,v 1.2 1998/09/14 18:40:08 stanton Exp $ +# RCS: @(#) $Id: concat.test,v 1.3 1999/04/16 00:47:25 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test concat-1.1 {simple concatenation} { concat a b c d e f g @@ -44,3 +47,19 @@ test concat-4.2 {pruning off extra white space} { test concat-4.3 {pruning off extra white space sets length correctly} { llength [concat { {{a}} }] } 1 + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/dcall.test b/tests/dcall.test index 6cd4908..2114071 100644 --- a/tests/dcall.test +++ b/tests/dcall.test @@ -6,20 +6,24 @@ # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: dcall.test,v 1.2 1998/09/14 18:40:08 stanton Exp $ +# RCS: @(#) $Id: dcall.test,v 1.3 1999/04/16 00:47:25 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[info commands testdcall] == {}} { puts "This application hasn't been compiled with the \"testdcall\"" puts "command, so I can't test Tcl_CallWhenDeleted." + ::tcltest::cleanupTests 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} @@ -38,3 +42,19 @@ test dcall-1.5 {deletion callbacks} { test dcall-1.6 {deletion callbacks} { lsort -increasing [testdcall 20 21 22 -21 -22 -20] } {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/defs b/tests/defs deleted file mode 100644 index 21c9458..0000000 --- a/tests/defs +++ /dev/null @@ -1,460 +0,0 @@ -# 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. -# Copyright (c) 1998 by Scriptics Corporation -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: defs,v 1.5 1998/12/04 04:18:20 hershey Exp $ - -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 {[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 we have a broken version of sprintf with respect to the -# "e" format of floating-point numbers. - -set testConfig(eformat) 1 -if {[string compare "[format %g 5e-5]" "5e-05"] != 0} { - set testConfig(eformat) 0 - puts stdout "(will skip tests that depend on the \"e\" format of floating-point numbers)" -} -# Test to see if execed commands such as cat, echo, rm and so forth are -# present on this machine. - -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} { - set ok 0 - foreach test $TESTS { - if {[string match $test $name]} { - set ok 1 - break - } - } - if {!$ok} { - 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} { - 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} { - if {$VERBOSE} { - 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 stdout "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 - } - catch {file delete -force tmp} -} - -if {($tcl_platform(platform) == "windows") && ($testConfig(stdio) == 0)} { - puts stdout "(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 stdout "(will skip tests that use sockets)" -} - - diff --git a/tests/defs.tcl b/tests/defs.tcl new file mode 100644 index 0000000..1e7d8fc --- /dev/null +++ b/tests/defs.tcl @@ -0,0 +1,990 @@ +# defs.tcl -- +# +# This file contains support code for the Tcl/Tk test suite.It is +# 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. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. +# +# RCS: @(#) $Id: defs.tcl,v 1.2 1999/04/16 00:47:26 stanton Exp $ + +# Initialize wish shell +if {[info exists tk_version]} { + tk appname tktest + wm title . tktest +} else { + # Ensure that we have a minimal auto_path so we don't pick up extra junk. + set auto_path [list [info library]] +} + +# create the "tcltest" namespace for all testing variables and procedures +namespace eval tcltest { + set procList [list test cleanupTests dotests saveState restoreState \ + normalizeMsg makeFile removeFile makeDirectory removeDirectory \ + viewFile bytestring set_iso8859_1_locale restore_locale \ + safeFetch] + if {[info exists tk_version]} { + lappend procList setupbg dobg bgReady cleanupbg fixfocus + } + foreach proc $procList { + namespace export $proc + } + + # ::tcltest::verbose defaults to "b" + variable verbose "b" + + # match defaults to the empty list + variable match {} + + # skip defaults to the empty list + variable skip {} + + # Tests should not rely on the current working directory. + # Files that are part of the test suite should be accessed relative to + # ::tcltest::testsDir. + + set originalDir [pwd] + set tDir [file join $originalDir [file dirname [info script]]] + cd $tDir + variable testsDir [pwd] + cd $originalDir + + # Count the number of files tested (0 if all.tcl wasn't called). + # The all.tcl file will set testSingleFile to false, so stats will + # not be printed until all.tcl calls the cleanupTests proc. + # The currentFailure var stores the boolean value of whether the + # current test file has had any failures. The failFiles list + # stores the names of test files that had failures. + + variable numTestFiles 0 + variable testSingleFile true + variable currentFailure false + variable failFiles {} + + # Tests should remove all files they create. The test suite will + # check the current working dir for files created by the tests. + # ::tcltest::filesMade keeps track of such files created using the + # ::tcltest::makeFile and ::tcltest::makeDirectory procedures. + # ::tcltest::filesExisted stores the names of pre-existing files. + + variable filesMade {} + variable filesExisted {} + + # ::tcltest::numTests will store test files as indices and the list + # of files (that should not have been) left behind by the test files. + array set ::tcltest::createdNewFiles {} + + # initialize ::tcltest::numTests array to keep track fo the number of + # tests that pass, fial, and are skipped. + array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0] + + # initialize ::tcltest::skippedBecause array to keep track of + # constraints that kept tests from running + array set ::tcltest::skippedBecause {} +} + +# 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 {} +} + +# ::tcltest::initConfig -- +# +# Check configuration information that will determine which tests +# to run. To do this, create an array ::tcltest::testConfig. Each +# element has a 0 or 1 value. If the element is "true" then tests +# with that constraint will be run, otherwise tests with that constraint +# will be skipped. See the README file for the list of built-in +# constraints defined in this procedure. +# +# Arguments: +# none +# +# Results: +# The ::tcltest::testConfig array is reset to have an index for +# each built-in test constraint. + +proc ::tcltest::initConfig {} { + + global tcl_platform tcl_interactive tk_version + + catch {unset ::tcltest::testConfig} + + # The following trace procedure makes it so that we can safely refer to + # non-existent members of the ::tcltest::testConfig array without causing an + # error. Instead, reading a non-existent member will return 0. This is + # necessary because tests are allowed to use constraint "X" without ensuring + # that ::tcltest::testConfig("X") is defined. + + trace variable ::tcltest::testConfig r ::tcltest::safeFetch + + proc ::tcltest::safeFetch {n1 n2 op} { + if {($n2 != {}) && ([info exists ::tcltest::testConfig($n2)] == 0)} { + set ::tcltest::testConfig($n2) 0 + } + } + + set ::tcltest::testConfig(unixOnly) \ + [expr {$tcl_platform(platform) == "unix"}] + set ::tcltest::testConfig(macOnly) \ + [expr {$tcl_platform(platform) == "macintosh"}] + set ::tcltest::testConfig(pcOnly) \ + [expr {$tcl_platform(platform) == "windows"}] + + set ::tcltest::testConfig(unix) $::tcltest::testConfig(unixOnly) + set ::tcltest::testConfig(mac) $::tcltest::testConfig(macOnly) + set ::tcltest::testConfig(pc) $::tcltest::testConfig(pcOnly) + + set ::tcltest::testConfig(unixOrPc) \ + [expr {$::tcltest::testConfig(unix) || $::tcltest::testConfig(pc)}] + set ::tcltest::testConfig(macOrPc) \ + [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(pc)}] + set ::tcltest::testConfig(macOrUnix) \ + [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(unix)}] + + set ::tcltest::testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}] + set ::tcltest::testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}] + + # The following config switches are used to mark tests that should work, + # but have been temporarily disabled on certain platforms because they don't + # and we haven't gotten around to fixing the underlying problem. + + set ::tcltest::testConfig(tempNotPc) [expr {!$::tcltest::testConfig(pc)}] + set ::tcltest::testConfig(tempNotMac) [expr {!$::tcltest::testConfig(mac)}] + set ::tcltest::testConfig(tempNotUnix) [expr {!$::tcltest::testConfig(unix)}] + + # The following config switches are used to mark tests that crash on + # certain platforms, so that they can be reactivated again when the + # underlying problem is fixed. + + set ::tcltest::testConfig(pcCrash) [expr {!$::tcltest::testConfig(pc)}] + set ::tcltest::testConfig(macCrash) [expr {!$::tcltest::testConfig(mac)}] + set ::tcltest::testConfig(unixCrash) [expr {!$::tcltest::testConfig(unix)}] + + # Set the "fonts" constraint for wish apps + if {[info exists tk_version]} { + set ::tcltest::testConfig(fonts) 1 + catch {destroy .e} + entry .e -width 0 -font {Helvetica -12} -bd 1 + .e insert end "a.bcd" + if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} { + set ::tcltest::testConfig(fonts) 0 + } + destroy .e + catch {destroy .t} + text .t -width 80 -height 20 -font {Times -14} -bd 1 + pack .t + .t insert end "This is\na dot." + update + set x [list [.t bbox 1.3] [.t bbox 2.5]] + destroy .t + if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} { + set ::tcltest::testConfig(fonts) 0 + } + } + + # Skip empty tests + set ::tcltest::testConfig(emptyTest) 0 + + # By default, tests that expost known bugs are skipped. + set ::tcltest::testConfig(knownBug) 0 + + # By default, non-portable tests are skipped. + set ::tcltest::testConfig(nonPortable) 0 + + # Some tests require user interaction. + set ::tcltest::testConfig(userInteraction) 0 + + # Some tests must be skipped if the interpreter is not in interactive mode + set ::tcltest::testConfig(interactive) $tcl_interactive + + # Some tests must be skipped if you are running as root on Unix. + # Other tests can only be run if you are running as root on Unix. + set ::tcltest::testConfig(root) 0 + set ::tcltest::testConfig(notRoot) 1 + set user {} + if {$tcl_platform(platform) == "unix"} { + catch {set user [exec whoami]} + if {$user == ""} { + catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} + } + if {($user == "root") || ($user == "")} { + set ::tcltest::testConfig(root) 1 + set ::tcltest::testConfig(notRoot) 0 + } + } + + # Set nonBlockFiles constraint: 1 means this platform supports + # setting files into nonblocking mode. + if {[catch {set f [open defs r]}]} { + set ::tcltest::testConfig(nonBlockFiles) 1 + } else { + if {[catch {fconfigure $f -blocking off}] == 0} { + set ::tcltest::testConfig(nonBlockFiles) 1 + } else { + set ::tcltest::testConfig(nonBlockFiles) 0 + } + close $f + } + + # Set asyncPipeClose constraint: 1 means this platform supports + # async flush and async close on a pipe. + # + # 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 ::tcltest::testConfig(asyncPipeClose) 0 + } else { + set ::tcltest::testConfig(asyncPipeClose) 1 + } + } else { + set ::tcltest::testConfig(asyncPipeClose) 1 + } + + # Test to see if we have a broken version of sprintf with respect + # to the "e" format of floating-point numbers. + set ::tcltest::testConfig(eformat) 1 + if {[string compare "[format %g 5e-5]" "5e-05"] != 0} { + set ::tcltest::testConfig(eformat) 0 + } + + # Test to see if execed commands such as cat, echo, rm and so forth are + # present on this machine. + set ::tcltest::testConfig(unixExecs) 1 + if {$tcl_platform(platform) == "macintosh"} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ($tcl_platform(platform) == "windows")} { + if {[catch {exec cat defs}] == 1} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec echo hello}] == 1)} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec sh -c echo hello}] == 1)} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec wc defs}] == 1)} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {$::tcltest::testConfig(unixExecs) == 1} { + exec echo hello > removeMe + if {[catch {exec rm removeMe}] == 1} { + set ::tcltest::testConfig(unixExecs) 0 + } + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec sleep 1}] == 1)} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec fgrep unixExecs defs}] == 1)} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec ps}] == 1)} { + set ::tcltest::testConfig(unixExecs) 0 + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec echo abc > removeMe}] == 0) && \ + ([catch {exec chmod 644 removeMe}] == 1) && \ + ([catch {exec rm removeMe}] == 0)} { + set ::tcltest::testConfig(unixExecs) 0 + } else { + catch {exec rm -f removeMe} + } + if {($::tcltest::testConfig(unixExecs) == 1) && \ + ([catch {exec mkdir removeMe}] == 1)} { + set ::tcltest::testConfig(unixExecs) 0 + } else { + catch {exec rm -r removeMe} + } + } +} + +::tcltest::initConfig + + +# ::tcltest::processCmdLineArgs -- +# +# Use command line args to set the verbose, skip, and +# match variables. This procedure must be run after +# constraints are initialized, because some constraints can be +# overridden. +# +# Arguments: +# none +# +# Results: +# ::tcltest::verbose is set to <value> + +proc ::tcltest::processCmdLineArgs {} { + global argv + + # The "argv" var doesn't exist in some cases, so use {} + # The "argv" var doesn't exist in some cases. + if {(![info exists argv]) || ([llength $argv] < 2)} { + set flagArray {} + } else { + set flagArray $argv + } + + if {[catch {array set flag $flagArray}]} { + puts stderr "Error: odd number of command line args specified:" + puts stderr " $argv" + exit + } + + # Allow for 1-char abbreviations, where applicable (e.g., -match == -m). + # Note that -verbose cannot be abbreviated to -v in wish because it + # conflicts with the wish option -visual. + foreach arg {-verbose -match -skip -constraints} { + set abbrev [string range $arg 0 1] + if {([info exists flag($abbrev)]) && \ + ([lsearch -exact $flagArray $arg] < \ + [lsearch -exact $flagArray $abbrev])} { + set flag($arg) $flag($abbrev) + } + } + + # Set ::tcltest::workingDir to [pwd]. + # Save the names of files that already exist in ::tcltest::workingDir. + set ::tcltest::workingDir [pwd] + foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] { + lappend ::tcltest::filesExisted [file tail $file] + } + + # Set ::tcltest::verbose to the arg of the -verbose flag, if given + if {[info exists flag(-verbose)]} { + set ::tcltest::verbose $flag(-verbose) + } + + # Set ::tcltest::match to the arg of the -match flag, if given + if {[info exists flag(-match)]} { + set ::tcltest::match $flag(-match) + } + + # Set ::tcltest::skip to the arg of the -skip flag, if given + if {[info exists flag(-skip)]} { + set ::tcltest::skip $flag(-skip) + } + + # Use the -constraints flag, if given, to turn on constraints that are + # turned off by default: userInteractive knownBug nonPortable. This + # code fragment must be run after constraints are initialized. + if {[info exists flag(-constraints)]} { + foreach elt $flag(-constraints) { + set ::tcltest::testConfig($elt) 1 + } + } +} + +::tcltest::processCmdLineArgs + + +# ::tcltest::cleanupTests -- +# +# Remove files and dirs created using the makeFile and makeDirectory +# commands since the last time this proc was invoked. +# +# Print the names of the files created without the makeFile command +# since the tests were invoked. +# +# Print the number tests (total, passed, failed, and skipped) since the +# tests were invoked. +# + +proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { + set tail [file tail [info script]] + + # Remove files and directories created by the :tcltest::makeFile and + # ::tcltest::makeDirectory procedures. + # Record the names of files in ::tcltest::workingDir that were not + # pre-existing, and associate them with the test file that created them. + if {!$calledFromAllFile} { + + foreach file $::tcltest::filesMade { + if {[file exists $file]} { + catch {file delete -force $file} + } + } + set currentFiles {} + foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] { + lappend currentFiles [file tail $file] + } + set newFiles {} + foreach file $currentFiles { + if {[lsearch -exact $::tcltest::filesExisted $file] == -1} { + lappend newFiles $file + } + } + set ::tcltest::filesExisted $currentFiles + if {[llength $newFiles] > 0} { + set ::tcltest::createdNewFiles($tail) $newFiles + } + } + + if {$calledFromAllFile || $::tcltest::testSingleFile} { + # print stats + puts -nonewline stdout "$tail:" + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + puts -nonewline stdout "\t$index\t$::tcltest::numTests($index)" + } + puts stdout "" + + # print number test files sourced + # print names of files that ran tests which failed + if {$calledFromAllFile} { + puts stdout "Sourced $::tcltest::numTestFiles Test Files." + set ::tcltest::numTestFiles 0 + if {[llength $::tcltest::failFiles] > 0} { + puts stdout "Files with failing tests: $::tcltest::failFiles" + set ::tcltest::failFiles {} + } + } + + # if any tests were skipped, print the constraints that kept them + # from running. + set constraintList [array names ::tcltest::skippedBecause] + if {[llength $constraintList] > 0} { + puts stdout "Number of tests skipped for each constraint:" + foreach constraint [lsort $constraintList] { + puts stdout \ + "\t$::tcltest::skippedBecause($constraint)\t$constraint" + unset ::tcltest::skippedBecause($constraint) + } + } + + # report the names of test files in ::tcltest::createdNewFiles, and + # reset the array to be empty. + set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]] + if {[llength $testFilesThatTurded] > 0} { + puts stdout "Warning: test files left files behind:" + foreach testFile $testFilesThatTurded { + puts "\t$testFile:\t$::tcltest::createdNewFiles($testFile)" + unset ::tcltest::createdNewFiles($testFile) + } + } + + # reset filesMade, filesExisted, and numTests + set ::tcltest::filesMade {} + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + set ::tcltest::numTests($index) 0 + } + + # exit only if running Tk in non-interactive mode + global tk_version tcl_interactive + if {[info exists tk_version] && !$tcl_interactive} { + exit + } + } else { + # if we're deferring stat-reporting until all files are sourced, + # then add current file to failFile list if any tests in this file + # failed + incr ::tcltest::numTestFiles + if {($::tcltest::currentFailure) && \ + ([lsearch -exact $::tcltest::failFiles $tail] == -1)} { + lappend ::tcltest::failFiles $tail + } + set ::tcltest::currentFailure false + } +} + + +# test -- +# +# This procedure runs a test and prints an error message if the test fails. +# If ::tcltest::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 +# ::tcltest::match variable, if it matches an element in +# ::tcltest::skip, 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 "::tcltest::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. +# expectedAnswer - Expected result from script. + +proc ::tcltest::test {name description script expectedAnswer args} { + incr ::tcltest::numTests(Total) + + # skip the test if it's name matches an element of skip + foreach pattern $::tcltest::skip { + if {[string match $pattern $name]} { + incr ::tcltest::numTests(Skipped) + return + } + } + # skip the test if it's name doesn't match any element of match + if {[llength $::tcltest::match] > 0} { + set ok 0 + foreach pattern $::tcltest::match { + if {[string match $pattern $name]} { + set ok 1 + break + } + } + if {!$ok} { + incr ::tcltest::numTests(Skipped) + 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 $expectedAnswer + set expectedAnswer [lindex $args 0] + set doTest 0 + if {[string match {*[$\[]*} $constraints] != 0} { + # full expression, e.g. {$foo > [info tclversion]} + + catch {set doTest [uplevel #0 expr $constraints]} + } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { + # something like {a || b} should be turned into + # $::tcltest::testConfig(a) || $::tcltest::testConfig(b). + + regsub -all {[.a-zA-Z0-9]+} $constraints \ + {$::tcltest::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 ::tcltest::testConfig($constraint)] + || !$::tcltest::testConfig($constraint)} { + set doTest 0 + # store the constraint that kept the test from running + set constraints $constraint + break + } + } + } + if {$doTest == 0} { + incr ::tcltest::numTests(Skipped) + if {[string first s $::tcltest::verbose] != -1} { + puts stdout "++++ $name SKIPPED: $constraints" + } + # add the constraint to the list of constraints the kept tests + # from running + if {[info exists ::tcltest::skippedBecause($constraints)]} { + incr ::tcltest::skippedBecause($constraints) + } else { + set ::tcltest::skippedBecause($constraints) 1 + } + return + } + } else { + error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\"" + } + memory tag $name + set code [catch {uplevel $script} actualAnswer] + if {$code != 0 || [string compare $actualAnswer $expectedAnswer] != 0} { + incr ::tcltest::numTests(Failed) + set ::tcltest::currentFailure true + if {[string first b $::tcltest::verbose] == -1} { + set script "" + } + puts stdout "\n==== $name $description FAILED" + if {$script != ""} { + puts stdout "==== Contents of test case:" + puts stdout $script + } + if {$code != 0} { + if {$code == 1} { + puts stdout "==== Test generated error:" + puts stdout $actualAnswer + } elseif {$code == 2} { + puts stdout "==== Test generated return exception; result was:" + puts stdout $actualAnswer + } 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 $actualAnswer + } + } else { + puts stdout "---- Result was:\n$actualAnswer" + } + puts stdout "---- Result should have been:\n$expectedAnswer" + puts stdout "==== $name FAILED\n" + } else { + incr ::tcltest::numTests(Passed) + if {[string first p $::tcltest::verbose] != -1} { + puts stdout "++++ $name PASSED" + } + } +} + +# ::tcltest::dotests -- +# +# 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 ::tcltest::matching to the second argument, calls +# "source" on the file specified in the first argument, and restores +# ::tcltest::matching to its pre-call value at the end. +# +# Arguments: +# file name of tests file to source +# args pattern selecting the tests you want to execute +# +# Results: +# none + +proc ::tcltest::dotests {file args} { + set savedTests $::tcltest::match + set ::tcltest::match $args + source $file + set ::tcltest::match $savedTests +} + +proc ::tcltest::openfiles {} { + if {[catch {testchannel open} result]} { + return {} + } + return $result +} + +proc ::tcltest::leakfiles {old} { + if {[catch {testchannel open} new]} { + return {} + } + set leak {} + foreach p $new { + if {[lsearch $old $p] < 0} { + lappend leak $p + } + } + return $leak +} + +set ::tcltest::saveState {} + +proc ::tcltest::saveState {} { + uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]} +} + +proc ::tcltest::restoreState {} { + foreach p [info procs] { + if {[lsearch [lindex $::tcltest::saveState 0] $p] < 0} { + rename $p {} + } + } + foreach p [uplevel #0 {info vars}] { + if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} { + uplevel #0 "unset $p" + } + } +} + +proc ::tcltest::normalizeMsg {msg} { + regsub "\n$" [string tolower $msg] "" msg + regsub -all "\n\n" $msg "\n" msg + regsub -all "\n\}" $msg "\}" msg + return $msg +} + +# makeFile -- +# +# Create a new file with the name <name>, and write <contents> to it. +# +# If this file hasn't been created via makeFile since the last time +# cleanupTests was called, add it to the $filesMade list, so it will +# be removed by the next call to cleanupTests. +# +proc ::tcltest::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 + + set fullName [file join [pwd] $name] + if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { + lappend ::tcltest::filesMade $fullName + } +} + +proc ::tcltest::removeFile {name} { + file delete $name +} + +# makeDirectory -- +# +# Create a new dir with the name <name>. +# +# If this dir hasn't been created via makeDirectory since the last time +# cleanupTests was called, add it to the $directoriesMade list, so it will +# be removed by the next call to cleanupTests. +# +proc ::tcltest::makeDirectory {name} { + file mkdir $name + + set fullName [file join [pwd] $name] + if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { + lappend ::tcltest::filesMade $fullName + } +} + +proc ::tcltest::removeDirectory {name} { + file delete -force $name +} + +proc ::tcltest::viewFile {name} { + global tcl_platform + if {($tcl_platform(platform) == "macintosh") || \ + ($::tcltest::testConfig(unixExecs) == 0)} { + set f [open $name] + set data [read -nonewline $f] + close $f + return $data + } else { + exec cat $name + } +} + +# +# Construct a string that consists of the requested sequence of bytes, +# as opposed to a string of properly formed UTF-8 characters. +# This allows the tester to +# 1. Create denormalized or improperly formed strings to pass to C procedures +# that are supposed to accept strings with embedded NULL bytes. +# 2. Confirm that a string result has a certain pattern of bytes, for instance +# to confirm that "\xe0\0" in a Tcl script is stored internally in +# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". +# +# Generally, it's a bad idea to examine the bytes in a Tcl string or to +# construct improperly formed strings in this manner, because it involves +# exposing that Tcl uses UTF-8 internally. + +proc ::tcltest::bytestring {string} { + encoding convertfrom identity $string +} + +# Locate tcltest executable + +if {![info exists tk_version]} { + set tcltest [info nameofexecutable] + + if {$tcltest == "{}"} { + set tcltest {} + } +} + +set ::tcltest::testConfig(stdio) 0 +catch { + 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 ::tcltest::testConfig(stdio) 1 +} +catch {file delete -force tmp} + +# Deliberately call the socket with the wrong number of arguments. The error +# message you get will indicate whether sockets are available on this system. +catch {socket} msg +set ::tcltest::testConfig(socket) \ + [expr {$msg != "sockets are not available on this system"}] + +# +# Internationalization / ISO support procs -- dl +# +if {[info commands testlocale]==""} { + # No testlocale command, no tests... + # (it could be that we are a sub interp and we could just load + # the Tcltest package but that would interfere with tests + # that tests packages/loading in slaves...) + set ::tcltest::testConfig(hasIsoLocale) 0 +} else { + proc ::tcltest::set_iso8859_1_locale {} { + set ::tcltest::previousLocale [testlocale ctype] + testlocale ctype $::tcltest::isoLocale + } + + proc ::tcltest::restore_locale {} { + testlocale ctype $::tcltest::previousLocale + } + + if {![info exists ::tcltest::isoLocale]} { + set ::tcltest::isoLocale fr + switch $tcl_platform(platform) { + "unix" { + # Try some 'known' values for some platforms: + switch -exact -- $tcl_platform(os) { + "FreeBSD" { + set ::tcltest::isoLocale fr_FR.ISO_8859-1 + } + HP-UX { + set ::tcltest::isoLocale fr_FR.iso88591 + } + Linux - + IRIX { + set ::tcltest::isoLocale fr + } + default { + # Works on SunOS 4 and Solaris, and maybe others... + # define it to something else on your system + #if you want to test those. + set ::tcltest::isoLocale iso_8859_1 + } + } + } + "windows" { + set ::tcltest::isoLocale French + } + } + } + + set ::tcltest::testConfig(hasIsoLocale) \ + [string length [::tcltest::set_iso8859_1_locale]] + ::tcltest::restore_locale +} + +# +# procedures that are Tk specific +# +if {[info exists tk_version]} { + # If the main window isn't already mapped (e.g. because the tests are + # being run automatically) , specify a precise size for it so that the + # user won't have to position it manually. + + if {![winfo ismapped .]} { + wm geometry . +0+0 + update + } + + # The following code can be used to perform tests involving a second + # process running in the background. + + # Locate the tktest executable + + set ::tcltest::tktest [info nameofexecutable] + if {$::tcltest::tktest == "{}"} { + set ::tcltest::tktest {} + puts stdout \ + "Unable to find tktest executable, skipping multiple process tests." + } + + # Create background process + + proc ::tcltest::setupbg args { + if {$::tcltest::tktest == ""} { + error "you're not running tktest so setupbg should not have been called" + } + if {[info exists ::tcltest::fd] && ($::tcltest::fd != "")} { + cleanupbg + } + + # The following code segment cannot be run on Windows in Tk8.1b2 + # This bug is logged as a pipe bug (bugID 1495). + + global tcl_platform + if {$tcl_platform(platform) != "windows"} { + set ::tcltest::fd [open "|[list $::tcltest::tktest -geometry +0+0 -name tktest] $args" r+] + puts $::tcltest::fd "puts foo; flush stdout" + flush $::tcltest::fd + if {[gets $::tcltest::fd data] < 0} { + error "unexpected EOF from \"$::tcltest::tktest\"" + } + if {[string compare $data foo]} { + error "unexpected output from background process \"$data\"" + } + fileevent $::tcltest::fd readable bgReady + } + } + + # Send a command to the background process, catching errors and + # flushing I/O channels + proc ::tcltest::dobg {command} { + puts $::tcltest::fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout" + flush $::tcltest::fd + set ::tcltest::bgDone 0 + set ::tcltest::bgData {} + tkwait variable ::tcltest::bgDone + set ::tcltest::bgData + } + + # Data arrived from background process. Check for special marker + # indicating end of data for this command, and make data available + # to dobg procedure. + proc ::tcltest::bgReady {} { + set x [gets $::tcltest::fd] + if {[eof $::tcltest::fd]} { + fileevent $::tcltest::fd readable {} + set ::tcltest::bgDone 1 + } elseif {$x == "**DONE**"} { + set ::tcltest::bgDone 1 + } else { + append ::tcltest::bgData $x + } + } + + # Exit the background process, and close the pipes + proc ::tcltest::cleanupbg {} { + catch { + puts $::tcltest::fd "exit" + close $::tcltest::fd + } + set ::tcltest::fd "" + } + + # Clean up focus after using generate event, which + # can leave the window manager with the wrong impression + # about who thinks they have the focus. (BW) + + proc ::tcltest::fixfocus {} { + catch {destroy .focus} + toplevel .focus + wm geometry .focus +0+0 + entry .focus.e + .focus.e insert 0 "fixfocus" + pack .focus.e + update + focus -force .focus.e + destroy .focus + } +} + +# Need to catch the import because it fails if defs.tcl is sourced +# more than once. +catch {namespace import ::tcltest::*} +return diff --git a/tests/dstring.test b/tests/dstring.test index 5b17b7d..e614b97 100644 --- a/tests/dstring.test +++ b/tests/dstring.test @@ -6,20 +6,24 @@ # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: dstring.test,v 1.2 1998/09/14 18:40:08 stanton Exp $ +# RCS: @(#) $Id: dstring.test,v 1.3 1999/04/16 00:47:26 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} 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." + ::tcltest::cleanupTests 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 @@ -245,4 +249,19 @@ test dstring-6.5 {Tcl_DStringGetResult} { lappend result [testdstring get] } {{} {This is a specially-allocated stringz}} +# cleanup testdstring free +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/encoding.test b/tests/encoding.test new file mode 100644 index 0000000..3852749 --- /dev/null +++ b/tests/encoding.test @@ -0,0 +1,316 @@ +# This file contains a collection of tests for tclEncoding.c +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: encoding.test,v 1.2 1999/04/16 00:47:26 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +proc toutf {args} { + global x + lappend x "toutf $args" +} +proc fromutf {args} { + global x + lappend x "fromutf $args" +} + +# Some tests require the testencoding command + +set ::tcltest::testConfig(testencoding) \ + [expr {[info commands testencoding] != {}}] + + +# TclInitEncodingSubsystem is tested by the rest of this file +# TclFinalizeEncodingSubsystem is not currently tested + +test encoding-1.1 {Tcl_GetEncoding: system encoding} {testencoding} { + testencoding create foo toutf fromutf + set old [encoding system] + encoding system foo + set x {} + encoding convertto abcd + encoding system $old + testencoding delete foo + set x +} {{fromutf }} +test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} { + testencoding create foo toutf fromutf + set x {} + encoding convertto foo abcd + testencoding delete foo + set x +} {{fromutf }} +test encoding-1.3 {Tcl_GetEncoding: load encoding} { + list [encoding convertto jis0208 \u4e4e] \ + [encoding convertfrom jis0208 8C] +} "8C \u4e4e" + +test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} { + encoding convertto jis0208 \u4e4e +} {8C} +test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} {testencoding} { + set system [encoding system] + set path [testencoding path] + encoding system jis0208 ;# incr ref count + testencoding path . + set x [encoding convertto jis0208 \u4e4e] ;# old one found + encoding system identity + lappend x [catch {encoding convertto jis0208 \u4e4e} msg] $msg + encoding system identity + testencoding path $path + encoding system $system + set x +} {8C 1 {unknown encoding "jis0208"}} + +test encoding-3.1 {Tcl_GetEncodingName, NULL} { + set old [encoding system] + encoding system jis0208 + set x [encoding system] + encoding system $old + set x +} {jis0208} +test encoding-3.2 {Tcl_GetEncodingName, non-null} { + set old [fconfigure stdout -encoding] + fconfigure stdout -encoding jis0208 + set x [fconfigure stdout -encoding] + fconfigure stdout -encoding $old + set x +} {jis0208} + +test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} { + file mkdir tmp/encoding + close [open tmp/encoding/junk.enc w] + close [open tmp/encoding/junk2.enc w] + cd tmp + set path [testencoding path] + testencoding path {} + catch {unset encodings} + catch {unset x} + foreach encoding [encoding names] { + set encodings($encoding) 1 + } + testencoding path . + foreach encoding [encoding names] { + if {![info exists encodings($encoding)]} { + lappend x $encoding + } + } + testencoding path $path + cd .. + file delete -force tmp + lsort $x +} {junk junk2} + +test encoding-5.1 {Tcl_SetSystemEncoding} { + set old [encoding system] + encoding system jis0208 + set x [encoding convertto \u4e4e] + encoding system identity + encoding system $old + set x +} {8C} +test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} { + set old [encoding system] + encoding system $old + string compare $old [encoding system] +} {0} + +test encoding-6.1 {Tcl_CreateEncoding: new} {testencoding} { + testencoding create foo {toutf 1} {fromutf 2} + set x {} + encoding convertfrom foo abcd + encoding convertto foo abcd + testencoding delete foo + set x +} {{toutf 1} {fromutf 2}} +test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} { + testencoding create foo {toutf a} {fromutf b} + set x {} + encoding convertfrom foo abcd + encoding convertto foo abcd + testencoding delete foo + set x +} {{toutf a} {fromutf b}} + +test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} { + encoding convertfrom jis0208 8c8c8c8c +} "\u543e\u543e\u543e\u543e" +test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} { + set a 8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C + append a $a + append a $a + append a $a + append a $a + set x [encoding convertfrom jis0208 $a] + list [string length $x] [string index $x 0] +} "512 \u4e4e" + +test encoding-8.1 {Tcl_ExternalToUtf} { + set f [open dummy w] + fconfigure $f -translation binary -encoding iso8859-1 + puts -nonewline $f "ab\x8c\xc1g" + close $f + set f [open dummy r] + fconfigure $f -translation binary -encoding shiftjis + set x [read $f] + close $f + file delete dummy + set x +} "ab\u4e4eg" + +test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} { + encoding convertto jis0208 "\u543e\u543e\u543e\u543e" +} {8c8c8c8c} +test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} { + set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e + append a $a + append a $a + append a $a + append a $a + append a $a + append a $a + set x [encoding convertto jis0208 $a] + list [string length $x] [string range $x 0 1] +} "1024 8C" + +test encoding-10.1 {Tcl_UtfToExternal} { + set f [open dummy w] + fconfigure $f -translation binary -encoding shiftjis + puts -nonewline $f "ab\u4e4eg" + close $f + set f [open dummy r] + fconfigure $f -translation binary -encoding iso8859-1 + set x [read $f] + close $f + file delete dummy + set x +} "ab\x8c\xc1g" + +test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} { + set system [encoding system] + set path [testencoding path] + encoding system iso8859-1 + testencoding path {} + set x [list [catch {encoding convertto jis0208 \u4e4e} msg] $msg] + testencoding path $path + encoding system $system + lappend x [encoding convertto jis0208 \u4e4e] +} {1 {unknown encoding "jis0208"} 8C} +test encoding-11.2 {LoadEncodingFile: single-byte} { + encoding convertfrom jis0201 \xa1 +} "\uff61" +test encoding-11.3 {LoadEncodingFile: double-byte} { + encoding convertfrom jis0208 8C +} "\u4e4e" +test encoding-11.4 {LoadEncodingFile: multi-byte} { + encoding convertfrom shiftjis \x8c\xc1 +} "\u4e4e" +test encoding-11.5 {LoadEncodingFile: escape file} { + encoding convertto iso2022 \u4e4e +} "\x1b(B\x1b$@8C" +test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} { + set system [encoding system] + set path [testencoding path] + encoding system identity + testencoding path tmp + file mkdir tmp/encoding + set f [open tmp/encoding/splat.enc w] + fconfigure $f -translation binary + puts $f "abcdefghijklmnop" + close $f + set x [list [catch {encoding convertto splat \u4e4e} msg] $msg] + file delete -force tmp + catch {file delete encoding} + testencoding path $path + encoding system $system + set x +} {1 {invalid encoding file "splat"}} + +# OpenEncodingFile is fully tested by the rest of the tests in this file. + +test encoding-12.1 {LoadTableEncoding: normal encoding} { + set x [encoding convertto iso8859-3 \u120] + append x [encoding convertto iso8859-3 \ud5] + append x [encoding convertfrom iso8859-3 \xd5] +} "\xd5?\u120" +test encoding-12.2 {LoadTableEncoding: single-byte encoding} { + set x [encoding convertto iso8859-3 ab\u0120g] + append x [encoding convertfrom iso8859-3 ab\xd5g] +} "ab\xd5gab\u120g" +test encoding-12.3 {LoadTableEncoding: multi-byte encoding} { + set x [encoding convertto shiftjis ab\u4e4eg] + append x [encoding convertfrom shiftjis ab\x8c\xc1g] +} "ab\x8c\xc1gab\u4e4eg" +test encoding-12.4 {LoadTableEncoding: double-byte encoding} { + set x [encoding convertto jis0208 \u4e4e\u3b1] + append x [encoding convertfrom jis0208 8C&A] +} "8C&A\u4e4e\u3b1" +test encoding-12.5 {LoadTableEncoding: symbol encoding} { + set x [encoding convertto symbol \u3b3] + append x [encoding convertto symbol \u67] + append x [encoding convertfrom symbol \x67] +} "\x67\x67\u3b3" + +test encoding-13.1 {LoadEscapeTable} { + set x [encoding convertto iso2022 ab\u4e4e\u68d9g] +} "\x1b(Bab\x1b$@8C\x1b$(DD%\x1b(Bg" + +test encoding-14.1 {BinaryProc} { + encoding convertto identity \x12\x34\x56\xff\x69 +} "\x12\x34\x56\xc3\xbf\x69" + +test encoding-15.1 {UtfToUtfProc} { + encoding convertto utf-8 \xa3 +} "\xc2\xa3" + +test encoding-16.1 {UnicodeToUtfProc} { + encoding convertfrom unicode NN +} "\u4e4e" + +test encoding-17.1 {UtfToUnicodeProc} { +} {} + +test encoding-18.1 {TableToUtfProc} { +} {} + +test encoding-19.1 {TableFromUtfProc} { +} {} + +test encoding-20.1 {TableFreefProc} { +} {} + +test encoding-21.1 {EscapeToUtfProc} { +} {} + +test encoding-22.1 {EscapeFromUtfProc} { +} {} + +# EscapeFreeProc, GetTableEncoding, unilen +# are fully tested by the rest of this file + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + + diff --git a/tests/env.test b/tests/env.test index c66812b..27656e4 100644 --- a/tests/env.test +++ b/tests/env.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: env.test,v 1.3 1998/09/30 20:52:00 escoffon Exp $ +# RCS: @(#) $Id: env.test,v 1.4 1999/04/16 00:47:26 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # # These tests will run on any platform (and indeed crashed @@ -38,17 +41,24 @@ test env-1.2 {lappend to env value} { set env(test) aaaaaaaaaaaaaaaa append env(test) bbbbbbbbbbbbbb unset env(test) -} {} -if {[info commands exec] == ""} { - puts "exec not implemented for this machine" - return -} +} {} +test env-1.3 {reflection of env by "array names"} { + catch {interp delete child} + catch {unset env(test)} + interp create child + child eval {set env(test) garbage} + set names [array names env] + interp delete child + set ix [lsearch $names test] + catch {unset env(test)} + expr {$ix >= 0} +} {1} + + +# Some tests require the "exec" command. +# Skip them if exec is not defined. +set ::tcltest::testConfig(execCommandExists) [expr {[info commands exec] != ""}] -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} { @@ -67,7 +77,7 @@ puts $f { lrem names ComSpec lrem names "" } - foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH SHLIB_PATH} { + foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH PURE_PROG_NAME DISPLAY SHLIB_PATH } { lrem names $name } foreach p $names { @@ -95,51 +105,135 @@ foreach name [array names env] { # Added the following lines so that child tcltest can actually find its # library if the initial tcltest is run from a non-standard place. # ('saved' env vars) -foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH SHLIB_PATH} { +foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH DISPLAY SHLIB_PATH} { if {[info exists env2($name)]} { set env($name) $env2($name); } } -test env-2.1 {adding environment variables} { +test env-2.1 {adding environment variables} {execCommandExists} { getenv } {} set env(NAME1) "test string" -test env-2.2 {adding environment variables} { +test env-2.2 {adding environment variables} {execCommandExists} { getenv } {NAME1=test string} set env(NAME2) "more" -test env-2.3 {adding environment variables} { +test env-2.3 {adding environment variables} {execCommandExists} { getenv } {NAME1=test string NAME2=more} set env(XYZZY) "garbage" -test env-2.4 {adding environment variables} { +test env-2.4 {adding environment variables} {execCommandExists} { getenv } {NAME1=test string NAME2=more XYZZY=garbage} set env(NAME2) "new value" -test env-3.1 {changing environment variables} { - getenv +test env-3.1 {changing environment variables} {execCommandExists} { + set result [getenv] + unset env(NAME2) + set result } {NAME1=test string NAME2=new value XYZZY=garbage} -unset env(NAME2) -test env-4.1 {unsetting environment variables} { - getenv +test env-4.1 {unsetting environment variables} {execCommandExists} { + set result [getenv] + unset env(NAME1) + set result } {NAME1=test string XYZZY=garbage} -unset env(NAME1) -test env-4.2 {unsetting environment variables} { - getenv + +test env-4.2 {unsetting environment variables} {execCommandExists} { + set result [getenv] + unset env(XYZZY) + set result } {XYZZY=garbage} +test env-4.3 {setting international environment variables} {execCommandExists} { + set env(\ua7) \ub6 + getenv +} "\ua7=\ub6" +test env-4.4 {changing international environment variables} {execCommandExists} { + set env(\ua7) \ua7 + getenv +} "\ua7=\ua7" +test env-4.5 {unsetting international environment variables} {execCommandExists} { + set env(\ub6) \ua7 + unset env(\ua7) + set result [getenv] + unset env(\ub6) + set result +} "\ub6=\ua7" + +test env-5.0 {corner cases - set a value, it should exist} {} { + set temp [lindex [array names env] end] + set x env($temp) + set env($temp) a + set result [set env($temp)] + set env($temp) $x + set result +} {a} +test env-5.1 {corner cases - remove one elem at a time} {} { + # When no environment variables exist, the env var will + # contain no entries. The "array names" call synchs up + # the C-level environ array with the Tcl level env array. + # Make sure an empty Tcl array is created. + + set x [array get env] + foreach e [array names env] { + unset env($e) + } + set result [catch {array names env}] + array set env $x + set result +} {0} +test env-5.2 {corner cases - unset the env array} {} { + # Unsetting a variable in an interp detaches the C-level + # traces from the Tcl "env" variable. + + interp create i + i eval { unset env } + i eval { set env(THIS_SHOULDNT_EXIST) a} + set result [info exist env(THIS_SHOULDNT_EXIST)] + interp delete i + set result +} {0} +test env-5.3 {corner cases - unset the env in master should unset child} {} { + # Variables deleted in a master interp should be deleted in + # child interp too. + + interp create i + i eval { set env(THIS_SHOULD_EXIST) a} + set result [set env(THIS_SHOULD_EXIST)] + unset env(THIS_SHOULD_EXIST) + lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}] + interp delete i + set result +} {a 1} +test env-5.4 {corner cases - unset the env array} {knownBug} { + # The info exist command should be in synch with the env array. + # Know Bug: 1737 + + interp create i + i eval { set env(THIS_SHOULD_EXIST) a} + set result [info exists env(THIS_SHOULD_EXIST)] + lappend result [set env(THIS_SHOULD_EXIST)] + lappend result [info exists env(THIS_SHOULD_EXIST)] + interp delete i + set result +} {1 a 1} +test env-5.5 {corner cases - cannot have null entries on Windows} {pcOnly} { + set env() a + catch {set env()} +} {1} + + # Restore the environment variables at the end of the test. foreach name [array names env] { @@ -149,4 +243,19 @@ foreach name [array names env2] { set env($name) $env2($name) } +# cleanup file delete printenv +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/error.test b/tests/error.test index bd78987..45e8f1d 100644 --- a/tests/error.test +++ b/tests/error.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: error.test,v 1.2 1998/09/14 18:40:08 stanton Exp $ +# RCS: @(#) $Id: error.test,v 1.3 1999/04/16 00:47:26 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} proc foo {} { global errorInfo @@ -171,5 +174,19 @@ test error-6.1 {catch must reset error state} { list $errorCode $errorInfo } {NONE 1} +# cleanup catch {rename p ""} -return "" +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/eval.test b/tests/eval.test index 05eec40..6c53bb8 100644 --- a/tests/eval.test +++ b/tests/eval.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: eval.test,v 1.2 1998/09/14 18:40:08 stanton Exp $ +# RCS: @(#) $Id: eval.test,v 1.3 1999/04/16 00:47:26 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test eval-1.1 {single argument} { eval {format 22} @@ -53,3 +56,19 @@ test eval-2.5 {error in eval'ed command: setting errorInfo} { set a 1 error \"test error\" }\"" + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/event.test b/tests/event.test index 118bfc1..d75c959 100644 --- a/tests/event.test +++ b/tests/event.test @@ -4,148 +4,159 @@ # output for errors. No output means no errors were found. # # Copyright (c) 1995-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: event.test,v 1.3 1998/09/14 18:40:08 stanton Exp $ - -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}} +# RCS: @(#) $Id: event.test,v 1.4 1999/04/16 00:47:26 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +set ::tcltest::testConfig(testfilehandler) \ + [expr {[info commands testfilehandler] != {}}] +set ::tcltest::testConfig(testexithandler) \ + [expr {[info commands testexithandler] != {}}] +set ::tcltest::testConfig(testfilewait) \ + [expr {[info commands testfilewait] != {}}] + + +test event-1.1 {Tcl_CreateFileHandler, reading} {testfilehandler} { + 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} {testfilehandler 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} {testfilehandler 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} {testfilehandler 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} \ + {testfilehandler 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} { + 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} \ + {testfilehandler 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} \ + {testfilehandler 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}} +update test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} { catch {rename bgerror {}} @@ -275,69 +286,67 @@ test event-7.4 {tkerror is nothing special anymore to tcl} { 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 +test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} { + 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 +test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { + 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 +test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { + 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 +test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { + 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-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { + 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} { @@ -453,115 +462,128 @@ test event-12.4 {Tcl_UpdateCmd procedure} { 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}} -} +test event-13.1 {Tcl_WaitForFile procedure, readable} {testfilehandler} { + 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} testfilehandler { + 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} testfilehandler { + 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} \ + {testfilehandler 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} \ + {testfilehandler 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} testfilehandler { + 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} testfilehandler { + 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} -} +test event-13.8 {Tcl_WaitForFile procedure, waiting indefinitely} testfilewait { + 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} +# cleanup foreach i [after info] { after cancel $i } +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/exec.test b/tests/exec.test index d365b5d..ceb677b 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -6,24 +6,21 @@ # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: exec.test,v 1.2 1998/09/14 18:40:08 stanton Exp $ +# RCS: @(#) $Id: exec.test,v 1.3 1999/04/16 00:47:27 stanton Exp $ -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 +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } +# All tests require the "exec" command. +# Skip them if exec is not defined. +set ::tcltest::testConfig(execCommandExists) [expr {[info commands exec] != ""}] + set f [open echo w] puts $f { puts -nonewline [lindex $argv 0] @@ -104,71 +101,71 @@ close $f # Basic operations. -test exec-1.1 {basic exec operation} { +test exec-1.1 {basic exec operation} {execCommandExists stdio} { exec $tcltest echo a b c } "a b c" -test exec-1.2 {pipelining} { +test exec-1.2 {pipelining} {execCommandExists stdio} { exec $tcltest echo a b c d | $tcltest cat | $tcltest cat } "a b c d" -test exec-1.3 {pipelining} { +test exec-1.3 {pipelining} {execCommandExists stdio} { 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} { +test exec-1.4 {long command lines} {execCommandExists stdio} { exec $tcltest echo $arg } $arg set arg {} # I/O redirection: input from Tcl command. -test exec-2.1 {redirecting input from immediate source} { +test exec-2.1 {redirecting input from immediate source} {execCommandExists stdio} { exec $tcltest cat << "Sample text" } {Sample text} -test exec-2.2 {redirecting input from immediate source} { +test exec-2.2 {redirecting input from immediate source} {execCommandExists stdio} { exec << "Sample text" $tcltest cat | $tcltest cat } {Sample text} -test exec-2.3 {redirecting input from immediate source} { +test exec-2.3 {redirecting input from immediate source} {execCommandExists stdio} { exec $tcltest cat << "Sample text" | $tcltest cat } {Sample text} -test exec-2.4 {redirecting input from immediate source} { +test exec-2.4 {redirecting input from immediate source} {execCommandExists stdio} { exec $tcltest cat | $tcltest cat << "Sample text" } {Sample text} -test exec-2.5 {redirecting input from immediate source} { +test exec-2.5 {redirecting input from immediate source} {execCommandExists stdio} { 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} { +test exec-3.1 {redirecting output to file} {execCommandExists stdio} { exec $tcltest echo "Some simple words" > gorp.file exec $tcltest cat gorp.file } "Some simple words" -test exec-3.2 {redirecting output to file} { +test exec-3.2 {redirecting output to file} {execCommandExists stdio} { 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} { +test exec-3.3 {redirecting output to file} {execCommandExists stdio} { 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} { +test exec-3.4 {redirecting output to file} {execCommandExists stdio} { exec $tcltest echo "Some simple words" >gorp.file exec $tcltest cat gorp.file } "Some simple words" -test exec-3.5 {redirecting output to file} { +test exec-3.5 {redirecting output to file} {execCommandExists stdio} { 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} { +test exec-3.6 {redirecting output to file} {execCommandExists stdio} { 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} { +test exec-3.7 {redirecting output to file} {execCommandExists stdio} { set f [open gorp.file w] puts $f "Line 1" flush $f @@ -182,20 +179,20 @@ test exec-3.7 {redirecting output to file} { # I/O redirection: output and stderr to file. file delete gorp.file -test exec-4.1 {redirecting output and stderr to file} { +test exec-4.1 {redirecting output and stderr to file} {execCommandExists stdio} { exec $tcltest echo "test output" >& gorp.file exec $tcltest cat gorp.file } "test output" -test exec-4.2 {redirecting output and stderr to file} { +test exec-4.2 {redirecting output and stderr to file} {execCommandExists stdio} { 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} { +test exec-4.3 {redirecting output and stderr to file} {execCommandExists stdio} { 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} { +test exec-4.4 {redirecting output and stderr to file} {execCommandExists stdio} { set f [open gorp.file w] puts $f "Line 1" flush $f @@ -205,7 +202,7 @@ test exec-4.4 {redirecting output and stderr to file} { 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} { +test exec-4.5 {redirecting output and stderr to file} {execCommandExists stdio} { set f [open gorp.file w] puts $f "Line 1" flush $f @@ -219,28 +216,28 @@ test exec-4.5 {redirecting output and stderr to file} { # I/O redirection: input from file. exec $tcltest echo "Just a few thoughts" > gorp.file -test exec-5.1 {redirecting input from file} { +test exec-5.1 {redirecting input from file} {execCommandExists stdio} { exec $tcltest cat < gorp.file } {Just a few thoughts} -test exec-5.2 {redirecting input from file} { +test exec-5.2 {redirecting input from file} {execCommandExists stdio} { exec $tcltest cat | $tcltest cat < gorp.file } {Just a few thoughts} -test exec-5.3 {redirecting input from file} { +test exec-5.3 {redirecting input from file} {execCommandExists stdio} { exec $tcltest cat < gorp.file | $tcltest cat } {Just a few thoughts} -test exec-5.4 {redirecting input from file} { +test exec-5.4 {redirecting input from file} {execCommandExists stdio} { exec < gorp.file $tcltest cat | $tcltest cat } {Just a few thoughts} -test exec-5.5 {redirecting input from file} { +test exec-5.5 {redirecting input from file} {execCommandExists stdio} { exec $tcltest cat <gorp.file } {Just a few thoughts} -test exec-5.6 {redirecting input from file} { +test exec-5.6 {redirecting input from file} {execCommandExists stdio} { 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} { +test exec-5.7 {redirecting input from file} {execCommandExists stdio} { set f [open gorp.file r] set result [exec <@$f $tcltest cat] close $f @@ -249,25 +246,25 @@ test exec-5.7 {redirecting input from file} { # I/O redirection: standard error through a pipeline. -test exec-6.1 {redirecting stderr through a pipeline} { +test exec-6.1 {redirecting stderr through a pipeline} {execCommandExists stdio} { exec $tcltest sh -c "echo foo bar" |& $tcltest cat } "foo bar" -test exec-6.2 {redirecting stderr through a pipeline} { +test exec-6.2 {redirecting stderr through a pipeline} {execCommandExists stdio} { exec $tcltest sh -c "echo foo bar 1>&2" |& $tcltest cat } "foo bar" -test exec-6.3 {redirecting stderr through a pipeline} { +test exec-6.3 {redirecting stderr through a pipeline} {execCommandExists stdio} { 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} { +file delete gorp.file2 +test exec-7.1 {multiple I/O redirections} {execCommandExists stdio} { 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} { +test exec-7.2 {multiple I/O redirections} {execCommandExists stdio} { exec < gorp.file << "command input" $tcltest cat } {command input} @@ -278,125 +275,141 @@ 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} { +test exec-8.1 {long input and output} {execCommandExists stdio} { exec $tcltest cat << $a } $a +# More than 20 arguments to exec. + +test exec-8.1 {long input and output} {execCommandExists stdio} { + exec $tcltest echo 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 +} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23} + # Commands that return errors. -test exec-9.1 {commands returning errors} { +test exec-9.1 {commands returning errors} {execCommandExists stdio} { 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} { +test exec-9.2 {commands returning errors} {execCommandExists stdio} { 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} { +test exec-9.3 {commands returning errors} {execCommandExists stdio} { 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} { +test exec-9.4 {commands returning errors} {execCommandExists stdio} { 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} { +test exec-9.5 {commands returning errors} {execCommandExists stdio} { 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} { +test exec-9.6 {commands returning errors} {execCommandExists stdio} { list [catch {exec $tcltest sh -c "echo error msg 1>&2"} msg] $msg } {1 {error msg}} -test exec-9.7 {commands returning errors} { +test exec-9.7 {commands returning errors} {execCommandExists stdio} { 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}} +test exec-9.8 {commands returning errors} {execCommandExists stdio} { + set f [open err w] + puts $f { + puts stdout out + puts stderr err + } + close $f + list [catch {exec $tcltest err} msg] $msg +} {1 {out +err}} # Errors in executing the Tcl command, as opposed to errors in the # processes that are invoked. -test exec-10.1 {errors in exec invocation} { +test exec-10.1 {errors in exec invocation} {execCommandExists stdio} { list [catch {exec} msg] $msg } {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}} -test exec-10.2 {errors in exec invocation} { +test exec-10.2 {errors in exec invocation} {execCommandExists stdio} { list [catch {exec | cat} msg] $msg } {1 {illegal use of | or |& in command}} -test exec-10.3 {errors in exec invocation} { +test exec-10.3 {errors in exec invocation} {execCommandExists stdio} { list [catch {exec cat |} msg] $msg } {1 {illegal use of | or |& in command}} -test exec-10.4 {errors in exec invocation} { +test exec-10.4 {errors in exec invocation} {execCommandExists stdio} { list [catch {exec cat | | cat} msg] $msg } {1 {illegal use of | or |& in command}} -test exec-10.5 {errors in exec invocation} { +test exec-10.5 {errors in exec invocation} {execCommandExists stdio} { list [catch {exec cat | |& cat} msg] $msg } {1 {illegal use of | or |& in command}} -test exec-10.6 {errors in exec invocation} { +test exec-10.6 {errors in exec invocation} {execCommandExists stdio} { list [catch {exec cat |&} msg] $msg } {1 {illegal use of | or |& in command}} -test exec-10.7 {errors in exec invocation} { +test exec-10.7 {errors in exec invocation} {execCommandExists stdio} { list [catch {exec cat <} msg] $msg } {1 {can't specify "<" as last word in command}} -test exec-10.8 {errors in exec invocation} { +test exec-10.8 {errors in exec invocation} {execCommandExists stdio} { list [catch {exec cat >} msg] $msg } {1 {can't specify ">" as last word in command}} -test exec-10.9 {errors in exec invocation} { +test exec-10.9 {errors in exec invocation} {execCommandExists stdio} { list [catch {exec cat <<} msg] $msg } {1 {can't specify "<<" as last word in command}} -test exec-10.10 {errors in exec invocation} { +test exec-10.10 {errors in exec invocation} {execCommandExists stdio} { list [catch {exec cat >>} msg] $msg } {1 {can't specify ">>" as last word in command}} -test exec-10.11 {errors in exec invocation} { +test exec-10.11 {errors in exec invocation} {execCommandExists stdio} { list [catch {exec cat >&} msg] $msg } {1 {can't specify ">&" as last word in command}} -test exec-10.12 {errors in exec invocation} { +test exec-10.12 {errors in exec invocation} {execCommandExists stdio} { list [catch {exec cat >>&} msg] $msg } {1 {can't specify ">>&" as last word in command}} -test exec-10.13 {errors in exec invocation} { +test exec-10.13 {errors in exec invocation} {execCommandExists stdio} { list [catch {exec cat >@} msg] $msg } {1 {can't specify ">@" as last word in command}} -test exec-10.14 {errors in exec invocation} { +test exec-10.14 {errors in exec invocation} {execCommandExists stdio} { list [catch {exec cat <@} msg] $msg } {1 {can't specify "<@" as last word in command}} -test exec-10.15 {errors in exec invocation} { +test exec-10.15 {errors in exec invocation} {execCommandExists stdio} { 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} { +test exec-10.16 {errors in exec invocation} {execCommandExists stdio} { 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} { +test exec-10.17 {errors in exec invocation} {execCommandExists stdio} { 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} { +test exec-10.18 {errors in exec invocation} {execCommandExists stdio} { 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} { +test exec-10.19 {errors in exec invocation} {execCommandExists stdio} { 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} { +test exec-10.20 {errors in exec invocation} {execCommandExists stdio} { 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} { +test exec-10.21 {errors in exec invocation} {execCommandExists stdio} { 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} { +test exec-11.1 {commands in background} {execCommandExists stdio} { set x [lindex [time {exec $tcltest sleep 2 &}] 0] expr $x<1000000 } 1 -test exec-11.2 {commands in background} { +test exec-11.2 {commands in background} {execCommandExists stdio} { list [catch {exec $tcltest echo a &b} msg] $msg } {0 {a &b}} -test exec-11.3 {commands in background} { +test exec-11.3 {commands in background} {execCommandExists stdio} { llength [exec $tcltest sleep 1 &] } 1 -test exec-11.4 {commands in background} { +test exec-11.4 {commands in background} {execCommandExists stdio} { llength [exec $tcltest sleep 1 | $tcltest sleep 1 | $tcltest sleep 1 &] } 3 -test exec-11.5 {commands in background} { +test exec-11.5 {commands in background} {execCommandExists stdio} { set f [open gorp.file w] puts $f { catch { exec [info nameofexecutable] echo foo & } } close $f @@ -407,7 +420,8 @@ test exec-11.5 {commands in background} { # they eventually die. exec $tcltest sleep 3 -test exec-12.1 {reaping background processes} {unixOnly nonPortable} { +test exec-12.1 {reaping background processes} \ + {execCommandExists stdio unixOnly nonPortable} { for {set i 0} {$i < 20} {incr i} { exec echo foo > /dev/null & } @@ -415,7 +429,8 @@ test exec-12.1 {reaping background processes} {unixOnly nonPortable} { catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg lindex $msg 0 } 0 -test exec-12.2 {reaping background processes} {unixOnly nonPortable} { +test exec-12.2 {reaping background processes} \ + {execCommandExists stdio 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] @@ -423,7 +438,8 @@ test exec-12.2 {reaping background processes} {unixOnly nonPortable} { 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} { +test exec-12.3 {reaping background processes} \ + {execCommandExists stdio unixOnly nonPortable} { exec sleep 1000 & exec sleep 1000 & set x [exec ps | fgrep "sleep" | fgrep -v fgrep] @@ -446,13 +462,13 @@ test exec-12.3 {reaping background processes} {unixOnly nonPortable} { # Make sure "errorCode" is set correctly. -test exec-13.1 {setting errorCode variable} { +test exec-13.1 {setting errorCode variable} {execCommandExists stdio} { 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} { +test exec-13.2 {setting errorCode variable} {execCommandExists stdio} { 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} { +test exec-13.3 {setting errorCode variable} {execCommandExists stdio} { set x [catch {exec _weird_cmd_} msg] list $x [string tolower $msg] [lindex $errorCode 0] \ [string tolower [lrange $errorCode 2 end]] @@ -460,39 +476,39 @@ test exec-13.3 {setting errorCode variable} { # Switches before the first argument -test exec-14.1 {-keepnewline switch} { +test exec-14.1 {-keepnewline switch} {execCommandExists stdio} { exec -keepnewline $tcltest echo foo } "foo\n" -test exec-14.2 {-keepnewline switch} { +test exec-14.2 {-keepnewline switch} {execCommandExists stdio} { list [catch {exec -keepnewline} msg] $msg } {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}} -test exec-14.3 {unknown switch} { +test exec-14.3 {unknown switch} {execCommandExists stdio} { list [catch {exec -gorp} msg] $msg } {1 {bad switch "-gorp": must be -keepnewline or --}} -test exec-14.4 {-- switch} { +test exec-14.4 {-- switch} {execCommandExists stdio} { 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} { +test exec-15.1 {standard error redirection} {execCommandExists stdio} { 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} { +test exec-15.2 {standard error redirection} {execCommandExists stdio} { 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} { +test exec-15.3 {standard error redirection} {execCommandExists stdio} { 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} { +test exec-15.4 {standard error redirection} {execCommandExists stdio} { set f [open gorp.file w] puts $f "Line 1" flush $f @@ -503,19 +519,19 @@ test exec-15.4 {standard error redirection} { } {Line 1 foo bar Line 3} -test exec-15.5 {standard error redirection} { +test exec-15.5 {standard error redirection} {execCommandExists stdio} { 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} { +test exec-15.6 {standard error redirection} {execCommandExists stdio} { 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} { +test exec-16.1 {flush output before exec} {execCommandExists stdio} { set f [open gorp.file w] puts $f "First line" exec $tcltest echo "Second line" >@ $f @@ -525,7 +541,7 @@ test exec-16.1 {flush output before exec} { } {First line Second line Third line} -test exec-16.2 {flush output before exec} {} { +test exec-16.2 {flush output before exec} {execCommandExists stdio} { set f [open gorp.file w] puts $f "First line" exec $tcltest << {puts stderr {Second line}} >&@ $f > gorp.file2 @@ -536,7 +552,7 @@ test exec-16.2 {flush output before exec} {} { Second line Third line} -test exec-17.1 { inheriting standard I/O } { +test exec-17.1 { inheriting standard I/O } {execCommandExists stdio} { set f [open script w] puts $f {close stdout set f [open gorp.file w] @@ -553,5 +569,21 @@ test exec-17.1 { inheriting standard I/O } { } {{foobar }} +# cleanup file delete script gorp.file gorp.file2 file delete echo cat wc sh sleep exit +file delete err +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/execute.test b/tests/execute.test index b4ae4a4..aebe67b 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -9,13 +9,16 @@ # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: execute.test,v 1.2 1998/09/14 18:40:08 stanton Exp $ +# RCS: @(#) $Id: execute.test,v 1.3 1999/04/16 00:47:27 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename foo ""} @@ -23,7 +26,420 @@ catch {unset x} catch {unset y} catch {unset msg} -test execute-1.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { +set ::tcltest::testConfig(testobj) \ + [expr {[info commands testobj] != {} \ + && [info commands testdoubleobj] != {} \ + && [info commands teststringobj] != {} \ + && [info commands testobj] != {}}] + +# Tests for the omnibus TclExecuteByteCode function: + +# INST_DONE not tested +# INST_PUSH1 not tested +# INST_PUSH4 not tested +# INST_POP not tested +# INST_DUP not tested +# INST_CONCAT1 not tested +# INST_INVOKE_STK4 not tested +# INST_INVOKE_STK1 not tested +# INST_EVAL_STK not tested +# INST_EXPR_STK not tested +# INST_LOAD_SCALAR1 not tested +# INST_LOAD_SCALAR4 not tested +# INST_LOAD_SCALAR_STK not tested +# INST_LOAD_ARRAY4 not tested +# INST_LOAD_ARRAY1 not tested +# INST_LOAD_ARRAY_STK not tested +# INST_LOAD_STK not tested +# INST_STORE_SCALAR4 not tested +# INST_STORE_SCALAR1 not tested +# INST_STORE_SCALAR_STK not tested +# INST_STORE_ARRAY4 not tested +# INST_STORE_ARRAY1 not tested +# INST_STORE_ARRAY_STK not tested +# INST_STORE_STK not tested +# INST_INCR_SCALAR1 not tested +# INST_INCR_SCALAR_STK not tested +# INST_INCR_STK not tested +# INST_INCR_ARRAY1 not tested +# INST_INCR_ARRAY_STK not tested +# INST_INCR_SCALAR1_IMM not tested +# INST_INCR_SCALAR_STK_IMM not tested +# INST_INCR_STK_IMM not tested +# INST_INCR_ARRAY1_IMM not tested +# INST_INCR_ARRAY_STK_IMM not tested +# INST_JUMP1 not tested +# INST_JUMP4 not tested +# INST_JUMP_TRUE4 not tested +# INST_JUMP_TRUE1 not tested +# INST_JUMP_FALSE4 not tested +# INST_JUMP_FALSE1 not tested +# INST_LOR not tested +# INST_LAND not tested +# INST_EQ not tested +# INST_NEQ not tested +# INST_LT not tested +# INST_GT not tested +# INST_LE not tested +# INST_GE not tested +# INST_MOD not tested +# INST_LSHIFT not tested +# INST_RSHIFT not tested +# INST_BITOR not tested +# INST_BITXOR not tested +# INST_BITAND not tested + +# INST_ADD is partially tested: +test execute-1.1 {TclExecuteByteCode, INST_ADD, op1 is int} {testobj} { + set x [testintobj set 0 1] + expr {$x + 1} +} 2 +test execute-1.2 {TclExecuteByteCode, INST_ADD, op1 is double} {testobj} { + set x [testdoubleobj set 0 1] + expr {$x + 1} +} 2.0 +test execute-1.3 {TclExecuteByteCode, INST_ADD, op1 is double with string} {testobj} { + set x [testintobj set 0 1] + testobj convert 0 double + expr {$x + 1} +} 2 +test execute-1.4 {TclExecuteByteCode, INST_ADD, op1 is string int} {testobj} { + set x [teststringobj set 0 1] + expr {$x + 1} +} 2 +test execute-1.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj} { + set x [teststringobj set 0 1.0] + expr {$x + 1} +} 2.0 +test execute-1.6 {TclExecuteByteCode, INST_ADD, op1 is non-numeric} {testobj} { + set x [teststringobj set 0 foo] + list [catch {expr {$x + 1}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test execute-1.7 {TclExecuteByteCode, INST_ADD, op2 is int} {testobj} { + set x [testintobj set 0 1] + expr {1 + $x} +} 2 +test execute-1.8 {TclExecuteByteCode, INST_ADD, op2 is double} {testobj} { + set x [testdoubleobj set 0 1] + expr {1 + $x} +} 2.0 +test execute-1.9 {TclExecuteByteCode, INST_ADD, op2 is double with string} {testobj} { + set x [testintobj set 0 1] + testobj convert 0 double + expr {1 + $x} +} 2 +test execute-1.10 {TclExecuteByteCode, INST_ADD, op2 is string int} {testobj} { + set x [teststringobj set 0 1] + expr {1 + $x} +} 2 +test execute-1.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj} { + set x [teststringobj set 0 1.0] + expr {1 + $x} +} 2.0 +test execute-1.12 {TclExecuteByteCode, INST_ADD, op2 is non-numeric} {testobj} { + set x [teststringobj set 0 foo] + list [catch {expr {1 + $x}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} + +# INST_SUB is partially tested: +test execute-1.13 {TclExecuteByteCode, INST_SUB, op1 is int} {testobj} { + set x [testintobj set 0 1] + expr {$x - 1} +} 0 +test execute-1.14 {TclExecuteByteCode, INST_SUB, op1 is double} {testobj} { + set x [testdoubleobj set 0 1] + expr {$x - 1} +} 0.0 +test execute-1.15 {TclExecuteByteCode, INST_SUB, op1 is double with string} {testobj} { + set x [testintobj set 0 1] + testobj convert 0 double + expr {$x - 1} +} 0 +test execute-1.16 {TclExecuteByteCode, INST_SUB, op1 is string int} {testobj} { + set x [teststringobj set 0 1] + expr {$x - 1} +} 0 +test execute-1.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj} { + set x [teststringobj set 0 1.0] + expr {$x - 1} +} 0.0 +test execute-1.18 {TclExecuteByteCode, INST_SUB, op1 is non-numeric} {testobj} { + set x [teststringobj set 0 foo] + list [catch {expr {$x - 1}} msg] $msg +} {1 {can't use non-numeric string as operand of "-"}} +test execute-1.19 {TclExecuteByteCode, INST_SUB, op2 is int} {testobj} { + set x [testintobj set 0 1] + expr {1 - $x} +} 0 +test execute-1.20 {TclExecuteByteCode, INST_SUB, op2 is double} {testobj} { + set x [testdoubleobj set 0 1] + expr {1 - $x} +} 0.0 +test execute-1.21 {TclExecuteByteCode, INST_SUB, op2 is double with string} {testobj} { + set x [testintobj set 0 1] + testobj convert 0 double + expr {1 - $x} +} 0 +test execute-1.22 {TclExecuteByteCode, INST_SUB, op2 is string int} {testobj} { + set x [teststringobj set 0 1] + expr {1 - $x} +} 0 +test execute-1.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj} { + set x [teststringobj set 0 1.0] + expr {1 - $x} +} 0.0 +test execute-1.24 {TclExecuteByteCode, INST_SUB, op2 is non-numeric} {testobj} { + set x [teststringobj set 0 foo] + list [catch {expr {1 - $x}} msg] $msg +} {1 {can't use non-numeric string as operand of "-"}} + +# INST_MULT is partially tested: +test execute-1.25 {TclExecuteByteCode, INST_MULT, op1 is int} {testobj} { + set x [testintobj set 1 1] + expr {$x * 1} +} 1 +test execute-1.26 {TclExecuteByteCode, INST_MULT, op1 is double} {testobj} { + set x [testdoubleobj set 1 2.0] + expr {$x * 1} +} 2.0 +test execute-1.27 {TclExecuteByteCode, INST_MULT, op1 is double with string} {testobj} { + set x [testintobj set 1 2] + testobj convert 1 double + expr {$x * 1} +} 2 +test execute-1.28 {TclExecuteByteCode, INST_MULT, op1 is string int} {testobj} { + set x [teststringobj set 1 1] + expr {$x * 1} +} 1 +test execute-1.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj} { + set x [teststringobj set 1 1.0] + expr {$x * 1} +} 1.0 +test execute-1.30 {TclExecuteByteCode, INST_MULT, op1 is non-numeric} {testobj} { + set x [teststringobj set 1 foo] + list [catch {expr {$x * 1}} msg] $msg +} {1 {can't use non-numeric string as operand of "*"}} +test execute-1.31 {TclExecuteByteCode, INST_MULT, op2 is int} {testobj} { + set x [testintobj set 1 1] + expr {1 * $x} +} 1 +test execute-1.32 {TclExecuteByteCode, INST_MULT, op2 is double} {testobj} { + set x [testdoubleobj set 1 2.0] + expr {1 * $x} +} 2.0 +test execute-1.33 {TclExecuteByteCode, INST_MULT, op2 is double with string} {testobj} { + set x [testintobj set 1 2] + testobj convert 1 double + expr {1 * $x} +} 2 +test execute-1.34 {TclExecuteByteCode, INST_MULT, op2 is string int} {testobj} { + set x [teststringobj set 1 1] + expr {1 * $x} +} 1 +test execute-1.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj} { + set x [teststringobj set 1 1.0] + expr {1 * $x} +} 1.0 +test execute-1.36 {TclExecuteByteCode, INST_MULT, op2 is non-numeric} {testobj} { + set x [teststringobj set 1 foo] + list [catch {expr {1 * $x}} msg] $msg +} {1 {can't use non-numeric string as operand of "*"}} + +# INST_DIV is partially tested: +test execute-1.37 {TclExecuteByteCode, INST_DIV, op1 is int} {testobj} { + set x [testintobj set 1 1] + expr {$x / 1} +} 1 +test execute-1.38 {TclExecuteByteCode, INST_DIV, op1 is double} {testobj} { + set x [testdoubleobj set 1 2.0] + expr {$x / 1} +} 2.0 +test execute-1.39 {TclExecuteByteCode, INST_DIV, op1 is double with string} {testobj} { + set x [testintobj set 1 2] + testobj convert 1 double + expr {$x / 1} +} 2 +test execute-1.40 {TclExecuteByteCode, INST_DIV, op1 is string int} {testobj} { + set x [teststringobj set 1 1] + expr {$x / 1} +} 1 +test execute-1.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj} { + set x [teststringobj set 1 1.0] + expr {$x / 1} +} 1.0 +test execute-1.42 {TclExecuteByteCode, INST_DIV, op1 is non-numeric} {testobj} { + set x [teststringobj set 1 foo] + list [catch {expr {$x / 1}} msg] $msg +} {1 {can't use non-numeric string as operand of "/"}} +test execute-1.43 {TclExecuteByteCode, INST_DIV, op2 is int} {testobj} { + set x [testintobj set 1 1] + expr {2 / $x} +} 2 +test execute-1.44 {TclExecuteByteCode, INST_DIV, op2 is double} {testobj} { + set x [testdoubleobj set 1 1.0] + expr {2 / $x} +} 2.0 +test execute-1.45 {TclExecuteByteCode, INST_DIV, op2 is double with string} {testobj} { + set x [testintobj set 1 1] + testobj convert 1 double + expr {2 / $x} +} 2 +test execute-1.46 {TclExecuteByteCode, INST_DIV, op2 is string int} {testobj} { + set x [teststringobj set 1 1] + expr {2 / $x} +} 2 +test execute-1.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj} { + set x [teststringobj set 1 1.0] + expr {2 / $x} +} 2.0 +test execute-1.48 {TclExecuteByteCode, INST_DIV, op2 is non-numeric} {testobj} { + set x [teststringobj set 1 foo] + list [catch {expr {1 / $x}} msg] $msg +} {1 {can't use non-numeric string as operand of "/"}} + +# INST_UPLUS is partially tested: +test execute-1.49 {TclExecuteByteCode, INST_UPLUS, op is int} {testobj} { + set x [testintobj set 1 1] + expr {+ $x} +} 1 +test execute-1.50 {TclExecuteByteCode, INST_UPLUS, op is double} {testobj} { + set x [testdoubleobj set 1 1.0] + expr {+ $x} +} 1.0 +test execute-1.51 {TclExecuteByteCode, INST_UPLUS, op is double with string} {testobj} { + set x [testintobj set 1 1] + testobj convert 1 double + expr {+ $x} +} 1 +test execute-1.52 {TclExecuteByteCode, INST_UPLUS, op is string int} {testobj} { + set x [teststringobj set 1 1] + expr {+ $x} +} 1 +test execute-1.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj} { + set x [teststringobj set 1 1.0] + expr {+ $x} +} 1.0 +test execute-1.54 {TclExecuteByteCode, INST_UPLUS, op is non-numeric} {testobj} { + set x [teststringobj set 1 foo] + list [catch {expr {+ $x}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} + +# INST_UMINUS is partially tested: +test execute-1.55 {TclExecuteByteCode, INST_UMINUS, op is int} {testobj} { + set x [testintobj set 1 1] + expr {- $x} +} -1 +test execute-1.56 {TclExecuteByteCode, INST_UMINUS, op is double} {testobj} { + set x [testdoubleobj set 1 1.0] + expr {- $x} +} -1.0 +test execute-1.57 {TclExecuteByteCode, INST_UMINUS, op is double with string} {testobj} { + set x [testintobj set 1 1] + testobj convert 1 double + expr {- $x} +} -1 +test execute-1.58 {TclExecuteByteCode, INST_UMINUS, op is string int} {testobj} { + set x [teststringobj set 1 1] + expr {- $x} +} -1 +test execute-1.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testobj} { + set x [teststringobj set 1 1.0] + expr {- $x} +} -1.0 +test execute-1.60 {TclExecuteByteCode, INST_UMINUS, op is non-numeric} {testobj} { + set x [teststringobj set 1 foo] + list [catch {expr {- $x}} msg] $msg +} {1 {can't use non-numeric string as operand of "-"}} + +# INST_LNOT is partially tested: +test execute-1.61 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} { + set x [testintobj set 1 2] + expr {! $x} +} 0 +test execute-1.62 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} { + set x [testintobj set 1 0] + expr {! $x} +} 1 +test execute-1.63 {TclExecuteByteCode, INST_LNOT, op is double} {testobj} { + set x [testdoubleobj set 1 1.0] + expr {! $x} +} 0 +test execute-1.64 {TclExecuteByteCode, INST_LNOT, op is double} {testobj} { + set x [testdoubleobj set 1 0.0] + expr {! $x} +} 1 +test execute-1.65 {TclExecuteByteCode, INST_LNOT, op is double with string} {testobj} { + set x [testintobj set 1 1] + testobj convert 1 double + expr {! $x} +} 0 +test execute-1.66 {TclExecuteByteCode, INST_LNOT, op is double with string} {testobj} { + set x [testintobj set 1 0] + testobj convert 1 double + expr {! $x} +} 1 +test execute-1.67 {TclExecuteByteCode, INST_LNOT, op is string int} {testobj} { + set x [teststringobj set 1 1] + expr {! $x} +} 0 +test execute-1.68 {TclExecuteByteCode, INST_LNOT, op is string int} {testobj} { + set x [teststringobj set 1 0] + expr {! $x} +} 1 +test execute-1.69 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} { + set x [teststringobj set 1 1.0] + expr {! $x} +} 0 +test execute-1.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} { + set x [teststringobj set 1 0.0] + expr {! $x} +} 1 +test execute-1.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} { + set x [teststringobj set 1 foo] + list [catch {expr {! $x}} msg] $msg +} {1 {can't use non-numeric string as operand of "!"}} + +# INST_BITNOT not tested +# INST_CALL_BUILTIN_FUNC1 not tested +# INST_CALL_FUNC1 not tested + +# INST_TRY_CVT_TO_NUMERIC is partially tested: +test execute-1.72 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is int} {testobj} { + set x [testintobj set 1 1] + expr {$x} +} 1 +test execute-1.73 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is double} {testobj} { + set x [testdoubleobj set 1 1.0] + expr {$x} +} 1.0 +test execute-1.74 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is double with string} {testobj} { + set x [testintobj set 1 1] + testobj convert 1 double + expr {$x} +} 1 +test execute-1.75 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is string int} {testobj} { + set x [teststringobj set 1 1] + expr {$x} +} 1 +test execute-1.76 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is string double} {testobj} { + set x [teststringobj set 1 1.0] + expr {$x} +} 1.0 +test execute-1.77 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is non-numeric} {testobj} { + set x [teststringobj set 1 foo] + expr {$x} +} foo + +# INST_BREAK not tested +# INST_CONTINUE not tested +# INST_FOREACH_START4 not tested +# INST_FOREACH_STEP4 not tested +# INST_BEGIN_CATCH4 not tested +# INST_END_CATCH not tested +# INST_PUSH_RESULT not tested +# INST_PUSH_RETURN_CODE not tested + +test execute-2.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {unset x} catch {unset y} @@ -41,7 +457,7 @@ test execute-1.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { [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} { +test execute-2.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename foo ""} catch {unset l} @@ -63,7 +479,7 @@ test execute-1.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is inval lappend l [test_ns_1::whichFoo] set l } {::foo ::test_ns_1::foo} -test execute-1.3 {Tcl_GetCommandFromObj, command never found} { +test execute-2.3 {Tcl_GetCommandFromObj, command never found} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename foo ""} namespace eval test_ns_1 { @@ -81,7 +497,7 @@ test execute-1.3 {Tcl_GetCommandFromObj, command never found} { [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} { +test execute-3.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {unset l} proc {} {} {return {}} @@ -91,7 +507,7 @@ test execute-2.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} {} } {} -test execute-3.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} { +test execute-4.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} { proc {} {} {} proc { } {} {} proc p {} { @@ -103,6 +519,7 @@ test execute-3.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName o p } {} +# cleanup catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename foo ""} catch {rename p ""} @@ -111,4 +528,21 @@ catch {rename { } ""} catch {unset x} catch {unset y} catch {unset msg} -concat {} +::tcltest::cleanupTests +return + + + + + + + + + + + + + + + + diff --git a/tests/expr-old.test b/tests/expr-old.test index 0e50a06..aa5e035 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -2,19 +2,22 @@ # # This file contains the original set of tests for Tcl's expr command. # Since the expr command is now compiled, a new set of tests covering -# the new implementation is in the file "expr.test". Sourcing this file -# into Tcl runs the tests and generates output for errors. -# No output means no errors were found. +# the new implementation are in the files "parseExpr.test and +# "compExpr.test". Sourcing this file into Tcl runs the tests and generates +# output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: expr-old.test,v 1.4 1998/11/02 23:04:13 stanton Exp $ +# RCS: @(#) $Id: expr-old.test,v 1.5 1999/04/16 00:47:27 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { set gotT1 0 @@ -456,13 +459,13 @@ test expr-old-26.15 {error conditions} { } {1 {syntax error in expression "a@b"}} test expr-old-26.16 {error conditions} { list [catch {expr a[b} msg] $msg -} {1 {missing close-bracket or close-brace}} +} {1 {missing close-bracket}} test expr-old-26.17 {error conditions} { list [catch {expr a`b} msg] $msg } {1 {syntax error in expression "a`b"}} test expr-old-26.18 {error conditions} { list [catch {expr \"a\"\{b} msg] $msg -} {1 {missing close-brace}} +} {1 syntax\ error\ in\ expression\ \"\"a\"\{b\"} test expr-old-26.19 {error conditions} { list [catch {expr a} msg] $msg } {1 {syntax error in expression "a"}} @@ -777,10 +780,10 @@ test expr-old-32.45 {math functions in expressions} { } {1} test expr-old-32.46 {math functions in expressions} { list [catch {expr rand(24)} msg] $msg -} {1 {syntax error in expression "rand(24)"}} +} {1 {too many arguments for math function}} test expr-old-32.47 {math functions in expressions} { list [catch {expr srand()} msg] $msg -} {1 {syntax error in expression "srand()"}} +} {1 {too few arguments for math function}} test expr-old-32.48 {math functions in expressions} { list [catch {expr srand(3.79)} msg] $msg } {1 {can't use floating-point value as argument to srand}} @@ -862,7 +865,7 @@ test expr-old-34.16 {errors in math functions} { if $gotT1 { test expr-old-34.17 {errors in math functions} { list [catch {expr T1(4)} msg] $msg - } {1 {syntax error in expression "T1(4)"}} + } {1 {too many arguments for math function}} } test expr-old-36.1 {ExprLooksLikeInt procedure} { @@ -871,7 +874,7 @@ test expr-old-36.1 {ExprLooksLikeInt procedure} { test expr-old-36.2 {ExprLooksLikeInt procedure} { set x 0289 list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use floating-point value as operand of "+"}} test expr-old-36.3 {ExprLooksLikeInt procedure} { list [catch {expr 0289.1} msg] $msg } {0 289.1} @@ -927,3 +930,19 @@ if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} { puts "call Intel customer service immediately at 1-800-628-8686" puts "to request a replacement processor." } + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/expr.test b/tests/expr.test index 2a5c860..7b0135a 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -5,13 +5,16 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: expr.test,v 1.2 1998/09/14 18:40:09 stanton Exp $ +# RCS: @(#) $Id: expr.test,v 1.3 1999/04/16 00:47:27 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { set gotT1 0 @@ -88,7 +91,7 @@ test expr-1.5 {TclCompileExprCmd: quoted expression word} { test expr-1.6 {TclCompileExprCmd: quoted expression word} { catch {expr "0005"zxy} msg set msg -} {quoted string doesn't terminate properly} +} {extra characters after close-quote} test expr-1.7 {TclCompileExprCmd: expression word in braces} { expr {-0005} } -5 @@ -98,7 +101,7 @@ test expr-1.8 {TclCompileExprCmd: expression word in braces} { test expr-1.9 {TclCompileExprCmd: expression word in braces} { catch {expr {-0005}foo} msg set msg -} {argument word in braces doesn't terminate properly} +} {extra characters after close-brace} test expr-1.10 {TclCompileExprCmd: other expression word in braces} { expr 4*[llength "6 2"] } 8 @@ -479,7 +482,6 @@ 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} { @@ -516,9 +518,7 @@ test expr-14.23 {CompilePrimaryExpr: error in subcommand primary} { 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" +} {missing close-bracket while compiling "expr {[set i}"} test expr-14.25 {CompilePrimaryExpr: math function primary} { @@ -531,7 +531,7 @@ 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 + while compiling "expr sinh::(2.0)"} test expr-14.28 {CompilePrimaryExpr: subexpression primary} { expr 2+(3*4) @@ -548,7 +548,7 @@ 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 + while compiling "expr 2+(3*(4+5)"} test expr-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} { set i "5+10" @@ -558,44 +558,44 @@ test expr-14.32 {CompilePrimaryExpr: unexpected token} { catch {expr @} msg set errorInfo } {syntax error in expression "@" - while executing + while compiling "expr @"} test expr-15.1 {CompileMathFuncCall: missing parenthesis} { catch {expr sinh2.0)} msg set errorInfo } {syntax error in expression "sinh2.0)" - while executing + while compiling "expr sinh2.0)"} test expr-15.2 {CompileMathFuncCall: unknown math function} { catch {expr whazzathuh(1)} msg set errorInfo } {unknown math function "whazzathuh" - while executing + while compiling "expr whazzathuh(1)"} test expr-15.3 {CompileMathFuncCall: too many arguments} { catch {expr sin(1,2,3)} msg set errorInfo } {too many arguments for math function - while executing + while compiling "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 +} {too few arguments for math function + while compiling "expr sin()"} test expr-15.5 {CompileMathFuncCall: too few arguments} { catch {expr pow(1)} msg set errorInfo } {too few arguments for math function - while executing + while compiling "expr pow(1)"} test expr-15.6 {CompileMathFuncCall: missing ')'} { catch {expr sin(1} msg set errorInfo } {syntax error in expression "sin(1" - while executing + while compiling "expr sin(1"} if $gotT1 { test expr-15.7 {CompileMathFuncCall: call registered math function} { @@ -667,4 +667,43 @@ test expr-19.1 {expr and interpreter result object resetting} { p } 3 +# Test for incorrect "double evaluation" semantics + +test expr-20.1 {wrong brace matching} { + catch {unset l} + catch {unset r} + catch {unset q} + catch {unset cmd} + catch {unset a} + set l "\{"; set r "\}"; set q "\"" + set cmd "expr $l$q|$q == $q$r$q$r" + list [catch $cmd a] $a +} {1 {extra characters after close-brace}} +test expr-20.2 {double invocation of variable traces} {knownBug} { + set exprtracecounter 0 + proc exprtraceproc {args} { + upvar #0 exprtracecounter counter + set argc [llength $args] + set extraargs [lrange $args 0 [expr {$argc - 4}]] + set name [lindex $args [expr {$argc - 3}]] + upvar 1 $name var + if {[incr counter] % 2 == 1} { + set var "$counter oops [concat $extraargs]" + } else { + set var "$counter + [concat $extraargs]" + } + } + trace variable exprtracevar r [list exprtraceproc 10] + list [catch {expr "$exprtracevar + 20"} a] $a \ + [catch {expr "$exprtracevar + 20"} b] $b \ + [unset exprtracevar exprtracecounter] +} {1 {syntax error in expression "1 oops 10 + 20"} 0 32 {}} +test expr-20.3 {broken substitution of integer digits} { + # fails with 8.0.x, but not 8.1b2 + list [set a 000; expr 0x1$a] [set a 1; expr ${a}000] +} {4096 1000} + +# cleanup unset a +::tcltest::cleanupTests +return diff --git a/tests/fCmd.test b/tests/fCmd.test index 2af1989..e1fc391 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -5,35 +5,46 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. +# Copyright (c) 1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fCmd.test,v 1.3 1998/12/04 04:18:20 hershey Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.4 1999/04/16 00:47:27 stanton Exp $ # -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[string compare testgetplatform [info commands testgetplatform]] != 0} { puts "This application hasn't been compiled with the \"testgetplatform\"" puts "command, therefore I am skipping all of these tests." + ::tcltest::cleanupTests return } 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." + ::tcltest::cleanupTests return } +# Several tests require need to match results against the unix username +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" + } +} + proc createfile {file {string a}} { set f [open $file w] puts -nonewline $f $string @@ -77,8 +88,8 @@ proc cleanup {args} { } foreach file $x { if {[catch {file delete -force -- $file}]} { - openup $file - file delete -force -- $file + catch {openup $file} + catch {file delete -force -- $file} } } } @@ -91,35 +102,27 @@ proc contents {file} { 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 +set ::tcltest::testConfig(fileSharing) 0 +set ::tcltest::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 + set ::tcltest::testConfig(fileSharing) 1 + set ::tcltest::testConfig(notFileSharing) 0 } file delete -force foo.dir } -set testConfig(xdev) 0 +set ::tcltest::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 ::tcltest::testConfig(xdev) 1 } } } @@ -137,77 +140,78 @@ append long $long append long $long append long $long -test fCmd-1.1 {TclFileRenameCmd} { +test fCmd-1.1 {TclFileRenameCmd} {notRoot} { cleanup createfile tf1 file rename tf1 tf2 glob tf* } {tf2} -test fCmd-2.1 {TclFileCopyCmd} { +test fCmd-2.1 {TclFileCopyCmd} {notRoot} { cleanup createfile tf1 file copy tf1 tf2 lsort [glob tf*] } {tf1 tf2} -test fCmd-3.1 {FileCopyRename: FileForceOption fails} { +test fCmd-3.1 {FileCopyRename: FileForceOption fails} {notRoot} { list [catch {file rename -xyz} msg] $msg } {1 {bad option "-xyz": should be -force or --}} -test fCmd-3.2 {FileCopyRename: not enough args} { +test fCmd-3.2 {FileCopyRename: not enough args} {notRoot} { 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} { +test fCmd-3.3 {FileCopyRename: Tcl_TranslateFileName fails} {notRoot} { list [catch {file rename xyz ~nonexistantuser} msg] $msg } {1 {user "nonexistantuser" doesn't exist}} -test fCmd-3.4 {FileCopyRename: Tcl_TranslateFileName passes} { +test fCmd-3.4 {FileCopyRename: Tcl_TranslateFileName passes} {notRoot} { 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} { +test fCmd-3.5 {FileCopyRename: target doesn't exist: stat(target) != 0} {notRoot} { 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)} { +test fCmd-3.6 {FileCopyRename: target tf3 is not a dir: !S_ISDIR(target)} \ + {notRoot} { 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} { +test fCmd-3.7 {FileCopyRename: target exists & is directory} {notRoot} { 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} { +test fCmd-3.8 {FileCopyRename: too many arguments: argc - i > 2} {notRoot} { 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} { +test fCmd-3.9 {FileCopyRename: too many arguments: argc - i > 2} {notRoot} { 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} { +test fCmd-3.10 {FileCopyRename: just 2 arguments} {notRoot} { cleanup createfile tf1 tf1 file rename tf1 tf2 contents tf2 } {tf1} -test fCmd-3.11 {FileCopyRename: just 2 arguments} { +test fCmd-3.11 {FileCopyRename: just 2 arguments} {notRoot} { cleanup createfile tf1 tf1 file rename -force -force -- tf1 tf2 contents tf2 } {tf1} -test fCmd-3.12 {FileCopyRename: move each source: 1 source} { +test fCmd-3.12 {FileCopyRename: move each source: 1 source} {notRoot} { 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} { +test fCmd-3.13 {FileCopyRename: move each source: multiple sources} {notRoot} { cleanup createfile tf1 tf1 createfile tf2 tf2 @@ -218,17 +222,17 @@ test fCmd-3.13 {FileCopyRename: move each source: multiple sources} { 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} { +test fCmd-3.14 {FileCopyRename: FileBasename fails} {notRoot} { 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} { +test fCmd-3.15 {FileCopyRename: source[0] == '\0'} {notRoot 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} { +test fCmd-3.16 {FileCopyRename: break on first error} {notRoot} { cleanup createfile tf1 createfile tf2 @@ -239,60 +243,62 @@ test fCmd-3.16 {FileCopyRename: break on first error} { 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} { +test fCmd-4.1 {TclFileMakeDirsCmd: make each dir: 1 dir} {notRoot} { cleanup file mkdir td1 glob td* } {td1} -test fCmd-4.2 {TclFileMakeDirsCmd: make each dir: multiple dirs} { +test fCmd-4.2 {TclFileMakeDirsCmd: make each dir: multiple dirs} {notRoot} { cleanup file mkdir td1 td2 td3 lsort [glob td*] } {td1 td2 td3} -test fCmd-4.3 {TclFileMakeDirsCmd: stops on first error} { +test fCmd-4.3 {TclFileMakeDirsCmd: stops on first error} {notRoot} { 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} { +test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName fails} {notRoot} { 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'} { +test fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\0'} \ + {notRoot} { 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} { +test fCmd-4.6 {TclFileMakeDirsCmd: one level deep} {notRoot} { cleanup file mkdir td1 glob td1 } {td1} -test fCmd-4.7 {TclFileMakeDirsCmd: multi levels deep} { +test fCmd-4.7 {TclFileMakeDirsCmd: multi levels deep} {notRoot} { 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} { +test fCmd-4.8 {TclFileMakeDirsCmd: already exist: lstat(target) == 0} {notRoot} { 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} { +test fCmd-4.9 {TclFileMakeDirsCmd: exists, not dir} {notRoot} { 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} { +test fCmd-4.10 {TclFileMakeDirsCmd: exists, is dir} {notRoot} { 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} { +test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} \ + {unixOnly notRoot} { cleanup file mkdir td1/td2/td3 testchmod 000 td1/td2 @@ -304,13 +310,14 @@ 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} { +test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} {notRoot} { cleanup set x [file exist td1] file mkdir td1 list $x [file exist td1] } {0 1} -test fCmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {unixOnly} { +test fCmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} \ + {unixOnly notRoot} { cleanup file delete -force foo file mkdir foo @@ -322,19 +329,19 @@ test fCmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {unixOnly} { 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} { +test fCmd-4.16 {TclFileMakeDirsCmd: TclpCreateDirectory succeeds} {notRoot} { cleanup file mkdir tf1 file exists tf1 } {1} -test fCmd-5.1 {TclFileDeleteCmd: FileForceOption fails} { +test fCmd-5.1 {TclFileDeleteCmd: FileForceOption fails} {notRoot} { list [catch {file delete -xyz} msg] $msg } {1 {bad option "-xyz": should be -force or --}} -test fCmd-5.2 {TclFileDeleteCmd: not enough args} { +test fCmd-5.2 {TclFileDeleteCmd: not enough args} {notRoot} { 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} { +test fCmd-5.3 {TclFileDeleteCmd: 1 file} {notRoot} { cleanup createfile tf1 createfile tf2 @@ -342,7 +349,7 @@ test fCmd-5.3 {TclFileDeleteCmd: 1 file} { file delete tf2 glob tf* td* } {tf1 td1} -test fCmd-5.4 {TclFileDeleteCmd: multiple files} { +test fCmd-5.4 {TclFileDeleteCmd: multiple files} {notRoot} { cleanup createfile tf1 createfile tf2 @@ -351,7 +358,7 @@ test fCmd-5.4 {TclFileDeleteCmd: multiple files} { 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} { +test fCmd-5.5 {TclFileDeleteCmd: stop at first error} {notRoot unixOrPc} { cleanup createfile tf1 createfile tf2 @@ -359,55 +366,55 @@ test fCmd-5.5 {TclFileDeleteCmd: stop at first error} {unixOrPc} { 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} { +test fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} {notRoot} { list [catch {file delete ~nonexistantuser} msg] $msg } {1 {user "nonexistantuser" doesn't exist}} -test fCmd-5.7 {TclFileDeleteCmd: Tcl_TranslateFileName succeeds} { +test fCmd-5.7 {TclFileDeleteCmd: Tcl_TranslateFileName succeeds} {notRoot} { catch {file delete ~/tf1} createfile ~/tf1 file delete ~/tf1 } {} -test fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} { +test fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} {notRoot} { cleanup set x [file exist tf1] file delete tf1 list $x [file exist tf1] } {0 0} -test fCmd-5.9 {TclFileDeleteCmd: is directory} { +test fCmd-5.9 {TclFileDeleteCmd: is directory} {notRoot} { cleanup file mkdir td1 file delete td1 file exist td1 } {0} -test fCmd-5.10 {TclFileDeleteCmd: TclpRemoveDirectory fails} { +test fCmd-5.10 {TclFileDeleteCmd: TclpRemoveDirectory fails} {notRoot} { 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} { +test fCmd-6.1 {CopyRenameOneFile: bad source} {notRoot} { # can't test this, because it's caught by FileCopyRename } {} -test fCmd-6.2 {CopyRenameOneFile: bad target} { +test fCmd-6.2 {CopyRenameOneFile: bad target} {notRoot} { # can't test this, because it's caught by FileCopyRename } {} -test fCmd-6.3 {CopyRenameOneFile: lstat(source) != 0} { +test fCmd-6.3 {CopyRenameOneFile: lstat(source) != 0} {notRoot} { 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} { +test fCmd-6.4 {CopyRenameOneFile: lstat(source) == 0} {notRoot} { cleanup createfile tf1 file rename tf1 tf2 glob tf* } {tf2} -test fCmd-6.5 {CopyRenameOneFile: lstat(target) != 0} { +test fCmd-6.5 {CopyRenameOneFile: lstat(target) != 0} {notRoot} { cleanup createfile tf1 file rename tf1 tf2 glob tf* } {tf2} -test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly} { +test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly notRoot} { cleanup file mkdir td1 testchmod 000 td1 @@ -426,45 +433,45 @@ test fCmd-6.8 {CopyRenameOneFile: errno != ENOENT} {macOnly} { 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} { +test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} {unixOnly notRoot} { cleanup createfile tf1 file rename tf1 tf2 glob tf* } {tf2} -test fCmd-6.10 {CopyRenameOneFile: lstat(target) == 0} { +test fCmd-6.10 {CopyRenameOneFile: lstat(target) == 0} {notRoot} { 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} { +test fCmd-6.11 {CopyRenameOneFile: force == 0} {notRoot} { 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} { +test fCmd-6.12 {CopyRenameOneFile: force != 0} {notRoot} { cleanup createfile tf1 createfile tf2 file rename -force tf1 tf2 glob tf* } {tf2} -test fCmd-6.13 {CopyRenameOneFile: source is dir, target is file} { +test fCmd-6.13 {CopyRenameOneFile: source is dir, target is file} {notRoot} { 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} { +test fCmd-6.14 {CopyRenameOneFile: source is file, target is dir} {notRoot} { 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} { +test fCmd-6.15 {CopyRenameOneFile: TclpRenameFile succeeds} {notRoot} { cleanup file mkdir [file join td1 td2] file mkdir td2 @@ -472,28 +479,26 @@ test fCmd-6.15 {CopyRenameOneFile: TclpRenameFile succeeds} { file rename -force td2 td1 file exists [file join td1 td2 tf1] } {1} -test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} { +test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} {notRoot} { 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. +test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} {notRoot} { 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} { +test fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} {notRoot} { 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} { +test fCmd-6.19 {CopyRenameOneFile: errno == EXDEV} {unixOnly notRoot} { cleanup /tmp createfile tf1 file rename tf1 /tmp @@ -510,19 +515,22 @@ test fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} {pcOnly} { set msg } } {d:/tcl8975@} -test fCmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} {unixOnly} { +test fCmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} \ + {unixOnly notRoot} { 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} { +test fCmd-6.22 {CopyRenameOneFile: copy/rename: !S_ISDIR(source)} \ + {unixOnly notRoot} { cleanup /tmp createfile tf1 file rename tf1 /tmp glob tf* /tmp/tf* } {/tmp/tf1} -test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly xdev} { +test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} \ + {unixOnly notRoot xdev} { cleanup /tmp file mkdir td1/td2/td3 exec chmod 000 td1 @@ -530,7 +538,8 @@ test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly xdev} { exec chmod 755 td1 set msg } {1 {error renaming "td1": permission denied}} -test fCmd-6.24 {CopyRenameOneFile: error uses original name} {unixOnly} { +test fCmd-6.24 {CopyRenameOneFile: error uses original name} \ + {unixOnly notRoot} { cleanup file mkdir ~/td1/td2 exec chmod 000 [file join [file dirname ~] [file tail ~] td1] @@ -539,7 +548,8 @@ test fCmd-6.24 {CopyRenameOneFile: error uses original name} {unixOnly} { file delete -force ~/td1 set msg } {1 {error copying "~/td1": permission denied}} -test fCmd-6.25 {CopyRenameOneFile: error uses original name} {unixOnly} { +test fCmd-6.25 {CopyRenameOneFile: error uses original name} \ + {unixOnly notRoot} { cleanup file mkdir td2 file mkdir ~/td1 @@ -549,7 +559,8 @@ test fCmd-6.25 {CopyRenameOneFile: error uses original name} {unixOnly} { 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} { +test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} \ + {unixOnly notRoot} { cleanup file mkdir ~/td1/td2 exec chmod 000 [file join [file dirname ~] [file tail ~] td1 td2] @@ -558,14 +569,16 @@ test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} {unixOnly} { 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} { +test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} \ + {unixOnly notRoot 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} { +test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} \ + {unixOnly notRoot xdev} { cleanup /tmp file mkdir td1/td2/td3 exec chmod 000 td1/td2/td3 @@ -573,65 +586,68 @@ test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly xdev} { 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} { +test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} \ + {unixOnly notRoot 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} { +test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} \ + {unixOnly notRoot} { 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}] + set catchResult [catch {file rename foo/bar /tmp} msg] + set msg [lindex [split $msg :] end] 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} { + list $catchResult $msg +} {1 { permission denied}} +test fCmd-6.31 {CopyRenameOneFile: TclpDeleteFile passed} \ + {unixOnly notRoot 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} { +test fCmd-6.32 {CopyRenameOneFile: copy} {notRoot} { 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} { +test fCmd-7.1 {FileForceOption: none} {notRoot} { 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} { +test fCmd-7.2 {FileForceOption: -force} {notRoot} { cleanup file mkdir [file join tf1 tf2] file delete -force tf1 } {} -test fCmd-7.3 {FileForceOption: --} { +test fCmd-7.3 {FileForceOption: --} {notRoot} { createfile -tf1 file delete -- -tf1 } {} -test fCmd-7.4 {FileForceOption: bad option} { +test fCmd-7.4 {FileForceOption: bad option} {notRoot} { 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} { +test fCmd-7.5 {FileForceOption: multiple times through loop} {notRoot} { 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} { +test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ + {unixOnly notRoot} { file mkdir td1 file attr td1 -perm 040000 set result [list [catch {file rename ~$user td1} msg] $msg] @@ -639,7 +655,7 @@ test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} {unixOn set result } "1 {error renaming \"~$user\" to \"td1/[file tail ~$user]\": permission denied}" -test fCmd-9.1 {file rename: comprehensive: EACCES} {unixOnly} { +test fCmd-9.1 {file rename: comprehensive: EACCES} {unixOnly notRoot} { cleanup file mkdir td1 file mkdir td2 @@ -649,11 +665,11 @@ test fCmd-9.1 {file rename: comprehensive: EACCES} {unixOnly} { 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} { +test fCmd-9.2 {file rename: comprehensive: source doesn't exist} {notRoot} { 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} { +test fCmd-9.3 {file rename: comprehensive: file to new name} {notRoot} { cleanup createfile tf1 createfile tf2 @@ -662,7 +678,7 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} { 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} { +test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc notRoot} { cleanup file mkdir td1 td2 testchmod 555 td2 @@ -670,7 +686,7 @@ test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc} { 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} { +test fCmd-9.5 {file rename: comprehensive: file to self} {notRoot} { cleanup createfile tf1 tf1 createfile tf2 tf2 @@ -679,7 +695,7 @@ test fCmd-9.5 {file rename: comprehensive: file to self} { 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} { +test fCmd-9.6 {file rename: comprehensive: dir to self} {notRoot unixOrPc} { cleanup file mkdir td1 file mkdir td2 @@ -688,7 +704,7 @@ test fCmd-9.6 {file rename: comprehensive: dir to self} {unixOrPc} { 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} { +test fCmd-9.7 {file rename: comprehensive: file to existing file} {notRoot} { cleanup createfile tf1 createfile tf2 @@ -711,7 +727,7 @@ test fCmd-9.7 {file rename: comprehensive: file to existing file} { 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} { +test fCmd-9.8 {file rename: comprehensive: dir to empty dir} {notRoot} { # Under unix, you can rename a read-only directory, but you can't # move it into another directory. @@ -749,7 +765,7 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} { 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} { +test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} {notRoot} { cleanup file mkdir tds1 file mkdir tds2 @@ -767,7 +783,7 @@ test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} { } 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} { +test fCmd-9.10 {file rename: comprehensive: file to new name and dir} {notRoot} { cleanup createfile tf1 createfile tf2 @@ -778,7 +794,7 @@ test fCmd-9.10 {file rename: comprehensive: file to new name and dir} { 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} { +test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} {notRoot} { cleanup file mkdir td1 file mkdir td2 @@ -796,7 +812,7 @@ test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} { 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} { +test fCmd-9.12 {file rename: comprehensive: target exists} {notRoot} { cleanup file mkdir [file join td1 td2] [file join td2 td1] if {$tcl_platform(platform) != "macintosh"} { @@ -811,34 +827,36 @@ test fCmd-9.12 {file rename: comprehensive: target exists} { } 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} { +test fCmd-9.13 {file rename: comprehensive: can't overwrite target} {notRoot} { 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} { +test fCmd-9.14 {file rename: comprehensive: dir into self} {notRoot} { 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} { +test fCmd-9.15 {file rename: comprehensive: source and target incompatible} \ + {notRoot} { 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} { +test fCmd-9.16 {file rename: comprehensive: source and target incompatible} \ + {notRoot} { 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} { +test fCmd-10.1 {file copy: comprehensive: source doesn't exist} {notRoot} { 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} { +test fCmd-10.2 {file copy: comprehensive: file to new name} {notRoot} { cleanup createfile tf1 tf1 createfile tf2 tf2 @@ -847,7 +865,7 @@ test fCmd-10.2 {file copy: comprehensive: file to new name} { 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} { +test fCmd-10.3 {file copy: comprehensive: dir to new name} {notRoot unixOrPc} { cleanup file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] @@ -862,7 +880,7 @@ test fCmd-10.3 {file copy: comprehensive: dir to new name} {unixOrPc} { } 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} { +test fCmd-10.4 {file copy: comprehensive: file to existing file} {notRoot} { cleanup createfile tf1 createfile tf2 @@ -885,7 +903,7 @@ test fCmd-10.4 {file copy: comprehensive: file to existing file} { 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} { +test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {notRoot} { cleanup file mkdir td1 file mkdir [file join td2 td1] @@ -910,7 +928,8 @@ test fCmd-10.5 {file copy: comprehensive: dir to empty dir} { 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} { +test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} \ + {notRoot unixOrPc} { cleanup file mkdir tds1 file mkdir tds2 @@ -921,7 +940,7 @@ test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} {unixOrPc} { 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} { +test fCmd-10.7 {file rename: comprehensive: file to new name and dir} {notRoot} { cleanup createfile tf1 createfile tf2 @@ -932,7 +951,8 @@ test fCmd-10.7 {file rename: comprehensive: file to new name and dir} { 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} { +test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} \ + {notRoot unixOrPc} { cleanup file mkdir td1 file mkdir td2 @@ -943,13 +963,15 @@ test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} {unixOrPc} 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} { +test fCmd-10.9 {file copy: comprehensive: source and target incompatible} \ + {notRoot} { 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} { +test fCmd-10.10 {file copy: comprehensive: source and target incompatible} \ + {notRoot} { cleanup file mkdir [file join td1 tf1] createfile tf1 @@ -959,7 +981,7 @@ cleanup # old tests -test fCmd-11.1 {TclFileRenameCmd: -- option } { +test fCmd-11.1 {TclFileRenameCmd: -- option } {notRoot} { catch {file delete -force -- -tfa1} set s [createfile -tfa1] file rename -- -tfa1 tfa2 @@ -968,7 +990,7 @@ test fCmd-11.1 {TclFileRenameCmd: -- option } { set result } {1} -test fCmd-11.2 {TclFileRenameCmd: bad option } { +test fCmd-11.2 {TclFileRenameCmd: bad option } {notRoot} { catch {file delete -force -- tfa1} set s [createfile tfa1] set r1 [catch {file rename -x tfa1 tfa2}] @@ -981,7 +1003,7 @@ test fCmd-11.3 {TclFileRenameCmd: bad \# args} { catch {file rename -- } } {1} -test fCmd-11.4 {TclFileRenameCmd: target filename translation failing} { +test fCmd-11.4 {TclFileRenameCmd: target filename translation failing} {notRoot} { global env set temp $env(HOME) unset env(HOME) @@ -990,7 +1012,7 @@ test fCmd-11.4 {TclFileRenameCmd: target filename translation failing} { set result } {1} -test fCmd-11.5 {TclFileRenameCmd: more than one source and target is not a directory} { +test fCmd-11.5 {TclFileRenameCmd: > 1 source & target is not a dir} {notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} createfile tfa1 createfile tfa2 @@ -1000,7 +1022,7 @@ test fCmd-11.5 {TclFileRenameCmd: more than one source and target is not a direc set result } {1} -test fCmd-11.6 {TclFileRenameCmd: : single file into directory } { +test fCmd-11.6 {TclFileRenameCmd: : single file into directory} {notRoot} { catch {file delete -force -- tfa1 tfad} set s [createfile tfa1] file mkdir tfad @@ -1010,7 +1032,7 @@ test fCmd-11.6 {TclFileRenameCmd: : single file into directory } { set result } {1} -test fCmd-11.7 {TclFileRenameCmd: : multiple files into directory } { +test fCmd-11.7 {TclFileRenameCmd: : multiple files into directory} {notRoot} { catch {file delete -force -- tfa1 tfa2 tfad} set s1 [createfile tfa1 ] set s2 [createfile tfa2 ] @@ -1025,7 +1047,7 @@ test fCmd-11.7 {TclFileRenameCmd: : multiple files into directory } { set result } {1} -test fCmd-11.8 {TclFileRenameCmd: error renaming file to directory } { +test fCmd-11.8 {TclFileRenameCmd: error renaming file to directory} {notRoot} { catch {file delete -force -- tfa tfad} set s [createfile tfa ] file mkdir tfad @@ -1041,7 +1063,7 @@ test fCmd-11.8 {TclFileRenameCmd: error renaming file to directory } { # # Coverage tests for renamefile() ; # -test fCmd-12.1 {renamefile: source filename translation failing} { +test fCmd-12.1 {renamefile: source filename translation failing} {notRoot} { global env set temp $env(HOME) unset env(HOME) @@ -1050,7 +1072,7 @@ test fCmd-12.1 {renamefile: source filename translation failing} { set result } {1} -test fCmd-12.2 {renamefile: src filename translation failing} { +test fCmd-12.2 {renamefile: src filename translation failing} {notRoot} { global env set temp $env(HOME) unset env(HOME) @@ -1062,13 +1084,13 @@ test fCmd-12.2 {renamefile: src filename translation failing} { set result } {1} -test fCmd-12.3 {renamefile: stat failing on source} { +test fCmd-12.3 {renamefile: stat failing on source} {notRoot} { 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 } { +test fCmd-12.4 {renamefile: error renaming file to directory} {notRoot} { catch {file delete -force -- tfa tfad} set s1 [createfile tfa ] file mkdir tfad @@ -1081,7 +1103,7 @@ test fCmd-12.4 {renamefile: error renaming file to directory } { set result } {1} -test fCmd-12.5 {renamefile: error renaming directory to file } { +test fCmd-12.5 {renamefile: error renaming directory to file} {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa file mkdir tfad @@ -1095,7 +1117,7 @@ test fCmd-12.5 {renamefile: error renaming directory to file } { set result } {1} -test fCmd-12.6 {renamefile: TclRenameFile succeeding } { +test fCmd-12.6 {renamefile: TclRenameFile succeeding} {notRoot} { catch {file delete -force -- tfa1 tfa2} set s [createfile tfa1] file rename tfa1 tfa2 @@ -1104,7 +1126,7 @@ test fCmd-12.6 {renamefile: TclRenameFile succeeding } { set result } {1} -test fCmd-12.7 {renamefile: renaming directory into offspring} { +test fCmd-12.7 {renamefile: renaming directory into offspring} {notRoot} { catch {file delete -force -- tfad} file mkdir tfad file mkdir tfad/dir @@ -1113,7 +1135,7 @@ test fCmd-12.7 {renamefile: renaming directory into offspring} { set result } {1} -test fCmd-12.8 {renamefile: generic error } {unixOnly} { +test fCmd-12.8 {renamefile: generic error} {unixOnly notRoot} { catch {file delete -force -- tfa} file mkdir tfa file mkdir tfa/dir @@ -1125,7 +1147,7 @@ test fCmd-12.8 {renamefile: generic error } {unixOnly} { } {1} -test fCmd-12.9 {renamefile: moving a file across volumes } {unixOnly} { +test fCmd-12.9 {renamefile: moving a file across volumes} {unixOnly notRoot} { catch {file delete -force -- tfa /tmp/tfa} set s [createfile tfa ] file rename tfa /tmp @@ -1134,7 +1156,8 @@ test fCmd-12.9 {renamefile: moving a file across volumes } {unixOnly} { set result } {1} -test fCmd-12.10 {renamefile: moving a directory across volumes } {unixOnly} { +test fCmd-12.10 {renamefile: moving a directory across volumes } \ + {unixOnly notRoot} { catch {file delete -force -- tfad /tmp/tfad} file mkdir tfad set s [createfile tfad/a ] @@ -1147,7 +1170,7 @@ test fCmd-12.10 {renamefile: moving a directory across volumes } {unixOnly} { # # Coverage tests for TclCopyFilesCmd() # -test fCmd-13.1 {TclCopyFilesCmd: -force option } { +test fCmd-13.1 {TclCopyFilesCmd: -force option} {notRoot} { catch {file delete -force -- tfa1} set s [createfile tfa1] file copy -force tfa1 tfa2 @@ -1156,7 +1179,7 @@ test fCmd-13.1 {TclCopyFilesCmd: -force option } { set result } {1} -test fCmd-13.2 {TclCopyFilesCmd: -- option } { +test fCmd-13.2 {TclCopyFilesCmd: -- option} {notRoot} { catch {file delete -force -- tfa1} set s [createfile -tfa1] file copy -- -tfa1 tfa2 @@ -1165,7 +1188,7 @@ test fCmd-13.2 {TclCopyFilesCmd: -- option } { set result } {1} -test fCmd-13.3 {TclCopyFilesCmd: bad option } { +test fCmd-13.3 {TclCopyFilesCmd: bad option} {notRoot} { catch {file delete -force -- tfa1} set s [createfile tfa1] set r1 [catch {file copy -x tfa1 tfa2}] @@ -1174,7 +1197,7 @@ test fCmd-13.3 {TclCopyFilesCmd: bad option } { set result } {1} -test fCmd-13.4 {TclCopyFilesCmd: bad \# args} { +test fCmd-13.4 {TclCopyFilesCmd: bad \# args} {notRoot} { catch {file copy -- } } {1} @@ -1187,7 +1210,7 @@ test fCmd-13.5 {TclCopyFilesCmd: target filename translation failing} { set result } {1} -test fCmd-13.6 {TclCopyFilesCmd: more than one source and target is not a directory} { +test fCmd-13.6 {TclCopyFilesCmd: > 1 source & target is not a dir} {notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} createfile tfa1 createfile tfa2 @@ -1197,7 +1220,7 @@ test fCmd-13.6 {TclCopyFilesCmd: more than one source and target is not a direct set result } {1} -test fCmd-13.7 {TclCopyFilesCmd: : single file into directory } { +test fCmd-13.7 {TclCopyFilesCmd: single file into directory} {notRoot} { catch {file delete -force -- tfa1 tfad} set s [createfile tfa1] file mkdir tfad @@ -1207,7 +1230,7 @@ test fCmd-13.7 {TclCopyFilesCmd: : single file into directory } { set result } {1} -test fCmd-13.8 {TclCopyFilesCmd: : multiple files into directory } { +test fCmd-13.8 {TclCopyFilesCmd: multiple files into directory} {notRoot} { catch {file delete -force -- tfa1 tfa2 tfad} set s1 [createfile tfa1 ] set s2 [createfile tfa2 ] @@ -1223,7 +1246,7 @@ test fCmd-13.8 {TclCopyFilesCmd: : multiple files into directory } { set result } {1} -test fCmd-13.9 {TclCopyFilesCmd: error copying file to directory } { +test fCmd-13.9 {TclCopyFilesCmd: error copying file to directory} {notRoot} { catch {file delete -force -- tfa tfad} set s [createfile tfa ] file mkdir tfad @@ -1239,7 +1262,7 @@ test fCmd-13.9 {TclCopyFilesCmd: error copying file to directory } { # # Coverage tests for copyfile() # -test fCmd-14.1 {copyfile: source filename translation failing} { +test fCmd-14.1 {copyfile: source filename translation failing} {notRoot} { global env set temp $env(HOME) unset env(HOME) @@ -1248,7 +1271,7 @@ test fCmd-14.1 {copyfile: source filename translation failing} { set result } {1} -test fCmd-14.2 {copyfile: dst filename translation failing} { +test fCmd-14.2 {copyfile: dst filename translation failing} {notRoot} { global env set temp $env(HOME) unset env(HOME) @@ -1261,13 +1284,13 @@ test fCmd-14.2 {copyfile: dst filename translation failing} { set result } {1} -test fCmd-14.3 {copyfile: stat failing on source} { +test fCmd-14.3 {copyfile: stat failing on source} {notRoot} { 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 } { +test fCmd-14.4 {copyfile: error copying file to directory} {notRoot} { catch {file delete -force -- tfa tfad} set s1 [createfile tfa ] file mkdir tfad @@ -1281,7 +1304,7 @@ test fCmd-14.4 {copyfile: error copying file to directory } { set result } {1} - test fCmd-14.5 {copyfile: error copying directory to file } { + test fCmd-14.5 {copyfile: error copying directory to file} {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa file mkdir tfad @@ -1295,7 +1318,7 @@ test fCmd-14.4 {copyfile: error copying file to directory } { set result } {1} -test fCmd-14.6 {copyfile: copy file succeeding } { +test fCmd-14.6 {copyfile: copy file succeeding} {notRoot} { catch {file delete -force -- tfa tfa2} set s [createfile tfa] file copy tfa tfa2 @@ -1304,7 +1327,7 @@ test fCmd-14.6 {copyfile: copy file succeeding } { set result } {1} -test fCmd-14.7 {copyfile: copy directory succeeding } { +test fCmd-14.7 {copyfile: copy directory succeeding} {notRoot} { catch {file delete -force -- tfa tfa2} file mkdir tfa set s [createfile tfa/file] @@ -1314,7 +1337,7 @@ test fCmd-14.7 {copyfile: copy directory succeeding } { set result } {1} -test fCmd-14.8 {copyfile: copy directory failing } {unixOnly} { +test fCmd-14.8 {copyfile: copy directory failing} {unixOnly notRoot} { catch {file delete -force -- tfa} file mkdir tfa/dir/a/b/c exec chmod 000 tfa/dir @@ -1328,7 +1351,7 @@ test fCmd-14.8 {copyfile: copy directory failing } {unixOnly} { # # Coverage tests for TclMkdirCmd() # -test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} { +test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} {notRoot} { global env set temp $env(HOME) unset env(HOME) @@ -1340,7 +1363,7 @@ test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} { # Can Tcl_SplitPath return argc == 0? If so them we need a # test for that code. # -test fCmd-15.2 {TclMakeDirsCmd - one directory } { +test fCmd-15.2 {TclMakeDirsCmd - one directory } {notRoot} { catch {file delete -force -- tfa} file mkdir tfa set result [file isdirectory tfa] @@ -1348,7 +1371,7 @@ test fCmd-15.2 {TclMakeDirsCmd - one directory } { set result } {1} -test fCmd-15.3 {TclMakeDirsCmd: - two directories } { +test fCmd-15.3 {TclMakeDirsCmd: - two directories} {notRoot} { catch {file delete -force -- tfa1 tfa2} file mkdir tfa1 tfa2 set result [expr [file isdirectory tfa1] && [file isdirectory tfa2]] @@ -1356,7 +1379,7 @@ test fCmd-15.3 {TclMakeDirsCmd: - two directories } { set result } {1} -test fCmd-15.4 {TclMakeDirsCmd - stat failing } {unixOnly} { +test fCmd-15.4 {TclMakeDirsCmd - stat failing} {unixOnly notRoot} { catch {file delete -force -- tfa} file mkdir tfa createfile tfa/file @@ -1367,7 +1390,8 @@ test fCmd-15.4 {TclMakeDirsCmd - stat failing } {unixOnly} { set result } {1} -test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep } { +test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep} \ + {notRoot} { catch {file delete -force -- tfa} file mkdir tfa/a/b/c set result [file isdir tfa/a/b/c] @@ -1376,7 +1400,7 @@ test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep } { } {1} -test fCmd-15.6 {TclMakeDirsCmd: - trying to overwrite a file } { +test fCmd-15.6 {TclMakeDirsCmd: - trying to overwrite a file} {notRoot} { catch {file delete -force -- tfa} set s [createfile tfa] set r1 [catch {file mkdir tfa}] @@ -1387,7 +1411,7 @@ test fCmd-15.6 {TclMakeDirsCmd: - trying to overwrite a file } { set result } {1} -test fCmd-15.7 {TclMakeDirsCmd - making several directories } { +test fCmd-15.7 {TclMakeDirsCmd - making several directories} {notRoot} { 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]] @@ -1395,7 +1419,7 @@ test fCmd-15.7 {TclMakeDirsCmd - making several directories } { set result } {1} -test fCmd-15.8 {TclFileMakeDirsCmd: trying to create an existing dir} { +test fCmd-15.8 {TclFileMakeDirsCmd: trying to create an existing dir} {notRoot} { file mkdir tfa file mkdir tfa set result [file isdir tfa] @@ -1405,21 +1429,21 @@ test fCmd-15.8 {TclFileMakeDirsCmd: trying to create an existing dir} { # Coverage tests for TclDeleteFilesCommand() -test fCmd-16.1 { test the -- argument } { +test fCmd-16.1 { test the -- argument } {notRoot} { catch {file delete -force -- tfa} createfile tfa file delete -- tfa file exists tfa } {0} -test fCmd-16.2 { test the -force and -- arguments } { +test fCmd-16.2 { test the -force and -- arguments } {notRoot} { catch {file delete -force -- tfa} createfile tfa file delete -force -- tfa file exists tfa } {0} -test fCmd-16.3 { test bad option } { +test fCmd-16.3 { test bad option } {notRoot} { catch {file delete -force -- tfa} createfile tfa set result [catch {file delete -dog tfa}] @@ -1427,15 +1451,15 @@ test fCmd-16.3 { test bad option } { set result } {1} -test fCmd-16.4 { test not enough args } { +test fCmd-16.4 { test not enough args } {notRoot} { catch {file delete} } {1} -test fCmd-16.5 { test not enough args with options } { +test fCmd-16.5 { test not enough args with options } {notRoot} { catch {file delete --} } {1} -test fCmd-16.6 {delete: source filename translation failing} { +test fCmd-16.6 {delete: source filename translation failing} {notRoot} { global env set temp $env(HOME) unset env(HOME) @@ -1444,7 +1468,7 @@ test fCmd-16.6 {delete: source filename translation failing} { set result } {1} -test fCmd-16.7 {remove a non-empty directory without -force } { +test fCmd-16.7 {remove a non-empty directory without -force } {notRoot} { catch {file delete -force -- tfa} file mkdir tfa createfile tfa/a @@ -1453,7 +1477,7 @@ test fCmd-16.7 {remove a non-empty directory without -force } { set result } {1} -test fCmd-16.8 {remove a normal file } { +test fCmd-16.8 {remove a normal file } {notRoot} { catch {file delete -force -- tfa} file mkdir tfa createfile tfa/a @@ -1462,7 +1486,7 @@ test fCmd-16.8 {remove a normal file } { set result } {1} -test fCmd-16.9 {error while deleting file } {unixOnly} { +test fCmd-16.9 {error while deleting file } {unixOnly notRoot} { catch {file delete -force -- tfa} file mkdir tfa createfile tfa/a @@ -1478,7 +1502,7 @@ test fCmd-16.9 {error while deleting file } {unixOnly} { set result } {1} -test fCmd-16.10 {deleting multiple files } { +test fCmd-16.10 {deleting multiple files} {notRoot} { catch {file delete -force -- tfa1 tfa2} createfile tfa1 createfile tfa2 @@ -1486,14 +1510,14 @@ test fCmd-16.10 {deleting multiple files } { expr ![file exists tfa1] && ![file exists tfa2] } {1} -test fCmd-16.11 { TclFileDeleteCmd: removing a nonexistant file} { +test fCmd-16.11 { TclFileDeleteCmd: removing a nonexistant file} {notRoot} { 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} { + test fCmd-17.1 {mkdir stat failing on target but not ENOENT} {unixOnly notRoot} { catch {file delete -force -- tfa1} file mkdir tfa1 exec chmod 555 tfa1 @@ -1503,7 +1527,7 @@ test fCmd-16.11 { TclFileDeleteCmd: removing a nonexistant file} { set result } {1} -test fCmd-17.2 {mkdir several levels deep - relative } { +test fCmd-17.2 {mkdir several levels deep - relative } {notRoot} { catch {file delete -force -- tfa} file mkdir tfa/a/b set result [file isdir tfa/a/b ] @@ -1511,7 +1535,7 @@ test fCmd-17.2 {mkdir several levels deep - relative } { set result } {1} -test fCmd-17.3 {mkdir several levels deep - absolute } { +test fCmd-17.3 {mkdir several levels deep - absolute } {notRoot} { catch {file delete -force -- tfa} set f [file join [pwd] tfa a ] file mkdir $f @@ -1524,7 +1548,8 @@ test fCmd-17.3 {mkdir several levels deep - absolute } { # Functionality tests for TclFileRenameCmd() # -test fCmd-18.1 {TclFileRenameCmd: rename (first form) in the same directory} { +test fCmd-18.1 {TclFileRenameCmd: rename (first form) in the same directory} \ + {notRoot} { catch {file delete -force -- tfad} file mkdir tfad/dir cd tfad/dir @@ -1544,7 +1569,7 @@ test fCmd-18.1 {TclFileRenameCmd: rename (first form) in the same directory} { set result } {1} -test fCmd-18.2 {TclFileRenameCmd: single dir to nonexistant } { +test fCmd-18.2 {TclFileRenameCmd: single dir to nonexistant} {notRoot} { catch {file delete -force -- tfa1 tfa2} file mkdir tfa1 file rename tfa1 tfa2 @@ -1553,7 +1578,7 @@ test fCmd-18.2 {TclFileRenameCmd: single dir to nonexistant } { set result } {1} -test fCmd-18.3 {TclFileRenameCmd: mixed dirs and files into directory } { +test fCmd-18.3 {TclFileRenameCmd: mixed dirs and files into directory} {notRoot} { catch {file delete -force -- tfa1 tfad1 tfad2} set s [createfile tfa1 ] file mkdir tfad1 tfad2 @@ -1566,7 +1591,7 @@ test fCmd-18.3 {TclFileRenameCmd: mixed dirs and files into directory } { set result } {1} -test fCmd-18.4 {TclFileRenameCmd: attempt to replace non-dir with dir } { +test fCmd-18.4 {TclFileRenameCmd: attempt to replace non-dir with dir} {notRoot} { catch {file delete -force -- tfa tfad} set s [createfile tfa ] file mkdir tfad @@ -1578,7 +1603,7 @@ test fCmd-18.4 {TclFileRenameCmd: attempt to replace non-dir with dir } { set result } {1} -test fCmd-18.5 {TclFileRenameCmd: attempt to replace dir with non-dir } { +test fCmd-18.5 {TclFileRenameCmd: attempt to replace dir with non-dir} {notRoot} { catch {file delete -force -- tfa tfad} set s [createfile tfa ] file mkdir tfad/tfa @@ -1593,7 +1618,7 @@ test fCmd-18.5 {TclFileRenameCmd: attempt to replace dir with non-dir } { # # 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} { +test fCmd-18.6 {TclFileRenameCmd: rename a file to itself} {macOrUnix notRoot} { catch {file delete -force -- tfa} set s [createfile tfa] set r1 [catch {file rename tfa tfa}] @@ -1602,7 +1627,8 @@ test fCmd-18.6 {TclFileRenameCmd: rename a file to itself} {macOrUnix} { set result } {1} -test fCmd-18.7 {TclFileRenameCmd: rename dir on top of another empty dir w/o -force} { +test fCmd-18.7 {TclFileRenameCmd: rename dir on top of another empty dir w/o -force} \ + {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa tfad/tfa set r1 [catch {file rename tfa tfad}] @@ -1611,7 +1637,8 @@ test fCmd-18.7 {TclFileRenameCmd: rename dir on top of another empty dir w/o -fo set result } {1} -test fCmd-18.8 {TclFileRenameCmd: rename dir on top of another empty dir w/ -force} { +test fCmd-18.8 {TclFileRenameCmd: rename dir on top of another empty dir w/ -force} \ + {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa tfad/tfa file rename -force tfa tfad @@ -1620,7 +1647,8 @@ test fCmd-18.8 {TclFileRenameCmd: rename dir on top of another empty dir w/ -for set result } {1} -test fCmd-18.9 {TclFileRenameCmd: rename dir on top of a non-empty dir w/o -force} { +test fCmd-18.9 {TclFileRenameCmd: rename dir on top of a non-empty dir w/o -force} \ + {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa tfad/tfa/file set r1 [catch {file rename tfa tfad}] @@ -1629,7 +1657,8 @@ test fCmd-18.9 {TclFileRenameCmd: rename dir on top of a non-empty dir w/o -forc set result } {1} -test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} { +test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} \ + {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa tfad/tfa/file set r1 [catch {file rename -force tfa tfad}] @@ -1638,13 +1667,14 @@ test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -forc set result } {1} -test fCmd-18.11 {TclFileRenameCmd: rename a non-existant file} { +test fCmd-18.11 {TclFileRenameCmd: rename a non-existant file} {notRoot} { 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} { +test fCmd-18.12 {TclFileRenameCmd : rename a symbolic link to file} \ + {unixOnly notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} set s [createfile tfa1] @@ -1656,7 +1686,8 @@ test fCmd-18.12 {TclFileRenameCmd : rename a symbolic link to file} {unixOnly} { set result } {1} -test fCmd-18.13 {TclFileRenameCmd : rename a symbolic link to dir} {unixOnly} { +test fCmd-18.13 {TclFileRenameCmd : rename a symbolic link to dir} \ + {unixOnly notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} file mkdir tfa1 @@ -1668,7 +1699,8 @@ test fCmd-18.13 {TclFileRenameCmd : rename a symbolic link to dir} {unixOnly} { set result } {1} -test fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} {unixOnly} { +test fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} \ + {unixOnly notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} file mkdir tfa1/a/b/c/d @@ -1684,7 +1716,8 @@ test fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} {unixOnly} { set result } {1} -test fCmd-18.15 {TclFileRenameCmd : rename a file to a symlink dir} {unixOnly} { +test fCmd-18.15 {TclFileRenameCmd : rename a file to a symlink dir} \ + {unixOnly notRoot} { catch {file delete -force -- tfa1 tfa2 tfalink} file mkdir tfa1 @@ -1697,7 +1730,7 @@ test fCmd-18.15 {TclFileRenameCmd : rename a file to a symlink dir} {unixOnly} { set result } {1} -test fCmd-18.16 {TclFileRenameCmd : rename a dangling symlink} {unixOnly} { +test fCmd-18.16 {TclFileRenameCmd: rename a dangling symlink} {unixOnly notRoot} { catch {file delete -force -- tfa1 tfalink} file mkdir tfa1 @@ -1713,14 +1746,14 @@ test fCmd-18.16 {TclFileRenameCmd : rename a dangling symlink} {unixOnly} { # # Coverage tests for TclUnixRmdir # -test fCmd-19.1 { remove empty directory } { +test fCmd-19.1 { remove empty directory } {notRoot} { catch {file delete -force -- tfa} file mkdir tfa file delete tfa file exists tfa } {0} -test fCmd-19.2 { rmdir error besides EEXIST} {unixOnly} { +test fCmd-19.2 { rmdir error besides EEXIST} {unixOnly notRoot} { catch {file delete -force -- tfa} file mkdir tfa file mkdir tfa/a @@ -1731,7 +1764,7 @@ test fCmd-19.2 { rmdir error besides EEXIST} {unixOnly} { set result } {1} -test fCmd-19.3 { recursive remove } { +test fCmd-19.3 { recursive remove } {notRoot} { catch {file delete -force -- tfa} file mkdir tfa file mkdir tfa/a @@ -1749,7 +1782,8 @@ test fCmd-19.3 { recursive remove } { # Coverage tests for TraverseUnixTree(), called from TclDeleteFilesCmd # -test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } {unixOnly} { +test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } \ + {unixOnly notRoot} { catch {file delete -force -- tfa} file mkdir tfa file mkdir tfa/a @@ -1764,7 +1798,7 @@ test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } {u # # Feature testing for TclCopyFilesCmd # -test fCmd-21.1 {copy : single file to nonexistant } { +test fCmd-21.1 {copy : single file to nonexistant } {notRoot} { catch {file delete -force -- tfa1 tfa2} set s [createfile tfa1] file copy tfa1 tfa2 @@ -1773,7 +1807,7 @@ test fCmd-21.1 {copy : single file to nonexistant } { set result } {1} -test fCmd-21.2 {copy : single dir to nonexistant } { +test fCmd-21.2 {copy : single dir to nonexistant } {notRoot} { catch {file delete -force -- tfa1 tfa2} file mkdir tfa1 file copy tfa1 tfa2 @@ -1782,7 +1816,7 @@ test fCmd-21.2 {copy : single dir to nonexistant } { set result } {1} -test fCmd-21.3 {copy : single file into directory } { +test fCmd-21.3 {copy : single file into directory } {notRoot} { catch {file delete -force -- tfa1 tfad} set s [createfile tfa1] file mkdir tfad @@ -1792,7 +1826,8 @@ test fCmd-21.3 {copy : single file into directory } { set result } {1} -test fCmd-21.4 {copy : more than one source and target is not a directory} { +test fCmd-21.4 {copy : more than one source and target is not a directory} \ + {notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} createfile tfa1 createfile tfa2 @@ -1802,7 +1837,7 @@ test fCmd-21.4 {copy : more than one source and target is not a directory} { set result } {1} -test fCmd-21.5 {copy : multiple files into directory } { +test fCmd-21.5 {copy : multiple files into directory } {notRoot} { catch {file delete -force -- tfa1 tfa2 tfad} set s1 [createfile tfa1 ] set s2 [createfile tfa2 ] @@ -1817,7 +1852,8 @@ test fCmd-21.5 {copy : multiple files into directory } { set result } {1} -test fCmd-21.6 {copy : mixed dirs and files into directory } {notFileSharing} { +test fCmd-21.6 {copy: mixed dirs and files into directory} \ + {notRoot notFileSharing} { catch {file delete -force -- tfa1 tfad1 tfad2} set s [createfile tfa1 ] file mkdir tfad1 tfad2 @@ -1830,7 +1866,7 @@ test fCmd-21.6 {copy : mixed dirs and files into directory } {notFileSharing} { set result } {1} -test fCmd-21.7 {TclCopyFilesCmd : copy a dangling link } {unixOnly} { +test fCmd-21.7 {TclCopyFilesCmd: copy a dangling link} {unixOnly notRoot} { file mkdir tfad1 exec ln -s tfad1 tfalink file delete tfad1 @@ -1840,7 +1876,7 @@ test fCmd-21.7 {TclCopyFilesCmd : copy a dangling link } {unixOnly} { set result } {1} -test fCmd-21.8 {TclCopyFilesCmd : copy a link } {unixOnly} { +test fCmd-21.8 {TclCopyFilesCmd : copy a link } {unixOnly notRoot} { file mkdir tfad1 exec ln -s tfad1 tfalink file copy tfalink tfalink2 @@ -1852,7 +1888,7 @@ test fCmd-21.8 {TclCopyFilesCmd : copy a link } {unixOnly} { set result } {1} -test fCmd-21.9 {TclCopyFilesCmd : copy dir with a link in it } {unixOnly} { +test fCmd-21.9 {TclCopyFilesCmd: copy dir with a link in it} {unixOnly notRoot} { file mkdir tfad1 exec ln -s "[pwd]/tfad1" tfad1/tfalink file copy tfad1 tfad2 @@ -1861,7 +1897,8 @@ test fCmd-21.9 {TclCopyFilesCmd : copy dir with a link in it } {unixOnly} { set result } {1} -test fCmd-21.10 {TclFileCopyCmd: copy dir on top of another empty dir w/o -force} { +test fCmd-21.10 {TclFileCopyCmd: copy dir on top of another empty dir w/o -force} \ + {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa [file join tfad tfa] set r1 [catch {file copy tfa tfad}] @@ -1870,7 +1907,7 @@ test fCmd-21.10 {TclFileCopyCmd: copy dir on top of another empty dir w/o -force set result } {1} -test fCmd-21.11 {TclFileCopyCmd: copy dir on top of a dir w/o -force} { +test fCmd-21.11 {TclFileCopyCmd: copy dir on top of a dir w/o -force} {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa [file join tfad tfa file] set r1 [catch {file copy tfa tfad}] @@ -1879,7 +1916,8 @@ test fCmd-21.11 {TclFileCopyCmd: copy dir on top of a dir w/o -force} { set result } {1} -test fCmd-21.12 {TclFileCopyCmd: copy dir on top of a non-empty dir w/ -force} { +test fCmd-21.12 {TclFileCopyCmd: copy dir on top of a non-empty dir w/ -force} \ + {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa [file join tfad tfa file] set r1 [catch {file copy -force tfa tfad}] @@ -1891,7 +1929,7 @@ test fCmd-21.12 {TclFileCopyCmd: copy dir on top of a non-empty dir w/ -force} { # # Coverage testing for TclpRenameFile # -test fCmd-22.1 { TclpRenameFile : rename and overwrite in a single dir } { +test fCmd-22.1 {TclpRenameFile: rename and overwrite in a single dir} {notRoot} { catch {file delete -force -- tfa1 tfa2} set s [createfile tfa1] set s2 [createfile tfa2 q] @@ -1903,7 +1941,7 @@ test fCmd-22.1 { TclpRenameFile : rename and overwrite in a single dir } { set result } {1} -test fCmd-22.2 { TclpRenameFile : attempt to overwrite itself } {macOrUnix} { +test fCmd-22.2 {TclpRenameFile: attempt to overwrite itself} {macOrUnix notRoot} { catch {file delete -force -- tfa1} set s [createfile tfa1] file rename -force tfa1 tfa1 @@ -1912,7 +1950,7 @@ test fCmd-22.2 { TclpRenameFile : attempt to overwrite itself } {macOrUnix} { set result } {1} -test fCmd-22.3 { TclpRenameFile : rename dir to existing dir } { +test fCmd-22.3 { TclpRenameFile : rename dir to existing dir } {notRoot} { catch {file delete -force -- d1 tfad} file mkdir d1 [file join tfad d1] set r1 [catch {file rename d1 tfad}] @@ -1921,7 +1959,7 @@ test fCmd-22.3 { TclpRenameFile : rename dir to existing dir } { set result } {1} -test fCmd-22.4 { TclpRenameFile : rename dir to dir several levels deep } { +test fCmd-22.4 {TclpRenameFile: rename dir to dir several levels deep} {notRoot} { 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] @@ -1934,7 +1972,7 @@ test fCmd-22.4 { TclpRenameFile : rename dir to dir several levels deep } { # # TclMacCopyFile needs to be redone. # -test fCmd-22.5 { TclMacCopyFile : copy and overwrite in a single dir } { +test fCmd-22.5 {TclMacCopyFile: copy and overwrite in a single dir} {notRoot} { catch {file delete -force -- tfa1 tfa2} set s [createfile tfa1] set s2 [createfile tfa2 q] @@ -1956,7 +1994,7 @@ test fCmd-22.5 { TclMacCopyFile : copy and overwrite in a single dir } { # Error cases are not covered. # -test fCmd-23.1 { TclMacRmdir : trying to remove a nonempty directory } { +test fCmd-23.1 {TclMacRmdir: trying to remove a nonempty directory} {notRoot} { catch {file delete -force -- tfad} file mkdir [file join tfad dir] @@ -1970,7 +2008,7 @@ test fCmd-23.1 { TclMacRmdir : trying to remove a nonempty directory } { # TclMacDeleteFile # Error cases are not covered. # -test fCmd-24.1 { TclMacDeleteFile : deleting a normal file } { +test fCmd-24.1 {TclMacDeleteFile: deleting a normal file} {notRoot} { catch {file delete -force -- tfa1} createfile tfa1 @@ -1982,7 +2020,8 @@ test fCmd-24.1 { TclMacDeleteFile : deleting a normal file } { # TclMacCopyDirectory # Error cases are not covered. # -test fCmd-25.1 { TclMacCopyDirectory : copying a normal directory} {notFileSharing} { +test fCmd-25.1 { TclMacCopyDirectory : copying a normal directory} \ + {notRoot notFileSharing} { catch {file delete -force -- tfad1 tfad2} file mkdir [file join tfad1 a b c] @@ -1992,7 +2031,8 @@ test fCmd-25.1 { TclMacCopyDirectory : copying a normal directory} {notFileShari set result } {1} -test fCmd-25.2 { TclMacCopyDirectory : copying a short path normal directory} {notFileSharing} { +test fCmd-25.2 { TclMacCopyDirectory : copying a short path normal directory} \ + {notRoot notFileSharing} { catch {file delete -force -- tfad1 tfad2} file mkdir tfad1 @@ -2002,7 +2042,8 @@ test fCmd-25.2 { TclMacCopyDirectory : copying a short path normal directory} {n set result } {1} -test fCmd-25.3 { TclMacCopyDirectory : copying dirs between different dirs} {notFileSharing} { +test fCmd-25.3 { TclMacCopyDirectory : copying dirs between different dirs} \ + {notRoot notFileSharing} { catch {file delete -force -- tfad1 tfad2} file mkdir [file join tfad1 x y z] @@ -2017,7 +2058,7 @@ test fCmd-25.3 { TclMacCopyDirectory : copying dirs between different dirs} {not # Functionality tests for TclDeleteFilesCmd # -test fCmd-26.1 { TclDeleteFilesCmd : delete symlink} {unixOnly} { +test fCmd-26.1 { TclDeleteFilesCmd : delete symlink} {unixOnly notRoot} { catch {file delete -force -- tfad1 tfad2} file mkdir tfad1 @@ -2032,7 +2073,7 @@ test fCmd-26.1 { TclDeleteFilesCmd : delete symlink} {unixOnly} { set result } {1} -test fCmd-26.2 { TclDeleteFilesCmd : delete dir with symlink} {unixOnly} { +test fCmd-26.2 { TclDeleteFilesCmd : delete dir with symlink} {unixOnly notRoot} { catch {file delete -force -- tfad1 tfad2} file mkdir tfad1 @@ -2048,7 +2089,7 @@ test fCmd-26.2 { TclDeleteFilesCmd : delete dir with symlink} {unixOnly} { set result } {1} -test fCmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly} { +test fCmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly notRoot} { catch {file delete -force -- tfad1 tfad2} file mkdir tfad1 @@ -2063,9 +2104,6 @@ test fCmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly} { set result } {1} -test fCmd-27.1 {TclFileAttrsCmd - wrong # args} { - list [catch {file attributes a b c d} msg] $msg -} {1 {wrong # args: must be "file attributes name ?option? ?value? ?option value? ..."}} test fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} { testsetplatform unix list [catch {file attributes ~_bad_user} msg] $msg [testsetplatform $platform] @@ -2082,27 +2120,45 @@ test fCmd-27.4 {TclFileAttrsCmd - getting one option} { 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 +# Find a group that exists on this Unix system, or else skip tests that +# require Unix groups. +if {$tcl_platform(platform) == "unix"} { + set ::tcltest::testConfig(foundGroup) 0 + catch { + set groupList [exec groups] + set group [lindex $groupList 0] + set ::tcltest::testConfig(foundGroup) 1 } +} else { + set ::tcltest::testConfig(foundGroup) 1 } -test fCmd-27.5 {TclFileAttrsCmd - setting one option} {tclGroup} { +test fCmd-27.5 {TclFileAttrsCmd - setting one option} {foundGroup} { 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} { +test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {foundGroup} { 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 cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/fileName.test b/tests/fileName.test index 287033f..426fd10 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -5,17 +5,21 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fileName.test,v 1.2 1998/09/14 18:40:09 stanton Exp $ +# RCS: @(#) $Id: fileName.test,v 1.3 1999/04/16 00:47:27 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} 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." + ::tcltest::cleanupTests return } @@ -1028,11 +1032,11 @@ test filename-10.22 {Tcl_TranslateFileName} { testsetplatform $platform -test filename-10.23 {Tcl_TranslateFileName} {nonPortable unixOnly} { +test filename-10.23 {Tcl_TranslateFileName} {unixOnly nonPortable} { # 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} { +test filename-10.24 {Tcl_TranslateFileName} {unixOnly nonPortable} { # this test fails if ~ouster is not /home/ouster list [catch {testtranslatefilename ~ouster/foo} msg] $msg } {0 /home/ouster/foo} @@ -1103,10 +1107,6 @@ 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]} @@ -1171,13 +1171,13 @@ test filename-13.7 {globbing with brace substitution} { 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} { +test filename-13.9 {globbing with brace substitution} { 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} { +test filename-13.10 {globbing with brace substitution} { 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} { +test filename-13.11 {globbing with brace substitution} {unixOrPc} { 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} { @@ -1214,12 +1214,9 @@ 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} { +test filename-14.1 {asterisks, question marks, and brackets} {unixOrPc} { 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} @@ -1229,30 +1226,21 @@ test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} { 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} { +test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc} { 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} { +test filename-14.7 {asterisks, question marks, and brackets} {unixOrPc} { 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} { +test filename-14.9 {asterisks, question marks, and brackets} {unixOrPc} { 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} @@ -1282,12 +1270,9 @@ test filename-14.17 {asterisks, question marks, and brackets} { 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} { +test filename-14.18 {asterisks, question marks, and brackets} {unixOrPc} { 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}} @@ -1308,142 +1293,137 @@ test filename-14.24 {slash globbing} {pcOnly} { } / # The following tests are only valid for Unix systems. +# On some systems, like AFS, "000" protection doesn't prevent +# access by owner, so the following test is not portable. -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. +catch {exec chmod 000 globTest/a1} +test filename-15.1 {unix specific globbing} {unixOnly 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} {unixOnly nonPortable} { + glob -nocomplain globTest/a1/* +} {} +test filename-15.3 {unix specific no complain: no errors, good result} \ + {unixOnly 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 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 -} +catch {exec chmod 755 globTest/a1} +test filename-15.4 {unix specific no complain: no errors, good result} \ + {unixOnly nonPortable knownBug} { + # test fails because if an error occurs, the interp's result + # is reset... or you don't run at scriptics where the + # outser and welch users exists + glob -nocomplain ~ouster ~foo ~welch +} {/home/ouster /home/welch} +test filename-15.5 {unix specific globbing} {unixOnly nonPortable} { + glob ~ouster/.csh* +} "/home/ouster/.cshrc" +catch {close [open globTest/odd\\\[\]*?\{\}name w]} +test filename-15.6 {unix specific globbing} {unixOnly} { + 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]] +catch {exec rm -f globTest/odd\\\[\]*?\{\}name} -# The following tests are only valid for Windows systems. -if {$tcl_platform(platform) == "windows"} { - set temp [pwd] +# The following tests are only valid for Windows systems. +set temp [pwd] +catch {cd c:/} +catch { 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 + makeDirectory globTest + close [open globTest/x1.BAT w] + close [open globTest/y1.Bat w] + close [open globTest/z1.bat w] +} - 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 +test filename-16.1 {windows specific globbing} {pcOnly} { + lsort [glob globTest/*.bat] +} {globTest/x1.BAT globTest/y1.Bat globTest/z1.bat} +test filename-16.2 {windows specific globbing} {pcOnly} { + glob c: +} c: +test filename-16.3 {windows specific globbing} {pcOnly} { + glob c:\\\\ +} c:/ +test filename-16.4 {windows specific globbing} {pcOnly} { + glob c:/ +} c:/ +test filename-16.5 {windows specific globbing} {pcOnly} { + glob c:*Test +} c:globTest +test filename-16.6 {windows specific globbing} {pcOnly} { + glob c:\\\\*Test +} c:/globTest +test filename-16.7 {windows specific globbing} {pcOnly} { + glob c:/*Test +} c:/globTest +test filename-16.8 {windows specific globbing} {pcOnly} { + lsort [glob c:globTest/*.bat] +} {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat} +test filename-16.9 {windows specific globbing} {pcOnly} { + lsort [glob c:/globTest/*.bat] +} {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat} +test filename-16.10 {windows specific globbing} {pcOnly} { + lsort [glob c:globTest\\\\*.bat] +} {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat} +test filename-16.11 {windows specific globbing} {pcOnly} { + lsort [glob c:\\\\globTest\\\\*.bat] +} {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat} - removeDirectory globTest - } +# some tests require a shared C drive - cd $temp +if {[catch {cd //[info hostname]/c}]} { + set ::tcltest::testConfig(sharedCdrive) 0 +} else { + set ::tcltest::testConfig(sharedCdrive) 1 } -removeDirectory globTest -set env(HOME) $oldhome +test filename-16.12 {windows specific globbing} {pcOnly sharedCdrive} { + cd //[info hostname]/c + removeDirectory globTest + makeDirectory globTest + close [open globTest/x1.BAT w] + close [open globTest/y1.Bat w] + close [open globTest/z1.bat w] + glob //[info hostname]/c/*Test +} //[info hostname]/c/globTest +test filename-16.13 {windows specific globbing} {pcOnly sharedCdrive} { + cd //[info hostname]/c + removeDirectory globTest + makeDirectory globTest + close [open globTest/x1.BAT w] + close [open globTest/y1.Bat w] + close [open globTest/z1.bat w] + glob "\\\\\\\\[info hostname]\\\\c\\\\*Test" +} //[info hostname]/c/globTest +# cleanup +file delete -force //[info hostname]/c/globTest +cd $temp +file delete -force globTest +set env(HOME) $oldhome testsetplatform $platform catch {unset oldhome platform temp result} -concat "" +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/for-old.test b/tests/for-old.test index c78ff2c..b2e2d39 100644 --- a/tests/for-old.test +++ b/tests/for-old.test @@ -12,9 +12,11 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: for-old.test,v 1.2 1998/09/14 18:40:09 stanton Exp $ +# RCS: @(#) $Id: for-old.test,v 1.3 1999/04/16 00:47:27 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # Check "for" and its use of continue and break. @@ -64,3 +66,19 @@ test for-old-1.9 {for tests} { } set a } {1 2 3} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/for.test b/tests/for.test index 609ca78..4503c0b 100644 --- a/tests/for.test +++ b/tests/for.test @@ -9,9 +9,11 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: for.test,v 1.2 1998/09/14 18:40:09 stanton Exp $ +# RCS: @(#) $Id: for.test,v 1.3 1999/04/16 00:47:27 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # Basic "for" operation. @@ -582,11 +584,169 @@ test for-4.1 {break must reset the interp result} { set j } {} -# Check "for" and computed command names. - -test for-5.1 {for and computed command names} { - set j 0 +# Basic "for" operation with computed command names. +test for-5.1 {for cmd with computed command names: missing initial command} { set z for - $z {set i 0} {$i<10} {incr i} {set j $i} - set j -} 9 + list [catch {$z} msg] $msg +} {1 {wrong # args: should be "for start test next command"}} +test for-5.2 {for cmd with computed command names: error in initial command} { + set z for + list [catch {$z {set}} msg] $msg $errorInfo +} {1 {wrong # args: should be "for start test next command"} {wrong # args: should be "for start test next command" + while executing +"$z {set}"}} +test for-5.3 {for cmd with computed command names: missing test expression} { + set z for + catch {$z {set i 0}} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-5.4 {for cmd with computed command names: error in test expression} { + set z for + catch {$z {set i 0} {$i<}} msg + set errorInfo +} {wrong # args: should be "for start test next command" + while executing +"$z {set i 0} {$i<}"} +test for-5.5 {for cmd with computed command names: test expression is enclosed in quotes} { + set z for + set i 0 + $z {} "$i > 5" {incr i} {} +} {} +test for-5.6 {for cmd with computed command names: missing "next" command} { + set z for + catch {$z {set i 0} {$i < 5}} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-5.7 {for cmd with computed command names: missing command body} { + set z for + catch {$z {set i 0} {$i < 5} {incr i}} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-5.8 {for cmd with computed command names: error executing command body} { + set z for + catch {$z {set i 0} {$i < 5} {incr i} {set}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("for" body line 1) + invoked from within +"$z {set i 0} {$i < 5} {incr i} {set}"} +test for-5.9 {for cmd with computed command names: simple command body} { + set z for + set a {} + $z {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 break + set a [concat $a $i] + } + set a +} {1 2 3} +test for-5.10 {for cmd with computed command names: command body in quotes} { + set z for + set a {} + $z {set i 1} {$i<6} {set i [expr $i+1]} "append a x" + set a +} {xxxxx} +test for-5.11 {for cmd with computed command names: computed command body} { + set z for + catch {unset x1} + catch {unset bb} + catch {unset x2} + set x1 {append a x1; } + set bb {break} + set x2 {; append a x2} + set a {} + $z {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2 + set a +} {x1} +test for-5.12 {for cmd with computed command names: error in "next" command} { + set z for + catch {$z {set i 0} {$i < 5} {set} {set j 4}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("for" loop-end command) + invoked from within +"$z {set i 0} {$i < 5} {set} {set j 4}"} +test for-5.13 {for cmd with computed command names: long command body} { + set z for + set a {} + $z {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + } + set a +} {1 2 3} +test for-5.14 {for cmd with computed command names: for command result} { + set z for + set a [$z {set i 0} {$i < 5} {incr i} {}] + set a +} {} +test for-5.15 {for cmd with computed command names: for command result} { + set z for + set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}] + set a +} {} + +# Test for incorrect "double evaluation" semantics + +test for-6.1 {possible delayed substitution of increment command} {knownBug} { + # Increment should be 5, and lappend should always append 5 + catch {unset a} + catch {unset i} + set a 5 + set i {} + for {set a 1} {$a < 12} "incr a $a" {lappend i $a} + set i +} {1 6 11} + +test for-6.2 {possible delayed substitution of body command} {knownBug} { + # Increment should be 5, and lappend should always append 5 + set a 5 + set i {} + for {set a 1} {$a < 12} {incr a $a} "lappend i $a" + set i +} {5 5 5 5} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/foreach.test b/tests/foreach.test index 7d7b8b5..66e626e 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -10,9 +10,11 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: foreach.test,v 1.2 1998/09/14 18:40:09 stanton Exp $ +# RCS: @(#) $Id: foreach.test,v 1.3 1999/04/16 00:47:27 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {unset a} catch {unset x} @@ -208,5 +210,33 @@ test foreach-5.4 {break tests} { set msg } {wrong # args: should be "break"} +# Test for incorrect "double evaluation" semantics + +test foreach-6.1 {delayed substitution of body} {knownBug} { + proc foo {} { + set a 0 + foreach a [list 1 2 3] " + set x $a + " + set x + } + foo +} {0} + +# cleanup catch {unset a} catch {unset x} +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/format.test b/tests/format.test index e3d8be0..2b52187 100644 --- a/tests/format.test +++ b/tests/format.test @@ -5,14 +5,16 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: format.test,v 1.3 1998/11/02 23:04:13 stanton Exp $ +# RCS: @(#) $Id: format.test,v 1.4 1999/04/16 00:47:28 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # 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 @@ -78,291 +80,337 @@ test format-2.3 {string formatting} { 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-2.5 {string formatting, embedded nulls} { + format "%10s" abc\0def +} " abc\0def" +test format-2.6 {string formatting, international chars} { + format "%10s" abc\ufeffdef +} " abc\ufeffdef" +test format-2.6 {string formatting, international chars} { + format "%.5s" abc\ufeffdef +} "abc\ufeffd" +test format-2.7 {string formatting, international chars} { + format "foo\ufeffbar%s" baz +} "foo\ufeffbarbaz" +test format-2.8 {string formatting, width} { + format "a%5sa" f +} "a fa" +test format-2.8 {string formatting, width} { + format "a%-5sa" f +} "af a" +test format-2.8 {string formatting, width} { + format "a%2sa" foo +} "afooa" +test format-2.8 {string formatting, width} { + format "a%0sa" foo +} "afooa" +test format-2.8 {string formatting, precision} { + format "a%.2sa" foobarbaz +} "afoa" +test format-2.8 {string formatting, precision} { + format "a%.sa" foobarbaz +} "aa" +test format-2.8 {string formatting, precision} { + list [catch {format "a%.-2sa" foobarbaz} msg] $msg +} {1 {bad field specifier "-"}} +test format-2.8 {string formatting, width and precision} { + format "a%5.2sa" foobarbaz +} "a foa" +test format-2.8 {string formatting, width and precision} { + format "a%5.7sa" foobarbaz +} "afoobarba" + +test format-3.1 {Tcl_FormatObjCmd: character formatting} { + format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 65 65 65 65 65 65 3 65 -4 65 +} "|A|A|A|A|A | A| A|A |" +test format-3.2 {Tcl_FormatObjCmd: international character formatting} { + format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 0xa2 0x4e4e 0x25a 0xc3 0xff08 0 3 0x6575 -4 0x4e4f +} "|\ua2|\u4e4e|\u25a|\uc3|\uff08 | \0| \u6575|\u4e4f |" -test format-3.1 {e and f formats} {eformat} { +test format-4.1 {e and f formats} {eformat} { format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053 } {3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} -test format-3.2 {e and f formats} {eformat} { +test format-4.2 {e and f formats} {eformat} { format "%20e %20e %20e %20e" 34.2e12 68.514 -.125 -16000. .000053 } { 3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} if {!$roundOffBug} { - test format-3.3 {e and f formats} {eformat} { + test format-4.3 {e and f formats} {eformat} { format "%.1e %.1e %.1e %.1e" 34.2e12 68.514 -.126 -16000. .000053 } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04} - test format-3.4 {e and f formats} {eformat} { + test format-4.4 {e and f formats} {eformat} { format "%020e %020e %020e %020e" 34.2e12 68.514 -.126 -16000. .000053 } {000000003.420000e+13 000000006.851400e+01 -00000001.260000e-01 -00000001.600000e+04} - test format-3.5 {e and f formats} {eformat} { + test format-4.5 {e and f formats} {eformat} { format "%7.1e %7.1e %7.1e %7.1e" 34.2e12 68.514 -.126 -16000. .000053 } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04} - test format-3.6 {e and f formats} { + test format-4.6 {e and f formats} { format "%f %f %f %f" 34.2e12 68.514 -.125 -16000. .000053 } {34200000000000.000000 68.514000 -0.125000 -16000.000000} } -test format-3.7 {e and f formats} {nonPortable} { +test format-4.7 {e and f formats} {nonPortable} { format "%.4f %.4f %.4f %.4f %.4f" 34.2e12 68.514 -.125 -16000. .000053 } {34200000000000.0000 68.5140 -0.1250 -16000.0000 0.0001} -test format-3.8 {e and f formats} {eformat} { +test format-4.8 {e and f formats} {eformat} { format "%.4e %.5e %.6e" -9.99996 -9.99996 9.99996 } {-1.0000e+01 -9.99996e+00 9.999960e+00} -test format-3.9 {e and f formats} { +test format-4.9 {e and f formats} { format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996 } {-10.0000 -9.99996 9.999960} -test format-3.10 {e and f formats} { +test format-4.10 {e and f formats} { format "%20f %-20f %020f" -9.99996 -9.99996 9.99996 } { -9.999960 -9.999960 0000000000009.999960} -test format-3.11 {e and f formats} { +test format-4.11 {e and f formats} { format "%-020f %020f" -9.99996 -9.99996 9.99996 } {-9.999960 -000000000009.999960} -test format-3.12 {e and f formats} {eformat} { +test format-4.12 {e and f formats} {eformat} { format "%.0e %#.0e" -9.99996 -9.99996 9.99996 } {-1e+01 -1.e+01} -test format-3.13 {e and f formats} { +test format-4.13 {e and f formats} { format "%.0f %#.0f" -9.99996 -9.99996 9.99996 } {-10 -10.} -test format-3.14 {e and f formats} { +test format-4.14 {e and f formats} { format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996 } {-10.0000 -9.99996 9.999960} -test format-3.15 {e and f formats} { +test format-4.15 {e and f formats} { format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001 } { 1 1 1 1} -test format-3.16 {e and f formats} { +test format-4.16 {e and f formats} { format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001 } {0.0 0.1 0.0 0.0} -test format-4.1 {g-format} {eformat} { +test format-5.1 {g-format} {eformat} { format "%.3g" 12341.0 } {1.23e+04} -test format-4.2 {g-format} {eformat} { +test format-5.2 {g-format} {eformat} { format "%.3G" 1234.12345 } {1.23E+03} -test format-4.3 {g-format} { +test format-5.3 {g-format} { format "%.3g" 123.412345 } {123} -test format-4.4 {g-format} { +test format-5.4 {g-format} { format "%.3g" 12.3412345 } {12.3} -test format-4.5 {g-format} { +test format-5.5 {g-format} { format "%.3g" 1.23412345 } {1.23} -test format-4.6 {g-format} { +test format-5.6 {g-format} { format "%.3g" 1.23412345 } {1.23} -test format-4.7 {g-format} { +test format-5.7 {g-format} { format "%.3g" .123412345 } {0.123} -test format-4.8 {g-format} { +test format-5.8 {g-format} { format "%.3g" .012341 } {0.0123} -test format-4.9 {g-format} { +test format-5.9 {g-format} { format "%.3g" .0012341 } {0.00123} -test format-4.10 {g-format} { +test format-5.10 {g-format} { format "%.3g" .00012341 } {0.000123} -test format-4.11 {g-format} {eformat} { +test format-5.11 {g-format} {eformat} { format "%.3g" .00001234 } {1.23e-05} -test format-4.12 {g-format} {eformat} { +test format-5.12 {g-format} {eformat} { format "%.4g" 9999.6 } {1e+04} -test format-4.13 {g-format} { +test format-5.13 {g-format} { format "%.4g" 999.96 } {1000} -test format-4.14 {g-format} { +test format-5.14 {g-format} { format "%.3g" 1.0 } {1} -test format-4.15 {g-format} { +test format-5.15 {g-format} { format "%.3g" .1 } {0.1} -test format-4.16 {g-format} { +test format-5.16 {g-format} { format "%.3g" .01 } {0.01} -test format-4.17 {g-format} { +test format-5.17 {g-format} { format "%.3g" .001 } {0.001} -test format-4.18 {g-format} {eformat} { +test format-5.18 {g-format} {eformat} { format "%.3g" .00001 } {1e-05} -test format-4.19 {g-format} {eformat} { +test format-5.19 {g-format} {eformat} { format "%#.3g" 1234.0 } {1.23e+03} -test format-4.20 {g-format} {eformat} { +test format-5.20 {g-format} {eformat} { format "%#.3G" 9999.5 } {1.00E+04} -test format-5.1 {floating-point zeroes} {eformat} { +test format-6.1 {floating-point zeroes} {eformat} { format "%e %f %g" 0.0 0.0 0.0 0.0 } {0.000000e+00 0.000000 0} -test format-5.2 {floating-point zeroes} {eformat} { +test format-6.2 {floating-point zeroes} {eformat} { format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0 } {0.0000e+00 0.0000 0} -test format-5.3 {floating-point zeroes} {eformat} { +test format-6.3 {floating-point zeroes} {eformat} { format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0 } {0.0000e+00 0.0000 0.000} -test format-5.4 {floating-point zeroes} {eformat} { +test format-6.4 {floating-point zeroes} {eformat} { format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0 } {0e+00 0 0} -test format-5.5 {floating-point zeroes} {eformat} { +test format-6.5 {floating-point zeroes} {eformat} { format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0 } {0.e+00 0. 0.} -test format-5.6 {floating-point zeroes} { +test format-6.6 {floating-point zeroes} { format "%3.0f %3.0f %3.0f %3.0f" 0.0 0.0 0.0 0.0 } { 0 0 0 0} -test format-5.7 {floating-point zeroes} { +test format-6.7 {floating-point zeroes} { format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001 } { 1 1 1 1} -test format-5.8 {floating-point zeroes} { +test format-6.8 {floating-point zeroes} { format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001 } {0.0 0.1 0.0 0.0} -test format-6.1 {various syntax features} { +test format-7.1 {various syntax features} { format "%*.*f" 12 3 12.345678901 } { 12.346} -test format-6.2 {various syntax features} { +test format-7.2 {various syntax features} { format "%0*.*f" 12 3 12.345678901 } {00000012.346} -test format-6.3 {various syntax features} { +test format-7.3 {various syntax features} { format "\*\t\\n" } {* \n} -test format-7.1 {error conditions} { +test format-8.1 {error conditions} { catch format } 1 -test format-7.2 {error conditions} { +test format-8.2 {error conditions} { catch format msg set msg } {wrong # args: should be "format formatString ?arg arg ...?"} -test format-7.3 {error conditions} { +test format-8.3 {error conditions} { catch {format %*d} } 1 -test format-7.4 {error conditions} { +test format-8.4 {error conditions} { catch {format %*d} msg set msg } {not enough arguments for all format specifiers} -test format-7.5 {error conditions} { +test format-8.5 {error conditions} { catch {format %*.*f 12} } 1 -test format-7.6 {error conditions} { +test format-8.6 {error conditions} { catch {format %*.*f 12} msg set msg } {not enough arguments for all format specifiers} -test format-7.7 {error conditions} { +test format-8.7 {error conditions} { catch {format %*.*f 12 3} } 1 -test format-7.8 {error conditions} { +test format-8.8 {error conditions} { catch {format %*.*f 12 3} msg set msg } {not enough arguments for all format specifiers} -test format-7.9 {error conditions} { +test format-8.9 {error conditions} { list [catch {format %*d x 3} msg] $msg } {1 {expected integer but got "x"}} -test format-7.10 {error conditions} { +test format-8.10 {error conditions} { list [catch {format %*.*f 2 xyz 3} msg] $msg } {1 {expected integer but got "xyz"}} -test format-7.11 {error conditions} { +test format-8.11 {error conditions} { catch {format %d 2a} } 1 -test format-7.12 {error conditions} { +test format-8.12 {error conditions} { catch {format %d 2a} msg set msg } {expected integer but got "2a"} -test format-7.13 {error conditions} { +test format-8.13 {error conditions} { catch {format %c 2x} } 1 -test format-7.14 {error conditions} { +test format-8.14 {error conditions} { catch {format %c 2x} msg set msg } {expected integer but got "2x"} -test format-7.15 {error conditions} { +test format-8.15 {error conditions} { catch {format %f 2.1z} } 1 -test format-7.16 {error conditions} { +test format-8.16 {error conditions} { catch {format %f 2.1z} msg set msg } {expected floating-point number but got "2.1z"} -test format-7.17 {error conditions} { +test format-8.17 {error conditions} { catch {format ab%} } 1 -test format-7.18 {error conditions} { +test format-8.18 {error conditions} { catch {format ab% 12} msg set msg } {format string ended in middle of field specifier} -test format-7.19 {error conditions} { +test format-8.19 {error conditions} { catch {format %q x} } 1 -test format-7.20 {error conditions} { +test format-8.20 {error conditions} { catch {format %q x} msg set msg } {bad field specifier "q"} -test format-7.21 {error conditions} { +test format-8.21 {error conditions} { catch {format %d} } 1 -test format-7.22 {error conditions} { +test format-8.22 {error conditions} { catch {format %d} msg set msg } {not enough arguments for all format specifiers} -test format-7.23 {error conditions} { +test format-8.23 {error conditions} { catch {format "%d %d" 24 xyz} msg set msg } {expected integer but got "xyz"} -test format-8.1 {long result} { +test format-9.1 {long result} { set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s} $a $a } {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} -test format-9.1 {"h" format specifier} {nonPortable} { +test format-10.1 {"h" format specifier} {nonPortable} { format %hd 0xffff } -1 -test format-9.2 {"h" format specifier} {nonPortable} { +test format-10.2 {"h" format specifier} {nonPortable} { format %hx 0x10fff } fff -test format-9.3 {"h" format specifier} {nonPortable} { +test format-10.3 {"h" format specifier} {nonPortable} { format %hd 0x10000 } 0 -test format-10.1 {XPG3 %$n specifiers} { +test format-11.1 {XPG3 %$n specifiers} { format {%2$d %1$d} 4 5 } {5 4} -test format-10.2 {XPG3 %$n specifiers} { +test format-11.2 {XPG3 %$n specifiers} { format {%2$d %1$d %1$d %3$d} 4 5 6 } {5 4 4 6} -test format-10.3 {XPG3 %$n specifiers} { +test format-11.3 {XPG3 %$n specifiers} { list [catch {format {%2$d %3$d} 4 5} msg] $msg } {1 {"%n$" argument index out of range}} -test format-10.4 {XPG3 %$n specifiers} { +test format-11.4 {XPG3 %$n specifiers} { list [catch {format {%2$d %0$d} 4 5 6} msg] $msg } {1 {"%n$" argument index out of range}} -test format-10.5 {XPG3 %$n specifiers} { +test format-11.5 {XPG3 %$n specifiers} { list [catch {format {%d %1$d} 4 5 6} msg] $msg } {1 {cannot mix "%" and "%n$" conversion specifiers}} -test format-10.6 {XPG3 %$n specifiers} { +test format-11.6 {XPG3 %$n specifiers} { list [catch {format {%2$d %d} 4 5 6} msg] $msg } {1 {cannot mix "%" and "%n$" conversion specifiers}} -test format-10.7 {XPG3 %$n specifiers} { +test format-11.7 {XPG3 %$n specifiers} { list [catch {format {%2$d %3d} 4 5 6} msg] $msg } {1 {cannot mix "%" and "%n$" conversion specifiers}} -test format-10.8 {XPG3 %$n specifiers} { +test format-11.8 {XPG3 %$n specifiers} { format {%2$*d %3$d} 1 10 4 } { 4 4} -test format-10.9 {XPG3 %$n specifiers} { +test format-11.9 {XPG3 %$n specifiers} { format {%2$.*s %4$d} 1 5 abcdefghijklmnop 44 } {abcde 44} -test format-10.10 {XPG3 %$n specifiers} { +test format-11.10 {XPG3 %$n specifiers} { list [catch {format {%2$*d} 4} msg] $msg } {1 {"%n$" argument index out of range}} -test format-10.11 {XPG3 %$n specifiers} { +test format-11.11 {XPG3 %$n specifiers} { list [catch {format {%2$*d} 4 5} msg] $msg } {1 {"%n$" argument index out of range}} -test format-10.12 {XPG3 %$n specifiers} { +test format-11.12 {XPG3 %$n specifiers} { list [catch {format {%2$*d} 4 5 6} msg] $msg } {0 { 6}} -test format-11.1 {negative width specifiers} { +test format-12.1 {negative width specifiers} { format "%*d" -47 25 -} {25} -test format-12.1 {tcl_precision fuzzy comparison} { +} {25 } +test format-13.1 {tcl_precision fuzzy comparison} { catch {unset a} catch {unset b} catch {unset c} @@ -373,7 +421,7 @@ test format-12.1 {tcl_precision fuzzy comparison} { set d [expr $a + $b + $c] format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d } {0.0000000000 0.000000000000 0.000000000000110 0.00000000000011001} -test format-12.2 {tcl_precision fuzzy comparison} { +test format-13.2 {tcl_precision fuzzy comparison} { catch {unset a} catch {unset b} catch {unset c} @@ -384,7 +432,7 @@ test format-12.2 {tcl_precision fuzzy comparison} { set d [expr $a + $b + $c] format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d } {0.0000000000 0.000000000001 0.000000000001006 0.00000000000100580} -test format-12.3 {tcl_precision fuzzy comparison} { +test format-13.3 {tcl_precision fuzzy comparison} { catch {unset a} catch {unset b} catch {unset c} @@ -393,7 +441,7 @@ test format-12.3 {tcl_precision fuzzy comparison} { set c [expr $a + $b] format {%0.10f %0.12f %0.15f %0.17f} $c $c $c $c } {0.0000000000 0.000000000001 0.000000000001001 0.00000000000100100} -test format-12.4 {tcl_precision fuzzy comparison} { +test format-13.4 {tcl_precision fuzzy comparison} { catch {unset a} catch {unset b} catch {unset c} @@ -402,7 +450,7 @@ test format-12.4 {tcl_precision fuzzy comparison} { set c [expr $a + $b] format {%0.10f %0.12f %0.15f %0.16f} $c $c $c $c } {0.7777777778 0.777777777777 0.777777777777330 0.7777777777773300} -test format-12.5 {tcl_precision fuzzy comparison} { +test format-13.5 {tcl_precision fuzzy comparison} { catch {unset a} catch {unset b} catch {unset c} @@ -411,10 +459,10 @@ test format-12.5 {tcl_precision fuzzy comparison} { set c [expr $a + $b] format {%0.10f %0.12f %0.15f} $c $c $c } {1.4444444444 1.444444444444 1.444444444443990} -test format-13.1 {testing MAX_FLOAT_SIZE for 0 and 1} { +test format-14.1 {testing MAX_FLOAT_SIZE for 0 and 1} { format {%s} "" } {} -test format-13.2 {testing MAX_FLOAT_SIZE for 0 and 1} { +test format-14.2 {testing MAX_FLOAT_SIZE for 0 and 1} { format {%s} "a" } {a} @@ -424,15 +472,28 @@ for {set i 0} {$i < 290} {incr i} { append b $a } for {set i 290} {$i < 400} {incr i} { - test format-14.[expr $i -290] {testing MAX_FLOAT_SIZE} { + test format-15.[expr $i -290] {testing MAX_FLOAT_SIZE} { format {%s} $b } $b append b "x" } - +# cleanup catch {unset a} catch {unset b} catch {unset c} catch {unset d} +::tcltest::cleanupTests return + + + + + + + + + + + + diff --git a/tests/get.test b/tests/get.test index bf746aa..261cf19 100644 --- a/tests/get.test +++ b/tests/get.test @@ -5,13 +5,16 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: get.test,v 1.2 1998/09/14 18:40:09 stanton Exp $ +# RCS: @(#) $Id: get.test,v 1.3 1999/04/16 00:47:28 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test get-1.1 {Tcl_GetInt procedure} { set x 44 @@ -39,39 +42,39 @@ test get-1.6 {Tcl_GetInt procedure} { } {1 {expected integer but got "16 x"}} # The following tests are non-portable because they depend on -# word size. 18446744073709551614 +# word size. if {0x80000000 > 0} { - test get-1.7 {Tcl_GetInt procedure} {nonPortable unixOnly} { + test get-1.7 {Tcl_GetInt procedure} { set x 44 list [catch {incr x 18446744073709551616} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} - test get-1.8 {Tcl_GetInt procedure} {nonPortable} { + test get-1.8 {Tcl_GetInt procedure} { set x 0 list [catch {incr x 18446744073709551614} msg] $msg } {0 -2} - test get-1.9 {Tcl_GetInt procedure} {nonPortable} { + test get-1.9 {Tcl_GetInt procedure} { set x 0 list [catch {incr x +18446744073709551614} msg] $msg } {0 -2} - test get-1.10 {Tcl_GetInt procedure} {nonPortable} { + test get-1.10 {Tcl_GetInt procedure} { set x 0 list [catch {incr x -18446744073709551614} msg] $msg } {0 2} } else { - test get-1.7 {Tcl_GetInt procedure} {nonPortable unixOnly} { + test get-1.7 {Tcl_GetInt procedure} { set x 44 list [catch {incr x 4294967296} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} - test get-1.8 {Tcl_GetInt procedure} {nonPortable} { + test get-1.8 {Tcl_GetInt procedure} { set x 0 list [catch {incr x 4294967294} msg] $msg } {0 -2} - test get-1.9 {Tcl_GetInt procedure} {nonPortable} { + test get-1.9 {Tcl_GetInt procedure} { set x 0 list [catch {incr x +4294967294} msg] $msg } {0 -2} - test get-1.10 {Tcl_GetInt procedure} {nonPortable} { + test get-1.10 {Tcl_GetInt procedure} { set x 0 list [catch {incr x -4294967294} msg] $msg } {0 2} @@ -89,3 +92,19 @@ test get-2.3 {Tcl_GetInt procedure} { test get-2.4 {Tcl_GetInt procedure} {nonPortable} { list [catch {format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001} msg] $msg $errorCode } {1 {floating-point value too small to represent} {ARITH UNDERFLOW {floating-point value too small to represent}}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/history.test b/tests/history.test index 4417049..c7f7d20 100644 --- a/tests/history.test +++ b/tests/history.test @@ -6,20 +6,24 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: history.test,v 1.2 1998/09/14 18:40:09 stanton Exp $ +# RCS: @(#) $Id: history.test,v 1.3 1999/04/16 00:47:28 stanton Exp $ +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + if {[catch {history}]} { puts stdout "This version of Tcl was built without the history command;\n" puts stdout "history tests will be skipped.\n" + ::tcltest::cleanupTests return } -if {[string compare test [info procs test]] == 1} then {source defs} - set num [history nextid] history keep 3 history add {set a 12345} @@ -209,3 +213,18 @@ test history-9.2 {miscellaneous} { set msg } {bad option "gorp": must be add, change, clear, event, info, keep, nextid, or redo} +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/http.test b/tests/http.test index c4ddbf8..752e3a2 100644 --- a/tests/http.test +++ b/tests/http.test @@ -6,21 +6,24 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # -# RCS: @(#) $Id: http.test,v 1.3 1998/11/03 02:00:54 welch Exp $ +# RCS: @(#) $Id: http.test,v 1.4 1999/04/16 00:47:28 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[catch {package require http 2.0}]} { if {[info exist http2]} { - catch {puts stderr "Cannot load http 2.0 package"} + catch {puts "Cannot load http 2.0 package"} return } else { - catch {puts stderr "Running http 2.0 tests in slave interp"} + catch {puts "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]] @@ -29,160 +32,34 @@ if {[catch {package require http 2.0}]} { } } -############### The httpd_ procedures implement a stub http server. ######## -proc httpd_init {{port 8015}} { - socket -server httpdAccept $port -} -proc httpd_log {args} { - global httpLog - if {[info exists httpLog] && $httpLog} { - puts stderr "httpd: [join $args { }]" - } -} -array set httpdErrors { - 204 {No Content} - 400 {Bad Request} - 404 {Not Found} - 503 {Service Unavailable} - 504 {Service Temporarily Unavailable} - } - -proc httpdError {sock code args} { - global httpdErrors - puts $sock "$code $httpdErrors($code)" - httpd_log "error: [join $args { }]" -} -proc httpdAccept {newsock ipaddr port} { - global httpd - upvar #0 httpd$newsock data - - fconfigure $newsock -blocking 0 -translation {auto crlf} - httpd_log $newsock Connect $ipaddr $port - set data(ipaddr) $ipaddr - fileevent $newsock readable [list httpdRead $newsock] -} - -# read data from a client request - -proc httpdRead { sock } { - upvar #0 httpd$sock data - - set readCount [gets $sock line] - if {![info exists data(state)]} { - if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \ - $line x data(proto) data(url) data(query)] { - set data(state) mime - httpd_log $sock Query $line - } else { - httpdError $sock 400 - httpd_log $sock Error "bad first line:$line" - httpdSockDone $sock - } - return - } - - # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1 - - set state [string compare $readCount 0],$data(state),$data(proto) - httpd_log $sock $state - switch -- $state { - -1,mime,HEAD - - -1,mime,GET - - -1,mime,POST { - # gets would block - return - } - 0,mime,HEAD - - 0,mime,GET - - 0,query,POST { httpdRespond $sock } - 0,mime,POST { set data(state) query } - 1,mime,HEAD - - 1,mime,POST - - 1,mime,GET { - if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] { - set data(mime,[string tolower $key]) $value - } - } - 1,query,POST { - append data(query) $line - httpdRespond $sock - } - default { - if [eof $sock] { - httpd_log $sock Error "unexpected eof on <$data(url)> request" - } else { - httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>" - } - httpdError $sock 404 - httpdSockDone $sock - } - } -} -proc httpdSockDone { sock } { -upvar #0 httpd$sock data - unset data - close $sock -} - -# Respond to the query. +set port 8010 set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" -proc httpdRespond { sock } { - global httpd bindata port - upvar #0 httpd$sock data - - if {[string match *binary* $data(url)]} { - set html "$bindata[info hostname]:$port$data(url)" - set type application/octet-stream - } else { - set type text/html - - set html "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>$data(proto) $data(url)</h2> -" - if {[info exists data(query)] && [string length $data(query)]} { - append html "<h2>Query</h2>\n<dl>\n" - foreach {key value} [split $data(query) &=] { - append html "<dt>$key<dd>$value\n" - if {[string compare $key timeout] == 0} { - # Simulate a timeout by not responding, - # but clean up our socket later. - - after 50 [list httpdSockDone $sock] - httpd_log $sock Noresponse "" - return - } - } - 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" +set httpdFile [file join $::tcltest::testsDir httpd] +if {[info commands testthread] == "testthread" && [file exists $httpdFile]} { + set httpthread [testthread create " + source $httpdFile + testthread wait + "] + testthread send $httpthread [list set port $port] + testthread send $httpthread [list set bindata $bindata] + testthread send $httpthread {httpd_init $port} + puts "Running httpd in thread $httpthread" +} else { + if ![file exists $httpdFile] { + puts "Cannot read $httpdFile script, http test skipped" + unset port + return } - puts $sock "Date: [clock format [clock clicks]]" - puts $sock "Content-Type: $type" - puts $sock "Content-Length: [string length $html]" - puts $sock "" - if {$data(proto) != "HEAD"} { - fconfigure $sock -translation binary - puts -nonewline $sock $html + source $httpdFile + if [catch {httpd_init $port} listen] { + puts "Cannot start http server, http test skipped" + unset port + return } - httpd_log $sock Done "" - httpdSockDone $sock } -##################### end server ########################### -set port 8010 -if [catch {httpd_init $port} listen] { - puts stderr "Cannot start http server, http test skipped" - unset port - return -} test http-1.1 {http::config} { http::config @@ -412,6 +289,27 @@ test http-6.1 {http::ProxyRequired} { <h2>GET http://$url</h2> </body></html>" +# cleanup unset url unset port -close $listen +if {[info exists httpthread]} { + testthread send -async $httpthread { + testthread exit + } +} else { + close $listen +} +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/httpd b/tests/httpd new file mode 100644 index 0000000..1531964 --- /dev/null +++ b/tests/httpd @@ -0,0 +1,148 @@ +# +# The httpd_ procedures implement a stub http server. +# +# Copyright (c) 1997-1998 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) httpd 1.2 98/02/20 14:51:59 + +proc httpd_init {{port 8015}} { + socket -server httpdAccept $port +} +proc httpd_log {args} { + global httpLog + if {[info exists httpLog] && $httpLog} { + puts stderr "httpd: [join $args { }]" + } +} +array set httpdErrors { + 204 {No Content} + 400 {Bad Request} + 404 {Not Found} + 503 {Service Unavailable} + 504 {Service Temporarily Unavailable} + } + +proc httpdError {sock code args} { + global httpdErrors + puts $sock "$code $httpdErrors($code)" + httpd_log "error: [join $args { }]" +} +proc httpdAccept {newsock ipaddr port} { + global httpd + upvar #0 httpd$newsock data + + fconfigure $newsock -blocking 0 -translation {auto crlf} + httpd_log $newsock Connect $ipaddr $port + set data(ipaddr) $ipaddr + fileevent $newsock readable [list httpdRead $newsock] +} + +# read data from a client request + +proc httpdRead { sock } { + upvar #0 httpd$sock data + + set readCount [gets $sock line] + if {![info exists data(state)]} { + if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \ + $line x data(proto) data(url) data(query)] { + set data(state) mime + httpd_log $sock Query $line + } else { + httpdError $sock 400 + httpd_log $sock Error "bad first line:$line" + httpdSockDone $sock + } + return + } + + # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1 + + set state [string compare $readCount 0],$data(state),$data(proto) + httpd_log $sock $state + switch -- $state { + -1,mime,HEAD - + -1,mime,GET - + -1,mime,POST { + # gets would block + return + } + 0,mime,HEAD - + 0,mime,GET - + 0,query,POST { httpdRespond $sock } + 0,mime,POST { set data(state) query } + 1,mime,HEAD - + 1,mime,POST - + 1,mime,GET { + if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] { + set data(mime,[string tolower $key]) $value + } + } + 1,query,POST { + append data(query) $line + httpdRespond $sock + } + default { + if [eof $sock] { + httpd_log $sock Error "unexpected eof on <$data(url)> request" + } else { + httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>" + } + httpdError $sock 404 + httpdSockDone $sock + } + } +} +proc httpdSockDone { sock } { +upvar #0 httpd$sock data + unset data + close $sock +} + +# Respond to the query. + +proc httpdRespond { sock } { + global httpd bindata port + upvar #0 httpd$sock data + + if {[string match *binary* $data(url)]} { + set html "$bindata[info hostname]:$port$data(url)" + set type application/octet-stream + } else { + set type text/html + + set html "<html><head><title>HTTP/1.0 TEST</title></head><body> +<h1>Hello, World!</h1> +<h2>$data(proto) $data(url)</h2> +" + if {[info exists data(query)] && [string length $data(query)]} { + append html "<h2>Query</h2>\n<dl>\n" + foreach {key value} [split $data(query) &=] { + append html "<dt>$key<dd>$value\n" + } + append html </dl>\n + } + append html </body></html> + } + + if {$data(proto) == "HEAD"} { + puts $sock "HTTP/1.0 200 OK" + } else { + puts $sock "HTTP/1.0 200 Data follows" + } + puts $sock "Date: [clock format [clock clicks]]" + puts $sock "Content-Type: $type" + puts $sock "Content-Length: [string length $html]" + puts $sock "" + if {$data(proto) != "HEAD"} { + fconfigure $sock -translation binary + puts -nonewline $sock $html + } + httpd_log $sock Done "" + httpdSockDone $sock +} + + diff --git a/tests/httpold.test b/tests/httpold.test index f6d5fe0..5d874f6 100644 --- a/tests/httpold.test +++ b/tests/httpold.test @@ -6,25 +6,29 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: httpold.test,v 1.2 1998/09/14 18:40:09 stanton Exp $ - -if {[string compare test [info procs test]] == 1} then {source defs} +# RCS: @(#) $Id: httpold.test,v 1.3 1999/04/16 00:47:28 stanton Exp $ +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[catch {package require http 1.0}]} { if {[info exist httpold]} { - catch {puts stderr "Cannot load http 1.0 package"} + catch {puts "Cannot load http 1.0 package"} + ::tcltest::cleanupTests return } else { - catch {puts stderr "Running http 1.0 tests in slave interp"} + catch {puts "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 + ::tcltest::cleanupTests return } } @@ -36,7 +40,7 @@ proc httpd_init {{port 8015}} { proc httpd_log {args} { global httpLog if {[info exists httpLog] && $httpLog} { - puts stderr "httpd: [join $args { }]" + puts "httpd: [join $args { }]" } } array set httpdErrors { @@ -145,6 +149,14 @@ proc httpdRespond { sock } { append html "<h2>Query</h2>\n<dl>\n" foreach {key value} [split $data(query) &=] { append html "<dt>$key<dd>$value\n" + if {[string compare $key timeout] == 0} { + # Simulate a timeout by not responding, + # but clean up our socket later. + + after 50 [list httpdSockDone $sock] + httpd_log $sock Noresponse "" + return + } } append html </dl>\n } @@ -171,8 +183,9 @@ proc httpdRespond { sock } { set port 8010 if [catch {httpd_init $port} listen] { - puts stderr "Cannot start http server, http test skipped" + puts "Cannot start http server, http test skipped" unset port + ::tcltest::cleanupTests return } @@ -376,10 +389,12 @@ test http-4.11 {httpEvent} { } {reset} test http-4.12 {httpEvent} { update - set token [http_get $url -timeout 1 -command {#}] - update - http_status $token -} {timeout} + set x {} + after 500 {lappend x ok} + set token [http_get $url -timeout 1 -command {lappend x fail}] + vwait x + list [http_status $token] $x +} {timeout ok} test http-5.1 {http_formatQuery} { http_formatQuery name1 value1 name2 "value two" @@ -406,6 +421,21 @@ test http-6.1 {httpProxyRequired} { <h2>GET http://$url</h2> </body></html>" +# cleanup unset url unset port close $listen +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/if-old.test b/tests/if-old.test index 024cc53..d21b568 100644 --- a/tests/if-old.test +++ b/tests/if-old.test @@ -8,13 +8,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: if-old.test,v 1.2 1998/09/14 18:40:10 stanton Exp $ +# RCS: @(#) $Id: if-old.test,v 1.3 1999/04/16 00:47:28 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test if-old-1.1 {taking proper branch} { set a {} @@ -154,3 +157,19 @@ test if-old-4.10 {error conditions} { test if-old-4.11 {error conditions} { list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg } {1 {error in else clause}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/if.test b/tests/if.test index 8da1a0d..99e7c37 100644 --- a/tests/if.test +++ b/tests/if.test @@ -5,13 +5,16 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: if.test,v 1.2 1998/09/14 18:40:10 stanton Exp $ +# RCS: @(#) $Id: if.test,v 1.3 1999/04/16 00:47:28 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # Basic "if" operation. @@ -495,11 +498,594 @@ test if-4.5 {TclCompileIfCmd: return value} { # Check "if" and computed command names. -test if-5.1 {if and computed command names} { - set i 0 +catch {unset a} +test if-5.1 {if cmd with computed command names: missing if/elseif test} { set z if - $z 1 { - set i 1 - } - set i + list [catch {$z} msg] $msg +} {1 {wrong # args: no expression after "if" argument}} + +test if-5.2 {if cmd with computed command names: error in if/elseif test} { + set z if + list [catch {$z {[error "error in condition"]} foo} msg] $msg +} {1 {error in condition}} +test if-5.3 {if cmd with computed command names: error in if/elseif test} { + set z if + list [catch {$z {1+}} msg] $msg $errorInfo +} {1 {syntax error in expression "1+"} {syntax error in expression "1+" + while executing +"$z {1+}"}} +test if-5.4 {if cmd with computed command names: if/elseif test in braces} { + set z if + set a {} + $z {1<2} {set a 1} + set a +} {1} +test if-5.5 {if cmd with computed command names: if/elseif test not in braces} { + set z if + set a {} + $z 1<2 {set a 1} + set a +} {1} +test if-5.6 {if cmd with computed command names: multiline test expr} { + set z if + set a {} + $z {($tcl_platform(platform) != "foobar1") && \ + ($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4} + set a +} 3 +test if-5.7 {if cmd with computed command names: "then" after if/elseif test} { + set z if + set a {} + $z 4>3 then {set a 1} + set a +} {1} +test if-5.8 {if cmd with computed command names: keyword other than "then" after if/elseif test} { + set z if + set a {} + catch {$z 1<2 therefore {set a 1}} msg + set msg +} {invalid command name "therefore"} +test if-5.9 {if cmd with computed command names: missing "then" body} { + set z if + set a {} + catch {$z 1<2 then} msg + set msg +} {wrong # args: no script following "then" argument} +test if-5.10 {if cmd with computed command names: error in "then" body} { + set z if + set a {} + list [catch {$z {$a!="xxx"} then {set}} msg] $msg $errorInfo +} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + invoked from within +"$z {$a!="xxx"} then {set}"}} +test if-5.11 {if cmd with computed command names: error in "then" body} { + set z if + list [catch {$z 2 then {[error "error in then clause"]}} msg] $msg +} {1 {error in then clause}} +test if-5.12 {if cmd with computed command names: "then" body in quotes} { + set z if + set a {} + $z 27>17 "append a x" + set a +} {x} +test if-5.13 {if cmd with computed command names: computed "then" body} { + set z if + catch {unset x1} + catch {unset x2} + set a {} + set x1 {append a x1} + set x2 {; append a x2} + set a {} + $z 1 $x1$x2 + set a +} {x1x2} +test if-5.14 {if cmd with computed command names: taking proper branch} { + set z if + set a {} + $z 1<2 {set a 1} + set a } 1 +test if-5.15 {if cmd with computed command names: taking proper branch} { + set z if + set a {} + $z 1>2 {set a 1} + set a +} {} +test if-5.16 {if cmd with computed command names: test jumpFalse instruction replacement after long "then" body} { + set z if + catch {unset i} + set a {} + $z 1<2 { + set a 1 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 2 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 3 + } + set a +} 3 +test if-5.17 {if cmd with computed command names: if/elseif test in quotes} { + set z if + set a {} + list [catch {$z {"0 < 3"} {set a 1}} msg] $msg +} {1 {expected boolean value but got "0 < 3"}} + + +test if-6.1 {if cmd with computed command names: "elseif" after if/elseif test} { + set z if + set a {} + $z 3>4 {set a 1} elseif 1 {set a 2} + set a +} {2} +# Since "else" is optional, the "elwood" below is treated as a command. +# But then there shouldn't be any additional argument words for the "if". +test if-6.2 {if cmd with computed command names: keyword other than "elseif"} { + set z if + set a {} + catch {$z 1<2 {set a 1} elwood {set a 2}} msg + set msg +} {wrong # args: extra words after "else" clause in "if" command} +test if-6.3 {if cmd with computed command names: missing expression after "elseif"} { + set z if + set a {} + catch {$z 1<2 {set a 1} elseif} msg + set msg +} {wrong # args: no expression after "elseif" argument} +test if-6.4 {if cmd with computed command names: error in expression after "elseif"} { + set z if + set a {} + list [catch {$z 3>4 {set a 1} elseif {1>}} msg] $msg $errorInfo +} {1 {syntax error in expression "1>"} {syntax error in expression "1>" + while executing +"$z 3>4 {set a 1} elseif {1>}"}} +test if-6.5 {if cmd with computed command names: test jumpFalse instruction replacement after long "elseif" body} { + set z if + catch {unset i} + set a {} + $z 1>2 { + set a 1 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 2 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 3 + } elseif 1<2 then { #; this if arm should be taken + set a 4 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 5 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 6 + } + set a +} 6 + +test if-7.1 {if cmd with computed command names: "else" clause} { + set z if + set a {} + $z 3>4 {set a 1} elseif {$a == "foo"} {set a 2} else {set a 3} + set a +} 3 +# Since "else" is optional, the "elsex" below is treated as a command. +# But then there shouldn't be any additional argument words for the "if". +test if-7.2 {if cmd with computed command names: keyword other than "else"} { + set z if + set a {} + catch {$z 1<2 then {set a 1} elsex {set a 2}} msg + set msg +} {wrong # args: extra words after "else" clause in "if" command} +test if-7.3 {if cmd with computed command names: missing body after "else"} { + set z if + set a {} + catch {$z 2<1 {set a 1} else} msg + set msg +} {wrong # args: no script following "else" argument} +test if-7.4 {if cmd with computed command names: error compiling body after "else"} { + set z if + set a {} + catch {$z 2<1 {set a 1} else {set}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + invoked from within +"$z 2<1 {set a 1} else {set}"} +test if-7.5 {if cmd with computed command names: extra arguments after "else" argument} { + set z if + set a {} + catch {$z 2<1 {set a 1} else {set a 2} or something} msg + set msg +} {wrong # args: extra words after "else" clause in "if" command} +# The following test also checks whether contained loops and other +# commands are properly relocated because a short jump must be replaced +# by a "long distance" one. +test if-7.6 {if cmd with computed command names: test jumpFalse instruction replacement after long "else" clause} { + set z if + catch {unset i} + set a {} + $z 1>2 { + set a 1 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 2 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 3 + } elseif 1==2 then { #; this if arm should be taken + set a 4 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 5 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 6 + } else { + set a 7 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 8 + while {$a != "xxx"} { + break; + while {$i >= 0} { + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + $z {[string compare $a "bar"] < 0} { + set i $i + set i [lindex $s $i] + } + set i [expr $i-1] + } + } + set a 9 + } + set a +} 9 + +test if-8.1 {if cmd with computed command names: "if" command result} { + set z if + set a {} + set a [$z 3<4 {set i 27}] + set a +} 27 +test if-8.2 {if cmd with computed command names: "if" command result} { + set z if + set a {} + set a [$z 3>4 {set i 27}] + set a +} {} +test if-8.3 {if cmd with computed command names: "if" command result} { + set z if + set a {} + set a [$z 0 {set i 1} elseif 1 {set i 2}] + set a +} 2 +test if-8.4 {if cmd with computed command names: "if" command result} { + set z if + set a {} + set a [$z 0 {set i 1} elseif 0 {set i 2} elseif 2>5 {set i 3} else {set i 4}] + set a +} 4 +test if-8.5 {if cmd with computed command names: return value} { + set z if + $z 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi} +} def + +test if-9.1 {if cmd with namespace qualifiers} { + ::if {1} {set x 4} +} 4 + +# Test for incorrect "double evaluation semantics" + +test if-10.1 {delayed substitution of then body} {knownBug} { + set j 0 + if {[incr j] == 1} " + set result $j + " + set result +} {0} +test if-10.2 {delayed substitution of elseif expression} {knownBug} { + set j 0 + if {[incr j] == 0} { + set result badthen + } elseif "$j == 1" { + set result badelseif + } else { + set result ok + } + set result +} {ok} +test if-10.3 {delayed substitution of elseif body} {knownBug} { + set j 0 + if {[incr j] == 0} { + set result badthen + } elseif {1} " + set result $j + " + set result +} {0} +test if-10.4 {delayed substitution of else body} {knownBug} { + set j 0 + if {[incr j] == 0} { + set result badthen + } else " + set result $j + " + set result +} {0} +test if-10.5 {substituted control words} {knownBug} { + set then then; proc then {} {return badthen} + set else else; proc else {} {return badelse} + set elseif elseif; proc elseif {} {return badelseif} + list [catch {if 1 $then {if 0 {} $elseif 1 {if 0 {} $else {list ok}}}} a] $a +} {0 ok} +test if-10.6 {double invocation of variable traces} {knownBug} { + set iftracecounter 0 + proc iftraceproc {args} { + upvar #0 iftracecounter counter + set argc [llength $args] + set extraargs [lrange $args 0 [expr {$argc - 4}]] + set name [lindex $args [expr {$argc - 3}]] + upvar 1 $name var + if {[incr counter] % 2 == 1} { + set var "$counter oops [concat $extraargs]" + } else { + set var "$counter + [concat $extraargs]" + } + } + trace variable iftracevar r [list iftraceproc 10] + list [catch {if "$iftracevar + 20" {}} a] $a \ + [catch {if "$iftracevar + 20" {}} b] $b \ + [unset iftracevar iftracecounter] +} {1 {syntax error in expression "1 oops 10 + 20"} 0 {} {}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/incr-old.test b/tests/incr-old.test index cafe208..64b2012 100644 --- a/tests/incr-old.test +++ b/tests/incr-old.test @@ -8,13 +8,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: incr-old.test,v 1.2 1998/09/14 18:40:10 stanton Exp $ +# RCS: @(#) $Id: incr-old.test,v 1.3 1999/04/16 00:47:28 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {unset x} @@ -86,4 +89,18 @@ test incr-old-2.10 {incr errors} { list [catch {incr x 1} msg] $msg } {1 {expected integer but got "20 x"}} -concat {} +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/incr.test b/tests/incr.test index 99ded82..02ccf37 100644 --- a/tests/incr.test +++ b/tests/incr.test @@ -5,13 +5,16 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: incr.test,v 1.2 1998/09/14 18:40:10 stanton Exp $ +# RCS: @(#) $Id: incr.test,v 1.3 1999/04/16 00:47:28 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # Basic "incr" operation. @@ -238,9 +241,273 @@ test incr-1.29 {TclCompileIncrCmd: runtime error, bad variable value} { # Check "incr" and computed command names. -test incr-2.1 {incr and computed command names} { +test incr-2.0 {incr and computed command names} { set i 5 set z incr $z i -1 set i } 4 +catch {unset x} +catch {unset i} + +test incr-2.1 {incr command (not compiled): missing variable name} { + set z incr + list [catch {$z} msg] $msg +} {1 {wrong # args: should be "incr varName ?increment?"}} +test incr-2.2 {incr command (not compiled): simple variable name} { + set z incr + set i 10 + list [$z i] $i +} {11 11} +test incr-2.3 {incr command (not compiled): error compiling variable name} { + set z incr + set i 10 + catch {$z "i"xxx} msg + set msg +} {extra characters after close-quote} +test incr-2.4 {incr command (not compiled): simple variable name in quotes} { + set z incr + set i 17 + list [$z "i"] $i +} {18 18} +test incr-2.5 {incr command (not compiled): simple variable name in braces} { + set z incr + catch {unset {a simple var}} + set {a simple var} 27 + list [$z {a simple var}] ${a simple var} +} {28 28} +test incr-2.6 {incr command (not compiled): simple array variable name} { + set z incr + catch {unset a} + set a(foo) 37 + list [$z a(foo)] $a(foo) +} {38 38} +test incr-2.7 {incr command (not compiled): non-simple (computed) variable name} { + set z incr + set x "i" + set i 77 + list [$z $x 2] $i +} {79 79} +test incr-2.8 {incr command (not compiled): non-simple (computed) variable name} { + set z incr + set x "i" + set i 77 + list [$z [set x] +2] $i +} {79 79} + +test incr-2.9 {incr command (not compiled): increment given} { + set z incr + set i 10 + list [$z i +07] $i +} {17 17} +test incr-2.10 {incr command (not compiled): no increment given} { + set z incr + set i 10 + list [$z i] $i +} {11 11} + +test incr-2.11 {incr command (not compiled): simple global name} { + proc p {} { + set z incr + global i + set i 54 + $z i + } + p +} {55} +test incr-2.12 {incr command (not compiled): simple local name} { + proc p {} { + set z incr + set foo 100 + $z foo + } + p +} {101} +test incr-2.13 {incr command (not compiled): simple but new (unknown) local name} { + proc p {} { + set z incr + $z bar + } + catch {p} msg + set msg +} {can't read "bar": no such variable} +test incr-2.14 {incr command (not compiled): simple local name, >255 locals} { + proc 260locals {} { + set z incr + # create 260 locals + set a0 0; set a1 0; set a2 0; set a3 0; set a4 0 + set a5 0; set a6 0; set a7 0; set a8 0; set a9 0 + set b0 0; set b1 0; set b2 0; set b3 0; set b4 0 + set b5 0; set b6 0; set b7 0; set b8 0; set b9 0 + set c0 0; set c1 0; set c2 0; set c3 0; set c4 0 + set c5 0; set c6 0; set c7 0; set c8 0; set c9 0 + set d0 0; set d1 0; set d2 0; set d3 0; set d4 0 + set d5 0; set d6 0; set d7 0; set d8 0; set d9 0 + set e0 0; set e1 0; set e2 0; set e3 0; set e4 0 + set e5 0; set e6 0; set e7 0; set e8 0; set e9 0 + set f0 0; set f1 0; set f2 0; set f3 0; set f4 0 + set f5 0; set f6 0; set f7 0; set f8 0; set f9 0 + set g0 0; set g1 0; set g2 0; set g3 0; set g4 0 + set g5 0; set g6 0; set g7 0; set g8 0; set g9 0 + set h0 0; set h1 0; set h2 0; set h3 0; set h4 0 + set h5 0; set h6 0; set h7 0; set h8 0; set h9 0 + set i0 0; set i1 0; set i2 0; set i3 0; set i4 0 + set i5 0; set i6 0; set i7 0; set i8 0; set i9 0 + set j0 0; set j1 0; set j2 0; set j3 0; set j4 0 + set j5 0; set j6 0; set j7 0; set j8 0; set j9 0 + set k0 0; set k1 0; set k2 0; set k3 0; set k4 0 + set k5 0; set k6 0; set k7 0; set k8 0; set k9 0 + set l0 0; set l1 0; set l2 0; set l3 0; set l4 0 + set l5 0; set l6 0; set l7 0; set l8 0; set l9 0 + set m0 0; set m1 0; set m2 0; set m3 0; set m4 0 + set m5 0; set m6 0; set m7 0; set m8 0; set m9 0 + set n0 0; set n1 0; set n2 0; set n3 0; set n4 0 + set n5 0; set n6 0; set n7 0; set n8 0; set n9 0 + set o0 0; set o1 0; set o2 0; set o3 0; set o4 0 + set o5 0; set o6 0; set o7 0; set o8 0; set o9 0 + set p0 0; set p1 0; set p2 0; set p3 0; set p4 0 + set p5 0; set p6 0; set p7 0; set p8 0; set p9 0 + set q0 0; set q1 0; set q2 0; set q3 0; set q4 0 + set q5 0; set q6 0; set q7 0; set q8 0; set q9 0 + set r0 0; set r1 0; set r2 0; set r3 0; set r4 0 + set r5 0; set r6 0; set r7 0; set r8 0; set r9 0 + set s0 0; set s1 0; set s2 0; set s3 0; set s4 0 + set s5 0; set s6 0; set s7 0; set s8 0; set s9 0 + set t0 0; set t1 0; set t2 0; set t3 0; set t4 0 + set t5 0; set t6 0; set t7 0; set t8 0; set t9 0 + set u0 0; set u1 0; set u2 0; set u3 0; set u4 0 + set u5 0; set u6 0; set u7 0; set u8 0; set u9 0 + set v0 0; set v1 0; set v2 0; set v3 0; set v4 0 + set v5 0; set v6 0; set v7 0; set v8 0; set v9 0 + set w0 0; set w1 0; set w2 0; set w3 0; set w4 0 + set w5 0; set w6 0; set w7 0; set w8 0; set w9 0 + set x0 0; set x1 0; set x2 0; set x3 0; set x4 0 + set x5 0; set x6 0; set x7 0; set x8 0; set x9 0 + set y0 0; set y1 0; set y2 0; set y3 0; set y4 0 + set y5 0; set y6 0; set y7 0; set y8 0; set y9 0 + set z0 0; set z1 0; set z2 0; set z3 0; set z4 0 + set z5 0; set z6 0; set z7 0; set z8 0; set z9 0 + # now increment the last one (local var index > 255) + $z z9 + } + 260locals +} {1} +test incr-2.15 {incr command (not compiled): variable is array} { + set z incr + catch {unset a} + set a(foo) 27 + set x [$z a(foo) 11] + catch {unset a} + set x +} 38 +test incr-2.16 {incr command (not compiled): variable is array, elem substitutions} { + set z incr + catch {unset a} + set i 5 + set a(foo5) 27 + set x [$z a(foo$i) 11] + catch {unset a} + set x +} 38 + +test incr-2.17 {incr command (not compiled): increment given, simple int} { + set z incr + set i 5 + $z i 123 +} 128 +test incr-2.18 {incr command (not compiled): increment given, simple int} { + set z incr + set i 5 + $z i -100 +} -95 +test incr-2.19 {incr command (not compiled): increment given, but erroneous} { + set z incr + set i 5 + catch {$z i [set]} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + while compiling +"$z i [set]"} +test incr-2.20 {incr command (not compiled): increment given, in quotes} { + set z incr + set i 25 + $z i "-100" +} -75 +test incr-2.21 {incr command (not compiled): increment given, in braces} { + set z incr + set i 24 + $z i {126} +} 150 +test incr-2.22 {incr command (not compiled): increment given, large int} { + set z incr + set i 5 + $z i 200000 +} 200005 +test incr-2.23 {incr command (not compiled): increment given, formatted int != int} { + set z incr + set i 25 + $z i 000012345 ;# an octal literal +} 5374 +test incr-2.24 {incr command (not compiled): increment given, formatted int != int} { + set z incr + set i 25 + catch {$z i 1a} msg + set msg +} {expected integer but got "1a"} + +test incr-2.25 {incr command (not compiled): too many arguments} { + set z incr + set i 10 + catch {$z i 10 20} msg + set msg +} {wrong # args: should be "incr varName ?increment?"} + + +test incr-2.26 {incr command (not compiled): runtime error, bad variable name} { + set z incr + list [catch {$z {"foo}} msg] $msg $errorInfo +} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable + (reading value of variable to increment) + invoked from within +"$z {"foo}"}} +test incr-2.27 {incr command (not compiled): runtime error, bad variable name} { + set z incr + list [catch {$z [set]} msg] $msg $errorInfo +} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + while compiling +"$z [set]"}} +test incr-2.28 {incr command (not compiled): runtime error, readonly variable} { + set z incr + proc readonly args {error "variable is read-only"} + set x 123 + trace var x w readonly + list [catch {$z x 1} msg] $msg $errorInfo +} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only + while executing +"$z x 1"}} +catch {unset x} +test incr-2.29 {incr command (not compiled): runtime error, bad variable value} { + set z incr + set x " - " + list [catch {$z x 1} msg] $msg +} {1 {expected integer but got " - "}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/indexObj.test b/tests/indexObj.test index d4ae81a..979e5a8 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -3,19 +3,21 @@ # are organized in the standard fashion for Tcl tests. # # Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: indexObj.test,v 1.2 1998/09/14 18:40:10 stanton Exp $ +# RCS: @(#) $Id: indexObj.test,v 1.3 1999/04/16 00:47:29 stanton Exp $ -if {[info procs test] != "test"} { - source defs +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } if {[info commands testindexobj] == {}} { puts "This application hasn't been compiled with the \"testindexobj\"" puts "command, so I can't test Tcl_GetIndexFromObj etc." + ::tcltest::cleanupTests return } @@ -66,3 +68,19 @@ test indexObj-4.1 {free old internal representation} { lindex $x 1 testindexobj 1 1 $x abc def {a b} zzz } {2} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/info.test b/tests/info.test index b059fc8..4522520 100644 --- a/tests/info.test +++ b/tests/info.test @@ -5,14 +5,29 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1995 Sun Microsystems, Inc. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: info.test,v 1.5 1998/11/11 02:39:56 welch Exp $ +# RCS: @(#) $Id: info.test,v 1.6 1999/04/16 00:47:29 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +# Set up namespaces needed to test operation of "info args", "info body", +# "info default", and "info procs" with imported procedures. + +catch {namespace delete test_ns_info1 test_ns_info2} + +namespace eval test_ns_info1 { + namespace export * + proc p {x} {return "x=$x"} + proc q {{y 27} z} {return "y=$y"} +} -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} @@ -38,6 +53,13 @@ test info-1.6 {info args option} { t1 1 2 info args t1 } {a b} +test info-1.7 {info args option} { + catch {namespace delete test_ns_info2} + namespace eval test_ns_info2 { + namespace import ::test_ns_info1::* + list [info args p] [info args q] + } +} {x {y z}} test info-2.1 {info body option} { proc t1 {} {body of t1} @@ -49,6 +71,13 @@ test info-2.2 {info body option} { test info-2.3 {info body option} { list [catch {info args set 1} msg] $msg } {1 {wrong # args: should be "info args procname"}} +test info-2.4 {info body option} { + catch {namespace delete test_ns_info2} + namespace eval test_ns_info2 { + namespace import ::test_ns_info1::* + list [info body p] [info body q] + } +} {{return "x=$x"} {return "y=$y"}} # "info cmdcount" is no longer accurate for compiled commands! The expected # result for info-3.1 used to be "3" and is now "1" since the "set"s have @@ -59,7 +88,7 @@ test info-3.1 {info cmdcount option} { set z [info cm] expr $z-$x } 1 -test info-3.2 {info body option} { +test info-3.2 {info cmdcount option} { list [catch {info cmdcount 1} msg] $msg } {1 {wrong # args: should be "info cmdcount"}} @@ -93,152 +122,17 @@ test info-4.5 {info commands option} { } {1 {wrong # args: should be "info commands ?pattern?"}} test info-5.1 {info complete option} { - info complete "" -} 1 + list [catch {info complete} msg] $msg +} {1 {wrong # args: should be "info complete command"}} test info-5.2 {info complete option} { - info complete " \n" -} 1 -test info-5.3 {info complete option} { - info complete "abc def" -} 1 -test info-5.4 {info complete option} { - info complete "a b c d e f \t\n" -} 1 -test info-5.5 {info complete option} { - info complete {a b c"d} -} 1 -test info-5.6 {info complete option} { - info complete {a b "c d" e} -} 1 -test info-5.7 {info complete option} { - info complete {a b "c d"} -} 1 -test info-5.8 {info complete option} { - info complete {a b "c d"} -} 1 -test info-5.9 {info complete option} { - info complete {a b "c d} -} 0 -test info-5.10 {info complete option} { - info complete {a b "} -} 0 -test info-5.11 {info complete option} { - info complete {a b "cd"xyz} -} 1 -test info-5.12 {info complete option} { - info complete {a b "c $d() d"} -} 1 -test info-5.13 {info complete option} { - info complete {a b "c $dd("} -} 0 -test info-5.14 {info complete option} { - info complete {a b "c \"} -} 0 -test info-5.15 {info complete option} { - info complete {a b "c [d e f]"} -} 1 -test info-5.16 {info complete option} { - info complete {a b "c [d e f] g"} -} 1 -test info-5.17 {info complete option} { - info complete {a b "c [d e f"} -} 0 -test info-5.18 {info complete option} { - info complete {a {b c d} e} -} 1 -test info-5.19 {info complete option} { - info complete {a {b c d}} -} 1 -test info-5.20 {info complete option} { - info complete "a b\{c d" -} 1 -test info-5.21 {info complete option} { - info complete "a b \{c" -} 0 -test info-5.22 {info complete option} { - info complete "a b \{c{ }" -} 0 -test info-5.23 {info complete option} { - info complete "a b {c d e}xxx" -} 1 -test info-5.24 {info complete option} { - info complete "a b {c \\\{d e}xxx" -} 1 -test info-5.25 {info complete option} { - info complete {a b [ab cd ef]} -} 1 -test info-5.26 {info complete option} { - info complete {a b x[ab][cd][ef] gh} -} 1 -test info-5.27 {info complete option} { - info complete {a b x[ab][cd[ef] gh} -} 0 -test info-5.28 {info complete option} { - info complete {a b x[ gh} -} 0 -test info-5.29 {info complete option} { - info complete {[]]]} + info complete abc } 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" +test info-5.2 {info complete option} { + info complete "\{abcd " } 0 -test info-5.48 {info complete option} { - info complete "set x [binary format H 00]; puts hi" +test info-5.3 {info complete option} { + info complete {# Comment should be complete command} } 1 -test info-5.49 {info complete option} { - info complete "set x [binary format H 00]; \{" -} 0 test info-6.1 {info default option} { proc t1 {a b {c d} {e "long default value"}} {} @@ -288,6 +182,13 @@ test info-6.10 {info default option} { proc t1 {{a 18} b} {} list [catch {info default t1 a a} msg] $msg } {1 {couldn't store default value in variable "a"}} +test info-6.11 {info default option} { + catch {namespace delete test_ns_info2} + namespace eval test_ns_info2 { + namespace import ::test_ns_info1::* + list [info default p x foo] $foo [info default q y bar] $bar + } +} {0 {} 1 27} catch {unset a} test info-7.1 {info exists option} { @@ -416,7 +317,7 @@ test info-11.1 {info loaded option} { } {1 {wrong # args: should be "info loaded ?interp?"}} test info-11.2 {info loaded option} { list [catch {info loaded {}}] [catch {info loaded gorp} msg] $msg -} {0 1 {couldn't find slave interpreter named "gorp"}} +} {0 1 {could not find interpreter "gorp"}} test info-12.1 {info locals option} { set a 22 @@ -499,31 +400,34 @@ 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-15.4 {info procs option} { + catch {namespace delete test_ns_info2} + namespace eval test_ns_info2 { + namespace import ::test_ns_info1::* + proc r {} {} + list [info procs] [info procs p*] + } +} {{p q r} p} 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 +} "info.test" 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] +} [list gorp.info info.test] test info-16.4 {resetting "info script" after errors} { catch {source ~_nobody_/foo} file tail [info script] -} $self +} "info.test" test info-16.5 {resetting "info script" after errors} { catch {source _nonexistent_} file tail [info script] -} $self +} "info.test" removeFile gorp.info test info-17.1 {info sharedlibextension option} { @@ -594,3 +498,20 @@ test info-20.4 {miscellaneous error conditions} { test info-20.5 {miscellaneous error conditions} { list [catch {info s} msg] $msg } {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} + +# cleanup +catch {namespace delete test_ns_info1 test_ns_info2} +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/init.test b/tests/init.test index 2cec460..4172606 100644 --- a/tests/init.test +++ b/tests/init.test @@ -5,14 +5,16 @@ # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: init.test,v 1.2 1998/09/14 18:40:10 stanton Exp $ +# RCS: @(#) $Id: init.test,v 1.3 1999/04/16 00:47:29 stanton Exp $ - -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # Clear out any namespaces called test_ns_* catch {eval namespace delete [namespace children :: test_ns_*]} @@ -58,25 +60,27 @@ test init-1.8 {auto_qualify - multiple colons 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 [list set argv $argv] +interp eval $testInterp [list source [file join $::tcltest::testsDir defs.tcl]] interp eval $testInterp { -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} auto_reset catch {rename parray {}} test init-2.0 {load parray - stage 1} { - set ret [catch {namespace eval ::test {parray}} error] + set ret [catch {namespace eval ::tcltest {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] + set ret [catch {namespace eval ::tcltest {parray}} error] list $ret $error } {1 {no value given for parameter "a" to "parray"}} @@ -129,7 +133,7 @@ catch {rename ::http::geturl {}} test init-2.8 {load http::geturl (package)} { # 3 ':' on purpose - set ret [catch {namespace eval ::test {http:::geturl}} error] + set ret [catch {namespace eval ::tcltest {http:::geturl}} error] # removing it, for the next test. should not fail. rename ::http::geturl {} ; list $ret $error @@ -145,5 +149,19 @@ test init-3.0 {random stuff in the auto_index, should still work} { } +# cleanup interp delete $testInterp +::tcltest::cleanupTests +return + + + + + + + + + + + diff --git a/tests/interp.test b/tests/interp.test index da0c433..817ef99 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -5,21 +5,23 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998 by Scriptics Corporation. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: interp.test,v 1.6 1999/02/03 02:58:41 stanton Exp $ +# RCS: @(#) $Id: interp.test,v 1.7 1999/04/16 00:47:29 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # 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} + set hidden_cmds {beep cd echo encoding 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} + set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source} } foreach i [interp slaves] { @@ -40,7 +42,7 @@ test interp-1.3 {options for interp command} { } "" test interp-1.4 {options for interp command} { list [catch {interp delete foo bar} msg] $msg -} {1 {interpreter named "foo" not found}} +} {1 {could not find interpreter "foo"}} test interp-1.5 {options for interp command} { list [catch {interp exists foo bar} msg] $msg } {1 {wrong # args: should be "interp exists ?path?"}} @@ -84,7 +86,7 @@ test interp-2.6 {basic interpreter creation} { } d test interp-2.7 {basic interpreter creation} { list [catch {interp create -froboz} msg] $msg -} {1 {bad option "-froboz": should be -safe}} +} {1 {bad option "-froboz": must be -safe or --}} test interp-2.8 {basic interpreter creation} { interp create -- -froboz } -froboz @@ -100,17 +102,15 @@ test interp-2.11 {anonymous interps vs existing procs} { set x [interp create] regexp "interp(\[0-9]+)" $x dummy thenum interp delete $x - incr thenum proc interp$thenum {} {} set x [interp create] regexp "interp(\[0-9]+)" $x dummy anothernum - expr $anothernum - $thenum + expr $anothernum > $thenum } 1 test interp-2.12 {anonymous interps vs existing procs} { set x [interp create -safe] regexp "interp(\[0-9]+)" $x dummy thenum interp delete $x - incr thenum proc interp$thenum {} {} set x [interp create -safe] regexp "interp(\[0-9]+)" $x dummy anothernum @@ -165,10 +165,10 @@ test interp-4.1 {testing interp delete} { } "" test interp-4.2 {testing interp delete} { list [catch {interp delete nonexistent} msg] $msg -} {1 {interpreter named "nonexistent" not found}} +} {1 {could not find interpreter "nonexistent"}} test interp-4.3 {testing interp delete} { list [catch {interp delete x y z} msg] $msg -} {1 {interpreter named "x" not found}} +} {1 {could not find interpreter "x"}} test interp-4.4 {testing interp delete} { interp delete } "" @@ -188,10 +188,10 @@ test interp-4.7 {testing interp delete} { interp create c1 interp create c2 list [catch {interp delete c1 c2 c3} msg] $msg -} {1 {interpreter named "c3" not found}} +} {1 {could not find interpreter "c3"}} test interp-4.8 {testing interp delete} { list [catch {interp delete {}} msg] $msg -} {1 {interpreter named "" not found}} +} {1 {cannot delete the current interpreter}} foreach i [interp slaves] { interp delete $i @@ -1598,7 +1598,7 @@ test interp-22.5 {testing interp marktrusted} { catch {a eval {interp marktrusted b}} msg interp delete a set msg -} {"interp marktrusted" can only be invoked from a trusted interpreter} +} {permission denied: safe interpreter cannot mark trusted} test interp-22.6 {testing interp marktrusted} { catch {interp delete a} interp create a -safe @@ -1606,7 +1606,7 @@ test interp-22.6 {testing interp marktrusted} { catch {a eval {b marktrusted}} msg interp delete a set msg -} {"b marktrusted" can only be invoked from a trusted interpreter} +} {permission denied: safe interpreter cannot mark trusted} test interp-22.7 {testing interp marktrusted} { catch {interp delete a} interp create a -safe @@ -1666,7 +1666,7 @@ test interp-23.1 {testing hiding vs aliases} { interp delete a set l } {{} bar {} bar bar {} {}} -test interp-23.2 {testing hiding vs aliases} {pc || unix} { +test interp-23.2 {testing hiding vs aliases} {unixOrPc} { catch {interp delete a} interp create a -safe set l "" @@ -1682,7 +1682,7 @@ test interp-23.2 {testing hiding vs aliases} {pc || unix} { lappend l [lsort [interp hidden a]] interp delete a set l -} {{cd exec exit fconfigure file glob load open pwd socket source} 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}} +} {{cd encoding exec exit fconfigure file glob load open pwd socket source} bar {cd encoding exec exit fconfigure file glob load open pwd socket source} bar {bar cd encoding exec exit fconfigure file glob load open pwd socket source} {} {cd encoding exec exit fconfigure file glob load open pwd socket source}} test interp-23.3 {testing hiding vs aliases} {macOnly} { catch {interp delete a} @@ -1933,31 +1933,94 @@ test interp-25.1 {testing aliasing of string commands} { } "" +# # Interps result transmission -test interp-26.1 {result code transmission 1} {knownBug} { - # This test currently fails ! (only ok/error are passed, not the other - # codes). Fixing the code is thus needed... -- dl - # (the only other acceptable result list would be - # {-1 0 1 0 3 4 5} because of the way return -code return(=2) works) - # test that all the possibles error codes from Tcl get passed +# + +test interp-26.1 {result code transmission : interp eval direct} { + # Test that all the possibles error codes from Tcl get passed up + # from the slave interp's context to the master, even though the + # slave nominally thinks the command is running at the root level. + catch {interp delete a} interp create a - 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] + lappend res [catch {interp eval a return -code $code} msg] } interp delete a set res } {-1 0 1 2 3 4 5} -test interp-26.2 {result code transmission 2} {knownBug} { - # This test currently fails ! (error is cleared) - # Code fixing is needed... -- dl - # (the only other acceptable result list would be - # {-1 0 1 0 3 4 5} because of the way return -code return(=2) works) - # test that all the possibles error codes from Tcl get passed + +test interp-26.2 {result code transmission : interp eval indirect} { + # retcode == 2 == return is special + catch {interp delete a} + interp create a + interp eval a {proc retcode {code} {return -code $code ret$code}} + set res {} + # use a for so if a return -code break 'escapes' we would notice + for {set code -1} {$code<=5} {incr code} { + lappend res [catch {interp eval a retcode $code} msg] $msg + } + interp delete a + set res +} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} + +test interp-26.3 {result code transmission : aliases} { + # Test that all the possibles error codes from Tcl get passed up + # from the slave interp's context to the master, even though the + # slave nominally thinks the command is running at the root level. + + catch {interp delete a} + interp create a + set res {} + proc MyTestAlias {code} { + return -code $code ret$code + } + interp alias a Test {} MyTestAlias + for {set code -1} {$code<=5} {incr code} { + lappend res [interp eval a [list catch [list Test $code] msg]] + } + interp delete a + set res +} {-1 0 1 2 3 4 5} + +test interp-26.4 {result code transmission: invoke hidden direct--bug 1637} \ + {knownBug} { + # The known bug is that code 2 is returned, not the -code argument + catch {interp delete a} + interp create a + set res {} + interp hide a return + for {set code -1} {$code<=5} {incr code} { + lappend res [catch {interp invokehidden a return -code $code ret$code}] + } + interp delete a + set res +} {-1 0 1 2 3 4 5} + +test interp-26.5 {result code transmission: invoke hidden indirect--bug 1637} \ + {knownBug} { + # The known bug is that the break and continue should raise errors + # that they are used outside a loop. + catch {interp delete a} + interp create a + set res {} + interp eval a {proc retcode {code} {return -code $code ret$code}} + interp hide a retcode + for {set code -1} {$code<=5} {incr code} { + lappend res [catch {interp invokehidden a retcode $code} msg] $msg + } + interp delete a + set res +} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} + +test interp-26.6 {result code transmission: all combined--bug 1637} \ + {knownBug} { + # Test that all the possibles error codes from Tcl get passed + # In both directions. This doesn't work. set interp [interp create]; proc MyTestAlias {interp args} { global aliasTrace; @@ -1968,17 +2031,22 @@ test interp-26.2 {result code transmission 2} {knownBug} { interp hide $interp $c; interp alias $interp $c {} MyTestAlias $interp $c; } - interp eval $interp {proc ret {code} {return -code $code $code}} + interp eval $interp {proc ret {code} {return -code $code ret$code}} set res {} set aliasTrace {} for {set code -1} {$code<=5} {incr code} { - lappend res [catch {interp eval $interp ret $code} msg] + lappend res [catch {interp eval $interp ret $code} msg] $msg } interp delete $interp; - list $res -} {-1 0 1 2 3 4 5} + set res +} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} + +# Some tests might need to be added to check for difference between +# toplevel and non toplevel evals. + +# End of return code transmission section -test interp-26.3 {errorInfo transmission : regular interps} { +test interp-26.7 {errorInfo transmission: regular interps} { set interp [interp create]; proc MyError {secret} { return -code error "msg" @@ -1993,14 +2061,15 @@ test interp-26.3 {errorInfo transmission : regular interps} { } {msg while executing "MyError "some secret"" - (procedure "test" line 2) + (procedure "MyTestAlias" line 2) invoked from within -"catch test"} +"test"} -test interp-26.4 {errorInfo transmission : safe interps} {knownBug} { +test interp-26.8 {errorInfo transmission: safe interps--bug 1637} {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. + # whether the interp is safe or not. The errorInfo should never + # report data from the master interpreter because it could + # contain sensitive information. set interp [interp create -safe]; proc MyError {secret} { return -code error "msg" @@ -2014,7 +2083,7 @@ test interp-26.4 {errorInfo transmission : safe interps} {knownBug} { set res } {msg while executing -"catch test"} +"test"} # Interps & Namespaces test interp-27.1 {interp aliases & namespaces} { @@ -2163,7 +2232,7 @@ test interp-27.4 {interp aliases & namespaces} { # 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)}} +# } {{slave bar called (foo-slave) (bar test1) (::tcltest) (::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 { @@ -2264,6 +2333,28 @@ test interp-30.1 {deletion of aliases inside namespaces} { $i alias ns::cmd {} } {} +test interp-31.1 {alias invocation scope} { + proc mySet {varName value} { + upvar 1 $varName localVar + set localVar $value + } + + interp alias {} myNewSet {} mySet + proc testMyNewSet {value} { + myNewSet a $value + return $a + } + catch {unset a} + set result [testMyNewSet "ok"] + rename testMyNewSet {} + rename mySet {} + rename myNewSet {} + set result +} ok + +# cleanup foreach i [interp slaves] { interp delete $i } +::tcltest::cleanupTests +return diff --git a/tests/io.test b/tests/io.test index 51dc6ae..620bc48 100644 --- a/tests/io.test +++ b/tests/io.test @@ -7,13 +7,16 @@ # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: io.test,v 1.6 1998/11/02 23:04:14 stanton Exp $ +# RCS: @(#) $Id: io.test,v 1.7 1999/04/16 00:47:29 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {"[info commands testchannel]" != "testchannel"} { puts "Skipping io tests. This application does not seem to have the" @@ -21,6 +24,8 @@ if {"[info commands testchannel]" != "testchannel"} { return } +::tcltest::saveState + removeFile test1 removeFile pipe @@ -35,95 +40,1544 @@ for { set i 0 } { $i < 100 } { incr i} { } close $f -set f [open cat w] -puts $f { - if {$argv == {}} { - set argv - - } - foreach name $argv { - if {$name == "-"} { - set f stdin - } elseif {[catch {open $name r} f] != 0} { - puts stderr $f - continue - } - while {[eof $f] == 0} { - puts -nonewline stdout [read $f] - } - if {$f != "stdin"} { +makeFile { + set f stdin + if {$argv != ""} { + set f [open $argv] + } + fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a + fconfigure stdout -encoding binary -translation lf -buffering none + fileevent $f readable "foo $f" + proc foo {f} { + set x [read $f] + catch {puts -nonewline $x} + if {[eof $f]} { close $f + exit 0 } } -} -close $f + vwait forever +} cat + +set thisScript [file join [pwd] [info script]] # 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 io-1.1 {unsupported0 command} {knownBug} { + removeFile test1 + set f1 [open iocmd.test] + set f2 [open test1 w] + unsupported0 $f1 $f2 + close $f1 + catch {close $f2} + set s1 [file size $thisScript] + set s2 [file size test1] + set x ok + if {"$s1" != "$s2"} { + set x broken + } + set x +} ok +test io-1.2 {unsupported0 command} {knownBug} { + removeFile test1 + set f1 [open $thisScript] + set f2 [open test1 w] + unsupported0 $f1 $f2 40 + close $f1 + close $f2 + file size test1 +} 40 +test io-1.3 {unsupported0 command} {knownBug} { + removeFile test1 + set f1 [open $thisScript] + set f2 [open test1 w] + unsupported0 $f1 $f2 -1 + close $f1 + close $f2 + set x ok + set s1 [file size $thisScript] + set s2 [file size test1] + if {$s1 != $s2} { + set x broken + } + set x +} ok +test io-1.4 {unsupported0 command} {knownBug unixOrPc} { + removeFile pipe + removeFile test1 + set f1 [open pipe w] + puts $f1 {puts ready} + puts $f1 {gets stdin} + puts $f1 {set f1 [open $thisScript 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} + +proc contents {file} { + set f [open $file] + fconfigure $f -translation binary + set a [read $f] + close $f + return $a +} + +test io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} { + # no test, need to cause an async error. +} {} +test io-1.6 {Tcl_WriteChars: WriteBytes} { + set f [open test1 w] + fconfigure $f -encoding binary + puts -nonewline $f "a\u4e4d\0" + close $f + contents test1 +} "a\x4d\x00" +test io-1.7 {Tcl_WriteChars: WriteChars} { + set f [open test1 w] + fconfigure $f -encoding shiftjis + puts -nonewline $f "a\u4e4d\0" + close $f + contents test1 +} "a\x93\xe1\x00" + +test io-2.1 {WriteBytes} { + # loop until all bytes are written + + set f [open test1 w] + fconfigure $f -encoding binary -buffersize 16 -translation crlf + puts $f "abcdefghijklmnopqrstuvwxyz" + close $f + contents test1 +} "abcdefghijklmnopqrstuvwxyz\r\n" +test io-2.2 {WriteBytes: savedLF > 0} { + # After flushing buffer, there was a \n left over from the last + # \n -> \r\n expansion. It gets stuck at beginning of this buffer. + + set f [open test1 w] + fconfigure $f -encoding binary -buffersize 16 -translation crlf + puts -nonewline $f "123456789012345\n12" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "123456789012345\r" "123456789012345\r\n12"] +test io-2.3 {WriteBytes: flush on line} { + # Tcl "line" buffering has weird behavior: if current buffer contains + # a \n, entire buffer gets flushed. Logical behavior would be to flush + # only up to the \n. + + set f [open test1 w] + fconfigure $f -encoding binary -buffering line -translation crlf + puts -nonewline $f "\n12" + set x [contents test1] + close $f + set x +} "\r\n12" +test io-2.4 {WriteBytes: reset sawLF after each buffer} { + set f [open test1 w] + fconfigure $f -encoding binary -buffering line -translation lf \ + -buffersize 16 + puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"] + +test io-3.1 {WriteChars: compatibility with WriteBytes} { + # loop until all bytes are written + + set f [open test1 w] + fconfigure $f -encoding ascii -buffersize 16 -translation crlf + puts $f "abcdefghijklmnopqrstuvwxyz" + close $f + contents test1 +} "abcdefghijklmnopqrstuvwxyz\r\n" +test io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} { + # After flushing buffer, there was a \n left over from the last + # \n -> \r\n expansion. It gets stuck at beginning of this buffer. + + set f [open test1 w] + fconfigure $f -encoding ascii -buffersize 16 -translation crlf + puts -nonewline $f "123456789012345\n12" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "123456789012345\r" "123456789012345\r\n12"] +test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { + # Tcl "line" buffering has weird behavior: if current buffer contains + # a \n, entire buffer gets flushed. Logical behavior would be to flush + # only up to the \n. + + set f [open test1 w] + fconfigure $f -encoding ascii -buffering line -translation crlf + puts -nonewline $f "\n12" + set x [contents test1] + close $f + set x +} "\r\n12" +test io-3.4 {WriteChars: loop over stage buffer} { + # stage buffer maps to more than can be queued at once. + + set f [open test1 w] + fconfigure $f -encoding jis0208 -buffersize 16 + puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test io-3.5 {WriteChars: saved != 0} { + # Bytes produced by UtfToExternal from end of last channel buffer + # had to be moved to beginning of next channel buffer to preserve + # requested buffersize. + + set f [open test1 w] + fconfigure $f -encoding jis0208 -buffersize 17 + puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { + # One incomplete UTF-8 character at end of staging buffer. Backup + # in src to the beginning of that UTF-8 character and try again. + # + # Translate the first 16 bytes, produce 14 bytes of output, 2 left over + # (first two bytes of \uff21 in UTF-8). Given those two bytes try + # translating them again, find that no bytes are read produced, and break + # to outer loop where those two bytes will have the remaining 4 bytes + # (the last byte of \uff21 plus the all of \uff22) appended. + + set f [open test1 w] + fconfigure $f -encoding shiftjis -buffersize 16 + puts -nonewline $f "12345678901234\uff21\uff22" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] +test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { + # When translating UTF-8 to external, the produced bytes went past end + # of the channel buffer. This is done purpose -- we then truncate the + # bytes at the end of the partial character to preserve the requested + # blocksize on flush. The truncated bytes are moved to the beginning + # of the next channel buffer. + + set f [open test1 w] + fconfigure $f -encoding jis0208 -buffersize 17 + puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test io-3.8 {WriteChars: reset sawLF after each buffer} { + set f [open test1 w] + fconfigure $f -encoding ascii -buffering line -translation lf \ + -buffersize 16 + puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"] + +test io-4.1 {TranslateOutputEOL: lf} { + # search for \n + + set f [open test1 w] + fconfigure $f -buffering line -translation lf + puts $f "abcde" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "abcde\n" "abcde\n"] +test io-4.2 {TranslateOutputEOL: cr} { + # search for \n, replace with \r + + set f [open test1 w] + fconfigure $f -buffering line -translation cr + puts $f "abcde" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "abcde\r" "abcde\r"] +test io-4.3 {TranslateOutputEOL: crlf} { + # simple case: search for \n, replace with \r + + set f [open test1 w] + fconfigure $f -buffering line -translation crlf + puts $f "abcde" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "abcde\r\n" "abcde\r\n"] +test io-4.4 {TranslateOutputEOL: crlf} { + # keep storing more bytes in output buffer until output buffer is full. + # We have 13 bytes initially that would turn into 18 bytes. Fill + # dest buffer while (dstEnd < dstMax). + + set f [open test1 w] + fconfigure $f -translation crlf -buffersize 16 + puts -nonewline $f "1234567\n\n\n\n\nA" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "1234567\r\n\r\n\r\n\r\n\r" "1234567\r\n\r\n\r\n\r\n\r\nA"] +test io-4.5 {TranslateOutputEOL: crlf} { + # Check for overflow of the destination buffer + + set f [open test1 w] + fconfigure $f -translation crlf -buffersize 12 + puts -nonewline $f "12345678901\n456789012345678901234" + close $f + set x [contents test1] +} "12345678901\r\n456789012345678901234" + +test io-5.1 {CheckFlush: not full} { + set f [open test1 w] + fconfigure $f + puts -nonewline $f "12345678901234567890" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "" "12345678901234567890"] +test io-5.2 {CheckFlush: full} { + set f [open test1 w] + fconfigure $f -buffersize 16 + puts -nonewline $f "12345678901234567890" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "1234567890123456" "12345678901234567890"] +test io-5.3 {CheckFlush: not line} { + set f [open test1 w] + fconfigure $f -buffering line + puts -nonewline $f "12345678901234567890" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "" "12345678901234567890"] +test io-5.4 {CheckFlush: line} { + set f [open test1 w] + fconfigure $f -buffering line -translation lf -encoding ascii + puts -nonewline $f "1234567890\n1234567890" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "1234567890\n1234567890" "1234567890\n1234567890"] +test io-5.5 {CheckFlush: none} { + set f [open test1 w] + fconfigure $f -buffering none + puts -nonewline $f "1234567890" + set x [list [contents test1]] + close $f + lappend x [contents test1] +} [list "1234567890" "1234567890"] + +test io-6.1 {Tcl_GetsObj: working} { + set f [open test1 w] + puts $f "foo\nboo" + close $f + set f [open test1] + set x [gets $f] + close $f + set x +} {foo} +test io-6.2 {Tcl_GetsObj: CheckChannelErrors() != 0} { + # no test, need to cause an async error. +} {} +test io-6.3 {Tcl_GetsObj: how many have we used?} { + # if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved} + + set f [open test1 w] + fconfigure $f -translation crlf + puts $f "abc\ndefg" + close $f + set f [open test1] + set x [list [tell $f] [gets $f line] [tell $f] [gets $f line] $line] + close $f + set x +} {0 3 5 4 defg} +test io-6.4 {Tcl_GetsObj: encoding == NULL} { + set f [open test1 w] + fconfigure $f -translation binary + puts $f "\x81\u1234\0" + close $f + set f [open test1] + fconfigure $f -translation binary + set x [list [gets $f line] $line] + close $f + set x +} [list 3 "\x81\x34\x00"] +test io-6.5 {Tcl_GetsObj: encoding != NULL} { + set f [open test1 w] + fconfigure $f -translation binary + puts $f "\x88\xea\x92\x9a" + close $f + set f [open test1] + fconfigure $f -encoding shiftjis + set x [list [gets $f line] $line] + close $f + set x +} [list 2 "\u4e00\u4e01"] +set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" +append a $a +append a $a +test io-6.6 {Tcl_GetsObj: loop test} { + # if (dst >= dstEnd) + + set f [open test1 w] + puts $f $a + puts $f hi + close $f + set f [open test1] + set x [list [gets $f line] $line] + close $f + set x +} [list 256 $a] +test io-6.7 {Tcl_GetsObj: error in input} {stdio} { + # if (FilterInputBytes(chanPtr, &gs) != 0) + + set f [open "|[list $tcltest cat]" w+] + puts -nonewline $f "hi\nwould" + flush $f + gets $f + fconfigure $f -blocking 0 + set x [gets $f line] + close $f + set x +} {-1} +test io-6.8 {Tcl_GetsObj: remember if EOF is seen} { + set f [open test1 w] + puts $f "abcdef\x1aghijk\nwombat" + close $f + set f [open test1] + fconfigure $f -eofchar \x1a + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {6 abcdef -1 {}} +test io-6.9 {Tcl_GetsObj: remember if EOF is seen} { + set f [open test1 w] + puts $f "abcdefghijk\nwom\u001abat" + close $f + set f [open test1] + fconfigure $f -eofchar \x1a + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {11 abcdefghijk 3 wom} + +# Comprehensive tests + +test io-6.10 {Tcl_GetsObj: lf mode: no chars} { + set f [open test1 w] + close $f + set f [open test1] + fconfigure $f -translation lf + set x [list [gets $f line] $line] + close $f + set x +} {-1 {}} +test io-6.11 {Tcl_GetsObj: lf mode: lone \n} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\n" + close $f + set f [open test1] + fconfigure $f -translation lf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {0 {} -1 {}} +test io-6.12 {Tcl_GetsObj: lf mode: lone \r} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r" + close $f + set f [open test1] + fconfigure $f -translation lf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 1 "\r" -1 ""] +test io-6.13 {Tcl_GetsObj: lf mode: 1 char} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f a + close $f + set f [open test1] + fconfigure $f -translation lf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\n" + close $f + set f [open test1] + fconfigure $f -translation lf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.15 {Tcl_GetsObj: lf mode: several chars} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" + close $f + set f [open test1] + fconfigure $f -translation lf + set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""] +test io-6.16 {Tcl_GetsObj: cr mode: no chars} { + set f [open test1 w] + close $f + set f [open test1] + fconfigure $f -translation cr + set x [list [gets $f line] $line] + close $f + set x +} {-1 {}} +test io-6.17 {Tcl_GetsObj: cr mode: lone \n} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\n" + close $f + set f [open test1] + fconfigure $f -translation cr + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 1 "\n" -1 ""] +test io-6.18 {Tcl_GetsObj: cr mode: lone \r} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r" + close $f + set f [open test1] + fconfigure $f -translation cr + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {0 {} -1 {}} +test io-6.19 {Tcl_GetsObj: cr mode: 1 char} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f a + close $f + set f [open test1] + fconfigure $f -translation cr + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\r" + close $f + set f [open test1] + fconfigure $f -translation cr + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.21 {Tcl_GetsObj: cr mode: several chars} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" + close $f + set f [open test1] + fconfigure $f -translation cr + set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""] +test io-6.22 {Tcl_GetsObj: crlf mode: no chars} { + set f [open test1 w] + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line] + close $f + set x +} {-1 {}} +test io-6.23 {Tcl_GetsObj: crlf mode: lone \n} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\n" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 1 "\n" -1 ""] +test io-6.24 {Tcl_GetsObj: crlf mode: lone \r} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 1 "\r" -1 ""] +test io-6.25 {Tcl_GetsObj: crlf mode: \r\r} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r\r" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 2 "\r\r" -1 ""] +test io-6.26 {Tcl_GetsObj: crlf mode: \r\n} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r\n" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 0 "" -1 ""] +test io-6.27 {Tcl_GetsObj: crlf mode: 1 char} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f a + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\r\n" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.29 {Tcl_GetsObj: crlf mode: several chars} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""] +test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} { + # if (eol >= dstEnd) + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456789012345\r\nabcdefghijklmnoprstuvwxyz" + close $f + set f [open test1] + fconfigure $f -translation crlf -buffersize 16 + set x [list [gets $f line] $line [testchannel inputbuffered $f]] + close $f + set x +} [list 15 "123456789012345" 15] +test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio} { + # (FilterInputBytes() != 0) + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {crlf lf} -buffering none + puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r" + fconfigure $f -buffersize 16 + set x [gets $f] + fconfigure $f -blocking 0 + lappend x [gets $f line] $line [fblocked $f] [testchannel inputbuffered $f] + close $f + set x +} [list "bbbbbbbbbbbbbb" -1 "" 1 16] +test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} { + # not (FilterInputBytes() != 0) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456789012345\r\n123" + close $f + set f [open test1] + fconfigure $f -translation crlf -buffersize 16 + set x [list [gets $f line] $line [tell $f] [testchannel inputbuffered $f]] + close $f + set x +} [list 15 "123456789012345" 17 3] +test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { + # eol still equals dstEnd + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456789012345\r" + close $f + set f [open test1] + fconfigure $f -translation crlf -buffersize 16 + set x [list [gets $f line] $line [eof $f]] + close $f + set x +} [list 16 "123456789012345\r" 1] +test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} { + # not (*eol == '\n') + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456789012345\rabcd\r\nefg" + close $f + set f [open test1] + fconfigure $f -translation crlf -buffersize 16 + set x [list [gets $f line] $line [tell $f]] + close $f + set x +} [list 20 "123456789012345\rabcd" 22] +test io-6.35 {Tcl_GetsObj: auto mode: no chars} { + set f [open test1 w] + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line] + close $f + set x +} {-1 {}} +test io-6.36 {Tcl_GetsObj: auto mode: lone \n} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\n" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 0 "" -1 ""] +test io-6.37 {Tcl_GetsObj: auto mode: lone \r} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 0 "" -1 ""] +test io-6.38 {Tcl_GetsObj: auto mode: \r\r} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r\r" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 0 "" 0 "" -1 ""] +test io-6.39 {Tcl_GetsObj: auto mode: \r\n} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r\n" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 0 "" -1 ""] +test io-6.40 {Tcl_GetsObj: auto mode: 1 char} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f a + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "a\r\n" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line [gets $f line] $line] + close $f + set x +} {1 a -1 {}} +test io-6.42 {Tcl_GetsObj: auto mode: several chars} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [gets $f line] $line [gets $f line] $line] + lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line + close $f + set x +} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""] +test io-6.43 {Tcl_GetsObj: input saw cr} {stdio} { + # if (chanPtr->flags & INPUT_SAW_CR) + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto lf} -buffering none + puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" + fconfigure $f -buffersize 16 + set x [list [gets $f]] + fconfigure $f -blocking 0 + lappend x [gets $f line] $line [testchannel queuedcr $f] + fconfigure $f -blocking 1 + puts -nonewline $f "\nabcd\refg\x1a" + lappend x [gets $f line] $line [testchannel queuedcr $f] + lappend x [gets $f line] $line + close $f + set x +} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] +test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio} { + # not (*eol == '\n') + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto lf} -buffering none + puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" + fconfigure $f -buffersize 16 + set x [list [gets $f]] + fconfigure $f -blocking 0 + lappend x [gets $f line] $line [testchannel queuedcr $f] + fconfigure $f -blocking 1 + puts -nonewline $f "abcd\refg\x1a" + lappend x [gets $f line] $line [testchannel queuedcr $f] + lappend x [gets $f line] $line + close $f + set x +} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] +test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio} { + # Tcl_ExternalToUtf() + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto lf} -buffering none + fconfigure $f -encoding unicode + puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" + fconfigure $f -buffersize 16 + gets $f + fconfigure $f -blocking 0 + set x [list [gets $f line] $line [testchannel queuedcr $f]] + fconfigure $f -blocking 1 + puts -nonewline $f "\nabcd\refg" + lappend x [gets $f line] $line [testchannel queuedcr $f] + close $f + set x +} [list 15 "123456789abcdef" 1 4 "abcd" 0] +test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio} { + # memmove() + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto lf} -buffering none + puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" + fconfigure $f -buffersize 16 + gets $f + fconfigure $f -blocking 0 + set x [list [gets $f line] $line [testchannel queuedcr $f]] + fconfigure $f -blocking 1 + puts -nonewline $f "\n\x1a" + lappend x [gets $f line] $line [testchannel queuedcr $f] + close $f + set x +} [list 15 "123456789abcdef" 1 -1 "" 0] +test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} { + # (eol == dstEnd) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456789012345\r\nabcdefghijklmnopq" + close $f + set f [open test1] + fconfigure $f -translation auto -buffersize 16 + set x [list [gets $f] [testchannel inputbuffered $f]] + close $f + set x +} [list "123456789012345" 15] +test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} { + # PeekAhead() did not get any, so (eol >= dstEnd) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456789012345\r" + close $f + set f [open test1] + fconfigure $f -translation auto -buffersize 16 + set x [list [gets $f] [testchannel queuedcr $f]] + close $f + set x +} [list "123456789012345" 1] +test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} { + # if (*eol == '\n') {skip++} + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456\r\n78901" + close $f + set f [open test1] + set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]] + close $f + set x +} [list "123456" 0 8 "78901"] +test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} { + # not (*eol == '\n') + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456\r78901" + close $f + set f [open test1] + set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]] + close $f + set x +} [list "123456" 0 7 "78901"] +test io-6.51 {Tcl_GetsObj: auto mode: \n} { + # else if (*eol == '\n') {goto gotoeol;} + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456\n78901" + close $f + set f [open test1] + set x [list [gets $f] [tell $f] [gets $f]] + close $f + set x +} [list "123456" 7 "78901"] +test io-6.52 {Tcl_GetsObj: saw EOF character} { + # if (eof != NULL) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "123456\x1ak9012345\r" + close $f + set f [open test1] + fconfigure $f -eofchar \x1a + set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]] + close $f + set x +} [list "123456" 0 6 ""] +test io-6.53 {Tcl_GetsObj: device EOF} { + # didn't produce any bytes + + set f [open test1 w] + close $f + set f [open test1] + set x [list [gets $f line] $line [eof $f]] + close $f + set x +} {-1 {} 1} +test io-6.54 {Tcl_GetsObj: device EOF} { + # got some bytes before EOF. + + set f [open test1 w] + puts -nonewline $f abc + close $f + set f [open test1] + set x [list [gets $f line] $line [eof $f]] + close $f + set x +} {3 abc 1} +test io-6.55 {Tcl_GetsObj: overconverted} { + # Tcl_ExternalToUtf(), make sure state updated + + set f [open test1 w] + fconfigure $f -encoding iso2022-jp + puts $f "there\u4e00ok\n\u4e01more bytes\nhere" + close $f + set f [open test1] + fconfigure $f -encoding iso2022-jp + set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] + close $f + set x +} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] +test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio} { + update + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -buffering none + puts -nonewline $f "foobar" + fconfigure $f -blocking 0 + set x {} + after 500 { lappend x timeout } + fileevent $f readable { lappend x [gets $f] } + vwait x + vwait x + fconfigure $f -blocking 1 + puts -nonewline $f "baz\n" + after 500 { lappend x timeout } + fconfigure $f -blocking 0 + vwait x + vwait x + close $f + set x +} {{} timeout foobarbaz timeout} + +test io-7.1 {FilterInputBytes: split up character at end of buffer} { + # (result == TCL_CONVERT_MULTIBYTE) + + set f [open test1 w] + fconfigure $f -encoding shiftjis + puts $f "1234567890123\uff10\uff11\uff12\uff13\uff14\nend" + close $f + set f [open test1] + fconfigure $f -encoding shiftjis -buffersize 16 + set x [gets $f] + close $f + set x +} "1234567890123\uff10\uff11\uff12\uff13\uff14" +test io-7.2 {FilterInputBytes: split up character in middle of buffer} { + # (bufPtr->nextAdded < bufPtr->bufLength) + + set f [open test1 w] + fconfigure $f -encoding binary + puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82" + close $f + set f [open test1] + fconfigure $f -encoding shiftjis + set x [list [gets $f line] $line [eof $f]] + close $f + set x +} [list 10 "1234567890" 0] +test io-7.3 {FilterInputBytes: split up character at EOF} { + set f [open test1 w] + fconfigure $f -encoding binary + puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" + close $f + set f [open test1] + fconfigure $f -encoding shiftjis + set x [list [gets $f line] $line] + lappend x [tell $f] [testchannel inputbuffered $f] [eof $f] + lappend x [gets $f line] $line + close $f + set x +} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] +test io-7.4 {FilterInputBytes: recover from split up character} {stdio} { + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -encoding binary -buffering none + puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" + fconfigure $f -encoding shiftjis -blocking 0 + fileevent $f read "ready $f" + set x {} + proc ready {f} { + lappend ::x [gets $f line] $line [fblocked $f] + } + vwait x + fconfigure $f -encoding binary -blocking 1 + puts $f "\x51\x82\x52" + fconfigure $f -encoding shiftjis + vwait x + close $f + set x +} [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0] + +test io-8.1 {PeekAhead: only go to device if no more cached data} { + # (bufPtr->nextPtr == NULL) + + set f [open "test1" w] + fconfigure $f -encoding ascii -translation lf + puts -nonewline $f "123456789012345\r\n2345678" + close $f + set f [open "test1"] + fconfigure $f -encoding ascii -translation auto -buffersize 16 + # here + gets $f + set x [testchannel inputbuffered $f] + close $f + set x +} "7" +test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio} { + # not (bufPtr->nextPtr == NULL) + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation lf -encoding ascii -buffering none + puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz" + set x {} + fileevent $f read "ready $f" + proc ready {f} { + lappend ::x [gets $f line] $line [testchannel inputbuffered $f] + } + fconfigure $f -encoding unicode -buffersize 16 -blocking 0 + vwait x + fconfigure $f -translation auto -encoding ascii -blocking 1 + # here + vwait x + close $f + set x +} [list -1 "" 42 15 "123456789012345" 25] +test io-8.3 {PeekAhead: no cached data available} {stdio} { + # (bytesLeft == 0) + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto binary} + puts -nonewline $f "abcdefghijklmno\r" + flush $f + set x [list [gets $f line] $line [testchannel queuedcr $f]] + close $f + set x +} [list 15 "abcdefghijklmno" 1] +set a "123456789012345678901234567890" +append a "123456789012345678901234567890" +append a "1234567890123456789012345678901" +test io-8.4 {PeekAhead: cached data available in this buffer} { + # not (bytesLeft == 0) + + set f [open test1 w+] + fconfigure $f -translation binary + puts $f "${a}\r\nabcdef" + close $f + set f [open test1] + fconfigure $f -encoding binary -translation auto + + # "${a}\r" was converted in one operation (because ENCODING_LINESIZE + # is 30). To check if "\n" follows, calls PeekAhead and determines + # that cached data is available in buffer w/o having to call driver. + + set x [gets $f] + close $f + set x +} $a +unset a +test io-8.5 {PeekAhead: don't peek if last read was short} {stdio} { + # (bufPtr->nextAdded < bufPtr->length) + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto binary} + puts -nonewline $f "abcdefghijklmno\r" + flush $f + # here + set x [list [gets $f line] $line [testchannel queuedcr $f]] + close $f + set x +} {15 abcdefghijklmno 1} +test io-8.6 {PeekAhead: change to non-blocking mode} {stdio} { + # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto binary} -buffersize 16 + puts -nonewline $f "abcdefghijklmno\r" + flush $f + # here + set x [list [gets $f line] $line [testchannel queuedcr $f]] + close $f + set x +} {15 abcdefghijklmno 1} +test io-8.7 {PeekAhead: cleanup} {stdio} { + # Make sure bytes are removed from buffer. + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -translation {auto binary} -buffering none + puts -nonewline $f "abcdefghijklmno\r" + # here + set x [list [gets $f line] $line [testchannel queuedcr $f]] + puts -nonewline $f "\x1a" + lappend x [gets $f line] $line + close $f + set x +} {15 abcdefghijklmno 1 -1 {}} + + +test io-9.1 {CommonGetsCleanup} { +} {} + +test io-10.1 {Tcl_ReadChars: CheckChannelErrors} { + # no test, need to cause an async error. +} {} +test io-10.2 {Tcl_ReadChars: loop until enough copied} { + # one time + # for (copied = 0; (unsigned) toRead > 0; ) + + set f [open "test1" w] + puts $f abcdefghijklmnop + close $f + + set f [open "test1"] + set x [read $f 5] + close $f + set x +} {abcde} +test io-10.3 {Tcl_ReadChars: loop until enough copied} { + # multiple times + # for (copied = 0; (unsigned) toRead > 0; ) + + set f [open "test1" w] + puts $f abcdefghijklmnopqrstuvwxyz + close $f + + set f [open "test1"] + fconfigure $f -buffersize 16 + # here + set x [read $f 19] + close $f + set x +} {abcdefghijklmnopqrs} +test io-10.4 {Tcl_ReadChars: no more in channel buffer} { + # (copiedNow < 0) + + set f [open "test1" w] + puts -nonewline $f abcdefghijkl + close $f + + set f [open "test1"] + # here + set x [read $f 1000] + close $f + set x +} {abcdefghijkl} +test io-10.5 {Tcl_ReadChars: stop on EOF} { + # (chanPtr->flags & CHANNEL_EOF) + + set f [open "test1" w] + puts -nonewline $f abcdefghijkl + close $f + + set f [open "test1"] + # here + set x [read $f 1000] + close $f + set x +} {abcdefghijkl} + +test io-11.1 {ReadBytes: want to read a lot} { + # ((unsigned) toRead > (unsigned) srcLen) + + set f [open "test1" w] + puts -nonewline $f abcdefghijkl + close $f + set f [open "test1"] + fconfigure $f -encoding binary + # here + set x [read $f 1000] + close $f + set x +} {abcdefghijkl} +test io-11.2 {ReadBytes: want to read all} { + # ((unsigned) toRead > (unsigned) srcLen) + + set f [open "test1" w] + puts -nonewline $f abcdefghijkl + close $f + set f [open "test1"] + fconfigure $f -encoding binary + # here + set x [read $f] + close $f + set x +} {abcdefghijkl} +test io-11.3 {ReadBytes: allocate more space} { + # (toRead > length - offset - 1) + + set f [open "test1" w] + puts -nonewline $f abcdefghijklmnopqrstuvwxyz + close $f + set f [open "test1"] + fconfigure $f -buffersize 16 -encoding binary + # here + set x [read $f] + close $f + set x +} {abcdefghijklmnopqrstuvwxyz} +test io-11.4 {ReadBytes: EOF char found} { + # (TranslateInputEOL() != 0) + + set f [open "test1" w] + puts $f abcdefghijklmnopqrstuvwxyz + close $f + set f [open "test1"] + fconfigure $f -eofchar m -encoding binary + # here + set x [list [read $f] [eof $f] [read $f] [eof $f]] + close $f + set x +} [list "abcdefghijkl" 1 "" 1] + +test io-12.1 {ReadChars: want to read a lot} { + # ((unsigned) toRead > (unsigned) srcLen) + + set f [open "test1" w] + puts -nonewline $f abcdefghijkl + close $f + set f [open "test1"] + # here + set x [read $f 1000] + close $f + set x +} {abcdefghijkl} +test io-12.2 {ReadChars: want to read all} { + # ((unsigned) toRead > (unsigned) srcLen) + + set f [open "test1" w] + puts -nonewline $f abcdefghijkl + close $f + set f [open "test1"] + # here + set x [read $f] + close $f + set x +} {abcdefghijkl} +test io-12.3 {ReadChars: allocate more space} { + # (toRead > length - offset - 1) + + set f [open "test1" w] + puts -nonewline $f abcdefghijklmnopqrstuvwxyz + close $f + set f [open "test1"] + fconfigure $f -buffersize 16 + # here + set x [read $f] + close $f + set x +} {abcdefghijklmnopqrstuvwxyz} +test io-12.4 {ReadChars: split-up char} {stdio} { + # (srcRead == 0) + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -encoding binary -buffering none -buffersize 16 + puts -nonewline $f "123456789012345\x96" + fconfigure $f -encoding shiftjis -blocking 0 + + fileevent $f read "ready $f" + proc ready {f} { + lappend ::x [read $f] [testchannel inputbuffered $f] + } + set x {} + + fconfigure $f -encoding shiftjis + vwait x + fconfigure $f -encoding binary -blocking 1 + puts -nonewline $f "\x7b" + after 500 ;# Give the cat process time to catch up + fconfigure $f -encoding shiftjis -blocking 0 + vwait x + close $f + set x +} [list "123456789012345" 1 "\u672c" 0] +test io-12.5 {ReadChars: fileevents on partial characters} {stdio} { + makeFile { + fconfigure stdout -encoding binary -buffering none + gets stdin; puts -nonewline "\xe7" + gets stdin; puts -nonewline "\x89" + gets stdin; puts -nonewline "\xa6" + } test1 + set f [open "|[list $tcltest test1]" r+] + fileevent $f readable { + lappend x [read $f] + if {[eof $f]} { + lappend x eof + } + } + puts $f "go1" + flush $f + fconfigure $f -blocking 0 -encoding utf-8 + set x {} + vwait x + after 500 { lappend x timeout } + vwait x + puts $f "go2" + flush $f + vwait x + after 500 { lappend x timeout } + vwait x + puts $f "go3" + flush $f + vwait x + vwait x + lappend x [catch {close $f} msg] $msg + set x +} "{} timeout {} timeout \u7266 {} eof 0 {}" + +test io-13.1 {TranslateInputEOL: cr mode} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\rdef\r" + close $f + set f [open test1] + fconfigure $f -translation cr + set x [read $f] + close $f + set x +} "abcd\ndef\n" +test io-13.2 {TranslateInputEOL: crlf mode} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef\r\n" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "abcd\ndef\n" +test io-13.3 {TranslateInputEOL: crlf mode: naked cr} { + # (src >= srcMax) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef\r" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "abcd\ndef\r" +test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { + # (src >= srcMax) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef\rfgh" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "abcd\ndef\rfgh" +test io-13.5 {TranslateInputEOL: crlf mode: naked lf} { + # (src >= srcMax) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef\nfgh" + close $f + set f [open test1] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "abcd\ndef\nfgh" +test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio} { + # (chanPtr->flags & INPUT_SAW_CR) + # This test may fail on slower machines. + + set f [open "|[list $tcltest cat]" w+] + fconfigure $f -blocking 0 -buffering none -translation {auto lf} + + fileevent $f read "ready $f" + proc ready {f} { + lappend ::x [read $f] [testchannel queuedcr $f] + } + set x {} + + puts -nonewline $f "abcdefghj\r" + after 500 {set y ok} + vwait y + + puts -nonewline $f "\n01234" + after 500 {set y ok} + vwait y + + close $f + set x +} [list "abcdefghj\n" 1 "01234" 0] +test io-13.7 {TranslateInputEOL: auto mode: naked \r} { + # (src >= srcMax) + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [list [read $f] [testchannel queuedcr $f]] + close $f + set x +} [list "abcd\n" 1] +test io-13.8 {TranslateInputEOL: auto mode: \r\n} { + # (*src == '\n') + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [read $f] + close $f + set x +} "abcd\ndef" +test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} { + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\rdef" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [read $f] + close $f + set x +} "abcd\ndef" +test io-13.10 {TranslateInputEOL: auto mode: \n} { + # not (*src == '\r') + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\ndef" + close $f + set f [open test1] + fconfigure $f -translation auto + set x [read $f] + close $f + set x +} "abcd\ndef" +test io-13.11 {TranslateInputEOL: EOF char} { + # (*chanPtr->inEofChar != '\0') + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\ndefgh" + close $f + set f [open test1] + fconfigure $f -translation auto -eofchar e + set x [read $f] + close $f + set x +} "abcd\nd" +test io-13.12 {TranslateInputEOL: find EOF char in src} { + # (*chanPtr->inEofChar != '\0') + + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f "\r\n\r\n\r\nab\r\n\r\ndef\r\n\r\n\r\n" + close $f + set f [open test1] + fconfigure $f -translation auto -eofchar e + set x [read $f] + close $f + set x +} "\n\n\nab\n\nd" + # Test standard handle management. The functions tested are # Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are # also testing channel table management. @@ -133,7 +1587,7 @@ if {$tcl_platform(platform) == "macintosh"} { } else { set consoleFileNames [lsort [testchannel open]] } -test io-1.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} { +test io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} { set l "" lappend l [fconfigure stdin -buffering] lappend l [fconfigure stdout -buffering] @@ -141,7 +1595,7 @@ test io-1.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} { lappend l [lsort [testchannel open]] set l } [list line line none $consoleFileNames] -test io-1.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { +test io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { interp create x set l "" lappend l [x eval {fconfigure stdin -buffering}] @@ -150,7 +1604,7 @@ test io-1.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { interp delete x set l } {line line none} -test io-1.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {stdio} { +test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {stdio} { set f [open test1 w] puts $f { close stdin @@ -179,7 +1633,7 @@ out } {err }} # This test relies on the fact that the smallest available fd is used first. -test io-1.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOnly} { +test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOnly} { set f [open test1 w] puts $f { close stdin close stdout @@ -207,7 +1661,7 @@ file1 } {file2 }} catch {interp delete z} -test io-1.5 {Tcl_GetChannel: stdio name translation} { +test io-14.5 {Tcl_GetChannel: stdio name translation} { interp create z eof stdin catch {z eval flush stdin} msg1 @@ -217,7 +1671,7 @@ test io-1.5 {Tcl_GetChannel: stdio name translation} { interp delete z set result } {{channel "stdin" wasn't opened for writing} {} {can not find channel named "stdin"}} -test io-1.6 {Tcl_GetChannel: stdio name translation} { +test io-14.6 {Tcl_GetChannel: stdio name translation} { interp create z eof stdout catch {z eval flush stdout} msg1 @@ -227,7 +1681,7 @@ test io-1.6 {Tcl_GetChannel: stdio name translation} { interp delete z set result } {{} {} {can not find channel named "stdout"}} -test io-1.7 {Tcl_GetChannel: stdio name translation} { +test io-14.7 {Tcl_GetChannel: stdio name translation} { interp create z eof stderr catch {z eval flush stderr} msg1 @@ -237,7 +1691,7 @@ test io-1.7 {Tcl_GetChannel: stdio name translation} { interp delete z set result } {{} {} {can not find channel named "stderr"}} -test io-1.8 {reuse of stdio special channels} {unixOnly} { +test io-14.8 {reuse of stdio special channels} {stdio} { removeFile script removeFile test1 set f [open script w] @@ -255,7 +1709,7 @@ test io-1.8 {reuse of stdio special channels} {unixOnly} { close $f set c } hello -test io-1.9 {reuse of stdio special channels} {stdio} { +test io-14.9 {reuse of stdio special channels} {stdio} { removeFile script removeFile test1 set f [open script w] @@ -274,8 +1728,11 @@ test io-1.9 {reuse of stdio special channels} {stdio} { set c } hello -# Must add test function for testing Tcl_CreateCloseHandler and -# Tcl_DeleteCloseHandler. +test io-15.1 {Tcl_CreateCloseHandler} { +} {} + +test io-16.1 {Tcl_DeleteCloseHandler} { +} {} # Test channel table management. The functions tested are # GetChannelTable, DeleteChannelTable, Tcl_RegisterChannel, @@ -284,7 +1741,7 @@ test io-1.9 {reuse of stdio special channels} {stdio} { # These functions use "eof stdin" to ensure that the standard # channels are added to the channel table of the interpreter. -test io-2.1 {GetChannelTable, DeleteChannelTable on std handles} { +test io-17.1 {GetChannelTable, DeleteChannelTable on std handles} { set l1 [testchannel refcount stdin] eof stdin interp create x @@ -296,7 +1753,7 @@ test io-2.1 {GetChannelTable, DeleteChannelTable on std handles} { lappend l [expr [testchannel refcount stdin] - $l1] set l } {0 1 0} -test io-2.2 {GetChannelTable, DeleteChannelTable on std handles} { +test io-17.2 {GetChannelTable, DeleteChannelTable on std handles} { set l1 [testchannel refcount stdout] eof stdin interp create x @@ -308,7 +1765,7 @@ test io-2.2 {GetChannelTable, DeleteChannelTable on std handles} { lappend l [expr [testchannel refcount stdout] - $l1] set l } {0 1 0} -test io-2.3 {GetChannelTable, DeleteChannelTable on std handles} { +test io-17.3 {GetChannelTable, DeleteChannelTable on std handles} { set l1 [testchannel refcount stderr] eof stdin interp create x @@ -320,7 +1777,8 @@ test io-2.3 {GetChannelTable, DeleteChannelTable on std handles} { lappend l [expr [testchannel refcount stderr] - $l1] set l } {0 1 0} -test io-2.4 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { + +test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { removeFile test1 set l "" set f [open test1 w] @@ -334,7 +1792,7 @@ test io-2.4 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { string compare [string tolower $l] \ [list 1 [format "can not find channel named \"%s\"" $f]] } 0 -test io-2.5 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { +test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { removeFile test1 set l "" set f [open test1 w] @@ -355,7 +1813,7 @@ test io-2.5 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { string compare [string tolower $l] \ [list 1 2 1 1 [format "can not find channel named \"%s\"" $f]] } 0 -test io-2.6 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { +test io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { removeFile test1 set l "" set f [open test1 w] @@ -374,20 +1832,21 @@ test io-2.6 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { string compare [string tolower $l] \ [list 1 2 1 [format "can not find channel named \"%s\"" $f]] } 0 -test io-2.7 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} { + +test io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} { eof stdin } 0 -test io-2.8 {testing Tcl_GetChannel, user opened handle} { +test io-19.2 {testing Tcl_GetChannel, user opened handle} { removeFile test1 set f [open test1 w] set x [eof $f] close $f set x } 0 -test io-2.9 {Tcl_GetChannel, channel not found} { +test io-19.3 {Tcl_GetChannel, channel not found} { list [catch {eof file34} msg] $msg } {1 {can not find channel named "file34"}} -test io-2.10 {Tcl_CreateChannel, insertion into channel table} { +test io-19.4 {Tcl_CreateChannel, insertion into channel table} { removeFile test1 set f [open test1 w] set l "" @@ -402,27 +1861,79 @@ test io-2.10 {Tcl_CreateChannel, insertion into channel table} { [list 0 [format "can not find channel named \"%s\"" $f]] } 0 +test io-20.1 {Tcl_CreateChannel: initial settings} { + set a [open test2 w] + set old [encoding system] + encoding system ascii + set f [open test1 w] + set x [fconfigure $f -encoding] + close $f + encoding system $old + close $a + set x +} {ascii} +test io-20.2 {Tcl_CreateChannel: initial settings} {pcOnly} { + set f [open test1 w+] + set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] + close $f + set x +} [list [list \x1a ""] {auto crlf}] +test io-20.3 {Tcl_CreateChannel: initial settings} {unixOnly} { + set f [open test1 w+] + set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] + close $f + set x +} {{{} {}} {auto lf}} +test io-20.4 {Tcl_CreateChannel: initial settings} {macOnly} { + set f [open test1 w+] + set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] + close $f + set x +} {{{} {}} {auto cr}} +test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio} { + set f [open script w] + puts $f { + close stdout + set f1 [open stdout w] + fconfigure $f1 -buffersize 777 + puts stderr [fconfigure stdout -buffersize] + } + close $f + set f [open "|[list $tcltest script]"] + catch {close $f} msg + set msg +} {777} + +test io-21.1 {CloseChannelsOnExit} { +} {} + # Test management of attributes associated with a channel, such as # its default translation, its name and type, etc. The functions # tested in this group are Tcl_GetChannelName, # Tcl_GetChannelType and Tcl_GetChannelFile. Tcl_GetChannelInstanceData # not tested because files do not use the instance data. -test io-3.1 {Tcl_GetChannelName} { +test io-22.1 {Tcl_GetChannelMode} { + # Not used anywhere in Tcl. +} {} + +test io-23.1 {Tcl_GetChannelName} { removeFile test1 set f [open test1 w] set n [testchannel name $f] close $f string compare $n $f } 0 -test io-3.2 {Tcl_GetChannelType} { + +test io-24.1 {Tcl_GetChannelType} { removeFile test1 set f [open test1 w] set t [testchannel type $f] close $f string compare $t file } 0 -test io-3.3 {Tcl_GetChannelFile, input} { + +test io-25.1 {Tcl_GetChannelHandle, input} { set f [open test1 w] fconfigure $f -translation lf -eofchar {} puts $f "1234567890\n098765432" @@ -435,7 +1946,7 @@ test io-3.3 {Tcl_GetChannelFile, input} { close $f set l } {10 11} -test io-3.4 {Tcl_GetChannelFile, output} { +test io-25.2 {Tcl_GetChannelHandle, output} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -451,9 +1962,18 @@ test io-3.4 {Tcl_GetChannelFile, output} { set l } {6 6 0 6} +test io-26.1 {Tcl_GetChannelInstanceData} {stdio} { + # "pid" command uses Tcl_GetChannelInstanceData + # Don't care what pid is (but must be a number), just want to exercise it. + + set f [open "|[list $tcltest << exit]"] + expr [pid $f] + close $f +} {} + # Test flushing. The functions tested here are FlushChannel. -test io-4.1 {FlushChannel, no output buffered} { +test io-27.1 {FlushChannel, no output buffered} { removeFile test1 set f [open test1 w] flush $f @@ -461,7 +1981,7 @@ test io-4.1 {FlushChannel, no output buffered} { close $f set s } 0 -test io-4.2 {FlushChannel, some output buffered} { +test io-27.2 {FlushChannel, some output buffered} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -474,7 +1994,7 @@ test io-4.2 {FlushChannel, some output buffered} { lappend l [file size test1] set l } {0 6 6} -test io-4.3 {FlushChannel, implicit flush on close} { +test io-27.3 {FlushChannel, implicit flush on close} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -485,7 +2005,7 @@ test io-4.3 {FlushChannel, implicit flush on close} { lappend l [file size test1] set l } {0 6} -test io-4.4 {FlushChannel, implicit flush when buffer fills} { +test io-27.4 {FlushChannel, implicit flush when buffer fills} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -501,7 +2021,8 @@ test io-4.4 {FlushChannel, implicit flush when buffer fills} { close $f set l } {0 60 72} -test io-4.5 {FlushChannel, implicit flush when buffer fills and on close} {unixOrPc} { +test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \ + {unixOrPc} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffersize 60 -eofchar {} @@ -515,7 +2036,8 @@ test io-4.5 {FlushChannel, implicit flush when buffer fills and on close} {unixO lappend l [file size test1] set l } {0 60 72} -test io-4.6 {FlushChannel, async flushing, async close} {stdio && asyncPipeClose} { +test io-27.6 {FlushChannel, async flushing, async close} \ + {stdio asyncPipeClose} { removeFile pipe removeFile output set f [open pipe w] @@ -546,7 +2068,7 @@ test io-4.6 {FlushChannel, async flushing, async close} {stdio && asyncPipeClose update } if {$counter == 1000} { - set result probably_broken + set result "file size only [file size output]" } else { set result ok } @@ -554,7 +2076,7 @@ test io-4.6 {FlushChannel, async flushing, async close} {stdio && asyncPipeClose # Tests closing a channel. The functions tested are CloseChannel and Tcl_Close. -test io-5.1 {CloseChannel called when all references are dropped} { +test io-28.1 {CloseChannel called when all references are dropped} { removeFile test1 set f [open test1 w] interp create x @@ -567,7 +2089,7 @@ test io-5.1 {CloseChannel called when all references are dropped} { close $f set l } {2 1} -test io-5.2 {CloseChannel called when all references are dropped} { +test io-28.2 {CloseChannel called when all references are dropped} { removeFile test1 set f [open test1 w] interp create x @@ -582,7 +2104,8 @@ test io-5.2 {CloseChannel called when all references are dropped} { close $f set l } abcdef -test io-5.3 {CloseChannel, not called before output queue is empty} {unixOrPc asyncPipeClose nonPortable tempNotPc} { +test io-28.3 {CloseChannel, not called before output queue is empty} \ + {stdio asyncPipeClose nonPortable} { removeFile pipe removeFile output set f [open pipe w] @@ -613,9 +2136,6 @@ test io-5.3 {CloseChannel, not called before output queue is empty} {unixOrPc as set f [open "|[list $tcltest pipe]" r+] fconfigure $f -blocking off -eofchar {} - # Under windows, the first 24576 bytes of $x are copied to $f, and - # then the writing fails. - puts -nonewline $f $x close $f set counter 0 @@ -630,7 +2150,7 @@ test io-5.3 {CloseChannel, not called before output queue is empty} {unixOrPc as set result ok } } ok -test io-5.4 {Tcl_Close} { +test io-28.4 {Tcl_Close} { removeFile test1 set l "" lappend l [lsort [testchannel open]] @@ -643,7 +2163,7 @@ test io-5.4 {Tcl_Close} { $consoleFileNames] string compare $l $x } 0 -test io-5.5 {Tcl_Close vs standard handles} {unixOnly} { +test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly} { removeFile script set f [open script w] puts $f { @@ -657,13 +2177,10 @@ test io-5.5 {Tcl_Close vs standard handles} {unixOnly} { set l } {file1 file2} -# Test output on channels. The functions tested are Tcl_Write -# and Tcl_Flush. - -test io-6.1 {Tcl_Write, channel not writable} { +test io-29.1 {Tcl_WriteChars, channel not writable} { list [catch {puts stdin hello} msg] $msg } {1 {channel "stdin" wasn't opened for writing}} -test io-6.2 {Tcl_Write, empty string} { +test io-29.2 {Tcl_WriteChars, empty string} { removeFile test1 set f [open test1 w] fconfigure $f -eofchar {} @@ -671,7 +2188,7 @@ test io-6.2 {Tcl_Write, empty string} { close $f file size test1 } 0 -test io-6.3 {Tcl_Write, nonempty string} { +test io-29.3 {Tcl_WriteChars, nonempty string} { removeFile test1 set f [open test1 w] fconfigure $f -eofchar {} @@ -679,7 +2196,7 @@ test io-6.3 {Tcl_Write, nonempty string} { close $f file size test1 } 5 -test io-6.4 {Tcl_Write, buffering in full buffering mode} { +test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering full -eofchar {} @@ -693,7 +2210,7 @@ test io-6.4 {Tcl_Write, buffering in full buffering mode} { close $f set l } {6 0 0 6} -test io-6.5 {Tcl_Write, buffering in line buffering mode} { +test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering line -eofchar {} @@ -707,7 +2224,7 @@ test io-6.5 {Tcl_Write, buffering in line buffering mode} { close $f set l } {5 0 0 11} -test io-6.6 {Tcl_Write, buffering in no buffering mode} { +test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering none -eofchar {} @@ -721,7 +2238,8 @@ test io-6.6 {Tcl_Write, buffering in no buffering mode} { close $f set l } {0 5 0 11} -test io-6.7 {Tcl_Flush, full buffering} { + +test io-29.7 {Tcl_Flush, full buffering} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering full -eofchar {} @@ -738,7 +2256,7 @@ test io-6.7 {Tcl_Flush, full buffering} { close $f set l } {5 0 11 0 0 11} -test io-6.8 {Tcl_Flush, full buffering} { +test io-29.8 {Tcl_Flush, full buffering} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering line @@ -758,34 +2276,34 @@ test io-6.8 {Tcl_Flush, full buffering} { close $f set l } {5 0 0 5 0 11 0 11} -test io-6.9 {Tcl_Flush, channel not writable} { +test io-29.9 {Tcl_Flush, channel not writable} { list [catch {flush stdin} msg] $msg } {1 {channel "stdin" wasn't opened for writing}} -test io-6.10 {Tcl_Write, looping and buffering} { +test io-29.10 {Tcl_WriteChars, looping and buffering} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} set f2 [open longfile r] for {set x 0} {$x < 10} {incr x} { - puts $f1 [gets $f2] + puts $f1 [gets $f2] } close $f2 close $f1 file size test1 } 387 -test io-6.11 {Tcl_Write, no newline, implicit flush} { +test io-29.11 {Tcl_WriteChars, no newline, implicit flush} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -eofchar {} set f2 [open longfile r] for {set x 0} {$x < 10} {incr x} { - puts -nonewline $f1 [gets $f2] + puts -nonewline $f1 [gets $f2] } close $f1 close $f2 file size test1 } 377 -test io-6.12 {Tcl_Write on a pipe} {stdio} { +test io-29.12 {Tcl_WriteChars on a pipe} {stdio} { removeFile test1 removeFile pipe set f1 [open pipe w] @@ -800,17 +2318,17 @@ test io-6.12 {Tcl_Write on a pipe} {stdio} { set f2 [open longfile r] set y ok for {set x 0} {$x < 10} {incr x} { - set l1 [gets $f1] - set l2 [gets $f2] - if {"$l1" != "$l2"} { - set y broken - } + set l1 [gets $f1] + set l2 [gets $f2] + if {"$l1" != "$l2"} { + set y broken + } } close $f1 close $f2 set y } ok -test io-6.13 {Tcl_Write to a pipe, line buffered} {stdio} { +test io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio} { removeFile test1 removeFile pipe set f1 [open pipe w] @@ -827,19 +2345,19 @@ test io-6.13 {Tcl_Write to a pipe, line buffered} {stdio} { puts $f1 $line set backline [gets $f1] if {"$line" != "$backline"} { - set y broken + set y broken } set line [gets $f2] puts $f1 $line set backline [gets $f1] if {"$line" != "$backline"} { - set y broken + set y broken } close $f1 close $f2 set y } ok -test io-6.14 {Tcl_Write, buffering and implicit flush at close} { +test io-29.14 {Tcl_WriteChars, buffering and implicit flush at close} { removeFile test3 set f [open test3 w] puts -nonewline $f "Text1" @@ -851,7 +2369,7 @@ test io-6.14 {Tcl_Write, buffering and implicit flush at close} { close $f set x } {Text1 Text 2 Text 3} -test io-6.15 {Tcl_Flush, channel not open for writing} { +test io-29.15 {Tcl_Flush, channel not open for writing} { removeFile test1 set fd [open test1 w] close $fd @@ -861,14 +2379,14 @@ test io-6.15 {Tcl_Flush, channel not open for writing} { string compare $x \ [list 1 "channel \"$fd\" wasn't opened for writing"] } 0 -test io-6.16 {Tcl_Flush on pipe opened only for reading} {stdio} { +test io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio} { set fd [open "|[list $tcltest cat longfile]" r] set x [list [catch {flush $fd} msg] $msg] catch {close $fd} string compare $x \ [list 1 "channel \"$fd\" wasn't opened for writing"] } 0 -test io-6.17 {Tcl_Write buffers, then Tcl_Flush flushes} { +test io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf @@ -880,7 +2398,7 @@ test io-6.17 {Tcl_Write buffers, then Tcl_Flush flushes} { close $f1 set x } 18 -test io-6.18 {Tcl_Write and Tcl_Flush intermixed} { +test io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} { removeFile test1 set x "" set f1 [open test1 w] @@ -899,7 +2417,7 @@ test io-6.18 {Tcl_Write and Tcl_Flush intermixed} { close $f1 set x } {18 24 30} -test io-6.19 {Explicit and implicit flushes} { +test io-29.19 {Explicit and implicit flushes} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -917,7 +2435,7 @@ test io-6.19 {Explicit and implicit flushes} { lappend x [file size test1] set x } {18 24 30} -test io-6.20 {Implicit flush when buffer is full} { +test io-29.20 {Implicit flush when buffer is full} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -928,14 +2446,14 @@ test io-6.20 {Implicit flush when buffer is full} { set z "" lappend z [file size test1] for {set x 0} {$x < 100} {incr x} { - puts $f1 $line + puts $f1 $line } lappend z [file size test1] close $f1 lappend z [file size test1] set z } {4096 12288 12600} -test io-6.21 {Tcl_Flush to pipe} {stdio} { +test io-29.21 {Tcl_Flush to pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 {set x [read stdin 6]} @@ -949,7 +2467,7 @@ test io-6.21 {Tcl_Flush to pipe} {stdio} { catch {close $f1} set x } "read 6 characters" -test io-6.22 {Tcl_Flush called at other end of pipe} {stdio} { +test io-29.22 {Tcl_Flush called at other end of pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 { @@ -972,7 +2490,7 @@ test io-6.22 {Tcl_Flush called at other end of pipe} {stdio} { close $f1 set x } {hello hello bye} -test io-6.23 {Tcl_Flush and line buffering at end of pipe} {stdio} { +test io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 { @@ -992,7 +2510,7 @@ test io-6.23 {Tcl_Flush and line buffering at end of pipe} {stdio} { close $f1 set x } {hello hello bye} -test io-6.24 {Tcl_Write and Tcl_Flush move end of file} { +test io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} { set f [open test3 w] puts $f "Line 1" puts $f "Line 2" @@ -1006,9 +2524,8 @@ test io-6.24 {Tcl_Write and Tcl_Flush move end of file} { close $f2 close $f set x -} {{} {Line 1 -Line 2}} -test io-6.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio} { +} "{} {Line 1\nLine 2}" +test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio} { removeFile test3 set f [open "|[list $tcltest cat | $tcltest cat > test3]" w] puts $f "Line 1" @@ -1019,10 +2536,8 @@ test io-6.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio} { set x [read $f] close $f set x -} {Line 1 -Line 2 -} -test io-6.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {unixOrPc && unixExecs && tempNotPc} { +} "Line 1\nLine 2\n" +test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs} { set f [open "|[list cat -u]" r+] puts $f "Line1" flush $f @@ -1030,7 +2545,7 @@ test io-6.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {unixOrPc && unix close $f set x } {Line1} -test io-6.27 {Tcl_Flush on closed pipeline} {stdio && tempNotPc} { +test io-29.27 {Tcl_Flush on closed pipeline} {stdio} { removeFile pipe set f [open pipe w] puts $f {exit} @@ -1058,7 +2573,7 @@ test io-6.27 {Tcl_Flush on closed pipeline} {stdio && tempNotPc} { regsub {".*":} $x {"":} x string tolower $x } {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}} -test io-6.28 {Tcl_Write, lf mode} { +test io-29.28 {Tcl_WriteChars, lf mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -1068,7 +2583,7 @@ test io-6.28 {Tcl_Write, lf mode} { close $f set s } 21 -test io-6.29 {Tcl_Write, cr mode} { +test io-29.29 {Tcl_WriteChars, cr mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -1076,7 +2591,7 @@ test io-6.29 {Tcl_Write, cr mode} { close $f file size test1 } 21 -test io-6.30 {Tcl_Write, crlf mode} { +test io-29.30 {Tcl_WriteChars, crlf mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -1084,7 +2599,7 @@ test io-6.30 {Tcl_Write, crlf mode} { close $f file size test1 } 25 -test io-6.31 {Tcl_Write, background flush} {stdio} { +test io-29.31 {Tcl_WriteChars, background flush} {stdio} { removeFile pipe removeFile output set f [open pipe w] @@ -1100,7 +2615,7 @@ test io-6.31 {Tcl_Write, background flush} {stdio} { close $f set x 01234567890123456789012345678901 for {set i 0} {$i < 11} {incr i} { - set x "$x$x" + set x "$x$x" } set f [open output w] close $f @@ -1110,17 +2625,18 @@ test io-6.31 {Tcl_Write, background flush} {stdio} { close $f set counter 0 while {([file size output] < 65536) && ($counter < 1000)} { - incr counter - after 5 - update + incr counter + after 5 + update } if {$counter == 1000} { - set result probably_broken + set result "file size only [file size output]" } else { - set result ok + set result ok } } ok -test io-6.32 {Tcl_Write, background flush to slow reader} {stdio && asyncPipeClose} { +test io-29.32 {Tcl_WriteChars, background flush to slow reader} \ + {stdio asyncPipeClose} { removeFile pipe removeFile output set f [open pipe w] @@ -1137,7 +2653,7 @@ test io-6.32 {Tcl_Write, background flush to slow reader} {stdio && asyncPipeClo close $f set x 01234567890123456789012345678901 for {set i 0} {$i < 11} {incr i} { - set x "$x$x" + set x "$x$x" } set f [open output w] close $f @@ -1147,17 +2663,17 @@ test io-6.32 {Tcl_Write, background flush to slow reader} {stdio && asyncPipeClo close $f set counter 0 while {([file size output] < 65536) && ($counter < 1000)} { - incr counter - after 20 - update + incr counter + after 20 + update } if {$counter == 1000} { - set result probably_broken + set result "file size only [file size output]" } else { - set result ok + set result ok } } ok -test io-6.33 {Tcl_Flush, implicit flush on exit} {stdio} { +test io-29.33 {Tcl_Flush, implicit flush on exit} {stdio} { set f [open script w] puts $f { set f [open test1 w] @@ -1172,12 +2688,8 @@ test io-6.33 {Tcl_Flush, implicit flush on exit} {stdio} { set r [read $f] close $f set r -} {hello -bye -strange -} - -test io-6.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac} { +} "hello\nbye\nstrange\n" +test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac} { set c 0 set x running set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz @@ -1213,7 +2725,10 @@ test io-6.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac vwait x set c } 2000 -test io-6.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket} { +test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac} { + # On Mac, this test screws up sockets such that subsequent tests using port 2828 + # either cause errors or panic(). + catch {interp delete x} catch {interp delete y} interp create x @@ -1254,7 +2769,7 @@ test io-6.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket} { # Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read. -test io-7.1 {Tcl_Write lf, Tcl_Read lf} { +test io-30.1 {Tcl_Write lf, Tcl_Read lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1266,7 +2781,7 @@ test io-7.1 {Tcl_Write lf, Tcl_Read lf} { close $f set x } "hello\nthere\nand\nhere\n" -test io-7.2 {Tcl_Write lf, Tcl_Read cr} { +test io-30.2 {Tcl_Write lf, Tcl_Read cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1278,7 +2793,7 @@ test io-7.2 {Tcl_Write lf, Tcl_Read cr} { close $f set x } "hello\nthere\nand\nhere\n" -test io-7.3 {Tcl_Write lf, Tcl_Read crlf} { +test io-30.3 {Tcl_Write lf, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1290,7 +2805,7 @@ test io-7.3 {Tcl_Write lf, Tcl_Read crlf} { close $f set x } "hello\nthere\nand\nhere\n" -test io-7.4 {Tcl_Write cr, Tcl_Read cr} { +test io-30.4 {Tcl_Write cr, Tcl_Read cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1302,7 +2817,7 @@ test io-7.4 {Tcl_Write cr, Tcl_Read cr} { close $f set x } "hello\nthere\nand\nhere\n" -test io-7.5 {Tcl_Write cr, Tcl_Read lf} { +test io-30.5 {Tcl_Write cr, Tcl_Read lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1314,7 +2829,7 @@ test io-7.5 {Tcl_Write cr, Tcl_Read lf} { close $f set x } "hello\rthere\rand\rhere\r" -test io-7.6 {Tcl_Write cr, Tcl_Read crlf} { +test io-30.6 {Tcl_Write cr, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1326,7 +2841,7 @@ test io-7.6 {Tcl_Write cr, Tcl_Read crlf} { close $f set x } "hello\rthere\rand\rhere\r" -test io-7.7 {Tcl_Write crlf, Tcl_Read crlf} { +test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1338,7 +2853,7 @@ test io-7.7 {Tcl_Write crlf, Tcl_Read crlf} { close $f set x } "hello\nthere\nand\nhere\n" -test io-7.8 {Tcl_Write crlf, Tcl_Read lf} { +test io-30.8 {Tcl_Write crlf, Tcl_Read lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1350,7 +2865,7 @@ test io-7.8 {Tcl_Write crlf, Tcl_Read lf} { close $f set x } "hello\r\nthere\r\nand\r\nhere\r\n" -test io-7.9 {Tcl_Write crlf, Tcl_Read cr} { +test io-30.9 {Tcl_Write crlf, Tcl_Read cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1362,7 +2877,7 @@ test io-7.9 {Tcl_Write crlf, Tcl_Read cr} { close $f set x } "hello\n\nthere\n\nand\n\nhere\n\n" -test io-7.10 {Tcl_Write lf, Tcl_Read auto} { +test io-30.10 {Tcl_Write lf, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1378,7 +2893,7 @@ there and here } auto} -test io-7.11 {Tcl_Write cr, Tcl_Read auto} { +test io-30.11 {Tcl_Write cr, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1394,7 +2909,7 @@ there and here } auto} -test io-7.12 {Tcl_Write crlf, Tcl_Read auto} { +test io-30.12 {Tcl_Write crlf, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1411,7 +2926,7 @@ and here } auto} -test io-7.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { +test io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1428,7 +2943,7 @@ test io-7.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { string length $c } [expr 700*15+1] -test io-7.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { +test io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1445,7 +2960,7 @@ test io-7.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { string length $c } [expr 700*15+1] -test io-7.15 {Tcl_Write mixed, Tcl_Read auto} { +test io-30.15 {Tcl_Write mixed, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1461,7 +2976,7 @@ there and here } -test io-7.16 {Tcl_Write ^Z at end, Tcl_Read auto} { +test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1477,7 +2992,7 @@ there and here } -test io-7.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} { +test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} { removeFile test1 set f [open test1 w] fconfigure $f -eofchar \x1a -translation lf @@ -1493,7 +3008,7 @@ there and here } -test io-7.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { +test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1513,7 +3028,7 @@ test io-7.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { close $f set l } {abc def 0 {} 1 {} 1} -test io-7.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { +test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1533,7 +3048,7 @@ test io-7.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { close $f set l } {abc def 0 {} 1 {} 1} -test io-7.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { +test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -1555,7 +3070,7 @@ test io-7.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { close $f set l } "abc def 0 \x1aghi 0 qrs 0 {} 1" -test io-7.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { +test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -1566,14 +3081,14 @@ test io-7.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { fconfigure $f -translation cr -eofchar {} set l "" set x [gets $f] - lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs"] + lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] lappend l [eof $f] lappend l [gets $f] lappend l [eof $f] close $f set l } {0 1 {} 1} -test io-7.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { +test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -1584,14 +3099,14 @@ test io-7.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { fconfigure $f -translation crlf -eofchar {} set l "" set x [gets $f] - lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs"] + lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] lappend l [eof $f] lappend l [gets $f] lappend l [eof $f] close $f set l } {0 1 {} 1} -test io-7.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { +test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1605,7 +3120,7 @@ test io-7.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { close $f list $c $e } {8 1} -test io-7.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { +test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1619,7 +3134,7 @@ test io-7.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { close $f list $c $e } {8 1} -test io-7.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { +test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1633,7 +3148,7 @@ test io-7.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { close $f list $c $e } {8 1} -test io-7.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { +test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1647,7 +3162,7 @@ test io-7.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { close $f list $c $e } {8 1} -test io-7.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { +test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1661,7 +3176,7 @@ test io-7.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { close $f list $c $e } {8 1} -test io-7.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { +test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1678,7 +3193,7 @@ test io-7.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { # Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets. -test io-8.1 {Tcl_Write lf, Tcl_Gets auto} { +test io-31.1 {Tcl_Write lf, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1695,7 +3210,7 @@ test io-8.1 {Tcl_Write lf, Tcl_Gets auto} { close $f set l } {hello 6 auto there 12 auto} -test io-8.2 {Tcl_Write cr, Tcl_Gets auto} { +test io-31.2 {Tcl_Write cr, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1712,7 +3227,7 @@ test io-8.2 {Tcl_Write cr, Tcl_Gets auto} { close $f set l } {hello 6 auto there 12 auto} -test io-8.3 {Tcl_Write crlf, Tcl_Gets auto} { +test io-31.3 {Tcl_Write crlf, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1729,7 +3244,7 @@ test io-8.3 {Tcl_Write crlf, Tcl_Gets auto} { close $f set l } {hello 7 auto there 14 auto} -test io-8.4 {Tcl_Write lf, Tcl_Gets lf} { +test io-31.4 {Tcl_Write lf, Tcl_Gets lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1747,7 +3262,7 @@ test io-8.4 {Tcl_Write lf, Tcl_Gets lf} { close $f set l } {hello 6 lf there 12 lf} -test io-8.5 {Tcl_Write lf, Tcl_Gets cr} { +test io-31.5 {Tcl_Write lf, Tcl_Gets cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1766,8 +3281,8 @@ test io-8.5 {Tcl_Write lf, Tcl_Gets cr} { lappend l [eof $f] close $f set l -} {20 21 cr 1 {} 21 cr 1} -test io-8.6 {Tcl_Write lf, Tcl_Gets crlf} { +} {21 21 cr 1 {} 21 cr 1} +test io-31.6 {Tcl_Write lf, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1786,8 +3301,8 @@ test io-8.6 {Tcl_Write lf, Tcl_Gets crlf} { lappend l [eof $f] close $f set l -} {20 21 crlf 1 {} 21 crlf 1} -test io-8.7 {Tcl_Write cr, Tcl_Gets cr} { +} {21 21 crlf 1 {} 21 crlf 1} +test io-31.7 {Tcl_Write cr, Tcl_Gets cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1807,7 +3322,7 @@ test io-8.7 {Tcl_Write cr, Tcl_Gets cr} { close $f set l } {hello 6 cr 0 there 12 cr 0} -test io-8.8 {Tcl_Write cr, Tcl_Gets lf} { +test io-31.8 {Tcl_Write cr, Tcl_Gets lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1827,7 +3342,7 @@ test io-8.8 {Tcl_Write cr, Tcl_Gets lf} { close $f set l } {21 21 lf 1 {} 21 lf 1} -test io-8.9 {Tcl_Write cr, Tcl_Gets crlf} { +test io-31.9 {Tcl_Write cr, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -1847,7 +3362,7 @@ test io-8.9 {Tcl_Write cr, Tcl_Gets crlf} { close $f set l } {21 21 crlf 1 {} 21 crlf 1} -test io-8.10 {Tcl_Write crlf, Tcl_Gets crlf} { +test io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1867,7 +3382,7 @@ test io-8.10 {Tcl_Write crlf, Tcl_Gets crlf} { close $f set l } {hello 7 crlf 0 there 14 crlf 0} -test io-8.11 {Tcl_Write crlf, Tcl_Gets cr} { +test io-31.11 {Tcl_Write crlf, Tcl_Gets cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1887,7 +3402,7 @@ test io-8.11 {Tcl_Write crlf, Tcl_Gets cr} { close $f set l } {hello 6 cr 0 6 13 cr 0} -test io-8.12 {Tcl_Write crlf, Tcl_Gets lf} { +test io-31.12 {Tcl_Write crlf, Tcl_Gets lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -1907,7 +3422,7 @@ test io-8.12 {Tcl_Write crlf, Tcl_Gets lf} { close $f set l } {6 7 lf 0 6 14 lf 0} -test io-8.13 {binary mode is synonym of lf mode} { +test io-31.13 {binary mode is synonym of lf mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation binary @@ -1919,7 +3434,7 @@ test io-8.13 {binary mode is synonym of lf mode} { # Test io-9.14 has been removed because "auto" output translation mode is # not supoprted. # -test io-8.14 {Tcl_Write mixed, Tcl_Gets auto} { +test io-31.14 {Tcl_Write mixed, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1938,7 +3453,7 @@ test io-8.14 {Tcl_Write mixed, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-8.15 {Tcl_Write mixed, Tcl_Gets auto} { +test io-31.15 {Tcl_Write mixed, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1957,7 +3472,7 @@ test io-8.15 {Tcl_Write mixed, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-8.16 {Tcl_Write mixed, Tcl_Gets auto} { +test io-31.16 {Tcl_Write mixed, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1975,7 +3490,7 @@ test io-8.16 {Tcl_Write mixed, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-8.17 {Tcl_Write mixed, Tcl_Gets auto} { +test io-31.17 {Tcl_Write mixed, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -1994,7 +3509,7 @@ test io-8.17 {Tcl_Write mixed, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-8.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { +test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -2014,7 +3529,7 @@ test io-8.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-8.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { +test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -eofchar \x1a -translation lf @@ -2033,7 +3548,7 @@ test io-8.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { close $f set l } {hello there and here 0 {} 1} -test io-8.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { +test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -2052,7 +3567,7 @@ test io-8.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { close $f set l } {abc def 0 {} 1} -test io-8.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { +test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -2070,7 +3585,7 @@ test io-8.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { close $f set l } {abc def 0 {} 1} -test io-8.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { +test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -2092,7 +3607,7 @@ test io-8.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { close $f set l } "abc def 0 \x1aqrs 0 tuv 0 {} 1" -test io-8.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { +test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -2114,7 +3629,7 @@ test io-8.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { close $f set l } "abc def 0 \x1aqrs 0 tuv 0 {} 1" -test io-8.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { +test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -2136,7 +3651,7 @@ test io-8.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { close $f set l } "abc def 0 \x1aqrs 0 tuv 0 {} 1" -test io-8.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { +test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -2154,7 +3669,7 @@ test io-8.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { close $f set l } {abc def 0 {} 1} -test io-8.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { +test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -2172,7 +3687,7 @@ test io-8.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { close $f set l } {abc def 0 {} 1} -test io-8.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { +test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -2190,7 +3705,7 @@ test io-8.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { close $f set l } {abc def 0 {} 1} -test io-8.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { +test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -2208,7 +3723,7 @@ test io-8.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { close $f set l } {abc def 0 {} 1} -test io-8.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { +test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -2226,7 +3741,7 @@ test io-8.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { close $f set l } {abc def 0 {} 1} -test io-8.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { +test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -2244,7 +3759,7 @@ test io-8.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { close $f set l } {abc def 0 {} 1} -test io-8.31 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { +test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -2255,7 +3770,7 @@ test io-8.31 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { } close $f set f [open test1 r] - fconfigure $f -translation auto + fconfigure $f -translation crlf set c "" while {[gets $f line] >= 0} { append c $line\n @@ -2263,13 +3778,13 @@ test io-8.31 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { close $f string length $c } [expr 700*15+1] -test io-8.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { +test io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf puts -nonewline $f x ;# shift crlf across block boundary - for {set i 0} {$i < 256} {incr i} { + for {set i 0} {$i < 700} {incr i} { puts $f $line } close $f @@ -2281,24 +3796,24 @@ test io-8.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { } close $f string length $c -} [expr 256*15+1] +} [expr 700*15+1] # Test Tcl_Read and buffering. -test io-9.1 {Tcl_Read, channel not readable} { +test io-32.1 {Tcl_Read, channel not readable} { list [catch {read stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} -test io-9.2 {Tcl_Read, zero byte count} { +test io-32.2 {Tcl_Read, zero byte count} { read stdin 0 } "" -test io-9.3 {Tcl_Read, negative byte count} { +test io-32.3 {Tcl_Read, negative byte count} { set f [open longfile r] set l [list [catch {read $f -1} msg] $msg] close $f set l } {1 {bad argument "-1": should be "nonewline"}} -test io-9.4 {Tcl_Read, positive byte count} { +test io-32.4 {Tcl_Read, positive byte count} { set f [open longfile r] set x [read $f 1024] set s [string length $x] @@ -2306,7 +3821,7 @@ test io-9.4 {Tcl_Read, positive byte count} { close $f set s } 1024 -test io-9.5 {Tcl_Read, multiple buffers} { +test io-32.5 {Tcl_Read, multiple buffers} { set f [open longfile r] fconfigure $f -buffersize 100 set x [read $f 1024] @@ -2315,7 +3830,7 @@ test io-9.5 {Tcl_Read, multiple buffers} { close $f set s } 1024 -test io-9.6 {Tcl_Read, very large read} { +test io-32.6 {Tcl_Read, very large read} { set f1 [open longfile r] set z [read $f1 1000000] close $f1 @@ -2323,11 +3838,11 @@ test io-9.6 {Tcl_Read, very large read} { set x ok set z [file size longfile] if {$z != $l} { - set x broken + set x broken } set x } ok -test io-9.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { +test io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set f1 [open longfile r] fconfigure $f1 -blocking off set z [read $f1 20] @@ -2335,11 +3850,11 @@ test io-9.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set l [string length $z] set x ok if {$l != 20} { - set x broken + set x broken } set x } ok -test io-9.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { +test io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set f1 [open longfile r] fconfigure $f1 -blocking off set z [read $f1 1000000] @@ -2348,11 +3863,11 @@ test io-9.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set l [string length $z]] set z [file size longfile]] if {$z != $l} { - set x broken + set x broken } set x } ok -test io-9.9 {Tcl_Read, read to end of file} { +test io-32.9 {Tcl_Read, read to end of file} { set f1 [open longfile r] set z [read $f1] close $f1 @@ -2360,11 +3875,11 @@ test io-9.9 {Tcl_Read, read to end of file} { set x ok set z [file size longfile] if {$z != $l} { - set x broken + set x broken } set x } ok -test io-9.10 {Tcl_Read from a pipe} {stdio} { +test io-32.10 {Tcl_Read from a pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 {puts [gets stdin]} @@ -2376,7 +3891,7 @@ test io-9.10 {Tcl_Read from a pipe} {stdio} { close $f1 set x } "hello\n" -test io-9.11 {Tcl_Read from a pipe} {stdio} { +test io-32.11 {Tcl_Read from a pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 {puts [gets stdin]} @@ -2395,7 +3910,7 @@ test io-9.11 {Tcl_Read from a pipe} {stdio} { } {{hello } {hello }} -test io-9.12 {Tcl_Read, -nonewline} { +test io-32.12 {Tcl_Read, -nonewline} { removeFile test1 set f1 [open test1 w] puts $f1 hello @@ -2407,7 +3922,7 @@ test io-9.12 {Tcl_Read, -nonewline} { set c } {hello bye} -test io-9.13 {Tcl_Read, -nonewline} { +test io-32.13 {Tcl_Read, -nonewline} { removeFile test1 set f1 [open test1 w] puts $f1 hello @@ -2419,7 +3934,7 @@ test io-9.13 {Tcl_Read, -nonewline} { list [string length $c] $c } {9 {hello bye}} -test io-9.14 {Tcl_Read, reading in small chunks} { +test io-32.14 {Tcl_Read, reading in small chunks} { removeFile test1 set f [open test1 w] puts $f "Two lines: this one" @@ -2432,7 +3947,7 @@ test io-9.14 {Tcl_Read, reading in small chunks} { } {T wo { lines: this one and this one }} -test io-9.15 {Tcl_Read, asking for more input than available} { +test io-32.15 {Tcl_Read, asking for more input than available} { removeFile test1 set f [open test1 w] puts $f "Two lines: this one" @@ -2445,7 +3960,7 @@ test io-9.15 {Tcl_Read, asking for more input than available} { } {Two lines: this one and this one } -test io-9.16 {Tcl_Read, read to end of file with -nonewline} { +test io-32.16 {Tcl_Read, read to end of file with -nonewline} { removeFile test1 set f [open test1 w] puts $f "Two lines: this one" @@ -2460,7 +3975,7 @@ and this one} # Test Tcl_Gets. -test io-10.1 {Tcl_Gets, reading what was written} { +test io-33.1 {Tcl_Gets, reading what was written} { removeFile test1 set f1 [open test1 w] set y "first line" @@ -2470,23 +3985,23 @@ test io-10.1 {Tcl_Gets, reading what was written} { set x [gets $f1] set z ok if {"$x" != "$y"} { - set z broken + set z broken } close $f1 set z } ok -test io-10.2 {Tcl_Gets into variable} { +test io-33.2 {Tcl_Gets into variable} { set f1 [open longfile r] set c [gets $f1 x] set l [string length x] set z ok if {$l != $l} { - set z broken + set z broken } close $f1 set z } ok -test io-10.3 {Tcl_Gets from pipe} {stdio} { +test io-33.3 {Tcl_Gets from pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 {puts [gets stdin]} @@ -2498,11 +4013,11 @@ test io-10.3 {Tcl_Gets from pipe} {stdio} { close $f1 set z ok if {"$x" != "hello"} { - set z broken + set z broken } set z } ok -test io-10.4 {Tcl_Gets with long line} { +test io-33.4 {Tcl_Gets with long line} { removeFile test3 set f [open test3 w] puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" @@ -2516,13 +4031,13 @@ test io-10.4 {Tcl_Gets with long line} { close $f set x } {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} -test io-10.5 {Tcl_Gets with long line} { +test io-33.5 {Tcl_Gets with long line} { set f [open test3] set x [gets $f y] close $f list $x $y } {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} -test io-10.6 {Tcl_Gets and end of file} { +test io-33.6 {Tcl_Gets and end of file} { removeFile test3 set f [open test3 w] puts -nonewline $f "Test1\nTest2" @@ -2538,7 +4053,7 @@ test io-10.6 {Tcl_Gets and end of file} { close $f set x } {5 Test1 5 Test2 -1 {}} -test io-10.7 {Tcl_Gets and bad variable} { +test io-33.7 {Tcl_Gets and bad variable} { set f [open test3 w] puts $f "Line 1" puts $f "Line 2" @@ -2550,7 +4065,7 @@ test io-10.7 {Tcl_Gets and bad variable} { close $f set result } {1 {can't set "x(0)": variable isn't array}} -test io-10.8 {Tcl_Gets, exercising double buffering} { +test io-33.8 {Tcl_Gets, exercising double buffering} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} set x "" @@ -2563,7 +4078,7 @@ test io-10.8 {Tcl_Gets, exercising double buffering} { close $f set y } 100 -test io-10.9 {Tcl_Gets, exercising double buffering} { +test io-33.9 {Tcl_Gets, exercising double buffering} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} set x "" @@ -2576,7 +4091,7 @@ test io-10.9 {Tcl_Gets, exercising double buffering} { close $f set y } 200 -test io-10.10 {Tcl_Gets, exercising double buffering} { +test io-33.10 {Tcl_Gets, exercising double buffering} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} set x "" @@ -2592,14 +4107,14 @@ test io-10.10 {Tcl_Gets, exercising double buffering} { # Test Tcl_Seek and Tcl_Tell. -test io-11.1 {Tcl_Seek to current position at start of file} { +test io-34.1 {Tcl_Seek to current position at start of file} { set f1 [open longfile r] seek $f1 0 current set c [tell $f1] close $f1 set c } 0 -test io-11.2 {Tcl_Seek to offset from start} { +test io-34.2 {Tcl_Seek to offset from start} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2612,7 +4127,7 @@ test io-11.2 {Tcl_Seek to offset from start} { close $f1 set c } 10 -test io-11.3 {Tcl_Seek to end of file} { +test io-34.3 {Tcl_Seek to end of file} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2625,7 +4140,7 @@ test io-11.3 {Tcl_Seek to end of file} { close $f1 set c } 54 -test io-11.4 {Tcl_Seek to offset from end of file} { +test io-34.4 {Tcl_Seek to offset from end of file} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2638,7 +4153,7 @@ test io-11.4 {Tcl_Seek to offset from end of file} { close $f1 set c } 44 -test io-11.5 {Tcl_Seek to offset from current position} { +test io-34.5 {Tcl_Seek to offset from current position} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2652,7 +4167,7 @@ test io-11.5 {Tcl_Seek to offset from current position} { close $f1 set c } 20 -test io-11.6 {Tcl_Seek to offset from end of file} { +test io-34.6 {Tcl_Seek to offset from end of file} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2667,7 +4182,7 @@ test io-11.6 {Tcl_Seek to offset from end of file} { list $c $r } {44 {rstuvwxyz }} -test io-11.7 {Tcl_Seek to offset from end of file, then to current position} { +test io-34.7 {Tcl_Seek to offset from end of file, then to current position} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2683,14 +4198,14 @@ test io-11.7 {Tcl_Seek to offset from end of file, then to current position} { close $f1 list $c1 $r1 $c2 } {44 rstuv 49} -test io-11.8 {Tcl_Seek on pipes: not supported} {stdio} { +test io-34.8 {Tcl_Seek on pipes: not supported} {stdio} { set f1 [open "|[list $tcltest]" r+] set x [list [catch {seek $f1 0 current} msg] $msg] close $f1 regsub {".*":} $x {"":} x string tolower $x } {1 {error during seek on "": invalid argument}} -test io-11.9 {Tcl_Seek, testing buffered input flushing} { +test io-34.9 {Tcl_Seek, testing buffered input flushing} { removeFile test3 set f [open test3 w] fconfigure $f -eofchar {} @@ -2713,7 +4228,7 @@ test io-11.9 {Tcl_Seek, testing buffered input flushing} { close $f set x } {a d a l Y {} b} -test io-11.10 {Tcl_Seek testing flushing of buffered input} { +test io-34.10 {Tcl_Seek testing flushing of buffered input} { set f [open test3 w] fconfigure $f -translation lf puts $f xyz\n123 @@ -2727,7 +4242,7 @@ test io-11.10 {Tcl_Seek testing flushing of buffered input} { list $x [viewFile test3] } "xyz {xyz 456}" -test io-11.11 {Tcl_Seek testing flushing of buffered output} { +test io-34.11 {Tcl_Seek testing flushing of buffered output} { set f [open test3 w] puts $f xyz\n123 close $f @@ -2738,7 +4253,7 @@ test io-11.11 {Tcl_Seek testing flushing of buffered output} { close $f list $x [viewFile test3] } "zzy xyzzy" -test io-11.12 {Tcl_Seek testing combination of write, seek back and read} { +test io-34.12 {Tcl_Seek testing combination of write, seek back and read} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} puts $f xyz\n123 @@ -2755,14 +4270,14 @@ test io-11.12 {Tcl_Seek testing combination of write, seek back and read} { } {14 {xyz 123 xyzzy} zzy} -test io-11.13 {Tcl_Tell at start of file} { +test io-34.13 {Tcl_Tell at start of file} { removeFile test1 set f1 [open test1 w] set p [tell $f1] close $f1 set p } 0 -test io-11.14 {Tcl_Tell after seek to end of file} { +test io-34.14 {Tcl_Tell after seek to end of file} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2775,7 +4290,7 @@ test io-11.14 {Tcl_Tell after seek to end of file} { close $f1 set c1 } 54 -test io-11.15 {Tcl_Tell combined with seeking} { +test io-34.15 {Tcl_Tell combined with seeking} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -eofchar {} @@ -2790,13 +4305,13 @@ test io-11.15 {Tcl_Tell combined with seeking} { close $f1 list $c1 $c2 } {10 20} -test io-11.16 {Tcl_tell on pipe: always -1} {stdio} { +test io-34.16 {Tcl_tell on pipe: always -1} {stdio} { set f1 [open "|[list $tcltest]" r+] set c [tell $f1] close $f1 set c } -1 -test io-11.17 {Tcl_Tell on pipe: always -1} {stdio} { +test io-34.17 {Tcl_Tell on pipe: always -1} {stdio} { set f1 [open "|[list $tcltest]" r+] puts $f1 {puts hello} flush $f1 @@ -2805,7 +4320,7 @@ test io-11.17 {Tcl_Tell on pipe: always -1} {stdio} { close $f1 set c } -1 -test io-11.18 {Tcl_Tell combined with seeking and reading} { +test io-34.18 {Tcl_Tell combined with seeking and reading} { removeFile test2 set f [open test2 w] fconfigure $f -translation lf -eofchar {} @@ -2825,7 +4340,7 @@ test io-11.18 {Tcl_Tell combined with seeking and reading} { close $f set x } {0 3 2 12 30} -test io-11.19 {Tcl_Tell combined with opening in append mode} { +test io-34.19 {Tcl_Tell combined with opening in append mode} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} puts $f "abcdefghijklmnopqrstuvwxyz" @@ -2836,7 +4351,7 @@ test io-11.19 {Tcl_Tell combined with opening in append mode} { close $f set c } 54 -test io-11.20 {Tcl_Tell combined with writing} { +test io-34.20 {Tcl_Tell combined with writing} { set f [open test3 w] set l "" seek $f 29 start @@ -2854,7 +4369,7 @@ test io-11.20 {Tcl_Tell combined with writing} { # Test Tcl_Eof -test io-12.1 {Tcl_Eof} { +test io-35.1 {Tcl_Eof} { removeFile test1 set f [open test1 w] puts $f hello @@ -2873,7 +4388,7 @@ test io-12.1 {Tcl_Eof} { close $f set x } {0 0 0 0 1 1} -test io-12.2 {Tcl_Eof with pipe} {stdio} { +test io-35.2 {Tcl_Eof with pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 {gets stdin} @@ -2891,7 +4406,7 @@ test io-12.2 {Tcl_Eof with pipe} {stdio} { close $f1 set x } {0 0 0 1} -test io-12.3 {Tcl_Eof with pipe} {stdio} { +test io-35.3 {Tcl_Eof with pipe} {stdio} { removeFile pipe set f1 [open pipe w] puts $f1 {gets stdin} @@ -2913,7 +4428,7 @@ test io-12.3 {Tcl_Eof with pipe} {stdio} { close $f1 set x } {0 0 0 1 1 1} -test io-12.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { +test io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { removeFile test1 set f [open test1 w] close $f @@ -2925,7 +4440,7 @@ test io-12.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { close $f set l } {{} 1} -test io-12.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio} { +test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio} { removeFile pipe set f [open pipe w] puts $f { @@ -2939,7 +4454,7 @@ test io-12.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio} { close $f set l } {{} 1} -test io-12.6 {Tcl_Eof, eof char, lf write, auto read} { +test io-35.6 {Tcl_Eof, eof char, lf write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar \x1a @@ -2953,7 +4468,7 @@ test io-12.6 {Tcl_Eof, eof char, lf write, auto read} { close $f list $s $l $e } {9 8 1} -test io-12.7 {Tcl_Eof, eof char, lf write, lf read} { +test io-35.7 {Tcl_Eof, eof char, lf write, lf read} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar \x1a @@ -2967,7 +4482,7 @@ test io-12.7 {Tcl_Eof, eof char, lf write, lf read} { close $f list $s $l $e } {9 8 1} -test io-12.8 {Tcl_Eof, eof char, cr write, auto read} { +test io-35.8 {Tcl_Eof, eof char, cr write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar \x1a @@ -2981,7 +4496,7 @@ test io-12.8 {Tcl_Eof, eof char, cr write, auto read} { close $f list $s $l $e } {9 8 1} -test io-12.9 {Tcl_Eof, eof char, cr write, cr read} { +test io-35.9 {Tcl_Eof, eof char, cr write, cr read} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar \x1a @@ -2995,7 +4510,7 @@ test io-12.9 {Tcl_Eof, eof char, cr write, cr read} { close $f list $s $l $e } {9 8 1} -test io-12.10 {Tcl_Eof, eof char, crlf write, auto read} { +test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar \x1a @@ -3009,7 +4524,7 @@ test io-12.10 {Tcl_Eof, eof char, crlf write, auto read} { close $f list $s $l $e } {11 8 1} -test io-12.11 {Tcl_Eof, eof char, crlf write, crlf read} { +test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar \x1a @@ -3023,7 +4538,7 @@ test io-12.11 {Tcl_Eof, eof char, crlf write, crlf read} { close $f list $s $l $e } {11 8 1} -test io-12.12 {Tcl_Eof, eof char in middle, lf write, auto read} { +test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -3038,7 +4553,7 @@ test io-12.12 {Tcl_Eof, eof char in middle, lf write, auto read} { close $f list $c $l $e } {17 8 1} -test io-12.13 {Tcl_Eof, eof char in middle, lf write, lf read} { +test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -eofchar {} @@ -3053,7 +4568,7 @@ test io-12.13 {Tcl_Eof, eof char in middle, lf write, lf read} { close $f list $c $l $e } {17 8 1} -test io-12.14 {Tcl_Eof, eof char in middle, cr write, auto read} { +test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -3068,7 +4583,7 @@ test io-12.14 {Tcl_Eof, eof char in middle, cr write, auto read} { close $f list $c $l $e } {17 8 1} -test io-12.15 {Tcl_Eof, eof char in middle, cr write, cr read} { +test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr -eofchar {} @@ -3083,7 +4598,7 @@ test io-12.15 {Tcl_Eof, eof char in middle, cr write, cr read} { close $f list $c $l $e } {17 8 1} -test io-12.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { +test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -3098,7 +4613,7 @@ test io-12.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { close $f list $c $l $e } {21 8 1} -test io-12.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { +test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf -eofchar {} @@ -3116,7 +4631,7 @@ test io-12.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { # Test Tcl_InputBlocked -test io-13.1 {Tcl_InputBlocked on nonblocking pipe} {unixOrPc tempNotPc} { +test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio} { set f1 [open "|[list $tcltest]" r+] puts $f1 {puts hello_from_pipe} flush $f1 @@ -3135,7 +4650,7 @@ test io-13.1 {Tcl_InputBlocked on nonblocking pipe} {unixOrPc tempNotPc} { close $f1 set x } {{} 1 hello 0 {} 1} -test io-13.2 {Tcl_InputBlocked on blocking pipe} {unixOrPc tempNotPc} { +test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio} { set f1 [open "|[list $tcltest]" r+] fconfigure $f1 -buffering line puts $f1 {puts hello_from_pipe} @@ -3149,7 +4664,7 @@ test io-13.2 {Tcl_InputBlocked on blocking pipe} {unixOrPc tempNotPc} { close $f1 set x } {hello_from_pipe 0 {} 0 1} -test io-13.3 {Tcl_InputBlocked vs files, short read} { +test io-36.3 {Tcl_InputBlocked vs files, short read} { removeFile test1 set f [open test1 w] puts $f abcdefghijklmnop @@ -3165,7 +4680,7 @@ test io-13.3 {Tcl_InputBlocked vs files, short read} { close $f set l } {0 abc 0 defghijklmnop 0 1} -test io-13.4 {Tcl_InputBlocked vs files, event driven read} { +test io-36.4 {Tcl_InputBlocked vs files, event driven read} { proc in {f} { global l x lappend l [read $f 3] @@ -3182,7 +4697,7 @@ test io-13.4 {Tcl_InputBlocked vs files, event driven read} { set l } {abc def ghi jkl mno {p } eof} -test io-13.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} { +test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} { removeFile test1 set f [open test1 w] puts $f abcdefghijklmnop @@ -3199,7 +4714,7 @@ test io-13.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles close $f set l } {0 abc 0 defghijklmnop 0 1} -test io-13.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} { +test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} { proc in {f} { global l x lappend l [read $f 3] @@ -3220,7 +4735,7 @@ test io-13.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} { # Test Tcl_InputBuffered -test io-14.1 {Tcl_InputBuffered} { +test io-37.1 {Tcl_InputBuffered} { set f [open longfile r] fconfigure $f -buffersize 4096 read $f 3 @@ -3230,7 +4745,7 @@ test io-14.1 {Tcl_InputBuffered} { close $f set l } {4093 3} -test io-14.2 {Tcl_InputBuffered, test input flushing on seek} { +test io-37.2 {Tcl_InputBuffered, test input flushing on seek} { set f [open longfile r] fconfigure $f -buffersize 4096 read $f 3 @@ -3246,13 +4761,13 @@ test io-14.2 {Tcl_InputBuffered, test input flushing on seek} { # Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize -test io-15.1 {Tcl_GetChannelBufferSize, default buffer size} { +test io-38.1 {Tcl_GetChannelBufferSize, default buffer size} { set f [open longfile r] set s [fconfigure $f -buffersize] close $f set s } 4096 -test io-15.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { +test io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { set f [open longfile r] set l "" lappend l [fconfigure $f -buffersize] @@ -3274,7 +4789,7 @@ test io-15.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { # Test Tcl_SetChannelOption, Tcl_GetChannelOption -test io-16.1 {Tcl_GetChannelOption} { +test io-39.1 {Tcl_GetChannelOption} { removeFile test1 set f1 [open test1 w] set x [fconfigure $f1 -blocking] @@ -3284,14 +4799,14 @@ test io-16.1 {Tcl_GetChannelOption} { # # Test 17.2 was removed. # -test io-16.2 {Tcl_GetChannelOption} { +test io-39.2 {Tcl_GetChannelOption} { removeFile test1 set f1 [open test1 w] set x [fconfigure $f1 -buffering] close $f1 set x } full -test io-16.3 {Tcl_GetChannelOption} { +test io-39.3 {Tcl_GetChannelOption} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -buffering line @@ -3299,7 +4814,7 @@ test io-16.3 {Tcl_GetChannelOption} { close $f1 set x } line -test io-16.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} { +test io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} { removeFile test1 set f1 [open test1 w] set l "" @@ -3315,7 +4830,7 @@ test io-16.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} { close $f1 set l } {full line none line full} -test io-16.5 {Tcl_GetChannelOption, invariance} { +test io-39.5 {Tcl_GetChannelOption, invariance} { removeFile test1 set f1 [open test1 w] set l "" @@ -3325,7 +4840,7 @@ test io-16.5 {Tcl_GetChannelOption, invariance} { close $f1 set l } {full {1 {bad value for -buffering: must be one of full, line, or none}} full} -test io-16.6 {Tcl_SetChannelOption, multiple options} { +test io-39.6 {Tcl_SetChannelOption, multiple options} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -buffering line @@ -3335,7 +4850,7 @@ test io-16.6 {Tcl_SetChannelOption, multiple options} { close $f1 set x } 10 -test io-16.7 {Tcl_SetChannelOption, buffering, translation} { +test io-39.7 {Tcl_SetChannelOption, buffering, translation} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf @@ -3349,7 +4864,7 @@ test io-16.7 {Tcl_SetChannelOption, buffering, translation} { close $f1 set x } {0 21} -test io-16.8 {Tcl_SetChannelOption, different buffering options} { +test io-39.8 {Tcl_SetChannelOption, different buffering options} { removeFile test1 set f1 [open test1 w] set l "" @@ -3369,7 +4884,7 @@ test io-16.8 {Tcl_SetChannelOption, different buffering options} { lappend l [file size test1] set l } {5 10 10 10 20 20} -test io-16.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { +test io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { removeFile test1 set f1 [open test1 w] close $f1 @@ -3385,13 +4900,15 @@ test io-16.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { close $f1 set x } {1 0 {} {} 0 1} -test io-16.10 {Tcl_SetChannelOption, blocking mode} {unixOrPc tempNotPc} { +test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio} { removeFile pipe set f1 [open pipe w] - puts $f1 {gets stdin} - puts $f1 {after 100} - puts $f1 {puts hi} - puts $f1 {gets stdin} + puts $f1 { + gets stdin + after 100 + puts hi + gets stdin + } close $f1 set x "" set f1 [open "|[list $tcltest pipe]" r+] @@ -3399,10 +4916,14 @@ test io-16.10 {Tcl_SetChannelOption, blocking mode} {unixOrPc tempNotPc} { lappend x [fconfigure $f1 -blocking] lappend x [gets $f1] lappend x [fblocked $f1] + fconfigure $f1 -blocking on puts $f1 hello + fconfigure $f1 -blocking off lappend x [gets $f1] lappend x [fblocked $f1] + fconfigure $f1 -blocking on puts $f1 bye + fconfigure $f1 -blocking off lappend x [gets $f1] lappend x [fblocked $f1] fconfigure $f1 -blocking on @@ -3415,7 +4936,7 @@ test io-16.10 {Tcl_SetChannelOption, blocking mode} {unixOrPc tempNotPc} { close $f1 set x } {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1} -test io-16.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { +test io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { removeFile test1 set f [open test1 w] fconfigure $f -buffersize -10 @@ -3423,7 +4944,7 @@ test io-16.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { close $f set x } 4096 -test io-16.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} { +test io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} { removeFile test1 set f [open test1 w] fconfigure $f -buffersize 10000000 @@ -3431,7 +4952,7 @@ test io-16.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} { close $f set x } 4096 -test io-16.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { +test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { removeFile test1 set f [open test1 w] fconfigure $f -buffersize 40000 @@ -3439,12 +4960,66 @@ test io-16.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { close $f set x } 40000 -test io-16.14 {Tcl_SetChannelOption, setting read mode independently} \ +test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { + removeFile test1 + set f [open test1 w] + fconfigure $f -encoding {} + puts -nonewline $f \xe7\x89\xa6 + close $f + set f [open test1 r] + fconfigure $f -encoding utf-8 + set x [read $f] + close $f + set x +} \u7266 +test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} { + removeFile test1 + set f [open test1 w] + fconfigure $f -encoding binary + puts -nonewline $f \xe7\x89\xa6 + close $f + set f [open test1 r] + fconfigure $f -encoding utf-8 + set x [read $f] + close $f + set x +} \u7266 +test io-39.16 {Tcl_SetChannelOption: -encoding, errors} { + removeFile test1 + set f [open test1 w] + set result [list [catch {fconfigure $f -encoding foobar} msg] $msg] + close $f + set result +} {1 {unknown encoding "foobar"}} +test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio} { + set f [open "|[list $tcltest cat]" r+] + fconfigure $f -encoding binary + puts -nonewline $f "\xe7" + flush $f + fconfigure $f -encoding utf-8 -blocking 0 + set x {} + fileevent $f readable { lappend x [read $f] } + vwait x + after 300 { lappend x timeout } + vwait x + fconfigure $f -encoding utf-8 + vwait x + after 300 { lappend x timeout } + vwait x + fconfigure $f -encoding binary + vwait x + after 300 { lappend x timeout } + vwait x + close $f + set x +} "{} timeout {} timeout \xe7 timeout" + +test io-39.18 {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] + set s2 [socket 127.0.0.1 $port] update fconfigure $s2 -translation {auto lf} set modes [fconfigure $s2 -translation] @@ -3452,12 +5027,12 @@ test io-16.14 {Tcl_SetChannelOption, setting read mode independently} \ close $s2 set modes } {auto lf} -test io-16.15 {Tcl_SetChannelOption, setting read mode independently} \ +test io-39.19 {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] + set s2 [socket 127.0.0.1 $port] update fconfigure $s2 -translation {auto crlf} set modes [fconfigure $s2 -translation] @@ -3465,12 +5040,12 @@ test io-16.15 {Tcl_SetChannelOption, setting read mode independently} \ close $s2 set modes } {auto crlf} -test io-16.16 {Tcl_SetChannelOption, setting read mode independently} \ +test io-39.20 {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] + set s2 [socket 127.0.0.1 $port] update fconfigure $s2 -translation {auto cr} set modes [fconfigure $s2 -translation] @@ -3478,12 +5053,12 @@ test io-16.16 {Tcl_SetChannelOption, setting read mode independently} \ close $s2 set modes } {auto cr} -test io-16.17 {Tcl_SetChannelOption, setting read mode independently} \ +test io-39.21 {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] + set s2 [socket 127.0.0.1 $port] update fconfigure $s2 -translation {auto auto} set modes [fconfigure $s2 -translation] @@ -3492,7 +5067,7 @@ test io-16.17 {Tcl_SetChannelOption, setting read mode independently} \ set modes } {auto crlf} -test io-17.1 {POSIX open access modes: RDWR} { +test io-40.1 {POSIX open access modes: RDWR} { removeFile test3 set f [open test3 w] puts $f xyzzy @@ -3507,7 +5082,7 @@ test io-17.1 {POSIX open access modes: RDWR} { close $f set x } {zzy abzzy} -test io-17.2 {POSIX open access modes: CREAT} {unixOnly} { +test io-40.2 {POSIX open access modes: CREAT} {unixOnly} { removeFile test3 set f [open test3 {WRONLY CREAT} 0600] file stat test3 stats @@ -3519,7 +5094,12 @@ test io-17.2 {POSIX open access modes: CREAT} {unixOnly} { close $f set x } {0600 {line 1}} -test io-17.3 {POSIX open access modes: CREAT} {$testConfig(unix) && ([exec umask] == 2)} { + +# some tests can only be run is umask is 2 +# if "umask" cannot be run, the tests will be skipped. +catch {set ::tcltest::testConfig(umask2) [expr {[exec umask] == 2}]} + +test io-40.3 {POSIX open access modes: CREAT} {unixOnly umask2} { # This test only works if your umask is 2, like ouster's. removeFile test3 set f [open test3 {WRONLY CREAT}] @@ -3527,7 +5107,7 @@ test io-17.3 {POSIX open access modes: CREAT} {$testConfig(unix) && ([exec umask file stat test3 stats format "0%o" [expr $stats(mode)&0777] } 0664 -test io-17.4 {POSIX open access modes: CREAT} { +test io-40.4 {POSIX open access modes: CREAT} { removeFile test3 set f [open test3 w] fconfigure $f -eofchar {} @@ -3542,7 +5122,7 @@ test io-17.4 {POSIX open access modes: CREAT} { close $f set x } abzzy -test io-17.5 {POSIX open access modes: APPEND} { +test io-40.5 {POSIX open access modes: APPEND} { removeFile test3 set f [open test3 w] fconfigure $f -translation lf -eofchar {} @@ -3563,7 +5143,7 @@ test io-17.5 {POSIX open access modes: APPEND} { close $f set x } {{new line} abc} -test io-17.6 {POSIX open access modes: EXCL} { +test io-40.6 {POSIX open access modes: EXCL} { removeFile test3 set f [open test3 w] puts $f xyzzy @@ -3572,7 +5152,7 @@ test io-17.6 {POSIX open access modes: EXCL} { regsub " already " $msg " " msg string tolower $msg } {1 {couldn't open "test3": file exists}} -test io-17.7 {POSIX open access modes: EXCL} { +test io-40.7 {POSIX open access modes: EXCL} { removeFile test3 set f [open test3 {WRONLY CREAT EXCL}] fconfigure $f -eofchar {} @@ -3580,7 +5160,7 @@ test io-17.7 {POSIX open access modes: EXCL} { close $f viewFile test3 } {A test line} -test io-17.8 {POSIX open access modes: TRUNC} { +test io-40.8 {POSIX open access modes: TRUNC} { removeFile test3 set f [open test3 w] puts $f xyzzy @@ -3593,7 +5173,7 @@ test io-17.8 {POSIX open access modes: TRUNC} { close $f set x } abc -test io-17.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} { +test io-40.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} { removeFile test3 set f [open test3 {WRONLY NONBLOCK CREAT}] puts $f "NONBLOCK test" @@ -3603,7 +5183,7 @@ test io-17.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} { close $f set x } {NONBLOCK test} -test io-17.10 {POSIX open access modes: RDONLY} { +test io-40.10 {POSIX open access modes: RDONLY} { set f [open test1 w] puts $f "two lines: this one" puts $f "and this" @@ -3615,15 +5195,15 @@ test io-17.10 {POSIX open access modes: RDONLY} { [list {two lines: this one} 1 \ [format "channel \"%s\" wasn't opened for writing" $f]] } 0 -test io-17.11 {POSIX open access modes: RDONLY} { +test io-40.11 {POSIX open access modes: RDONLY} { removeFile test3 string tolower [list [catch {open test3 RDONLY} msg] $msg] } {1 {couldn't open "test3": no such file or directory}} -test io-17.12 {POSIX open access modes: WRONLY} { +test io-40.12 {POSIX open access modes: WRONLY} { removeFile test3 string tolower [list [catch {open test3 WRONLY} msg] $msg] } {1 {couldn't open "test3": no such file or directory}} -test io-17.13 {POSIX open access modes: WRONLY} { +test io-40.13 {POSIX open access modes: WRONLY} { makeFile xyzzy test3 set f [open test3 WRONLY] fconfigure $f -eofchar {} @@ -3635,11 +5215,11 @@ test io-17.13 {POSIX open access modes: WRONLY} { string compare [string tolower $x] \ [list 1 "channel \"$f\" wasn't opened for reading" abzzy] } 0 -test io-17.14 {POSIX open access modes: RDWR} { +test io-40.14 {POSIX open access modes: RDWR} { removeFile test3 string tolower [list [catch {open test3 RDWR} msg] $msg] } {1 {couldn't open "test3": no such file or directory}} -test io-17.15 {POSIX open access modes: RDWR} { +test io-40.15 {POSIX open access modes: RDWR} { makeFile xyzzy test3 set f [open test3 RDWR] puts -nonewline $f "ab" @@ -3649,7 +5229,7 @@ test io-17.15 {POSIX open access modes: RDWR} { lappend x [viewFile test3] } {zzy abzzy} if {![file exists ~/_test_] && [file writable ~]} { - test io-17.16 {tilde substitution in open} { + test io-40.16 {tilde substitution in open} { set f [open ~/_test_ w] puts $f "Some text" close $f @@ -3658,7 +5238,7 @@ if {![file exists ~/_test_] && [file writable ~]} { set x } 1 } -test io-17.17 {tilde substitution in open} { +test io-40.17 {tilde substitution in open} { set home $env(HOME) unset env(HOME) set x [list [catch {open ~/foo} msg] $msg] @@ -3666,19 +5246,19 @@ test io-17.17 {tilde substitution in open} { set x } {1 {couldn't find HOME environment variable to expand path}} -test io-18.1 {Tcl_FileeventCmd: errors} { +test io-41.1 {Tcl_FileeventCmd: errors} { list [catch {fileevent foo} msg] $msg -} {1 {wrong # args: must be "fileevent channelId event ?script?}} -test io-18.2 {Tcl_FileeventCmd: errors} { +} {1 {wrong # args: should be "fileevent channelId event ?script?"}} +test io-41.2 {Tcl_FileeventCmd: errors} { list [catch {fileevent foo bar baz q} msg] $msg -} {1 {wrong # args: must be "fileevent channelId event ?script?}} -test io-18.3 {Tcl_FileeventCmd: errors} { +} {1 {wrong # args: should be "fileevent channelId event ?script?"}} +test io-41.3 {Tcl_FileeventCmd: errors} { list [catch {fileevent gorp readable} msg] $msg } {1 {can not find channel named "gorp"}} -test io-18.4 {Tcl_FileeventCmd: errors} { +test io-41.4 {Tcl_FileeventCmd: errors} { list [catch {fileevent gorp writable} msg] $msg } {1 {can not find channel named "gorp"}} -test io-18.5 {Tcl_FileeventCmd: errors} { +test io-41.5 {Tcl_FileeventCmd: errors} { list [catch {fileevent gorp who-knows} msg] $msg } {1 {bad event name "who-knows": must be readable or writable}} @@ -3688,10 +5268,10 @@ test io-18.5 {Tcl_FileeventCmd: errors} { set f [open foo w+] -test io-19.1 {Tcl_FileeventCmd: creating, deleting, querying} { +test io-42.1 {Tcl_FileeventCmd: creating, deleting, querying} { list [fileevent $f readable] [fileevent $f writable] } {{} {}} -test io-19.2 {Tcl_FileeventCmd: replacing} { +test io-42.2 {Tcl_FileeventCmd: replacing} { set result {} fileevent $f r "first script" lappend result [fileevent $f readable] @@ -3702,18 +5282,26 @@ test io-19.2 {Tcl_FileeventCmd: replacing} { fileevent $f r "" lappend result [fileevent $f readable] } {{first script} {new script} {yet another} {}} +test io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} { + set result {} + fileevent $f r "first scr\0ipt" + lappend result [string length [fileevent $f readable]] + fileevent $f r "new scr\0ipt" + lappend result [string length [fileevent $f readable]] + fileevent $f r "yet ano\0ther" + lappend result [string length [fileevent $f readable]] + fileevent $f r "" + lappend result [fileevent $f readable] +} {13 11 12 {}} # # Test fileevent on a pipe # -if {($tcl_platform(platform) != "macintosh") && \ - ($testConfig(unixExecs) == 1)} { - catch {set f2 [open "|[list cat -u]" r+]} catch {set f3 [open "|[list cat -u]" r+]} -test io-20.1 {Tcl_FileeventCmd: creating, deleting, querying} { +test io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs} { set result {} fileevent $f readable "script 1" lappend result [fileevent $f readable] [fileevent $f writable] @@ -3724,7 +5312,7 @@ test io-20.1 {Tcl_FileeventCmd: creating, deleting, querying} { fileevent $f writable {} lappend result [fileevent $f readable] [fileevent $f writable] } {{script 1} {} {script 1} {write script} {} {write script} {} {}} -test io-20.2 {Tcl_FileeventCmd: deleting when many present} { +test io-43.2 {Tcl_FileeventCmd: deleting when many present} {stdio unixExecs} { set result {} lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] fileevent $f r "read f" @@ -3739,7 +5327,7 @@ test io-20.2 {Tcl_FileeventCmd: deleting when many present} { lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] } {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}} -test io-21.1 {FileEventProc procedure: normal read event} { +test io-44.1 {FileEventProc procedure: normal read event} {stdio unixExecs} { fileevent $f2 readable { set x [gets $f2]; fileevent $f2 readable {} } @@ -3748,7 +5336,7 @@ test io-21.1 {FileEventProc procedure: normal read event} { vwait x set x } {text} -test io-21.2 {FileEventProc procedure: error in read event} { +test io-44.2 {FileEventProc procedure: error in read event} {stdio unixExecs} { proc bgerror args { global x set x $args @@ -3760,7 +5348,7 @@ test io-21.2 {FileEventProc procedure: error in read event} { rename bgerror {} list $x [fileevent $f2 readable] } {bogus {}} -test io-21.3 {FileEventProc procedure: normal write event} { +test io-44.3 {FileEventProc procedure: normal write event} {stdio unixExecs} { fileevent $f2 writable { lappend x "triggered" incr count -1 @@ -3775,7 +5363,7 @@ test io-21.3 {FileEventProc procedure: normal write event} { vwait x set x } {initial triggered triggered triggered} -test io-21.4 {FileEventProc procedure: eror in write event} { +test io-44.4 {FileEventProc procedure: eror in write event} {stdio unixExecs} { proc bgerror args { global x set x $args @@ -3786,7 +5374,7 @@ test io-21.4 {FileEventProc procedure: eror in write event} { rename bgerror {} list $x [fileevent $f2 writable] } {bad-write {}} -test io-21.5 {FileEventProc procedure: end of file} {unixOrPc} { +test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs} { set f4 [open "|[list $tcltest cat << foo]" r] fileevent $f4 readable { if {[gets $f4 line] < 0} { @@ -3806,13 +5394,10 @@ test io-21.5 {FileEventProc procedure: end of file} {unixOrPc} { 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} { +test io-45.1 {DeleteFileEvent, cleanup on close} { set f [open foo r] fileevent $f readable { lappend x "binding triggered: \"[gets $f]\"" @@ -3824,7 +5409,7 @@ test io-22.1 {DeleteFileEvent, cleanup on close} { vwait y set x } {initial} -test io-22.2 {DeleteFileEvent, cleanup on close} { +test io-45.2 {DeleteFileEvent, cleanup on close} { set f [open foo r] set f2 [open foo r] fileevent $f readable { @@ -3841,7 +5426,7 @@ test io-22.2 {DeleteFileEvent, cleanup on close} { close $f2 set x } {initial {f2 triggered: "foo bar"}} -test io-22.3 {DeleteFileEvent, cleanup on close} { +test io-45.3 {DeleteFileEvent, cleanup on close} { set f [open foo r] set f2 [open foo r] set f3 [open foo r] @@ -3867,7 +5452,7 @@ test io-22.3 {DeleteFileEvent, cleanup on close} { if {[info commands testfevent] == "testfevent"} { -test io-23.1 {Tcl event loop vs multiple interpreters} { +test io-46.1 {Tcl event loop vs multiple interpreters} { testfevent create testfevent cmd { set f [open foo r] @@ -3882,7 +5467,7 @@ test io-23.1 {Tcl event loop vs multiple interpreters} { testfevent cmd {close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} -test io-23.2 {Tcl event loop vs multiple interpreters} { +test io-46.2 {Tcl event loop vs multiple interpreters} { testfevent create testfevent cmd { set x 0 @@ -3891,7 +5476,7 @@ test io-23.2 {Tcl event loop vs multiple interpreters} { set x } } {triggered} -test io-23.3 {Tcl event loop vs multiple interpreters} { +test io-46.3 {Tcl event loop vs multiple interpreters} { testfevent create testfevent cmd { set x 0 @@ -3905,7 +5490,7 @@ test io-23.3 {Tcl event loop vs multiple interpreters} { } } {0 0 {0 timer}} -test io-24.1 {fileevent vs multiple interpreters} { +test io-47.1 {fileevent vs multiple interpreters} { set f [open foo r] set f2 [open foo r] set f3 [open foo r] @@ -3924,7 +5509,7 @@ test io-24.1 {fileevent vs multiple interpreters} { close $f3 set x } {{} {script 1} {} {sript 3}} -test io-24.2 {deleting fileevent on interpreter delete} { +test io-47.2 {deleting fileevent on interpreter delete} { set f [open foo r] set f2 [open foo r] set f3 [open foo r] @@ -3945,7 +5530,7 @@ test io-24.2 {deleting fileevent on interpreter delete} { close $f4 set x } {{script 1} {} {} {script 4}} -test io-24.3 {deleting fileevent on interpreter delete} { +test io-47.3 {deleting fileevent on interpreter delete} { set f [open foo r] set f2 [open foo r] set f3 [open foo r] @@ -3966,7 +5551,7 @@ test io-24.3 {deleting fileevent on interpreter delete} { close $f4 set x } {{script 1} {script 2} {} {}} -test io-24.4 {file events on shared files and multiple interpreters} { +test io-47.4 {file events on shared files and multiple interpreters} { set f [open foo r] set f2 [open foo r] testfevent create @@ -3982,7 +5567,7 @@ test io-24.4 {file events on shared files and multiple interpreters} { close $f2 set x } {{script 3} {script 1} {script 2}} -test io-24.5 {file events on shared files, deleting file events} { +test io-47.5 {file events on shared files, deleting file events} { set f [open foo r] testfevent create testfevent share $f @@ -3995,7 +5580,7 @@ test io-24.5 {file events on shared files, deleting file events} { close $f set x } {{} {script 2}} -test io-24.6 {file events on shared files, deleting file events} { +test io-47.6 {file events on shared files, deleting file events} { set f [open foo r] testfevent create testfevent share $f @@ -4013,7 +5598,7 @@ test io-24.6 {file events on shared files, deleting file events} { # The above curly closes the test for presence of the "testfevent" command. -test io-25.1 {testing readability conditions} { +test io-48.1 {testing readability conditions} { set f [open bar w] puts $f abcdefg puts $f abcdefg @@ -4038,7 +5623,7 @@ test io-25.1 {testing readability conditions} { vwait x list $x $l } {done {called called called called called called called}} -test io-25.2 {testing readability conditions} {nonBlockFiles} { +test io-48.2 {testing readability conditions} {nonBlockFiles} { set f [open bar w] puts $f abcdefg puts $f abcdefg @@ -4064,7 +5649,7 @@ test io-25.2 {testing readability conditions} {nonBlockFiles} { vwait x list $x $l } {done {called called called called called called called}} -test io-25.3 {testing readability conditions} {unixOnly nonBlockFiles} { +test io-48.3 {testing readability conditions} {unixOnly nonBlockFiles} { set f [open bar w] puts $f abcdefg puts $f abcdefg @@ -4108,7 +5693,7 @@ test io-25.3 {testing readability conditions} {unixOnly nonBlockFiles} { close $f list $x $l } {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} -test io-25.4 {lf write, testing readability, ^Z termination, auto read mode} { +test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4133,7 +5718,7 @@ test io-25.4 {lf write, testing readability, ^Z termination, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.5 {lf write, testing readability, ^Z in middle, auto read mode} { +test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4158,7 +5743,7 @@ test io-25.5 {lf write, testing readability, ^Z in middle, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.6 {cr write, testing readability, ^Z termination, auto read mode} { +test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -4183,7 +5768,7 @@ test io-25.6 {cr write, testing readability, ^Z termination, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.7 {cr write, testing readability, ^Z in middle, auto read mode} { +test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -4208,7 +5793,7 @@ test io-25.7 {cr write, testing readability, ^Z in middle, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.8 {crlf write, testing readability, ^Z termination, auto read mode} { +test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -4233,7 +5818,7 @@ test io-25.8 {crlf write, testing readability, ^Z termination, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.9 {crlf write, testing readability, ^Z in middle, auto read mode} { +test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -4258,7 +5843,7 @@ test io-25.9 {crlf write, testing readability, ^Z in middle, auto read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.10 {lf write, testing readability, ^Z in middle, lf read mode} { +test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4283,7 +5868,7 @@ test io-25.10 {lf write, testing readability, ^Z in middle, lf read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.11 {lf write, testing readability, ^Z termination, lf read mode} { +test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4308,7 +5893,7 @@ test io-25.11 {lf write, testing readability, ^Z termination, lf read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.12 {cr write, testing readability, ^Z in middle, cr read mode} { +test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -4333,7 +5918,7 @@ test io-25.12 {cr write, testing readability, ^Z in middle, cr read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.13 {cr write, testing readability, ^Z termination, cr read mode} { +test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation cr @@ -4358,7 +5943,7 @@ test io-25.13 {cr write, testing readability, ^Z termination, cr read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.14 {crlf write, testing readability, ^Z in middle, crlf read mode} { +test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -4383,7 +5968,7 @@ test io-25.14 {crlf write, testing readability, ^Z in middle, crlf read mode} { vwait x list $c $l } {3 {abc def {}}} -test io-25.15 {crlf write, testing readability, ^Z termi, crlf read mode} { +test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation crlf @@ -4409,7 +5994,7 @@ test io-25.15 {crlf write, testing readability, ^Z termi, crlf read mode} { list $c $l } {3 {abc def {}}} -test io-26.1 {testing crlf reading, leftover cr disgorgment} { +test io-49.1 {testing crlf reading, leftover cr disgorgment} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4438,7 +6023,7 @@ test io-26.1 {testing crlf reading, leftover cr disgorgment} { set l } "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 { } 7 0 {} 1" -test io-26.2 {testing crlf reading, leftover cr disgorgment} { +test io-49.2 {testing crlf reading, leftover cr disgorgment} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4461,7 +6046,7 @@ test io-26.2 {testing crlf reading, leftover cr disgorgment} { close $f set l } "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1" -test io-26.3 {testing crlf reading, leftover cr disgorgment} { +test io-49.3 {testing crlf reading, leftover cr disgorgment} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4482,7 +6067,7 @@ test io-26.3 {testing crlf reading, leftover cr disgorgment} { close $f set l } "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1" -test io-26.4 {testing crlf reading, leftover cr disgorgment} { +test io-49.4 {testing crlf reading, leftover cr disgorgment} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4503,7 +6088,7 @@ test io-26.4 {testing crlf reading, leftover cr disgorgment} { close $f set l } "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1" -test io-26.5 {testing crlf reading, leftover cr disgorgment} { +test io-49.5 {testing crlf reading, leftover cr disgorgment} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -4522,7 +6107,7 @@ test io-26.5 {testing crlf reading, leftover cr disgorgment} { set l } [list 7 a\rb\rc 7 {} 7 1] -test io-27.1 {testing handler deletion} { +test io-50.1 {testing handler deletion} { removeFile test1 set f [open test1 w] close $f @@ -4538,7 +6123,7 @@ test io-27.1 {testing handler deletion} { close $f set z } called -test io-27.2 {testing handler deletion with multiple handlers} { +test io-50.2 {testing handler deletion with multiple handlers} { removeFile test1 set f [open test1 w] close $f @@ -4556,7 +6141,7 @@ test io-27.2 {testing handler deletion with multiple handlers} { string compare [string tolower $z] \ [list [list called delhandler $f 0] [list called delhandler $f 1]] } 0 -test io-27.3 {testing handler deletion with multiple handlers} { +test io-50.3 {testing handler deletion with multiple handlers} { removeFile test1 set f [open test1 w] close $f @@ -4582,7 +6167,7 @@ test io-27.3 {testing handler deletion with multiple handlers} { [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] } 0 -test io-27.4 {testing handler deletion vs reentrant calls} { +test io-50.4 {testing handler deletion vs reentrant calls} { removeFile test1 set f [open test1 w] close $f @@ -4606,7 +6191,7 @@ test io-27.4 {testing handler deletion vs reentrant calls} { string compare [string tolower $z] \ {{delrecursive calling recursive} {delrecursive deleting recursive}} } 0 -test io-27.5 {testing handler deletion vs reentrant calls} { +test io-50.5 {testing handler deletion vs reentrant calls} { removeFile test1 set f [open test1 w] close $f @@ -4639,7 +6224,7 @@ test io-27.5 {testing handler deletion vs reentrant calls} { [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] } 0 -test io-27.6 {testing handler deletion vs reentrant calls} { +test io-50.6 {testing handler deletion vs reentrant calls} { removeFile test1 set f [open test1 w] close $f @@ -4681,7 +6266,7 @@ test io-27.6 {testing handler deletion vs reentrant calls} { {first after update}] } 0 -test io-28.1 {Test old socket deletion on Macintosh} {socket} { +test io-51.1 {Test old socket deletion on Macintosh} {socket} { set x 0 set result "" proc accept {s a p} { @@ -4719,9 +6304,9 @@ test io-28.1 {Test old socket deletion on Macintosh} {socket} { set result } {sock1 sock2 sock3 sock4} -test io-29.1 {TclCopyChannel} { +test io-52.1 {TclCopyChannel} { removeFile test1 - set f1 [open [info script]] + set f1 [open $thisScript] set f2 [open test1 w] fcopy $f1 $f2 -command { # } catch { fcopy $f1 $f2 } msg @@ -4729,11 +6314,11 @@ test io-29.1 {TclCopyChannel} { close $f2 string compare $msg "channel \"$f1\" is busy" } {0} -test io-29.2 {TclCopyChannel} { +test io-52.2 {TclCopyChannel} { removeFile test1 - set f1 [open [info script]] + set f1 [open $thisScript] set f2 [open test1 w] - set f3 [open [info script]] + set f3 [open $thisScript] fcopy $f1 $f2 -command { # } catch { fcopy $f3 $f2 } msg close $f1 @@ -4741,9 +6326,9 @@ test io-29.2 {TclCopyChannel} { close $f3 string compare $msg "channel \"$f2\" is busy" } {0} -test io-29.3 {TclCopyChannel} { +test io-52.3 {TclCopyChannel} { removeFile test1 - set f1 [open [info script]] + set f1 [open $thisScript] set f2 [open test1 w] fconfigure $f1 -translation lf -blocking 0 fconfigure $f2 -translation cr -blocking 0 @@ -4751,16 +6336,16 @@ test io-29.3 {TclCopyChannel} { set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 close $f2 - set s1 [file size [info script]] + set s1 [file size $thisScript] set s2 [file size test1] if {("$s1" == "$s2") && ($s0 == $s1)} { lappend result ok } set result } {0 0 ok} -test io-29.4 {TclCopyChannel} { +test io-52.4 {TclCopyChannel} { removeFile test1 - set f1 [open [info script]] + set f1 [open $thisScript] set f2 [open test1 w] fconfigure $f1 -translation lf -blocking 0 fconfigure $f2 -translation cr -blocking 0 @@ -4770,9 +6355,9 @@ test io-29.4 {TclCopyChannel} { close $f2 lappend result [file size test1] } {0 0 40} -test io-29.5 {TclCopyChannel} { +test io-52.5 {TclCopyChannel} { removeFile test1 - set f1 [open [info script]] + set f1 [open $thisScript] set f2 [open test1 w] fconfigure $f1 -translation lf -blocking 0 fconfigure $f2 -translation lf -blocking 0 @@ -4780,39 +6365,39 @@ test io-29.5 {TclCopyChannel} { set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 close $f2 - set s1 [file size [info script]] + set s1 [file size $thisScript] set s2 [file size test1] if {"$s1" == "$s2"} { lappend result ok } set result } {0 0 ok} -test io-29.6 {TclCopyChannel} { +test io-52.6 {TclCopyChannel} { removeFile test1 - set f1 [open [info script]] + set f1 [open $thisScript] 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 s0 [fcopy $f1 $f2 -size [expr [file size $thisScript] + 5]] set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 close $f2 - set s1 [file size [info script]] + set s1 [file size $thisScript] set s2 [file size test1] if {("$s1" == "$s2") && ($s0 == $s1)} { lappend result ok } set result } {0 0 ok} -test io-29.7 {TclCopyChannel} { +test io-52.7 {TclCopyChannel} { removeFile test1 - set f1 [open [info script]] + set f1 [open $thisScript] 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 s1 [file size $thisScript] set s2 [file size test1] close $f1 close $f2 @@ -4821,19 +6406,19 @@ test io-29.7 {TclCopyChannel} { } set result } {0 0 ok} -test io-29.8 {TclCopyChannel} {stdio} { +test io-52.8 {TclCopyChannel} {stdio} { removeFile test1 removeFile pipe set f1 [open pipe w] fconfigure $f1 -translation lf - puts $f1 { + puts $f1 " puts ready gets stdin - set f1 [open [info script] r] - fconfigure $f1 -translation lf - puts [read $f1 100] - close $f1 - } + set f1 \[open [list $thisScript] r\] + fconfigure \$f1 -translation lf + puts \[read \$f1 100\] + close \$f1 + " close $f1 set f1 [open "|[list $tcltest pipe]" r+] fconfigure $f1 -translation lf @@ -4848,9 +6433,9 @@ test io-29.8 {TclCopyChannel} {stdio} { list $s0 [file size test1] } {40 40} -test io-30.1 {CopyData} { +test io-53.1 {CopyData} { removeFile test1 - set f1 [open [info script]] + set f1 [open $thisScript] set f2 [open test1 w] fconfigure $f1 -translation lf -blocking 0 fconfigure $f2 -translation cr -blocking 0 @@ -4860,9 +6445,9 @@ test io-30.1 {CopyData} { close $f2 lappend result [file size test1] } {0 0 0} -test io-30.2 {CopyData} { +test io-53.2 {CopyData} { removeFile test1 - set f1 [open [info script]] + set f1 [open $thisScript] set f2 [open test1 w] fconfigure $f1 -translation lf -blocking 0 fconfigure $f2 -translation cr -blocking 0 @@ -4871,14 +6456,14 @@ test io-30.2 {CopyData} { vwait s0 close $f1 close $f2 - set s1 [file size [info script]] + set s1 [file size $thisScript] 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} { +test io-53.3 {CopyData: background read underflow} {unixOnly} { removeFile test1 removeFile pipe set f1 [open pipe w] @@ -4908,8 +6493,8 @@ test io-30.3 {CopyData: background read underflow} {unixOnly} { close $f set result } "ready line1 line2 {done\n}" -test io-30.4 {CopyData: background write overflow} {unixOnly} { - set big aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n +test io-53.4 {CopyData: background write overflow} {unixOnly} { + set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n for {set x 0} {$x < 12} {incr x} { append big $big } @@ -4944,6 +6529,7 @@ test io-30.4 {CopyData: background write overflow} {unixOnly} { set big {} set x } done +set result {} proc FcopyTestAccept {sock args} { after 1000 "close $sock" @@ -4956,24 +6542,22 @@ proc FcopyTestDone {bytes {error {}}} { set fcopyTestDone 0 } } -if [catch {socket -server FcopyTestAccept 2828} listen] { - puts stderr "Skipping fcopy error test" -} else { - test io-30.5 {CopyData: error during fcopy} { - set in [open [info script]] ;# 126 K - set out [socket localhost 2828] - catch {unset fcopyTestDone} - close $listen ;# This means the socket open never really succeeds - fcopy $in $out -command FcopyTestDone - if ![info exists fcopyTestDone] { - vwait fcopyTestDone ;# The error occurs here in the b.g. - } - close $in - close $out - set fcopyTestDone ;# 1 for error condition - } 1 -} -test io-30.6 {CopyData: error during fcopy} {stdio} { + +test io-53.5 {CopyData: error during fcopy} {socket} { + set listen [socket -server FcopyTestAccept 2828] + set in [open $thisScript] ;# 126 K + set out [socket 127.0.0.1 2828] + catch {unset fcopyTestDone} + close $listen ;# This means the socket open never really succeeds + fcopy $in $out -command FcopyTestDone + if ![info exists fcopyTestDone] { + vwait fcopyTestDone ;# The error occurs here in the b.g. + } + close $in + close $out + set fcopyTestDone ;# 1 for error condition +} 1 +test io-53.6 {CopyData: error during fcopy} {stdio} { removeFile pipe removeFile test1 catch {unset fcopyTestDone} @@ -4991,7 +6575,7 @@ test io-30.6 {CopyData: error during fcopy} {stdio} { set fcopyTestDone ;# 0 for plain end of file } {0} -test io-31.1 {Recursive channel events} {socket} { +test io-54.1 {Recursive channel events} {socket} { # This test checks to see if file events are delivered during recursive # event loops when there is buffered data on the channel. @@ -5043,36 +6627,40 @@ test io-31.1 {Recursive channel events} {socket} { close $cs list $result $x } {{{line 1} 1 2} 2} -test io-31.2 {Testing for busy-wait in recursive channel events} {socket} { +test io-54.2 {Testing for busy-wait in recursive channel events} {socket} { + set accept {} + set after {} set s [socket -server accept 3939] proc accept {s a p} { - global counter + global counter accept + set accept $s set counter 0 fconfigure $s -blocking off -buffering line -translation lf fileevent $s readable "doit $s" } proc doit {s} { - global counter + global counter after incr counter set l [gets $s] if {"$l" == ""} { fileevent $s readable "doit1 $s" - after 1000 newline + set after [after 1000 newline] } } proc doit1 {s} { - global counter + global counter accept incr counter set l [gets $s] close $s + set accept {} } proc producer {} { global writer - set writer [socket localhost 3939] + set writer [socket 127.0.0.1 3939] fconfigure $writer -buffering line puts -nonewline $writer hello flush $writer @@ -5088,9 +6676,12 @@ test io-31.2 {Testing for busy-wait in recursive channel events} {socket} { vwait done close $writer close $s + after cancel $after + if {$accept != {}} {close $accept} set counter } 1 -test io-32.1 {ChannelEventScriptInvoker: deletion} { + +test io-55.1 {ChannelEventScriptInvoker: deletion} { proc eventScript {fd} { close $fd error "planned error" @@ -5106,7 +6697,7 @@ test io-32.1 {ChannelEventScriptInvoker: deletion} { set x } {got_error} -test io-33.1 {ChannelTimerProc} { +test io-56.1 {ChannelTimerProc} { set f [open fooBar w] puts $f "this is a test" close $f @@ -5126,12 +6717,12 @@ test io-33.1 {ChannelTimerProc} { lappend result $y } {2 done} -test io-34.1 {buffered data and file events, gets} { +test io-57.1 {buffered data and file events, gets} { proc accept {sock args} { set ::s2 $sock } set server [socket -server accept 4040] - set s [socket localhost 4040] + set s [socket 127.0.0.1 4040] vwait s2 update fileevent $s2 readable {lappend result readable} @@ -5147,12 +6738,12 @@ test io-34.1 {buffered data and file events, gets} { close $server set result } {12 readable 34567890 timer} -test io-34.2 {buffered data and file events, read} { +test io-57.2 {buffered data and file events, read} { proc accept {sock args} { set ::s2 $sock } set server [socket -server accept 4041] - set s [socket localhost 4041] + set s [socket 127.0.0.1 4041] vwait s2 update fileevent $s2 readable {lappend result readable} @@ -5169,7 +6760,7 @@ test io-34.2 {buffered data and file events, read} { set result } {1 readable 234567890 timer} -test io-35.1 {Tcl_NotifyChannel and error when closing} {unixOrPc} { +test io-58.1 {Tcl_NotifyChannel and error when closing} {unixOrPc} { set out [open script w] puts $out { puts "normal message from pipe" @@ -5195,20 +6786,24 @@ test io-35.1 {Tcl_NotifyChannel and error when closing} {unixOrPc} { list $x $result } {1 {gets {normal message from pipe} gets {} catch {error message from pipe}}} +# cleanup +foreach file [list fooBar longfile script output test1 pipe my_script foo \ + bar test2 test3 cat stdout] { + ::tcltest::removeFile $file +} +restoreState +::tcltest::cleanupTests +return + + + + + + + + + + -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 index 8de4456..1937c5d 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -7,13 +7,16 @@ # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: ioCmd.test,v 1.2 1998/09/14 18:40:11 stanton Exp $ +# RCS: @(#) $Id: ioCmd.test,v 1.3 1999/04/16 00:47:29 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} removeFile test1 removeFile pipe @@ -158,7 +161,7 @@ test iocmd-5.3 {seek command} { } {1 {expected integer but got "gugu"}} test iocmd-5.4 {seek command} { list [catch {seek stdin 100 gugu} msg] $msg -} {1 {bad origin "gugu": should be start, current, or end}} +} {1 {bad origin "gugu": must be start, current, or end}} test iocmd-6.1 {tell command} { list [catch {tell} msg] $msg @@ -205,31 +208,31 @@ test iocmd-8.6 {fconfigure command} { test iocmd-8.7 {fconfigure command} { removeFile test1 set f1 [open test1 w] - fconfigure $f1 -translation lf -eofchar {} + fconfigure $f1 -translation lf -eofchar {} -encoding unicode set x [fconfigure $f1] close $f1 set x -} {-blocking 1 -buffering full -buffersize 4096 -eofchar {} -translation lf} +} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} test iocmd-8.8 {fconfigure command} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ - -eofchar {} + -eofchar {} -encoding unicode set x "" lappend x [fconfigure $f1 -buffering] lappend x [fconfigure $f1] close $f1 set x -} {line {-blocking 1 -buffering line -buffersize 3030 -eofchar {} -translation lf}} +} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} test iocmd-8.9 {fconfigure command} { removeFile test1 set f1 [open test1 w] fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ - -eofchar {} + -eofchar {} -encoding binary set x [fconfigure $f1] close $f1 set x -} {-blocking 1 -buffering none -buffersize 4040 -eofchar {} -translation lf} +} {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} test iocmd-8.10 {fconfigure command} { list [catch {fconfigure a b} msg] $msg } {1 {can not find channel named "a"}} @@ -250,7 +253,7 @@ proc iocmdSSETUP {} { 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]; + set cli [socket 127.0.0.1 $port]; } } proc iocmdSSHTDWN {} { @@ -293,9 +296,8 @@ test iocmd-8.18 {fconfigure command / unix tty channel} {nonPortable unixOnly} { close $tty; set r; } {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}} -test iocmd-8.19 {fconfigure command / win tty channel} {pcOnly && !win32s} { - # None of the com port functions are implemented on Win32s. - # Also, might fail if com1 is unavailable +test iocmd-8.19 {fconfigure command / win tty channel} {nonPortable pcOnly} { + # might fail if com1 is unavailable set tty [open com1] set r [list [catch {fconfigure $tty -blah blih} msg] $msg]; close $tty; @@ -313,6 +315,8 @@ test iocmd-9.3 {eof command} { list [catch {eof file100} msg] $msg $errorCode } {1 {can not find channel named "file100"} NONE} +# The tests for Tcl_ExecObjCmd are in exec.test + test iocmd-10.1 {fblocked command} { list [catch {fblocked} msg] $msg } {1 {wrong # args: should be "fblocked channelId"}} @@ -488,7 +492,7 @@ test iocmd-15.9 {Tcl_FcopyObjCmd} { } "1 {channel \"$rfile\" wasn't opened for writing}" test iocmd-15.10 {Tcl_FcopyObjCmd} { list [catch {fcopy $rfile $wfile foo bar} msg] $msg -} {1 {bad switch "foo": must be -size, or -command}} +} {1 {bad switch "foo": must be -size or -command}} test iocmd-15.11 {Tcl_FcopyObjCmd} { list [catch {fcopy $rfile $wfile -size foo} msg] $msg } {1 {expected integer but got "foo"}} @@ -499,14 +503,26 @@ test iocmd-15.12 {Tcl_FcopyObjCmd} { close $rfile close $wfile -removeFile test1 -removeFile test2 -removeFile test3 -removeFile test4 +# cleanup +foreach file [list test1 test2 test3 test4] { + ::tcltest::removeFile $file +} # delay long enough for background processes to finish after 500 -removeFile test5 -removeFile pipe -removeFile output -set x "" -set x +foreach file [list test5 pipe output] { + ::tcltest::removeFile $file +} +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/ioUtil.test b/tests/ioUtil.test index dd254fd..5bb8c35 100644 --- a/tests/ioUtil.test +++ b/tests/ioUtil.test @@ -1,16 +1,18 @@ -# This file (iOUtil.test) tests the hookable TclStat(), TclAccess(), +# This file (ioUtil.test) tests the hookable TclStat(), TclAccess(), # and Tcl_OpenFileChannel, routines in the file generic/tclIOUtils.c. # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 1998 by Scriptics Corporation. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: ioUtil.test,v 1.5 1998/09/14 18:40:10 stanton Exp $ +# RCS: @(#) $Id: ioUtil.test,v 1.6 1999/04/16 00:47:29 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} set unsetScript { catch {unset testStat1(size)} @@ -18,7 +20,7 @@ set unsetScript { catch {unset testStat3(size)} } -test stat-1.1 {TclStat: Check that none of the test procs are there.} { +test ioUtil-1.1 {TclStat: Check that none of the test procs are there.} {knownBug} { catch {file stat testStat1%.fil testStat1} err1 catch {file stat testStat2%.fil testStat2} err2 catch {file stat testStat3%.fil testStat3} err3 @@ -29,7 +31,7 @@ if {[info commands teststatproc] == {}} { puts "This application hasn't been compiled with the \"teststatproc\"" puts "command, so I can't test Tcl_Stat_* etc." } else { -test stat-1.2 {TclStatInsertProc: Insert the 3 test TclStat_ procedures.} { +test ioUtil-1.2 {TclStatInsertProc: Insert the 3 test TclStat_ procedures.} { catch {teststatproc insert TclpStat} err1 teststatproc insert TestStatProc1 teststatproc insert TestStatProc2 @@ -37,7 +39,7 @@ test stat-1.2 {TclStatInsertProc: Insert the 3 test TclStat_ procedures.} { set err1 } {bad arg "insert": must be TestStatProc1, TestStatProc2, or TestStatProc3} -test stat-1.3 {TclStat: Use "file stat ?" to invoke each procedure.} { +test ioUtil-1.3 {TclStat: Use "file stat ?" to invoke each procedure.} {knownBug} { file stat testStat2%.fil testStat2 file stat testStat1%.fil testStat1 file stat testStat3%.fil testStat3 @@ -47,12 +49,12 @@ test stat-1.3 {TclStat: Use "file stat ?" to invoke each procedure.} { eval $unsetScript -test stat-1.4 {TclStatDeleteProc: "TclpStat" function should not be deletedable.} { +test ioUtil-1.4 {TclStatDeleteProc: "TclpStat" function should not be deletedable.} { catch {teststatproc delete TclpStat} err2 set err2 } {"TclpStat": could not be deleteed} -test stat-1.5 {TclStatDeleteProc: Delete the 2nd TclStat procedure.} { +test ioUtil-1.5 {TclStatDeleteProc: Delete the 2nd TclStat procedure.} {knownBug} { # Delete the 2nd procedure and test that it longer exists but that # the others do actually return a result. @@ -66,7 +68,7 @@ test stat-1.5 {TclStatDeleteProc: Delete the 2nd TclStat procedure.} { eval $unsetScript -test stat-1.6 {TclStatDeleteProc: Delete the 1st TclStat procedure.} { +test ioUtil-1.6 {TclStatDeleteProc: Delete the 1st TclStat procedure.} {knownBug} { # Next delete the 1st procedure and test that only the 3rd procedure # is the only one that exists. @@ -80,7 +82,7 @@ test stat-1.6 {TclStatDeleteProc: Delete the 1st TclStat procedure.} { eval $unsetScript -test stat-1.7 {TclStatDeleteProc: Delete the 3rd procedure & verify all are gone.} { +test ioUtil-1.7 {TclStatDeleteProc: Delete the 3rd procedure & verify all are gone.} {knownBug} { # Finally delete the 3rd procedure and check that none of the # procedures exist. @@ -94,7 +96,7 @@ test stat-1.7 {TclStatDeleteProc: Delete the 3rd procedure & verify all are gone eval $unsetScript -test stat-1.8 {TclStatDeleteProc: Verify that all procs have been deleted.} { +test ioUtil-1.8 {TclStatDeleteProc: Verify that all procs have been deleted.} {knownBug} { # Attempt to delete all the Stat procs. again to ensure they no longer # exist and an error is returned. @@ -120,7 +122,7 @@ if {[info commands testaccessproc] == {}} { puts "This application hasn't been compiled with the \"testaccessproc\"" puts "command, so I can't test Tcl_Access_* etc." } else { -test access-1.2 {TclAccessInsertProc: Insert the 3 test TclAccess_ procedures.} { +test ioUtil-1.2 {TclAccessInsertProc: Insert the 3 test TclAccess_ procedures.} { catch {testaccessproc insert TclpAccess} err1 testaccessproc insert TestAccessProc1 testaccessproc insert TestAccessProc2 @@ -128,14 +130,14 @@ test access-1.2 {TclAccessInsertProc: Insert the 3 test TclAccess_ procedures.} set err1 } {bad arg "insert": must be TestAccessProc1, TestAccessProc2, or TestAccessProc3} -test access-1.3 {TclAccess: Use "file access ?" to invoke each procedure.} { +test ioUtil-2.3 {TclAccess: Use "file access ?" to invoke each procedure.} { list \ [file exists testAccess2%.fil] \ [file exists testAccess1%.fil] \ [file exists testAccess3%.fil] } {1 1 1} -test access-1.4 {TclAccessDeleteProc: "TclpAccess" function should not be deletedable.} { +test ioUtil-2.4 {TclAccessDeleteProc: "TclpAccess" function should not be deletedable.} { catch {testaccessproc delete TclpAccess} err2 set err2 } {"TclpAccess": could not be deleteed} @@ -152,7 +154,7 @@ test accesst-1.5 {TclAccessDeleteProc: Delete the 2nd TclAccess procedure.} { list $res1 $err3 $res2 } {1 0 1} -test access-1.6 {TclAccessDeleteProc: Delete the 1st TclAccess procedure.} { +test ioUtil-2.6 {TclAccessDeleteProc: Delete the 1st TclAccess procedure.} { # Next delete the 1st procedure and test that only the 3rd procedure # is the only one that exists. @@ -164,7 +166,7 @@ test access-1.6 {TclAccessDeleteProc: Delete the 1st TclAccess procedure.} { list $err4 $err5 $res3 } {0 0 1} -test access-1.7 {TclAccessDeleteProc: Delete the 3rd procedure & verify all are gone.} { +test ioUtil-2.7 {TclAccessDeleteProc: Delete the 3rd procedure & verify all are gone.} { # Finally delete the 3rd procedure and check that none of the # procedures exist. @@ -176,7 +178,7 @@ test access-1.7 {TclAccessDeleteProc: Delete the 3rd procedure & verify all are list $err6 $err7 $err8 } {0 0 0} -test access-1.8 {TclAccessDeleteProc: Verify that all procs have been deleted.} { +test ioUtil-2.8 {TclAccessDeleteProc: Verify that all procs have been deleted.} { # Attempt to delete all the Access procs. again to ensure they no longer # exist and an error is returned. @@ -188,7 +190,7 @@ test access-1.8 {TclAccessDeleteProc: Verify that all procs have been deleted.} } {{"TestAccessProc1": could not be deleteed} {"TestAccessProc2": could not be deleteed} {"TestAccessProc3": could not be deleteed}} } -test openfilechannel-1.1 {TclOpenFileChannel: Check that none of the test procs are there.} { +test ioUtil-3.1 {TclOpenFileChannel: Check that none of the test procs are there.} { catch {file exists __testOpenFileChannel1%__.fil} err1 catch {file exists __testOpenFileChannel2%__.fil} err2 catch {file exists __testOpenFileChannel3%__.fil} err3 @@ -202,7 +204,7 @@ if {[info commands testopenfilechannelproc] == {}} { puts "This application hasn't been compiled with the \"testopenfilechannelproc\"" puts "command, so I can't test Tcl_OpenFileChannelInsert" } else { -test openfilechannel-1.2 {TclOpenFileChannelInsertProc: Insert the 3 test TclOpenFileChannel_ procedures.} { +test ioUtil-3.2 {TclOpenFileChannelInsertProc: Insert the 3 test TclOpenFileChannel_ procedures.} { catch {testopenfilechannelproc insert TclpOpenFileChannel} err1 testopenfilechannelproc insert TestOpenFileChannelProc1 testopenfilechannelproc insert TestOpenFileChannelProc2 @@ -210,7 +212,7 @@ test openfilechannel-1.2 {TclOpenFileChannelInsertProc: Insert the 3 test TclOpe set err1 } {bad arg "insert": must be TestOpenFileChannelProc1, TestOpenFileChannelProc2, or TestOpenFileChannelProc3} -test openfilechannel-1.3 {TclOpenFileChannel: Use "file openfilechannel ?" to invoke each procedure.} { +test ioUtil-3.3 {TclOpenFileChannel: Use "file openfilechannel ?" to invoke each procedure.} { close [open __testOpenFileChannel1%__.fil w] close [open __testOpenFileChannel2%__.fil w] close [open __testOpenFileChannel3%__.fil w] @@ -228,7 +230,7 @@ test openfilechannel-1.3 {TclOpenFileChannel: Use "file openfilechannel ?" to in set err } {} -test openfilechannel-1.4 {TclOpenFileChannelDeleteProc: "TclpOpenFileChannel" function should not be deletedable.} { +test ioUtil-3.4 {TclOpenFileChannelDeleteProc: "TclpOpenFileChannel" function should not be deletedable.} { catch {testopenfilechannelproc delete TclpOpenFileChannel} err2 set err2 } {"TclpOpenFileChannel": could not be deleteed} @@ -254,7 +256,7 @@ test openfilechannelt-1.5 {TclOpenFileChannelDeleteProc: Delete the 2nd TclOpenF set err3 } {} -test openfilechannel-1.6 {TclOpenFileChannelDeleteProc: Delete the 1st TclOpenFileChannel procedure.} { +test ioUtil-3.6 {TclOpenFileChannelDeleteProc: Delete the 1st TclOpenFileChannel procedure.} { # Next delete the 1st procedure and test that only the 3rd procedure # is the only one that exists. @@ -273,7 +275,7 @@ test openfilechannel-1.6 {TclOpenFileChannelDeleteProc: Delete the 1st TclOpenFi set err4 } {} -test openfilechannel-1.7 {TclOpenFileChannelDeleteProc: Delete the 3rd procedure & verify all are gone.} { +test ioUtil-3.7 {TclOpenFileChannelDeleteProc: Delete the 3rd procedure & verify all are gone.} { # Finally delete the 3rd procedure and check that none of the # procedures exist. @@ -287,7 +289,7 @@ test openfilechannel-1.7 {TclOpenFileChannelDeleteProc: Delete the 3rd procedure set err5 } {1} -test openfilechannel-1.8 {TclOpenFileChannelDeleteProc: Verify that all procs have been deleted.} { +test ioUtil-3.8 {TclOpenFileChannelDeleteProc: Verify that all procs have been deleted.} { # Attempt to delete all the OpenFileChannel procs. again to ensure they no longer # exist and an error is returned. @@ -298,3 +300,19 @@ test openfilechannel-1.8 {TclOpenFileChannelDeleteProc: Verify that all procs ha list $err9 $err10 $err11 } {{"TestOpenFileChannelProc1": could not be deleteed} {"TestOpenFileChannelProc2": could not be deleteed} {"TestOpenFileChannelProc3": could not be deleteed}} } + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/join.test b/tests/join.test index 1c41d53..6194c7d 100644 --- a/tests/join.test +++ b/tests/join.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: join.test,v 1.2 1998/09/14 18:40:11 stanton Exp $ +# RCS: @(#) $Id: join.test,v 1.3 1999/04/16 00:47:29 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test join-1.1 {basic join commands} { join {a b c} xyz @@ -45,4 +48,18 @@ test join-3.2 {join is binary ok} { string length [join "a\0b a\0b a\0b"] } 11 +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + diff --git a/tests/lindex.test b/tests/lindex.test index a4596c5..c7e5fb8 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: lindex.test,v 1.2 1998/09/14 18:40:11 stanton Exp $ +# RCS: @(#) $Id: lindex.test,v 1.3 1999/04/16 00:47:30 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test lindex-1.1 {basic tests} { lindex {a b c} 0} a @@ -72,3 +75,19 @@ test lindex-3.3 {quoted elements} { test lindex-3.4 {quoted elements} { lindex {a b {c d "e} {f g"}} 2 } {c d "e} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/link.test b/tests/link.test index 0878c5f..4ea079c 100644 --- a/tests/link.test +++ b/tests/link.test @@ -6,20 +6,24 @@ # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: link.test,v 1.2 1998/09/14 18:40:11 stanton Exp $ +# RCS: @(#) $Id: link.test,v 1.3 1999/04/16 00:47:30 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} 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." + ::tcltest::cleanupTests return } -if {[string compare test [info procs test]] == 1} then {source defs} - foreach i {int real bool string} { catch {unset $i} } @@ -228,7 +232,24 @@ test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} { list [catch {testlink update 47 {} {} {}} msg] $msg $int } {0 {} 47} +testlink set 0 0 0 - testlink delete foreach i {int real bool string} { catch {unset $i} } + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/linsert.test b/tests/linsert.test index 2ccce4b..5c54d92 100644 --- a/tests/linsert.test +++ b/tests/linsert.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: linsert.test,v 1.2 1998/09/14 18:40:11 stanton Exp $ +# RCS: @(#) $Id: linsert.test,v 1.3 1999/04/16 00:47:30 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {unset lis} catch {rename p ""} @@ -101,5 +104,20 @@ test linsert-3.2 {linsert won't modify shared argument objects} { linsert $lis 0 [string length $lis] } "7 a b c" +# cleanup catch {unset lis} catch {rename p ""} +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/list.test b/tests/list.test index 06a7e2f..fa83038 100644 --- a/tests/list.test +++ b/tests/list.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: list.test,v 1.2 1998/09/14 18:40:11 stanton Exp $ +# RCS: @(#) $Id: list.test,v 1.3 1999/04/16 00:47:30 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # First, a bunch of individual tests @@ -105,3 +108,19 @@ proc slowsort list { test list-3.1 {SetListFromAny and lrange/concat results} { slowsort {fred julie alex carol bill annie} } {alex annie bill carol fred julie} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/listObj.test b/tests/listObj.test index 5ea2ad4..2c9e58e 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -6,20 +6,24 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: listObj.test,v 1.2 1998/09/14 18:40:11 stanton Exp $ +# RCS: @(#) $Id: listObj.test,v 1.3 1999/04/16 00:47:30 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} 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." + ::tcltest::cleanupTests 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] @@ -27,16 +31,19 @@ test listobj-1.1 {Tcl_GetListObjType} { set result [expr {$first != -1}] } {1} -test listobj-2.1 {Tcl_ListObjForObjArray, use in lappend} { +test listobj-2.1 {Tcl_SetListObj, use in lappend} { catch {unset x} list [lappend x 1 abc def] [lappend x 1 ghi jkl] $x } {{1 abc def} {1 abc def 1 ghi jkl} {1 abc def 1 ghi jkl}} -test listobj-2.2 {Tcl_ListObjForObjArray, use in ObjInterpProc} { +test listobj-2.2 {Tcl_SetListObj, use in ObjInterpProc} { proc return_args {args} { return $args } list [return_args] [return_args x] [return_args x y] } {{} x {x y}} +test listobj-2.3 {Tcl_SetListObj, zero element count} { + list +} {} test listobj-3.1 {Tcl_ListObjAppend, list conversion} { catch {unset x} @@ -174,3 +181,19 @@ test listobj-8.1 {SetListFromAny} { test listobj-9.1 {UpdateStringOfList} { string length [list foo\x00help] } 8 + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/llength.test b/tests/llength.test index cf09b23..40c0d73 100644 --- a/tests/llength.test +++ b/tests/llength.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: llength.test,v 1.2 1998/09/14 18:40:11 stanton Exp $ +# RCS: @(#) $Id: llength.test,v 1.3 1999/04/16 00:47:30 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test llength-1.1 {length of list} { llength {a b c d} @@ -33,3 +36,19 @@ test llength-2.2 {error conditions} { test llength-2.3 {error conditions} { list [catch {llength "a b c \{"} msg] $msg } {1 {unmatched open brace in list}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/load.test b/tests/load.test index d5b27ae..8bbfb98 100644 --- a/tests/load.test +++ b/tests/load.test @@ -5,79 +5,92 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1995 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: load.test,v 1.3 1998/11/12 05:54:21 welch Exp $ +# RCS: @(#) $Id: load.test,v 1.4 1999/04/16 00:47:30 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # 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" + ::tcltest::cleanupTests return } + +# Tests require the existence of one of the DLLs in the dltest directory. 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 -} +set x [file join $testDir pkga$ext] +set dll "[file tail $x]Required" +set ::tcltest::testConfig($dll) [file readable $x] -if [string match *pkga* [set alreadyLoaded [info loaded]]] { - puts "load tests have already been run once: skipping (can't rerun)" - return -} +# Tests also require that this DLL has not already been loaded. +set loaded "[file tail $x]Loaded" +set alreadyLoaded [info loaded] +set ::tcltest::testConfig($loaded) \ + [expr {![string match *pkga* $alreadyLoaded]}] set alreadyTotalLoaded [info loaded] -test load-1.1 {basic errors} { +test load-1.1 {basic errors} [list $dll $loaded] { list [catch {load} msg] $msg } {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}} -test load-1.2 {basic errors} { +test load-1.2 {basic errors} [list $dll $loaded] { list [catch {load a b c d} msg] $msg } {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}} -test load-1.3 {basic errors} { +test load-1.3 {basic errors} [list $dll $loaded] { list [catch {load a b foobar} msg] $msg -} {1 {couldn't find slave interpreter named "foobar"}} -test load-1.4 {basic errors} { +} {1 {could not find interpreter "foobar"}} +test load-1.4 {basic errors} [list $dll $loaded] { list [catch {load {}} msg] $msg } {1 {must specify either file name or package name}} -test load-1.5 {basic errors} { +test load-1.5 {basic errors} [list $dll $loaded] { list [catch {load {} {}} msg] $msg } {1 {must specify either file name or package name}} -test load-1.6 {basic errors} { +test load-1.6 {basic errors} [list $dll $loaded] { list [catch {load {} Unknown} msg] $msg } {1 {package "Unknown" isn't loaded statically}} -test load-2.1 {basic loading, with guess for package name} { +test load-2.1 {basic loading, with guess for package name} \ + [list $dll $loaded] { 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} { +test load-2.2 {loading into a safe interpreter, with package name conversion} \ + [list $dll $loaded] { 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} { +test load-2.3 {loading with no _Init procedure} [list $dll $loaded] { 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} { +test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] { 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 +test load-3.1 {error in _Init procedure, same interpreter} \ + [list $dll $loaded] { + 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 +"if 44 {open non_existent}" + invoked from within "load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} -test load-3.2 {error in _Init procedure, slave interpreter} { +test load-3.2 {error in _Init procedure, slave interpreter} \ + [list $dll $loaded] { catch {interp delete x} interp create x set errorCode foo @@ -90,16 +103,19 @@ test load-3.2 {error in _Init procedure, slave interpreter} { while executing "open non_existent" invoked from within +"if 44 {open non_existent}" + invoked from within "load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}} -test load-4.1 {reloading package into same interpreter} { +test load-4.1 {reloading package into same interpreter} [list $dll $loaded] { list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg } {0 {}} -test load-4.2 {reloading package into same interpreter} { +test load-4.2 {reloading package into same interpreter} [list $dll $loaded] { 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} { +test load-5.1 {file name not specified and no static package: pick default} \ + [list $dll $loaded] { catch {interp delete x} interp create x load [file join $testDir pkga$ext] pkga @@ -112,49 +128,67 @@ test load-5.1 {file name not specified and no static package: pick default} { # 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} { +test load-6.1 {errors loading file} [list $dll $loaded nonPortable] { catch {load foo foo} } {1} if {[info command teststaticpkg] != ""} { - test load-7.1 {Tcl_StaticPackage procedure} { + test load-7.1 {Tcl_StaticPackage procedure} [list $dll $loaded] { 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} { + test load-7.2 {Tcl_StaticPackage procedure} [list $dll $loaded] { 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] + 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} { + test load-7.3 {Tcl_StaticPackage procedure} [list $dll $loaded] { set x "not loaded" teststaticpkg More 0 1 load {} More set x } {not loaded} - test load-7.4 {Tcl_StaticPackage procedure, redundant calls} { + test load-7.4 {Tcl_StaticPackage procedure, redundant calls} \ + [list $dll $loaded] { 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} { + test load-8.1 {TclGetLoadedPackages procedure} [list $dll $loaded] { 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} { + test load-8.2 {TclGetLoadedPackages procedure} [list $dll $loaded] { list [catch {info loaded gorp} msg] $msg - } {1 {couldn't find slave interpreter named "gorp"}} - test load-8.3 {TclGetLoadedPackages procedure} { + } {1 {could not find interpreter "gorp"}} + test load-8.3 {TclGetLoadedPackages procedure} [list $dll $loaded] { 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} { + test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded] { 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 } + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/lrange.test b/tests/lrange.test index 1691eb4..4132969 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: lrange.test,v 1.2 1998/09/14 18:40:11 stanton Exp $ +# RCS: @(#) $Id: lrange.test,v 1.3 1999/04/16 00:47:30 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test lrange-1.1 {range of list elements} { lrange {a b c d} 1 2 @@ -81,3 +84,19 @@ test lrange-2.5 {error conditions} { test lrange-2.6 {error conditions} { list [catch {lrange "a b c \{ d e" 1 4} msg] $msg } {1 {unmatched open brace in list}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/lreplace.test b/tests/lreplace.test index 0aed5d5..d0743eb 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: lreplace.test,v 1.2 1998/09/14 18:40:11 stanton Exp $ +# RCS: @(#) $Id: lreplace.test,v 1.3 1999/04/16 00:47:30 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test lreplace-1.1 {lreplace command} { lreplace {1 2 3 4 5} 0 0 a @@ -128,4 +131,19 @@ test lreplace-3.1 {lreplace won't modify shared argument objects} { p } "a b c" +# cleanup catch {unset foo} +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/lsearch.test b/tests/lsearch.test index 8d066c4..498607b 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: lsearch.test,v 1.2 1998/09/14 18:40:12 stanton Exp $ +# RCS: @(#) $Id: lsearch.test,v 1.3 1999/04/16 00:47:30 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} set x {abcd bbcd 123 234 345} test lsearch-1.1 {lsearch command} { @@ -45,7 +48,7 @@ test lsearch-2.5 {search modes} { } 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}} +} {1 {couldn't compile regular expression pattern: quantifier operand invalid}} test lsearch-2.7 {search modes} { lsearch -regexp {b.x ^bc xy bcx} ^bc } 3 @@ -84,3 +87,19 @@ test lsearch-4.2 {binary data} { append x two lsearch -exact [list foo one\000two bar] $x } 1 + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/macFCmd.test b/tests/macFCmd.test index 17d6f89..bbb5df8 100644 --- a/tests/macFCmd.test +++ b/tests/macFCmd.test @@ -5,164 +5,204 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: macFCmd.test,v 1.2 1998/09/14 18:40:12 stanton Exp $ +# RCS: @(#) $Id: macFCmd.test,v 1.3 1999/04/16 00:47:30 stanton Exp $ # -if {$tcl_platform(platform) != "macintosh"} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } -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 + set ::tcltest::testConfig(fileSharing) 0 + set ::tcltest::testConfig(notFileSharing) 1 } else { - set testConfig(fileSharing) 1 - set testConfig(notFileSharing) 0 + set ::tcltest::testConfig(fileSharing) 1 + set ::tcltest::testConfig(notFileSharing) 0 } file delete -force foo.dir -test macFCmd-1.1 {GetFileFinderAttributes - no file} { +test macFCmd-1.1 {GetFileFinderAttributes - no file} {macOnly} { 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} { +test macFCmd-1.2 {GetFileFinderAttributes - creator} {macOnly} { 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] + list [catch {file attributes foo.file -creator} msg] $msg \ + [file delete -force foo.file] } {0 {MPW } {}} -test macFCmd-1.3 {GetFileFinderAttributes - type} { +test macFCmd-1.3 {GetFileFinderAttributes - type} {macOnly} { 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] + list [catch {file attributes foo.file -type} msg] $msg \ + [file delete -force foo.file] } {0 TEXT {}} -test macFCmd-1.4 {GetFileFinderAttributes - not hidden} { +test macFCmd-1.4 {GetFileFinderAttributes - not hidden} {macOnly} { 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] + list [catch {file attributes foo.file -hidden} msg] $msg \ + [file delete -force foo.file] } {0 0 {}} -test macFCmd-1.5 {GetFileFinderAttributes - hidden} { +test macFCmd-1.5 {GetFileFinderAttributes - hidden} {macOnly} { 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] + list [catch {file attributes foo.file -hidden} msg] $msg \ + [file delete -force foo.file] } {0 1 {}} -test macFCmd-1.6 {GetFileFinderAttributes - folder creator} { +test macFCmd-1.6 {GetFileFinderAttributes - folder creator} {macOnly} { catch {file delete -force foo.dir} file mkdir foo.dir - list [catch {file attributes foo.dir -creator} msg] $msg [file delete -force 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} { +test macFCmd-1.7 {GetFileFinderAttributes - folder type} {macOnly} { catch {file delete -force foo.dir} file mkdir foo.dir - list [catch {file attributes foo.dir -type} msg] $msg [file delete -force 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} { +test macFCmd-1.8 {GetFileFinderAttributes - folder hidden} {macOnly} { catch {file delete -force foo.dir} file mkdir foo.dir - list [catch {file attributes foo.dir -hidden} msg] $msg [file delete -force 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} { +test macFCmd-2.1 {GetFileReadOnly - bad file} {macOnly} { 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} { +test macFCmd-2.2 {GetFileReadOnly - file not read only} {macOnly} { 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] + list [catch {file attributes foo.file -readonly} msg] $msg \ + [file delete -force foo.file] } {0 0 {}} -test macFCmd-2.3 {GetFileReadOnly - file read only} { +test macFCmd-2.3 {GetFileReadOnly - file read only} {macOnly} { 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] + 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} { +test macFCmd-2.4 {GetFileReadOnly - directory not read only} {macOnly} { catch {file delete -force foo.dir} file mkdir foo.dir - list [catch {file attributes foo.dir -readonly} msg] $msg [file delete -force 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} { +test macFCmd-2.5 {GetFileReadOnly - directory read only} {macOnly 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] + list [catch {file attributes foo.dir -readonly} msg] $msg \ + [file delete -force foo.dir] } {0 1 {}} -test macFCmd-3.1 {SetFileFinderAttributes - bad file} { +test macFCmd-3.1 {SetFileFinderAttributes - bad file} {macOnly} { 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} { +test macFCmd-3.2 {SetFileFinderAttributes - creator} {macOnly} { 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] + 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} { +test macFCmd-3.3 {SetFileFinderAttributes - bad creator} {macOnly} { 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] + 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} { +test macFCmd-3.4 {SetFileFinderAttributes - hidden} {macOnly} { 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] + 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} { +test macFCmd-3.5 {SetFileFinderAttributes - type} {macOnly} { 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] + 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} { +test macFCmd-3.6 {SetFileFinderAttributes - bad type} {macOnly} { 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] + 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} { +test macFCmd-3.7 {SetFileFinderAttributes - directory} {macOnly} { 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] + 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} { +test macFCmd-4.1 {SetFileReadOnly - bad file} {macOnly} { 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} { +test macFCmd-4.2 {SetFileReadOnly - file not readonly} {macOnly} { 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] + 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} { +test macFCmd-4.3 {SetFileReadOnly - file readonly} {macOnly} { 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] + 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} { +test macFCmd-4.4 {SetFileReadOnly - directory not readonly} \ + {macOnly 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] + 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} { +test macFCmd-4.5 {SetFileReadOnly - directory not readonly} \ + {macOnly 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] + 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} { +test macFCmd-4.6 {SetFileReadOnly - directory readonly} {macOnly 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] + 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} { +test macFCmd-4.7 {SetFileReadOnly - directory readonly} {macOnly 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] + 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} {}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/misc.test b/tests/misc.test index 6106ce8..67c2216 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -7,13 +7,16 @@ # # Copyright (c) 1992-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: misc.test,v 1.2 1998/09/14 18:40:12 stanton Exp $ +# RCS: @(#) $Id: misc.test,v 1.3 1999/04/16 00:47:30 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test misc-1.1 {error in variable ref. in command in array reference} { proc tstProc {} { @@ -48,4 +51,25 @@ test misc-1.2 {error in variable ref. in command in array reference} { " set msg {} list [catch tstProc msg] $msg $errorInfo -} {1 {missing close-bracket or close-brace} missing\ close-bracket\ or\ close-brace\n\ \ \ \ while\ compiling\n\"set\ tst\ \$a(\[winfo\ name\ \$\{zz)\"\n\ \ \ \ (compiling\ body\ of\ proc\ \"tstProc\",\ line\ 4)\n\ \ \ \ invoked\ from\ within\n\"tstProc\"} +} {1 {missing close-brace for variable name} {missing close-brace for variable name + while compiling +"set tst $a([winfo name " + (compiling body of proc "tstProc", line 4) + invoked from within +"tstProc"}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/msgcat.test b/tests/msgcat.test new file mode 100644 index 0000000..b9410e2 --- /dev/null +++ b/tests/msgcat.test @@ -0,0 +1,318 @@ +# Commands covered: ::msgcat::mc ::msgcat::mclocale +# ::msgcat::mcpreferences ::msgcat::mcload +# ::msgcat::mcset ::msgcat::mcunknown +# +# This file contains a collection of tests for the msgcat script library. +# Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998 Mark Harrison. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: msgcat.test,v 1.2 1999/04/16 00:47:31 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {[catch {package require msgcat 1.0}]} { + if {[info exist msgcat1]} { + catch {puts "Cannot load msgcat 1.0 package"} + return + } else { + catch {puts "Running msgcat 1.0 tests in slave interp"} + set interp [interp create msgcat1] + $interp eval [list set msgcat1 "running"] + $interp eval [list source [info script]] + interp delete $interp + return + } +} + +set oldlocale [::msgcat::mclocale] + +# +# Test the various permutations of mclocale +# and mcpreferences. +# + +test msgcat-1.1 {::msgcat::mclocale default} { + ::msgcat::mclocale +} {c} +test msgcat-1.2 {::msgcat::mcpreferences, single element} { + ::msgcat::mcpreferences +} {c} +test msgcat-1.3 {::msgcat::mclocale, single element} { + ::msgcat::mclocale en +} {en} +test msgcat-1.4 {::msgcat::mclocale, single element} { + ::msgcat::mclocale +} {en} +test msgcat-1.5 {::msgcat::mcpreferences, single element} { + ::msgcat::mcpreferences +} {en} +test msgcat-1.6 {::msgcat::mclocale, two elements} { + ::msgcat::mclocale en_US +} {en_us} +test msgcat-1.7 {::msgcat::mclocale, two elements} { + ::msgcat::mclocale en_US + ::msgcat::mclocale +} {en_us} +test msgcat-1.8 {::msgcat::mcpreferences, two elements} { + ::msgcat::mcpreferences +} {en_us en} +test msgcat-1.9 {::msgcat::mclocale, three elements} { + ::msgcat::mclocale en_US_funky +} {en_us_funky} +test msgcat-1.10 {::msgcat::mclocale, three elements} { + ::msgcat::mclocale +} {en_us_funky} +test msgcat-1.11 {::msgcat::mcpreferences, three elements} { + ::msgcat::mcpreferences +} {en_us_funky en_us en} + +# +# Test mcset and mcc, ensuring that namespace partitioning +# is working. +# + +test msgcat-2.1 {::msgcat::mcset, global scope} { + ::msgcat::mcset foo_BAR text1 text2 +} {text2} +test msgcat-2.2 {::msgcat::mcset, global scope, default} { + ::msgcat::mcset foo_BAR text3 +} {text3} +test msgcat-2.2 {::msgcat::mcset, namespace overlap} { + namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar} + namespace eval baz {::msgcat::mcset foo_BAR con1 con1baz} +} {con1baz} +test msgcat-2.3 {::msgcat::mcset, namespace overlap} { + ::msgcat::mclocale foo_BAR + namespace eval bar {::msgcat::mc con1} +} {con1bar} +test msgcat-2.4 {::msgcat::mcset, namespace overlap} { + ::msgcat::mclocale foo_BAR + namespace eval baz {::msgcat::mc con1} +} {con1baz} + +# +# Test mcset and mc, ensuring that more specific locales +# (e.g. "en_UK") will search less specific locales +# (e.g. "en") for translation strings. +# +# Do this for the 12 permutations of +# locales: {foo foo_BAR foo_BAR_baz} +# strings: {ov1 ov2 ov3 ov4} +# locale foo defines ov1, ov2, ov3 +# locale foo_BAR defines ov2, ov3 +# locale foo_BAR_BAZ defines ov3 +# (ov4 is defined in none) +# So, +# ov3 should be resolved in foo, foo_BAR, foo_BAR_baz +# ov2 should be resolved in foo, foo_BAR +# ov2 should resolve to foo_BAR in foo_BAR_baz +# ov1 should be resolved in foo +# ov1 should resolve to foo in foo_BAR, foo_BAR_baz +# ov4 should be resolved in none, and call mcunknown +# + +test msgcat-3.1 {::msgcat::mcset, overlap} { + ::msgcat::mcset foo ov1 ov1_foo + ::msgcat::mcset foo ov2 ov2_foo + ::msgcat::mcset foo ov3 ov3_foo + ::msgcat::mcset foo_BAR ov2 ov2_foo_BAR + ::msgcat::mcset foo_BAR ov3 ov3_foo_BAR + ::msgcat::mcset foo_BAR_baz ov3 ov3_foo_BAR_baz +} {ov3_foo_BAR_baz} +# top level, locale foo +test msgcat-3.2 {::msgcat::mcset, overlap} { + ::msgcat::mclocale foo + ::msgcat::mc ov1 +} {ov1_foo} +test msgcat-3.3 {::msgcat::mcset, overlap} { + ::msgcat::mclocale foo + ::msgcat::mc ov2 +} {ov2_foo} +test msgcat-3.4 {::msgcat::mcset, overlap} { + ::msgcat::mclocale foo + ::msgcat::mc ov3 +} {ov3_foo} +test msgcat-3.5 {::msgcat::mcset, overlap} { + ::msgcat::mclocale foo + ::msgcat::mc ov4 +} {ov4} +# second level, locale foo_BAR +test msgcat-3.6 {::msgcat::mcset, overlap} { + ::msgcat::mclocale foo_BAR + ::msgcat::mc ov1 +} {ov1_foo} +test msgcat-3.7 {::msgcat::mcset, overlap} { + ::msgcat::mclocale foo_BAR + ::msgcat::mc ov2 +} {ov2_foo_BAR} +test msgcat-3.8 {::msgcat::mcset, overlap} { + ::msgcat::mclocale foo_BAR + ::msgcat::mc ov3 +} {ov3_foo_BAR} +test msgcat-3.9 {::msgcat::mcset, overlap} { + ::msgcat::mclocale foo_BAR + ::msgcat::mc ov4 +} {ov4} +# third level, locale foo_BAR_baz +test msgcat-3.10 {::msgcat::mcset, overlap} { + ::msgcat::mclocale foo_BAR_baz + ::msgcat::mc ov1 +} {ov1_foo} +test msgcat-3.11 {::msgcat::mcset, overlap} { + ::msgcat::mclocale foo_BAR_baz + ::msgcat::mc ov2 +} {ov2_foo_BAR} +test msgcat-3.12 {::msgcat::mcset, overlap} { + ::msgcat::mclocale foo_BAR_baz + ::msgcat::mc ov3 +} {ov3_foo_BAR_baz} +test msgcat-3.13 {::msgcat::mcset, overlap} { + ::msgcat::mclocale foo_BAR_baz + ::msgcat::mc ov4 +} {ov4} + +# +# Test mcunknown, first the default operation +# and then with an overridden definition. +# + +test msgcat-4.1 {::msgcat::mcunknown, default} { + ::msgcat::mcset foo unk1 "unknown 1" +} {unknown 1} +test msgcat-4.2 {::msgcat::mcunknown, default} { + ::msgcat::mclocale foo + ::msgcat::mc unk1 +} {unknown 1} +test msgcat-4.3 {::msgcat::mcunknown, default} { + ::msgcat::mclocale foo + ::msgcat::mc unk2 +} {unk2} +test msgcat-4.4 {::msgcat::mcunknown, overridden} { + rename ::msgcat::mcunknown oldproc + proc ::msgcat::mcunknown {dom s} { + return "unknown:$dom:$s" + } + ::msgcat::mclocale foo + set result [::msgcat::mc unk1] + rename ::msgcat::mcunknown {} + rename oldproc ::msgcat::mcunknown + set result +} {unknown 1} +test msgcat-4.5 {::msgcat::mcunknown, overridden} { + rename ::msgcat::mcunknown oldproc + proc ::msgcat::mcunknown {dom s} { + return "unknown:$dom:$s" + } + ::msgcat::mclocale foo + set result [::msgcat::mc unk2] + rename ::msgcat::mcunknown {} + rename oldproc ::msgcat::mcunknown + set result +} {unknown:foo:unk2} +test msgcat-4.6 {::msgcat::mcunknown, uplevel context} { + rename ::msgcat::mcunknown oldproc + proc ::msgcat::mcunknown {dom s} { + return "unknown:$dom:$s:[info level]" + } + ::msgcat::mclocale foo + set result [::msgcat::mc unk2] + rename ::msgcat::mcunknown {} + rename oldproc ::msgcat::mcunknown + set result +} {unknown:foo:unk2:1} + + +# +# Test mcload. Need to set up an environment for +# these tests by creating a temporary directory and +# message files. +# + +set locales {en en_US en_US_funky} + +catch {file mkdir msgdir} +foreach l $locales { + set fd [open [string tolower [file join msgdir $l.msg]] w] + puts $fd "::msgcat::mcset $l abc abc-$l" + close $fd +} + +test msgcat-5.1 {::msgcat::mcload} { + ::msgcat::mclocale en + ::msgcat::mcload msgdir +} {1} +test msgcat-5.2 {::msgcat::mcload} { + ::msgcat::mclocale en_US + ::msgcat::mcload msgdir +} {2} +test msgcat-5.3 {::msgcat::mcload} { + ::msgcat::mclocale en_US_funky + ::msgcat::mcload msgdir +} {3} + +# Even though en_US_notexist does not exist, +# en_US and en should be loaded. + +test msgcat-5.4 {::msgcat::mcload} { + ::msgcat::mclocale en_US_notexist + ::msgcat::mcload msgdir +} {2} +test msgcat-5.5 {::msgcat::mcload} { + ::msgcat::mclocale no_FI_notexist + ::msgcat::mcload msgdir +} {0} +test msgcat-5.6 {::msgcat::mcload} { + ::msgcat::mclocale en + ::msgcat::mc abc +} {abc-en} +test msgcat-5.7 {::msgcat::mcload} { + ::msgcat::mclocale en_US + ::msgcat::mc abc +} {abc-en_US} +test msgcat-5.8 {::msgcat::mcload} { + ::msgcat::mclocale en_US_funky + ::msgcat::mc abc +} {abc-en_US_funky} +test msgcat-5.9 {::msgcat::mcload} { + rename ::msgcat::mcunknown oldproc + proc ::msgcat::mcunknown {dom s} { + return "unknown:$dom:$s" + } + ::msgcat::mclocale no_FI_notexist + set result [::msgcat::mc abc] + rename ::msgcat::mcunknown {} + rename oldproc ::msgcat::mcunknown + set result +} {unknown:no_fi_notexist:abc} + +# cleanup +foreach l $locales { + file delete [string tolower [file join msgdir $l.msg]] +} + +# Clean out the msg catalogs +::msgcat::mclocale $oldlocale +file delete msgdir + +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 7efa6c1..d8a736e 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -9,13 +9,16 @@ # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1997 Lucent Technologies +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: namespace-old.test,v 1.2 1998/09/14 18:40:12 stanton Exp $ +# RCS: @(#) $Id: namespace-old.test,v 1.3 1999/04/16 00:47:31 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # Clear out any namespaces called test_ns_* catch {eval namespace delete [namespace children :: test_ns_*]} @@ -842,3 +845,19 @@ catch {unset x} catch {unset test_ns_var_global} catch {unset cmd} eval namespace delete [namespace children :: test_ns_*] + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/namespace.test b/tests/namespace.test index 93add66..54f1149 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -6,13 +6,16 @@ # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: namespace.test,v 1.3 1998/09/14 18:40:12 stanton Exp $ +# RCS: @(#) $Id: namespace.test,v 1.4 1999/04/16 00:47:31 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # Clear out any namespaces called test_ns_* catch {eval namespace delete [namespace children :: test_ns_*]} @@ -1090,8 +1093,23 @@ test namespace-38.1 {UpdateStringOfNsName} { [namespace eval {} {namespace current}] } {:: ::} +# cleanup catch {rename cmd1 {}} catch {unset l} catch {unset msg} catch {unset trigger} eval namespace delete [namespace children :: test_ns_*] +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/obj.test b/tests/obj.test index b4b7672..ce7738d 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -6,20 +6,24 @@ # errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: obj.test,v 1.2 1998/09/14 18:40:12 stanton Exp $ +# RCS: @(#) $Id: obj.test,v 1.3 1999/04/16 00:47:31 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} 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." + ::tcltest::cleanupTests 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} { @@ -83,31 +87,55 @@ test obj-6.2 {Tcl_DuplicateObj, "empty string" object} { lappend result [testobj refcount 2] } {{} {} {} {} 2 3} -test obj-7.1 {Tcl_GetStringFromObj, return existing string rep} { +test obj-7.1 {Tcl_GetString, return existing string rep} { + set result "" + lappend result [testintobj set 1 47] + lappend result [testintobj get2 1] +} {47 47} +test obj-7.2 {Tcl_GetString, "empty string" object} { + set result "" + lappend result [testobj newobj 1] + lappend result [teststringobj append 1 abc -1] + lappend result [teststringobj get2 1] +} {{} abc abc} +test obj-7.3 {Tcl_GetString, returns string internal rep (DString)} { + set result "" + lappend result [teststringobj set 1 xyz] + lappend result [teststringobj append 1 abc -1] + lappend result [teststringobj get2 1] +} {xyz xyzabc xyzabc} +test obj-7.4 {Tcl_GetString, recompute string rep from internal rep} { + set result "" + lappend result [testintobj set 1 77] + lappend result [testintobj mult10 1] + lappend result [teststringobj get2 1] +} {77 770 770} + +test obj-8.1 {Tcl_GetStringFromObj, return existing string rep} { set result "" lappend result [testintobj set 1 47] lappend result [testintobj get 1] } {47 47} -test obj-7.2 {Tcl_GetStringFromObj, "empty string" object} { +test obj-8.2 {Tcl_GetStringFromObj, "empty string" object} { set result "" lappend result [testobj newobj 1] lappend result [teststringobj append 1 abc -1] lappend result [teststringobj get 1] } {{} abc abc} -test obj-7.3 {Tcl_GetStringFromObj, returns string internal rep (DString)} { +test obj-8.3 {Tcl_GetStringFromObj, returns string internal rep (DString)} { set result "" lappend result [teststringobj set 1 xyz] lappend result [teststringobj append 1 abc -1] lappend result [teststringobj get 1] } {xyz xyzabc xyzabc} -test obj-7.4 {Tcl_GetStringFromObj, recompute string rep from internal rep} { +test obj-8.4 {Tcl_GetStringFromObj, recompute string rep from internal rep} { set result "" lappend result [testintobj set 1 77] lappend result [testintobj mult10 1] lappend result [teststringobj get 1] } {77 770 770} -test obj-8.1 {Tcl_NewBooleanObj} { +test obj-9.1 {Tcl_NewBooleanObj} { set result "" lappend result [testobj freeallvars] lappend result [testbooleanobj set 1 0] @@ -115,7 +143,7 @@ test obj-8.1 {Tcl_NewBooleanObj} { lappend result [testobj refcount 1] } {{} 0 boolean 2} -test obj-9.1 {Tcl_SetBooleanObj, existing "empty string" object} { +test obj-10.1 {Tcl_SetBooleanObj, existing "empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -123,7 +151,7 @@ test obj-9.1 {Tcl_SetBooleanObj, existing "empty string" object} { lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 0 boolean 2} -test obj-9.2 {Tcl_SetBooleanObj, existing non-"empty string" object} { +test obj-10.2 {Tcl_SetBooleanObj, existing non-"empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 98765] @@ -132,50 +160,50 @@ test obj-9.2 {Tcl_SetBooleanObj, existing non-"empty string" object} { lappend result [testobj refcount 1] } {{} 98765 1 boolean 2} -test obj-10.1 {Tcl_GetBooleanFromObj, existing boolean object} { +test obj-11.1 {Tcl_GetBooleanFromObj, existing boolean object} { set result "" lappend result [testbooleanobj set 1 1] lappend result [testbooleanobj not 1] ;# gets existing boolean rep } {1 0} -test obj-10.2 {Tcl_GetBooleanFromObj, convert to boolean} { +test obj-11.2 {Tcl_GetBooleanFromObj, convert to boolean} { set result "" lappend result [testintobj set 1 47] lappend result [testbooleanobj not 1] ;# must convert to bool lappend result [testobj type 1] } {47 0 boolean} -test obj-10.3 {Tcl_GetBooleanFromObj, error converting to boolean} { +test obj-11.3 {Tcl_GetBooleanFromObj, error converting to boolean} { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {abc 1 {expected boolean value but got "abc"}} -test obj-10.4 {Tcl_GetBooleanFromObj, error converting from "empty string"} { +test obj-11.4 {Tcl_GetBooleanFromObj, error converting from "empty string"} { set result "" lappend result [testobj newobj 1] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {{} 1 {expected boolean value but got ""}} -test obj-11.1 {DupBooleanInternalRep} { +test obj-12.1 {DupBooleanInternalRep} { set result "" lappend result [testbooleanobj set 1 1] lappend result [testobj duplicate 1 2] ;# uses DupBooleanInternalRep lappend result [testbooleanobj get 2] } {1 1 1} -test obj-12.1 {SetBooleanFromAny, int to boolean special case} { +test obj-13.1 {SetBooleanFromAny, int to boolean special case} { set result "" lappend result [testintobj set 1 1234] lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny lappend result [testobj type 1] } {1234 0 boolean} -test obj-12.2 {SetBooleanFromAny, double to boolean special case} { +test obj-13.2 {SetBooleanFromAny, double to boolean special case} { set result "" lappend result [testdoubleobj set 1 3.14159] lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny lappend result [testobj type 1] } {3.14159 0 boolean} -test obj-12.3 {SetBooleanFromAny, special case strings representing booleans} { +test obj-13.3 {SetBooleanFromAny, special case strings representing booleans} { set result "" foreach s {yes no true false on off} { teststringobj set 1 $s @@ -183,40 +211,46 @@ test obj-12.3 {SetBooleanFromAny, special case strings representing booleans} { } lappend result [testobj type 1] } {0 1 0 1 0 1 boolean} -test obj-12.4 {SetBooleanFromAny, recompute string rep then parse it} { +test obj-13.4 {SetBooleanFromAny, recompute string rep then parse it} { set result "" lappend result [testintobj set 1 456] lappend result [testintobj div10 1] lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny lappend result [testobj type 1] } {456 45 0 boolean} -test obj-12.5 {SetBooleanFromAny, error parsing string} { +test obj-13.5 {SetBooleanFromAny, error parsing string} { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {abc 1 {expected boolean value but got "abc"}} -test obj-12.6 {SetBooleanFromAny, error parsing string} { +test obj-13.6 {SetBooleanFromAny, error parsing string} { set result "" lappend result [teststringobj set 1 x1.0] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {x1.0 1 {expected boolean value but got "x1.0"}} -test obj-12.7 {SetBooleanFromAny, error converting from "empty string"} { +test obj-13.7 {SetBooleanFromAny, error converting from "empty string"} { set result "" lappend result [testobj newobj 1] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {{} 1 {expected boolean value but got ""}} +test obj-13.8 {SetBooleanFromAny, unicode strings} { + set result "" + lappend result [teststringobj set 1 1\u7777] + lappend result [catch {testbooleanobj not 1} msg] + lappend result $msg +} "1\u7777 1 {expected boolean value but got \"1\u7777\"}" -test obj-13.1 {UpdateStringOfBoolean} { +test obj-14.1 {UpdateStringOfBoolean} { set result "" lappend result [testbooleanobj set 1 0] lappend result [testbooleanobj not 1] lappend result [testbooleanobj get 1] ;# must update string rep } {0 1 1} -test obj-14.1 {Tcl_NewDoubleObj} { +test obj-15.1 {Tcl_NewDoubleObj} { set result "" lappend result [testobj freeallvars] lappend result [testdoubleobj set 1 3.1459] @@ -224,7 +258,7 @@ test obj-14.1 {Tcl_NewDoubleObj} { lappend result [testobj refcount 1] } {{} 3.1459 double 2} -test obj-15.1 {Tcl_SetDoubleObj, existing "empty string" object} { +test obj-16.1 {Tcl_SetDoubleObj, existing "empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -232,7 +266,7 @@ test obj-15.1 {Tcl_SetDoubleObj, existing "empty string" object} { lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 0.123 double 2} -test obj-15.2 {Tcl_SetDoubleObj, existing non-"empty string" object} { +test obj-16.2 {Tcl_SetDoubleObj, existing non-"empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 98765] @@ -241,83 +275,83 @@ test obj-15.2 {Tcl_SetDoubleObj, existing non-"empty string" object} { lappend result [testobj refcount 1] } {{} 98765 27.56 double 2} -test obj-16.1 {Tcl_GetDoubleFromObj, existing double object} { +test obj-17.1 {Tcl_GetDoubleFromObj, existing double object} { set result "" lappend result [testdoubleobj set 1 16.1] lappend result [testdoubleobj mult10 1] ;# gets existing double rep } {16.1 161.0} -test obj-16.2 {Tcl_GetDoubleFromObj, convert to double} { +test obj-17.2 {Tcl_GetDoubleFromObj, convert to double} { set result "" lappend result [testintobj set 1 477] lappend result [testdoubleobj div10 1] ;# must convert to bool lappend result [testobj type 1] } {477 47.7 double} -test obj-16.3 {Tcl_GetDoubleFromObj, error converting to double} { +test obj-17.3 {Tcl_GetDoubleFromObj, error converting to double} { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testdoubleobj mult10 1} msg] lappend result $msg } {abc 1 {expected floating-point number but got "abc"}} -test obj-16.4 {Tcl_GetDoubleFromObj, error converting from "empty string"} { +test obj-17.4 {Tcl_GetDoubleFromObj, error converting from "empty string"} { set result "" lappend result [testobj newobj 1] lappend result [catch {testdoubleobj div10 1} msg] lappend result $msg } {{} 1 {expected floating-point number but got ""}} -test obj-17.1 {DupDoubleInternalRep} { +test obj-18.1 {DupDoubleInternalRep} { set result "" lappend result [testdoubleobj set 1 17.1] lappend result [testobj duplicate 1 2] ;# uses DupDoubleInternalRep lappend result [testdoubleobj get 2] } {17.1 17.1 17.1} -test obj-18.1 {SetDoubleFromAny, int to double special case} { +test obj-19.1 {SetDoubleFromAny, int to double special case} { set result "" lappend result [testintobj set 1 1234] lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny lappend result [testobj type 1] } {1234 12340.0 double} -test obj-18.2 {SetDoubleFromAny, boolean to double special case} { +test obj-19.2 {SetDoubleFromAny, boolean to double special case} { set result "" lappend result [testbooleanobj set 1 1] lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny lappend result [testobj type 1] } {1 10.0 double} -test obj-18.3 {SetDoubleFromAny, recompute string rep then parse it} { +test obj-19.3 {SetDoubleFromAny, recompute string rep then parse it} { set result "" lappend result [testintobj set 1 456] lappend result [testintobj div10 1] lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny lappend result [testobj type 1] } {456 45 450.0 double} -test obj-18.4 {SetDoubleFromAny, error parsing string} { +test obj-19.4 {SetDoubleFromAny, error parsing string} { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testdoubleobj mult10 1} msg] lappend result $msg } {abc 1 {expected floating-point number but got "abc"}} -test obj-18.5 {SetDoubleFromAny, error parsing string} { +test obj-19.5 {SetDoubleFromAny, error parsing string} { set result "" lappend result [teststringobj set 1 x1.0] lappend result [catch {testdoubleobj mult10 1} msg] lappend result $msg } {x1.0 1 {expected floating-point number but got "x1.0"}} -test obj-18.6 {SetDoubleFromAny, error converting from "empty string"} { +test obj-19.6 {SetDoubleFromAny, error converting from "empty string"} { set result "" lappend result [testobj newobj 1] lappend result [catch {testdoubleobj div10 1} msg] lappend result $msg } {{} 1 {expected floating-point number but got ""}} -test obj-19.1 {UpdateStringOfDouble} { +test obj-20.1 {UpdateStringOfDouble} { set result "" lappend result [testdoubleobj set 1 3.14159] lappend result [testdoubleobj mult10 1] lappend result [testdoubleobj get 1] ;# must update string rep } {3.14159 31.4159 31.4159} -test obj-20.1 {Tcl_NewIntObj} { +test obj-21.1 {Tcl_NewIntObj} { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 55] @@ -325,7 +359,7 @@ test obj-20.1 {Tcl_NewIntObj} { lappend result [testobj refcount 1] } {{} 55 int 2} -test obj-21.1 {Tcl_SetIntObj, existing "empty string" object} { +test obj-22.1 {Tcl_SetIntObj, existing "empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -333,7 +367,7 @@ test obj-21.1 {Tcl_SetIntObj, existing "empty string" object} { lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 77 int 2} -test obj-21.2 {Tcl_SetIntObj, existing non-"empty string" object} { +test obj-22.2 {Tcl_SetIntObj, existing non-"empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testdoubleobj set 1 12.34] @@ -342,94 +376,94 @@ test obj-21.2 {Tcl_SetIntObj, existing non-"empty string" object} { lappend result [testobj refcount 1] } {{} 12.34 77 int 2} -test obj-22.1 {Tcl_GetIntFromObj, existing int object} { +test obj-23.1 {Tcl_GetIntFromObj, existing int object} { set result "" lappend result [testintobj set 1 22] lappend result [testintobj mult10 1] ;# gets existing int rep } {22 220} -test obj-22.2 {Tcl_GetIntFromObj, convert to int} { +test obj-23.2 {Tcl_GetIntFromObj, convert to int} { set result "" lappend result [testintobj set 1 477] lappend result [testintobj div10 1] ;# must convert to bool lappend result [testobj type 1] } {477 47 int} -test obj-22.3 {Tcl_GetIntFromObj, error converting to int} { +test obj-23.3 {Tcl_GetIntFromObj, error converting to int} { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {abc 1 {expected integer but got "abc"}} -test obj-22.4 {Tcl_GetIntFromObj, error converting from "empty string"} { +test obj-23.4 {Tcl_GetIntFromObj, error converting from "empty string"} { set result "" lappend result [testobj newobj 1] lappend result [catch {testintobj div10 1} msg] lappend result $msg } {{} 1 {expected integer but got ""}} -test obj-22.5 {Tcl_GetIntFromObj, integer too large to represent as non-long error} {nonPortable} { +test obj-23.5 {Tcl_GetIntFromObj, integer too large to represent as non-long error} {nonPortable} { set result "" lappend result [testobj newobj 1] lappend result [testintobj inttoobigtest 1] } {{} 1} -test obj-23.1 {DupIntInternalRep} { +test obj-24.1 {DupIntInternalRep} { set result "" lappend result [testintobj set 1 23] lappend result [testobj duplicate 1 2] ;# uses DupIntInternalRep lappend result [testintobj get 2] } {23 23 23} -test obj-24.1 {SetIntFromAny, int to int special case} { +test obj-25.1 {SetIntFromAny, int to int special case} { set result "" lappend result [testintobj set 1 1234] lappend result [testintobj mult10 1] ;# converts with SetIntFromAny lappend result [testobj type 1] } {1234 12340 int} -test obj-24.2 {SetIntFromAny, boolean to int special case} { +test obj-25.2 {SetIntFromAny, boolean to int special case} { set result "" lappend result [testbooleanobj set 1 1] lappend result [testintobj mult10 1] ;# converts with SetIntFromAny lappend result [testobj type 1] } {1 10 int} -test obj-24.3 {SetIntFromAny, recompute string rep then parse it} { +test obj-25.3 {SetIntFromAny, recompute string rep then parse it} { set result "" lappend result [testintobj set 1 456] lappend result [testintobj div10 1] lappend result [testintobj mult10 1] ;# converts with SetIntFromAny lappend result [testobj type 1] } {456 45 450 int} -test obj-24.4 {SetIntFromAny, error parsing string} { +test obj-25.4 {SetIntFromAny, error parsing string} { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {abc 1 {expected integer but got "abc"}} -test obj-24.5 {SetIntFromAny, error parsing string} { +test obj-25.5 {SetIntFromAny, error parsing string} { set result "" lappend result [teststringobj set 1 x17] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {x17 1 {expected integer but got "x17"}} -test obj-24.6 {SetIntFromAny, integer too large} {nonPortable} { +test obj-25.6 {SetIntFromAny, integer too large} {nonPortable} { set result "" lappend result [teststringobj set 1 123456789012345678901] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {123456789012345678901 1 {integer value too large to represent}} -test obj-24.7 {SetIntFromAny, error converting from "empty string"} { +test obj-25.7 {SetIntFromAny, error converting from "empty string"} { set result "" lappend result [testobj newobj 1] lappend result [catch {testintobj div10 1} msg] lappend result $msg } {{} 1 {expected integer but got ""}} -test obj-25.1 {UpdateStringOfInt} { +test obj-26.1 {UpdateStringOfInt} { set result "" lappend result [testintobj set 1 512] lappend result [testintobj mult10 1] lappend result [testintobj get 1] ;# must update string rep } {512 5120 5120} -test obj-26.1 {Tcl_NewLongObj} { +test obj-27.1 {Tcl_NewLongObj} { set result "" lappend result [testobj freeallvars] testintobj setmaxlong 1 @@ -438,7 +472,7 @@ test obj-26.1 {Tcl_NewLongObj} { lappend result [testobj refcount 1] } {{} 1 int 1} -test obj-27.1 {Tcl_SetLongObj, existing "empty string" object} { +test obj-28.1 {Tcl_SetLongObj, existing "empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -446,7 +480,7 @@ test obj-27.1 {Tcl_SetLongObj, existing "empty string" object} { lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 77 int 2} -test obj-27.2 {Tcl_SetLongObj, existing non-"empty string" object} { +test obj-28.2 {Tcl_SetLongObj, existing non-"empty string" object} { set result "" lappend result [testobj freeallvars] lappend result [testdoubleobj set 1 12.34] @@ -455,31 +489,31 @@ test obj-27.2 {Tcl_SetLongObj, existing non-"empty string" object} { lappend result [testobj refcount 1] } {{} 12.34 77 int 2} -test obj-28.1 {Tcl_GetLongFromObj, existing long integer object} { +test obj-29.1 {Tcl_GetLongFromObj, existing long integer object} { set result "" lappend result [testintobj setlong 1 22] lappend result [testintobj mult10 1] ;# gets existing long int rep } {22 220} -test obj-28.2 {Tcl_GetLongFromObj, convert to long} { +test obj-29.2 {Tcl_GetLongFromObj, convert to long} { set result "" lappend result [testintobj setlong 1 477] lappend result [testintobj div10 1] ;# must convert to bool lappend result [testobj type 1] } {477 47 int} -test obj-28.3 {Tcl_GetLongFromObj, error converting to long integer} { +test obj-29.3 {Tcl_GetLongFromObj, error converting to long integer} { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int lappend result $msg } {abc 1 {expected integer but got "abc"}} -test obj-28.4 {Tcl_GetLongFromObj, error converting from "empty string"} { +test obj-29.4 {Tcl_GetLongFromObj, error converting from "empty string"} { set result "" lappend result [testobj newobj 1] lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int lappend result $msg } {{} 1 {expected integer but got ""}} -test obj-29.1 {Ref counting and object deletion, simple types} { +test obj-30.1 {Ref counting and object deletion, simple types} { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 1024] @@ -494,3 +528,19 @@ test obj-29.1 {Ref counting and object deletion, simple types} { } {{} 1024 1024 int 4 4 0 boolean 3 2} testobj freeallvars + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/opt.test b/tests/opt.test index ce79827..3ca62f2 100644 --- a/tests/opt.test +++ b/tests/opt.test @@ -1,4 +1,4 @@ -# Package covered: opt0.1/optparse.tcl +# Package covered: opt1.0/optparse.tcl # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and @@ -6,16 +6,19 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: opt.test,v 1.3 1998/09/14 18:40:12 stanton Exp $ +# RCS: @(#) $Id: opt.test,v 1.4 1999/04/16 00:47:31 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # the package we are going to test -package require opt 0.1 +package require opt 0.4.1 # we are using implementation specifics to test the package @@ -253,7 +256,6 @@ test opt-10.10 {medium size overall test} { list [catch {optTest save tst foo} msg] [lindex [split $msg "\n"] 0] } {1 {too many arguments (unexpected argument(s): foo), usage:}} - test opt-11.1 {too many args test 2} { set key [::tcl::OptKeyRegister {-foo}] list [catch {::tcl::OptKeyParse $key {-foo blah}} msg] $msg\ @@ -263,9 +265,6 @@ test opt-11.1 {too many args test 2} { ------------ ---- ----- ---- ( -help gives this help ) -foo boolflag (false) } {}} - - - test opt-11.2 {default value for args} { set args {} set key [::tcl::OptKeyRegister {{args -list {a b c} "args..."}}] @@ -274,4 +273,18 @@ test opt-11.2 {default value for args} { set args } {a b c} +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + diff --git a/tests/osa.test b/tests/osa.test index d7de348..4b061cf 100644 --- a/tests/osa.test +++ b/tests/osa.test @@ -5,32 +5,43 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: osa.test,v 1.2 1998/09/14 18:40:12 stanton Exp $ +# RCS: @(#) $Id: osa.test,v 1.3 1999/04/16 00:47:31 stanton Exp $ -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 +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } -test osa-1.1 {Tcl_OSAComponentCmd} { +# Only run the test if we can load the AppleScript command +set ::tcltest::testConfig(appleScript) [expr {[info commands AppleScript] != ""}] + +test osa-1.1 {Tcl_OSAComponentCmd} {macOnly appleScript} { list [catch AppleScript msg] $msg } {1 {wrong # args: should be "AppleScript option ?arg ...?"}} -test osa-1.2 {Tcl_OSAComponentCmd} { +test osa-1.2 {Tcl_OSAComponentCmd} {macOnly appleScript} { 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} { +test osa-1.3 {TclOSACompileCmd} {macOnly appleScript} { list [catch {AppleScript compile} msg] $msg } {1 {wrong # args: should be "AppleScript compile ?options? code"}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/parse.test b/tests/parse.test index 7019b7a..1f36063 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -1,556 +1,743 @@ -# Commands covered: set (plus basic command syntax). Also tests -# the procedures in the file tclParse.c. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and +# This file contains a collection of tests for the procedures in the +# file tclParse.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: parse.test,v 1.2 1998/09/14 18:40:12 stanton Exp $ - -if {[string compare test [info procs test]] == 1} then {source defs} +# RCS: @(#) $Id: parse.test,v 1.3 1999/04/16 00:47:31 stanton Exp $ -proc fourArgs {a b c d} { - global arg1 arg2 arg3 arg4 - set arg1 $a - set arg2 $b - set arg3 $c - set arg4 $d +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } -proc getArgs args { - global argv - set argv $args +if {[info commands testparser] == {}} { + puts "This application hasn't been compiled with the \"testparser\"" + puts "command, so I can't test the Tcl parser." + ::tcltest::cleanupTests + return } -# 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} { +test parse-1.1 {Tcl_ParseCommand procedure, computing string length} { + testparser [bytestring "foo\0 bar"] -1 +} {- foo 1 simple foo 1 text foo 0 {}} +test parse-1.2 {Tcl_ParseCommand procedure, computing string length} { + testparser "foo bar" -1 +} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}} +test parse-1.3 {Tcl_ParseCommand procedure, leading space} { + testparser " \n\t foo" 0 +} {- foo 1 simple foo 1 text foo 0 {}} +test parse-1.4 {Tcl_ParseCommand procedure, leading space} { + testparser "\f\r\vfoo" 0 +} {- foo 1 simple foo 1 text foo 0 {}} +test parse-1.5 {Tcl_ParseCommand procedure, backslash-newline in leading space} { + testparser " \\\n foo" 0 +} {- foo 1 simple foo 1 text foo 0 {}} +test parse-1.6 {Tcl_ParseCommand procedure, backslash-newline in leading space} { + testparser { \a foo} 0 +} {- {\a foo} 2 word {\a} 1 backslash {\a} 0 simple foo 1 text foo 0 {}} +test parse-1.7 {Tcl_ParseCommand procedure, missing continuation line in leading space} { + testparser " \\\n" 0 +} {- {} 0 {}} +test parse-1.8 {Tcl_ParseCommand procedure, eof in leading space} { + testparser " foo" 3 +} {- {} 0 { foo}} + +test parse-2.1 {Tcl_ParseCommand procedure, comments} { + testparser "# foo bar\n foo" 0 +} {{# foo bar +} foo 1 simple foo 1 text foo 0 {}} +test parse-2.2 {Tcl_ParseCommand procedure, several comments} { + testparser " # foo bar\n # another comment\n\n foo" 0 +} {{# foo bar + # another comment +} foo 1 simple foo 1 text foo 0 {}} +test parse-2.3 {Tcl_ParseCommand procedure, backslash-newline in comments} { + testparser " # foo bar\\\ncomment on continuation line\nfoo" 0 +} {#\ foo\ bar\\\ncomment\ on\ continuation\ line\n foo 1 simple foo 1 text foo 0 {}} +test parse-2.4 {Tcl_ParseCommand procedure, missing continuation line in comment} { + testparser "# \\\n" 0 +} {#\ \ \ \\\n {} 0 {}} +test parse-2.5 {Tcl_ParseCommand procedure, eof in comment} { + testparser " # foo bar\nfoo" 8 +} {{# foo b} {} 0 {ar +foo}} + +test parse-3.1 {Tcl_ParseCommand procedure, parsing words, skipping space} { + testparser "foo bar\t\tx" 0 +} {- {foo bar x} 3 simple foo 1 text foo 0 simple bar 1 text bar 0 simple x 1 text x 0 {}} +test parse-3.2 {Tcl_ParseCommand procedure, missing continuation line in leading space} { + testparser "abc \\\n" 0 +} {- abc\ \ \\\n 1 simple abc 1 text abc 0 {}} +test parse-3.3 {Tcl_ParseCommand procedure, parsing words, command ends in space} { + testparser "foo ; bar x" 0 +} {- {foo ;} 1 simple foo 1 text foo 0 { bar x}} +test parse-3.4 {Tcl_ParseCommand procedure, parsing words, command ends in space} { + testparser "foo " 5 +} {- {foo } 1 simple foo 1 text foo 0 { }} +test parse-3.5 {Tcl_ParseCommand procedure, quoted words} { + testparser {foo "a b c" d "efg";} 0 +} {- {foo "a b c" d "efg";} 4 simple foo 1 text foo 0 simple {"a b c"} 1 text {a b c} 0 simple d 1 text d 0 simple {"efg"} 1 text efg 0 {}} +test parse-3.6 {Tcl_ParseCommand procedure, words in braces} { + testparser {foo {a $b [concat foo]} {c d}} 0 +} {- {foo {a $b [concat foo]} {c d}} 3 simple foo 1 text foo 0 simple {{a $b [concat foo]}} 1 text {a $b [concat foo]} 0 simple {{c d}} 1 text {c d} 0 {}} +test parse-3.7 {Tcl_ParseCommand procedure, error in unquoted word} { + list [catch {testparser "foo \$\{abc" 0} msg] $msg $errorInfo +} {1 {missing close-brace for variable name} missing\ close-brace\ for\ variable\ name\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\$\\\{abc\"\ 0\"} + +test parse-4.1 {Tcl_ParseCommand procedure, simple words} { + testparser {foo} 0 +} {- foo 1 simple foo 1 text foo 0 {}} +test parse-4.2 {Tcl_ParseCommand procedure, simple words} { + testparser {{abc}} 0 +} {- {{abc}} 1 simple {{abc}} 1 text abc 0 {}} +test parse-4.3 {Tcl_ParseCommand procedure, simple words} { + testparser {"c d"} 0 +} {- {"c d"} 1 simple {"c d"} 1 text {c d} 0 {}} +test parse-4.4 {Tcl_ParseCommand procedure, simple words} { + testparser {x$d} 0 +} {- {x$d} 1 word {x$d} 3 text x 0 variable {$d} 1 text d 0 {}} +test parse-4.5 {Tcl_ParseCommand procedure, simple words} { + testparser {"a [foo] b"} 0 +} {- {"a [foo] b"} 1 word {"a [foo] b"} 3 text {a } 0 command {[foo]} 0 text { b} 0 {}} +test parse-4.6 {Tcl_ParseCommand procedure, simple words} { + testparser {$x} 0 +} {- {$x} 1 word {$x} 2 variable {$x} 1 text x 0 {}} + +test parse-5.1 {Tcl_ParseCommand procedure, backslash-newline terminates word} { + testparser "{abc}\\\n" 0 +} {- \{abc\}\\\n 1 simple {{abc}} 1 text abc 0 {}} +test parse-5.2 {Tcl_ParseCommand procedure, backslash-newline terminates word} { + testparser "foo\\\nbar" 0 +} {- foo\\\nbar 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}} +test parse-5.3 {Tcl_ParseCommand procedure, word terminator is command terminator} { + testparser "foo\n bar" 0 +} {- {foo +} 1 simple foo 1 text foo 0 { bar}} +test parse-5.4 {Tcl_ParseCommand procedure, word terminator is command terminator} { + testparser "foo; bar" 0 +} {- {foo;} 1 simple foo 1 text foo 0 { bar}} +test parse-5.5 {Tcl_ParseCommand procedure, word terminator is end of string} { + testparser "\"foo\" bar" 5 +} {- {"foo"} 1 simple {"foo"} 1 text foo 0 { bar}} +test parse-5.6 {Tcl_ParseCommand procedure, junk after close quote} { + list [catch {testparser {foo "bar"x} 0} msg] $msg $errorInfo +} {1 {extra characters after close-quote} {extra characters after close-quote + (remainder of script: "x") + invoked from within +"testparser {foo "bar"x} 0"}} +test parse-5.7 {Tcl_ParseCommand procedure, backslash-newline after close quote} { + testparser "foo \"bar\"\\\nx" 0 +} {- foo\ \"bar\"\\\nx 3 simple foo 1 text foo 0 simple {"bar"} 1 text bar 0 simple x 1 text x 0 {}} +test parse-5.8 {Tcl_ParseCommand procedure, junk after close brace} { + list [catch {testparser {foo {bar}x} 0} msg] $msg $errorInfo +} {1 {extra characters after close-brace} {extra characters after close-brace + (remainder of script: "x") + invoked from within +"testparser {foo {bar}x} 0"}} +test parse-5.9 {Tcl_ParseCommand procedure, backslash-newline after close brace} { + testparser "foo {bar}\\\nx" 0 +} {- foo\ \{bar\}\\\nx 3 simple foo 1 text foo 0 simple {{bar}} 1 text bar 0 simple x 1 text x 0 {}} +test parse-5.10 {Tcl_ParseCommand procedure, multiple deletion of non-static buffer} { + # This test is designed to catch bug 1681. + list [catch {testparser "a \"\\1\\2\\3\\4\\5\\6\\7\\8\\9\\1\\2\\3\\4\\5\\6\\7\\8" 0} msg] $msg $errorInfo +} "1 {missing \"} {missing \" + (remainder of script: \"\"\\1\\2\\3\\4\\5\\6\\7\\8\\9\\1\\2\\3\\4\\5\\6\\7\\8\") + invoked from within +\"testparser \"a \\\"\\\\1\\\\2\\\\3\\\\4\\\\5\\\\6\\\\7\\\\8\\\\9\\\\1\\\\2\\\\3\\\\4\\\\5\\\\6\\\\7\\\\8\" 0\"}" + +test parse-6.1 {ParseTokens procedure, empty word} { + testparser {""} 0 +} {- {""} 1 simple {""} 1 text {} 0 {}} +test parse-6.2 {ParseTokens procedure, simple range} { + testparser {"abc$x.e"} 0 +} {- {"abc$x.e"} 1 word {"abc$x.e"} 4 text abc 0 variable {$x} 1 text x 0 text .e 0 {}} +test parse-6.3 {ParseTokens procedure, variable reference} { + testparser {abc$x.e $y(z)} 0 +} {- {abc$x.e $y(z)} 2 word {abc$x.e} 4 text abc 0 variable {$x} 1 text x 0 text .e 0 word {$y(z)} 3 variable {$y(z)} 2 text y 0 text z 0 {}} +test parse-6.4 {ParseTokens procedure, variable reference} { + list [catch {testparser {$x([a )} 0} msg] $msg +} {1 {missing close-bracket}} +test parse-6.5 {ParseTokens procedure, command substitution} { + testparser {[foo $x bar]z} 0 +} {- {[foo $x bar]z} 1 word {[foo $x bar]z} 2 command {[foo $x bar]} 0 text z 0 {}} +test parse-6.6 {ParseTokens procedure, command substitution} { + testparser {[foo \] [a b]]} 0 +} {- {[foo \] [a b]]} 1 word {[foo \] [a b]]} 1 command {[foo \] [a b]]} 0 {}} +test parse-6.7 {ParseTokens procedure, error in command substitution} { + list [catch {testparser {a [b {}c d] e} 0} msg] $msg $errorInfo +} {1 {extra characters after close-brace} {extra characters after close-brace + (remainder of script: "c d] e") + invoked from within +"testparser {a [b {}c d] e} 0"}} +test parse-6.8 {ParseTokens procedure, error in command substitution} { + info complete {a [b {}c d]} +} {1} +test parse-6.9 {ParseTokens procedure, error in command substitution} { + info complete {a [b "c d} +} {0} +test parse-6.10 {ParseTokens procedure, incomplete sub-command} { + info complete {puts [ + expr 1+1 + #this is a comment ]} +} {0} +test parse-6.11 {ParseTokens procedure, memory allocation for big nested command} { + testparser {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 0 +} {- {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 1 word {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 1 command {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 0 {}} +test parse-6.12 {ParseTokens procedure, missing close bracket} { + list [catch {testparser {[foo $x bar} 0} msg] $msg $errorInfo +} {1 {missing close-bracket} {missing close-bracket + (remainder of script: "[foo $x bar") + invoked from within +"testparser {[foo $x bar} 0"}} +test parse-6.13 {ParseTokens procedure, backslash-newline without continuation line} { + list [catch {testparser "\"a b\\\n" 0} msg] $msg $errorInfo +} {1 {missing "} missing\ \"\n\ \ \ \ (remainder\ of\ script:\ \"\"a\ b\\\n\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\\\"a\ b\\\\\\n\"\ 0\"} +test parse-6.14 {ParseTokens procedure, backslash-newline} { + testparser "b\\\nc" 0 +} {- b\\\nc 2 simple b 1 text b 0 simple c 1 text c 0 {}} +test parse-6.15 {ParseTokens procedure, backslash-newline} { + testparser "\"b\\\nc\"" 0 +} {- \"b\\\nc\" 1 word \"b\\\nc\" 3 text b 0 backslash \\\n 0 text c 0 {}} +test parse-6.16 {ParseTokens procedure, backslash substitution} { + testparser {\n\a\x7f} 0 +} {- {\n\a\x7f} 1 word {\n\a\x7f} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7f} 0 {}} +test parse-6.17 {ParseTokens procedure, null characters} { + testparser [bytestring "foo\0zz"] 0 +} "- [bytestring foo\0zz] 1 word [bytestring foo\0zz] 3 text foo 0 text [bytestring \0] 0 text zz 0 {}" + +test parse-7.1 {Tcl_FreeParse and ExpandTokenArray procedures} { + testparser {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 0 +} {- {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 16 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 {}} + +test parse-8.1 {Tcl_EvalObjv procedure} { + testevalobjv 0 concat this is a test +} {this is a test} +test parse-8.2 {Tcl_EvalObjv procedure, unknown commands} { + rename unknown unknown.old + set x [catch {testevalobjv 10 asdf poiu} msg] + rename unknown.old unknown + list $x $msg +} {1 {invalid command name "asdf"}} +test parse-8.3 {Tcl_EvalObjv procedure, unknown commands} { + rename unknown unknown.old + proc unknown args { + return "unknown $args" + } + set x [catch {testevalobjv 0 asdf poiu} msg] + rename unknown {} + rename unknown.old unknown + list $x $msg +} {0 {unknown asdf poiu}} +test parse-8.4 {Tcl_EvalObjv procedure, unknown commands} { + rename unknown unknown.old + proc unknown args { + error "I don't like that command" + } + set x [catch {testevalobjv 0 asdf poiu} msg] + rename unknown {} + rename unknown.old unknown + list $x $msg +} {1 {I don't like that command}} +test parse-8.5 {Tcl_EvalObjv procedure, command traces} { + testevalobjv 0 set x 123 + testcmdtrace tracetest {testevalobjv 0 set x $x} +} {{testevalobjv 0 set x $x} {testevalobjv 0 set x 123} {set x 123} {set x 123}} +test parse-8.7 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL flag} { + proc x {} { + set y 23 + set z [testevalobjv 1 set y] + return [list $z $y] + } + catch {unset y} + set y 16 + x +} {16 23} +test parse-8.8 {Tcl_EvalObjv procedure, async handlers} { + proc async1 {result code} { + global aresult acode + set aresult $result + set acode $code + return "new result" + } + set handler1 [testasync create async1] + set aresult xxx + set acode yyy + set x [list [catch [list testevalobjv 0 testasync mark $handler1 original 0] msg] $msg $acode $aresult] + testasync delete + set x +} {0 {new result} 0 original} +test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} { + list [catch {testevalobjv 0 error message} msg] $msg +} {1 message} + +test parse-9.1 {Tcl_LogCommandInfo, line numbers} { + catch {unset x} + list [catch {testevalex {for {} 1 {} { + + + # asdf + set x + }}}] $errorInfo +} {1 {can't read "x": no such variable + while executing +"set x" + ("for" body line 5) + invoked from within +"for {} 1 {} { + + + # asdf + set x + }" + invoked from within +"testevalex {for {} 1 {} { + + + # asdf + set x + }}"}} +test parse-9.2 {Tcl_LogCommandInfo, truncating long commands} { + list [testevalex {catch {set a b 111111111 222222222 333333333 444444444 555555555 666666666 777777777 888888888 999999999 000000000 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee fffffffff ggggggggg}}] $errorInfo +} {1 {wrong # args: should be "set varName ?newValue?" + while executing +"set a b 111111111 222222222 333333333 444444444 555555555 666666666 777777777 888888888 999999999 000000000 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd ee..."}} + +test parse-10.1 {Tcl_EvalTokens, simple text} { + testevalex {concat test} +} {test} +test parse-10.2 {Tcl_EvalTokens, backslash sequences} { + testevalex {concat test\063\062test} +} {test32test} +test parse-10.3 {Tcl_EvalTokens, nested commands} { + testevalex {concat [expr 2 + 6]} +} {8} +test parse-10.4 {Tcl_EvalTokens, nested commands} { catch {unset a} - set a(xyz) 123 - set b $a(xyz)foo - set b -} 123foo -test parse-5.8 {array variable substitution} { + list [catch {testevalex {concat xxx[expr $a]}} msg] $msg +} {1 {can't read "a": no such variable}} +test parse-10.5 {Tcl_EvalTokens, simple variables} { + set a hello + testevalex {concat $a} +} {hello} +test parse-10.6 {Tcl_EvalTokens, array variables} { 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} { + set a(12) 46 + testevalex {concat $a(12)} +} {46} +test parse-10.7 {Tcl_EvalTokens, array variables} { 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} { + set a(12) 46 + testevalex {concat $a(1[expr 3 - 1])} +} {46} +test parse-10.8 {Tcl_EvalTokens, array variables} { 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] -} + list [catch {testevalex {concat $x($a)}} msg] $msg +} {1 {can't read "a": no such variable}} +test parse-10.9 {Tcl_EvalTokens, array variables} { + catch {unset a} + list [catch {testevalex {concat xyz$a(1)}} msg] $msg +} {1 {can't read "a(1)": no such variable}} +test parse-10.10 {Tcl_EvalTokens, object values} { + set a 123 + testevalex {concat $a} +} {123} +test parse-10.11 {Tcl_EvalTokens, object values} { + set a 123 + testevalex {concat $a$a$a} +} {123123123} +test parse-10.12 {Tcl_EvalTokens, object values} { + testevalex {concat [expr 2][expr 4][expr 6]} +} {246} +test parse-10.13 {Tcl_EvalTokens, string values} { + testevalex {concat {a" b"}} +} {a" b"} +test parse-10.14 {Tcl_EvalTokens, string values} { + set a 111 + testevalex {concat x$a.$a.$a} +} {x111.111.111} -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 +test parse-11.1 {Tcl_Eval2, TCL_EVAL_GLOBAL flag} { + proc x {} { + set y 777 + set z [testevalex "set y" global] + return [list $z $y] + } + catch {unset y} + set y 321 + x +} {321 777} +test parse-11.2 {Tcl_Eval2, error while parsing} { + list [catch {testevalex {concat "abc}} msg] $msg +} {1 {missing "}} +test parse-11.3 {Tcl_Eval2, error while collecting words} { + catch {unset a} + list [catch {testevalex {concat xyz $a}} msg] $msg +} {1 {can't read "a": no such variable}} +test parse-11.4 {Tcl_Eval2, error in Tcl_EvalObjv call} { + catch {unset a} + list [catch {testevalex {_bogus_ a b c d}} msg] $msg +} {1 {invalid command name "_bogus_"}} +test parse-11.5 {Tcl_Eval2, exceptional return} { + list [catch {testevalex {break}} msg] $msg +} {3 {}} +test parse-11.6 {Tcl_Eval2, freeing memory} { + testevalex {concat a b c d e f g h i j k l m n o p q r s t u v w x y z} +} {a b c d e f g h i j k l m n o p q r s t u v w x y z} +test parse-11.7 {Tcl_Eval2, multiple commands in script} { + list [testevalex {set a b; set c d}] $a $c +} {d b d} +test parse-11.8 {Tcl_Eval2, multiple commands in script} { + list [testevalex { + set a b + set c d + }] $a $c +} {d b d} +test parse-11.9 {Tcl_Eval2, freeing memory after error} { + catch {unset a} + list [catch {testevalex {concat a b c d e f g h i j k l m n o p q r s t u v w x y z $a}} msg] $msg +} {1 {can't read "a": no such variable}} +test parse-11.10 {Tcl_EvalTokens, empty commands} { + testevalex {concat xyz; } +} {xyz} +test parse-11.11 {Tcl_EvalTokens, empty commands} { + testevalex "concat abc; ; # this is a comment\n" +} {abc} +test parse-11.12 {Tcl_EvalTokens, empty commands} { + testevalex {} +} {} + +test parse-12.1 {Tcl_ParseVarName procedure, initialization} { + list [catch {testparsevarname {$a([first second])} 8 0} msg] $msg +} {1 {missing close-bracket}} +test parse-12.2 {Tcl_ParseVarName procedure, initialization} { + testparsevarname {$a([first second])} 0 0 +} {- {} 0 variable {$a([first second])} 2 text a 0 command {[first second]} 0 {}} +test parse-12.3 {Tcl_ParseVarName procedure, initialization} { + list [catch {testparsevarname {$abcd} 3 0} msg] $msg +} {0 {- {} 0 variable {$ab} 1 text ab 0 cd}} +test parse-12.4 {Tcl_ParseVarName procedure, initialization} { + testparsevarname {$abcd} 0 0 +} {- {} 0 variable {$abcd} 1 text abcd 0 {}} +test parse-12.5 {Tcl_ParseVarName procedure, just a dollar sign} { + testparsevarname {$abcd} 1 0 +} {- {} 0 text {$} 0 abcd} +test parse-12.6 {Tcl_ParseVarName procedure, braced variable name} { + testparser {${..[]b}cd} 0 +} {- {${..[]b}cd} 1 word {${..[]b}cd} 3 variable {${..[]b}} 1 text {..[]b} 0 text cd 0 {}} +test parse-12.7 {Tcl_ParseVarName procedure, braced variable name} { + testparser "\$\{\{\} " 0 +} {- \$\{\{\}\ 1 word \$\{\{\} 2 variable \$\{\{\} 1 text \{ 0 {}} +test parse-12.8 {Tcl_ParseVarName procedure, missing close brace} { + list [catch {testparser "$\{abc" 0} msg] $msg $errorInfo +} {1 {missing close-brace for variable name} missing\ close-brace\ for\ variable\ name\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\$\\\{abc\"\ 0\"} +test parse-12.9 {Tcl_ParseVarName procedure, missing close brace} { + list [catch {testparsevarname {${bcd}} 4 0} msg] $msg +} {1 {missing close-brace for variable name}} +test parse-12.10 {Tcl_ParseVarName procedure, missing close brace} { + list [catch {testparsevarname {${bc}} 4 0} msg] $msg +} {1 {missing close-brace for variable name}} +test parse-12.11 {Tcl_ParseVarName procedure, simple variable name} { + testparser {$az_AZ.} 0 +} {- {$az_AZ.} 1 word {$az_AZ.} 3 variable {$az_AZ} 1 text az_AZ 0 text . 0 {}} +test parse-12.12 {Tcl_ParseVarName procedure, simple variable name} { + testparser {$abcdefg} 4 +} {- {$abc} 1 word {$abc} 2 variable {$abc} 1 text abc 0 defg} +test parse-12.13 {Tcl_ParseVarName procedure, simple variable name with ::} { + testparser {$xyz::ab:c} 0 +} {- {$xyz::ab:c} 1 word {$xyz::ab:c} 3 variable {$xyz::ab} 1 text xyz::ab 0 text :c 0 {}} +test parse-12.14 {Tcl_ParseVarName procedure, variable names with many colons} { + testparser {$xyz:::::c} 0 +} {- {$xyz:::::c} 1 word {$xyz:::::c} 2 variable {$xyz:::::c} 1 text xyz:::::c 0 {}} +test parse-12.15 {Tcl_ParseVarName procedure, : vs. ::} { + testparsevarname {$ab:cd} 0 0 +} {- {} 0 variable {$ab} 1 text ab 0 :cd} +test parse-12.16 {Tcl_ParseVarName procedure, eof in ::} { + testparsevarname {$ab::cd} 4 0 +} {- {} 0 variable {$ab} 1 text ab 0 ::cd} +test parse-12.17 {Tcl_ParseVarName procedure, eof in ::} { + testparsevarname {$ab:::cd} 5 0 +} {- {} 0 variable {$ab::} 1 text ab:: 0 :cd} +test parse-12.18 {Tcl_ParseVarName procedure, no variable name} { + testparser {$$ $.} 0 +} {- {$$ $.} 2 word {$$} 2 text {$} 0 text {$} 0 word {$.} 2 text {$} 0 text . 0 {}} +test parse-12.19 {Tcl_ParseVarName procedure, EOF before (} { + testparsevarname {$ab(cd)} 3 0 +} {- {} 0 variable {$ab} 1 text ab 0 (cd)} +test parse-12.20 {Tcl_ParseVarName procedure, array reference} { + testparser {$x(abc)} 0 +} {- {$x(abc)} 1 word {$x(abc)} 3 variable {$x(abc)} 2 text x 0 text abc 0 {}} +test parse-12.21 {Tcl_ParseVarName procedure, array reference} { + testparser {$x(ab$cde[foo bar])} 0 +} {- {$x(ab$cde[foo bar])} 1 word {$x(ab$cde[foo bar])} 6 variable {$x(ab$cde[foo bar])} 5 text x 0 text ab 0 variable {$cde} 1 text cde 0 command {[foo bar]} 0 {}} +test parse-12.22 {Tcl_ParseVarName procedure, array reference} { + testparser {$x([cmd arg]zz)} 0 +} {- {$x([cmd arg]zz)} 1 word {$x([cmd arg]zz)} 4 variable {$x([cmd arg]zz)} 3 text x 0 command {[cmd arg]} 0 text zz 0 {}} +test parse-12.23 {Tcl_ParseVarName procedure, missing close paren in array reference} { + list [catch {testparser {$x(poiu} 0} msg] $msg $errorInfo } {1 {missing )} {missing ) - (parsing index for array "x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000") - while compiling -"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 ..." - ("eval" body line 1) + (remainder of script: "(poiu") invoked from within -"eval \$x[format "%01000d" 0]("}} -test parse-9.15 {syntax errors, missplaced braces} { - catch { - proc misplaced_end_brace {} { - set what foo - set when [expr ${what}size - [set off$what]}] - } msg - set msg -} {wrong # args: should be "proc name args body"} -test parse-9.16 {syntax errors, missplaced braces} { - catch { - set a { - set what foo - set when [expr ${what}size - [set off$what]}] - } msg - set msg -} {argument word in braces doesn't terminate properly} - -# Long values (stressing storage management) - -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 +"testparser {$x(poiu} 0"}} +test parse-12.24 {Tcl_ParseVarName procedure, missing close paren in array reference} { + list [catch {testparsevarname {$ab(cd)} 6 0} msg] $msg $errorInfo +} {1 {missing )} {missing ) + (remainder of script: "(cd)") + invoked from within +"testparsevarname {$ab(cd)} 6 0"}} +test parse-12.25 {Tcl_ParseVarName procedure, nested array reference} { + testparser {$x(a$y(b$z))} 0 +} {- {$x(a$y(b$z))} 1 word {$x(a$y(b$z))} 8 variable {$x(a$y(b$z))} 7 text x 0 text a 0 variable {$y(b$z)} 4 text y 0 text b 0 variable {$z} 1 text z 0 {}} -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-13.1 {Tcl_ParseVar procedure} { + set abc 24 + testparsevar {$abc.fg} +} {24 .fg} +test parse-13.2 {Tcl_ParseVar procedure, no variable name} { + testparsevar {$} +} {{$} {}} +test parse-13.3 {Tcl_ParseVar procedure, no variable name} { + testparsevar {$.123} +} {{$} .123} +test parse-13.4 {Tcl_ParseVar procedure, error looking up variable} { + catch {unset abc} + list [catch {testparsevar {$abc}} msg] $msg +} {1 {can't read "abc": no such variable}} +test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} { + catch {unset abc} + list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg +} {1 {invalid command name "bogus"}} -test parse-14.1 {TclScriptEnd procedure} { - info complete {puts [ - expr 1+1 - #this is a comment ]} -} {0} -test parse-14.2 {TclScriptEnd procedure} { +test parse-14.1 {Tcl_ParseBraces procedure, computing string length} { + testparser [bytestring "foo\0 bar"] -1 +} {- foo 1 simple foo 1 text foo 0 {}} +test parse-14.2 {Tcl_ParseBraces procedure, computing string length} { + testparser "foo bar" -1 +} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}} +test parse-14.3 {Tcl_ParseBraces procedure, words in braces} { + testparser {foo {a $b [concat foo]} {c d}} 0 +} {- {foo {a $b [concat foo]} {c d}} 3 simple foo 1 text foo 0 simple {{a $b [concat foo]}} 1 text {a $b [concat foo]} 0 simple {{c d}} 1 text {c d} 0 {}} +test parse-14.4 {Tcl_ParseBraces procedure, empty nested braces} { + testparser {foo {{}}} 0 +} {- {foo {{}}} 2 simple foo 1 text foo 0 simple {{{}}} 1 text {{}} 0 {}} +test parse-14.5 {Tcl_ParseBraces procedure, nested braces} { + testparser {foo {{a {b} c} {} {d e}}} 0 +} {- {foo {{a {b} c} {} {d e}}} 2 simple foo 1 text foo 0 simple {{{a {b} c} {} {d e}}} 1 text {{a {b} c} {} {d e}} 0 {}} +test parse-14.6 {Tcl_ParseBraces procedure, backslashes in words in braces} { + testparser "foo {a \\n\\\{}" 0 +} {- {foo {a \n\{}} 2 simple foo 1 text foo 0 simple {{a \n\{}} 1 text {a \n\{} 0 {}} +test parse-14.7 {Tcl_ParseBraces procedure, missing continuation line in braces} { + list [catch {testparser "\{abc\\\n" 0} msg] $msg $errorInfo +} {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\\\n\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\\\{abc\\\\\\n\"\ 0\"} +test parse-14.8 {Tcl_ParseBraces procedure, backslash-newline in braces} { + testparser "foo {\\\nx}" 0 +} {- foo\ \{\\\nx\} 2 simple foo 1 text foo 0 word \{\\\nx\} 2 backslash \\\n 0 text x 0 {}} +test parse-14.9 {Tcl_ParseBraces procedure, backslash-newline in braces} { + testparser "foo {a \\\n b}" 0 +} {- foo\ \{a\ \\\n\ \ \ b\} 2 simple foo 1 text foo 0 word \{a\ \\\n\ \ \ b\} 3 text {a } 0 backslash \\\n\ \ \ 0 text b 0 {}} +test parse-14.10 {Tcl_ParseBraces procedure, backslash-newline in braces} { + testparser "foo {xyz\\\n }" 0 +} {- foo\ \{xyz\\\n\ \} 2 simple foo 1 text foo 0 word \{xyz\\\n\ \} 2 text xyz 0 backslash \\\n\ 0 {}} +test parse-14.11 {Tcl_ParseBraces procedure, empty braced string} { + testparser {foo {}} 0 +} {- {foo {}} 2 simple foo 1 text foo 0 simple {{}} 1 text {} 0 {}} +test parse-14.12 {Tcl_ParseBraces procedure, missing close brace} { + list [catch {testparser "foo \{xy\\\nz" 0} msg] $msg $errorInfo +} {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{xy\\\nz\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\{xy\\\\\\nz\"\ 0\"} + +test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} { + testparser [bytestring "foo\0 bar"] -1 +} {- foo 1 simple foo 1 text foo 0 {}} +test parse-15.2 {Tcl_ParseQuotedString procedure, computing string length} { + testparser "foo bar" -1 +} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}} +test parse-15.3 {Tcl_ParseQuotedString procedure, word is quoted string} { + testparser {foo "a b c" d "efg";} 0 +} {- {foo "a b c" d "efg";} 4 simple foo 1 text foo 0 simple {"a b c"} 1 text {a b c} 0 simple d 1 text d 0 simple {"efg"} 1 text efg 0 {}} +test parse-15.4 {Tcl_ParseQuotedString procedure, garbage after quoted string} { + list [catch {testparser {foo "a b c"d} 0} msg] $msg $errorInfo +} {1 {extra characters after close-quote} {extra characters after close-quote + (remainder of script: "d") + invoked from within +"testparser {foo "a b c"d} 0"}} + +test parse-15.5 {CommandComplete procedure} { + info complete "" +} 1 +test parse-15.6 {CommandComplete procedure} { + info complete " \n" +} 1 +test parse-15.7 {CommandComplete procedure} { + info complete "abc def" +} 1 +test parse-15.8 {CommandComplete procedure} { + info complete "a b c d e f \t\n" +} 1 +test parse-15.9 {CommandComplete procedure} { + info complete {a b c"d} +} 1 +test parse-15.10 {CommandComplete procedure} { + info complete {a b "c d" e} +} 1 +test parse-15.11 {CommandComplete procedure} { + info complete {a b "c d"} +} 1 +test parse-15.12 {CommandComplete procedure} { + info complete {a b "c d"} +} 1 +test parse-15.13 {CommandComplete procedure} { + info complete {a b "c d} +} 0 +test parse-15.14 {CommandComplete procedure} { + info complete {a b "} +} 0 +test parse-15.15 {CommandComplete procedure} { + info complete {a b "cd"xyz} +} 1 +test parse-15.16 {CommandComplete procedure} { + info complete {a b "c $d() d"} +} 1 +test parse-15.17 {CommandComplete procedure} { + info complete {a b "c $dd("} +} 0 +test parse-15.18 {CommandComplete procedure} { + info complete {a b "c \"} +} 0 +test parse-15.19 {CommandComplete procedure} { + info complete {a b "c [d e f]"} +} 1 +test parse-15.20 {CommandComplete procedure} { + info complete {a b "c [d e f] g"} +} 1 +test parse-15.21 {CommandComplete procedure} { + info complete {a b "c [d e f"} +} 0 +test parse-15.22 {CommandComplete procedure} { + info complete {a {b c d} e} +} 1 +test parse-15.23 {CommandComplete procedure} { + info complete {a {b c d}} +} 1 +test parse-15.24 {CommandComplete procedure} { + info complete "a b\{c d" +} 1 +test parse-15.25 {CommandComplete procedure} { + info complete "a b \{c" +} 0 +test parse-15.26 {CommandComplete procedure} { + info complete "a b \{c{ }" +} 0 +test parse-15.27 {CommandComplete procedure} { + info complete "a b {c d e}xxx" +} 1 +test parse-15.28 {CommandComplete procedure} { + info complete "a b {c \\\{d e}xxx" +} 1 +test parse-15.29 {CommandComplete procedure} { + info complete {a b [ab cd ef]} +} 1 +test parse-15.30 {CommandComplete procedure} { + info complete {a b x[ab][cd][ef] gh} +} 1 +test parse-15.31 {CommandComplete procedure} { + info complete {a b x[ab][cd[ef] gh} +} 0 +test parse-15.32 {CommandComplete procedure} { + info complete {a b x[ gh} +} 0 +test parse-15.33 {CommandComplete procedure} { + info complete {[]]]} +} 1 +test parse-15.34 {CommandComplete procedure} { + info complete {abc x$yyy} +} 1 +test parse-15.35 {CommandComplete procedure} { + info complete "abc x\${abc\[\\d} xyz" +} 1 +test parse-15.36 {CommandComplete procedure} { + info complete "abc x\$\{ xyz" +} 0 +test parse-15.37 {CommandComplete procedure} { + info complete {word $a(xyz)} +} 1 +test parse-15.38 {CommandComplete procedure} { + info complete {word $a(} +} 0 +test parse-15.39 {CommandComplete procedure} { + info complete "set a \\\n" +} 0 +test parse-15.40 {CommandComplete procedure} { + info complete "set a \\\\\n" +} 1 +test parse-15.41 {CommandComplete procedure} { + info complete "set a \\n " +} 1 +test parse-15.42 {CommandComplete procedure} { + info complete "set a \\" +} 1 +test parse-15.43 {CommandComplete procedure} { + info complete "foo \\\n\{" +} 0 +test parse-15.44 {CommandComplete procedure} { + info complete "a\nb\n# \{\n# \{\nc\n" +} 1 +test parse-15.45 {CommandComplete procedure} { + info complete "#Incomplete comment\\\n" +} 0 +test parse-15.46 {CommandComplete procedure} { + info complete "#Incomplete comment\\\nBut now it's complete.\n" +} 1 +test parse-15.47 {CommandComplete procedure} { + info complete "# Complete comment\\\\\n" +} 1 +test parse-15.48 {CommandComplete procedure} { + info complete "abc\\\n def" +} 1 +test parse-15.49 {CommandComplete procedure} { + info complete "abc\\\n " +} 1 +test parse-15.50 {CommandComplete 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} +} 0 +test parse-15.51 {CommandComplete procedure} " + info complete \"\\{abc\\}\\{\" +" 1 +test parse-15.52 {CommandComplete procedure} { + info complete "\"abc\"(" +} 1 +test parse-15.53 {CommandComplete procedure} " + info complete \" # {\" +" 1 +test parse-15.54 {CommandComplete procedure} " + info complete \"foo bar;# {\" +" 1 +test parse-15.55 {CommandComplete procedure} { + info complete "set x [bytestring \0]; puts hi" +} 1 +test parse-15.56 {CommandComplete procedure} { + info complete "set x [bytestring \0]; \{" +} 0 +test parse-15.57 {CommandComplete procedure} { + info complete "# Comment should be complete command" +} 1 + +# cleanup +catch {unset a} +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tests/parseExpr.test b/tests/parseExpr.test new file mode 100644 index 0000000..e454321 --- /dev/null +++ b/tests/parseExpr.test @@ -0,0 +1,637 @@ +# This file contains a collection of tests for the procedures in the +# file tclParseExpr.c. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: parseExpr.test,v 1.2 1999/04/16 00:47:31 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +# Note that the Tcl expression parser (tclParseExpr.c) does not check +# the semantic validity of the expressions it parses. It does not check, +# for example, that a math function actually exists, or that the operands +# of "<<" are integers. + +if {[info commands testexprparser] == {}} { + puts "This application hasn't been compiled with the \"testexprparser\"" + puts "command, so I can't test the Tcl expression parser." + ::tcltest::cleanupTests + return +} + +test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} { + testexprparser [bytestring "1+2\0 +3"] -1 +} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} { + testexprparser "1 + 2" -1 +} {- {} 0 subexpr {1 + 2} 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} {nonPortable} { + list [catch {testexprparser {12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-1.4 {Tcl_ParseExpr procedure, error in conditional expression} { + list [catch {testexprparser {foo+} -1} msg] $msg +} {1 {syntax error in expression "foo+"}} +test parseExpr-1.5 {Tcl_ParseExpr procedure, lexemes after the expression} { + list [catch {testexprparser {1+2 345} -1} msg] $msg +} {1 {syntax error in expression "1+2 345"}} + +test parseExpr-2.1 {ParseCondExpr procedure, valid test subexpr} { + testexprparser {2>3? 1 : 0} -1 +} {- {} 0 subexpr {2>3? 1 : 0} 11 operator ? 0 subexpr 2>3 5 operator > 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-2.2 {ParseCondExpr procedure, error in test subexpr} { + list [catch {testexprparser {0 || foo} -1} msg] $msg +} {1 {syntax error in expression "0 || foo"}} +test parseExpr-2.3 {ParseCondExpr procedure, next lexeme isn't "?"} { + testexprparser {1+2} -1 +} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-2.4 {ParseCondExpr procedure, next lexeme is "?"} { + testexprparser {1+2 ? 3 : 4} -1 +} {- {} 0 subexpr {1+2 ? 3 : 4} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-2.5 {ParseCondExpr procedure, bad lexeme after "?"} {nonPortable} { + list [catch {testexprparser {1+2 ? 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-2.6 {ParseCondExpr procedure, valid "then" subexpression} { + testexprparser {1? 3 : 4} -1 +} {- {} 0 subexpr {1? 3 : 4} 7 operator ? 0 subexpr 1 1 text 1 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-2.7 {ParseCondExpr procedure, error in "then" subexpression} { + list [catch {testexprparser {1? fred : martha} -1} msg] $msg +} {1 {syntax error in expression "1? fred : martha"}} +test parseExpr-2.8 {ParseCondExpr procedure, lexeme after "then" subexpr isn't ":"} { + list [catch {testexprparser {1? 2 martha 3} -1} msg] $msg +} {1 {syntax error in expression "1? 2 martha 3"}} +test parseExpr-2.9 {ParseCondExpr procedure, valid "else" subexpression} { + testexprparser {27||3? 3 : 4&&9} -1 +} {- {} 0 subexpr {27||3? 3 : 4&&9} 15 operator ? 0 subexpr 27||3 5 operator || 0 subexpr 27 1 text 27 0 subexpr 3 1 text 3 0 subexpr 3 1 text 3 0 subexpr 4&&9 5 operator && 0 subexpr 4 1 text 4 0 subexpr 9 1 text 9 0 {}} +test parseExpr-2.10 {ParseCondExpr procedure, error in "else" subexpression} { + list [catch {testexprparser {1? 2 : martha} -1} msg] $msg +} {1 {syntax error in expression "1? 2 : martha"}} + +test parseExpr-3.1 {ParseLorExpr procedure, valid logical and subexpr} { + testexprparser {1&&2 || 3} -1 +} {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-3.2 {ParseLorExpr procedure, error in logical and subexpr} { + list [catch {testexprparser {1&&foo || 3} -1} msg] $msg +} {1 {syntax error in expression "1&&foo || 3"}} +test parseExpr-3.3 {ParseLorExpr procedure, next lexeme isn't "||"} { + testexprparser {1&&2? 1 : 0} -1 +} {- {} 0 subexpr {1&&2? 1 : 0} 11 operator ? 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-3.4 {ParseLorExpr procedure, next lexeme is "||"} { + testexprparser {1&&2 || 3} -1 +} {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-3.5 {ParseLorExpr procedure, bad lexeme after "||"} {nonPortable} { + list [catch {testexprparser {1&&2 || 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-3.6 {ParseLorExpr procedure, valid RHS subexpression} { + testexprparser {1&&2 || 3 || 4} -1 +} {- {} 0 subexpr {1&&2 || 3 || 4} 13 operator || 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-3.7 {ParseLorExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1&&2 || 3 || martha} -1} msg] $msg +} {1 {syntax error in expression "1&&2 || 3 || martha"}} + +test parseExpr-4.1 {ParseLandExpr procedure, valid LHS "|" subexpr} { + testexprparser {1|2 && 3} -1 +} {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-4.2 {ParseLandExpr procedure, error in LHS "|" subexpr} { + list [catch {testexprparser {1&&foo && 3} -1} msg] $msg +} {1 {syntax error in expression "1&&foo && 3"}} +test parseExpr-4.3 {ParseLandExpr procedure, next lexeme isn't "&&"} { + testexprparser {1|2? 1 : 0} -1 +} {- {} 0 subexpr {1|2? 1 : 0} 11 operator ? 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-4.4 {ParseLandExpr procedure, next lexeme is "&&"} { + testexprparser {1|2 && 3} -1 +} {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-4.5 {ParseLandExpr procedure, bad lexeme after "&&"} {nonPortable} { + list [catch {testexprparser {1|2 && 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-4.6 {ParseLandExpr procedure, valid RHS subexpression} { + testexprparser {1|2 && 3 && 4} -1 +} {- {} 0 subexpr {1|2 && 3 && 4} 13 operator && 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-4.7 {ParseLandExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1|2 && 3 && martha} -1} msg] $msg +} {1 {syntax error in expression "1|2 && 3 && martha"}} + +test parseExpr-5.1 {ParseBitOrExpr procedure, valid LHS "^" subexpr} { + testexprparser {1^2 | 3} -1 +} {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-5.2 {ParseBitOrExpr procedure, error in LHS "^" subexpr} { + list [catch {testexprparser {1|foo | 3} -1} msg] $msg +} {1 {syntax error in expression "1|foo | 3"}} +test parseExpr-5.3 {ParseBitOrExpr procedure, next lexeme isn't "|"} { + testexprparser {1^2? 1 : 0} -1 +} {- {} 0 subexpr {1^2? 1 : 0} 11 operator ? 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-5.4 {ParseBitOrExpr procedure, next lexeme is "|"} { + testexprparser {1^2 | 3} -1 +} {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-5.5 {ParseBitOrExpr procedure, bad lexeme after "|"} {nonPortable} { + list [catch {testexprparser {1^2 | 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-5.6 {ParseBitOrExpr procedure, valid RHS subexpression} { + testexprparser {1^2 | 3 | 4} -1 +} {- {} 0 subexpr {1^2 | 3 | 4} 13 operator | 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-5.7 {ParseBitOrExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1^2 | 3 | martha} -1} msg] $msg +} {1 {syntax error in expression "1^2 | 3 | martha"}} + +test parseExpr-6.1 {ParseBitXorExpr procedure, valid LHS "&" subexpr} { + testexprparser {1&2 ^ 3} -1 +} {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-6.2 {ParseBitXorExpr procedure, error in LHS "&" subexpr} { + list [catch {testexprparser {1^foo ^ 3} -1} msg] $msg +} {1 {syntax error in expression "1^foo ^ 3"}} +test parseExpr-6.3 {ParseBitXorExpr procedure, next lexeme isn't "^"} { + testexprparser {1&2? 1 : 0} -1 +} {- {} 0 subexpr {1&2? 1 : 0} 11 operator ? 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-6.4 {ParseBitXorExpr procedure, next lexeme is "^"} { + testexprparser {1&2 ^ 3} -1 +} {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-6.5 {ParseBitXorExpr procedure, bad lexeme after "^"} {nonPortable} { + list [catch {testexprparser {1&2 ^ 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-6.6 {ParseBitXorExpr procedure, valid RHS subexpression} { + testexprparser {1&2 ^ 3 ^ 4} -1 +} {- {} 0 subexpr {1&2 ^ 3 ^ 4} 13 operator ^ 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-6.7 {ParseBitXorExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1&2 ^ 3 ^ martha} -1} msg] $msg +} {1 {syntax error in expression "1&2 ^ 3 ^ martha"}} + +test parseExpr-7.1 {ParseBitAndExpr procedure, valid LHS equality subexpr} { + testexprparser {1==2 & 3} -1 +} {- {} 0 subexpr {1==2 & 3} 9 operator & 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-7.2 {ParseBitAndExpr procedure, error in LHS equality subexpr} { + list [catch {testexprparser {1!=foo & 3} -1} msg] $msg +} {1 {syntax error in expression "1!=foo & 3"}} +test parseExpr-7.3 {ParseBitAndExpr procedure, next lexeme isn't "&"} { + testexprparser {1==2? 1 : 0} -1 +} {- {} 0 subexpr {1==2? 1 : 0} 11 operator ? 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-7.4 {ParseBitAndExpr procedure, next lexeme is "&"} { + testexprparser {1>2 & 3} -1 +} {- {} 0 subexpr {1>2 & 3} 9 operator & 0 subexpr 1>2 5 operator > 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-7.5 {ParseBitAndExpr procedure, bad lexeme after "&"} {nonPortable} { + list [catch {testexprparser {1==2 & 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-7.6 {ParseBitAndExpr procedure, valid RHS subexpression} { + testexprparser {1<2 & 3 & 4} -1 +} {- {} 0 subexpr {1<2 & 3 & 4} 13 operator & 0 subexpr {1<2 & 3} 9 operator & 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-7.7 {ParseBitAndExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1==2 & 3>2 & martha} -1} msg] $msg +} {1 {syntax error in expression "1==2 & 3>2 & martha"}} + +test parseExpr-7.1 {ParseEqualityExpr procedure, valid LHS relational subexpr} { + testexprparser {1<2 == 3} -1 +} {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-7.2 {ParseEqualityExpr procedure, error in LHS relational subexpr} { + list [catch {testexprparser {1>=foo == 3} -1} msg] $msg +} {1 {syntax error in expression "1>=foo == 3"}} +test parseExpr-7.3 {ParseEqualityExpr procedure, next lexeme isn't "==" or "!="} { + testexprparser {1<2? 1 : 0} -1 +} {- {} 0 subexpr {1<2? 1 : 0} 11 operator ? 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-7.4 {ParseEqualityExpr procedure, next lexeme is "==" or "!=} { + testexprparser {1<2 == 3} -1 +} {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-7.5 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} { + testexprparser {1<2 != 3} -1 +} {- {} 0 subexpr {1<2 != 3} 9 operator != 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-7.6 {ParseEqualityExpr procedure, bad lexeme after "==" or "!="} {nonPortable} { + list [catch {testexprparser {1<2 == 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-7.7 {ParseEqualityExpr procedure, valid RHS subexpression} { + testexprparser {1<2 == 3 == 4} -1 +} {- {} 0 subexpr {1<2 == 3 == 4} 13 operator == 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-7.8 {ParseEqualityExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1<2 == 3 != martha} -1} msg] $msg +} {1 {syntax error in expression "1<2 == 3 != martha"}} + +test parseExpr-8.1 {ParseRelationalExpr procedure, valid LHS shift subexpr} { + testexprparser {1<<2 < 3} -1 +} {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-8.2 {ParseRelationalExpr procedure, error in LHS shift subexpr} { + list [catch {testexprparser {1>=foo < 3} -1} msg] $msg +} {1 {syntax error in expression "1>=foo < 3"}} +test parseExpr-8.3 {ParseRelationalExpr procedure, next lexeme isn't relational op} { + testexprparser {1<<2? 1 : 0} -1 +} {- {} 0 subexpr {1<<2? 1 : 0} 11 operator ? 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-8.4 {ParseRelationalExpr procedure, next lexeme is relational op} { + testexprparser {1<<2 < 3} -1 +} {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-8.5 {ParseRelationalExpr procedure, next lexeme is relational op} { + testexprparser {1>>2 > 3} -1 +} {- {} 0 subexpr {1>>2 > 3} 9 operator > 0 subexpr 1>>2 5 operator >> 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-8.6 {ParseRelationalExpr procedure, next lexeme is relational op} { + testexprparser {1<<2 <= 3} -1 +} {- {} 0 subexpr {1<<2 <= 3} 9 operator <= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-8.7 {ParseRelationalExpr procedure, next lexeme is relational op} { + testexprparser {1<<2 >= 3} -1 +} {- {} 0 subexpr {1<<2 >= 3} 9 operator >= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-8.8 {ParseRelationalExpr procedure, bad lexeme after relational op} {nonPortable} { + list [catch {testexprparser {1<<2 < 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-8.9 {ParseRelationalExpr procedure, valid RHS subexpression} { + testexprparser {1<<2 < 3 < 4} -1 +} {- {} 0 subexpr {1<<2 < 3 < 4} 13 operator < 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-8.8 {ParseRelationalExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1<<2 < 3 > martha} -1} msg] $msg +} {1 {syntax error in expression "1<<2 < 3 > martha"}} + +test parseExpr-9.1 {ParseShiftExpr procedure, valid LHS add subexpr} { + testexprparser {1+2 << 3} -1 +} {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-9.2 {ParseShiftExpr procedure, error in LHS add subexpr} { + list [catch {testexprparser {1-foo << 3} -1} msg] $msg +} {1 {syntax error in expression "1-foo << 3"}} +test parseExpr-9.3 {ParseShiftExpr procedure, next lexeme isn't "<<" or ">>"} { + testexprparser {1+2? 1 : 0} -1 +} {- {} 0 subexpr {1+2? 1 : 0} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-9.4 {ParseShiftExpr procedure, next lexeme is "<<" or ">>} { + testexprparser {1+2 << 3} -1 +} {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-9.5 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} { + testexprparser {1+2 >> 3} -1 +} {- {} 0 subexpr {1+2 >> 3} 9 operator >> 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-9.6 {ParseShiftExpr procedure, bad lexeme after "<<" or ">>"} {nonPortable} { + list [catch {testexprparser {1+2 << 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-9.7 {ParseShiftExpr procedure, valid RHS subexpression} { + testexprparser {1+2 << 3 << 4} -1 +} {- {} 0 subexpr {1+2 << 3 << 4} 13 operator << 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-9.8 {ParseShiftExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1+2 << 3 >> martha} -1} msg] $msg +} {1 {syntax error in expression "1+2 << 3 >> martha"}} + +test parseExpr-10.1 {ParseAddExpr procedure, valid LHS multiply subexpr} { + testexprparser {1*2 + 3} -1 +} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-10.2 {ParseAddExpr procedure, error in LHS multiply subexpr} { + list [catch {testexprparser {1/foo + 3} -1} msg] $msg +} {1 {syntax error in expression "1/foo + 3"}} +test parseExpr-10.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} { + testexprparser {1*2? 1 : 0} -1 +} {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-10.4 {ParseAddExpr procedure, next lexeme is "+" or "-} { + testexprparser {1*2 + 3} -1 +} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-10.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} { + testexprparser {1*2 - 3} -1 +} {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-10.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {nonPortable} { + list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-10.7 {ParseAddExpr procedure, valid RHS subexpression} { + testexprparser {1*2 + 3 + 4} -1 +} {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-10.8 {ParseAddExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg +} {1 {syntax error in expression "1*2 + 3 - martha"}} + +test parseExpr-10.1 {ParseAddExpr procedure, valid LHS multiply subexpr} { + testexprparser {1*2 + 3} -1 +} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-10.2 {ParseAddExpr procedure, error in LHS multiply subexpr} { + list [catch {testexprparser {1/foo + 3} -1} msg] $msg +} {1 {syntax error in expression "1/foo + 3"}} +test parseExpr-10.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} { + testexprparser {1*2? 1 : 0} -1 +} {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-10.4 {ParseAddExpr procedure, next lexeme is "+" or "-} { + testexprparser {1*2 + 3} -1 +} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-10.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} { + testexprparser {1*2 - 3} -1 +} {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-10.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {nonPortable} { + list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-10.7 {ParseAddExpr procedure, valid RHS subexpression} { + testexprparser {1*2 + 3 + 4} -1 +} {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-10.8 {ParseAddExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg +} {1 {syntax error in expression "1*2 + 3 - martha"}} + +test parseExpr-11.1 {ParseMultiplyExpr procedure, valid LHS unary subexpr} { + testexprparser {+2 * 3} -1 +} {- {} 0 subexpr {+2 * 3} 7 operator * 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-11.2 {ParseMultiplyExpr procedure, error in LHS unary subexpr} {nonPortable} { + list [catch {testexprparser {-12345678901234567890 * 3} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-11.3 {ParseMultiplyExpr procedure, next lexeme isn't "*", "/", or "%"} { + testexprparser {+2? 1 : 0} -1 +} {- {} 0 subexpr {+2? 1 : 0} 9 operator ? 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-11.4 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} { + testexprparser {-123 * 3} -1 +} {- {} 0 subexpr {-123 * 3} 7 operator * 0 subexpr -123 3 operator - 0 subexpr 123 1 text 123 0 subexpr 3 1 text 3 0 {}} +test parseExpr-11.5 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} { + testexprparser {+-456 / 3} -1 +} {- {} 0 subexpr {+-456 / 3} 9 operator / 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}} +test parseExpr-11.6 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} { + testexprparser {+-456 % 3} -1 +} {- {} 0 subexpr {+-456 % 3} 9 operator % 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}} +test parseExpr-11.7 {ParseMultiplyExpr procedure, bad lexeme after "*", "/", or "%"} {nonPortable} { + list [catch {testexprparser {--++5 / 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-11.8 {ParseMultiplyExpr procedure, valid RHS subexpression} { + testexprparser {-2 / 3 % 4} -1 +} {- {} 0 subexpr {-2 / 3 % 4} 11 operator % 0 subexpr {-2 / 3} 7 operator / 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} +test parseExpr-11.9 {ParseMultiplyExpr procedure, error in RHS subexpression} { + list [catch {testexprparser {++2 / 3 * martha} -1} msg] $msg +} {1 {syntax error in expression "++2 / 3 * martha"}} + +test parseExpr-12.1 {ParseUnaryExpr procedure, first token is unary operator} { + testexprparser {+2} -1 +} {- {} 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 {}} +test parseExpr-12.2 {ParseUnaryExpr procedure, first token is unary operator} { + testexprparser {-2} -1 +} {- {} 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 {}} +test parseExpr-12.3 {ParseUnaryExpr procedure, first token is unary operator} { + testexprparser {~2} -1 +} {- {} 0 subexpr ~2 3 operator ~ 0 subexpr 2 1 text 2 0 {}} +test parseExpr-12.4 {ParseUnaryExpr procedure, first token is unary operator} { + testexprparser {!2} -1 +} {- {} 0 subexpr !2 3 operator ! 0 subexpr 2 1 text 2 0 {}} +test parseExpr-12.5 {ParseUnaryExpr procedure, error in lexeme after unary op} {nonPortable} { + list [catch {testexprparser {-12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-12.6 {ParseUnaryExpr procedure, simple unary expr after unary op} { + testexprparser {+"1234"} -1 +} {- {} 0 subexpr +\"1234\" 3 operator + 0 subexpr {"1234"} 1 text 1234 0 {}} +test parseExpr-12.7 {ParseUnaryExpr procedure, another unary expr after unary op} { + testexprparser {~!{fred}} -1 +} {- {} 0 subexpr ~!{fred} 5 operator ~ 0 subexpr !{fred} 3 operator ! 0 subexpr {{fred}} 1 text fred 0 {}} +test parseExpr-12.8 {ParseUnaryExpr procedure, error in unary expr after unary op} { + list [catch {testexprparser {+-||27} -1} msg] $msg +} {1 {syntax error in expression "+-||27"}} +test parseExpr-12.9 {ParseUnaryExpr procedure, error in unary expr after unary op} { + list [catch {testexprparser {+-||27} -1} msg] $msg +} {1 {syntax error in expression "+-||27"}} +test parseExpr-12.10 {ParseUnaryExpr procedure, first token is not unary op} { + testexprparser {123} -1 +} {- {} 0 subexpr 123 1 text 123 0 {}} +test parseExpr-12.11 {ParseUnaryExpr procedure, not unary expr, complex primary expr} { + testexprparser {(1+2)} -1 +} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-12.12 {ParseUnaryExpr procedure, not unary expr, error in primary expr} {nonPortable} { + list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg +} {1 {integer value too large to represent}} + +test parseExpr-13.1 {ParsePrimaryExpr procedure, just parenthesized subexpr} { + testexprparser {({abc}/{def})} -1 +} {- {} 0 subexpr {{abc}/{def}} 5 operator / 0 subexpr {{abc}} 1 text abc 0 subexpr {{def}} 1 text def 0 {}} +test parseExpr-13.2 {ParsePrimaryExpr procedure, bad lexeme after "("} {nonPortable} { + list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-13.3 {ParsePrimaryExpr procedure, valid parenthesized subexpr} { + testexprparser {({abc}? 2*4 : -6)} -1 +} {- {} 0 subexpr {{abc}? 2*4 : -6} 13 operator ? 0 subexpr {{abc}} 1 text abc 0 subexpr 2*4 5 operator * 0 subexpr 2 1 text 2 0 subexpr 4 1 text 4 0 subexpr -6 3 operator - 0 subexpr 6 1 text 6 0 {}} +test parseExpr-13.4 {ParsePrimaryExpr procedure, error in parenthesized subexpr} { + list [catch {testexprparser {(? 123 : 456)} -1} msg] $msg +} {1 {syntax error in expression "(? 123 : 456)"}} +test parseExpr-13.5 {ParsePrimaryExpr procedure, missing ")" after in parenthesized subexpr} { + list [catch {testexprparser {({abc}/{def}} -1} msg] $msg +} {1 {syntax error in expression "({abc}/{def}"}} +test parseExpr-13.6 {ParsePrimaryExpr procedure, primary is literal} { + testexprparser {12345} -1 +} {- {} 0 subexpr 12345 1 text 12345 0 {}} +test parseExpr-13.7 {ParsePrimaryExpr procedure, primary is literal} { + testexprparser {12345.6789} -1 +} {- {} 0 subexpr 12345.6789 1 text 12345.6789 0 {}} +test parseExpr-13.8 {ParsePrimaryExpr procedure, primary is var reference} { + testexprparser {$a} -1 +} {- {} 0 subexpr {$a} 2 variable {$a} 1 text a 0 {}} +test parseExpr-13.9 {ParsePrimaryExpr procedure, primary is var reference} { + testexprparser {$a(hello$there)} -1 +} {- {} 0 subexpr {$a(hello$there)} 5 variable {$a(hello$there)} 4 text a 0 text hello 0 variable {$there} 1 text there 0 {}} +test parseExpr-13.10 {ParsePrimaryExpr procedure, primary is var reference} { + testexprparser {$a()} -1 +} {- {} 0 subexpr {$a()} 3 variable {$a()} 2 text a 0 text {} 0 {}} +test parseExpr-13.11 {ParsePrimaryExpr procedure, error in var reference} { + list [catch {testexprparser {$a(} -1} msg] $msg +} {1 {missing )}} +test parseExpr-13.12 {ParsePrimaryExpr procedure, primary is quoted string} { + testexprparser {"abc $xyz def"} -1 +} {- {} 0 subexpr {"abc $xyz def"} 5 word {"abc $xyz def"} 4 text {abc } 0 variable {$xyz} 1 text xyz 0 text { def} 0 {}} +test parseExpr-13.13 {ParsePrimaryExpr procedure, error in quoted string} { + list [catch {testexprparser {"$a(12"} -1} msg] $msg +} {1 {missing )}} +test parseExpr-13.14 {ParsePrimaryExpr procedure, quoted string has multiple tokens} { + testexprparser {"abc [xyz] $def"} -1 +} {- {} 0 subexpr {"abc [xyz] $def"} 6 word {"abc [xyz] $def"} 5 text {abc } 0 command {[xyz]} 0 text { } 0 variable {$def} 1 text def 0 {}} +test parseExpr-13.15 {ParsePrimaryExpr procedure, primary is command} { + testexprparser {[def]} -1 +} {- {} 0 subexpr {[def]} 1 command {[def]} 0 {}} +test parseExpr-13.16 {ParsePrimaryExpr procedure, primary is multiple commands} { + testexprparser {[one; two; three; four;]} -1 +} {- {} 0 subexpr {[one; two; three; four;]} 1 command {[one; two; three; four;]} 0 {}} +test parseExpr-13.17 {ParsePrimaryExpr procedure, primary is multiple commands} { + testexprparser {[one; two; three; four;]} -1 +} {- {} 0 subexpr {[one; two; three; four;]} 1 command {[one; two; three; four;]} 0 {}} +test parseExpr-13.18 {ParsePrimaryExpr procedure, missing close bracket} { + list [catch {testexprparser {[one} -1} msg] $msg +} {1 {missing close-bracket}} +test parseExpr-13.19 {ParsePrimaryExpr procedure, primary is braced string} { + testexprparser {{hello world}} -1 +} {- {} 0 subexpr {{hello world}} 1 text {hello world} 0 {}} +test parseExpr-13.20 {ParsePrimaryExpr procedure, error in primary, which is braced string} { + list [catch {testexprparser "\{abc\\\n" -1} msg] $msg +} {1 {missing close-brace}} +test parseExpr-13.21 {ParsePrimaryExpr procedure, primary is braced string with multiple tokens} { + testexprparser "\{ \\ + +123 \}" -1 +} {- {} 0 subexpr \{\ \ \\\n\ +123\ \} 4 word \{\ \ \\\n\ +123\ \} 3 text { } 0 backslash \\\n\ 0 text {+123 } 0 {}} +test parseExpr-13.22 {ParsePrimaryExpr procedure, primary is function call} { + testexprparser {foo(123)} -1 +} {- {} 0 subexpr foo(123) 3 operator foo 0 subexpr 123 1 text 123 0 {}} +test parseExpr-13.23 {ParsePrimaryExpr procedure, bad lexeme after function name} {nonPortable} { + list [catch {testexprparser {foo 12345678901234567890 123)} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-13.24 {ParsePrimaryExpr procedure, lexeme after function name isn't "("} { + list [catch {testexprparser {foo 27.4 123)} -1} msg] $msg +} {1 {syntax error in expression "foo 27.4 123)"}} +test parseExpr-13.25 {ParsePrimaryExpr procedure, bad lexeme after "("} {nonPortable} { + list [catch {testexprparser {foo(12345678901234567890)} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-13.26 {ParsePrimaryExpr procedure, function call, one arg} { + testexprparser {foo(27*4)} -1 +} {- {} 0 subexpr foo(27*4) 7 operator foo 0 subexpr 27*4 5 operator * 0 subexpr 27 1 text 27 0 subexpr 4 1 text 4 0 {}} +test parseExpr-13.27 {ParsePrimaryExpr procedure, error in function arg} { + list [catch {testexprparser {foo(*1-2)} -1} msg] $msg +} {1 {syntax error in expression "foo(*1-2)"}} +test parseExpr-13.28 {ParsePrimaryExpr procedure, error in function arg} { + list [catch {testexprparser {foo(*1-2)} -1} msg] $msg +} {1 {syntax error in expression "foo(*1-2)"}} +test parseExpr-13.29 {ParsePrimaryExpr procedure, function call, comma after arg} { + testexprparser {foo(27-2, (-2*[foo]))} -1 +} {- {} 0 subexpr {foo(27-2, (-2*[foo]))} 15 operator foo 0 subexpr 27-2 5 operator - 0 subexpr 27 1 text 27 0 subexpr 2 1 text 2 0 subexpr {-2*[foo]} 7 operator * 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr {[foo]} 1 command {[foo]} 0 {}} +test parseExpr-13.30 {ParsePrimaryExpr procedure, bad lexeme after comma} {nonPortable} { + list [catch {testexprparser {foo(123, 12345678901234567890)} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-13.31 {ParsePrimaryExpr procedure, lexeme not "," or ")" after arg} { + list [catch {testexprparser {foo(123 [foo])} -1} msg] $msg +} {1 {syntax error in expression "foo(123 [foo])"}} +test parseExpr-13.32 {ParsePrimaryExpr procedure, bad lexeme after primary} {nonPortable} { + list [catch {testexprparser {123 12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} + +test parseExpr-14.1 {GetLexeme procedure, whitespace before lexeme} { + testexprparser { 123} -1 +} {- {} 0 subexpr 123 1 text 123 0 {}} +test parseExpr-14.2 {GetLexeme procedure, whitespace before lexeme} { + testexprparser { \ +456} -1 +} {- {} 0 subexpr 456 1 text 456 0 {}} +test parseExpr-14.3 {GetLexeme procedure, no lexeme after whitespace} { + testexprparser { 123 \ + } -1 +} {- {} 0 subexpr 123 1 text 123 0 {}} +test parseExpr-14.4 {GetLexeme procedure, integer lexeme} { + testexprparser {000} -1 +} {- {} 0 subexpr 000 1 text 000 0 {}} +test parseExpr-14.5 {GetLexeme procedure, integer lexeme too big} {nonPortable} { + list [catch {testexprparser {12345678901234567890} -1} msg] $msg +} {1 {integer value too large to represent}} +test parseExpr-14.6 {GetLexeme procedure, bad integer lexeme} { + list [catch {testexprparser {0999} -1} msg] $msg +} {1 {syntax error in expression "0999"}} +test parseExpr-14.7 {GetLexeme procedure, double lexeme} { + testexprparser {0.999} -1 +} {- {} 0 subexpr 0.999 1 text 0.999 0 {}} +test parseExpr-14.8 {GetLexeme procedure, double lexeme} { + testexprparser {.123} -1 +} {- {} 0 subexpr .123 1 text .123 0 {}} +test parseExpr-14.9 {GetLexeme procedure, double lexeme} {nonPortable unixOnly} { + testexprparser {nan} -1 +} {- {} 0 subexpr nan 1 text nan 0 {}} +test parseExpr-14.10 {GetLexeme procedure, double lexeme} {nonPortable unixOnly} { + testexprparser {NaN} -1 +} {- {} 0 subexpr NaN 1 text NaN 0 {}} +test parseExpr-14.11 {GetLexeme procedure, bad double lexeme too big} { + list [catch {testexprparser {123.e+99999999999999} -1} msg] $msg +} {1 {floating-point value too large to represent}} +test parseExpr-14.12 {GetLexeme procedure, bad double lexeme} { + list [catch {testexprparser {123.4x56} -1} msg] $msg +} {1 {syntax error in expression "123.4x56"}} +test parseExpr-14.13 {GetLexeme procedure, lexeme is "["} { + testexprparser {[foo]} -1 +} {- {} 0 subexpr {[foo]} 1 command {[foo]} 0 {}} +test parseExpr-14.14 {GetLexeme procedure, lexeme is open brace} { + testexprparser {{bar}} -1 +} {- {} 0 subexpr {{bar}} 1 text bar 0 {}} +test parseExpr-14.15 {GetLexeme procedure, lexeme is "("} { + testexprparser {(123)} -1 +} {- {} 0 subexpr 123 1 text 123 0 {}} +test parseExpr-14.16 {GetLexeme procedure, lexeme is ")"} { + testexprparser {(2*3)} -1 +} {- {} 0 subexpr 2*3 5 operator * 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.17 {GetLexeme procedure, lexeme is "$"} { + testexprparser {$wombat} -1 +} {- {} 0 subexpr {$wombat} 2 variable {$wombat} 1 text wombat 0 {}} +test parseExpr-14.18 {GetLexeme procedure, lexeme is '"'} { + testexprparser {"fred"} -1 +} {- {} 0 subexpr {"fred"} 1 text fred 0 {}} +test parseExpr-14.19 {GetLexeme procedure, lexeme is ","} { + testexprparser {foo(1,2)} -1 +} {- {} 0 subexpr foo(1,2) 5 operator foo 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-14.20 {GetLexeme procedure, lexeme is "*"} { + testexprparser {$a*$b} -1 +} {- {} 0 subexpr {$a*$b} 7 operator * 0 subexpr {$a} 2 variable {$a} 1 text a 0 subexpr {$b} 2 variable {$b} 1 text b 0 {}} +test parseExpr-14.21 {GetLexeme procedure, lexeme is "/"} { + testexprparser {5/6} -1 +} {- {} 0 subexpr 5/6 5 operator / 0 subexpr 5 1 text 5 0 subexpr 6 1 text 6 0 {}} +test parseExpr-14.22 {GetLexeme procedure, lexeme is "%"} { + testexprparser {5%[xxx]} -1 +} {- {} 0 subexpr {5%[xxx]} 5 operator % 0 subexpr 5 1 text 5 0 subexpr {[xxx]} 1 command {[xxx]} 0 {}} +test parseExpr-14.23 {GetLexeme procedure, lexeme is "+"} { + testexprparser {1+2} -1 +} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-14.24 {GetLexeme procedure, lexeme is "-"} { + testexprparser {.12-0e27} -1 +} {- {} 0 subexpr .12-0e27 5 operator - 0 subexpr .12 1 text .12 0 subexpr 0e27 1 text 0e27 0 {}} +test parseExpr-14.25 {GetLexeme procedure, lexeme is "?" or ":"} { + testexprparser {$b? 1 : 0} -1 +} {- {} 0 subexpr {$b? 1 : 0} 8 operator ? 0 subexpr {$b} 2 variable {$b} 1 text b 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} +test parseExpr-14.26 {GetLexeme procedure, lexeme is "<"} { + testexprparser {2<3} -1 +} {- {} 0 subexpr 2<3 5 operator < 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.27 {GetLexeme procedure, lexeme is "<<"} { + testexprparser {2<<3} -1 +} {- {} 0 subexpr 2<<3 5 operator << 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.28 {GetLexeme procedure, lexeme is "<="} { + testexprparser {2<=3} -1 +} {- {} 0 subexpr 2<=3 5 operator <= 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.29 {GetLexeme procedure, lexeme is ">"} { + testexprparser {2>3} -1 +} {- {} 0 subexpr 2>3 5 operator > 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.30 {GetLexeme procedure, lexeme is ">>"} { + testexprparser {2>>3} -1 +} {- {} 0 subexpr 2>>3 5 operator >> 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.31 {GetLexeme procedure, lexeme is ">="} { + testexprparser {2>=3} -1 +} {- {} 0 subexpr 2>=3 5 operator >= 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.32 {GetLexeme procedure, lexeme is "=="} { + testexprparser {2==3} -1 +} {- {} 0 subexpr 2==3 5 operator == 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.33 {GetLexeme procedure, bad lexeme starting with "="} { + list [catch {testexprparser {2=+3} -1} msg] $msg +} {1 {syntax error in expression "2=+3"}} +test parseExpr-14.34 {GetLexeme procedure, lexeme is "!="} { + testexprparser {2!=3} -1 +} {- {} 0 subexpr 2!=3 5 operator != 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.35 {GetLexeme procedure, lexeme is "!"} { + testexprparser {!2} -1 +} {- {} 0 subexpr !2 3 operator ! 0 subexpr 2 1 text 2 0 {}} +test parseExpr-14.36 {GetLexeme procedure, lexeme is "&&"} { + testexprparser {2&&3} -1 +} {- {} 0 subexpr 2&&3 5 operator && 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.37 {GetLexeme procedure, lexeme is "&"} { + testexprparser {1&2} -1 +} {- {} 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-14.38 {GetLexeme procedure, lexeme is "^"} { + testexprparser {1^2} -1 +} {- {} 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-14.39 {GetLexeme procedure, lexeme is "||"} { + testexprparser {2||3} -1 +} {- {} 0 subexpr 2||3 5 operator || 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.40 {GetLexeme procedure, lexeme is "|"} { + testexprparser {1|2} -1 +} {- {} 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} +test parseExpr-14.41 {GetLexeme procedure, lexeme is "~"} { + testexprparser {~2} -1 +} {- {} 0 subexpr ~2 3 operator ~ 0 subexpr 2 1 text 2 0 {}} +test parseExpr-14.42 {GetLexeme procedure, lexeme is func name} { + testexprparser {george()} -1 +} {- {} 0 subexpr george() 1 operator george 0 {}} +test parseExpr-14.43 {GetLexeme procedure, lexeme is func name} { + testexprparser {harmonic_ratio(2,3)} -1 +} {- {} 0 subexpr harmonic_ratio(2,3) 5 operator harmonic_ratio 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} +test parseExpr-14.44 {GetLexeme procedure, unknown lexeme} { + list [catch {testexprparser {@27} -1} msg] $msg +} {1 {syntax error in expression "@27"}} + +test parseExpr-15.1 {PrependSubExprTokens procedure, expand token array} { + testexprparser {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} -1 +} {- {} 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 13 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 9 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 5 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 {}} + +test parse-16.1 {LogSyntaxError procedure, error in expr longer than 60 chars} { + list [catch {testexprparser {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1} msg] $msg +} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012"}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/parseOld.test b/tests/parseOld.test new file mode 100644 index 0000000..3f799d6 --- /dev/null +++ b/tests/parseOld.test @@ -0,0 +1,546 @@ +# Commands covered: set (plus basic command syntax). Also tests the +# procedures in the file tclOldParse.c. This set of tests is an old +# one that predates the new parser in Tcl 8.1. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: parseOld.test,v 1.2 1999/04/16 00:47:32 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +proc fourArgs {a b c d} { + global arg1 arg2 arg3 arg4 + set arg1 $a + set arg2 $b + set arg3 $c + set arg4 $d +} + +proc getArgs args { + global argv + set argv $args +} + +# Basic argument parsing. + +test parseOld-1.1 {basic argument parsing} { + set arg1 {} + fourArgs a b c d + list $arg1 $arg2 $arg3 $arg4 +} {a b c d} +test parseOld-1.2 {basic argument parsing} { + set arg1 {} + eval "fourArgs 123\v4\f56\r7890" + list $arg1 $arg2 $arg3 $arg4 +} {123 4 56 7890} + +# Quotes. + +test parseOld-2.1 {quotes and variable-substitution} { + getArgs "a b c" d + set argv +} {{a b c} d} +test parseOld-2.2 {quotes and variable-substitution} { + set a 101 + getArgs "a$a b c" + set argv +} {{a101 b c}} +test parseOld-2.3 {quotes and variable-substitution} { + set argv "xy[format xabc]" + set argv +} {xyxabc} +test parseOld-2.4 {quotes and variable-substitution} { + set argv "xy\t" + set argv +} xy\t +test parseOld-2.5 {quotes and variable-substitution} { + set argv "a b c +d e f" + set argv +} a\ b\tc\nd\ e\ f +test parseOld-2.6 {quotes and variable-substitution} { + set argv a"bcd"e + set argv +} {a"bcd"e} + +# Braces. + +test parseOld-3.1 {braces} { + getArgs {a b c} d + set argv +} "{a b c} d" +test parseOld-3.2 {braces} { + set a 101 + set argv {a$a b c} + set b [string index $argv 1] + set b +} {$} +test parseOld-3.3 {braces} { + set argv {a[format xyz] b} + string length $argv +} 15 +test parseOld-3.4 {braces} { + set argv {a\nb\}} + string length $argv +} 6 +test parseOld-3.5 {braces} { + set argv {{{{}}}} + set argv +} "{{{}}}" +test parseOld-3.6 {braces} { + set argv a{{}}b + set argv +} "a{{}}b" +test parseOld-3.7 {braces} { + set a [format "last]"] + set a +} {last]} + +# Command substitution. + +test parseOld-4.1 {command substitution} { + set a [format xyz] + set a +} xyz +test parseOld-4.2 {command substitution} { + set a a[format xyz]b[format q] + set a +} axyzbq +test parseOld-4.3 {command substitution} { + set a a[ +set b 22; +format %s $b + +]b + set a +} a22b +test parseOld-4.4 {command substitution} { + set a 7.7 + if [catch {expr int($a)}] {set a foo} + set a +} 7.7 + +# Variable substitution. + +test parseOld-5.1 {variable substitution} { + set a 123 + set b $a + set b +} 123 +test parseOld-5.2 {variable substitution} { + set a 345 + set b x$a.b + set b +} x345.b +test parseOld-5.3 {variable substitution} { + set _123z xx + set b $_123z^ + set b +} xx^ +test parseOld-5.4 {variable substitution} { + set a 78 + set b a${a}b + set b +} a78b +test parseOld-5.5 {variable substitution} {catch {$_non_existent_} msg} 1 +test parseOld-5.6 {variable substitution} { + catch {$_non_existent_} msg + set msg +} {can't read "_non_existent_": no such variable} +test parseOld-5.7 {array variable substitution} { + catch {unset a} + set a(xyz) 123 + set b $a(xyz)foo + set b +} 123foo +test parseOld-5.8 {array variable substitution} { + catch {unset a} + set "a(x y z)" 123 + set b $a(x y z)foo + set b +} 123foo +test parseOld-5.9 {array variable substitution} { + catch {unset a}; catch {unset qqq} + set "a(x y z)" qqq + set $a([format x]\ y [format z]) foo + set qqq +} foo +test parseOld-5.10 {array variable substitution} { + catch {unset a} + list [catch {set b $a(22)} msg] $msg +} {1 {can't read "a(22)": no such variable}} +test parseOld-5.11 {array variable substitution} { + set b a$! + set b +} {a$!} +test parseOld-5.12 {array variable substitution} { + set b a$() + set b +} {a$()} +catch {unset a} +test parseOld-5.13 {array variable substitution} { + catch {unset a} + set long {This is a very long variable, long enough to cause storage \ + allocation to occur in Tcl_ParseVar. If that storage isn't getting \ + freed up correctly, then a core leak will occur when this test is \ + run. This text is probably beginning to sound like drivel, but I've \ + run out of things to say and I need more characters still.} + set a($long) 777 + set b $a($long) + list $b [array names a] +} {777 {{This is a very long variable, long enough to cause storage \ + allocation to occur in Tcl_ParseVar. If that storage isn't getting \ + freed up correctly, then a core leak will occur when this test is \ + run. This text is probably beginning to sound like drivel, but I've \ + run out of things to say and I need more characters still.}}} +test parseOld-5.14 {array variable substitution} { + catch {unset a}; catch {unset b}; catch {unset a1} + set a1(22) foo + set a(foo) bar + set b $a($a1(22)) + set b +} bar +catch {unset a}; catch {unset a1} + +test parseOld-7.1 {backslash substitution} { + set a "\a\c\n\]\}" + string length $a +} 5 +test parseOld-7.2 {backslash substitution} { + set a {\a\c\n\]\}} + string length $a +} 10 +test parseOld-7.3 {backslash substitution} { + set a "abc\ +def" + set a +} {abc def} +test parseOld-7.4 {backslash substitution} { + set a {abc\ +def} + set a +} {abc def} +test parseOld-7.5 {backslash substitution} { + set msg {} + set a xxx + set error [catch {if {24 < \ + 35} {set a 22} {set \ + a 33}} msg] + list $error $msg $a +} {0 22 22} +test parseOld-7.6 {backslash substitution} { + eval "concat abc\\" +} "abc\\" +test parseOld-7.7 {backslash substitution} { + eval "concat \\\na" +} "a" +test parseOld-7.8 {backslash substitution} { + eval "concat x\\\n a" +} "x a" +test parseOld-7.9 {backslash substitution} { + eval "concat \\x" +} "x" +test parseOld-7.10 {backslash substitution} { + eval "list a b\\\nc d" +} {a b c d} +test parseOld-7.11 {backslash substitution} { + eval "list a \"b c\"\\\nd e" +} {a {b c} d e} +test parseOld-7.12 {backslash substitution} { + list \ua2 +} [bytestring "\xc2\xa2"] +test parseOld-7.13 {backslash substitution} { + list \u4e21 +} [bytestring "\xe4\xb8\xa1"] +test parseOld-7.14 {backslash substitution} { + list \u4e2k +} [bytestring "\xd3\xa2k"] + +# Semi-colon. + +test parseOld-8.1 {semi-colons} { + set b 0 + getArgs a;set b 2 + set argv +} a +test parseOld-8.2 {semi-colons} { + set b 0 + getArgs a;set b 2 + set b +} 2 +test parseOld-8.3 {semi-colons} { + getArgs a b ; set b 1 + set argv +} {a b} +test parseOld-8.4 {semi-colons} { + getArgs a b ; set b 1 + set b +} 1 + +# The following checks are to ensure that the interpreter's result +# gets re-initialized by Tcl_Eval in all the right places. + +test parseOld-9.1 {result initialization} {concat abc} abc +test parseOld-9.2 {result initialization} {concat abc; proc foo {} {}} {} +test parseOld-9.3 {result initialization} {concat abc; proc foo {} $a} {} +test parseOld-9.4 {result initialization} {proc foo {} [concat abc]} {} +test parseOld-9.5 {result initialization} {concat abc; } abc +test parseOld-9.6 {result initialization} { + eval { + concat abc +}} abc +test parseOld-9.7 {result initialization} {} {} +test parseOld-9.8 {result initialization} {concat abc; ; ;} abc + +# Syntax errors. + +test parseOld-10.1 {syntax errors} {catch "set a \{bcd" msg} 1 +test parseOld-10.2 {syntax errors} { + catch "set a \{bcd" msg + set msg +} {missing close-brace} +test parseOld-10.3 {syntax errors} {catch {set a "bcd} msg} 1 +test parseOld-10.4 {syntax errors} { + catch {set a "bcd} msg + set msg +} {missing "} +test parseOld-10.5 {syntax errors} {catch {set a "bcd"xy} msg} 1 +test parseOld-10.6 {syntax errors} { + catch {set a "bcd"xy} msg + set msg +} {extra characters after close-quote} +test parseOld-10.7 {syntax errors} {catch "set a {bcd}xy" msg} 1 +test parseOld-10.8 {syntax errors} { + catch "set a {bcd}xy" msg + set msg +} {extra characters after close-brace} +test parseOld-10.9 {syntax errors} {catch {set a [format abc} msg} 1 +test parseOld-10.10 {syntax errors} { + catch {set a [format abc} msg + set msg +} {missing close-bracket} +test parseOld-10.11 {syntax errors} {catch gorp-a-lot msg} 1 +test parseOld-10.12 {syntax errors} { + catch gorp-a-lot msg + set msg +} {invalid command name "gorp-a-lot"} +test parseOld-10.13 {syntax errors} { + set a [concat {a}\ + {b}] + set a +} {a b} +test parseOld-10.14 {syntax errors} { + list [catch {eval \$x[format "%01000d" 0](} msg] $msg $errorInfo +} {1 {missing )} {missing ) + while compiling +"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000..." + ("eval" body line 1) + invoked from within +"eval \$x[format "%01000d" 0]("}} +test parseOld-10.15 {syntax errors, missplaced braces} { + catch { + proc misplaced_end_brace {} { + set what foo + set when [expr ${what}size - [set off$what]}] + } msg + set msg +} {extra characters after close-brace} +test parseOld-10.16 {syntax errors, missplaced braces} { + catch { + set a { + set what foo + set when [expr ${what}size - [set off$what]}] + } msg + set msg +} {extra characters after close-brace} +test parseOld-10.17 {syntax errors, unusual spacing} { + list [catch {return [ [1]]} msg] $msg +} {1 {invalid command name "1"}} +# Long values (stressing storage management) + +set a {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH} + +test parseOld-11.1 {long values} { + string length $a +} 214 +test parseOld-11.2 {long values} { + llength $a +} 43 +test parseOld-11.3 {long values} { + set b "1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH" + set b +} $a +test parseOld-11.4 {long values} { + set b "$a" + set b +} $a +test parseOld-11.5 {long values} { + set b [set a] + set b +} $a +test parseOld-11.6 {long values} { + set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] + string length $b +} 214 +test parseOld-11.7 {long values} { + set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] + llength $b +} 43 +test parseOld-11.8 {long values} { + set b +} $a +test parseOld-11.9 {long values} { + set a [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] + llength $a +} 62 +set i 0 +foreach j [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] { + set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i] + set test $test$test$test$test + set i [expr $i+1] + test parseOld-11.10 {long values} { + set j + } $test +} +test parseOld-11.11 {test buffer overflow in backslashes in braces} { + expr {"a" == {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101}} +} 0 + +test parseOld-12.1 {comments} { + set a old + eval { # set a new} + set a +} {old} +test parseOld-12.2 {comments} { + set a old + eval " # set a new\nset a new" + set a +} {new} +test parseOld-12.3 {comments} { + set a old + eval " # set a new\\\nset a new" + set a +} {old} +test parseOld-12.4 {comments} { + set a old + eval " # set a new\\\\\nset a new" + set a +} {new} + +test parseOld-13.1 {comments at the end of a bracketed script} { + set x "[ +expr 1+1 +# skip this! +]" +} {2} + +if {[info command testwordend] == "testwordend"} { + test parseOld-14.1 {TclWordEnd procedure} { + testwordend " \n abc" + } {c} + test parseOld-14.2 {TclWordEnd procedure} { + testwordend " \\\n" + } {} + test parseOld-14.3 {TclWordEnd procedure} { + testwordend " \\\n " + } { } + test parseOld-14.4 {TclWordEnd procedure} { + testwordend {"abc"} + } {"} + test parseOld-14.5 {TclWordEnd procedure} { + testwordend {{xyz}} + } \} + test parseOld-14.6 {TclWordEnd procedure} { + testwordend {{a{}b{}\}} xyz} + } "\} xyz" + test parseOld-14.7 {TclWordEnd procedure} { + testwordend {abc[this is a]def ghi} + } {f ghi} + test parseOld-14.8 {TclWordEnd procedure} { + testwordend "puts\\\n\n " + } "s\\\n\n " + test parseOld-14.9 {TclWordEnd procedure} { + testwordend "puts\\\n " + } "s\\\n " + test parseOld-14.10 {TclWordEnd procedure} { + testwordend "puts\\\n xyz" + } "s\\\n xyz" + test parseOld-14.11 {TclWordEnd procedure} { + testwordend {a$x.$y(a long index) foo} + } ") foo" + test parseOld-14.12 {TclWordEnd procedure} { + testwordend {abc; def} + } {; def} + test parseOld-14.13 {TclWordEnd procedure} { + testwordend {abc def} + } {c def} + test parseOld-14.14 {TclWordEnd procedure} { + testwordend {abc def} + } {c def} + test parseOld-14.15 {TclWordEnd procedure} { + testwordend "abc\ndef" + } "c\ndef" + test parseOld-14.16 {TclWordEnd procedure} { + testwordend "abc" + } {c} + test parseOld-14.17 {TclWordEnd procedure} { + testwordend "a\000bc" + } {c} + test parseOld-14.18 {TclWordEnd procedure} { + testwordend \[a\000\] + } {]} + test parseOld-14.19 {TclWordEnd procedure} { + testwordend \"a\000\" + } {"} + test parseOld-14.20 {TclWordEnd procedure} { + testwordend a{\000}b + } {b} + test parseOld-14.21 {TclWordEnd procedure} { + testwordend " \000b" + } {b} +} + +test parseOld-15.1 {TclScriptEnd procedure} { + info complete {puts [ + expr 1+1 + #this is a comment ]} +} {0} +test parseOld-15.2 {TclScriptEnd procedure} { + info complete "abc\\\n" +} {0} +test parseOld-15.3 {TclScriptEnd procedure} { + info complete "abc\\\\\n" +} {1} +test parseOld-15.4 {TclScriptEnd procedure} { + info complete "xyz \[abc \{abc\]" +} {0} +test parseOld-15.5 {TclScriptEnd procedure} { + info complete "xyz \[abc" +} {0} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/pid.test b/tests/pid.test index c93237f..3f8275b 100644 --- a/tests/pid.test +++ b/tests/pid.test @@ -6,21 +6,25 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: pid.test,v 1.2 1998/09/14 18:40:12 stanton Exp $ +# RCS: @(#) $Id: pid.test,v 1.3 1999/04/16 00:47:32 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # 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" + ::tcltest::cleanupTests return } -if {[string compare test [info procs test]] == 1} then {source defs} - catch {removeFile test1} test pid-1.1 {pid command} { @@ -48,5 +52,19 @@ test pid-1.5 {pid command} { list [catch {pid gorp} msg] $msg } {1 {can not find channel named "gorp"}} -catch {removeFile test1} -concat {} +# cleanup +catch {::tcltest::removeFile test1} +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/pkg.test b/tests/pkg.test index d379eb8..02ffc14 100644 --- a/tests/pkg.test +++ b/tests/pkg.test @@ -5,23 +5,24 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: pkg.test,v 1.3 1999/03/10 05:52:51 stanton Exp $ +# RCS: @(#) $Id: pkg.test,v 1.4 1999/04/16 00:47:32 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # 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 [list set argv $argv] +interp eval $i [list source [file join $::tcltest::testsDir defs.tcl]] 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 {} @@ -483,7 +484,7 @@ test pkg-3.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { } {0} test pkg-3.53 {Tcl_PackageCmd procedure, "versions" option} { list [catch {package foo} msg] $msg -} {1 {bad option "foo": should be forget, ifneeded, names, present, provide, require, unknown, vcompare, versions, or vsatisfies}} +} {1 {bad option "foo": must be forget, ifneeded, names, present, provide, require, unknown, vcompare, versions, or vsatisfies}} # No tests for FindPackage; can't think up anything detectable # errors. @@ -632,4 +633,20 @@ package unknown $oldPkgUnknown concat } + +# cleanup interp delete $i +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/pkg/import.tcl b/tests/pkg/import.tcl new file mode 100644 index 0000000..e7196f5 --- /dev/null +++ b/tests/pkg/import.tcl @@ -0,0 +1,16 @@ +package provide fubar 1.0 + +namespace eval ::fubar:: { + # + # export only public functions. + # + namespace export {[a-z]*} +} + +proc ::fubar::foo {bar} { + puts "$bar" + return true +} + +namespace import ::fubar::foo + diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index 5b14989..e49cf25 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -5,20 +5,33 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 1998 by Scriptics Corporation. +# Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: pkgMkIndex.test,v 1.5 1999/03/31 22:37:17 welch Exp $ +# RCS: @(#) $Id: pkgMkIndex.test,v 1.6 1999/04/16 00:47:32 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +# temporarily copy the pkg and pkg1 dirs from testsDir to tmpDir +if {"$::tcltest::testsDir" != "$::tcltest::workingDir"} { + set origPkgDir [file join $::tcltest::testsDir pkg] + set newPkgDir [file join $::tcltest::workingDir pkg] + if {![catch {file copy $origPkgDir $newPkgDir}]} { + set removePkgDir 1 + } + if {![catch {file copy "${origPkgDir}1" "${newPkgDir}1"}]} { + set removePkg1Dir 1 + } +} # Add the pkg1 directory to auto_path, so that its packages can be found. # packages in pkg1 are used to test indexing of packages in pkg. # Make sure that the path to pkg1 is absolute. -set scriptDir [file dirname [info script]] set oldDir [pwd] -lappend auto_path [file join [pwd] $scriptDir pkg1] +lappend auto_path [file join $::tcltest::workingDir pkg1] namespace eval pkgtest { # Namespace for procs we can discard @@ -316,20 +329,19 @@ test pkgMkIndex-9.1 {circular packages} { pkgtest::runIndex pkg circ1.tcl circ2.tcl circ3.tcl } {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}} -# Try to find one of the DLLs in the dltest directory -set x [file join [pwd] [file dirname [info script]]] -set x [file join $x ../unix/dltest/pkga[info sharedlibextension]] -if {[file exists $x]} { +# Some tests require the existence of one of the DLLs in the dltest directory +set x [file join [file dirname [info nameofexecutable]] dltest \ + pkga[info sharedlibextension]] +set dll "[file tail $x]Required" +set ::tcltest::testConfig($dll) [file exists $x] + +test pkgMkIndex-10.1 {package in DLL and script} $dll { file copy -force $x pkg - test pkgMkIndex-10.1 {package in DLL and script} { - pkgtest::runIndex pkg pkga[info sharedlibextension] pkga.tcl - } {0 {{Pkga:1.0 {tclPkgSetup {pkga.so load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}} - test pkgMkIndex-10.2 {package in DLL hidden by -load} { - pkgtest::runIndex -load Pkg* -- pkg pkga[info sharedlibextension] - } {0 {}} -} else { - puts "Skipping pkgMkIndex-10.1 (index of DLL and script)" -} + pkgtest::runIndex pkg pkga[info sharedlibextension] pkga.tcl +} "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}" +test pkgMkIndex-10.2 {package in DLL hidden by -load} $dll { + pkgtest::runIndex -load Pkg* -- pkg pkga[info sharedlibextension] +} {0 {}} # Tolerate "namespace import" at the global scope @@ -337,11 +349,27 @@ test pkgMkIndex-11.1 {conflicting namespace imports} { pkgtest::runIndex pkg import.tcl } {0 {{fubar:1.0 {tclPkgSetup {import.tcl source ::fubar::foo}}}}} - -# # cleanup -# -if {![info exist TESTS]} { - file delete [file join pkg pkgIndex.tcl] - namespace delete pkgtest +namespace delete pkgtest +cd $::tcltest::workingDir +if {[info exists removePkgDir]} { + # strange error deleting the pkg dir only once--needs be done twice! + catch {file delete -force $newPkgDir} + catch {file delete -force $newPkgDir} +} +if {[info exists removePkg1Dir]} { + catch {file delete -force "${newPkgDir}1"} } +::tcltest::cleanupTests +return + + + + + + + + + + + diff --git a/tests/platform.test b/tests/platform.test index f5273b2..b81103c 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -11,10 +11,29 @@ # # RCS: @(#) -if {[info procs test] != "test"} {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test platform-1.1 {TclpSetVariables: tcl_platform} { - lsort [array names tcl_platform] -} {byteOrder machine os osVersion platform} + interp create i + i eval {catch {unset tcl_platform(debug)}} + set result [i eval {lsort [array names tcl_platform]}] + interp delete i + set result +} {byteOrder machine os osVersion platform user} +# cleanup +::tcltest::cleanupTests return + + + + + + + + + + + diff --git a/tests/proc-old.test b/tests/proc-old.test index 07310f4..a57e147 100644 --- a/tests/proc-old.test +++ b/tests/proc-old.test @@ -9,13 +9,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: proc-old.test,v 1.2 1998/09/14 18:40:12 stanton Exp $ +# RCS: @(#) $Id: proc-old.test,v 1.3 1999/04/16 00:47:32 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {rename t1 ""} catch {rename foo ""} @@ -501,5 +504,20 @@ test proc-old-10.1 {ByteCode epoch change during recursive proc execution} { t1 1 } 20 +# cleanup catch {rename t1 ""} catch {rename foo ""} +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/proc.test b/tests/proc.test index 478d15f..60f5d8e 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -8,13 +8,16 @@ # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: proc.test,v 1.3 1998/10/05 22:32:11 escoffon Exp $ +# RCS: @(#) $Id: proc.test,v 1.4 1999/04/16 00:47:32 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename p ""} @@ -165,6 +168,7 @@ catch {unset msg} if {[catch {package require procbodytest}]} { puts "This application couldn't load the \"procbodytest\" package, so I" puts "can't test creation of procs whose bodies have type \"procbody\"." + ::tcltest::cleanupTests return } @@ -289,5 +293,20 @@ test proc-4.7 {TclCreateProc, procbody obj, inconsitent arg default value} { set result } {procedure "t": formal parameter "z" has default value inconsistent with precompiled body} +# cleanup catch {rename p ""} catch {rename t ""} +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/pwd.test b/tests/pwd.test index ae827f9..0656b63 100644 --- a/tests/pwd.test +++ b/tests/pwd.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: pwd.test,v 1.2 1998/09/14 18:40:12 stanton Exp $ +# RCS: @(#) $Id: pwd.test,v 1.3 1999/04/16 00:47:32 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test pwd-1.1 {simple pwd} { catch pwd @@ -20,3 +23,19 @@ test pwd-1.1 {simple pwd} { test pwd-1.2 {simple pwd} { expr [string length pwd]>0 } 1 + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/reg.test b/tests/reg.test new file mode 100644 index 0000000..de20e33 --- /dev/null +++ b/tests/reg.test @@ -0,0 +1,905 @@ +# reg.test -- +# +# 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) 1998-1999 by Scriptics Corporation. +# All rights reserved. +# +# RCS: @(#) $Id: reg.test,v 1.2 1999/04/16 00:47:33 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +# All tests require the testregexp command, return if this +# command doesn't exist + +set ::tcltest::testConfig(testregexp) \ + [expr {[info commands testregexp] != {}}] + +# This file uses some custom procedures, defined below, for regexp regression +# testing. The name of the procedure indicates the general nature of the +# test: e for compile error expected, f for match failure expected, m +# for a successful match, and i for a successful match with -indices (used +# in checking things like nonparticipating subexpressions). There is also +# a "doing" procedure which sets up title and major test number for each +# block of tests, and an "xx" procedure which ignores its arguments and +# arranges for the next invocation of "doing" to announce that some tests +# were bypassed (which is better than just commenting them out). + +# The first 3 arguments are constant: a minor number (which often gets +# a letter or two suffixed to it internally), some flags, and the RE itself. +# For e, the remaining argument is the name of the compile error expected, +# less the leading "REG_". For the rest, the next argument is the string +# to try the match against. Remaining arguments are the substring expected +# to be matched, and any substrings expected to be matched by subexpressions. +# (For f, these arguments are optional, and if present are ignored except +# that they indicate how many subexpressions should be presents in the RE.) +# It is an error for the number of subexpression arguments to be wrong. +# Cases involving nonparticipating subexpressions, checking where empty +# substrings are located, etc. should be done using i. + +# The flag characters are complex and a bit eclectic. Generally speaking, +# lowercase letters are compile options, uppercase are expected re_info +# bits, and nonalphabetics are match options, controls for how the test is +# run, or testing options. The one small surprise is that AREs are the +# default, and you must explicitly request lesser flavors of RE. The flags +# are as follows. It is admitted that some are not very mnemonic. +# There are some others which are purely debugging tools and are not +# useful in this file. +# +# - no-op (placeholder) +# + provide fake xy equivalence class +# % force small state-set cache in matcher (to test cache replace) +# ^ beginning of string is not beginning of line +# $ end of string is not end of line +# +# & test as both ARE and BRE +# b BRE +# e ERE +# a turn advanced-features bit on (error unless ERE already) +# q literal string, no metacharacters at all +# +# i case-independent matching +# o ("opaque") no subexpression capture +# p newlines are half-magic, excluded from . and [^ only +# w newlines are half-magic, significant to ^ and $ only +# n newlines are fully magic, both effects +# x expanded RE syntax +# +# A backslash-_a_lphanumeric seen +# B ERE/ARE literal-_b_race heuristic used +# E backslash (_e_scape) seen within [] +# H looka_h_ead constraint seen +# I _i_mpossible to match +# L _l_ocale-specific construct seen +# M unportable (_m_achine-specific) construct seen +# N RE can match empty (_n_ull) string +# P non-_P_OSIX construct seen +# Q {} _q_uantifier seen +# R back _r_eference seen +# S POSIX-un_s_pecified syntax seen +# U saw original-POSIX botch: unmatched right paren in ERE (_u_gh) + +# The one area we can't easily test is memory-allocation failures (which +# are hard to provoke on command). Embedded NULs also are not tested at +# the moment, but this is a historical accident which should be fixed. + + + +# test procedures and related + +set ask "about" +set xflags "xflags" +set testbypassed 0 + +# re_info abbreviation mapping table +set infonames(A) "REG_UBSALNUM" +set infonames(B) "REG_UBRACES" +set infonames(E) "REG_UBBS" +set infonames(H) "REG_ULOOKAHEAD" +set infonames(I) "REG_UIMPOSSIBLE" +set infonames(L) "REG_ULOCALE" +set infonames(M) "REG_UUNPORT" +set infonames(N) "REG_UEMPTYMATCH" +set infonames(P) "REG_UNONPOSIX" +set infonames(Q) "REG_UBOUNDS" +set infonames(R) "REG_UBACKREF" +set infonames(S) "REG_UUNSPEC" +set infonames(U) "REG_UPBOTCH" +set infonameorder "RHQBAUEPSMLNI" ;# must match bit order, lsb first + +# set major test number and description +proc doing {major desc} { + global prefix description testbypassed + + if {$testbypassed != 0} { + puts stdout "!!! bypassed $testbypassed tests in\ + $major, `$description'" + } + + set prefix reg-$major + set description "reg $desc" + set testbypassed 0 +} + +# build test number (internal) +proc tno {testid} { + return [lindex $testid 0] +} + +# build description, with possible modifiers (internal) +proc desc {testid} { + global description + + set d $description + if {[llength $testid] > 1} { + set d "([lreplace $testid 0 0]) $d" + } + return $d +} + +# build trailing options and flags argument from a flags string (internal) +proc flags {fl} { + global xflags + + set args [list] + set flags "" + foreach f [split $fl ""] { + switch -exact -- $f { + "i" { lappend args "-nocase" } + "x" { lappend args "-expanded" } + "n" { lappend args "-line" } + "p" { lappend args "-linestop" } + "w" { lappend args "-lineanchor" } + "-" { } + default { append flags $f } + } + } + if {[string compare $flags ""] != 0} { + lappend args -$xflags $flags + } + return $args +} + +# build info-flags list from a flags string (internal) +proc infoflags {fl} { + global infonames infonameorder + + set ret [list] + foreach f [split $infonameorder ""] { + if {[string first $f $fl] >= 0} { + lappend ret $infonames($f) + } + } + return $ret +} + +# compilation error expected +proc e {testid flags re err} { + global prefix ask errorCode + + # if &, test as both ARE and BRE + set amp [string first "&" $flags] + if {$amp >= 0} { + set f [string range $flags 0 [expr $amp - 1]] + append f [string range $flags [expr $amp + 1] end] + e [linsert $testid end ARE] ${f} $re $err + e [linsert $testid end BRE] ${f}b $re $err + return + } + + set cmd [concat [list testregexp -$ask] [flags $flags] [list $re]] + set run "list \[catch \{$cmd\}\] \[lindex \$errorCode 1\]" + test $prefix.[tno $testid] [desc $testid] {testregexp} $run [list 1 REG_$err] +} + +# match failure expected +proc f {testid flags re target args} { + global prefix description ask + + # if &, test as both ARE and BRE + set amp [string first "&" $flags] + if {$amp >= 0} { + set f [string range $flags 0 [expr $amp - 1]] + append f [string range $flags [expr $amp + 1] end] + eval [linsert $args 0 f [linsert $testid end ARE] ${f} $re \ + $target] + eval [linsert $args 0 f [linsert $testid end BRE] ${f}b $re \ + $target] + return + } + + set f [flags $flags] + set infoflags [infoflags $flags] + set ccmd [concat [list testregexp -$ask] $f [list $re]] + set nsub [expr [llength $args] - 1] + if {$nsub == -1} { + # didn't tell us number of subexps + set ccmd "lreplace \[$ccmd\] 0 0" + set info [list $infoflags] + } else { + set info [list $nsub $infoflags] + } + lappend testid "compile" + test $prefix.[tno $testid] [desc $testid] {testregexp} $ccmd $info + + set testid [lreplace $testid end end "execute"] + set ecmd [concat [list testregexp] $f [list $re $target]] + test $prefix.[tno $testid] [desc $testid] {testregexp} $ecmd 0 +} + +# match expected, internal routine that does the work +# parameters like the "real" routines except they don't have "opts", +# which is a possibly-empty list of switches for the regexp match attempt +proc matchexpected {opts testid flags re target args} { + global prefix description ask + + # if &, test as both BRE and ARE + set amp [string first "&" $flags] + if {$amp >= 0} { + set f [string range $flags 0 [expr $amp - 1]] + append f [string range $flags [expr $amp + 1] end] + eval [concat [list matchexpected $opts \ + [linsert $testid end ARE] ${f} $re $target] $args] + eval [concat [list matchexpected $opts \ + [linsert $testid end BRE] ${f}b $re $target] $args] + return + } + + set f [flags $flags] + set infoflags [infoflags $flags] + set ccmd [concat [list testregexp -$ask] $f [list $re]] + set ecmd [concat [list testregexp] $opts $f [list $re $target]] + + set nsub [expr [llength $args] - 1] + set names [list] + set refs "" + for {set i 0} {$i <= $nsub} {incr i} { + if {$i == 0} { + set name match + } else { + set name sub$i + } + lappend names $name + append refs " \$$name" + set $name "" + } + if {[string first "o" $flags] >= 0} { ;# REG_NOSUB + set nsub 0 ;# unsigned value cannot be -1 + } + set ecmd [concat $ecmd $names] + set erun "list \[$ecmd\] $refs" + set result [concat [list 1] $args] + + set info [list $nsub $infoflags] + lappend testid "compile" + test $prefix.[tno $testid] [desc $testid] {testregexp} $ccmd $info + set testid [lreplace $testid end end "execute"] + test $prefix.[tno $testid] [desc $testid] {testregexp} $erun $result +} + +# match expected (no missing, empty, or ambiguous submatches) +# m testno flags re target mat submat ... +proc m {args} { + eval matchexpected [linsert $args 0 [list]] +} + +# match expected (full fanciness) +# i testno flags re target mat submat ... +proc i {args} { + eval matchexpected [linsert $args 0 [list "-indices"]] +} + +# test temporarily unimplemented +proc xx {args} { + global testbypassed + + incr testbypassed +} + + + +# the tests themselves + + + +# support functions and preliminary misc. +# This is sensitive to changes in message wording, but we really have to +# test the code->message expansion at least once. +test regexp-0.1 "regexp error reporting" { + list [catch {regexp (*) ign} msg] $msg +} {1 {couldn't compile regular expression pattern: quantifier operand invalid}} + + + +doing 1 "basic sanity checks" +m 1 & abc abc abc +f 2 & abc def +m 3 & abc xyabxabce abc + + + +doing 2 "invalid option combinations" +e 1 qe a INVARG +e 2 qa a INVARG +e 3 qx a INVARG +e 4 qn a INVARG +e 5 ba a INVARG + + + +doing 3 "basic syntax" +i 1 &NS "" a {0 -1} +m 2 NS a| a a +m 3 - a|b a a +m 4 - a|b b b +m 5 NS a||b b b +m 6 & ab ab ab + + + +doing 4 "parentheses" +m 1 - (a)e ae ae a +m 2 o (a)e ae +m 3 b {\(a\)b} ab ab a +m 4 - a((b)c) abc abc bc b +m 5 - a(b)(c) abc abc b c +e 6 - a(b EPAREN +e 7 b {a\(b} EPAREN +# sigh, we blew it on the specs here... someday this will be fixed in POSIX, +# but meanwhile, it's fixed in AREs +m 8 eU a)b a)b a)b +e 9 - a)b EPAREN +e 10 b {a\)b} EPAREN +m 11 P a(?:b)c abc abc +e 12 e a(?:b)c BADRPT +i 13 S a()b ab {0 1} {1 0} +m 14 SP a(?:)b ab ab +i 15 S a(|b)c ac {0 1} {1 0} +m 16 S a(b|)c abc abc b + + + +doing 5 "simple one-char matching" +# general case of brackets done later +m 1 & a.b axb axb +f 2 &n "a.b" "a\nb" +m 3 & {a[bc]d} abd abd +m 4 & {a[bc]d} acd acd +f 5 & {a[bc]d} aed +f 6 & {a[^bc]d} abd +m 7 & {a[^bc]d} aed aed +f 8 &p "a\[^bc]d" "a\nd" + + + +doing 6 "context-dependent syntax" +# plus odds and ends +e 1 - * BADRPT +m 2 b * * * +m 3 b {\(*\)} * * * +e 4 - (*) BADRPT +m 5 b ^* * * +e 6 - ^* BADRPT +f 7 & ^b ^b +m 8 b x^ x^ x^ +f 9 I x^ x +m 10 n "\n^" "x\nb" "\n" +f 11 bS {\(^b\)} ^b +m 12 - (^b) b b b +m 13 & {x$} x x +m 14 bS {\(x$\)} x x x +m 15 - {(x$)} x x x +m 16 b {x$y} "x\$y" "x\$y" +f 17 I {x$y} xy +m 18 n "x\$\n" "x\n" "x\n" +e 19 - + BADRPT +e 20 - ? BADRPT + + + +doing 7 "simple quantifiers" +m 1 &N a* aa aa +i 2 &N a* b {0 -1} +m 3 - a+ aa aa +m 4 - a?b ab ab +m 5 - a?b b b +e 6 - ** BADRPT +m 7 bN ** *** *** +e 8 & a** BADRPT +e 9 & a**b BADRPT +e 10 & *** BADRPT +e 11 * a++ BADRPT +e 12 * a?+ BADRPT +e 13 * a?* BADRPT +e 14 * a+* BADRPT +e 15 * a*+ BADRPT + + + +doing 8 "braces" +m 1 NQ "a{0,1}" "" "" +m 2 NQ "a{0,1}" ac a +e 3 - "a{1,0}" BADBR +e 4 - "a{1,2,3}" BADBR +e 5 - "a{257}" BADBR +e 6 - "a{1000}" BADBR +e 7 - "a{1" EBRACE +e 8 - "a{1n}" BADBR +m 9 BS "a{b" "a\{b" "a\{b" +m 10 BS "a{" "a\{" "a\{" +m 11 bQ {a\{0,1\}b} cb b +e 12 b {a\{0,1} EBRACE +e 13 - "a{0,1\\" BADBR +m 14 Q "a{0}b" ab b +m 15 Q "a{0,0}b" ab b +m 16 Q "a{0,1}b" ab ab +m 17 Q "a{0,2}b" b b +m 18 Q "a{0,2}b" aab aab +m 19 Q "a{0,}b" aab aab +m 20 Q "a{1,1}b" aab ab +m 21 Q "a{1,3}b" aaaab aaab +f 22 Q "a{1,3}b" b +m 23 Q "a{1,}b" aab aab +f 24 Q "a{2,3}b" ab +m 25 Q "a{2,3}b" aaaab aaab +f 26 Q "a{2,}b" ab +m 27 Q "a{2,}b" aaaab aaaab + + + +doing 9 "brackets" +m 1 & {a[bc]} ac ac +m 2 & {a[-]} a- a- +m 3 & {a[[.-.]]} a- a- +m 4 &L {a[[.zero.]]} a0 a0 +m 5 &LM {a[[.zero.]-9]} a2 a2 +m 6 &M {a[0-[.9.]]} a2 a2 +m 7 &+L {a[[=x=]]} ax ax +m 8 &+L {a[[=x=]]} ay ay +f 9 &+L {a[[=x=]]} az +e 10 & {a[0-[=x=]]} ERANGE +m 11 &L {a[[:digit:]]} a0 a0 +e 12 & {a[[:woopsie:]]} ECTYPE +f 13 &L {a[[:digit:]]} ab +e 14 & {a[0-[:digit:]]} ERANGE +m 15 &LP {[[:<:]]a} a a +m 16 &LP {a[[:>:]]} a a +e 17 & {a[[..]]b} ECOLLATE +e 18 & {a[[==]]b} ECOLLATE +e 19 & {a[[::]]b} ECTYPE +e 20 & {a[[.a} EBRACK +e 21 & {a[[=a} EBRACK +e 22 & {a[[:a} EBRACK +e 23 & {a[} EBRACK +e 24 & {a[b} EBRACK +e 25 & {a[b-} EBRACK +e 26 & {a[b-c} EBRACK +m 27 &M {a[b-c]} ab ab +m 28 & {a[b-b]} ab ab +m 29 &M {a[1-2]} a2 a2 +e 30 & {a[c-b]} ERANGE +e 31 & {a[a-b-c]} ERANGE +m 32 &M {a[--?]b} a?b a?b +m 33 & {a[---]b} a-b a-b +m 34 & {a[]b]c} a]c a]c +m 35 EP {a[\]]b} a]b a]b +f 36 bE {a[\]]b} a]b +m 37 bE {a[\]]b} "a\\]b" "a\\]b" +m 38 eE {a[\]]b} "a\\]b" "a\\]b" +m 39 EP {a[\\]b} "a\\b" "a\\b" +m 40 eE {a[\\]b} "a\\b" "a\\b" +m 41 bE {a[\\]b} "a\\b" "a\\b" +e 42 - {a[\Z]b} EESCAPE +m 43 & {a[[b]c} "a\[c" "a\[c" +m 44 EMP {a[\u00fe-\u0507][\u00ff-\u0300]b} \ + "a\u0102\u02ffb" "a\u0102\u02ffb" + + + +doing 10 "anchors and newlines" +m 1 & ^a a a +f 2 &^ ^a a +i 3 &N ^ a {0 -1} +i 4 & {a$} aba {2 2} +f 5 {&$} {a$} a +i 6 &N {$} ab {2 1} +m 7 &n ^a a a +m 8 &n "^a" "b\na" "a" +i 9 &w "^a" "a\na" {0 0} +i 10 &n^ "^a" "a\na" {2 2} +m 11 &n {a$} a a +m 12 &n "a\$" "a\nb" "a" +i 13 &n "a\$" "a\na" {0 0} +i 14 N ^^ a {0 -1} +m 15 b ^^ ^ ^ +i 16 N {$$} a {1 0} +m 17 b {$$} "\$" "\$" +m 18 &N {^$} "" "" +f 19 &N {^$} a +i 20 &nN "^\$" "a\n\nb" {2 1} +m 21 N {$^} "" "" +m 22 b {$^} "\$^" "\$^" +m 23 P {\Aa} a a +m 24 ^P {\Aa} a a +f 25 ^nP {\Aa} "b\na" +m 26 P {a\Z} a a +m 27 {$P} {a\Z} a a +f 28 {$nP} {a\Z} "a\nb" +e 29 - ^* BADRPT +e 30 - {$*} BADRPT +e 31 - {\A*} BADRPT +e 32 - {\Z*} BADRPT + + + +doing 11 "boundary constraints" +m 1 &LP {[[:<:]]a} a a +m 2 &LP {[[:<:]]a} -a a +f 3 &LP {[[:<:]]a} ba +m 4 &LP {a[[:>:]]} a a +m 5 &LP {a[[:>:]]} a- a +f 6 &LP {a[[:>:]]} ab +m 7 bLP {\<a} a a +f 8 bLP {\<a} ba +m 9 bLP {a\>} a a +f 10 bLP {a\>} ab +m 11 LP {\ya} a a +f 12 LP {\ya} ba +m 13 LP {a\y} a a +f 14 LP {a\y} ab +m 15 LP {a\Y} ab a +f 16 LP {a\Y} a- +f 17 LP {a\Y} a +f 18 LP {-\Y} -a +m 19 LP {-\Y} -% - +f 20 LP {\Y-} a- +e 21 - {[[:<:]]*} BADRPT +e 22 - {[[:>:]]*} BADRPT +e 23 b {\<*} BADRPT +e 24 b {\>*} BADRPT +e 25 - {\y*} BADRPT +e 26 - {\Y*} BADRPT +m 27 LP {\ma} a a +f 28 LP {\ma} ba +m 29 LP {a\M} a a +f 30 LP {a\M} ab +f 31 ILP {\Ma} a +f 32 ILP {a\m} a + + + +doing 12 "character classes" +m 1 LP {a\db} a0b a0b +f 2 LP {a\db} axb +f 3 LP {a\Db} a0b +m 4 LP {a\Db} axb axb +m 5 LP "a\\sb" "a b" "a b" +m 6 LP "a\\sb" "a\tb" "a\tb" +m 7 LP "a\\sb" "a\nb" "a\nb" +f 8 LP {a\sb} axb +m 9 LP {a\Sb} axb axb +f 10 LP "a\\Sb" "a b" +m 11 LP {a\wb} axb axb +f 12 LP {a\wb} a-b +f 13 LP {a\Wb} axb +m 14 LP {a\Wb} a-b a-b +m 15 LP {\y\w+z\y} adze-guz guz +m 16 LPE {a[\d]b} a1b a1b +m 17 LPE "a\[\\s]b" "a b" "a b" +m 18 LPE {a[\w]b} axb axb + + + +doing 13 "escapes" +e 1 & "a\\" EESCAPE +m 2 - {a\<b} a<b a<b +m 3 e {a\<b} a<b a<b +m 4 bAS {a\wb} awb awb +m 5 eAS {a\wb} awb awb +m 6 PL "a\\ab" "a\007b" "a\007b" +m 7 P "a\\bb" "a\bb" "a\bb" +m 8 P {a\Bb} "a\\b" "a\\b" +m 9 MP "a\\chb" "a\bb" "a\bb" +m 10 MP "a\\cHb" "a\bb" "a\bb" +m 11 LMP "a\\e" "a\033" "a\033" +m 12 P "a\\fb" "a\fb" "a\fb" +m 13 P "a\\nb" "a\nb" "a\nb" +m 14 P "a\\rb" "a\rb" "a\rb" +m 15 P "a\\tb" "a\tb" "a\tb" +m 16 P "a\\u0008x" "a\bx" "a\bx" +e 17 - {a\u008x} EESCAPE +m 18 P "a\\u00088x" "a\b8x" "a\b8x" +m 19 P "a\\U00000008x" "a\bx" "a\bx" +e 20 - {a\U0000008x} EESCAPE +m 21 P "a\\vb" "a\vb" "a\vb" +m 22 MP "a\\x08x" "a\bx" "a\bx" +e 23 - {a\xq} EESCAPE +m 24 MP "a\\x0008x" "a\bx" "a\bx" +e 25 - {a\z} EESCAPE +m 26 MP "a\\010b" "a\bb" "a\bb" + + + +doing 14 "back references" +# ugh +m 1 {R[1P} {a(b*)c\1} abbcbb abbcbb bb +m 2 {R[1P} {a(b*)c\1} ac ac "" +f 3 {R[1P} {a(b*)c\1} abbcb +m 4 {R[1P} {a(b*)\1} abbcbb abb b +m 5 {R[1P} {a(b|bb)\1} abbcbb abb b +m 6 {R[1P} {a([bc])\1} abb abb b +f 7 {R[1P} {a([bc])\1} abc +m 8 {R[1P} {a([bc])\1} abcabb abb b +f 9 {R[1P} {a([bc])*\1} abc +f 10 {R[1P} {a([bc])\1} abB +m 11 {iR[1P} {a([bc])\1} abB abB b +m 12 {R[1P} {a([bc])\1+} abbb abbb b +m 13 {QR[1P} "a(\[bc])\\1{3,4}" abbbb abbbb b +f 14 {QR[1P} "a(\[bc])\\1{3,4}" abbb +m 15 {R[1P} {a([bc])\1*} abbb abbb b +m 16 {R[1P} {a([bc])\1*} ab ab b +m 17 {R[2P} {a([bc])(\1*)} ab ab b "" +e 18 - {a((b)\1)} ESUBREG +e 19 - {a(b)c\2} ESUBREG +m 20 {bR[1} {a\(b*\)c\1} abbcbb abbcbb bb + + + +doing 15 "octal escapes vs back references" +# initial zero is always octal +m 1 MP "a\\010b" "a\bb" "a\bb" +m 2 MP "a\\0070b" "a\0070b" "a\0070b" +m 3 MP "a\\07b" "a\007b" "a\007b" +m 4 MP "a(b)(b)(b)(b)(b)(b)(b)(b)(b)(b)\\07c" "abbbbbbbbbb\007c" \ + "abbbbbbbbbb\007c" "b" "b" "b" "b" "b" "b" \ + "b" "b" "b" "b" +# a single digit is always a backref +e 5 - {a\7b} ESUBREG +# otherwise it's a backref only if within range (barf!) +m 6 MP "a\\10b" "a\bb" "a\bb" +m 7 MP {a\101b} aAb aAb +m 8 RP {a(b)(b)(b)(b)(b)(b)(b)(b)(b)(b)\10c} abbbbbbbbbbbc \ + abbbbbbbbbbbc b b b b b b b \ + b b b +# but we're fussy about border cases -- guys who want octal should use the zero +e 9 - {a((((((((((b\10))))))))))c} ESUBREG +# BREs don't have octal, EREs don't have backrefs +m 10 MP "a\\12b" "a\nb" "a\nb" +e 11 b {a\12b} ESUBREG +m 12 eAS {a\12b} a12b a12b + + + +doing 16 "expanded syntax" +m 1 xP "a b c" "abc" "abc" +m 2 xP "a b #oops\nc\td" "abcd" "abcd" +m 3 x "a\\ b\\\tc" "a b\tc" "a b\tc" +m 4 xP "a b\\#c" "ab#c" "ab#c" +m 5 xP "a b\[c d]e" "ab e" "ab e" +m 6 xP "a b\[c#d]e" "ab#e" "ab#e" +m 7 xP "a b\[c#d]e" "abde" "abde" +m 8 xSPB "ab{ d" "ab\{d" "ab\{d" +m 9 xPQ "ab{ 1 , 2 }c" "abc" "abc" + + + +doing 17 "misc syntax" +m 1 P a(?#comment)b ab ab + + + +doing 18 "unmatchable REs" +f 1 I a^b ab + + + +doing 19 "case independence" +m 1 &i ab Ab Ab +m 2 &i {a[bc]} aC aC +f 3 &i {a[^bc]} aB +m 4 &iM {a[b-d]} aC aC +f 5 &iM {a[^b-d]} aC + + + +doing 20 "directors and embedded options" +e 1 & ***? BADPAT +m 2 q ***? ***? ***? +m 3 &P ***=a*b a*b a*b +m 4 q ***=a*b ***=a*b ***=a*b +m 5 bLP {***:\w+} ab ab +m 6 eLP {***:\w+} ab ab +e 7 & ***:***=a*b BADRPT +m 8 &P ***:(?b)a+b a+b a+b +m 9 P (?b)a+b a+b a+b +e 10 e {(?b)\w+} BADRPT +m 11 bAS {(?b)\w+} (?b)w+ (?b)w+ +m 12 iP (?c)a a a +f 13 iP (?c)a A +m 14 APS {(?e)\W+} WW WW +m 15 P (?i)a+ Aa Aa +f 16 P "(?m)a.b" "a\nb" +m 17 P "(?m)^b" "a\nb" "b" +f 18 P "(?n)a.b" "a\nb" +m 19 P "(?n)^b" "a\nb" "b" +f 20 P "(?p)a.b" "a\nb" +f 21 P "(?p)^b" "a\nb" +m 22 P (?q)a+b a+b a+b +m 23 nP "(?s)a.b" "a\nb" "a\nb" +m 24 xP "(?t)a b" "a b" "a b" +m 25 P "(?w)a.b" "a\nb" "a\nb" +m 26 P "(?w)^b" "a\nb" "b" +m 27 P "(?x)a b" "ab" "ab" +e 28 - (?z)ab BADOPT +m 29 P (?ici)a+ Aa Aa +e 30 P (?i)(?q)a+ BADRPT +m 31 P (?q)(?i)a+ (?i)a+ (?i)a+ +m 32 P (?qe)a+ a a +m 33 xP "(?q)a b" "a b" "a b" +m 34 P "(?qx)a b" "a b" "a b" +m 35 P (?qi)ab Ab Ab + + + +doing 21 "capturing" +m 1 - a(b)c abc abc b +m 2 P a(?:b)c xabc abc +m 3 - a((b))c xabcy abc b b +m 4 P a(?:(b))c abcy abc b +m 5 P a((?:b))c abc abc b +m 6 P a(?:(?:b))c abc abc +i 7 Q "a(b){0}c" ac {0 1} {-1 -1} +m 8 - a(b)c(d)e abcde abcde b d +m 9 - (b)c(d)e bcde bcde b d +m 10 - a(b)(d)e abde abde b d +m 11 - a(b)c(d) abcd abcd b d +m 12 - (ab)(cd) xabcdy abcd ab cd +m 13 - a(b)?c xabcy abc b +i 14 - a(b)?c xacy {1 2} {-1 -1} +m 15 - a(b)?c(d)?e xabcdey abcde b d +i 16 - a(b)?c(d)?e xacdey {1 4} {-1 -1} {3 3} +i 17 - a(b)?c(d)?e xabcey {1 4} {2 2} {-1 -1} +i 18 - a(b)?c(d)?e xacey {1 3} {-1 -1} {-1 -1} +m 19 - a(b)*c xabcy abc b +i 20 - a(b)*c xabbbcy {1 5} {4 4} +i 21 - a(b)*c xacy {1 2} {-1 -1} +m 22 - a(b*)c xabbbcy abbbc bbb +m 23 - a(b*)c xacy ac "" +f 24 - a(b)+c xacy +m 25 - a(b)+c xabcy abc b +i 26 - a(b)+c xabbbcy {1 5} {4 4} +m 27 - a(b+)c xabbbcy abbbc bbb +i 28 Q "a(b){2,3}c" xabbbcy {1 5} {4 4} +i 29 Q "a(b){2,3}c" xabbcy {1 4} {3 3} +f 30 Q "a(b){2,3}c" xabcy +m 31 LP "\\y(\\w+)\\y" "-- abc-" "abc" "abc" +m 32 - a((b|c)d+)+ abacdbd acdbd bd b +m 33 N (.*).* abc abc abc +m 34 N (a*)* bc "" "" + + + +doing 22 "multicharacter collating elements" +# again ugh +# currently disabled because the fake MCCE we use for testing is unavailable +xx m 1 &+L {a[c]e} ace ace +xx f 2 &+I {a[c]h} ach +xx m 3 &+L {a[[.ch.]]} ach ach +xx f 4 &+L {a[[.ch.]]} ace +xx m 5 &+L {a[c[.ch.]]} ac ac +xx m 6 &+L {a[c[.ch.]]} ace ac +xx m 7 &+L {a[c[.ch.]]} ache ach +xx f 8 &+L {a[^c]e} ace +xx m 9 &+L {a[^c]e} abe abe +xx m 10 &+L {a[^c]e} ache ache +xx f 11 &+L {a[^[.ch.]]} ach +xx m 12 &+L {a[^[.ch.]]} ace ac +xx m 13 &+L {a[^[.ch.]]} ac ac +xx m 14 &+L {a[^[.ch.]]} abe ab +xx f 15 &+L {a[^c[.ch.]]} ach +xx f 16 &+L {a[^c[.ch.]]} ace +xx f 17 &+L {a[^c[.ch.]]} ac +xx m 18 &+L {a[^c[.ch.]]} abe ab +xx m 19 &+L {a[^b]} ac ac +xx m 20 &+L {a[^b]} ace ac +xx m 21 &+L {a[^b]} ach ach +xx f 22 &+L {a[^b]} abe + + + +doing 23 "lookahead constraints" +m 1 HP a(?=b)b* ab ab +f 2 HP a(?=b)b* a +m 3 HP a(?=b)b*(?=c)c* abc abc +f 4 HP a(?=b)b*(?=c)c* ab +f 5 HP a(?!b)b* ab +m 6 HP a(?!b)b* a a +m 7 HP (?=b)b b b +f 8 HP (?=b)b a + + + +doing 24 "non-greedy quantifiers" +m 1 P ab+? abb ab +m 2 P ab+?c abbc abbc +m 3 P ab*? abb a +m 4 P ab*?c abbc abbc +m 5 P ab?? ab a +m 6 P ab??c abc abc +m 7 PQ "ab{2,4}?" abbbb abb +m 8 PQ "ab{2,4}?c" abbbbc abbbbc + + + +doing 25 "mixed quantifiers" +xx to be done, actually +xx should include | + + + +doing 26 "tricky cases" +# attempts to trick the matcher into accepting a short match +m 1 - (week|wee)(night|knights) weeknights weeknights \ + wee knights +m 2 RP {a(bc*).*\1} abccbccb abccbccb b +m 3 - {a(b.[bc]*)+} abcbd abcbd bd + + + +doing 27 "implementation misc." +# duplicate arcs are suppressed +m 1 P a(?:b|b)c abc abc +# make color/subcolor relationship go back and forth +m 2 & {[ab][ab][ab]} aba aba +m 3 & {[ab][ab][ab][ab][ab][ab][ab]} abababa abababa + + + +doing 28 "boundary busters etc." +# color-descriptor allocation changes at 10 +m 1 & abcdefghijkl abcdefghijkl abcdefghijkl +# so does arc allocation +m 2 P a(?:b|c|d|e|f|g|h|i|j|k|l|m)n agn agn +# subexpression tracking also at 10 +m 3 - a(((((((((((((b)))))))))))))c abc abc b b b b b b b b b b b b b +# state-set handling changes slightly at unsigned size (might be 64...) +# (also stresses arc allocation) +m 4 Q "ab{1,100}c" abbc abbc +m 5 Q "ab{1,100}c" abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc \ + abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc +m 6 Q "ab{1,100}c" \ + abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc \ + abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc +# force small cache and bust it, several ways +m 7 LP {\w+abcdefgh} xyzabcdefgh xyzabcdefgh +m 8 %LP {\w+abcdefgh} xyzabcdefgh xyzabcdefgh +m 9 %LP {\w+abcdefghijklmnopqrst} xyzabcdefghijklmnopqrst \ + xyzabcdefghijklmnopqrst +i 10 %LP {\w+(abcdefgh)?} xyz {0 2} {-1 -1} +i 11 %LP {\w+(abcdefgh)?} xyzabcdefg {0 9} {-1 -1} +i 12 %LP {\w+(abcdefghijklmnopqrst)?} xyzabcdefghijklmnopqrs \ + {0 21} {-1 -1} + + + +doing 29 "misc. oddities and old bugs" +e 1 & *** BADRPT +m 2 N a?b* abb abb +m 3 N a?b* bb bb +m 4 & a*b aab aab +m 5 & ^a*b aaaab aaaab +m 6 &M {[0-6][1-2][0-3][0-6][1-6][0-6]} 010010 010010 + + + +doing 0 "flush" ;# to flush any leftover complaints + +# cleanup +::tcltest::cleanupTests +return + + diff --git a/tests/regexp.test b/tests/regexp.test index f5354fb..611a780 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -5,14 +5,17 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: regexp.test,v 1.2 1998/09/14 18:40:13 stanton Exp $ +# RCS: @(#) $Id: regexp.test,v 1.3 1999/04/16 00:47:33 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {unset foo} test regexp-1.1 {basic regexp operation} { @@ -30,6 +33,15 @@ test regexp-1.4 {basic regexp operation} { test regexp-1.5 {basic regexp operation} { regexp {^([^ ]*)[ ]*([^ ]*)} "" a } 1 +test regexp-1.6 {basic regexp operation} { + list [catch {regexp {} abc} msg] $msg +} {0 1} +test regexp-1.7 {regexp utf compliance} { + # if not UTF-8 aware, result is "0 1" + set foo "\u4e4eb q" + regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar + list [string compare $foo $bar] [regexp 4 $bar] +} {0 0} test regexp-2.1 {getting substrings back from regexp} { set foo {} @@ -67,7 +79,10 @@ 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-2.8 {getting substrings back from regexp} { + set match {} + list [regexp {^a*b} aaaab match] $match +} {1 aaaab} test regexp-3.1 {-indices option to regexp} { set foo {} @@ -120,10 +135,10 @@ test regexp-4.3 {-nocase option to regexp} { } 1 set x abcdefghijklmnopqrstuvwxyz1234567890 set x $x$x$x$x$x$x$x$x$x$x$x$x -test regexp-4.4 {case conversion in regsub} { +test regexp-4.4 {case conversion in regexp} { list [regexp -nocase $x $x foo] $foo } "1 $x" -unset x +catch {unset x} test regexp-5.1 {exercise cache of compiled expressions} { regexp .*a b @@ -174,20 +189,21 @@ test regexp-6.2 {regexp errors} { } {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 --}} +} {1 {bad switch "-gorp": must be -indices, -nocase, -about, -expanded, -line, -linestop, -lineanchor, or --}} test regexp-6.4 {regexp errors} { list [catch {regexp a( b} msg] $msg -} {1 {couldn't compile regular expression pattern: unmatched ()}} +} {1 {couldn't compile regular expression pattern: parentheses () not balanced}} test regexp-6.5 {regexp errors} { list [catch {regexp a( b} msg] $msg -} {1 {couldn't compile regular expression pattern: unmatched ()}} +} {1 {couldn't compile regular expression pattern: parentheses () not balanced}} 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 ()}} +} {0 0} test regexp-6.8 {regexp errors} { + catch {unset f1} set f1 44 list [catch {regexp abc abc f1(f2)} msg] $msg } {1 {couldn't set variable "f1(f2)"}} @@ -244,6 +260,12 @@ test regexp-7.16 {basic regsub operation} { set foo xxx list [regsub x "" y foo] $foo } {0 {}} +test regexp-7.17 {regsub utf compliance} { + # if not UTF-8 aware, result is "0 1" + set foo "xyz555ijka\u4e4ebpqr" + regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar + list [string compare $foo $bar] [regexp 4 $bar] +} {0 0} test regexp-8.1 {case conversion in regsub} { list [regsub -nocase a(a+) xaAAaAAay & foo] $foo @@ -312,7 +334,45 @@ test regexp-10.5 {regsub errors} { } {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 ()}} +} {1 {couldn't compile regular expression pattern: parentheses () not balanced}} test regexp-10.7 {regsub errors} { + catch {unset f1} + set f1 44 list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg } {1 {couldn't set variable "f1(f2)"}} + +test regexp-11.1 {Tcl_RegExpExec: large number of subexpressions} { + list [regexp (.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) abcdefghijklmnopqrstuvwxyz all a b c d e f g h i j k l m n o p q r s t u v w x y z] $all $a $b $c $d $e $f $g $h $i $j $k $l $m $n $o $p $q $r $s $t $u $v $w $x $y $z +} {1 abcdefghijklmnopqrstuvwxyz a b c d e f g h i j k l m n o p q r s t u v w x y z} + +test regexp-12.1 {regsub of a very large string} { + # This test is designed to stress the memory subsystem in order + # to catch Bug #933. It only fails if the Tcl memory allocator + # is in use. + + set line {BEGIN_TABLE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END_TABLE} + set filedata "" + for {set i 1} {$i<200} {incr i} { + append filedata $line + } + for {set i 1} {$i<10} {incr i} { + regsub -all "BEGIN_TABLE " $filedata "" newfiledata + } + set x done +} {done} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/registry.test b/tests/registry.test index b78beff..773f964 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -8,150 +8,159 @@ # auto_path or the registry package must have been loaded already. # # Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. +# Copyright (c) 1998-1999 by Scriptics Corporation. # -# RCS: @(#) $Id: registry.test,v 1.4 1999/02/02 23:01:42 stanton Exp $ +# RCS: @(#) $Id: registry.test,v 1.5 1999/04/16 00:47:33 stanton Exp $ -if {$tcl_platform(platform) != "windows"} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } -if {[string compare test [info procs test]] == 1} then {source defs} - -set lib [lindex [glob [file join [pwd] [file dirname \ - [info nameofexecutable]] tclreg*.dll]] 0] - -if [catch {load $lib registry}] { - puts "Unable to find the registry package. Skipping registry tests." - return -} - -if {$testConfig(win32s)} { - puts "Skipping registry tests under Win32s" - return +if {$tcl_platform(platform) == "windows"} { + if [catch { + set lib [lindex [glob [file join [pwd] [file dirname \ + [info nameofexecutable]] tclreg*.dll]] 0] + load $lib registry + }] { + puts "Unable to find the registry package. Skipping registry tests." + return + } } -switch $tcl_platform(os) { - "Windows NT" {set testConfig(NT) 1} - "Windows 95" {set testConfig(95) 1} +# determine the current locale +set old [testlocale all] +if {![string compare [testlocale all ""] "English_United States.1252"]} { + # error messages from registry package are already localized. + set ::tcltest::testConfig(english) 1 } +testlocale all $old +unset old set hostname [info hostname] -test registry-1.1 {argument parsing for registry command} { +test registry-1.1 {argument parsing for registry command} {pcOnly} { list [catch {registry} msg] $msg } {1 {wrong # args: should be "registry option ?arg arg ...?"}} -test registry-1.2 {argument parsing for registry command} { +test registry-1.2 {argument parsing for registry command} {pcOnly} { 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} { +test registry-1.3 {argument parsing for registry command} {pcOnly} { list [catch {registry d} msg] $msg } {1 {wrong # args: should be "registry delete keyName ?valueName?"}} -test registry-1.4 {argument parsing for registry command} { +test registry-1.4 {argument parsing for registry command} {pcOnly} { list [catch {registry delete} msg] $msg } {1 {wrong # args: should be "registry delete keyName ?valueName?"}} -test registry-1.5 {argument parsing for registry command} { +test registry-1.5 {argument parsing for registry command} {pcOnly} { 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} { +test registry-1.6 {argument parsing for registry command} {pcOnly} { list [catch {registry g} msg] $msg } {1 {wrong # args: should be "registry get keyName valueName"}} -test registry-1.7 {argument parsing for registry command} { +test registry-1.7 {argument parsing for registry command} {pcOnly} { list [catch {registry get} msg] $msg } {1 {wrong # args: should be "registry get keyName valueName"}} -test registry-1.8 {argument parsing for registry command} { +test registry-1.8 {argument parsing for registry command} {pcOnly} { 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} { +test registry-1.9 {argument parsing for registry command} {pcOnly} { 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} { +test registry-1.10 {argument parsing for registry command} {pcOnly} { list [catch {registry k} msg] $msg } {1 {wrong # args: should be "registry keys keyName ?pattern?"}} -test registry-1.11 {argument parsing for registry command} { +test registry-1.11 {argument parsing for registry command} {pcOnly} { list [catch {registry keys} msg] $msg } {1 {wrong # args: should be "registry keys keyName ?pattern?"}} -test registry-1.12 {argument parsing for registry command} { +test registry-1.12 {argument parsing for registry command} {pcOnly} { 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} { +test registry-1.13 {argument parsing for registry command} {pcOnly} { 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} { +test registry-1.14 {argument parsing for registry command} {pcOnly} { 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} { +test registry-1.15 {argument parsing for registry command} {pcOnly} { 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} { +test registry-1.16 {argument parsing for registry command} {pcOnly} { 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} { +test registry-1.17 {argument parsing for registry command} {pcOnly} { list [catch {registry t} msg] $msg } {1 {wrong # args: should be "registry type keyName valueName"}} -test registry-1.18 {argument parsing for registry command} { +test registry-1.18 {argument parsing for registry command} {pcOnly} { list [catch {registry type} msg] $msg } {1 {wrong # args: should be "registry type keyName valueName"}} -test registry-1.19 {argument parsing for registry command} { +test registry-1.19 {argument parsing for registry command} {pcOnly} { 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} { +test registry-1.20 {argument parsing for registry command} {pcOnly} { 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} { +test registry-1.21 {argument parsing for registry command} {pcOnly} { list [catch {registry v} msg] $msg } {1 {wrong # args: should be "registry values keyName ?pattern?"}} -test registry-1.22 {argument parsing for registry command} { +test registry-1.22 {argument parsing for registry command} {pcOnly} { list [catch {registry values} msg] $msg } {1 {wrong # args: should be "registry values keyName ?pattern?"}} -test registry-1.23 {argument parsing for registry command} { +test registry-1.23 {argument parsing for registry command} {pcOnly} { 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} { +test registry-2.1 {DeleteKey: bad key} {pcOnly} { 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, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} -test registry-2.2 {DeleteKey: bad key} { +test registry-2.2 {DeleteKey: bad key} {pcOnly} { list [catch {registry delete HKEY_CLASSES_ROOT} msg] $msg } {1 {bad key: cannot delete root keys}} -test registry-2.3 {DeleteKey: bad key} { +test registry-2.3 {DeleteKey: bad key} {pcOnly} { 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} { +test registry-2.4 {DeleteKey: subkey at root level} {pcOnly} { 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} { +test registry-2.5 {DeleteKey: subkey below root level} {pcOnly} { 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} { +test registry-2.6 {DeleteKey: recursive delete} {pcOnly} { 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} { +test registry-2.7 {DeleteKey: trailing backslashes} {pcOnly english} { registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar\\} msg] $msg } {1 {unable to delete key: The configuration registry key is invalid.}} -test registry-2.8 {DeleteKey: failure} { +test registry-2.8 {DeleteKey: failure} {pcOnly} { registry delete HKEY_CLASSES_ROOT\\TclFoobar registry delete HKEY_CLASSES_ROOT\\TclFoobar } {} +test registry-2.9 {DeleteKey: unicode} {pcOnly} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test\u00c7bar\\a + registry set HKEY_CLASSES_ROOT\\TclFoobar\\test\u00c7bar\\b + registry delete HKEY_CLASSES_ROOT\\TclFoobar\\test\u00c7bar + set result [registry keys HKEY_CLASSES_ROOT\\TclFoobar] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} {} - -test registry-3.1 {DeleteValue} { +test registry-3.1 {DeleteValue} {pcOnly} { registry delete HKEY_CLASSES_ROOT\\TclFoobar registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test1 blort registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test2 blat @@ -160,44 +169,52 @@ test registry-3.1 {DeleteValue} { registry delete HKEY_CLASSES_ROOT\\TclFoobar set result } test2 -test registry-3.2 {DeleteValue: bad key} { +test registry-3.2 {DeleteValue: bad key} {pcOnly english} { registry delete HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar test} msg] $msg } {1 {unable to open key: The system cannot find the file specified.}} -test registry-3.3 {DeleteValue: bad value} { +test registry-3.3 {DeleteValue: bad value} {pcOnly english} { registry delete HKEY_CLASSES_ROOT\\TclFoobar registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test2 blort set result [list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar test1} msg] $msg] 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-3.4 {DeleteValue: Unicode} {pcOnly} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\\u00c7baz \u00c7test1 blort + registry set HKEY_CLASSES_ROOT\\TclFoobar\\\u00c7baz test2 blat + registry delete HKEY_CLASSES_ROOT\\TclFoobar\\\u00c7baz \u00c7test1 + set result [registry values HKEY_CLASSES_ROOT\\TclFoobar\\\u00c7baz] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} test2 - -test registry-4.1 {GetKeyNames: bad key} { +test registry-4.1 {GetKeyNames: bad key} {pcOnly english} { registry delete HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg } {1 {unable to open key: The system cannot find the file specified.}} -test registry-4.2 {GetKeyNames} { +test registry-4.2 {GetKeyNames} {pcOnly} { 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} { +test registry-4.3 {GetKeyNames: remote key} {pcOnly nonPortable english} { registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar\\baz set result [registry keys \\\\gaspode\\HKEY_CLASSES_ROOT\\TclFoobar] registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar set result } {baz} -test registry-4.4 {GetKeyNames: empty key} { +test registry-4.4 {GetKeyNames: empty key} {pcOnly} { 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} { +test registry-4.5 {GetKeyNames: patterns} {pcOnly} { registry delete HKEY_CLASSES_ROOT\\TclFoobar registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat @@ -206,7 +223,7 @@ test registry-4.5 {GetKeyNames: patterns} { registry delete HKEY_CLASSES_ROOT\\TclFoobar set result } {baz blat} -test registry-4.6 {GetKeyNames: names with spaces} { +test registry-4.6 {GetKeyNames: names with spaces} {pcOnly} { registry delete HKEY_CLASSES_ROOT\\TclFoobar registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz\ bar registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat @@ -215,187 +232,236 @@ test registry-4.6 {GetKeyNames: names with spaces} { registry delete HKEY_CLASSES_ROOT\\TclFoobar set result } {{baz bar} blat} +test registry-4.7 {GetKeyNames: Unicode} {pcOnly english} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz\u00c7bar + 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\u00c7bar blat" +test registry-4.8 {GetKeyNames: Unicode} {pcOnly} { + registry delete HKEY_CLASSES_ROOT\\TclFoobar + registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz\u30b7bar + 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\u30b7bar blat" -test registry-5.1 {GetType} { +test registry-5.1 {GetType} {pcOnly english} { registry delete HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg } {1 {unable to open key: The system cannot find the file specified.}} -test registry-5.2 {GetType} { +test registry-5.2 {GetType} {pcOnly english} { registry set HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg } {1 {unable to get type of value "val1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}} -test registry-5.3 {GetType} { +test registry-5.3 {GetType} {pcOnly} { 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} { +test registry-5.4 {GetType} {pcOnly} { 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} { +test registry-5.5 {GetType} {pcOnly} { 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} { +test registry-5.6 {GetType} {pcOnly} { 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} { +test registry-5.7 {GetType} {pcOnly} { 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} { +test registry-5.8 {GetType} {pcOnly} { 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} { +test registry-5.9 {GetType} {pcOnly} { 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} { +test registry-5.10 {GetType} {pcOnly} { 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} { +test registry-5.11 {GetType} {pcOnly} { 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} { +test registry-5.12 {GetType} {pcOnly} { 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} { +test registry-5.13 {GetType: unknown types} {pcOnly} { 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-5.14 {GetType: Unicode} {pcOnly} { + registry set HKEY_CLASSES_ROOT\\TclFoobar va\u00c7l1 1 24 + set result [registry type HKEY_CLASSES_ROOT\\TclFoobar va\u00c7l1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} 24 -test registry-6.1 {GetValue} { +test registry-6.1 {GetValue} {pcOnly english} { registry delete HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry get HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg } {1 {unable to open key: The system cannot find the file specified.}} -test registry-6.2 {GetValue} { +test registry-6.2 {GetValue} {pcOnly english} { registry set HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry get HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg } {1 {unable to get value "val1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}} -test registry-6.3 {GetValue} { +test registry-6.3 {GetValue} {pcOnly} { 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} { +test registry-6.4 {GetValue} {pcOnly} { 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} { +test registry-6.5 {GetValue} {pcOnly} { 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} { +test registry-6.6 {GetValue} {pcOnly} { 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} { +test registry-6.7 {GetValue} {pcOnly} { 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} { +test registry-6.8 {GetValue} {pcOnly} { 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} { +test registry-6.9 {GetValue} {pcOnly} { 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} { +test registry-6.10 {GetValue} {pcOnly} { 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} { +test registry-6.11 {GetValue} {pcOnly} { 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} { +test registry-6.12 {GetValue} {pcOnly} { 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} { +test registry-6.13 {GetValue} {pcOnly} { 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} { +test registry-6.14 {GetValue: truncation of multivalues with null elements} \ + {pcOnly} { 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} { +test registry-6.15 {GetValue} {pcOnly} { 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} { +test registry-6.16 {GetValue: unknown types} {pcOnly} { 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-6.17 {GetValue: Unicode value names} {pcOnly} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val\u00c71 foobar multi_sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val\u00c71] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} foobar +test registry-6.18 {GetValue: values with Unicode strings} {pcOnly} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {foo ba\u30b7r baz} multi_sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} "foo ba\u30b7r baz" +test registry-6.19 {GetValue: values with Unicode strings} {pcOnly english} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {foo ba\u00c7r baz} multi_sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} "foo ba\u00c7r baz" +test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} {pcOnly} { + registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {foo ba\u0000r baz} multi_sz + set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1] + registry delete HKEY_CLASSES_ROOT\\TclFoobar + set result +} "foo ba r baz" -test registry-7.1 {GetValueNames: bad key} { +test registry-7.1 {GetValueNames: bad key} {pcOnly english} { registry delete HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry values HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg } {1 {unable to open key: The system cannot find the file specified.}} -test registry-7.2 {GetValueNames} { +test registry-7.2 {GetValueNames} {pcOnly} { 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} { +test registry-7.3 {GetValueNames} {pcOnly} { registry delete HKEY_CLASSES_ROOT\\TclFoobar registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1 registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2 @@ -404,20 +470,20 @@ test registry-7.3 {GetValueNames} { registry delete HKEY_CLASSES_ROOT\\TclFoobar set result } {{} baz blat} -test registry-7.4 {GetValueNames: remote key} {nonPortable} { +test registry-7.4 {GetValueNames: remote key} {pcOnly nonPortable english} { registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar baz blat - set result [registry values \\\\gaspode\\HKEY_CLASSES_ROOT\\TclFoobar] + set result [registry values \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar] registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar set result } baz -test registry-7.5 {GetValueNames: empty key} { +test registry-7.5 {GetValueNames: empty key} {pcOnly} { 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} { +test registry-7.6 {GetValueNames: patterns} {pcOnly} { registry delete HKEY_CLASSES_ROOT\\TclFoobar registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1 registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2 @@ -426,7 +492,7 @@ test registry-7.6 {GetValueNames: patterns} { registry delete HKEY_CLASSES_ROOT\\TclFoobar set result } {baz blat} -test registry-7.7 {GetValueNames: names with spaces} { +test registry-7.7 {GetValueNames: names with spaces} {pcOnly} { registry delete HKEY_CLASSES_ROOT\\TclFoobar registry set HKEY_CLASSES_ROOT\\TclFoobar baz\ bar foobar1 registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2 @@ -436,50 +502,52 @@ test registry-7.7 {GetValueNames: names with spaces} { set result } {{baz bar} blat} -test registry-8.1 {OpenSubKey} {nonPortable} { - list [catch {registry keys {\\petrouchka\HKEY_LOCAL_MACHINE}} msg] $msg +test registry-8.1 {OpenSubKey} {pcOnly nonPortable english} { + # This test will only succeed if the current user does not have registry + # access on the specified machine. + list [catch {registry keys {\\mom\HKEY_LOCAL_MACHINE}} msg] $msg } {1 {unable to open key: Access is denied.}} -test registry-8.2 {OpenSubKey} { +test registry-8.2 {OpenSubKey} {pcOnly} { 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} { +test registry-8.3 {OpenSubKey} {pcOnly english} { registry delete HKEY_CLASSES_ROOT\\TclFoobar list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg } {1 {unable to open key: The system cannot find the file specified.}} -test registry-9.1 {ParseKeyName: bad keys} { +test registry-9.1 {ParseKeyName: bad keys} {pcOnly} { list [catch {registry values \\} msg] $msg } "1 {bad key \"\\\": must start with a valid root}" -test registry-9.2 {ParseKeyName: bad keys} { +test registry-9.2 {ParseKeyName: bad keys} {pcOnly} { list [catch {registry values \\foobar} msg] $msg } {1 {bad key "\foobar": must start with a valid root}} -test registry-9.3 {ParseKeyName: bad keys} { +test registry-9.3 {ParseKeyName: bad keys} {pcOnly} { list [catch {registry values \\\\} msg] $msg } {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} -test registry-9.4 {ParseKeyName: bad keys} { +test registry-9.4 {ParseKeyName: bad keys} {pcOnly} { list [catch {registry values \\\\\\} msg] $msg } {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} -test registry-9.5 {ParseKeyName: bad keys} { +test registry-9.5 {ParseKeyName: bad keys} {pcOnly english} { list [catch {registry values \\\\\\HKEY_CLASSES_ROOT} msg] $msg } {1 {unable to open key: The network address is invalid.}} -test registry-9.6 {ParseKeyName: bad keys} { +test registry-9.6 {ParseKeyName: bad keys} {pcOnly} { list [catch {registry values \\\\gaspode} msg] $msg } {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} -test registry-9.7 {ParseKeyName: bad keys} { +test registry-9.7 {ParseKeyName: bad keys} {pcOnly} { 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, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} -test registry-9.8 {ParseKeyName: null keys} { +test registry-9.8 {ParseKeyName: null keys} {pcOnly} { list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg } {1 {bad key: cannot delete root keys}} -test registry-9.9 {ParseKeyName: null keys} { +test registry-9.9 {ParseKeyName: null keys} {pcOnly english} { 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} { +test registry-10.1 {RecursiveDeleteKey} {pcOnly} { registry delete HKEY_CLASSES_ROOT\\TclFoobar registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1 registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3 @@ -487,7 +555,7 @@ test registry-10.1 {RecursiveDeleteKey} { set result [registry keys HKEY_CLASSES_ROOT TclFoobar] set result } {} -test registry-10.2 {RecursiveDeleteKey} { +test registry-10.2 {RecursiveDeleteKey} {pcOnly} { registry delete HKEY_CLASSES_ROOT\\TclFoobar registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1 registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3 @@ -496,20 +564,38 @@ test registry-10.2 {RecursiveDeleteKey} { set result } {} -test registry-11.1 {SetValue: recursive creation} { +test registry-11.1 {SetValue: recursive creation} {pcOnly} { 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} { +test registry-11.2 {SetValue: modification} {pcOnly} { 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 +test registry-11.3 {SetValue: failure} {pcOnly nonPortable english} { + # This test will only succeed if the current user does not have registry + # access on the specified machine. + list [catch {registry set {\\mom\HKEY_CLASSES_ROOT\TclFoobar} bar foobar} msg] $msg } {1 {unable to open key: Access is denied.}} +# cleanup unset hostname +::tcltest::cleanupTests +return + + + + + + + + + + + + + diff --git a/tests/remote.tcl b/tests/remote.tcl index 9d27cdc..005f2df 100644 --- a/tests/remote.tcl +++ b/tests/remote.tcl @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: remote.tcl,v 1.2 1998/09/14 18:40:13 stanton Exp $ +# RCS: @(#) $Id: remote.tcl,v 1.3 1999/04/16 00:47:33 stanton Exp $ # Initialize message delimitor @@ -159,3 +159,14 @@ if {[catch {set serverSocket \ } else { vwait __server_wait_variable__ } + + + + + + + + + + + diff --git a/tests/rename.test b/tests/rename.test index 5f0d733..14cdf05 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: rename.test,v 1.2 1998/09/14 18:40:13 stanton Exp $ +# RCS: @(#) $Id: rename.test,v 1.3 1999/04/16 00:47:33 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # Must eliminate the "unknown" command while the test is running, # especially if the test is being run in a program with its @@ -163,10 +166,21 @@ test rename-6.1 {old code invalidated (epoch incremented) when cmd with compile set msg } {called "incr" with too many arguments} +# cleanup catch {rename incr {}} catch {rename incr.old incr} +::tcltest::cleanupTests +return + + + + + + + + + + -# Make the file return an empty string (cleaner.). -set x "" diff --git a/tests/resource.test b/tests/resource.test index 91e93a4..b5f341a 100644 --- a/tests/resource.test +++ b/tests/resource.test @@ -5,45 +5,44 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: resource.test,v 1.3 1998/11/10 06:54:20 jingham Exp $ +# RCS: @(#) $Id: resource.test,v 1.4 1999/04/16 00:47:33 stanton Exp $ -# Only run this test on Macintosh systems -if {$tcl_platform(platform) != "macintosh"} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } -if {[string compare test [info procs test]] == 1} then {source defs} -test resource-1.1 {resource tests} { +test resource-1.1 {resource tests} {macOnly} { list [catch {resource} msg] $msg } {1 {wrong # args: should be "resource option ?arg ...?"}} -test resource-1.2 {resource tests} { +test resource-1.2 {resource tests} {macOnly} { 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} { +test resource-2.1 {resource open & close tests} {macOnly} { list [catch {resource open} msg] $msg } {1 {wrong # args: should be "resource open fileName ?permissions?"}} -test resource-2.2 {resource open & close tests} { +test resource-2.2 {resource open & close tests} {macOnly} { 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} { +test resource-2.3 {resource open & close tests} {macOnly} { list [catch {resource open resource.test bad_perms} msg] $msg } {1 {illegal access mode "bad_perms"}} -test resource-2.4 {resource open & close tests} { +test resource-2.4 {resource open & close tests} {macOnly} { list [catch {resource open _bad_file_} msg] $msg } {1 {file does not exist}} -test resource-2.5 {resource open & close tests} { +test resource-2.5 {resource open & close tests} {macOnly} { 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} { +test resource-2.6 {resource open & close tests} {macOnly} { catch {file delete rsrc.file} testWriteTextResource -rsrc fileRsrcName -file rsrc.file {A test string} set id [resource open rsrc.file] @@ -53,7 +52,7 @@ test resource-2.6 {resource open & close tests} { file delete rsrc.file set result } {0 {A test string}} -test resource-2.7 {resource open & close tests} { +test resource-2.7 {resource open & close tests} {macOnly} { catch {file delete rsrc.file} testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"} set id [resource open rsrc.file r] @@ -63,38 +62,38 @@ test resource-2.7 {resource open & close tests} { lappend result $mssg set result } {1 {Resource already open with different permissions.}} -test resource-2.8 {resource open & close tests} { +test resource-2.8 {resource open & close tests} {macOnly} { list [catch {resource close} msg] $msg } {1 {wrong # args: should be "resource close resourceRef"}} -test resource-2.9 {resource open & close tests} { +test resource-2.9 {resource open & close tests} {macOnly} { list [catch {resource close foo bar} msg] $msg } {1 {wrong # args: should be "resource close resourceRef"}} -test resource-2.10 {resource open & close tests} { +test resource-2.10 {resource open & close tests} {macOnly} { list [catch {resource close _bad_resource_} msg] $msg } {1 {invalid resource file reference "_bad_resource_"}} -test resource-2.11 {resource open & close tests} { +test resource-2.11 {resource open & close tests} {macOnly} { set result [catch {resource close System} mssg] lappend result $mssg } {1 {can't close "System" resource file}} -test resource-2.12 {resource open & close tests} { +test resource-2.12 {resource open & close tests} {macOnly} { 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} { +test resource-3.1 {resource list tests} {macOnly} { list [catch {resource list} msg] $msg } {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}} -test resource-3.2 {resource list tests} { +test resource-3.2 {resource list tests} {macOnly} { list [catch {resource list _bad_type_} msg] $msg } {1 {expected Macintosh OS type but got "_bad_type_"}} -test resource-3.3 {resource list tests} { +test resource-3.3 {resource list tests} {macOnly} { list [catch {resource list TEXT _bad_ref_} msg] $msg } {1 {invalid resource file reference "_bad_ref_"}} -test resource-3.4 {resource list tests} { +test resource-3.4 {resource list tests} {macOnly} { 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} { +test resource-3.5 {resource list tests} {macOnly} { catch {file delete rsrc.file} testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"} set id [resource open rsrc.file] @@ -102,11 +101,11 @@ test resource-3.5 {resource list tests} { resource close $id set result } {fileRsrcName} -test resource-3.6 {resource list tests} { +test resource-3.6 {resource list tests} {macOnly} { # There should not be any resource of this type resource list XXXX } {} -test resource-3.7 {resource list tests} { +test resource-3.7 {resource list tests} {macOnly} { set resourceList [resource list STR#] if {[lsearch $resourceList {Tcl Environment Variables}] == -1} { set result {couldn't find resource that should exist} @@ -116,32 +115,32 @@ test resource-3.7 {resource list tests} { } {ok} # Tests for reading resources -test resource-4.1 {resource read tests} { +test resource-4.1 {resource read tests} {macOnly} { list [catch {resource read} msg] $msg } {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}} -test resource-4.2 {resource read tests} { +test resource-4.2 {resource read tests} {macOnly} { list [catch {resource read TEXT} msg] $msg } {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}} -test resource-4.3 {resource read tests} { +test resource-4.3 {resource read tests} {macOnly} { list [catch {resource read STR# {_non_existant_resource_}} msg] $msg } {1 {could not load resource}} -test resource-4.4 {resource read tests} { +test resource-4.4 {resource read tests} {macOnly} { # 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} { +test resource-5.1 {resource types tests} {macOnly} { list [catch {resource types _bad_ref_} msg] $msg } {1 {invalid resource file reference "_bad_ref_"}} -test resource-5.2 {resource types tests} { +test resource-5.2 {resource types tests} {macOnly} { list [catch {resource types _bad_ref_ extraArg} msg] $msg } {1 {wrong # args: should be "resource types ?resourceRef?"}} -test resource-5.3 {resource types tests} { +test resource-5.3 {resource types tests} {macOnly} { # This should never cause an error catch {resource types} } {0} -test resource-5.4 {resource types tests} { +test resource-5.4 {resource types tests} {macOnly} { testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"} set id [resource open rsrc.file] set result [resource types $id] @@ -150,13 +149,13 @@ test resource-5.4 {resource types tests} { } {TEXT} # resource write tests -test resource-6.1 {resource write tests} { +test resource-6.1 {resource write tests} {macOnly} { 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} { +test resource-6.2 {resource write tests} {macOnly} { 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} { +test resource-6.3 {resource write tests} {macOnly} { catch {file delete rsrc2.file} set id [resource open rsrc2.file w] resource close $id @@ -168,7 +167,7 @@ test resource-6.3 {resource write tests} { file delete rsrc2.file set result } {1 0 -1} -test resource-6.4 {resource write tests} { +test resource-6.4 {resource write tests} {macOnly} { catch {file delete rsrc2.file} set id [resource open rsrc2.file w] resource write -file $id -name Hello TEXT {set x "our test data"} @@ -177,7 +176,7 @@ test resource-6.4 {resource write tests} { file delete rsrc2.file set x } {our test data} -test resource-6.5 {resource write tests} { +test resource-6.5 {resource write tests} {macOnly} { catch {file delete rsrc2.file} set id [resource open rsrc2.file w] resource write -file $id -id 256 TEXT {HAHAHAHAHAHAHA} @@ -186,7 +185,7 @@ test resource-6.5 {resource write tests} { 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} { +test resource-6.6 {resource write tests} {macOnly} { 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] @@ -195,7 +194,7 @@ test resource-6.6 {resource write tests} { 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} { +test resource-6.7 {resource write tests} {macOnly} { 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"]} @@ -208,11 +207,11 @@ test resource-6.7 {resource write tests} { } {{our second test data} BAR} #Tests for listing open resource files -test resource-7.1 {resource file tests} { +test resource-7.1 {resource file tests} {macOnly} { catch {resource files foo bar} mssg set mssg } {wrong # args: should be "resource files ?resourceId?"} -test resource-7.2 {resource file tests} { +test resource-7.2 {resource file tests} {macOnly} { catch {file delete rsrc2.file} set rsrcFiles [resource files] set id [resource open rsrc2.file w] @@ -222,7 +221,7 @@ test resource-7.2 {resource file tests} { file delete rsrc2.file set result } {0 0} -test resource-7.3 {resource file tests} { +test resource-7.3 {resource file tests} {macOnly} { set result 0 foreach file [resource files] { if {[catch {resource types $file}] != 0} { @@ -231,31 +230,31 @@ test resource-7.3 {resource file tests} { } set result } {0} -test resource-7.4 {resource file tests} { +test resource-7.4 {resource file tests} {macOnly} { catch {resource files __NO_SUCH_RESOURCE__} mssg set mssg } {invalid resource file reference "__NO_SUCH_RESOURCE__"} -test resource-7.5 {resource file tests} { +test resource-7.5 {resource file tests} {macOnly} { set sys [resource files System] string compare $sys [file join $env(SYS_FOLDER) System] } {0} -test resource-7.6 {resource file tests} { +test resource-7.6 {resource file tests} {macOnly} { set app [resource files application] string compare $app [info nameofexecutable] } {0} #Tests for the resource delete command -test resource-8.1 {resource delete tests} { +test resource-8.1 {resource delete tests} {macOnly} { 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} { +test resource-8.2 {resource delete tests} {macOnly} { 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} { +test resource-8.3 {resource delete tests} {macOnly} { 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} { +test resource-8.4 {resource delete tests} {macOnly} { catch {file delete rsrc2.file} testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff} set id [resource open rsrc2.file r] @@ -264,7 +263,7 @@ test resource-8.4 {resource delete tests} { 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} { +test resource-8.5 {resource delete tests} {macOnly} { catch {file delete rsrc2.file} testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff} set id [resource open rsrc2.file w] @@ -273,7 +272,7 @@ test resource-8.5 {resource delete tests} { file delete rsrc2.file lappend result $mssg } {1 {expected Macintosh OS type but got "_bad_type_"}} -test resource-8.5 {resource delete tests} { +test resource-8.5 {resource delete tests} {macOnly} { catch {file delete rsrc2.file} set id [resource open rsrc2.file w] set result [catch {resource delete -id 128 -file $id TEXT} mssg] @@ -281,7 +280,7 @@ test resource-8.5 {resource delete tests} { file delete rsrc2.file lappend result $mssg } {1 {resource not found}} -test resource-8.6 {resource delete tests} { +test resource-8.6 {resource delete tests} {macOnly} { catch {file delete rsrc2.file} set id [resource open rsrc2.file w] set result [catch {resource delete -name foo -file $id TEXT} mssg] @@ -289,7 +288,7 @@ test resource-8.6 {resource delete tests} { file delete rsrc2.file lappend result $mssg } {1 {resource not found}} -test resource-8.7 {resource delete tests} { +test resource-8.7 {resource delete tests} {macOnly} { catch {file delete rsrc2.file} set id [resource open rsrc2.file w] resource write -file $id -name foo -id 128 TEXT {some stuff} @@ -299,7 +298,7 @@ test resource-8.7 {resource delete tests} { 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} { +test resource-8.8 {resource delete tests} {macOnly} { 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] @@ -308,7 +307,7 @@ test resource-8.8 {resource delete tests} { file delete rsrc2.file lappend result $mssg } {1 {resource cannot be deleted: it is protected.}} -test resource-8.9 {resource delete tests} { +test resource-8.9 {resource delete tests} {macOnly} { catch {file delete rsrc2.file} testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff} set id [resource open rsrc2.file w] @@ -322,31 +321,44 @@ test resource-8.9 {resource delete tests} { # 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} { +test resource-9.1 {source command} {macOnly} { + testWriteTextResource -rsrc fileRsrcName -rsrcid 128 \ + -file rsrc.file {set rsrc_foo 1} catch {unset rsrc_foo} source -rsrc fileRsrcName rsrc.file list [catch {set rsrc_foo} msg] $msg } {0 1} -test resource-9.2 {source command} { +test resource-9.2 {source command} {macOnly} { 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} { +test resource-9.3 {source command} {macOnly} { catch {unset rsrc_foo} source -rsrcid 128 rsrc.file list [catch {set rsrc_foo} msg] $msg } {0 1} -test resource-9.4 {source command} { +test resource-9.4 {source command} {macOnly} { 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} { +test resource-9.5 {source command} {macOnly} { 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 +# cleanup catch {file delete rsrc.file} +::tcltest::cleanupTests return + + + + + + + + + + + + diff --git a/tests/result.test b/tests/result.test new file mode 100644 index 0000000..3f77fdc --- /dev/null +++ b/tests/result.test @@ -0,0 +1,102 @@ +# This file tests the routines in tclResult.c. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 by Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) result.test 1.4 97/12/08 15:07:49 + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +# Some tests require the testsaveresult command + +set ::tcltest::testConfig(testsaveresult) \ + [expr {[info commands testsaveresult] != {}}] + +test result-1.1 {Tcl_SaveInterpResult} {testsaveresult} { + testsaveresult small {set x 42} 0 +} {small result} +test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} { + testsaveresult append {set x 42} 0 +} {append result} +test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} { + testsaveresult dynamic {set x 42} 0 +} {dynamic result notCalled present} +test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} { + testsaveresult object {set x 42} 0 +} {object result same} +test result-1.5 {Tcl_SaveInterpResult} {testsaveresult} { + testsaveresult small {set x 42} 1 +} {42} +test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} { + testsaveresult append {set x 42} 1 +} {42} +test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} { + testsaveresult dynamic {set x 42} 1 +} {42 called missing} +test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} { + testsaveresult object {set x 42} 1 +} {42 different} + + +# Tcl_RestoreInterpResult is mostly tested by the previous tests except +# for the following case + +test result-2.1 {Tcl_RestoreInterpResult} {testsaveresult} { + testsaveresult append {cd _foobar} 0 +} {append result} + +# Tcl_DiscardInterpResult is mostly tested by the previous tests except +# for the following cases + +test result-3.1 {Tcl_DiscardInterpResult} {testsaveresult} { + list [catch {testsaveresult append {cd _foobar} 1} msg] $msg +} {1 {couldn't change working directory to "_foobar": no such file or directory}} +test result-3.2 {Tcl_DiscardInterpResult} {testsaveresult} { + testsaveresult free {set x 42} 1 +} {42} + +test result-4.1 {Tcl_SetObjErrorCode - one arg} {testsaveresult} { + catch {testsetobjerrorcode 1} + list [set errorCode] +} {1} +test result-4.2 {Tcl_SetObjErrorCode - two args} {testsaveresult} { + catch {testsetobjerrorcode 1 2} + list [set errorCode] +} {{1 2}} +test result-4.3 {Tcl_SetObjErrorCode - three args} {testsaveresult} { + catch {testsetobjerrorcode 1 2 3} + list [set errorCode] +} {{1 2 3}} +test result-4.4 {Tcl_SetObjErrorCode - four args} {testsaveresult} { + catch {testsetobjerrorcode 1 2 3 4} + list [set errorCode] +} {{1 2 3 4}} +test result-4.5 {Tcl_SetObjErrorCode - five args} {testsaveresult} { + catch {testsetobjerrorcode 1 2 3 4 5} + list [set errorCode] +} {{1 2 3 4 5}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/safe.test b/tests/safe.test index 74cac8d..5149c59 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -5,13 +5,16 @@ # and generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: safe.test,v 1.4 1998/11/03 01:02:28 stanton Exp $ +# RCS: @(#) $Id: safe.test,v 1.5 1999/04/16 00:47:33 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} foreach i [interp slaves] { interp delete $i @@ -81,7 +84,7 @@ test safe-3.2 {calling safe::interpCreate on trusted interp} { set l [lsort [a aliases]] safe::interpDelete a set l -} {exit file load source} +} {encoding exit file load source} test safe-3.3 {calling safe::interpCreate on trusted interp} { catch {safe::interpDelete a} safe::interpCreate a @@ -167,11 +170,16 @@ test safe-6.1 {test safe interpreters knowledge of the world} { 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} {pcOnly} { - SI; set r [lsort [$I eval {array names tcl_platform}]]; DI; set r -} {byteOrder debug platform} -test safe-6.3 {test safe interpreters knowledge of the world} {macOrUnix} { - SI; set r [lsort [$I eval {array names tcl_platform}]]; 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 + # If running a windows-debug shell, remove the "debug" element from r. + if {$tcl_platform(platform) == "windows" && \ + [lsearch $r "debug"] != -1} { + set r [lreplace $r 1 1] + } + set r } {byteOrder platform} # more test should be added to check that hostname, nameofexecutable, @@ -434,3 +442,86 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} { } + +test safe-11.1 {testing safe encoding} { + set i [safe::interpCreate] + list \ + [catch {interp eval $i encoding} msg] \ + $msg \ + [safe::interpDelete $i]; +} {1 {wrong # args: should be "encoding option ?arg ...?"} {}} + +test safe-11.2 {testing safe encoding} { + set i [safe::interpCreate] + list \ + [catch {interp eval $i encoding system cp775} msg] \ + $msg \ + [safe::interpDelete $i]; +} {1 {wrong # args: should be "encoding system"} {}} + +test safe-11.3 {testing safe encoding} { + set i [safe::interpCreate] + set result [catch { + string match [encoding system] [interp eval $i encoding system] + } msg] + list $result $msg [safe::interpDelete $i] +} {0 1 {}} + +test safe-11.4 {testing safe encoding} { + set i [safe::interpCreate] + set result [catch { + string match [encoding names] [interp eval $i encoding names] + } msg] + list $result $msg [safe::interpDelete $i] +} {0 1 {}} + +test safe-11.5 {testing safe encoding} { + set i [safe::interpCreate] + list \ + [catch {interp eval $i encoding convertfrom cp1258 foobar} msg] \ + $msg \ + [safe::interpDelete $i]; +} {0 foobar {}} + + +test safe-11.6 {testing safe encoding} { + set i [safe::interpCreate] + list \ + [catch {interp eval $i encoding convertto cp1258 foobar} msg] \ + $msg \ + [safe::interpDelete $i]; +} {0 foobar {}} + +test safe-11.7 {testing safe encoding} { + set i [safe::interpCreate] + list \ + [catch {interp eval $i encoding convertfrom} msg] \ + $msg \ + [safe::interpDelete $i]; +} {1 {wrong # args: should be "encoding convertfrom ?encoding? data"} {}} + + +test safe-11.8 {testing safe encoding} { + set i [safe::interpCreate] + list \ + [catch {interp eval $i encoding convertto} msg] \ + $msg \ + [safe::interpDelete $i]; +} {1 {wrong # args: should be "encoding convertto ?encoding? data"} {}} + + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/scan.test b/tests/scan.test index ecbd79a..aa86a4d 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -6,52 +6,354 @@ # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: scan.test,v 1.3 1998/11/02 23:04:14 stanton Exp $ +# RCS: @(#) $Id: scan.test,v 1.4 1999/04/16 00:47:34 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} -test scan-1.1 {integer scanning} { +test scan-1.1 {BuildCharSet, CharInSet} { + list [scan foo {%[^o]} x] $x +} {1 f} +test scan-1.2 {BuildCharSet, CharInSet} { + list [scan \]foo {%[]f]} x] $x +} {1 \]f} +test scan-1.3 {BuildCharSet, CharInSet} { + list [scan abc-def {%[a-c]} x] $x +} {1 abc} +test scan-1.4 {BuildCharSet, CharInSet} { + list [scan abc-def {%[a-c]} x] $x +} {1 abc} +test scan-1.5 {BuildCharSet, CharInSet} { + list [scan -abc-def {%[-ac]} x] $x +} {1 -a} +test scan-1.6 {BuildCharSet, CharInSet} { + list [scan -abc-def {%[ac-]} x] $x +} {1 -a} +test scan-1.7 {BuildCharSet, CharInSet} { + list [scan abc-def {%[c-a]} x] $x +} {1 abc} +test scan-1.8 {BuildCharSet, CharInSet} { + list [scan def-abc {%[^c-a]} x] $x +} {1 def-} + +test scan-2.1 {ReleaseCharSet} { + list [scan abcde {%[abc]} x] $x +} {1 abc} +test scan-2.2 {ReleaseCharSet} { + list [scan abcde {%[a-c]} x] $x +} {1 abc} + +test scan-3.1 {ValidateFormat} { + list [catch {scan {} {%d%1$d} x} msg] $msg +} {1 {cannot mix "%" and "%n$" conversion specifiers}} +test scan-3.2 {ValidateFormat} { + list [catch {scan {} {%d%1$d} x} msg] $msg +} {1 {cannot mix "%" and "%n$" conversion specifiers}} +test scan-3.3 {ValidateFormat} { + list [catch {scan {} {%2$d%d} x} msg] $msg +} {1 {"%n$" argument index out of range}} +test scan-3.4 {ValidateFormat} { + list [catch {scan {} %d} msg] $msg +} {1 {different numbers of variable names and field specifiers}} +test scan-3.5 {ValidateFormat} { + list [catch {scan {} {%10c} a} msg] $msg +} {1 {field width may not be specified in %c conversion}} +test scan-3.6 {ValidateFormat} { + list [catch {scan {} {%*1$d} a} msg] $msg +} {1 {bad scan conversion character "$"}} +test scan-3.7 {ValidateFormat} { + list [catch {scan {} {%1$d%1$d} a} msg] $msg +} {1 {variable is assigned by multiple "%n$" conversion specifiers}} +test scan-3.8 {ValidateFormat} { + list [catch {scan {} a x} msg] $msg +} {1 {variable is not assigend by any conversion specifiers}} +test scan-3.9 {ValidateFormat} { + list [catch {scan {} {%2$s} x y} msg] $msg +} {1 {variable is not assigend by any conversion specifiers}} +test scan-3.10 {ValidateFormat} { + list [catch {scan {} {%[a} x} msg] $msg +} {1 {unmatched [ in format string}} +test scan-3.11 {ValidateFormat} { + list [catch {scan {} {%[^a} x} msg] $msg +} {1 {unmatched [ in format string}} +test scan-3.12 {ValidateFormat} { + list [catch {scan {} {%[]a} x} msg] $msg +} {1 {unmatched [ in format string}} +test scan-3.13 {ValidateFormat} { + list [catch {scan {} {%[^]a} x} msg] $msg +} {1 {unmatched [ in format string}} + +test scan-4.1 {Tcl_ScanObjCmd, argument checks} { + list [catch {scan} msg] $msg +} {1 {wrong # args: should be "scan string format ?varName varName ...?"}} +test scan-4.2 {Tcl_ScanObjCmd, argument checks} { + list [catch {scan string} msg] $msg +} {1 {wrong # args: should be "scan string format ?varName varName ...?"}} +test scan-4.3 {Tcl_ScanObjCmd, argument checks} { + list [catch {scan string format} msg] $msg +} {0 0} +test scan-4.4 {Tcl_ScanObjCmd, whitespace} { + list [scan { abc def } {%s%s} x y] $x $y +} {2 abc def} +test scan-4.5 {Tcl_ScanObjCmd, whitespace} { + list [scan { abc def } { %s %s } x y] $x $y +} {2 abc def} +test scan-4.6 {Tcl_ScanObjCmd, whitespace} { + list [scan { abc def } { %s %s } x y] $x $y +} {2 abc def} +test scan-4.7 {Tcl_ScanObjCmd, literals} { + scan { abc def } { abc def } +} 0 +test scan-4.8 {Tcl_ScanObjCmd, literals} { + set x {} + list [scan { abcg} { abc def %1s} x] $x +} {0 {}} +test scan-4.9 {Tcl_ScanObjCmd, literals} { + list [scan { abc%defghi} { abc %% def%n } x] $x +} {1 10} +test scan-4.10 {Tcl_ScanObjCmd, assignment suppression} { + list [scan { abc def } { %*c%s def } x] $x +} {1 bc} +test scan-4.11 {Tcl_ScanObjCmd, XPG3-style} { + list [scan { abc def } {%2$s %1$s} x y] $x $y +} {2 def abc} +test scan-4.12 {Tcl_ScanObjCmd, width specifiers} { + list [scan {abc123456789012} {%3s%3d%3f%3[0-9]%s} a b c d e] $a $b $c $d $e +} {5 abc 123 456.0 789 012} +test scan-4.13 {Tcl_ScanObjCmd, width specifiers} { + list [scan {abc123456789012} {%3s%3d%3f%3[0-9]%s} a b c d e] $a $b $c $d $e +} {5 abc 123 456.0 789 012} +test scan-4.14 {Tcl_ScanObjCmd, underflow} { + set x {} + list [scan {a} {a%d} x] $x +} {-1 {}} +test scan-4.15 {Tcl_ScanObjCmd, underflow} { + set x {} + list [scan {} {a%d} x] $x +} {-1 {}} +test scan-4.16 {Tcl_ScanObjCmd, underflow} { + set x {} + list [scan {ab} {a%d} x] $x +} {0 {}} +test scan-4.17 {Tcl_ScanObjCmd, underflow} { + set x {} + list [scan {a } {a%d} x] $x +} {-1 {}} +test scan-4.18 {Tcl_ScanObjCmd, skipping whitespace} { + list [scan { b} {%c%s} x y] $x $y +} {2 32 b} +test scan-4.19 {Tcl_ScanObjCmd, skipping whitespace} { + list [scan { b} {%[^b]%s} x y] $x $y +} {2 { } b} +test scan-4.20 {Tcl_ScanObjCmd, string scanning} { + list [scan {abc def} {%s} x] $x +} {1 abc} +test scan-4.21 {Tcl_ScanObjCmd, string scanning} { + list [scan {abc def} {%0s} x] $x +} {1 abc} +test scan-4.22 {Tcl_ScanObjCmd, string scanning} { + list [scan {abc def} {%2s} x] $x +} {1 ab} +test scan-4.23 {Tcl_ScanObjCmd, string scanning} { + list [scan {abc def} {%*s%n} x] $x +} {1 3} +test scan-4.24 {Tcl_ScanObjCmd, charset scanning} { + list [scan {abcdef} {%[a-c]} x] $x +} {1 abc} +test scan-4.25 {Tcl_ScanObjCmd, charset scanning} { + list [scan {abcdef} {%0[a-c]} x] $x +} {1 abc} +test scan-4.26 {Tcl_ScanObjCmd, charset scanning} { + list [scan {abcdef} {%2[a-c]} x] $x +} {1 ab} +test scan-4.27 {Tcl_ScanObjCmd, charset scanning} { + list [scan {abcdef} {%*[a-c]%n} x] $x +} {1 3} +test scan-4.28 {Tcl_ScanObjCmd, character scanning} { + list [scan {abcdef} {%c} x] $x +} {1 97} +test scan-4.29 {Tcl_ScanObjCmd, character scanning} { + list [scan {abcdef} {%*c%n} x] $x +} {1 1} + +test scan-4.30 {Tcl_ScanObjCmd, base-10 integer scanning} { + set x {} + list [scan {1234567890a} {%3d} x] $x +} {1 123} +test scan-4.31 {Tcl_ScanObjCmd, base-10 integer scanning} { + set x {} + list [scan {1234567890a} {%d} x] $x +} {1 1234567890} +test scan-4.32 {Tcl_ScanObjCmd, base-10 integer scanning} { + set x {} + list [scan {01234567890a} {%d} x] $x +} {1 1234567890} +test scan-4.33 {Tcl_ScanObjCmd, base-10 integer scanning} { + set x {} + list [scan {+01234} {%d} x] $x +} {1 1234} +test scan-4.34 {Tcl_ScanObjCmd, base-10 integer scanning} { + set x {} + list [scan {-01234} {%d} x] $x +} {1 -1234} +test scan-4.35 {Tcl_ScanObjCmd, base-10 integer scanning} { + set x {} + list [scan {a01234} {%d} x] $x +} {0 {}} +test scan-4.36 {Tcl_ScanObjCmd, base-10 integer scanning} { + set x {} + list [scan {0x10} {%d} x] $x +} {1 0} +test scan-4.37 {Tcl_ScanObjCmd, base-8 integer scanning} { + set x {} + list [scan {012345678} {%o} x] $x +} {1 342391} +test scan-4.38 {Tcl_ScanObjCmd, base-8 integer scanning} { + set x {} + list [scan {+1238 -1239 123a} {%o%*s%o%*s%o} x y z] $x $y $z +} {3 83 -83 83} +test scan-4.39 {Tcl_ScanObjCmd, base-16 integer scanning} { + set x {} + list [scan {+1238 -123a 0123} {%x%x%x} x y z] $x $y $z +} {3 4664 -4666 291} +test scan-4.40 {Tcl_ScanObjCmd, base-16 integer scanning} { + set x {} + list [scan {aBcDeF AbCdEf 0x1} {%x%x%x} x y z] $x $y $z +} {3 11259375 11259375 0} +test scan-4.41 {Tcl_ScanObjCmd, base-unknown integer scanning} { + set x {} + list [scan {10 010 0x10} {%i%i%i} x y z] $x $y $z +} {3 10 8 16} +test scan-4.42 {Tcl_ScanObjCmd, base-unknown integer scanning} { + set x {} + list [scan {10 010 0X10} {%i%i%i} x y z] $x $y $z +} {3 10 8 16} +test scan-4.43 {Tcl_ScanObjCmd, integer scanning, odd cases} { + set x {} + list [scan {+ } {%i} x] $x +} {0 {}} +test scan-4.44 {Tcl_ScanObjCmd, integer scanning, odd cases} { + set x {} + list [scan {+} {%i} x] $x +} {-1 {}} +test scan-4.45 {Tcl_ScanObjCmd, integer scanning, odd cases} { + set x {} + list [scan {0x} {%i%s} x y] $x $y +} {2 0 x} +test scan-4.46 {Tcl_ScanObjCmd, integer scanning, odd cases} { + set x {} + list [scan {0X} {%i%s} x y] $x $y +} {2 0 X} +test scan-4.47 {Tcl_ScanObjCmd, integer scanning, suppressed} { + set x {} + list [scan {123def} {%*i%s} x] $x +} {1 def} +test scan-4.48 {Tcl_ScanObjCmd, float scanning} { + list [scan {1 2 3} {%e %f %g} x y z] $x $y $z +} {3 1.0 2.0 3.0} +test scan-4.49 {Tcl_ScanObjCmd, float scanning} { + list [scan {.1 0.2 3.} {%e %f %g} x y z] $x $y $z +} {3 0.1 0.2 3.0} +test scan-4.50 {Tcl_ScanObjCmd, float scanning} { + list [scan {1234567890a} %f x] $x +} {1 1234567890.0} +test scan-4.51 {Tcl_ScanObjCmd, float scanning} { + list [scan {+123+45} %f x] $x +} {1 123.0} +test scan-4.52 {Tcl_ScanObjCmd, float scanning} { + list [scan {-123+45} %f x] $x +} {1 -123.0} +test scan-4.53 {Tcl_ScanObjCmd, float scanning} { + list [scan {1.0e1} %f x] $x +} {1 10.0} +test scan-4.54 {Tcl_ScanObjCmd, float scanning} { + list [scan {1.0e-1} %f x] $x +} {1 0.1} +test scan-4.55 {Tcl_ScanObjCmd, odd cases} { + set x {} + list [scan {+} %f x] $x +} {-1 {}} +test scan-4.56 {Tcl_ScanObjCmd, odd cases} { + set x {} + list [scan {1.0e} %f%s x y] $x $y +} {2 1.0 e} +test scan-4.57 {Tcl_ScanObjCmd, odd cases} { + set x {} + list [scan {1.0e+} %f%s x y] $x $y +} {2 1.0 e+} +test scan-4.58 {Tcl_ScanObjCmd, odd cases} { + set x {} + set y {} + list [scan {e1} %f%s x y] $x $y +} {0 {} {}} +test scan-4.59 {Tcl_ScanObjCmd, float scanning} { + list [scan {1.0e-1x} %*f%n x] $x +} {1 6} + +test scan-4.60 {Tcl_ScanObjCmd, set errors} { + set x {} + set y {} + catch {unset z}; array set z {} + set result [list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] \ + $msg $x $y] + unset z + set result +} {1 {couldn't set variable "z"} abc ghi} +test scan-4.61 {Tcl_ScanObjCmd, set errors} { + set x {} + catch {unset y}; array set y {} + catch {unset z}; array set z {} + set result [list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] \ + $msg $x] + unset y + unset z + set result +} {1 {couldn't set variable "z"couldn't set variable "y"} abc} + +test scan-5.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} { +test scan-5.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} { +test scan-5.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} { +test scan-5.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} { +test scan-5.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} { +test scan-5.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} { +test scan-5.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} { +test scan-5.8 {integer scanning} { set a {}; set b {} list [scan "a 1234" "%d %d" a b] $a $b } {0 {} {}} -test scan-1.9 {integer scanning} { +test scan-5.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} { +test scan-5.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 {} {}} @@ -60,20 +362,21 @@ test scan-1.10 {integer scanning} { # not defined by the ANSI spec. Some implementations wrap the # input (-16) some return MAX_INT. # -test scan-1.11 {integer scanning} {nonPortable} { +test scan-5.11 {integer scanning} {nonPortable} { set a {}; set b {}; - list [scan "4294967280 4294967280" "%u %d" a b] $a $b -} {2 4294967280 -16} + list [scan "4294967280 4294967280" "%u %d" a b] $a \ + [expr {$b == -16 || $b == 0x7fffffff}] +} {2 4294967280 1} -test scan-2.1 {floating-point scanning} { +test scan-6.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} { +test scan-6.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} { +test scan-6.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} @@ -81,166 +384,203 @@ test scan-2.3 {floating-point scanning} { # 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} { +test scan-6.4 {floating-point scanning} { 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} { +test scan-6.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} {eformat} { +test scan-6.6 {floating-point scanning} {eformat} { set a {}; set b {}; set c {}; set d {} list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d } {4 1.2345 0.697 124.0 5e-05} -test scan-2.7 {floating-point scanning} { +test scan-6.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} { +test scan-6.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} { +test scan-7.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} { +test scan-7.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} { +test scan-7.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} { +test scan-7.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} { +test scan-7.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-7.6 {string and character scanning, unicode} { + set a {}; set b {}; set c {}; set d {} + list [scan "abc d\u00c7fghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d +} "4 abc d\u00c7f ghijk dum" +test scan-7.7 {string and character scanning, unicode} { + set a {}; set b {} + list [scan "ab\u00c7cdef" "ab%c%c" a b] $a $b +} "2 199 99" +test scan-7.8 {string and character scanning, unicode} { + set a {}; set b {} + list [scan "ab\ufeffdef" "%\[ab\ufeff\]" a] $a +} "1 ab\ufeff" -test scan-4.1 {error conditions} { +test scan-8.1 {error conditions} { catch {scan a} } 1 -test scan-4.2 {error conditions} { +test scan-8.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 +test scan-8.3 {error conditions} { + list [catch {scan a %D x} msg] $msg } {1 {bad scan conversion character "D"}} -test scan-4.6 {error conditions} { - list [catch {scan a %O} msg] $msg +test scan-8.4 {error conditions} { + list [catch {scan a %O x} msg] $msg } {1 {bad scan conversion character "O"}} -test scan-4.7 {error conditions} { - list [catch {scan a %X} msg] $msg +test scan-8.5 {error conditions} { + list [catch {scan a %X x} msg] $msg } {1 {bad scan conversion character "X"}} -test scan-4.8 {error conditions} { - list [catch {scan a %F} msg] $msg +test scan-8.6 {error conditions} { + list [catch {scan a %F x} msg] $msg } {1 {bad scan conversion character "F"}} -test scan-4.9 {error conditions} { - list [catch {scan a %E} msg] $msg +test scan-8.7 {error conditions} { + list [catch {scan a %E x} msg] $msg } {1 {bad scan conversion character "E"}} -test scan-4.10 {error conditions} { +test scan-8.8 {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} { +test scan-8.9 {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} { +} {1 {variable is not assigend by any conversion specifiers}} +test scan-8.10 {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} { +test scan-8.11 {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} { +test scan-8.12 {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} { +test scan-8.13 {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} { +test scan-8.14 {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} { +test scan-8.15 {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} { +test scan-8.16 {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} { +test scan-8.17 {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 +test scan-8.18 {error conditions} { + list [catch {scan abc {%[} x} msg] $msg +} {1 {unmatched [ in format string}} +test scan-8.19 {error conditions} { + list [catch {scan abc {%[^a} x} msg] $msg +} {1 {unmatched [ in format string}} +test scan-8.20 {error conditions} { + list [catch {scan abc {%[^]a} x} msg] $msg +} {1 {unmatched [ in format string}} +test scan-8.21 {error conditions} { + list [catch {scan abc {%[]a} x} msg] $msg } {1 {unmatched [ in format string}} -test scan-5.1 {lots of arguments} { +test scan-9.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} { +test scan-9.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} { +test scan-10.1 {miscellaneous tests} { set a {} list [scan ab16c ab%dc a] $a } {1 16} -test scan-6.2 {miscellaneous tests} { +test scan-10.2 {miscellaneous tests} { set a {} list [scan ax16c ab%dc a] $a } {0 {}} -test scan-6.3 {miscellaneous tests} { +test scan-10.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} { +test scan-10.4 {miscellaneous tests} { set a {} list [catch {scan ab%c14 ab%%c%d a} msg] $msg $a } {0 1 14} +test scan-10.5 {miscellaneous tests} { + catch {unset arr} + set arr(2) {} + list [catch {scan ab%c14 ab%%c%d arr(2)} msg] $msg $arr(2) +} {0 1 14} -test scan-7.1 {alignment in results array (TCL_ALIGN)} { +test scan-11.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)} { +test scan-11.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)} { +test scan-11.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)} { +test scan-11.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)} { +test scan-11.5 {alignment in results array (TCL_ALIGN)} { scan "1234567890123456789 13.6" "%s %f" a b set b } 13.6 + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + + diff --git a/tests/security.test b/tests/security.test new file mode 100644 index 0000000..d75696a --- /dev/null +++ b/tests/security.test @@ -0,0 +1,53 @@ +# security.test -- +# +# 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. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. +# +# RCS: @(#) $Id: security.test,v 1.2 1999/04/16 00:47:34 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +# If this proc becomes invoked, then there is a bug + +proc BUG {args} { + set ::BUG 1 +} + +# Check and Clear the bug flag (to do before each test) +set ::BUG 0 + +proc CB {} { + set ret $::BUG + set ::BUG 0 + return $ret +} + + +test sec-1.1 {tcl_endOfPreviousWord} { + catch {tcl_startOfPreviousWord x {[BUG]}} + CB +} 0 + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + diff --git a/tests/set-old.test b/tests/set-old.test index bd93730..08e2cd1 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -8,13 +8,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: set-old.test,v 1.3 1998/09/14 18:40:13 stanton Exp $ +# RCS: @(#) $Id: set-old.test,v 1.4 1999/04/16 00:47:34 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} proc ignore args {} @@ -786,9 +789,23 @@ test set-old-12.2 {cleanup on procedure return} { # 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 "" + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/set.test b/tests/set.test index 5d762b4..7ffeb75 100644 --- a/tests/set.test +++ b/tests/set.test @@ -5,13 +5,16 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: set.test,v 1.2 1998/09/14 18:40:13 stanton Exp $ +# RCS: @(#) $Id: set.test,v 1.3 1999/04/16 00:47:34 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {unset x} catch {unset i} @@ -27,7 +30,7 @@ test set-1.3 {TclCompileSetCmd: error compiling variable name} { set i 10 catch {set "i"xxx} msg set msg -} {quoted string doesn't terminate properly} +} {extra characters after close-quote} test set-1.4 {TclCompileSetCmd: simple variable name in quotes} { set i 17 list [set "i"] $i @@ -226,8 +229,271 @@ test set-2.6 {set command: runtime error, basic array operations} { list [catch {set a} msg] $msg } {1 {can't read "a": variable is array}} +# Test the uncompiled version of set + catch {unset a} catch {unset b} catch {unset i} catch {unset x} -return "" + +test set-3.1 {uncompiled set command: missing variable name} { + set z set + list [catch {$z} msg] $msg +} {1 {wrong # args: should be "set varName ?newValue?"}} +test set-3.2 {uncompiled set command: simple variable name} { + set z set + $z i 10 + list [$z i] $i +} {10 10} +test set-3.3 {uncompiled set command: error compiling variable name} { + set z set + $z i 10 + catch {$z "i"xxx} msg + $z msg +} {extra characters after close-quote} +test set-3.4 {uncompiled set command: simple variable name in quotes} { + set z set + $z i 17 + list [$z "i"] $i +} {17 17} +test set-3.5 {uncompiled set command: simple variable name in braces} { + set z set + catch {unset {a simple var}} + $z {a simple var} 27 + list [$z {a simple var}] ${a simple var} +} {27 27} +test set-3.6 {uncompiled set command: simple array variable name} { + set z set + catch {unset a} + $z a(foo) 37 + list [$z a(foo)] $a(foo) +} {37 37} +test set-3.7 {uncompiled set command: non-simple (computed) variable name} { + set z set + $z x "i" + $z i 77 + list [$z $x] $i +} {77 77} +test set-3.8 {uncompiled set command: non-simple (computed) variable name} { + set z set + $z x "i" + $z i 77 + list [$z [$z x] 2] $i +} {2 2} + +test set-3.9 {uncompiled set command: 3rd arg => assignment} { + set z set + $z i "abcdef" + list [$z i] $i +} {abcdef abcdef} +test set-3.10 {uncompiled set command: only two args => just getting value} { + set z set + $z i {one two} + $z i +} {one two} + +test set-3.11 {uncompiled set command: simple global name} { + proc p {} { + set z set + global i + $z i 54 + $z i + } + p +} {54} +test set-3.12 {uncompiled set command: simple local name} { + proc p {bar} { + set z set + $z foo $bar + $z foo + } + p 999 +} {999} +test set-3.13 {uncompiled set command: simple but new (unknown) local name} { + set z set + proc p {} { + set z set + $z bar + } + catch {p} msg + $z msg +} {can't read "bar": no such variable} +test set-3.14 {uncompiled set command: simple local name, >255 locals} { + proc 260locals {} { + set z set + # create 260 locals (the last ones with index > 255) + $z a0 0; $z a1 0; $z a2 0; $z a3 0; $z a4 0 + $z a5 0; $z a6 0; $z a7 0; $z a8 0; $z a9 0 + $z b0 0; $z b1 0; $z b2 0; $z b3 0; $z b4 0 + $z b5 0; $z b6 0; $z b7 0; $z b8 0; $z b9 0 + $z c0 0; $z c1 0; $z c2 0; $z c3 0; $z c4 0 + $z c5 0; $z c6 0; $z c7 0; $z c8 0; $z c9 0 + $z d0 0; $z d1 0; $z d2 0; $z d3 0; $z d4 0 + $z d5 0; $z d6 0; $z d7 0; $z d8 0; $z d9 0 + $z e0 0; $z e1 0; $z e2 0; $z e3 0; $z e4 0 + $z e5 0; $z e6 0; $z e7 0; $z e8 0; $z e9 0 + $z f0 0; $z f1 0; $z f2 0; $z f3 0; $z f4 0 + $z f5 0; $z f6 0; $z f7 0; $z f8 0; $z f9 0 + $z g0 0; $z g1 0; $z g2 0; $z g3 0; $z g4 0 + $z g5 0; $z g6 0; $z g7 0; $z g8 0; $z g9 0 + $z h0 0; $z h1 0; $z h2 0; $z h3 0; $z h4 0 + $z h5 0; $z h6 0; $z h7 0; $z h8 0; $z h9 0 + $z i0 0; $z i1 0; $z i2 0; $z i3 0; $z i4 0 + $z i5 0; $z i6 0; $z i7 0; $z i8 0; $z i9 0 + $z j0 0; $z j1 0; $z j2 0; $z j3 0; $z j4 0 + $z j5 0; $z j6 0; $z j7 0; $z j8 0; $z j9 0 + $z k0 0; $z k1 0; $z k2 0; $z k3 0; $z k4 0 + $z k5 0; $z k6 0; $z k7 0; $z k8 0; $z k9 0 + $z l0 0; $z l1 0; $z l2 0; $z l3 0; $z l4 0 + $z l5 0; $z l6 0; $z l7 0; $z l8 0; $z l9 0 + $z m0 0; $z m1 0; $z m2 0; $z m3 0; $z m4 0 + $z m5 0; $z m6 0; $z m7 0; $z m8 0; $z m9 0 + $z n0 0; $z n1 0; $z n2 0; $z n3 0; $z n4 0 + $z n5 0; $z n6 0; $z n7 0; $z n8 0; $z n9 0 + $z o0 0; $z o1 0; $z o2 0; $z o3 0; $z o4 0 + $z o5 0; $z o6 0; $z o7 0; $z o8 0; $z o9 0 + $z p0 0; $z p1 0; $z p2 0; $z p3 0; $z p4 0 + $z p5 0; $z p6 0; $z p7 0; $z p8 0; $z p9 0 + $z q0 0; $z q1 0; $z q2 0; $z q3 0; $z q4 0 + $z q5 0; $z q6 0; $z q7 0; $z q8 0; $z q9 0 + $z r0 0; $z r1 0; $z r2 0; $z r3 0; $z r4 0 + $z r5 0; $z r6 0; $z r7 0; $z r8 0; $z r9 0 + $z s0 0; $z s1 0; $z s2 0; $z s3 0; $z s4 0 + $z s5 0; $z s6 0; $z s7 0; $z s8 0; $z s9 0 + $z t0 0; $z t1 0; $z t2 0; $z t3 0; $z t4 0 + $z t5 0; $z t6 0; $z t7 0; $z t8 0; $z t9 0 + $z u0 0; $z u1 0; $z u2 0; $z u3 0; $z u4 0 + $z u5 0; $z u6 0; $z u7 0; $z u8 0; $z u9 0 + $z v0 0; $z v1 0; $z v2 0; $z v3 0; $z v4 0 + $z v5 0; $z v6 0; $z v7 0; $z v8 0; $z v9 0 + $z w0 0; $z w1 0; $z w2 0; $z w3 0; $z w4 0 + $z w5 0; $z w6 0; $z w7 0; $z w8 0; $z w9 0 + $z x0 0; $z x1 0; $z x2 0; $z x3 0; $z x4 0 + $z x5 0; $z x6 0; $z x7 0; $z x8 0; $z x9 0 + $z y0 0; $z y1 0; $z y2 0; $z y3 0; $z y4 0 + $z y5 0; $z y6 0; $z y7 0; $z y8 0; $z y9 0 + $z z0 0; $z z1 0; $z z2 0; $z z3 0; $z z4 0 + $z z5 0; $z z6 0; $z z7 0; $z z8 0; $z z9 1234 + } + 260locals +} {1234} +test set-3.15 {uncompiled set command: variable is array} { + set z set + catch {unset a} + $z x 27 + $z x [$z a(foo) 11] + catch {unset a} + $z x +} 11 +test set-3.16 {uncompiled set command: variable is array, elem substitutions} { + set z set + catch {unset a} + $z i 5 + $z x 789 + $z a(foo5) 27 + $z x [$z a(foo$i)] + catch {unset a} + $z x +} 27 + +test set-3.17 {uncompiled set command: doing assignment, simple int} { + set z set + $z i 5 + $z i 123 +} 123 +test set-3.18 {uncompiled set command: doing assignment, simple int} { + set z set + $z i 5 + $z i -100 +} -100 +test set-3.19 {uncompiled set command: doing assignment, simple but not int} { + set z set + $z i 5 + $z i 0x12MNOP + $z i +} {0x12MNOP} +test set-3.20 {uncompiled set command: doing assignment, in quotes} { + set z set + $z i 25 + $z i "-100" +} -100 +test set-3.21 {uncompiled set command: doing assignment, in braces} { + set z set + $z i 24 + $z i {126} +} 126 +test set-3.22 {uncompiled set command: doing assignment, large int} { + set z set + $z i 5 + $z i 200000 +} 200000 +test set-3.23 {uncompiled set command: doing assignment, formatted int != int} { + set z set + $z i 25 + $z i 000012345 ;# an octal literal == 5349 decimal + list $i [incr i] +} {000012345 5350} + +test set-3.24 {uncompiled set command: too many arguments} { + set z set + $z i 10 + catch {$z i 20 30} msg + $z msg +} {wrong # args: should be "set varName ?newValue?"} + +test set-4.1 {uncompiled set command: runtime error, bad variable name} { + set z set + list [catch {$z {"foo}} msg] $msg $errorInfo +} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable + while executing +"$z {"foo}"}} +test set-4.2 {uncompiled set command: runtime error, not array variable} { + set z set + catch {unset b} + $z b 44 + list [catch {$z b(123)} msg] $msg +} {1 {can't read "b(123)": variable isn't array}} +test set-4.3 {uncompiled set command: runtime error, errors in reading variables} { + set z set + catch {unset a} + $z a(6) 44 + list [catch {$z a(18)} msg] $msg +} {1 {can't read "a(18)": no such element in array}} +test set-4.4 {uncompiled set command: runtime error, readonly variable} { + set z set + proc readonly args {error "variable is read-only"} + $z x 123 + trace var x w readonly + list [catch {$z x 1} msg] $msg $errorInfo +} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only + while executing +"$z x 1"}} +test set-4.5 {uncompiled set command: runtime error, basic array operations} { + set z set + list [catch {$z a(other)} msg] $msg +} {1 {can't read "a(other)": no such element in array}} +test set-4.6 {set command: runtime error, basic array operations} { + set z set + list [catch {$z a} msg] $msg +} {1 {can't read "a": variable is array}} + +# cleanup +catch {unset a} +catch {unset b} +catch {unset i} +catch {unset x} +catch {unset z} +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/socket.test b/tests/socket.test index 5ff563a..249dc5e 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -5,10 +5,13 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # +# RCS: @(#) $Id: socket.test,v 1.7 1999/04/16 00:47:34 stanton Exp $ + # Running socket tests with a remote server: # ------------------------------------------ # @@ -58,15 +61,16 @@ # 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. -# -# RCS: @(#) $Id: socket.test,v 1.6 1998/12/04 01:01:55 stanton Exp $ - -if {[string compare test [info procs test]] == 1} then {source defs} -if {$testConfig(socket) == 0} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } +# Some tests require the testthread command + +set ::tcltest::testConfig(testthread) \ + [expr {[info commands testthread] != {}}] + # # If remoteServerIP or remoteServerPort are not set, check in the # environment variables for externally set values. @@ -93,7 +97,7 @@ if {![info exists remoteServerPort]} { set doTestsWithRemoteServer 1 if {![info exists remoteServerIP] && ($tcl_platform(platform) != "macintosh")} { - set remoteServerIP localhost + set remoteServerIP 127.0.0.1 } if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} { set remoteServerPort 2048 @@ -115,13 +119,11 @@ if {$doTestsWithRemoteServer} { 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 + set remoteServerIP 127.0.0.1 + set remoteFile [file join [pwd] remote.tcl] if {[catch {set remoteProcChan \ - [open "|[list $tcltest remote.tcl \ + [open "|[list $tcltest $remoteFile \ -serverIsSilent \ -port $remoteServerPort \ -address $remoteServerIP]" \ @@ -145,10 +147,12 @@ if {$doTestsWithRemoteServer} { } } +# Some tests are run only if we are doing testing against a remote server. +set ::tcltest::testConfig(doTestsWithRemoteServer) $doTestsWithRemoteServer 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)} { + if {[string first s $::tcltest::verbose] != -1} { + puts "Skipping tests with remote server. See tests/socket.test for" + puts "information on how to run remote server." puts "Reason for not doing remote tests: $noRemoteTestReason" } } @@ -192,54 +196,54 @@ if {$doTestsWithRemoteServer == 1} { } } -test socket-1.1 {arg parsing for socket command} { +test socket-1.1 {arg parsing for socket command} {socket} { list [catch {socket -server} msg] $msg } {1 {no argument given for -server option}} -test socket-1.2 {arg parsing for socket command} { +test socket-1.2 {arg parsing for socket command} {socket} { 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} { +test socket-1.3 {arg parsing for socket command} {socket} { list [catch {socket -myaddr} msg] $msg } {1 {no argument given for -myaddr option}} -test socket-1.4 {arg parsing for socket command} { +test socket-1.4 {arg parsing for socket command} {socket} { 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} { +test socket-1.5 {arg parsing for socket command} {socket} { list [catch {socket -myport} msg] $msg } {1 {no argument given for -myport option}} -test socket-1.6 {arg parsing for socket command} { +test socket-1.6 {arg parsing for socket command} {socket} { list [catch {socket -myport xxxx} msg] $msg } {1 {expected integer but got "xxxx"}} -test socket-1.7 {arg parsing for socket command} { +test socket-1.7 {arg parsing for socket command} {socket} { 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} { +test socket-1.8 {arg parsing for socket command} {socket} { 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} { +} {1 {bad option "-froboz": must be -async, -myaddr, -myport, or -server}} +test socket-1.9 {arg parsing for socket command} {socket} { 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} { +test socket-1.10 {arg parsing for socket command} {socket} { 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} { +test socket-1.11 {arg parsing for socket command} {socket} { 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} { +test socket-1.12 {arg parsing for socket command} {socket} { list [catch {socket foo badport} msg] $msg } {1 {expected integer but got "badport"}} -test socket-2.1 {tcp connection} {stdio} { +test socket-2.1 {tcp connection} {socket stdio} { removeFile script set f [open script w] puts $f { @@ -259,7 +263,7 @@ test socket-2.1 {tcp connection} {stdio} { close $f set f [open "|[list $tcltest script]" r] gets $f x - if {[catch {socket localhost 2828} msg]} { + if {[catch {socket 127.0.0.1 2828} msg]} { set x $msg } else { lappend x [gets $f] @@ -275,12 +279,12 @@ if [info exists port] { } else { set port [expr 2048 + [pid]%1024] } -test socket-2.2 {tcp connection with client port specified} {stdio} { +test socket-2.2 {tcp connection with client port specified} {socket stdio} { removeFile script set f [open script w] puts $f { set timer [after 2000 "set x done"] - set f [socket -server accept 2828] + set f [socket -server accept 2829] proc accept {file addr port} { global x puts "[gets $file] $port" @@ -296,9 +300,9 @@ test socket-2.2 {tcp connection with client port specified} {stdio} { set f [open "|[list $tcltest script]" r] gets $f x global port - if {[catch {socket -myport $port localhost 2828} sock]} { + if {[catch {socket -myport $port 127.0.0.1 2829} sock]} { set x $sock - close [socket localhost 2828] + close [socket 127.0.0.1 2829] puts stderr $sock } else { puts $sock hello @@ -309,12 +313,12 @@ test socket-2.2 {tcp connection with client port specified} {stdio} { close $f set x } [list ready "hello $port"] -test socket-2.3 {tcp connection with client interface specified} {stdio} { +test socket-2.3 {tcp connection with client interface specified} {socket stdio} { removeFile script set f [open script w] puts $f { set timer [after 2000 "set x done"] - set f [socket -server accept 2828] + set f [socket -server accept 2830] proc accept {file addr port} { global x puts "[gets $file] $addr" @@ -329,7 +333,7 @@ test socket-2.3 {tcp connection with client interface specified} {stdio} { close $f set f [open "|[list $tcltest script]" r] gets $f x - if {[catch {socket -myaddr localhost localhost 2828} sock]} { + if {[catch {socket -myaddr 127.0.0.1 127.0.0.1 2830} sock]} { set x $sock } else { puts $sock hello @@ -340,12 +344,12 @@ test socket-2.3 {tcp connection with client interface specified} {stdio} { close $f set x } {ready {hello 127.0.0.1}} -test socket-2.4 {tcp connection with server interface specified} {stdio} { +test socket-2.4 {tcp connection with server interface specified} {socket 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] + set f [socket -server accept -myaddr [info hostname] 2831] proc accept {file addr port} { global x puts "[gets $file]" @@ -360,7 +364,7 @@ test socket-2.4 {tcp connection with server interface specified} {stdio} { close $f set f [open "|[list $tcltest script]" r] gets $f x - if {[catch {socket [info hostname] 2828} sock]} { + if {[catch {socket [info hostname] 2831} sock]} { set x $sock } else { puts $sock hello @@ -371,12 +375,12 @@ test socket-2.4 {tcp connection with server interface specified} {stdio} { close $f set x } {ready hello} -test socket-2.5 {tcp connection with redundant server port} {stdio} { +test socket-2.5 {tcp connection with redundant server port} {socket stdio} { removeFile script set f [open script w] puts $f { set timer [after 2000 "set x done"] - set f [socket -server accept 2828] + set f [socket -server accept 2832] proc accept {file addr port} { global x puts "[gets $file]" @@ -391,7 +395,7 @@ test socket-2.5 {tcp connection with redundant server port} {stdio} { close $f set f [open "|[list $tcltest script]" r] gets $f x - if {[catch {socket localhost 2828} sock]} { + if {[catch {socket 127.0.0.1 2832} sock]} { set x $sock } else { puts $sock hello @@ -402,9 +406,9 @@ test socket-2.5 {tcp connection with redundant server port} {stdio} { close $f set x } {ready hello} -test socket-2.6 {tcp connection} {} { +test socket-2.6 {tcp connection} {socket} { set status ok - if {![catch {set sock [socket localhost 2828]}]} { + if {![catch {set sock [socket 127.0.0.1 2833]}]} { if {![catch {gets $sock}]} { set status broken } @@ -412,12 +416,12 @@ test socket-2.6 {tcp connection} {} { } set status } ok -test socket-2.7 {echo server, one line} {stdio} { +test socket-2.7 {echo server, one line} {socket stdio} { removeFile script set f [open script w] puts $f { set timer [after 2000 "set x done"] - set f [socket -server accept 2828] + set f [socket -server accept 2834] proc accept {s a p} { fileevent $s readable [list echo $s] fconfigure $s -translation lf -buffering line @@ -441,20 +445,19 @@ test socket-2.7 {echo server, one line} {stdio} { close $f set f [open "|[list $tcltest script]" r] gets $f - set s [socket localhost 2828] + set s [socket 127.0.0.1 2834] fconfigure $s -buffering line -translation lf puts $s "hello abcdefghijklmnop" + after 1000 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] +test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} { + makeFile { + set f [socket -server accept 2835] proc accept {s a p} { fileevent $s readable [list echo $s] fconfigure $s -buffering line @@ -478,26 +481,27 @@ test socket-2.8 {echo server, loop 50 times, single connection} {stdio} { after cancel $timer close $f puts "done $i" - } - close $f + } script set f [open "|[list $tcltest script]" r] gets $f - set s [socket localhost 2828] + set s [socket 127.0.0.1 2835] fconfigure $s -buffering line - for {set x 0} {$x < 50} {incr x} { - puts $s "hello abcdefghijklmnop" - gets $s + catch { + for {set x 0} {$x < 50} {incr x} { + puts $s "hello abcdefghijklmnop" + gets $s + } } close $s - set x [gets $f] + catch {set x [gets $f]} close $f set x } {done 50} -test socket-2.9 {socket conflict} {stdio} { +test socket-2.9 {socket conflict} {socket stdio} { set s [socket -server accept 2828] removeFile script set f [open script w] - puts $f {set f [socket -server accept 2828]} + puts -nonewline $f {socket -server accept 2828} close $f set f [open "|[list $tcltest script]" r] gets $f @@ -509,7 +513,7 @@ test socket-2.9 {socket conflict} {stdio} { while executing "socket -server accept 2828" (file "script" line 1)}} -test socket-2.10 {close on accept, accepted socket lives} { +test socket-2.10 {close on accept, accepted socket lives} {socket} { set done 0 set timer [after 20000 "set done timed_out"] set ss [socket -server accept 2830] @@ -532,7 +536,7 @@ test socket-2.10 {close on accept, accepted socket lives} { after cancel $timer set done } 1 -test socket-2.11 {detecting new data} { +test socket-2.11 {detecting new data} {socket} { proc accept {s a p} { global sock set sock $s @@ -540,7 +544,7 @@ test socket-2.11 {detecting new data} { set s [socket -server accept 2400] set sock "" - set s2 [socket localhost 2400] + set s2 [socket 127.0.0.1 2400] vwait sock puts $s2 one flush $s2 @@ -561,7 +565,7 @@ test socket-2.11 {detecting new data} { } {one {} two} -test socket-3.1 {socket conflict} {stdio} { +test socket-3.1 {socket conflict} {socket stdio} { removeFile script set f [open script w] puts $f { @@ -579,7 +583,7 @@ test socket-3.1 {socket conflict} {stdio} { close $f set x } {1 {couldn't open socket: address already in use}} -test socket-3.2 {server with several clients} {stdio} { +test socket-3.2 {server with several clients} {socket stdio} { removeFile script set f [open script w] puts $f { @@ -615,11 +619,11 @@ test socket-3.2 {server with several clients} {stdio} { close $f set f [open "|[list $tcltest script]" r+] set x [gets $f] - set s1 [socket localhost 2828] + set s1 [socket 127.0.0.1 2828] fconfigure $s1 -buffering line - set s2 [socket localhost 2828] + set s2 [socket 127.0.0.1 2828] fconfigure $s2 -buffering line - set s3 [socket localhost 2828] + set s3 [socket 127.0.0.1 2828] fconfigure $s3 -buffering line for {set i 0} {$i < 100} {incr i} { puts $s1 hello,s1 @@ -637,12 +641,12 @@ test socket-3.2 {server with several clients} {stdio} { set x } {ready done} -test socket-4.1 {server with several clients} {stdio} { +test socket-4.1 {server with several clients} {socket stdio} { removeFile script set f [open script w] puts $f { gets stdin - set s [socket localhost 2828] + set s [socket 127.0.0.1 2828] fconfigure $s -buffering line for {set i 0} {$i < 100} {incr i} { puts $s hello @@ -699,7 +703,7 @@ test socket-4.1 {server with several clients} {stdio} { close $p3 set l } {{p1 bye done} {p2 bye done} {p3 bye done}} -test socket-4.2 {byte order problems, socket numbers, htons} { +test socket-4.2 {byte order problems, socket numbers, htons} {socket} { set x ok if {[catch {socket -server dodo 0x3000} msg]} { set x $msg @@ -709,10 +713,8 @@ test socket-4.2 {byte order problems, socket numbers, htons} { set x } ok -test socket-5.1 {byte order problems, socket numbers, htons} {unixOnly} { - # - # THIS TEST WILL FAIL if you are running as superuser. - # +test socket-5.1 {byte order problems, socket numbers, htons} \ + {socket unixOnly notRoot} { 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?} @@ -720,7 +722,7 @@ test socket-5.1 {byte order problems, socket numbers, htons} {unixOnly} { } set x } {couldn't open socket: not owner} -test socket-5.2 {byte order problems, socket numbers, htons} { +test socket-5.2 {byte order problems, socket numbers, htons} {socket} { 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} @@ -728,10 +730,8 @@ test socket-5.2 {byte order problems, socket numbers, htons} { } 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. - # +test socket-5.3 {byte order problems, socket numbers, htons} \ + {socket unixOnly notRoot} { 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?} @@ -740,12 +740,12 @@ test socket-5.3 {byte order problems, socket numbers, htons} {unixOnly} { set x } {couldn't open socket: not owner} -test socket-6.1 {accept callback error} {stdio} { +test socket-6.1 {accept callback error} {socket stdio} { removeFile script set f [open script w] puts $f { gets stdin - socket localhost 2848 + socket 127.0.0.1 2848 } close $f set f [open "|[list $tcltest script]" r+] @@ -765,7 +765,7 @@ test socket-6.1 {accept callback error} {stdio} { set x } {{divide by zero}} -test socket-7.1 {testing socket specific options} {stdio} { +test socket-7.1 {testing socket specific options} {socket stdio} { removeFile script set f [open script w] puts $f { @@ -782,7 +782,7 @@ test socket-7.1 {testing socket specific options} {stdio} { close $f set f [open "|[list $tcltest script]" r] gets $f - set s [socket localhost 2820] + set s [socket 127.0.0.1 2820] set p [fconfigure $s -peername] close $s close $f @@ -791,7 +791,7 @@ test socket-7.1 {testing socket specific options} {stdio} { lappend l [string compare [lindex $p 2] 2820] lappend l [llength $p] } {0 0 3} -test socket-7.2 {testing socket specific options} {stdio} { +test socket-7.2 {testing socket specific options} {socket stdio} { removeFile script set f [open script w] puts $f { @@ -808,7 +808,7 @@ test socket-7.2 {testing socket specific options} {stdio} { close $f set f [open "|[list $tcltest script]" r] gets $f - set s [socket localhost 2821] + set s [socket 127.0.0.1 2821] set p [fconfigure $s -sockname] close $s close $f @@ -817,14 +817,14 @@ test socket-7.2 {testing socket specific options} {stdio} { 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} { +test socket-7.3 {testing socket specific options} {socket} { set s [socket -server accept 2822] set l [fconfigure $s] close $s update llength $l -} 10 -test socket-7.4 {testing socket specific options} { +} 12 +test socket-7.4 {testing socket specific options} {socket} { set s [socket -server accept 2823] proc accept {s a p} { global x @@ -840,14 +840,14 @@ test socket-7.4 {testing socket specific options} { set l "" lappend l [lindex $x 2] [llength $x] } {2823 3} -test socket-7.5 {testing socket specific options} {unixOrPc} { +test socket-7.5 {testing socket specific options} {socket 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 s1 [socket 127.0.0.1 2829] set timer [after 10000 "set x timed_out"] vwait x after cancel $timer @@ -857,7 +857,7 @@ test socket-7.5 {testing socket specific options} {unixOrPc} { 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} { +test socket-8.1 {testing -async flag on sockets} {socket} { # NOTE: This test may fail on some Solaris 2.4 systems. If it does, # check that you have these patches installed (using showrev -p): # @@ -887,7 +887,7 @@ test socket-8.1 {testing -async flag on sockets} { set z } bye -test socket-9.1 {testing spurious events} { +test socket-9.1 {testing spurious events} {socket} { set len 0 set spurious 0 set done 0 @@ -919,7 +919,7 @@ test socket-9.1 {testing spurious events} { close $s list $spurious $len } {0 50} -test socket-9.2 {testing async write, fileevents, flush on close} {} { +test socket-9.2 {testing async write, fileevents, flush on close} {socket} { set firstblock "" for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"} set secondblock "" @@ -967,7 +967,7 @@ test socket-9.2 {testing async write, fileevents, flush on close} {} { close $l set count } 65566 -test socket-9.3 {testing EOF stickyness} { +test socket-9.3 {testing EOF stickyness} {socket} { proc count_to_eof {s} { global count done timer set l [gets $s] @@ -1007,30 +1007,21 @@ test socket-9.3 {testing EOF stickyness} { set count } {eof is sticky} -test socket-10.1 {testing socket accept callback error handling} { +removeFile script + +test socket-10.1 {testing socket accept callback error handling} {socket} { set goterror 0 proc bgerror args {global goterror; set goterror 1} set s [socket -server accept 2898] proc accept {s a p} {close $s; error} - set c [socket localhost 2898] + set c [socket 127.0.0.1 2898] vwait goterror close $s close $c set goterror } 1 -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-11.1 {tcp connection} { +test socket-11.1 {tcp connection} {socket doTestsWithRemoteServer} { sendCommand { set socket9_1_test_server [socket -server accept 2834] proc accept {s a p} { @@ -1044,7 +1035,7 @@ test socket-11.1 {tcp connection} { sendCommand {close $socket9_1_test_server} set r } done -test socket-11.2 {client specifies its port} { +test socket-11.2 {client specifies its port} {socket doTestsWithRemoteServer} { if {[info exists port]} { incr port } else { @@ -1068,7 +1059,7 @@ test socket-11.2 {client specifies its port} { } set result } ok -test socket-11.3 {trying to connect, no server} { +test socket-11.3 {trying to connect, no server} {socket doTestsWithRemoteServer} { set status ok if {![catch {set s [socket $remoteServerIp 2836]}]} { if {![catch {gets $s}]} { @@ -1078,7 +1069,7 @@ test socket-11.3 {trying to connect, no server} { } set status } ok -test socket-11.4 {remote echo, one line} { +test socket-11.4 {remote echo, one line} {socket doTestsWithRemoteServer} { sendCommand { set socket10_6_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1102,7 +1093,7 @@ test socket-11.4 {remote echo, one line} { sendCommand {close $socket10_6_test_server} set r } hello -test socket-11.5 {remote echo, 50 lines} { +test socket-11.5 {remote echo, 50 lines} {socket doTestsWithRemoteServer} { sendCommand { set socket10_7_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1136,7 +1127,7 @@ if {$tcl_platform(platform) == "macintosh"} { } else { set conflictResult {1 {couldn't open socket: address already in use}} } -test socket-11.6 {socket conflict} { +test socket-11.6 {socket conflict} {socket doTestsWithRemoteServer} { set s1 [socket -server accept 2836] if {[catch {set s2 [socket -server accept 2836]} msg]} { set result [list 1 $msg] @@ -1147,7 +1138,7 @@ test socket-11.6 {socket conflict} { close $s1 set result } $conflictResult -test socket-11.7 {server with several clients} { +test socket-11.7 {server with several clients} {socket doTestsWithRemoteServer} { sendCommand { set socket10_9_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1183,7 +1174,7 @@ test socket-11.7 {server with several clients} { sendCommand {close $socket10_9_test_server} set i } 100 -test socket-11.8 {client with several servers} { +test socket-11.8 {client with several servers} {socket doTestsWithRemoteServer} { sendCommand { set s1 [socket -server "accept 4003" 4003] set s2 [socket -server "accept 4004" 4004] @@ -1209,7 +1200,7 @@ test socket-11.8 {client with several servers} { } set l } {4003 {} 1 4004 {} 1 4005 {} 1} -test socket-11.9 {accept callback error} { +test socket-11.9 {accept callback error} {socket doTestsWithRemoteServer} { set s [socket -server accept 2836] proc accept {s a p} {expr 10 / 0} proc bgerror args { @@ -1231,7 +1222,7 @@ test socket-11.9 {accept callback error} { rename bgerror {} set x } {{divide by zero}} -test socket-11.10 {testing socket specific options} { +test socket-11.10 {testing socket specific options} {socket doTestsWithRemoteServer} { sendCommand { set socket10_12_test_server [socket -server accept 2836] proc accept {s a p} {close $s} @@ -1245,7 +1236,7 @@ test socket-11.10 {testing socket specific options} { sendCommand {close $socket10_12_test_server} set l } {2836 3 3} -test socket-11.11 {testing spurious events} { +test socket-11.11 {testing spurious events} {socket doTestsWithRemoteServer} { sendCommand { set socket10_13_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1284,7 +1275,7 @@ test socket-11.11 {testing spurious events} { sendCommand {close $socket10_13_test_server} list $spurious $len } {0 2690} -test socket-11.12 {testing EOF stickyness} { +test socket-11.12 {testing EOF stickyness} {socket doTestsWithRemoteServer} { set counter 0 set done 0 proc count_up {s} { @@ -1317,7 +1308,8 @@ test socket-11.12 {testing EOF stickyness} { sendCommand {close $socket10_14_test_server} set done } {EOF is sticky} -test socket-11.13 {testing async write, async flush, async close} { +test socket-11.13 {testing async write, async flush, async close} \ + {socket doTestsWithRemoteServer} { proc readit {s} { global count done set l [read $s] @@ -1370,7 +1362,8 @@ test socket-11.13 {testing async write, async flush, async close} { set count } 65566 -test socket-12.1 {testing inheritance of server sockets} { +test socket-12.1 {testing inheritance of server sockets} \ + {socket doTestsWithRemoteServer} { removeFile script1 removeFile script2 @@ -1410,7 +1403,7 @@ test socket-12.1 {testing inheritance of server sockets} { # If we can still connect to the server, the socket got inherited. - if {[catch {socket localhost 2828} msg]} { + if {[catch {socket 127.0.0.1 2828} msg]} { set x {server socket was not inherited} } else { close $msg @@ -1421,7 +1414,8 @@ test socket-12.1 {testing inheritance of server sockets} { removeFile script2 set x } {server socket was not inherited} -test socket-12.2 {testing inheritance of client sockets} { +test socket-12.2 {testing inheritance of client sockets} \ + {socket doTestsWithRemoteServer} { removeFile script1 removeFile script2 @@ -1442,7 +1436,7 @@ test socket-12.2 {testing inheritance of client sockets} { set f [open script2 w] puts $f [list set tcltest $tcltest] puts $f { - set f [socket localhost 2829] + set f [socket 127.0.0.1 2829] exec $tcltest script1 & puts $f testing flush $f @@ -1506,7 +1500,8 @@ test socket-12.2 {testing inheritance of client sockets} { removeFile script2 set x } {client socket was not inherited} -test socket-12.3 {testing inheritance of accepted sockets} { +test socket-12.3 {testing inheritance of accepted sockets} \ + {socket doTestsWithRemoteServer} { removeFile script1 removeFile script2 @@ -1539,7 +1534,7 @@ test socket-12.3 {testing inheritance of accepted sockets} { after 1000 set ok_to_proceed 1 vwait ok_to_proceed - set f [socket localhost 2930] + set f [socket 127.0.0.1 2930] fconfigure $f -buffering full -blocking 0 fileevent $f readable [list getdata $f] @@ -1581,13 +1576,94 @@ test socket-12.3 {testing inheritance of accepted sockets} { set x } {accepted socket was not inherited} +test socket-13.1 {Testing use of shared socket between two threads} \ + {socket testthread} { + + set mainthread [testthread names] + proc ThreadReap {} { + global mainthread + testthread errorproc ThreadNullError + while {[llength [testthread names]] > 1} { + foreach tid [testthread names] { + if {$tid != $mainthread} { + catch {testthread send -async $tid {testthread exit}} + update + } + } + } + testthread errorproc ThreadError + return [llength [testthread names]] + } + + 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 + vwait x + close $f + + # thread cleans itself up. + testthread exit + } + close $f + + # create a thread + set serverthread [testthread create { source script } ] + update + + + set s [socket 127.0.0.1 2828] + fconfigure $s -buffering line + catch { + puts $s "hello" + gets $s result + } + close $s + update + + after 2000 + ThreadReap + + set result + +} hello + +# cleanup if {[string match sock* $commandSocket] == 1} { puts $commandSocket exit flush $commandSocket } catch {close $commandSocket} catch {close $remoteProcChan} +::tcltest::cleanupTests +flush stdout +return + + + + + + + + + + -set x "" -unset x diff --git a/tests/source.test b/tests/source.test index 590188f..74a3589 100644 --- a/tests/source.test +++ b/tests/source.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: source.test,v 1.2 1998/09/14 18:40:13 stanton Exp $ +# RCS: @(#) $Id: source.test,v 1.3 1999/04/16 00:47:34 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test source-1.1 {source command} { set x "old x value" @@ -30,23 +33,19 @@ test source-1.2 {source command} { makeFile {list result} source.file source source.file } result +test source-1.3 {source command} { + set y {\ } -# The mac version of source returns a different result for -# the next two tests. + set fd [open source.file w] + fconfigure $fd -translation lf + puts -nonewline $fd "list a b c " + puts $fd [string index $y 0] + puts $fd "d e f" + close $fd + + source source.file +} {a b c d e f} -if {$tcl_platform(platform) == "macintosh"} { - set retMsg1 {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} - set retMsg2 {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} -} else { - set retMsg1 {1 {wrong # args: should be "source fileName"}} - set retMsg2 {1 {wrong # args: should be "source fileName"}} -} -test source-2.1 {source error conditions} { - list [catch {source} msg] $msg -} $retMsg1 -test source-2.2 {source error conditions} { - list [catch {source a b} msg] $msg -} $retMsg2 test source-2.3 {source error conditions} { makeFile { set x 146 @@ -132,13 +131,13 @@ test source-4.2 {source error conditions} {macOnly} { } [list 1 "expected integer but got \"bad_id\""] test source-4.3 {source error conditions} {macOnly} { list [catch {source -rsrc rsrcName fileName extra} msg] $msg -} $retMsg1 +} {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} test source-4.4 {source error conditions} {macOnly} { list [catch {source non_switch rsrcName} msg] $msg -} $retMsg2 +} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} test source-4.5 {source error conditions} {macOnly} { list [catch {source -bad_switch argument} msg] $msg -} $retMsg2 +} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} test source-5.1 {source resource files} {macOnly} { list [catch {source -rsrc rsrcName bad_file} msg] $msg } [list 1 "Error finding the file: \"bad_file\"."] @@ -180,8 +179,19 @@ test source-6.1 {source is binary ok} { string length $x } 5 -catch {removeFile source.file} +# cleanup +catch {::tcltest::removeFile source.file} +::tcltest::cleanupTests +return + + + + + + + + + + -# Generate null final value -concat {} diff --git a/tests/split.test b/tests/split.test index 8674db8..fc78e84 100644 --- a/tests/split.test +++ b/tests/split.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: split.test,v 1.2 1998/09/14 18:40:14 stanton Exp $ +# RCS: @(#) $Id: split.test,v 1.3 1999/04/16 00:47:34 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test split-1.1 {basic split commands} { split "a\n b\t\r c\n " @@ -63,3 +66,19 @@ test split-2.1 {split errors} { test split-2.2 {split errors} { list [catch {split a b c} msg] $msg $errorCode } {1 {wrong # args: should be "split string ?splitChars?"} NONE} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/stack.test b/tests/stack.test index 2499220..1e62788 100644 --- a/tests/stack.test +++ b/tests/stack.test @@ -4,14 +4,16 @@ # 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) 1998 by Scriptics Corporation. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: stack.test,v 1.1 1998/09/30 20:52:01 escoffon Exp $ +# RCS: @(#) $Id: stack.test,v 1.2 1999/04/16 00:47:34 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # Note that a failure in this test results in a crash of the executable. @@ -21,3 +23,19 @@ test stack-1.1 {maxNestingDepth reached on infinite recursion} { rename recurse {} set rv } {too many nested calls to Tcl_EvalObj (infinite loop?)} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/string.test b/tests/string.test index b7b58ab..641b8c2 100644 --- a/tests/string.test +++ b/tests/string.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: string.test,v 1.2 1998/09/14 18:40:14 stanton Exp $ +# RCS: @(#) $Id: string.test,v 1.3 1999/04/16 00:47:34 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test string-1.1 {string compare} { string compare abcde abdef @@ -289,7 +292,7 @@ test string-10.4 {string trimright errors} { } {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}} +} {1 {bad option "trimg": must be compare, first, index, last, length, match, range, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}} test string-11.1 {string tolower} { string tolower ABCDeF @@ -350,7 +353,7 @@ test string-13.8 {string wordend} { 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}} +} {1 {ambiguous option "word": must be compare, first, index, last, length, match, range, tolower, toupper, totitle, 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"}} @@ -378,7 +381,23 @@ test string-14.9 {string wordend} { 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}} +} {1 {bad option "gorp": must be compare, first, index, last, length, match, range, tolower, toupper, totitle, 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 ...?"}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/stringObj.test b/tests/stringObj.test index bcfbe0c..33100e5 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -7,20 +7,24 @@ # errors. No output means no errors were found. # # Copyright (c) 1995-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: stringObj.test,v 1.2 1998/09/14 18:40:14 stanton Exp $ +# RCS: @(#) $Id: stringObj.test,v 1.3 1999/04/16 00:47:35 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} 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." + ::tcltest::cleanupTests 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] @@ -187,3 +191,19 @@ test stringObj-8.1 {DupStringInternalRep procedure} { } {5 10 5 5 abcde} testobj freeallvars + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/subst.test b/tests/subst.test index 3378756..51546d2 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -6,13 +6,16 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: subst.test,v 1.2 1998/09/14 18:40:14 stanton Exp $ +# RCS: @(#) $Id: subst.test,v 1.3 1999/04/16 00:47:35 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test subst-1.1 {basics} { list [catch {subst} msg] $msg @@ -84,7 +87,7 @@ test subst-7.1 {switches} { } {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}} test subst-7.2 {switches} { list [catch {subst -no bar} msg] $msg -} {1 {bad switch "-no": must be -nobackslashes, -nocommands, or -novariables}} +} {1 {ambiguous switch "-no": must be -nobackslashes, -nocommands, or -novariables}} test subst-7.3 {switches} { list [catch {subst -bogus bar} msg] $msg } {1 {bad switch "-bogus": must be -nobackslashes, -nocommands, or -novariables}} @@ -104,3 +107,19 @@ test subst-7.7 {switches} { set x 123 subst -nov -nob -noc {abc $x [expr 1+2] \\\x41} } {abc $x [expr 1+2] \\\x41} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/switch.test b/tests/switch.test index 4d1f4a8..cdbfc61 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -6,13 +6,16 @@ # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: switch.test,v 1.2 1998/09/14 18:40:14 stanton Exp $ +# RCS: @(#) $Id: switch.test,v 1.3 1999/04/16 00:47:35 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test switch-1.1 {simple patterns} { switch a a {format 1} b {format 2} c {format 3} default {format 4} @@ -56,7 +59,7 @@ test switch-3.1 {-exact vs. -glob vs. -regexp} { } } exact test switch-3.2 {-exact vs. -glob vs. -regexp} { - switch -exact -regexp aaaab { + switch -regexp aaaab { ^a*b$ {concat regexp} *b {concat glob} aaaab {concat exact} @@ -121,7 +124,7 @@ test switch-5.1 {errors in -regexp matching} { aaaab {concat exact} default {concat none} }} msg] $msg -} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} +} {1 {couldn't compile regular expression pattern: quantifier operand invalid}} test switch-6.1 {backslashes in patterns} { switch -exact {\a\$\.\[} { @@ -177,3 +180,19 @@ test switch-8.1 {empty body} { default {set msg 2} } } {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/thread.test b/tests/thread.test new file mode 100644 index 0000000..b3051ed --- /dev/null +++ b/tests/thread.test @@ -0,0 +1,240 @@ +# Commands covered: (test)thread +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: thread.test,v 1.2 1999/04/16 00:47:35 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {[info command testthread] == ""} { + puts "skipping: tests require the testthread command" + ::tcltest::cleanupTests + return +} + +set mainthread [testthread names] +proc ThreadReap {} { + global mainthread + testthread errorproc ThreadNullError + while {[llength [testthread names]] > 1} { + foreach tid [testthread names] { + if {$tid != $mainthread} { + catch {testthread send -async $tid {testthread exit}} + update + } + } + } + testthread errorproc ThreadError + return [llength [testthread names]] +} +testthread errorproc ThreadError +proc ThreadError {id info} { + global threadError + set threadError $info +} +proc ThreadNullError {id info} { + # ignore +} + +test thread-1.1 {Tcl_ThreadObjCmd: no args} { + list [catch {testthread} msg] $msg +} {1 {wrong # args: should be "testthread option ?args?"}} + +test thread-1.2 {Tcl_ThreadObjCmd: bad option} { + list [catch {testthread foo} msg] $msg +} {1 {bad option "foo": must be create, exit, id, names, send, wait, or errorproc}} + +test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} { + list [catch {testthread names} mainthread] [llength $mainthread] +} {0 1} + +test thread-1.4 {Tcl_ThreadObjCmd: thread create } { + set serverthread [testthread create] + update + set numthreads [llength [testthread names]] +} {2} +ThreadReap + +test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} { + testthread create {set x 5} + foreach try {0 1 2 4 5 6} { + # Try various ways to yeild + update + after 10 + set l [llength [testthread names]] + if {$l == 1} { + break + } + } + set l +} {1} +ThreadReap + +test thread-1.6 {Tcl_ThreadObjCmd: thread exit} { + testthread create {testthread exit} + update + after 10 + llength [testthread names] +} {1} +ThreadReap + +test thread-1.7 {Tcl_ThreadObjCmd: thread id args} { + set x [catch {testthread id x} msg] + list $x $msg +} {1 {wrong # args: should be "testthread id"}} + +test thread-1.8 {Tcl_ThreadObjCmd: thread id} { + string compare [testthread id] $mainthread +} {0} + +test thread-1.9 {Tcl_ThreadObjCmd: thread names args} { + set x [catch {testthread names x} msg] + list $x $msg +} {1 {wrong # args: should be "testthread names"}} + +test thread-1.10 {Tcl_ThreadObjCmd: thread id} { + string compare [testthread names] $mainthread +} {0} + +test thread-1.11 {Tcl_ThreadObjCmd: send args} { + set x [catch {testthread send} msg] + list $x $msg +} {1 {wrong # args: should be "testthread send ?-async? id script"}} + +test thread-1.12 {Tcl_ThreadObjCmd: send nonint} { + set x [catch {testthread send abc command} msg] + list $x $msg +} {1 {expected integer but got "abc"}} + +test thread-1.13 {Tcl_ThreadObjCmd: send args} { + set serverthread [testthread create] + set five [testthread send $serverthread {set x 5}] + ThreadReap + set five +} 5 + +test thread-1.14 {Tcl_ThreadObjCmd: send bad id} { + set tid [expr $mainthread + 10] + set x [catch {testthread send $tid {set x 5}} msg] + list $x $msg +} {1 {invalid thread id}} + +test thread-1.15 {Tcl_ThreadObjCmd: wait} { + set serverthread [testthread create {set z 5 ; testthread wait}] + set five [testthread send $serverthread {set z}] + ThreadReap + set five +} 5 + +test thread-1.16 {Tcl_ThreadObjCmd: errorproc args} { + set x [catch {testthread errorproc foo bar} msg] + list $x $msg +} {1 {wrong # args: should be "testthread errorproc proc"}} + +test thread-1.17 {Tcl_ThreadObjCmd: errorproc change} { + testthread errorproc foo + testthread errorproc ThreadError +} {} + +# The tests above also cover: +# TclCreateThread, except when pthread_create fails +# NewThread, safe and regular +# ThreadErrorProc, except for printing to standard error + +test thread-2.1 {ListUpdateInner and ListRemove} { + catch {unset tid} + foreach t {0 1 2} { + upvar #0 t$t tid + set tid [testthread create] + } + ThreadReap +} 1 + +test thread-3.1 {TclThreadList} { + catch {unset tid} + set mainthread [testthread names] + set l1 {} + foreach t {0 1 2} { + lappend l1 [testthread create] + } + set l2 [testthread names] + list $l1 $l2 + set c [string compare [lsort -integer [concat $mainthread $l1]] [lsort -integer $l2]] + ThreadReap + set c +} 0 + +test thread-4.1 {TclThreadSend to self} { + catch {unset x} + testthread send [testthread id] { + set x 4 + } + set x +} {4} + +test thread-4.1 {TclThreadSend -async} { + set mainthread [testthread names] + set serverthread [testthread create] + testthread send -async $serverthread { + after 1000 + testthread exit + } + set two [llength [testthread names]] + after 1500 {set done 1} + vwait done + list [llength [testthread names]] $two +} {1 2} + +test thread-4.2 {TclThreadSend preserve errorInfo} { + set mainthread [testthread names] + set serverthread [testthread create] + set x [catch {testthread send $serverthread {set undef}} msg] + list $x $msg $errorInfo +} {1 {can't read "undef": no such variable} {can't read "undef": no such variable + while executing +"set undef" + invoked from within +"testthread send $serverthread {set undef}"}} +ThreadReap + +test thread-4.3 {TclThreadSend preserve code} { + set mainthread [testthread names] + set serverthread [testthread create] + set x [catch {testthread send $serverthread {break}} msg] + list $x $msg $errorInfo +} {3 {} {}} +ThreadReap + +test thread-4.4 {TclThreadSend preserve errorCode} { + set mainthread [testthread names] + set serverthread [testthread create] + set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg] + list $x $msg $errorCode +} {1 ERR CODE} +ThreadReap + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/timer.test b/tests/timer.test index 7064d6d..0e6f4e6 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -8,13 +8,16 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: timer.test,v 1.2 1998/09/14 18:40:14 stanton Exp $ +# RCS: @(#) $Id: timer.test,v 1.3 1999/04/16 00:47:35 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test timer-1.1 {Tcl_CreateTimerHandler procedure} { foreach i [after info] { @@ -333,12 +336,93 @@ test timer-6.21 {Tcl_AfterCmd, info option} { test timer-6.22 {Tcl_AfterCmd, info option} { list [after info $event1] [after info $event2] } {{{event 1} idle} {{event 2} timer}} + after cancel $event1 after cancel $event2 interp delete x +test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NULL} { + foreach i [after info] { + after cancel $i + } + set x "hello world" + after 1 "set x ab\0cd" + after 10 + update + string length $x +} {5} +test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NULL} { + foreach i [after info] { + after cancel $i + } + set x "hello world" + after 1 set x ab\0cd + after 10 + update + string length $x +} {5} +test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NULL} { + foreach i [after info] { + after cancel $i + } + set x "hello world" + after 1 set x ab\0cd + after cancel "set x ab\0ef" + set x [llength [after info]] + foreach i [after info] { + after cancel $i + } + set x +} {1} +test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NULL} { + foreach i [after info] { + after cancel $i + } + set x "hello world" + after 1 set x ab\0cd + after cancel set x ab\0ef + set y [llength [after info]] + foreach i [after info] { + after cancel $i + } + set y +} {1} +test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NULL} { + foreach i [after info] { + after cancel $i + } + set x "hello world" + after idle "set x ab\0cd" + update + string length $x +} {5} +test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NULL} { + foreach i [after info] { + after cancel $i + } + set x "hello world" + after idle set x ab\0cd + update + string length $x +} {5} +test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NULL} { + foreach i [after info] { + after cancel $i + } + set x "hello world" + set id junk + set id [after 1 set x ab\0cd] + update + set y [string length [lindex [lindex [after info $id] 0] 2]] + foreach i [after info] { + after cancel $i + } + set y +} {5} + set event [after idle foo bar] scan $event after#%d id + test timer-7.1 {GetAfterEvent procedure} { list [catch {after info xfter#$id} msg] $msg } "1 {event \"xfter#$id\" doesn't exist}" @@ -453,3 +537,18 @@ test timer-9.1 {AfterCleanupProc procedure} { set x } {before after2 after4} +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/trace.test b/tests/trace.test index c0faa35..a2dd45e 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: trace.test,v 1.2 1998/09/14 18:40:14 stanton Exp $ +# RCS: @(#) $Id: trace.test,v 1.3 1999/04/16 00:47:35 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} proc traceScalar {name1 name2 op} { global info @@ -610,10 +613,10 @@ test trace-12.1 {delete one trace from another} { test trace-13.1 {trace command (overall)} { list [catch {trace} msg] $msg -} {1 {too few args: should be "trace option [arg arg ...]"}} +} {1 {wrong # args: should be "trace option [arg arg ...]"}} test trace-13.2 {trace command (overall)} { list [catch {trace gorp} msg] $msg -} {1 {bad option "gorp": should be variable, vdelete, or vinfo}} +} {1 {bad option "gorp": must be variable, vdelete, or vinfo}} test trace-13.3 {trace command ("variable" option)} { list [catch {trace variable x y} msg] $msg } {1 {wrong # args: should be "trace variable name ops command"}} @@ -963,4 +966,19 @@ test trace-17.1 {unset traces on procedure returns} { catch {unset x} catch {unset y} -concat {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 76febd0..d026aa3 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -9,18 +9,22 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unixFCmd.test,v 1.5 1998/09/14 18:40:14 stanton Exp $ +# RCS: @(#) $Id: unixFCmd.test,v 1.6 1999/04/16 00:47:35 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} - -if {$tcl_platform(platform) != "unix"} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } -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 +# Several tests require need to match results against the unix username +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" + } } proc openup {path} { @@ -49,7 +53,7 @@ proc cleanup {args} { } } -test unixFCmd-1.1 {TclpRenameFile: EACCES} { +test unixFCmd-1.1 {TclpRenameFile: EACCES} {unixOnly notRoot} { cleanup file mkdir td1/td2/td3 exec chmod 000 td1/td2 @@ -57,46 +61,45 @@ test unixFCmd-1.1 {TclpRenameFile: EACCES} { exec chmod 755 td1/td2 set msg } {1 {error renaming "td1/td2/td3": permission denied}} -test unixFCmd-1.2 {TclpRenameFile: EEXIST} { +test unixFCmd-1.2 {TclpRenameFile: EEXIST} {unixOnly notRoot} { 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} { +test unixFCmd-1.3 {TclpRenameFile: EINVAL} {unixOnly notRoot} { 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} { +test unixFCmd-1.4 {TclpRenameFile: EISDIR} {emptyTest unixOnly notRoot} { # can't make it happen } {} -test unixFCmd-1.5 {TclpRenameFile: ENOENT} { +test unixFCmd-1.5 {TclpRenameFile: ENOENT} {unixOnly notRoot} { 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} { +test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} {emptyTest unixOnly notRoot} { # can't make it happen } {} -test unixFCmd-1.7 {TclpRenameFile: EXDEV} { +test unixFCmd-1.7 {TclpRenameFile: EXDEV} {unixOnly notRoot} { 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}] + set catchResult [catch {file rename foo/bar /tmp} msg] + set msg [lindex [split $msg :] end] catch {file delete /tmp/bar} catch {file attr foo -perm 040777} catch {file delete -force foo} - set result -} {1} -test unixFCmd-1.8 {Checking EINTR Bug} nonPortable { + list $catchResult $msg +} {1 { permission denied}} +test unixFCmd-1.8 {Checking EINTR Bug} {unixOnly notRoot nonPortable} { testalarm after 2000 list [testgotsig] [testgotsig] } {1 0} -test unixFCmd-1.9 {Checking EINTR Bug} nonPortable { +test unixFCmd-1.9 {Checking EINTR Bug} {unixOnly notRoot nonPortable} { cleanup set f [open tfalarm w] puts $f { @@ -111,19 +114,20 @@ test unixFCmd-1.9 {Checking EINTR Bug} nonPortable { catch {close $pipe} list $line [testgotsig] } {h 1} -test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} { +test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} \ + {unixOnly notRoot} { cleanup exec touch tf1 exec touch tf2 file copy -force tf1 tf2 } {} -test unixFCmd-2.2 {TclpCopyFile: src is symlink} { +test unixFCmd-2.2 {TclpCopyFile: src is symlink} {unixOnly notRoot} { cleanup exec ln -s tf1 tf2 file copy tf2 tf3 file type tf3 } {link} -test unixFCmd-2.3 {TclpCopyFile: src is block} { +test unixFCmd-2.3 {TclpCopyFile: src is block} {unixOnly notRoot} { cleanup set null "/dev/null" while {[file type $null] != "characterSpecial"} { @@ -131,7 +135,7 @@ test unixFCmd-2.3 {TclpCopyFile: src is block} { } # file copy $null tf1 } {} -test unixFCmd-2.4 {TclpCopyFile: src is fifo} { +test unixFCmd-2.4 {TclpCopyFile: src is fifo} {unixOnly notRoot} { cleanup if [catch {exec mknod tf1 p}] { list 1 @@ -140,7 +144,7 @@ test unixFCmd-2.4 {TclpCopyFile: src is fifo} { expr {"[file type tf1]" == "[file type tf2]"} } } {1} -test unixFCmd-2.5 {TclpCopyFile: copy attributes} { +test unixFCmd-2.5 {TclpCopyFile: copy attributes} {unixOnly notRoot} { cleanup exec touch tf1 exec chmod 472 tf1 @@ -148,111 +152,122 @@ test unixFCmd-2.5 {TclpCopyFile: copy attributes} { string range [exec ls -l tf2] 0 9 } {-r--rwx-w-} -test unixFCmd-3.1 {CopyFile not done} { +test unixFCmd-3.1 {CopyFile not done} {emptyTest unixOnly notRoot} { } {} -test unixFCmd-4.1 {TclpDeleteFile not done} { +test unixFCmd-4.1 {TclpDeleteFile not done} {emptyTest unixOnly notRoot} { } {} -test unixFCmd-5.1 {TclpCreateDirectory not done} { +test unixFCmd-5.1 {TclpCreateDirectory not done} {emptyTest unixOnly notRoot} { } {} -test unixFCmd-6.1 {TclpCopyDirectory not done} { +test unixFCmd-6.1 {TclpCopyDirectory not done} {emptyTest unixOnly notRoot} { } {} -test unixFCmd-7.1 {TclpRemoveDirectory not done} { +test unixFCmd-7.1 {TclpRemoveDirectory not done} {emptyTest unixOnly notRoot} { } {} -test unixFCmd-8.1 {TraverseUnixTree not done} { +test unixFCmd-8.1 {TraverseUnixTree not done} {emptyTest unixOnly notRoot} { } {} -test unixFCmd-9.1 {TraversalCopy not done} { +test unixFCmd-9.1 {TraversalCopy not done} {emptyTest unixOnly notRoot} { } {} -test unixFCmd-10.1 {TraversalDelete not done} { +test unixFCmd-10.1 {TraversalDelete not done} {emptyTest unixOnly notRoot} { } {} -test unixFCmd-11.1 {CopyFileAttrs not done} { +test unixFCmd-11.1 {CopyFileAttrs not done} {emptyTest unixOnly notRoot} { } {} -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} { +test unixFCmd-12.1 {GetGroupAttribute - file not found} {unixOnly notRoot} { 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} { +} {1 {could not read "foo.test": no such file or directory}} +test unixFCmd-12.2 {GetGroupAttribute - file found} {unixOnly notRoot} { 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} { +test unixFCmd-13.1 {GetOwnerAttribute - file not found} {unixOnly notRoot} { 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} { +} {1 {could not read "foo.test": no such file or directory}} +test unixFCmd-13.2 {GetOwnerAttribute} {unixOnly notRoot} { 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] + 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} { +test unixFCmd-14.1 {GetPermissionsAttribute - file not found} {unixOnly notRoot} { 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} { +} {1 {could not read "foo.test": no such file or directory}} +test unixFCmd-14.2 {GetPermissionsAttribute} {unixOnly notRoot} { catch {file delete -force -- foo.test} close [open foo.test w] - list [catch {file attribute foo.test -permissions}] [file delete -force -- foo.test] + list [catch {file attribute foo.test -permissions}] \ + [file delete -force -- foo.test] } {0 {}} +# Find a group that exists on this system, or else skip tests that require +# groups +set ::tcltest::testConfig(foundGroup) 0 +catch { + set groupList [exec groups] + set group [lindex $groupList 0] + set ::tcltest::testConfig(foundGroup) 1 +} + #groups hard to test -test unixFCmd-15.1 {SetGroupAttribute - invalid group} { +test unixFCmd-15.1 {SetGroupAttribute - invalid group} {unixOnly notRoot} { catch {file delete -force -- foo.test} - list [catch {file attributes foo.test -group foozzz} msg] $msg [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} { +test unixFCmd-15.2 {SetGroupAttribute - invalid file} \ + {unixOnly notRoot foundGroup} { catch {file delete -force -- foo.test} - list [catch {file attributes foo.test -group tcl} msg] $msg + list [catch {file attributes foo.test -group $group} 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} { +test unixFCmd-16.1 {SetOwnerAttribute - current owner} {unixOnly notRoot} { 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] + 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} { +test unixFCmd-16.2 {SetOwnerAttribute - invalid file} {unixOnly notRoot} { 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} { +test unixFCmd-16.3 {SetOwnerAttribute - invalid owner} {unixOnly notRoot} { 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} { +test unixFCmd-17.1 {SetPermissionsAttribute} {unixOnly notRoot} { 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] + 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} { +test unixFCmd-17.2 {SetPermissionsAttribute} {unixOnly notRoot} { 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} { +test unixFCmd-17.3 {SetPermissionsAttribute} {unixOnly notRoot} { 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] + 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} { +test unixFCmd-18.1 {Unix pwd} {nonPortable unixOnly notRoot} { # This test is nonportable because SunOS generates a weird error # message when the current directory isn't readable. set cd [pwd] @@ -267,4 +282,19 @@ test unixFCmd-18.1 {Unix pwd} {nonPortable} { set r } {1 {error getting working directory name:}} +# cleanup cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/unixFile.test b/tests/unixFile.test index c7f5b7c..c18ac20 100644 --- a/tests/unixFile.test +++ b/tests/unixFile.test @@ -4,63 +4,74 @@ # 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) 1998 by Scriptics Corporation. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unixFile.test,v 1.2 1998/09/14 18:40:14 stanton Exp $ +# RCS: @(#) $Id: unixFile.test,v 1.3 1999/04/16 00:47:35 stanton Exp $ - -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} if {[info commands testobj] == {}} { puts "This application hasn't been compiled with the \"testfindexecutable\"" puts "command, so I can't test the Tcl_FindExecutable function" + ::tcltest::cleanupTests return } -if {$tcl_platform(platform) != "unix"} { - return +catch { + set oldPath $env(PATH) + close [open junk w] + file attributes junk -perm 0777 } - - -set oldPath $env(PATH) -close [open junk w] -file attributes junk -perm 0777 - set absPath [file join [pwd] junk] -test unixFile-1.1 {Tcl_FindExecutable} { + +test unixFile-1.1 {Tcl_FindExecutable} {unixOnly} { set env(PATH) "" testfindexecutable junk } $absPath -test unixFile-1.2 {Tcl_FindExecutable} { +test unixFile-1.2 {Tcl_FindExecutable} {unixOnly} { set env(PATH) "/dummy" testfindexecutable junk } {} -test unixFile-1.3 {Tcl_FindExecutable} { +test unixFile-1.3 {Tcl_FindExecutable} {unixOnly} { set env(PATH) "/dummy:[pwd]" testfindexecutable junk } $absPath -test unixFile-1.4 {Tcl_FindExecutable} { +test unixFile-1.4 {Tcl_FindExecutable} {unixOnly} { set env(PATH) "/dummy:" testfindexecutable junk } $absPath -test unixFile-1.5 {Tcl_FindExecutable} { +test unixFile-1.5 {Tcl_FindExecutable} {unixOnly} { set env(PATH) "/dummy:/dummy" testfindexecutable junk } {} -test unixFile-1.6 {Tcl_FindExecutable} { +test unixFile-1.6 {Tcl_FindExecutable} {unixOnly} { set env(PATH) "/dummy::/dummy" testfindexecutable junk } $absPath -test unixFile-1.7 {Tcl_FindExecutable} { +test unixFile-1.7 {Tcl_FindExecutable} {unixOnly} { set env(PATH) ":/dummy" testfindexecutable junk } $absPath +# cleanup +catch {set env(PATH) $oldPath} +file delete junk +::tcltest::cleanupTests +return + + + + + + + + + -set env(PATH) $oldPath -file delete junk diff --git a/tests/unixInit.test b/tests/unixInit.test new file mode 100644 index 0000000..313f3c1 --- /dev/null +++ b/tests/unixInit.test @@ -0,0 +1,205 @@ +# The file tests the functions in the tclUnixInit.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 by Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: unixInit.test,v 1.2 1999/04/16 00:47:35 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +catch {set oldlibrary $env(TCL_LIBRARY); unset env(TCL_LIBRARY)} +catch {set oldlang $env(LANG)} +set env(LANG) C + +# Some tests will fail if they are run on a machine that doesn't have +# this Tcl version installed (as opposed to built) on it. +if {[catch { + set f [open "|[list $tcltest]" w+] + exec kill -PIPE [pid $f] + close $f +}]} { + set ::tcltest::testConfig(installedTcl) 0 +} else { + set ::tcltest::testConfig(installedTcl) 1 +} + +test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly installedTcl} { + set x {} + + # Watch out for a race condition here. If tcltest is too slow to start + # then we'll kill it before it has a chance to set up its signal handler. + + set f [open "|[list $tcltest]" w+] + puts $f "puts hi" + flush $f + gets $f + exec kill -PIPE [pid $f] + lappend x [catch {close $f}] + + set f [open "|[list $tcltest]" w+] + puts $f "puts hi" + flush $f + gets $f + exec kill [pid $f] + lappend x [catch {close $f}] + + set x +} {0 1} + +proc getlibpath "{program [list $tcltest]}" { + set f [open "|$program" w+] + fconfigure $f -buffering none + puts $f {puts $tcl_libPath; exit} + set path [gets $f] + close $f + return $path +} + +# Some tests require the testgetdefenc command + +set ::tcltest::testConfig(testgetdefenc) \ + [expr {[info commands testgetdefenc] != {}}] + +test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} \ + {unixOnly testgetdefenc} { + set origDir [testgetdefenc] + testsetdefenc slappy + set path [testgetdefenc] + testsetdefenc $origDir + set path +} {slappy} +test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} \ + {unixOnly installedTcl} { + set path [getlibpath] + + set installLib lib/tcl[info tclversion] + if {[string match {*[ab]*} [info patchlevel]]} { + set developLib tcl[info patchlevel]/library + } else { + set developLib tcl[info tclversion]/library + } + set prefix [file dirname [file dirname $tcltest]] + + set x {} + lappend x [string compare [lindex $path 0] $prefix/$installLib] + lappend x [string compare [lindex $path 1] [file dirname $prefix]/$developLib] + set x +} {0 0} +test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} {unixOnly installedTcl} { + # ((str != NULL) && (str[0] != '\0')) + + set env(TCL_LIBRARY) sparkly + set path [getlibpath] + unset env(TCL_LIBRARY) + + lindex $path 0 +} "sparkly" +test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} \ + {unixOnly installedTcl} { + # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0)) + + set env(TCL_LIBRARY) /a/b/tcl1.7 + set path [getlibpath] + unset env(TCL_LIBRARY) + + lrange $path 0 1 +} [list /a/b/tcl1.7 /a/b/tcl[info tclversion]] +test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} \ + {unixOnly installedTcl} { + # Child process translates env variable from native encoding. + + set env(TCL_LIBRARY) "\xa7" + set x [lindex [getlibpath] 0] + unset env(TCL_LIBRARY) + unset env(LANG) + + set x +} "\xa7" +test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} \ + {emptyTest unixOnly} { + # cannot test +} {} +test unixInit-2.6 {TclpInitLibraryPath: executable relative} \ + {unixOnly installedTcl} { + file delete -force /tmp/sparkly + file mkdir /tmp/sparkly/bin + file copy $tcltest /tmp/sparkly/bin/tcltest + + file mkdir /tmp/sparkly/lib/tcl[info tclversion] + close [open /tmp/sparkly/lib/tcl[info tclversion]/init.tcl w] + + set x [lrange [getlibpath /tmp/sparkly/bin/tcltest] 0 1] + file delete -force /tmp/sparkly + set x +} [list /tmp/sparkly/lib/tcl[info tclversion] /tmp/tcl[info patchlevel]/library] +test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \ + {emptyTest unixOnly} { + # would need test command to get defaultLibDir and compare it to + # [lindex $auto_path end] +} {} +test unixInit-3.1 {TclpSetInitialEncodings} {unixOnly installedTcl} { + set env(LANG) C + + set f [open "|[list $tcltest]" w+] + fconfigure $f -buffering none + puts $f {puts [encoding system]; exit} + set enc [gets $f] + close $f + unset env(LANG) + + set enc +} {iso8859-1} +test unixInit-3.2 {TclpSetInitialEncodings} {unixOnly installedTcl} { + set env(LANG) japanese + + set f [open "|[list $tcltest]" w+] + fconfigure $f -buffering none + puts $f {puts [encoding system]; exit} + set enc [gets $f] + close $f + unset env(LANG) + + set enc +} {euc-jp} + +test unixInit-4.1 {TclpSetVariables} {unixOnly} { + # just make sure they exist + + set a [list $tcl_library $tcl_pkgPath $tcl_platform(os)] + set a [list $tcl_platform(osVersion) $tcl_platform(machine)] + set tcl_platform(platform) +} "unix" + +test unixInit-5.1 {Tcl_Init} {emptyTest unixOnly} { + # test initScript +} {} + +test unixInit-6.1 {Tcl_SourceRCFile} {emptyTest unixOnly} { +} {} + +# cleanup +catch {unset env(TCL_LIBRARY); set env(TCL_LIBRARY) $oldlibrary} +catch {unset env(LANG); set env(LANG) $oldlang} +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 7c19129..2775597 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -5,27 +5,29 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unixNotfy.test,v 1.3 1998/09/14 18:40:14 stanton Exp $ - -if {[string compare test [info procs test]] == 1} then {source defs} - -if {$tcl_platform(platform) != "unix"} { - return -} +# RCS: @(#) $Id: unixNotfy.test,v 1.4 1999/04/16 00:47:36 stanton Exp $ # The tests should not be run if you have a notifier which is unable to # detect infinite vwaits, as the tests below will hang. The presence of -# the "testeventloop" command indicates that this is the case. +# the "testthread" command indicates that this is the case. -if {"[info commands testeventloop]" == "testeventloop"} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } -test unixNotfy-1.1 {Tcl_DeleteFileHandler} { +set ::tcltest::testConfig(testthread) \ + [expr {[info commands testthread] != {}}] + +# The next two tests will hang if threads are enabled because the notifier +# will not necessarily wait for ever in this case, so it does not generate +# an error. + +test unixNotfy-1.1 {Tcl_DeleteFileHandler} {unixOnly && !testthread} { catch {vwait x} set f [open foo w] fileevent $f writable {set x 1} @@ -33,7 +35,7 @@ test unixNotfy-1.1 {Tcl_DeleteFileHandler} { close $f list [catch {vwait x} msg] $msg } {1 {can't wait for variable "x": would wait forever}} -test unixNotfy-1.2 {Tcl_DeleteFileHandler} { +test unixNotfy-1.2 {Tcl_DeleteFileHandler} {unixOnly && !testthread} { catch {vwait x} set f1 [open foo w] set f2 [open foo2 w] @@ -46,5 +48,52 @@ test unixNotfy-1.2 {Tcl_DeleteFileHandler} { list [catch {vwait x} msg] $msg } {1 {can't wait for variable "x": would wait forever}} + +test unixNotfy-2.1 {Tcl_DeleteFileHandler} {unixOnly testthread} { + update + set f [open foo w] + fileevent $f writable {set x 1} + vwait x + close $f + testthread create "after 500 + testthread send [testthread id] {set x ok} + testthread exit" + vwait x + set x +} {ok} +test unixNotfy-1.2 {Tcl_DeleteFileHandler} {unixOnly testthread} { + update + 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 + testthread create "after 500 + testthread send [testthread id] {set x ok} + testthread exit" + vwait x + set x +} {ok} + + + +# cleanup file delete foo file delete foo2 +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/unknown.test b/tests/unknown.test index d0f05c0..791a9d1 100644 --- a/tests/unknown.test +++ b/tests/unknown.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unknown.test,v 1.2 1998/09/14 18:40:14 stanton Exp $ +# RCS: @(#) $Id: unknown.test,v 1.3 1999/04/16 00:47:36 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {unset x} catch {rename unknown unknown.old} @@ -56,6 +59,20 @@ test unknown-4.1 {errors in "unknown" procedure} { list [catch {non-existent a b} msg] $msg $errorCode } {1 {unknown failed} NONE} +# cleanup catch {rename unknown {}} catch {rename unknown.old unknown} -return {} +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/uplevel.test b/tests/uplevel.test index ca091bb..857c8e1 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: uplevel.test,v 1.2 1998/09/14 18:40:14 stanton Exp $ +# RCS: @(#) $Id: uplevel.test,v 1.3 1999/04/16 00:47:36 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} proc a {x y} { newset z [expr $x+$y] @@ -107,3 +110,19 @@ proc a3 {} { a2 test uplevel-5.1 {info level} {set x} 1 test uplevel-5.2 {info level} {set y} a3 + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/upvar.test b/tests/upvar.test index 087b4b2..2fe81c9 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -6,13 +6,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: upvar.test,v 1.3 1998/09/14 18:40:14 stanton Exp $ +# RCS: @(#) $Id: upvar.test,v 1.4 1999/04/16 00:47:36 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test upvar-1.1 {reading variables with upvar} { proc p1 {a b} {set c 22; set d 33; p2} @@ -396,4 +399,18 @@ if {[info commands testupvar] != {}} { } catch {unset a} -concat +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/utf.test b/tests/utf.test new file mode 100644 index 0000000..eb9952f --- /dev/null +++ b/tests/utf.test @@ -0,0 +1,276 @@ +# This file contains a collection of tests for tclUtf.c +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: utf.test,v 1.2 1999/04/16 00:47:36 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +catch {unset x} + +test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} { + set x \x01 +} [bytestring "\x01"] +test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} { + set x "\x00" +} [bytestring "\xc0\x80"] +test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} { + set x "\xe0" +} [bytestring "\xc3\xa0"] +test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} { + set x "\u4e4e" +} [bytestring "\xe4\xb9\x8e"] + +test utf-2.1 {Tcl_UtfToUniChar: low ascii} { + string length "abc" +} {3} +test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} { + string length [bytestring "\x82\x83\x84"] +} {3} +test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} { + string length [bytestring "\xC2"] +} {1} +test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} { + string length [bytestring "\xC2\xa2"] +} {1} +test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} { + string length [bytestring "\xE2"] +} {1} +test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} { + string length [bytestring "\xE2\xA2"] +} {2} +test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} { + string length [bytestring "\xE4\xb9\x8e"] +} {1} +test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} { + string length [bytestring "\xF4\xA2\xA2\xA2"] +} {4} + +test utf-3.1 {Tcl_UtfCharComplete} { +} {} + +test utf-4.1 {Tcl_NumUtfChars: zero length} { + string length "" +} {0} +test utf-4.2 {Tcl_NumUtfChars: length 1} { + string length [bytestring "\xC2\xA2"] +} {1} +test utf-4.3 {Tcl_NumUtfChars: long string} { + string length [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] +} {7} + +test utf-5.1 {Tcl_UtfFindFirsts} { +} {} + +test utf-6.1 {Tcl_UtfNext} { +} {} + +test utf-7.1 {Tcl_UtfPrev} { +} {} + +test utf-8.1 {Tcl_UniCharAtIndex: index = 0} { + string index abcd 0 +} {a} +test utf-8.2 {Tcl_UniCharAtIndex: index = 0} { + string index \u4e4e\u25a 0 +} "\u4e4e" +test utf-8.3 {Tcl_UniCharAtIndex: index > 0} { + string index abcd 2 +} {c} +test utf-8.4 {Tcl_UniCharAtIndex: index > 0} { + string index \u4e4e\u25a\xff\u543 2 +} "\uff" + +test utf-9.1 {Tcl_UtfAtIndex: index = 0} { + string range abcd 0 2 +} {abc} +test utf-9.2 {Tcl_UtfAtIndex: index > 0} { + string range \u4e4e\u25a\xff\u543klmnop 1 5 +} "\u25a\xff\u543kl" + + +test utf-10.1 {Tcl_UtfBackslash: dst == NULL} { + set x \n +} { +} +test utf-10.2 {Tcl_UtfBackslash: \u subst} { + set x \ua2 +} [bytestring "\xc2\xa2"] +test utf-10.3 {Tcl_UtfBackslash: longer \u subst} { + set x \u4e21 +} [bytestring "\xe4\xb8\xa1"] +test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} { + set x \u4e2k +} "[bytestring \xd3\xa2]k" +test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} { + set x \u4e216 +} "[bytestring \xe4\xb8\xa1]6" +proc bsCheck {char num} { + global errNum + test utf-10.$errNum {backslash substitution} { + scan $char %c value + set value + } $num + incr errNum +} +set errNum 6 +bsCheck \b 8 +bsCheck \e 101 +bsCheck \f 12 +bsCheck \n 10 +bsCheck \r 13 +bsCheck \t 9 +bsCheck \v 11 +bsCheck \{ 123 +bsCheck \} 125 +bsCheck \[ 91 +bsCheck \] 93 +bsCheck \$ 36 +bsCheck \ 32 +bsCheck \; 59 +bsCheck \\ 92 +bsCheck \Ca 67 +bsCheck \Ma 77 +bsCheck \CMa 67 +bsCheck \8a 8 +bsCheck \14 12 +bsCheck \141 97 +bsCheck b\0 98 +bsCheck \x 120 +bsCheck \xa 10 +bsCheck \xA 10 +bsCheck \x41 65 +bsCheck \x541 65 +bsCheck \u 117 +bsCheck \uk 117 +bsCheck \u41 65 +bsCheck \ua 10 +bsCheck \uA 10 +bsCheck \340 224 +bsCheck \ua1 161 +bsCheck \u4e21 20001 + +test utf-11.1 {Tcl_UtfToUpper} { + string toupper {} +} {} +test utf-11.2 {Tcl_UtfToUpper} { + string toupper abc +} ABC +test utf-11.3 {Tcl_UtfToUpper} { + string toupper \u00e3ab +} \u00c3AB +test utf-11.4 {Tcl_UtfToUpper} { + string toupper \u01e3ab +} \u01e2AB + +test utf-12.1 {Tcl_UtfToLower} { + string tolower {} +} {} +test utf-12.2 {Tcl_UtfToLower} { + string tolower ABC +} abc +test utf-12.3 {Tcl_UtfToLower} { + string tolower \u00c3AB +} \u00e3ab +test utf-12.4 {Tcl_UtfToLower} { + string tolower \u01e2AB +} \u01e3ab + +test utf-13.1 {Tcl_UtfToTitle} { + string totitle {} +} {} +test utf-13.2 {Tcl_UtfToTitle} { + string totitle abc +} Abc +test utf-13.3 {Tcl_UtfToTitle} { + string totitle \u00e3ab +} \u00c3ab +test utf-13.4 {Tcl_UtfToTitle} { + string totitle \u01f3ab +} \u01f2ab + +test utf-14.1 {Tcl_UniCharToUpper, negative delta} { + string toupper aA +} AA +test utf-14.2 {Tcl_UniCharToUpper, positive delta} { + string toupper \u0178\u00ff +} \u0178\u0178 +test utf-14.3 {Tcl_UniCharToUpper, no delta} { + string toupper ! +} ! + +test utf-15.1 {Tcl_UniCharToLower, negative delta} { + string tolower aA +} aa +test utf-15.2 {Tcl_UniCharToLower, positive delta} { + string tolower \u0178\u00ff +} \u00ff\u00ff +test utf-16.1 {Tcl_UniCharToLower, no delta} { + string tolower ! +} ! + +test utf-17.1 {Tcl_UniCharToTitle, add one for title} { + string totitle \u01c4 +} \u01c5 +test utf-17.2 {Tcl_UniCharToTitle, subtract one for title} { + string totitle \u01c6 +} \u01c5 +test utf-17.3 {Tcl_UniCharToTitle, subtract delta for title (positive)} { + string totitle \u017f +} \u0053 +test utf-17.4 {Tcl_UniCharToTitle, subtract delta for title (negative)} { + string totitle \u00ff +} \u0178 +test utf-17.5 {Tcl_UniCharToTitle, no delta} { + string totitle ! +} ! + +test utf-18.1 {TclUniCharLen} { + list [regexp \\d abc456def foo] $foo +} {1 4} + +test utf-19.1 {TclUniCharNcmp} { +} {} + +test utf-20.1 {TclUniCharIsAlnum} { +} {} + +test utf-21.1 {TclUniCharIsWordChar} { + string wordend "xyz123_bar fg" 0 +} 10 +test utf-21.1 {TclUniCharIsWordChar} { + string wordend "x\u5080z123_bar\u203c fg" 0 +} 10 + +test utf-22.1 {TclUniCharIsAlpha} { +} {} + +test utf-23.1 {TclUniCharIsDigit} { +} {} + +test utf-23.1 {TclUniCharIsSpace} { +} {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/util.test b/tests/util.test index a8c5241..3c8b7b0 100644 --- a/tests/util.test +++ b/tests/util.test @@ -1,21 +1,25 @@ # This file is a Tcl script to test the code in the file tclUtil.c. # This file is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# Copyright (c) 1995-1998 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: util.test,v 1.3 1998/11/02 23:04:15 stanton Exp $ +# RCS: @(#) $Id: util.test,v 1.4 1999/04/16 00:47:36 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} 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." + ::tcltest::cleanupTests 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" @@ -58,26 +62,181 @@ test util-4.5 {Tcl_ConcatObj - backslash-space at end of argument} { concat a { } c } {a c} -test util-5.1 {Tcl_SetObjErrorCode - one arg} { - catch {testsetobjerrorcode 1} - list [set errorCode] -} {1} -test util-5.2 {Tcl_SetObjErrorCode - two args} { - catch {testsetobjerrorcode 1 2} - list [set errorCode] -} {{1 2}} -test util-5.3 {Tcl_SetObjErrorCode - three args} { - catch {testsetobjerrorcode 1 2 3} - list [set errorCode] -} {{1 2 3}} -test util-5.4 {Tcl_SetObjErrorCode - four args} { - catch {testsetobjerrorcode 1 2 3 4} - list [set errorCode] -} {{1 2 3 4}} -test util-5.5 {Tcl_SetObjErrorCode - five args} { - catch {testsetobjerrorcode 1 2 3 4 5} - list [set errorCode] -} {{1 2 3 4 5}} +test util-5.1 {Tcl_StringMatch} { + string match ab*c abc +} 1 +test util-5.2 {Tcl_StringMatch} { + string match ab**c abc +} 1 +test util-5.3 {Tcl_StringMatch} { + string match ab* abcdef +} 1 +test util-5.4 {Tcl_StringMatch} { + string match *c abc +} 1 +test util-5.5 {Tcl_StringMatch} { + string match *3*6*9 0123456789 +} 1 +test util-5.6 {Tcl_StringMatch} { + string match *3*6*9 01234567890 +} 0 +test util-5.7 {Tcl_StringMatch: UTF-8} { + string match *u \u4e4fu +} 1 +test util-5.8 {Tcl_StringMatch} { + string match a?c abc +} 1 +test util-5.9 {Tcl_StringMatch: UTF-8} { + # skip one character in string + + string match a?c a\u4e4fc +} 1 +test util-5.10 {Tcl_StringMatch} { + string match a??c abc +} 0 +test util-5.11 {Tcl_StringMatch} { + string match ?1??4???8? 0123456789 +} 1 +test util-5.12 {Tcl_StringMatch} { + string match {[abc]bc} abc +} 1 +test util-5.13 {Tcl_StringMatch: UTF-8} { + # string += Tcl_UtfToUniChar(string, &ch); + + string match "\[\u4e4fxy\]bc" "\u4e4fbc" +} 1 +test util-5.14 {Tcl_StringMatch} { + # if ((*pattern == ']') || (*pattern == '\0')) + # badly formed pattern + + string match {[]} {[]} +} 0 +test util-5.15 {Tcl_StringMatch} { + # if ((*pattern == ']') || (*pattern == '\0')) + # badly formed pattern + + string match {[} {[} +} 0 +test util-5.16 {Tcl_StringMatch} { + string match {a[abc]c} abc +} 1 +test util-5.17 {Tcl_StringMatch: UTF-8} { + # pattern += Tcl_UtfToUniChar(pattern, &endChar); + # get 1 UTF-8 character + + string match "a\[a\u4e4fc]c" "a\u4e4fc" +} 1 +test util-5.18 {Tcl_StringMatch: UTF-8} { + # pattern += Tcl_UtfToUniChar(pattern, &endChar); + # proper advance: wrong answer would match on UTF trail byte of \u4e4f + + string match {a[a\u4e4fc]c} [bytestring a\u008fc] +} 0 +test util-5.19 {Tcl_StringMatch: UTF-8} { + # pattern += Tcl_UtfToUniChar(pattern, &endChar); + # proper advance. + + string match {a[a\u4e4fc]c} "acc" +} 1 +test util-5.20 {Tcl_StringMatch} { + string match {a[xyz]c} abc +} 0 +test util-5.21 {Tcl_StringMatch} { + string match {12[2-7]45} 12345 +} 1 +test util-5.22 {Tcl_StringMatch: UTF-8 range} { + string match "\[\u4e00-\u4e4f]" "0" +} 0 +test util-5.23 {Tcl_StringMatch: UTF-8 range} { + string match "\[\u4e00-\u4e4f]" "\u4e33" +} 1 +test util-5.24 {Tcl_StringMatch: UTF-8 range} { + string match "\[\u4e00-\u4e4f]" "\uff08" +} 0 +test util-5.25 {Tcl_StringMatch} { + string match {12[ab2-4cd]45} 12345 +} 1 +test util-5.26 {Tcl_StringMatch} { + string match {12[ab2-4cd]45} 12b45 +} 1 +test util-5.27 {Tcl_StringMatch} { + string match {12[ab2-4cd]45} 12d45 +} 1 +test util-5.28 {Tcl_StringMatch} { + string match {12[ab2-4cd]45} 12145 +} 0 +test util-5.29 {Tcl_StringMatch} { + string match {12[ab2-4cd]45} 12545 +} 0 +test util-5.30 {Tcl_StringMatch: forwards range} { + string match {[k-w]} "z" +} 0 +test util-5.31 {Tcl_StringMatch: forwards range} { + string match {[k-w]} "w" +} 1 +test util-5.32 {Tcl_StringMatch: forwards range} { + string match {[k-w]} "r" +} 1 +test util-5.33 {Tcl_StringMatch: forwards range} { + string match {[k-w]} "k" +} 1 +test util-5.34 {Tcl_StringMatch: forwards range} { + string match {[k-w]} "a" +} 0 +test util-5.35 {Tcl_StringMatch: reverse range} { + string match {[w-k]} "z" +} 0 +test util-5.36 {Tcl_StringMatch: reverse range} { + string match {[w-k]} "w" +} 1 +test util-5.37 {Tcl_StringMatch: reverse range} { + string match {[w-k]} "r" +} 1 +test util-5.38 {Tcl_StringMatch: reverse range} { + string match {[w-k]} "k" +} 1 +test util-5.39 {Tcl_StringMatch: reverse range} { + string match {[w-k]} "a" +} 0 +test util-5.40 {Tcl_StringMatch: skip correct number of ']'} { + string match {[A-]x} Ax +} 0 +test util-5.41 {Tcl_StringMatch: skip correct number of ']'} { + string match {[A-]]x} Ax +} 1 +test util-5.42 {Tcl_StringMatch: skip correct number of ']'} { + string match {[A-]]x} \ue1x +} 0 +test util-5.43 {Tcl_StringMatch: skip correct number of ']'} { + string match \[A-]\ue1]x \ue1x +} 1 +test util-5.44 {Tcl_StringMatch: skip correct number of ']'} { + string match {[A-]h]x} hx +} 1 +test util-5.45 {Tcl_StringMatch} { + # if (*pattern == '\0') + # badly formed pattern, still treats as a set + + string match {[a} a +} 1 +test util-5.46 {Tcl_StringMatch} { + string match {a\*b} a*b +} 1 +test util-5.47 {Tcl_StringMatch} { + string match {a\*b} ab +} 0 +test util-5.48 {Tcl_StringMatch} { + string match {a\*\?\[\]\\\x} "a*?\[\]\\x" +} 1 +test util-5.49 {Tcl_StringMatch} { + string match ** "" +} 1 +test util-5.50 {Tcl_StringMatch} { + string match *. "" +} 0 +test util-5.51 {Tcl_StringMatch} { + string match "" "" +} 1 test util-6.1 {Tcl_PrintDouble - using tcl_precision} { concat x[expr 1.4] @@ -93,10 +252,10 @@ test util-6.4 {Tcl_PrintDouble - using tcl_precision} { concat x[expr 1.123412341234] } {x1.1234} set tcl_precision 12 -test util-6.4 {Tcl_PrintDouble - make sure there's a decimal point} { +test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr 2.0] } {x2.0} -test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} {eformat} { +test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} {eformat} { concat x[expr 3.0e98] } {x3e+98} @@ -123,10 +282,25 @@ test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} { interp delete child list $x $tcl_precision } {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12} -test util-7.3 {TclPrecTraceProc - write traces, bogus values} { +test util-7.4 {TclPrecTraceProc - write traces, bogus values} { set tcl_precision 12 list [catch {set tcl_precision abc} msg] $msg $tcl_precision } {1 {can't set "tcl_precision": improper value for precision} 12} set tcl_precision 12 -concat "" + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/var.test b/tests/var.test index 981c649..9145fc5 100644 --- a/tests/var.test +++ b/tests/var.test @@ -9,14 +9,17 @@ # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: var.test,v 1.4 1999/02/03 00:55:07 stanton Exp $ +# RCS: @(#) $Id: var.test,v 1.5 1999/04/16 00:47:36 stanton Exp $ # -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} catch {rename p ""} catch {namespace delete test_ns_var} @@ -27,7 +30,7 @@ catch {unset i} catch {unset a} catch {unset arr} -test var-1.1 {TclLookupVar, TCL_PARSE_PART1 flag set} { +test var-1.1 {TclLookupVar, Array handling} { catch {unset a} set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd set i 10 @@ -570,6 +573,10 @@ test var-9.12 {behaviour of TclSetVar write trace error} { [catch {testseterr v 3} msg] $msg $v } {1 {before set} 2 1 {can't set "v": read-only} 3} } +test var-10.1 {can't nest arrays with array set} { + catch {unset arr} + list [catch {array set arr(x) {a 1 b 2}} res] $res +} {1 {can't set "arr(x)(a)": variable isn't array}} catch {namespace delete ns} catch {unset arr} @@ -586,3 +593,18 @@ catch {unset a} catch {unset xxxxx} catch {unset aaaaa} +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/while-old.test b/tests/while-old.test index a97832e..f0d55ab 100644 --- a/tests/while-old.test +++ b/tests/while-old.test @@ -8,13 +8,16 @@ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: while-old.test,v 1.2 1998/09/14 18:40:15 stanton Exp $ +# RCS: @(#) $Id: while-old.test,v 1.3 1999/04/16 00:47:36 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} test while-old-1.1 {basic while loops} { set count 0 @@ -111,3 +114,19 @@ test while-old-5.2 {while return result} { set x 1 while {$x} {set x 0} } {} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/while.test b/tests/while.test index cd9381f..f4c7581 100644 --- a/tests/while.test +++ b/tests/while.test @@ -5,13 +5,16 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: while.test,v 1.2 1998/09/14 18:40:15 stanton Exp $ +# RCS: @(#) $Id: while.test,v 1.3 1999/04/16 00:47:36 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # Basic "while" operation. @@ -24,12 +27,12 @@ test while-1.1 {TclCompileWhileCmd: missing test expression} { } {wrong # args: should be "while test command"} test while-1.2 {TclCompileWhileCmd: error in test expression} { set i 0 - catch {while {$i<}} msg + catch {while {$i<} break} msg set errorInfo } {syntax error in expression "$i<" ("while" test expression) while compiling -"while {$i<}"} +"while {$i<} break"} test while-1.3 {TclCompileWhileCmd: error in test expression} { set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] list $err $msg @@ -286,7 +289,7 @@ test while-3.3 {break tests, long command body} { set a } {1 3} -# Check "while", "break", "continue" and computed command names. +# Check "while" with computed command names. test while-4.1 {while and computed command names} { set i 0 @@ -296,6 +299,149 @@ test while-4.1 {while and computed command names} { } set i } 10 +test while-4.2 {while (not compiled): missing test expression} { + set z while + catch {$z } msg + set msg +} {wrong # args: should be "while test command"} +test while-4.3 {while (not compiled): error in test expression} { + set i 0 + set z while + catch {$z {$i<} {set x 1}} msg + set errorInfo +} {syntax error in expression "$i<" + while executing +"$z {$i<} {set x 1}"} +test while-4.4 {while (not compiled): error in test expression} { + set z while + set err [catch {$z {"a"+"b"} {error "loop aborted"}} msg] + list $err $msg +} {1 {can't use non-numeric string as operand of "+"}} +test while-4.5 {while (not compiled): multiline test expr} { + set value 1 + set z while + $z {($tcl_platform(platform) != "foobar1") && \ + ($tcl_platform(platform) != "foobar2")} { + incr value + break + } + set value +} {2} +test while-4.6 {while (not compiled): non-numeric boolean test expr} { + set value 1 + set z while + $z {"true"} { + incr value; + if {$value > 5} { + break; + } + } + set value +} 6 +test while-4.7 {while (not compiled): test expr is enclosed in quotes} { + set i 0 + set z while + $z "$i > 5" {} +} {} +test while-4.8 {while (not compiled): missing command body} { + set i 0 + set z while + catch {$z {$i < 5} } msg + set msg +} {wrong # args: should be "while test command"} +test while-4.9 {while (not compiled): error compiling command body} { + set i 0 + set z while + catch {$z {$i < 5} {set}} msg + set errorInfo +} {wrong # args: should be "set varName ?newValue?" + while compiling +"set" + ("while" body line 1) + invoked from within +"$z {$i < 5} {set}"} +test while-4.10 {while (not compiled): simple command body} { + set a {} + set i 1 + set z while + $z {$i<6} { + if $i==4 break + set a [concat $a $i] + incr i + } + set a +} {1 2 3} +test while-4.11 {while (not compiled): command body in quotes} { + set a {} + set i 1 + set z while + $z {$i<6} "append a x; incr i" + set a +} {xxxxx} +test while-4.12 {while (not compiled): computed command body} { + set z while + catch {unset x1} + catch {unset bb} + catch {unset x2} + set x1 {append a x1; } + set bb {break} + set x2 {; append a x2; incr i} + set a {} + set i 1 + $z {$i<6} $x1$bb$x2 + set a +} {x1} +test while-4.13 {while (not compiled): long command body} { + set a {} + set z while + set i 1 + $z {$i<6} { + if $i==4 break + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + incr i + } + set a +} {1 2 3} +test while-4.14 {while (not compiled): while command result} { + set i 0 + set z while + set a [$z {$i < 5} {incr i}] + set a +} {} +test while-4.15 {while (not compiled): while command result} { + set i 0 + set z while + set a [$z {$i < 5} {if $i==3 break; incr i}] + set a +} {} + +# Check "break" with computed command names. test while-5.1 {break and computed command names} { set i 0 @@ -306,6 +452,73 @@ test while-5.1 {break and computed command names} { } set i } 11 +test while-5.2 {break tests with computed command names} { + set a {} + set i 1 + set z break + while {$i <= 4} { + if {$i == 3} $z + set a [concat $a $i] + incr i + } + set a +} {1 2} +test while-5.3 {break tests, nested loops with computed command names} { + set msg {} + set i 1 + set z break + while {$i <= 4} { + set a 1 + while {$a <= 2} { + if {$i>=2 && $a>=2} $z + set msg [concat $msg "$i.$a"] + incr a + } + incr i + } + set msg +} {1.1 1.2 2.1 3.1 4.1} +test while-5.4 {break tests, long command body with computed command names} { + set a {} + set i 1 + set z break + while {$i<6} { + if $i==2 {incr i; continue} + if $i==5 $z + if $i>5 continue + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if $i==4 $z + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + incr i + } + set a +} {1 3} + +# Check "continue" with computed command names. test while-6.1 {continue and computed command names} { set i 0 @@ -317,3 +530,104 @@ test while-6.1 {continue and computed command names} { } set i } 10 +test while-6.2 {continue tests} { + set a {} + set i 1 + set z continue + while {$i <= 4} { + incr i + if {$i == 3} $z + set a [concat $a $i] + } + set a +} {2 4 5} +test while-6.3 {continue tests with computed command names} { + set a {} + set i 1 + set z continue + while {$i <= 4} { + incr i + if {$i != 2} $z + set a [concat $a $i] + } + set a +} {2} +test while-6.4 {continue tests, nested loops with computed command names} { + set msg {} + set i 1 + set z continue + while {$i <= 4} { + incr i + set a 1 + while {$a <= 2} { + incr a + if {$i>=3 && $a>=3} $z + set msg [concat $msg "$i.$a"] + } + } + set msg +} {2.2 2.3 3.2 4.2 5.2} +test while-6.5 {continue tests, long command body with computed command names} { + set a {} + set i 1 + set z continue + while {$i<6} { + if $i==2 {incr i; continue} + if $i==4 break + if $i>5 $z + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + if {$i>6 && $tcl_platform(machine)=="xxx"} { + catch {set a $a} msg + catch {incr i 5} msg + catch {incr i -5} msg + } + set a [concat $a $i] + incr i + } + set a +} {1 3} + +# Test for incorrect "double evaluation" semantics + +test while-7.1 {delayed substitution of body} {knownBug} { + set i 0 + while {[incr i] < 10} " + set result $i + " + set result +} {0} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/winConsole.test b/tests/winConsole.test new file mode 100644 index 0000000..8a18b2c --- /dev/null +++ b/tests/winConsole.test @@ -0,0 +1,51 @@ +# This file tests the tclWinConsole.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) 1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: winConsole.test,v 1.2 1999/04/16 00:47:36 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + + +test winConsole-1.1 {Console file channel: non-blocking gets} \ + {pcOnly interactive} { + + set oldmode [fconfigure stdin] + + puts stdout "Enter abcdef<return> now: " nonewline + flush stdout + fileevent stdin readable { + if {[gets stdin line] >= 0} { + set result $line + } else { + set result "gets failed" + } + } + + fconfigure stdin -blocking 0 -buffering line + + set result {} + vwait result + + #cleanup the fileevent + fileevent stdin readable {} + eval fconfigure stdin $oldmode + + set result + +} "abcdef" + +#cleanup + +::tcltest::cleanupTests +return + diff --git a/tests/winDde.test b/tests/winDde.test new file mode 100644 index 0000000..e9b65d8 --- /dev/null +++ b/tests/winDde.test @@ -0,0 +1,152 @@ +# This file tests the tclWinDde.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) 1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: winDde.test,v 1.2 1999/04/16 00:47:37 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {$tcl_platform(platform) == "windows"} { + if [catch { + set lib [lindex [glob [file join [pwd] [file dirname \ + [info nameofexecutable]] tcldde*.dll]] 0] + load $lib dde + }] { + puts "Unable to find the dde package. Skipping registry tests." + ::tcltest::cleanupTests + return + } +} + +set scriptName script1.tcl + + +proc createChildProcess { ddeServerName } { + + file delete -force $::scriptName + + set f [open $::scriptName w+] + puts $f { + if [catch { + set lib [lindex [glob [file join [pwd] [file dirname \ + [info nameofexecutable]] tcldde*.dll]] 0] + load $lib dde + }] { + puts "Unable to find the dde package. Skipping registry tests." + ::tcltest::cleanupTests + return + } + } + puts $f "dde servername $ddeServerName" + puts $f { + puts ready + vwait done + update + exit + } + close $f + + set f [open "|$::tcltest $::scriptName" r] + gets $f + return $f +} + +test winDde-1.1 {Settings the server's topic name} {pcOnly} { + list [dde servername foobar] [dde servername] [dde servername self] +} {foobar foobar self} + +test winDde-2.1 {Checking for other services} {pcOnly} { + expr [llength [dde services {} {}]] >= 0 +} 1 + +test winDde-2.2 {Checking for existence, with service and topic specified} \ + {pcOnly} { + llength [dde services TclEval self] +} 1 + +test winDde-2.3 {Checking for existence, with only the service specified} \ + {pcOnly} { + expr [llength [dde services TclEval {}]] >= 1 +} 1 + +test winDde-3.1 {DDE execute locally} {pcOnly} { + set a "" + dde execute TclEval self {set a "foo"} + set a +} foo + +test winDde-3.2 {DDE execute -async locally} {pcOnly} { + set a "" + dde execute -async TclEval self {set a "foo"} + update + set a +} foo + +test winDde-3.3 {DDE request locally} {pcOnly} { + set a "" + dde execute TclEval self {set a "foo"} + dde request TclEval self a +} foo + +test winDde-3.4 {DDE eval locally} {pcOnly} { + set a "" + dde eval self set a "foo" +} foo + +test winDde-4.1 {DDE execute remotely} {pcOnly} { + set a "" + set child [createChildProcess child] + dde execute TclEval child {set a "foo"} + + dde execute TclEval child {set done 1} + + set a +} "" + +test winDde-4.2 {DDE execute remotely} {pcOnly} { + set a "" + set child [createChildProcess child] + dde execute -async TclEval child {set a "foo"} + + dde execute TclEval child {set done 1} + + set a +} "" + +test winDde-4.3 {DDE request locally} {pcOnly} { + set a "" + set child [createChildProcess child] + dde execute TclEval child {set a "foo"} + set a [dde request TclEval child a] + + + dde execute TclEval child {set done 1} + + set a +} foo + +test winDde-4.4 {DDE eval locally} {pcOnly} { + set a "" + set child [createChildProcess child] + set a [dde eval child set a "foo"] + + dde execute TclEval child {set done 1} + + set a +} foo + + +#cleanup +file delete -force $::scriptName +::tcltest::cleanupTests +return + diff --git a/tests/winFCmd.test b/tests/winFCmd.test index dad71e9..935198e 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -5,17 +5,16 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winFCmd.test,v 1.3 1999/02/02 23:01:42 stanton Exp $ +# RCS: @(#) $Id: winFCmd.test,v 1.4 1999/04/16 00:47:37 stanton Exp $ # -if {[string compare test [info procs test]] == 1} then {source defs} - -if {$tcl_platform(platform) != "windows"} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } proc createfile {file {string a}} { @@ -44,9 +43,8 @@ proc cleanup {args} { } } -set testConfig(cdrom) 0 -set testConfig(exdev) 0 -set testConfig(UNCPath} 0 +set ::tcltest::testConfig(cdrom) 0 +set ::tcltest::testConfig(exdev) 0 # find a CD-ROM so we can test read-only filesystems. @@ -85,11 +83,8 @@ proc findfile {dir} { 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 +if {$cdrom != ""} { + set ::tcltest::testConfig(cdrom) 1 set cdfile [findfile $cdrom] } @@ -97,21 +92,17 @@ 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 + set ::tcltest::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 + set ::tcltest::testConfig(longFileNames) 0 } else { close $testfile - set testConfig(longFileNames) 1 + set ::tcltest::testConfig(longFileNames) 1 file delete -force -- td1 } @@ -131,67 +122,64 @@ append longname $longname # it can be difficult to actually forward "insane" arguments to the # low-level posix emulation layer. -test winFCmd-1.1 {TclpRenameFile: errno: EACCES} {cdrom} { +test winFCmd-1.1 {TclpRenameFile: errno: EACCES} {pcOnly cdrom} { list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg } {1 EACCES} -test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} { +test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} {pcOnly} { 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. - +test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} {pcOnly} { cleanup list [catch {testfile mv / td1} msg] $msg } {1 EINVAL} -test winFCmd-1.4 {TclpRenameFile: errno: EINVAL} { +test winFCmd-1.4 {TclpRenameFile: errno: EINVAL} {pcOnly} { cleanup file mkdir td1 list [catch {testfile mv td1 td1/td2} msg] $msg } {1 EINVAL} -test winFCmd-1.5 {TclpRenameFile: errno: EISDIR} { +test winFCmd-1.5 {TclpRenameFile: errno: EISDIR} {pcOnly} { cleanup file mkdir td1 createfile tf1 list [catch {testfile mv tf1 td1} msg] $msg } {1 EISDIR} -test winFCmd-1.6 {TclpRenameFile: errno: ENOENT} { +test winFCmd-1.6 {TclpRenameFile: errno: ENOENT} {pcOnly} { cleanup list [catch {testfile mv tf1 tf2} msg] $msg } {1 ENOENT} -test winFCmd-1.7 {TclpRenameFile: errno: ENOENT} { +test winFCmd-1.7 {TclpRenameFile: errno: ENOENT} {pcOnly} { cleanup list [catch {testfile mv "" tf2} msg] $msg } {1 ENOENT} -test winFCmd-1.8 {TclpRenameFile: errno: ENOENT} { +test winFCmd-1.8 {TclpRenameFile: errno: ENOENT} {pcOnly} { cleanup createfile tf1 list [catch {testfile mv tf1 ""} msg] $msg } {1 ENOENT} -test winFCmd-1.9 {TclpRenameFile: errno: ENOTDIR} { +test winFCmd-1.9 {TclpRenameFile: errno: ENOTDIR} {pcOnly} { cleanup file mkdir td1 createfile tf1 list [catch {testfile mv td1 tf1} msg] $msg } {1 ENOTDIR} -test winFCmd-1.10 {TclpRenameFile: errno: EXDEV} {exdev} { +test winFCmd-1.10 {TclpRenameFile: errno: EXDEV} {pcOnly 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} { +test winFCmd-1.11 {TclpRenameFile: errno: EACCES} {pcOnly} { 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} { +test winFCmd-1.12 {TclpRenameFile: errno: EACCES} {pcOnly} { cleanup createfile tf1 set fd [open tf2 w] @@ -199,7 +187,7 @@ test winFCmd-1.12 {TclpRenameFile: errno: EACCES} { close $fd set msg } {1 EACCES} -test winFCmd-1.13 {TclpRenameFile: errno: EACCES} { +test winFCmd-1.13 {TclpRenameFile: errno: EACCES} {pcOnly} { cleanup list [catch {testfile mv nul tf1} msg] $msg } {1 EACCES} @@ -213,109 +201,99 @@ test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {nt} { createfile tf1 list [catch {testfile mv tf1 nul} msg] $msg } {1 EEXIST} -test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} { +test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} {pcOnly} { cleanup createfile tf1 tf1 testfile mv tf1 tf2 list [file exists tf1] [contents tf2] } {0 tf1} -test winFCmd-1.17 {TclpRenameFile: MoveFile() == FALSE} { +test winFCmd-1.17 {TclpRenameFile: MoveFile() == FALSE} {pcOnly} { cleanup list [catch {testfile mv tf1 tf2} msg] $msg } {1 ENOENT} -test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} { +test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} {pcOnly} { cleanup list [catch {testfile mv tf1 tf2} msg] $msg } {1 ENOENT} -test winFCmd-1.19 {TclpRenameFile: errno == EACCES} { +test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {pcOnly} { 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} { +test winFCmd-1.20 {TclpRenameFile: src is dir} {nt} { + # under 95, this would actually succeed and move the current dir out from + # under the current process! cleanup file delete /tf1 list [catch {testfile mv [pwd] /tf1} msg] $msg } {1 EACCES} -test winFCmd-1.21 {TclpRenameFile: obscenely long src} {!win32s} { - # Really long file names cause all the file system calls to lock up, - # endlessly throwing an access violation and retrying the operation. - +test winFCmd-1.21 {TclpRenameFile: long src} {pcOnly} { + cleanup list [catch {testfile mv $longname tf1} msg] $msg } {1 ENAMETOOLONG} -test winFCmd-1.22 {TclpRenameFile: obscenely long dst} {nt} { - # return ENOENT if name is too long! - cleanup - createfile tf1 - list [catch {testfile mv tf1 $longname} msg] $msg -} {1 ENOENT} -test winFCmd-1.23 {TclpRenameFile: obscenely long dst} {95} { +test winFCmd-1.22 {TclpRenameFile: long dst} {pcOnly} { cleanup createfile tf1 list [catch {testfile mv tf1 $longname} msg] $msg } {1 ENAMETOOLONG} -test winFCmd-1.24 {TclpRenameFile: move dir into self} { +test winFCmd-1.23 {TclpRenameFile: move dir into self} {pcOnly} { 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. - +test winFCmd-1.24 {TclpRenameFile: move a root dir} {pcOnly} { cleanup list [catch {testfile mv / c:/} msg] $msg } {1 EINVAL} -test winFCmd-1.26 {TclpRenameFile: cross file systems} {cdrom} { +test winFCmd-1.25 {TclpRenameFile: cross file systems} {pcOnly cdrom} { cleanup file mkdir td1 list [catch {testfile mv td1 $cdrom/td1} msg] $msg } {1 EXDEV} -test winFCmd-1.27 {TclpRenameFile: readonly fs} {cdrom} { +test winFCmd-1.26 {TclpRenameFile: readonly fs} {pcOnly cdrom} { cleanup list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg } {1 EACCES} -test winFCmd-1.28 {TclpRenameFile: open file} { +test winFCmd-1.27 {TclpRenameFile: open file} {pcOnly} { cleanup set fd [open tf1 w] set msg [list [catch {testfile mv tf1 tf2} msg] $msg] close $fd set msg } {1 EACCES} -test winFCmd-1.29 {TclpRenameFile: errno == EEXIST} { +test winFCmd-1.28 {TclpRenameFile: errno == EEXIST} {pcOnly} { cleanup createfile tf1 createfile tf2 testfile mv tf1 tf2 list [file exist tf1] [file exist tf2] } {0 1} -test winFCmd-1.30 {TclpRenameFile: src is dir} { +test winFCmd-1.29 {TclpRenameFile: src is dir} {pcOnly} { cleanup file mkdir td1 createfile tf1 list [catch {testfile mv td1 tf1} msg] $msg } {1 ENOTDIR} -test winFCmd-1.31 {TclpRenameFile: dst is dir} { +test winFCmd-1.30 {TclpRenameFile: dst is dir} {pcOnly} { cleanup file mkdir td1 file mkdir td2/td2 list [catch {testfile mv td1 td2} msg] $msg } {1 EEXIST} -test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory fails} { +test winFCmd-1.31 {TclpRenameFile: TclpRemoveDirectory fails} {pcOnly} { cleanup file mkdir td1 file mkdir td2/td2 list [catch {testfile mv td1 td2} msg] $msg } {1 EEXIST} -test winFCmd-1.33 {TclpRenameFile: TclpRemoveDirectory succeeds} { +test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} {pcOnly} { cleanup file mkdir td1/td2 file mkdir td2 testfile mv td1 td2 list [file exist td1] [file exist td2] [file exist td2/td2] } {0 1 1} -test winFCmd-1.34 {TclpRenameFile: After removing dst dir, MoveFile fails} {exdev} { +test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} \ + {pcOnly exdev} { file mkdir d:/td1 testchmod 000 d:/td1 set msg [list [catch {testfile mv c:/windows d:/td1} msg] $msg] @@ -323,56 +301,56 @@ test winFCmd-1.34 {TclpRenameFile: After removing dst dir, MoveFile fails} {exde file delete d:/td1 set msg } {1 EXDEV 0} -test winFCmd-1.35 {TclpRenameFile: src is dir, dst is not} { +test winFCmd-1.34 {TclpRenameFile: src is dir, dst is not} {pcOnly} { file mkdir td1 createfile tf1 list [catch {testfile mv td1 tf1} msg] $msg } {1 ENOTDIR} -test winFCmd-1.36 {TclpRenameFile: src is not dir, dst is} { +test winFCmd-1.35 {TclpRenameFile: src is not dir, dst is} {pcOnly} { file mkdir td1 createfile tf1 list [catch {testfile mv tf1 td1} msg] $msg } {1 EISDIR} -test winFCmd-1.37 {TclpRenameFile: src and dst not dir} { +test winFCmd-1.36 {TclpRenameFile: src and dst not dir} {pcOnly} { createfile tf1 tf1 createfile tf2 tf2 testfile mv tf1 tf2 contents tf2 } {tf1} -test winFCmd-1.38 {TclpRenameFile: need to restore temp file} { +test winFCmd-1.37 {TclpRenameFile: need to restore temp file} {pcOnly} { # Can't figure out how to cause this. # Need a file that can't be copied. } {} -test winFCmd-2.1 {TclpCopyFile: errno: EACCES} {cdrom} { +test winFCmd-2.1 {TclpCopyFile: errno: EACCES} {pcOnly cdrom} { cleanup list [catch {testfile cp $cdfile $cdrom/dummy~~.fil} msg] $msg } {1 EACCES} -test winFCmd-2.2 {TclpCopyFile: errno: EISDIR} { +test winFCmd-2.2 {TclpCopyFile: errno: EISDIR} {pcOnly} { cleanup file mkdir td1 list [catch {testfile cp td1 tf1} msg] $msg } {1 EISDIR} -test winFCmd-2.3 {TclpCopyFile: errno: EISDIR} { +test winFCmd-2.3 {TclpCopyFile: errno: EISDIR} {pcOnly} { cleanup createfile tf1 file mkdir td1 list [catch {testfile cp tf1 td1} msg] $msg } {1 EISDIR} -test winFCmd-2.4 {TclpCopyFile: errno: ENOENT} { +test winFCmd-2.4 {TclpCopyFile: errno: ENOENT} {pcOnly} { cleanup list [catch {testfile cp tf1 tf2} msg] $msg } {1 ENOENT} -test winFCmd-2.5 {TclpCopyFile: errno: ENOENT} { +test winFCmd-2.5 {TclpCopyFile: errno: ENOENT} {pcOnly} { cleanup list [catch {testfile cp "" tf2} msg] $msg } {1 ENOENT} -test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} { +test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} {pcOnly} { cleanup createfile tf1 list [catch {testfile cp tf1 ""} msg] $msg } {1 ENOENT} -test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {!nt} { +test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {95} { cleanup createfile tf1 set fd [open tf2 w] @@ -388,49 +366,49 @@ 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} { +test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} {pcOnly} { cleanup createfile tf1 tf1 testfile cp tf1 tf2 list [contents tf1] [contents tf2] } {tf1 tf1} -test winFCmd-2.11 {TclpCopyFile: CopyFile succeeds} { +test winFCmd-2.11 {TclpCopyFile: CopyFile succeeds} {pcOnly} { 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} { +test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} {pcOnly} { 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} { +test winFCmd-2.13 {TclpCopyFile: CopyFile fails} {pcOnly} { cleanup createfile tf1 file mkdir td1 list [catch {testfile cp tf1 td1} msg] $msg } {1 EISDIR} -test winFCmd-2.14 {TclpCopyFile: errno == EACCES} { +test winFCmd-2.14 {TclpCopyFile: errno == EACCES} {pcOnly} { cleanup file mkdir td1 list [catch {testfile cp td1 tf1} msg] $msg } {1 EISDIR} -test winFCmd-2.15 {TclpCopyFile: src is directory} { +test winFCmd-2.15 {TclpCopyFile: src is directory} {pcOnly} { cleanup file mkdir td1 list [catch {testfile cp td1 tf1} msg] $msg } {1 EISDIR} -test winFCmd-2.16 {TclpCopyFile: dst is directory} { +test winFCmd-2.16 {TclpCopyFile: dst is directory} {pcOnly} { cleanup createfile tf1 file mkdir td1 list [catch {testfile cp tf1 td1} msg] $msg } {1 EISDIR} -test winFCmd-2.17 {TclpCopyFile: dst is readonly} { +test winFCmd-2.17 {TclpCopyFile: dst is readonly} {pcOnly} { cleanup createfile tf1 tf1 createfile tf2 tf2 @@ -449,59 +427,59 @@ test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} {95} { set msg "$msg [file writable tf2]" } {1 EACCES 0} -test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} {cdrom} { +test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} {pcOnly cdrom} { list [catch {testfile rm $cdfile $cdrom/dummy~~.fil} msg] $msg } {1 EACCES} -test winFCmd-3.2 {TclpDeleteFile: errno: EISDIR} { +test winFCmd-3.2 {TclpDeleteFile: errno: EISDIR} {pcOnly} { cleanup file mkdir td1 list [catch {testfile rm td1} msg] $msg } {1 EISDIR} -test winFCmd-3.3 {TclpDeleteFile: errno: ENOENT} { +test winFCmd-3.3 {TclpDeleteFile: errno: ENOENT} {pcOnly} { cleanup list [catch {testfile rm tf1} msg] $msg } {1 ENOENT} -test winFCmd-3.4 {TclpDeleteFile: errno: ENOENT} { +test winFCmd-3.4 {TclpDeleteFile: errno: ENOENT} {pcOnly} { cleanup list [catch {testfile rm ""} msg] $msg } {1 ENOENT} -test winFCmd-3.5 {TclpDeleteFile: errno: EACCES} { +test winFCmd-3.5 {TclpDeleteFile: errno: EACCES} {pcOnly} { 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} { +test winFCmd-3.6 {TclpDeleteFile: errno: EACCES} {pcOnly} { cleanup list [catch {testfile rm nul} msg] $msg } {1 EACCES} -test winFCmd-3.7 {TclpDeleteFile: DeleteFile succeeds} { +test winFCmd-3.7 {TclpDeleteFile: DeleteFile succeeds} {pcOnly} { cleanup createfile tf1 testfile rm tf1 file exist tf1 } {0} -test winFCmd-3.8 {TclpDeleteFile: DeleteFile fails} { +test winFCmd-3.8 {TclpDeleteFile: DeleteFile fails} {pcOnly} { cleanup file mkdir td1 list [catch {testfile rm td1} msg] $msg } {1 EISDIR} -test winFCmd-3.9 {TclpDeleteFile: errno == EACCES} { +test winFCmd-3.9 {TclpDeleteFile: errno == EACCES} {pcOnly} { 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} { +test winFCmd-3.10 {TclpDeleteFile: path is readonly} {pcOnly} { cleanup createfile tf1 testchmod 000 tf1 testfile rm tf1 file exists tf1 } {0} -test winFCmd-3.11 {TclpDeleteFile: still can't remove path} { +test winFCmd-3.11 {TclpDeleteFile: still can't remove path} {pcOnly} { cleanup set fd [open tf1 w] testchmod 000 tf1 @@ -510,82 +488,82 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} { set msg } {1 EACCES} -test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {cdrom nt} { +test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {nt cdrom} { list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg } {1 EACCES} -test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} {cdrom 95} { +test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} {95 cdrom} { list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg } {1 ENOSPC} -test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} { +test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} {pcOnly} { cleanup file mkdir td1 list [catch {testfile mkdir td1} msg] $msg } {1 EEXIST} -test winFCmd-4.4 {TclpCreateDirectory: errno: ENOENT} { +test winFCmd-4.4 {TclpCreateDirectory: errno: ENOENT} {pcOnly} { cleanup list [catch {testfile mkdir td1/td2} msg] $msg } {1 ENOENT} -test winFCmd-4.5 {TclpCreateDirectory: CreateDirectory succeeds} { +test winFCmd-4.5 {TclpCreateDirectory: CreateDirectory succeeds} {pcOnly} { cleanup testfile mkdir td1 file type td1 } {directory} -test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} { +test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} {pcOnly} { cleanup file mkdir td1 testfile cpdir td1 td2 list [file type td1] [file type td2] } {directory directory} -test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} { +test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} {pcOnly} { cleanup file mkdir td1 testchmod 000 td1 testfile rmdir td1 file exist td1 } {0} -test winFCmd-6.2 {TclpRemoveDirectory: errno: EEXIST} { +test winFCmd-6.2 {TclpRemoveDirectory: errno: EEXIST} {pcOnly} { cleanup file mkdir td1/td2 list [catch {testfile rmdir td1} msg] $msg } {1 {td1 EEXIST}} -test winFCmd-6.3 {TclpRemoveDirectory: errno: EACCES} { +test winFCmd-6.3 {TclpRemoveDirectory: errno: EACCES} {pcOnly} { # can't test this w/o removing everything on your hard disk first! # testfile rmdir / } {} -test winFCmd-6.4 {TclpRemoveDirectory: errno: ENOENT} { +test winFCmd-6.4 {TclpRemoveDirectory: errno: ENOENT} {pcOnly} { cleanup list [catch {testfile rmdir td1} msg] $msg } {1 {td1 ENOENT}} -test winFCmd-6.5 {TclpRemoveDirectory: errno: ENOENT} { +test winFCmd-6.5 {TclpRemoveDirectory: errno: ENOENT} {pcOnly} { cleanup list [catch {testfile rmdir ""} msg] $msg } {1 ENOENT} -test winFCmd-6.6 {TclpRemoveDirectory: errno: ENOTDIR} { +test winFCmd-6.6 {TclpRemoveDirectory: errno: ENOTDIR} {pcOnly} { cleanup createfile tf1 list [catch {testfile rmdir tf1} msg] $msg } {1 {tf1 ENOTDIR}} -test winFCmd-6.7 {TclpRemoveDirectory: RemoveDirectory succeeds} { +test winFCmd-6.7 {TclpRemoveDirectory: RemoveDirectory succeeds} {pcOnly} { cleanup file mkdir td1 testfile rmdir td1 file exists td1 } {0} -test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} { +test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} {pcOnly} { cleanup createfile tf1 list [catch {testfile rmdir tf1} msg] $msg } {1 {tf1 ENOTDIR}} -test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} { +test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} {pcOnly} { cleanup file mkdir td1 testchmod 000 td1 testfile rmdir td1 file exists td1 } {0} -test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {!nt} { +test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {95} { cleanup list [catch {testfile rmdir nul} msg] $msg } {1 {nul EACCES}} @@ -593,94 +571,95 @@ 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} { +test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {95} { cleanup createfile tf1 list [catch {testfile rmdir tf1} msg] $msg } {1 {tf1 ENOTDIR}} -test winFCmd-6.13 {TclpRemoveDirectory: write-protected} { +test winFCmd-6.13 {TclpRemoveDirectory: write-protected} {pcOnly} { cleanup file mkdir td1 testchmod 000 td1 testfile rmdir td1 file exists td1 } {0} -test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {!nt} { +test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {95} { cleanup file mkdir td1/td2 list [catch {testfile rmdir td1} msg] $msg } {1 {td1 EEXIST}} -test winFCmd-6.15 {TclpRemoveDirectory: !recursive} { +test winFCmd-6.15 {TclpRemoveDirectory: !recursive} {pcOnly} { cleanup file mkdir td1/td2 list [catch {testfile rmdir td1} msg] $msg } {1 {td1 EEXIST}} -test winFCmd-6.16 {TclpRemoveDirectory: recursive, but errno != EEXIST} { +test winFCmd-6.16 {TclpRemoveDirectory: recursive, but errno != EEXIST} {pcOnly} { cleanup createfile tf1 list [catch {testfile rmdir -force tf1} msg] $msg } {1 {tf1 ENOTDIR}} -test winFCmd-6.17 {TclpRemoveDirectory: calls TraverseWinTree} { +test winFCmd-6.17 {TclpRemoveDirectory: calls TraverseWinTree} {pcOnly} { cleanup file mkdir td1/td2 testfile rmdir -force td1 file exists td1 } {0} -test winFCmd-7.1 {TraverseWinTree: targetPtr == NULL} { +test winFCmd-7.1 {TraverseWinTree: targetPtr == NULL} {pcOnly} { cleanup file mkdir td1/td2/td3 testfile rmdir -force td1 file exists td1 } {0} -test winFCmd-7.2 {TraverseWinTree: targetPtr != NULL} { +test winFCmd-7.2 {TraverseWinTree: targetPtr != NULL} {pcOnly} { 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} { +test winFCmd-7.3 {TraverseWinTree: sourceAttr == -1} {pcOnly} { cleanup list [catch {testfile cpdir td1 td2} msg] $msg } {1 {td1 ENOENT}} -test winFCmd-7.4 {TraverseWinTree: source isn't directory} { +test winFCmd-7.4 {TraverseWinTree: source isn't directory} {pcOnly} { 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} { +test winFCmd-7.5 {TraverseWinTree: call TraversalCopy: DOTREE_F} {pcOnly} { 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} { +test winFCmd-7.6 {TraverseWinTree: call TraversalDelete: DOTREE_F} {pcOnly} { 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} { +test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} {pcOnly} { 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} { +test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {95 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} { +test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \ + {pcOnly} { # can't make it happen } {} -test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} { +test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} {pcOnly} { cleanup file mkdir td1 testchmod 000 td1 @@ -688,21 +667,21 @@ test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} { testfile cpdir td1 td2 list [file exists td2] [file writable td2] } {1 0} -test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} { +test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} {pcOnly} { 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} { +test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} {pcOnly} { 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} { +test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {95} { cleanup file mkdir td1 list [catch {testfile cpdir td1 /} msg] $msg @@ -712,19 +691,20 @@ test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {nt} { file mkdir td1 list [catch {testfile cpdir td1 /} msg] $msg } {1 {\ EACCES}} -test winFCmd-7.16 {TraverseWinTree: recurse on files: no files} { +test winFCmd-7.16 {TraverseWinTree: recurse on files: no files} {pcOnly} { cleanup file mkdir td1 testfile cpdir td1 td2 } {} -test winFCmd-7.17 {TraverseWinTree: recurse on files: one file} { +test winFCmd-7.17 {TraverseWinTree: recurse on files: one file} {pcOnly} { 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} { +test winFCmd-7.18 {TraverseWinTree: recurse on files: several files and dir} \ + {pcOnly} { cleanup file mkdir td1 createfile td1/tf1 @@ -735,7 +715,7 @@ test winFCmd-7.18 {TraverseWinTree: recurse on files: several files and dir} { testfile cpdir td1 td2 lsort [glob td2/*] } {td2/td2 td2/tf1 td2/tf2 td2/tf3 td2/tf4} -test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} { +test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} {pcOnly} { cleanup file mkdir td1 testchmod 000 td1 @@ -743,37 +723,38 @@ test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} { testfile cpdir td1 td2 list [file exists td2] [file writable td2] } {1 0} -test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} { +test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} \ + {pcOnly} { cleanup file mkdir td1 createfile td1/tf1 tf1 testfile rmdir -force td1 file exists td1 } {0} -test winFCmd-7.21 {TraverseWinTree: fill errorPtr} { +test winFCmd-7.21 {TraverseWinTree: fill errorPtr} {pcOnly} { cleanup list [catch {testfile cpdir td1 td2} msg] $msg } {1 {td1 ENOENT}} -test winFCmd-8.1 {TraversalCopy: DOTREE_F} { +test winFCmd-8.1 {TraversalCopy: DOTREE_F} {pcOnly} { cleanup file mkdir td1 list [catch {testfile cpdir td1 td1} msg] $msg } {1 {td1 EEXIST}} -test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} { +test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} {pcOnly} { 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} { +test winFCmd-8.3 {TraversalCopy: DOTREE_POSTD} {pcOnly} { cleanup file mkdir td1 testfile cpdir td1 td2 } {} -test winFCmd-9.1 {TraversalDelete: DOTREE_F} { +test winFCmd-9.1 {TraversalDelete: DOTREE_F} {pcOnly} { cleanup file mkdir td1 createfile td1/tf1 @@ -787,193 +768,211 @@ test winFCmd-9.2 {TraversalDelete: DOTREE_F} {95} { close $fd set msg } {1 {td1\tf1 EACCES}} -test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} { +test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} {pcOnly} { cleanup file mkdir td1/td2 testchmod 000 td1 testfile rmdir -force td1 file exists td1 } {0} -test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} { +test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} {pcOnly} { cleanup file mkdir td1/td1/td3/td4/td5 testfile rmdir -force td1 } {} -test winFCmd-10.1 {AttributesPosixError - get} { +test winFCmd-10.1 {AttributesPosixError - get} {pcOnly} { 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} { +} {1 {could not read "td1": no such file or directory}} +test winFCmd-10.2 {AttributesPosixError - set} {pcOnly} { cleanup list [catch {file attributes td1 -archive 0} msg] $msg -} {1 {cannot set attribute "-archive" for file "td1": no such file or directory}} +} {1 {could not read "td1": no such file or directory}} -test winFCmd-11.1 {GetWinFileAttributes} { +test winFCmd-11.1 {GetWinFileAttributes} {pcOnly} { cleanup close [open td1 w] list [catch {file attributes td1 -archive} msg] $msg [cleanup] } {0 1 {}} -test winFCmd-11.2 {GetWinFileAttributes} { +test winFCmd-11.2 {GetWinFileAttributes} {pcOnly} { cleanup close [open td1 w] list [catch {file attributes td1 -readonly} msg] $msg [cleanup] } {0 0 {}} -test winFCmd-11.3 {GetWinFileAttributes} { +test winFCmd-11.3 {GetWinFileAttributes} {pcOnly} { cleanup close [open td1 w] list [catch {file attributes td1 -hidden} msg] $msg [cleanup] } {0 0 {}} -test winFCmd-11.4 {GetWinFileAttributes} { +test winFCmd-11.4 {GetWinFileAttributes} {pcOnly} { cleanup close [open td1 w] list [catch {file attributes td1 -system} msg] $msg [cleanup] } {0 0 {}} +test winfcmd-11.5 {GetWinFileAttributes} {pcOnly} { + # attr of relative paths that resolve to root was failing + # don't care about answer, just that test runs. + + set old [pwd] + cd c:/ + file attr c: + file attr c:. + file attr . + cd $old +} {} -test winFCmd-12.1 {ConvertFileNameFormat} { +test winFCmd-12.1 {ConvertFileNameFormat} {pcOnly} { cleanup close [open td1 w] list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup] } {0 td1 {}} -test winFCmd-12.2 {ConvertFileNameFormat} { +test winFCmd-12.2 {ConvertFileNameFormat} {pcOnly} { 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} { +test winFCmd-12.3 {ConvertFileNameFormat} {pcOnly} { 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} { +test winFCmd-12.4 {ConvertFileNameFormat} {pcOnly} { 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} { +test winFCmd-12.5 {ConvertFileNameFormat: absolute path} {pcOnly} { list [file attributes / -longname] [file attributes \\ -longname] } {/ /} -test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} { +test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} {pcOnly} { 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} { +test winFCmd-12.7 {ConvertFileNameFormat} {nonPortable pcOnly} { + string tolower [file attributes //bisque/tcl/ws -longname] +} {//bisque/tcl/ws} +test winFCmd-12.8 {ConvertFileNameFormat} {pcOnly longFileNames} { cleanup close [open td1 w] list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup] } {0 td1 {}} -test winFCmd-12.10 {ConvertFileNameFormat} {longFileNames} { +test winFCmd-12.10 {ConvertFileNameFormat} {longFileNames pcOnly} { cleanup close [open td1td1td1 w] list [catch {file attributes td1td1td1 -shortname}] [cleanup] } {0 {}} -test winFCmd-12.11 {ConvertFileNameFormat} {longFileNames} { +test winFCmd-12.11 {ConvertFileNameFormat} {longFileNames pcOnly} { cleanup close [open td1 w] list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup] } {0 td1 {}} -test winFCmd-13.1 {GetWinFileLongName} { +test winFCmd-13.1 {GetWinFileLongName} {pcOnly} { cleanup close [open td1 w] list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup] } {0 td1 {}} -test winFCmd-14.1 {GetWinFileShortName} { +test winFCmd-14.1 {GetWinFileShortName} {pcOnly} { cleanup close [open td1 w] list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup] } {0 td1 {}} -test winFCmd-15.1 {SetWinFileAttributes} { +test winFCmd-15.1 {SetWinFileAttributes} {pcOnly} { 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} { +} {1 {could not read "td1": no such file or directory}} +test winFCmd-15.2 {SetWinFileAttributes - archive} {pcOnly} { 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} { +test winFCmd-15.3 {SetWinFileAttributes - archive} {pcOnly} { 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} { +test winFCmd-15.4 {SetWinFileAttributes - hidden} {pcOnly} { 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} { +test winFCmd-15.5 {SetWinFileAttributes - hidden} {pcOnly} { 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} { +test winFCmd-15.6 {SetWinFileAttributes - readonly} {pcOnly} { 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} { +test winFCmd-15.7 {SetWinFileAttributes - readonly} {pcOnly} { 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} { +test winFCmd-15.8 {SetWinFileAttributes - system} {pcOnly} { 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} { +test winFCmd-15.9 {SetWinFileAttributes - system} {pcOnly} { 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} { +test winFCmd-15.10 {SetWinFileAttributes - failing} {pcOnly cdrom} { cleanup catch {file attributes $cdfile -archive 1} } {1} +# This block of code used to occur after the "return" call, so I'm +# commenting it out and assuming that this code is still under construction. +#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 +# } +# } +# } +# } +#} + +# cleanup cleanup - +::tcltest::cleanupTests 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/winFile.test b/tests/winFile.test new file mode 100644 index 0000000..677150d --- /dev/null +++ b/tests/winFile.test @@ -0,0 +1,64 @@ +# This file tests the tclWinFile.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: winFile.test,v 1.2 1999/04/16 00:47:37 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +test winFile-1.1 {TclpGetUserHome} {pcOnly} { + list [catch {glob ~nosuchuser} msg] $msg +} {1 {user "nosuchuser" doesn't exist}} +test winFile-1.2 {TclpGetUserHome} {nt nonPortable} { + # The administrator account should always exist. + + catch {glob ~administrator} +} {0} +test winFile-1.2 {TclpGetUserHome} {95} { + # Find some user in system.ini and then see if they have a home. + + set f [open $::env(windir)/system.ini] + set x 0 + while {![eof $f]} { + set line [gets $f] + if {$line == "\[Password Lists]"} { + gets $f + set name [lindex [split [gets $f] =] 0] + if {$name != ""} { + set x [catch {glob ~$name}] + break + } + } + } + close $f + set x +} {0} +test winFile-1.3 {TclpGetUserHome} {nt nonPortable} { + catch {glob ~stanton@workgroup} +} {0} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/winNotify.test b/tests/winNotify.test index 2264699..c8c3d9e 100644 --- a/tests/winNotify.test +++ b/tests/winNotify.test @@ -5,27 +5,29 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winNotify.test,v 1.2 1998/09/14 18:40:15 stanton Exp $ +# RCS: @(#) $Id: winNotify.test,v 1.3 1999/04/16 00:47:37 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} - -if {$tcl_platform(platform) != "windows"} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } +set ::tcltest::testConfig(testeventloop) \ + [expr {[info commands testeventloop] != {}}] + # There is no explicit test for InitNotifier or NotifierExitHandler -test winNotify-1.1 {Tcl_SetTimer: positive timeout} { +test winNotify-1.1 {Tcl_SetTimer: positive timeout} {pcOnly} { set done 0 after 1000 { set done 1 } vwait done set done } 1 -test winNotify-1.2 {Tcl_SetTimer: positive timeout, message pending} { +test winNotify-1.2 {Tcl_SetTimer: positive timeout, message pending} {pcOnly} { set x 0 set y 1 set a1 [after 0 { incr y }] @@ -34,7 +36,7 @@ test winNotify-1.2 {Tcl_SetTimer: positive timeout, message pending} { vwait x list $x $y } {1 1} -test winNotify-1.3 {Tcl_SetTimer: cancelling positive timeout} { +test winNotify-1.3 {Tcl_SetTimer: cancelling positive timeout} {pcOnly} { set x 0 set y 1 set id [after 10000 { incr y }] @@ -43,7 +45,7 @@ test winNotify-1.3 {Tcl_SetTimer: cancelling positive timeout} { after cancel $id list $x $y } {1 1} -test winNotify-1.4 {Tcl_SetTimer: null timeout, message pending} { +test winNotify-1.4 {Tcl_SetTimer: null timeout, message pending} {pcOnly} { set x 0 set y 1 after 0 { incr x } @@ -52,14 +54,14 @@ test winNotify-1.4 {Tcl_SetTimer: null timeout, message pending} { list $x $y } {1 2} -test winNotify-2.1 {Tcl_ResetIdleTimer} { +test winNotify-2.1 {Tcl_ResetIdleTimer} {pcOnly} { set x 0 update after idle { incr x } vwait x set x } 1 -test winNotify-2.2 {Tcl_ResetIdleTimer: message pending} { +test winNotify-2.2 {Tcl_ResetIdleTimer: message pending} {pcOnly} { set x 0 set y 1 update @@ -69,7 +71,7 @@ test winNotify-2.2 {Tcl_ResetIdleTimer: message pending} { list $x $y } {1 2} -test winNotify-3.1 {NotifierProc: non-modal normal timer} { +test winNotify-3.1 {NotifierProc: non-modal normal timer} {pcOnly testeventloop} { update set x 0 foreach i [after info] { @@ -79,7 +81,7 @@ test winNotify-3.1 {NotifierProc: non-modal normal timer} { testeventloop wait set x } 1 -test winNotify-3.2 {NotifierProc: non-modal normal timer, rescheduled} { +test winNotify-3.2 {NotifierProc: non-modal normal timer, rescheduled} {pcOnly testeventloop} { update set x 0 foreach i [after info] { @@ -89,7 +91,7 @@ test winNotify-3.2 {NotifierProc: non-modal normal timer, rescheduled} { testeventloop wait set x } 2 -test winNotify-3.3 {NotifierProc: modal normal timer} { +test winNotify-3.3 {NotifierProc: modal normal timer} {pcOnly} { update set x 0 foreach i [after info] { @@ -99,7 +101,7 @@ test winNotify-3.3 {NotifierProc: modal normal timer} { vwait x set x } 1 -test winNotify-3.4 {NotifierProc: modal normal timer, rescheduled} { +test winNotify-3.4 {NotifierProc: modal normal timer, rescheduled} {pcOnly} { update set x 0 foreach i [after info] { @@ -110,7 +112,7 @@ test winNotify-3.4 {NotifierProc: modal normal timer, rescheduled} { vwait x list $x $y } {1 1} -test winNotify-3.5 {NotifierProc: non-modal idle timer} { +test winNotify-3.5 {NotifierProc: non-modal idle timer} {pcOnly testeventloop} { update set x 0 foreach i [after info] { @@ -120,7 +122,7 @@ test winNotify-3.5 {NotifierProc: non-modal idle timer} { testeventloop wait set x } 1 -test winNotify-3.6 {NotifierProc: non-modal idle timer, rescheduled} { +test winNotify-3.6 {NotifierProc: non-modal idle timer, rescheduled} {pcOnly testeventloop} { update set x 0 foreach i [after info] { @@ -130,7 +132,7 @@ test winNotify-3.6 {NotifierProc: non-modal idle timer, rescheduled} { testeventloop wait set x } 2 -test winNotify-3.7 {NotifierProc: modal idle timer} { +test winNotify-3.7 {NotifierProc: modal idle timer} {pcOnly} { update set x 0 foreach i [after info] { @@ -140,7 +142,7 @@ test winNotify-3.7 {NotifierProc: modal idle timer} { vwait x set x } 1 -test winNotify-3.8 {NotifierProc: modal idle timer, rescheduled} { +test winNotify-3.8 {NotifierProc: modal idle timer, rescheduled} {pcOnly} { update set x 0 foreach i [after info] { @@ -153,3 +155,19 @@ test winNotify-3.8 {NotifierProc: modal idle timer, rescheduled} { } {1 1} # Tcl_DoOneEvent is tested by the timer.test, io.test, and event.test files + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/winPipe.test b/tests/winPipe.test index 6e1cb85..2d23544 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -2,34 +2,36 @@ # 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. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winPipe.test,v 1.5 1999/02/03 19:12:27 stanton Exp $ +# RCS: @(#) $Id: winPipe.test,v 1.6 1999/04/16 00:47:37 stanton Exp $ -if {$tcl_platform(platform) != "windows"} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } set bindir [file join [pwd] [file dirname [info nameofexecutable]]] set cat16 [file join $bindir cat16.exe] set cat32 [file join $bindir cat32.exe] -if {[string compare test [info procs test]] == 1} then {source defs} +set ::tcltest::testConfig(cat32) [file exists $cat32] +set ::tcltest::testConfig(cat16) [file exists $cat16] -if [catch {puts console1 ""}] { - set testConfig(AllocConsole) 1 +if {[catch {puts console1 ""}]} { + set ::tcltest::testConfig(AllocConsole) 1 } else { - set testConfig(.console) 1 + set ::tcltest::testConfig(.console) 1 } -set big aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n +set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n append big $big append big $big append big $big @@ -52,108 +54,114 @@ proc contents {file} { set r } -if {$testConfig(stdio) && [file exists $cat32]} { -test winpipe-1.1 {32 bit comprehensive tests: from little file} { +set f [open more w] +puts $f { + while {[eof stdin] == 0} { + puts -nonewline [read stdin] + } +} +close $f + +test winpipe-1.1 {32 bit comprehensive tests: from little file} {pcOnly stdio cat32} { exec $cat32 < little > stdout 2> stderr list [contents stdout] [contents stderr] -} "little stderr32" -test winpipe-1.2 {32 bit comprehensive tests: from big file} { +} {little stderr32} +test winpipe-1.2 {32 bit comprehensive tests: from big file} {pcOnly stdio cat32} { 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 +test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {nt stdio cat32} { + exec $tcltest more < little | $cat32 > stdout 2> stderr list [contents stdout] [contents stderr] -} "{little\n} stderr32" -test winpipe-1.4 {32 bit comprehensive tests: a little from pipe} {95} { - exec more < little |& $cat32 > stdout 2> stderr - list [contents stdout] [contents stderr] -} "{\nlittle} stderr32" -test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {nt} { - exec more < big | $cat32 > stdout 2> stderr +} {little stderr32} +test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {nt stdio cat32} { + exec $tcltest more < big | $cat32 > stdout 2> stderr list [contents stdout] [contents stderr] } "{$big} stderr32" -test winpipe-1.6 {32 bit comprehensive tests: a lot from pipe} {95} { +test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {95 stdio cat32} { exec command /c type big |& $cat32 > stdout 2> stderr list [contents stdout] [contents stderr] } "{$big} stderr32" -test winpipe-1.7 {32 bit comprehensive tests: from console} {AllocConsole} { +test winpipe-1.6 {32 bit comprehensive tests: from console} \ + {pcOnly stdio cat32 AllocConsole} { # would block waiting for human input } {} -test winpipe-1.8 {32 bit comprehensive tests: from NUL} { +test winpipe-1.7 {32 bit comprehensive tests: from NUL} {pcOnly stdio cat32} { exec $cat32 < nul > stdout 2> stderr list [contents stdout] [contents stderr] -} "{} stderr32" -test winpipe-1.9 {32 bit comprehensive tests: from socket} { +} {{} stderr32} +test winpipe-1.8 {32 bit comprehensive tests: from socket} {pcOnly stdio cat32} { # doesn't work } {} -test winpipe-1.10 {32 bit comprehensive tests: from nowhere} {.console} { +test winpipe-1.9 {32 bit comprehensive tests: from nowhere} \ + {pcOnly stdio cat32 .console} { exec $cat32 > stdout 2> stderr list [contents stdout] [contents stderr] -} "{} stderr32" -test winpipe-1.11 {32 bit comprehensive tests: from file handle} { +} {{} stderr32} +test winpipe-1.10 {32 bit comprehensive tests: from file handle} \ + {pcOnly stdio cat32} { set f [open "little" r] exec $cat32 <@$f > stdout 2> stderr close $f list [contents stdout] [contents stderr] -} "little stderr32" -test winpipe-1.12 {32 bit comprehensive tests: read from application} { +} {little stderr32} +test winpipe-1.11 {32 bit comprehensive tests: read from application} \ + {pcOnly stdio cat32} { set f [open "|$cat32 < little" r] gets $f line catch {close $f} msg list $line $msg -} "little stderr32" -test winpipe-1.13 {32 bit comprehensive tests: a little to file} { +} {little stderr32} +test winpipe-1.12 {32 bit comprehensive tests: a little to file} \ + {pcOnly stdio cat32} { exec $cat32 < little > stdout 2> stderr list [contents stdout] [contents stderr] -} "little stderr32" -test winpipe-1.14 {32 bit comprehensive tests: a lot to file} { +} {little stderr32} +test winpipe-1.13 {32 bit comprehensive tests: a lot to file} \ + {pcOnly stdio cat32} { 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 +test winpipe-1.14 {32 bit comprehensive tests: a little to pipe} \ + {pcOnly stdio cat32} { + exec $cat32 < little | $tcltest more > stdout 2> stderr list [contents stdout] [contents stderr] -} "{$big\n} stderr32" -test winpipe-1.18 {32 bit comprehensive tests: a lot to pipe} {95} { - exec $cat32 < big | more > stdout 2> stderr +} {little stderr32} +test winpipe-1.15 {32 bit comprehensive tests: a lot to pipe} \ + {pcOnly stdio cat32} { + exec $cat32 < big | $tcltest more > stdout 2> stderr list [contents stdout] [contents stderr] -} "{\n$big} stderr32" -test winpipe-1.19 {32 bit comprehensive tests: to console} { +} "{$big} stderr32" +test winpipe-1.16 {32 bit comprehensive tests: to console} {pcOnly stdio cat32} { catch {exec $cat32 << "You should see this\n" >@stdout} msg set msg } stderr32 -test winpipe-1.20 {32 bit comprehensive tests: to NUL} { +test winpipe-1.17 {32 bit comprehensive tests: to NUL} {pcOnly stdio cat32} { # some apps hang when sending a large amount to NUL. $cat32 isn't one. catch {exec $cat32 < big > nul} msg set msg } stderr32 -test winpipe-1.21 {32 bit comprehensive tests: to nowhere} {.console} { +test winpipe-1.18 {32 bit comprehensive tests: to nowhere} \ + {pcOnly stdio cat32 .console} { exec $cat32 < big >&@stdout } {} -test winpipe-1.22 {32 bit comprehensive tests: to file handle} { +test winpipe-1.19 {32 bit comprehensive tests: to file handle} {pcOnly stdio cat32} { set f1 [open "stdout" w] set f2 [open "stderr" w] exec $cat32 < little >@$f1 2>@$f2 close $f1 close $f2 list [contents stdout] [contents stderr] -} "little stderr32" -test winpipe-1.23 {32 bit comprehensive tests: write to application} { +} {little stderr32} +test winpipe-1.20 {32 bit comprehensive tests: write to application} \ + {pcOnly stdio cat32} { set f [open "|$cat32 > stdout" w] puts -nonewline $f "foo" catch {close $f} msg list [contents stdout] $msg -} "foo stderr32" -test winpipe-1.24 {32 bit comprehensive tests: read/write application} { +} {foo stderr32} +test winpipe-1.21 {32 bit comprehensive tests: read/write application} \ + {pcOnly stdio cat32} { set f [open "|$cat32" r+] puts $f $big puts $f \032 @@ -161,115 +169,99 @@ test winpipe-1.24 {32 bit comprehensive tests: read/write application} { set r [read $f 64] catch {close $f} set r -} "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -} +} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" -set stderr16 "stderr16" -if {$tcl_platform(os) == "Win32s"} { - set stderr16 "{}" -} -if [file exists $cat16] { -test winpipe-2.1 {16 bit comprehensive tests: from little file} { + +test winpipe-2.1 {16 bit comprehensive tests: from little file} {pcOnly stdio cat16} { exec $cat16 < little > stdout 2> stderr list [contents stdout] [contents stderr] -} "little $stderr16" -test winpipe-2.2 {16 bit comprehensive tests: from big file} { +} "little stderr16" +test winpipe-2.2 {16 bit comprehensive tests: from big file} {pcOnly stdio cat16} { 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 +} "{$big} stderr16" +test winpipe-2.3 {16 bit comprehensive tests: a little from pipe} {pcOnly stdio cat16} { + exec $tcltest more < little | $cat16 > stdout 2> stderr list [contents stdout] [contents stderr] -} "{\nlittle} stderr16" -test winpipe-2.5 {16 bit comprehensive tests: a lot from pipe} {nt} { +} {little stderr16} +test winpipe-2.4 {16 bit comprehensive tests: a lot from pipe} {nt stdio cat16} { exec $cat16 < big | $cat16 > stdout 2> stderr list [contents stdout] [contents stderr] } "{$big} stderr16stderr16" -test winpipe-2.6 {16 bit comprehensive tests: a lot from pipe} {95} { - exec more < big | $cat16 > stdout 2> stderr +test winpipe-2.5 {16 bit comprehensive tests: a lot from pipe} {95 stdio cat16} { + exec $tcltest more < big | $cat16 > stdout 2> stderr list [contents stdout] [contents stderr] -} "{\n$big} stderr16" -test winpipe-2.7 {16 bit comprehensive tests: from console} {AllocConsole} { +} "{$big} stderr16" +test winpipe-2.6 {16 bit comprehensive tests: from console} \ + {pcOnly stdio cat16 AllocConsole} { # would block waiting for human input } {} -test winpipe-2.8 {16 bit comprehensive tests: from NUL} {nt} { +test winpipe-2.7 {16 bit comprehensive tests: from NUL} {nt stdio cat16} { exec $cat16 < nul > stdout 2> stderr list [contents stdout] [contents stderr] } "{} stderr16" -test winpipe-2.9 {16 bit comprehensive tests: from socket} { +test winpipe-2.8 {16 bit comprehensive tests: from socket} {pcOnly stdio cat16} { # doesn't work } {} -test winpipe-2.10 {16 bit comprehensive tests: from nowhere} {.console} { +test winpipe-2.9 {16 bit comprehensive tests: from nowhere} {pcOnly stdio cat16 .console} { exec $cat16 > stdout 2> stderr list [contents stdout] [contents stderr] } "{} stderr16" -test winpipe-2.11 {16 bit comprehensive tests: from file handle} { +test winpipe-2.10 {16 bit comprehensive tests: from file handle} {pcOnly stdio cat16} { 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} { +} "little stderr16" +test winpipe-2.11 {16 bit comprehensive tests: read from application} {pcOnly stdio cat16} { 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} { +} "little stderr16" +test winpipe-2.12 {16 bit comprehensive tests: a little to file} {pcOnly stdio cat16} { 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} { +} "little stderr16" +test winpipe-2.13 {16 bit comprehensive tests: a lot to file} {pcOnly stdio cat16} { 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} +} "{$big} stderr16" +test winpipe-2.14 {16 bit comprehensive tests: a little to pipe} {pcOnly stdio cat16} { + exec $cat16 < little | $tcltest 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 +} {little stderr16} +test winpipe-2.15 {16 bit comprehensive tests: a lot to pipe} {pcOnly stdio cat16} { + exec $cat16 < big | $tcltest more > stdout 2> stderr list [contents stdout] [contents stderr] -} "{\nlittle} stderr16" -test winpipe-2.17 {16 bit comprehensive tests: a lot to pipe} {nt} { - catch {exec $cat16 < big | more > stdout 2> stderr} - list [contents stdout] [contents stderr] -} "{$big\n} stderr16" -test winpipe-2.18 {16 bit comprehensive tests: a lot to pipe} {95} { - exec $cat16 < big | more > stdout 2> stderr - list [contents stdout] [contents stderr] -} "{\n$big} stderr16" -test winpipe-2.19 {16 bit comprehensive tests: to console} { +} "{$big} stderr16" +test winpipe-2.16 {16 bit comprehensive tests: to console} {pcOnly stdio cat16} { 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} { +} [lindex stderr16 0] +test winpipe-2.17 {16 bit comprehensive tests: to NUL} {nt stdio cat16} { # some apps hang when sending a large amount to NUL. cat16 isn't one. catch {exec $cat16 < big > nul} msg set msg } stderr16 -test winpipe-2.21 {16 bit comprehensive tests: to nowhere} {.console} { +test winpipe-2.18 {16 bit comprehensive tests: to nowhere} {pcOnly stdio cat16 .console} { exec $cat16 < big >&@stdout } {} -test winpipe-2.22 {16 bit comprehensive tests: to file handle} { +test winpipe-2.19 {16 bit comprehensive tests: to file handle} {pcOnly stdio cat16} { 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} { +} "little stderr16" +test winpipe-2.20 {16 bit comprehensive tests: write to application} {pcOnly stdio cat16} { set f [open "|$cat16 > stdout" w] puts -nonewline $f "foo" catch {close $f} msg list [contents stdout] $msg } "foo stderr16" -test winpipe-2.24 {16 bit comprehensive tests: read/write application} {nt} { +test winpipe-2.21 {16 bit comprehensive tests: read/write application} {nt stdio cat16} { set f [open "|$cat16" r+] puts $f $big puts $f \032 @@ -277,10 +269,10 @@ test winpipe-2.24 {16 bit comprehensive tests: read/write application} {nt} { set r [read $f 64] catch {close $f} set r -} "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -} +} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" +file delete more -test winpipe-4.1 {Tcl_WaitPid} {nt} { +test winpipe-4.1 {Tcl_WaitPid} {nt stdio} { proc readResults {f} { global x result if { [eof $f] } { @@ -309,18 +301,18 @@ catch {set env_temp $env(TEMP)} set env(TMP) c:/ set env(TEMP) c:/ -test winpipe-3.1 {TclpCreateTempFile: cleanup temp files} { +test winpipe-4.1 {TclpCreateTempFile: cleanup temp files} {pcOnly stdio} { set x {} set existing [glob -nocomplain c:/tcl*.tmp] exec $tcltest < nothing foreach p [glob -nocomplain c:/tcl*.tmp] { - if {[lsearch $existing $p] != -1} { + if {[lsearch $existing $p] == -1} { lappend x $p } } set x } {} -test winpipe-3.2 {TclpCreateTempFile: TMP and TEMP not defined} { +test winpipe-4.2 {TclpCreateTempFile: TMP and TEMP not defined} {pcOnly stdio} { set tmp $env(TMP) set temp $env(TEMP) unset env(TMP) @@ -330,14 +322,16 @@ test winpipe-3.2 {TclpCreateTempFile: TMP and TEMP not defined} { set env(TEMP) $temp set x {} } {} -test winpipe-3.3 {TclpCreateTempFile: TMP specifies non-existent directory} { +test winpipe-4.3 {TclpCreateTempFile: TMP specifies non-existent directory} \ + {pcOnly stdio} { set tmp $env(TMP) set env(TMP) snarky exec $tcltest < nothing set env(TMP) $tmp set x {} } {} -test winpipe-3.3 {TclpCreateTempFile: TEMP specifies non-existent directory} { +test winpipe-4.4 {TclpCreateTempFile: TEMP specifies non-existent directory} \ + {pcOnly stdio} { set tmp $env(TMP) set temp $env(TEMP) unset env(TMP) @@ -348,24 +342,72 @@ test winpipe-3.3 {TclpCreateTempFile: TEMP specifies non-existent directory} { set x {} } {} +test winpipe-5.1 {PipeSetupProc & PipeCheckProc: read threads} \ + {pcOnly stdio cat32} { + set f [open "|$cat32" r+] + fconfigure $f -blocking 0 + fileevent $f writable { set x writable } + set x {} + vwait x + fileevent $f writable {} + fileevent $f readable { lappend x readable } + after 100 { lappend x timeout } + vwait x + puts $f foobar + flush $f + vwait x + lappend x [read $f] + after 100 { lappend x timeout } + vwait x + lappend x [catch {close $f} msg] $msg +} {writable timeout readable {foobar +} timeout 1 stderr32} +test winpipe-5.2 {PipeSetupProc & PipeCheckProc: write threads} \ + {pcOnly stdio cat32} { + set f [open "|$cat32" r+] + fconfigure $f -blocking 0 + fileevent $f writable { set x writable } + set x {} + vwait x + puts -nonewline $f $big$big$big$big + flush $f + after 100 { lappend x timeout } + vwait x + lappend x [catch {close $f} msg] $msg +} {writable timeout 0 {}} + makeFile { puts "[list $argv0 $argv]" } echoArgs.tcl -test winpipe-4.1 {BuildCommandLine: null arguments} { +test winpipe-4.1 {BuildCommandLine: null arguments} {pcOnly stdio} { exec $tcltest echoArgs.tcl foo "" bar } {echoArgs.tcl {foo {} bar}} -test winpipe-4.1 {BuildCommandLine: null arguments} { +test winpipe-4.1 {BuildCommandLine: null arguments} {pcOnly stdio} { exec $tcltest echoArgs.tcl foo \" bar } {echoArgs.tcl {foo {"} bar}} -# restore old values fro env(TMP) and env(TEMP) +# restore old values for env(TMP) and env(TEMP) if {[catch {set env(TMP) $env_tmp}]} { - unset $env(TMP) + unset env(TMP) } if {[catch {set env(TEMP) $env_temp}]} { - unset $env(TEMP) + unset env(TEMP) } -file delete big little stdout stderr nothing dummy.tcl echoArgs.tcl +# cleanup +file delete big little stdout stderr nothing echoArgs.tcl +::tcltest::cleanupTests +return + + + + + + + + + + + diff --git a/tests/winTime.test b/tests/winTime.test new file mode 100644 index 0000000..417f4bc --- /dev/null +++ b/tests/winTime.test @@ -0,0 +1,49 @@ +# This file tests the tclWinTime.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. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: winTime.test,v 1.2 1999/04/16 00:47:37 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +# The next two tests will crash on Windows if the check for negative +# clock values is not done properly. + +test winTime-1.1 {TclpGetDate} {pcOnly} { + set ::env(TZ) JST-9 + set result [clock format -1 -format %Y] + unset ::env(TZ) + set result +} {1970} +test winTime-1.2 {TclpGetDate} {pcOnly} { + set ::env(TZ) PST8 + set result [clock format 1 -format %Y] + unset ::env(TZ) + set result +} {1969} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + |