Tcl Source Code

README -- Tcl test suite design document.

RCS: @(#) $Id: README,v 1.1.2.2 1999/03/11 18:49:22 hershey Exp $


Introduction:
-------------

This directory contains a set of validation tests for the Tcl
commands.  Each of the files whose name ends in ".test" is
intended to fully exercise one or a few Tcl commands.  The

commands tested by a given file are listed in the first line
of the file.

You can run the tests in three ways:

    (a) type "make test" in ../unix; this will run all of the tests.

    (b) type "tcltest <testFile> ?<option> <value>?






















    (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.tcl".

In all cases, 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 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.  Many thanks to
her for donating her work back to the public Tcl release.

The rest of this file provides additional information on the
features of the testing environment.


Definitions file:
-----------------
................................................................................
The file "defs.tcl" defines the "test" 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 "test"
namespace and automatically imported:

    cleanupTests dotests saveState restoreState normalizeMsg
    makeFile removeFile makeDirectory removeDirectory viewFile
    safeFetch bytestring set_iso8859_1_locale restore_locale
    setTmpDir

Please refer to the defs.tcl file for these procedures' specs.


To keep tests from polluting the current working directory with
unwanted files, you can specify a temporary directory, which will
become the current working directory for the tests, by specifying
-tmpdir on the command line or by calling the ::test::setTmpDir
procedure (after sourcing the defs.tcl file).  The default working dir
is the directory from which tcltest was called.  Please note that when
you run the test suite by calling "make test", the working dir is
<tcl8.1>/tests.


Test output:
------------

Foreach test file, 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 ::test::verbose variable.

::test::verbose can be set to any substring or permutation of "bps".


The default value of ::test::verbose is "b".  If 'b' is present, then
the entire 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 taht cause the test to
be skipped) is printed for each skipped test, otherwise no line is
printed for skipped tests.

You can set ::test::verbose either interactively (after the defs.tcl
file has been sourced) or by the command line argument -verbose, for
example:

      tcltest socket.test -verbose "psb"


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 <tcl8.1>/tests 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
directory containing this file.


Selecting tests for execution within a file:
--------------------------------------------

Normally, all the tests in a file are run whenever the file is
sourced.  Each test will be skipped if it doesn't match (using glob
sytle matching) any element in the ::test::matchingTests variable, if





it matches (using glob sytle matching) an element in
::test::skippingTests, or if one of the elements of "constraints"
turns out not to be true.


You can set ::test::matchingTests and/or ::test::skippingTests either




interactively (after the defs.tcl file has been sourced), or by the
command line arguments -match and -skip, for example:

       tcltest socket.test -match "*2.* *4.*" -skip "*2.33*"

The three constraints: notIfCompiled, knownBug, and nonPortable can be
overridden either interactively (after the defs.tcl file has been
sourced) by setting the ::test::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"

................................................................................
and adding new ones.

Adding a New Test File:
-----------------------

If the file matches the tests/*.test pattern (as it should), then it
will automatically be run by the all.tcl file.  Make sure your test
file can be run from any working dir.  Running the following should
work the same from any cwd:

	tcltest <Tcl8.1>/tests/all.tcl

Make sure no temporary files are left behind by your test file.  Your
test file should call "::test::cleanupTests" before returning.  The
::test::cleanupTests procedure prints statistics about the number of
tests that passed, skipped, and failed, and removes all files the were
created using the ::test::makeFile and ::test::makeDirectory
procedures.

Be sure your tests can run cross-platform in both the build
environment as well as the installation environment.  If your test
file contains tests that should not be run in or more of those cases,
please use the constraints mechanism described in the next section to
skip those tests.
................................................................................

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.

If your test requires that a file be created on the fly, please use
the ::test::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 ::test::makeFile procedure.  Files created by the
::test::makeFile procedure will automatically be removed by the
::test::cleanupTests call at the end of each test file.

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 defs.tcl file for a list of built-in flags.  You can add any
constraints that you need.  The following is how the defs.tcl file


adds the "unixOnly" constraint:







    set ::test::testConfig(unixOnly) [expr {$tcl_platform(platform) == "unix"}]





































































Saving keystrokes:
------------------

A convenience procedure named "::test::dotests" is included in file
"defs.tcl".  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 ::test::matching to the second argument, calls
"source" on the file specified in the first argument, and restores
::test::matching to its pre-call value at the end.


Incompatibilities with prior Tcl versions:
------------------------------------------

1) Global variables such as VERBOSE, TESTS, and testConfig are now
   renamed to use the new "test" namespace.

   old name   new name
   --------   --------
   VERBOSE    ::test::verbose
   TESTS      ::test::matchingTests
   testConfig ::test::testConfig

   The introduction of the "test" namespace is a precursor to using a
   "test" package.  This next step will be part of a future Tcl
   version.

2) VERBOSE values are no longer numeric.  Please see the section above
   on "Test output" for the new usage of the ::test::verbose variable.

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
   <tcl8.1>/tests directory.  This change allows for both unix and
   windows test suites to be run simultaneously without interference.
   All tests must now run independently of their working directory.
   You can also control the working directory from the tcltest command
   line with the -tmpdir option.

README -- Tcl test suite design document.

RCS: @(#) $Id: README,v 1.1.2.3 1999/03/23 20:06:07 hershey Exp $


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:

    (a) type "make test" in ../unix; this will run all of the tests.

    (b) type "tcltest <testFile> ?<option> <value>?
	Command line options include:

	-verbose <level>     set the level of verbosity to a substirng
			     of "bps"

	-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 onloy applies
			     when you run the test suite with the
			     "all.tcl" file.

	-constraints <list>  tests with any of the following two
			     constraints:  knownBug and nonPortable
			     that appear in <list> should not be
			     skipped.

    (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.tcl".

In all cases, 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 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.

The rest of this file provides additional information on the
features of the testing environment.


Definitions file:
-----------------
................................................................................
The file "defs.tcl" defines the "test" 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 "test"
namespace and automatically imported:

    test cleanupTests dotests saveState restoreState normalizeMsg
    makeFile removeFile makeDirectory removeDirectory viewFile
    safeFetch bytestring set_iso8859_1_locale restore_locale setTmpDir


Please refer to the defs.tcl file for documentation on these
procedures.

To keep tests from polluting the current working directory with
unwanted files, you can specify a temporary directory, which will
become the current working directory for the tests, by specifying
-tmpdir on the command line or by calling the ::tcltest::setTmpDir
procedure (after sourcing the defs.tcl file).  The default working dir
is the directory from which tcltest was called.  Please note that when
you run the test suite by calling "make test", the working dir is no
longer automatically switched to "tests".


Test output:
------------

For each test file, 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


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.


Selecting tests for execution within a file:
--------------------------------------------

Normally, all the tests in a file are run whenever the file is
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::matchingTests
       variable

    2) the "name" of the tests matches (using glob style matching) one


       or more elements in the ::tcltest::skippingTests variable


    3) the "constraints" argument to the "test" call, if given,
       contains one or more false elements.

You can set ::tcltest::matchingTests and/or ::tcltest::skippingTests either
interactively (after the defs.tcl file has been sourced), or by the
command line arguments -match and -skip, for example:

       tcltest socket.test -match "*2.* *4.*" -skip "*2.33*"

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"

................................................................................
and adding new ones.

Adding a New Test File:
-----------------------

If the file matches the tests/*.test pattern (as it should), then it
will automatically be run by the all.tcl file.  Make sure your test
file can be run from any working directory by running the following
from several different working directories:

	tcltest tests/all.tcl

Make sure no temporary files are left behind by your test file.  Your
test file should call "::tcltest::cleanupTests" before returning.  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.

Be sure your tests can run cross-platform in both the build
environment as well as the installation environment.  If your test
file contains tests that should not be run in or more of those cases,
please use the constraints mechanism described in the next section to
skip those tests.
................................................................................

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.

If your test 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.

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.


Constraints:
------------

Constraints are used to determine whether a test is run.  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.

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.

interactive	test can only be run in if the interpreter is in
		interactive mode.


knownBug	test is known to fail and the bug is not yet
                fixed.  This constraint is always true.

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 is always
                true.

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

Saving keystrokes:
------------------

A convenience procedure named "::tcltest::dotests" is included in file
"defs.tcl".  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 ::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.


Incompatibilities with prior Tcl versions:
------------------------------------------

1) Global variables such as VERBOSE, TESTS, and testConfig are now
   renamed to use the new "test" namespace.

   old name   new name
   --------   --------
   VERBOSE    ::tcltest::verbose
   TESTS      ::tcltest::matchingTests
   testConfig ::tcltest::testConfig

   The introduction of the "test" namespace is a precursor to using a
   "test" package.  This next step will be part of a future Tcl
   version.

2) VERBOSE values are no longer numeric.  Please see the section above
   on "Test output" for the new usage of the ::tcltest::verbose variable.

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.  All tests
   must now run independently of their working directory.  You can
   also control the working directory from the tcltest command line
   with the -tmpdir option.

# 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.1.2.3 1999/03/12 19:51:30 hershey Exp $

if {[lsearch ::test [namespace children]] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}
set ::test::testSingleFile false

puts stdout "Tcl 8.1 tests running in interp:  [info nameofexecutable]"
puts stdout "Tests running in working dir:  $::test::tmpDir"
if {[llength $::test::skippingTests] > 0} {
    puts stdout "Skipping tests that match:  $::test::skippingTests"
}
if {[llength $::test::matchingTests] > 0} {
    puts stdout "Only running tests that match:  $::test::matchingTests"
}

# Use command line specified glob pattern (specified by -file or -f)
# if one exists.  Otherwise use *.test (or *.tes on win32s).  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 $::test::testsDir [lindex $argv $fileIndex]]
    puts stdout "Sourcing files that match:  $globPattern"
} elseif {$tcl_platform(os) == "Win32s"} {
    set globPattern [file join $::test::testsDir *.tes]
} else {
    set globPattern [file join $::test::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]}
................................................................................
    if {[catch {source $file} msg]} {
	puts stdout $msg
    }
}

# cleanup
puts stdout "\nTests ended at [eval $timeCmd]"
::test::cleanupTests 1
return

# 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.1.2.4 1999/03/23 20:06:08 hershey 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::tmpDir"
if {[llength $::tcltest::skippingTests] > 0} {
    puts stdout "Skipping tests that match:  $::tcltest::skippingTests"
}
if {[llength $::tcltest::matchingTests] > 0} {
    puts stdout "Only running tests that match:  $::tcltest::matchingTests"
}

# 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]}
................................................................................
    if {[catch {source $file} msg]} {
	puts stdout $msg
    }
}

# cleanup
puts stdout "\nTests ended at [eval $timeCmd]"
::tcltest::cleanupTests 1
return

# 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.1.2.3 1999/03/11 18:49:23 hershey Exp $

if {[lsearch [namespace children] ::test] == -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
................................................................................
} {0 1 {can't read "x": no such variable}}

catch {unset i x result y}
catch {rename foo ""}
catch {rename check ""}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:08 hershey 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
................................................................................
} {0 1 {can't read "x": no such variable}}

catch {unset i x result y}
catch {rename foo ""}
catch {rename check ""}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:23 hershey Exp $

if {[string compare testsetassocdata [info commands testsetassocdata]] != 0} {
    puts "This application hasn't been compiled with the tests for assocData,"
    puts "therefore I am skipping all of these tests."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test assocd-1.1 {testing setting assoc data} {
   testsetassocdata a 1
} ""
test assocd-1.2 {testing setting assoc data} {
................................................................................
   testdelassocdata 123
} ""
test assocd-3.3 {testing deleting assoc data} {
   list [catch {testdelassocdata nonexistent} msg] $msg
} {0 {}}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:08 hershey Exp $

if {[string compare testsetassocdata [info commands testsetassocdata]] != 0} {
    puts "This application hasn't been compiled with the tests for assocData,"
    puts "therefore I am skipping all of these tests."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test assocd-1.1 {testing setting assoc data} {
   testsetassocdata a 1
} ""
test assocd-1.2 {testing setting assoc data} {
................................................................................
   testdelassocdata 123
} ""
test assocd-3.3 {testing deleting assoc data} {
   list [catch {testdelassocdata nonexistent} msg] $msg
} {0 {}}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:23 hershey Exp $

if {[info commands testasync] == {}} {
    puts "This application hasn't been compiled with the \"testasync\""
    puts "command, so I can't test Tcl_AsyncCreate et al."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc async1 {result code} {
    global aresult acode
    set aresult $result
    set acode $code
................................................................................
test async-3.1 {deleting handlers} {
    set x {}
    list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
} {3 del2 {0 0 0 del1 del2}}

# cleanup
testasync delete
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:09 hershey Exp $

if {[info commands testasync] == {}} {
    puts "This application hasn't been compiled with the \"testasync\""
    puts "command, so I can't test Tcl_AsyncCreate et al."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc async1 {result code} {
    global aresult acode
    set aresult $result
    set acode $code
................................................................................
test async-3.1 {deleting handlers} {
    set x {}
    list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
} {3 del2 {0 0 0 del1 del2}}

# cleanup
testasync delete
::tcltest::cleanupTests
return

# Test file for:
#   auto_mkindex
#
# This file provides example cases for testing the Tcl autoloading
# facility.  Things are much more complicated with namespaces and classes.
# The "auto_mkindex" facility can no longer be built on top of a simple
# regular expression parser.  It must recognize constructs like this:
#
#   namespace eval foo {
#       proc test {x y} { ... }
#       namespace eval bar {
#           proc another {args} { ... }
#       }
#   }
#
# Note that procedures and itcl class definitions can be nested inside
# of namespaces.
#
# Copyright (c) 1993-1998  Lucent Technologies, Inc.

# This shouldn't cause any problems
namespace import -force blt::*

# Should be able to handle "proc" definitions, even if they are
# preceded by white space.

proc normal {x y} {return [expr $x+$y]}
  proc indented {x y} {return [expr $x+$y]}

#
# Should be able to handle proc declarations within namespaces,
# even if they have explicit namespace paths.
#
namespace eval buried {
    proc inside {args} {return "inside: $args"}

    namespace export pub_*
    proc pub_one {args} {return "one: $args"}
    proc pub_two {args} {return "two: $args"}
}
proc buried::within {args} {return "within: $args"}

namespace eval buried {
    namespace eval under {
        proc neath {args} {return "neath: $args"}
    }
    namespace eval ::buried {
        proc relative {args} {return "relative: $args"}
        proc ::top {args} {return "top: $args"}
        proc ::buried::explicit {args} {return "explicit: $args"}
    }
}

#
# 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.1.2.3 1999/03/11 18:49:24 hershey Exp $

if {[lsearch [namespace children] ::test] == -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 $::test::testsDir autoMkindex.tcl]
set newMkindexFile [file join $::test::tmpDir autoMkindex.tcl]
if {![catch {file copy $origMkindexFile $newMkindexFile}]} {
    set removeAutoMkindex 1
}

test autoMkindex-1.1 {remove any existing tclIndex file} {
    file delete tclIndex
    file exists tclIndex
................................................................................
} "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two"

# cleanup
if {[info exists removeAutoMkindex]} {
    catch {file delete $newMkindexFile}
}
catch {file delete -force tclIndex}
::test::cleanupTests

#
# 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.1.2.4 1999/03/23 20:06:10 hershey 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::tmpDir autoMkindex.tcl]
if {![catch {file copy $origMkindexFile $newMkindexFile}]} {
    set removeAutoMkindex 1
}

test autoMkindex-1.1 {remove any existing tclIndex file} {
    file delete tclIndex
    file exists tclIndex
................................................................................
} "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two"

# cleanup
if {[info exists removeAutoMkindex]} {
    catch {file delete $newMkindexFile}
}
catch {file delete -force tclIndex}
::tcltest::cleanupTests

#
# 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.1.2.3 1999/03/11 18:49:24 hershey Exp $
#

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {namespace delete test_ns_basic}
catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
................................................................................
catch {namespace delete george}
catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
catch {unset x}
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:10 hershey Exp $
#

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}
catch {rename p ""}
catch {rename q ""}
................................................................................
catch {namespace delete george}
catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
catch {unset x}
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:49:25 hershey Exp $

if {[lsearch [namespace children] ::test] == -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} {
................................................................................
} {2 1 1.6}
test binary-41.8 {ScanNumber: word alignment} {nonPortable pcOnly} {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2
} {2 1 1.6}

# cleanup
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:10 hershey Exp $

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} {
................................................................................
} {2 1 1.6}
test binary-41.8 {ScanNumber: word alignment} {nonPortable pcOnly} {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2
} {2 1 1.6}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:25 hershey Exp $

if {[lsearch [namespace children] ::test] == -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}
} 1
test case-1.2 {simple pattern} {
................................................................................
    }
} {2}
test case-3.3 {single-argument form for pattern/command pairs} {
    list [catch {case z in {a 2 b}} msg] $msg
} {1 {extra case pattern with no body}}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:11 hershey Exp $

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}
} 1
test case-1.2 {simple pattern} {
................................................................................
    }
} {2}
test case-3.3 {single-argument form for pattern/command pairs} {
    list [catch {case z in {a 2 b}} msg] $msg
} {1 {extra case pattern with no body}}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:49:26 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test clock-1.1 {clock tests} {
    list [catch {clock} msg] $msg
} {1 {wrong # args: should be "clock option ?arg ...?"}}
test clock-1.2 {clock tests} {
................................................................................
} {061}
test clock-6.11 {clock roll over dates} {
    set time [clock scan "March 1, 2001" -gmt true]
    clock format $time -format %j -gmt true
} {060}

# cleanup
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:11 hershey Exp $

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
} {1 {wrong # args: should be "clock option ?arg ...?"}}
test clock-1.2 {clock tests} {
................................................................................
} {061}
test clock-6.11 {clock roll over dates} {
    set time [clock scan "March 1, 2001" -gmt true]
    clock format $time -format %j -gmt true
} {060}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.7 1999/03/11 18:49:26 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

global env
set cmdAHwd [pwd]
catch {set platform [testgetplatform]}

................................................................................
    list [catch {file readable a b} msg] $msg
} {1 {wrong # args: should be "file readable name"}}
testchmod 444 gorp.file
test cmdAH-16.2 {Tcl_FileObjCmd: readable} {
    file readable gorp.file
} 1
testchmod 333 gorp.file
test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly && !root} {
    file reada gorp.file
} 0

# 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-17.2 {Tcl_FileObjCmd: writable} {!root} {
    file writable gorp.file
} 0
testchmod 222 gorp.file
test cmdAH-17.3 {Tcl_FileObjCmd: writable} {
    file writable gorp.file
} 1

................................................................................

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-18.2 {Tcl_FileObjCmd: executable} {
    file executable gorp.file
} 0
test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix} {
    # Only on unix will setting the execute bit on a regular file
    # cause that file to be executable.   
    
    testchmod 775 gorp.file
    file exe gorp.file
} 1

test cmdAH-18.4 {Tcl_FileObjCmd: executable} {mac} {
    # On mac, the only executable files are of type APPL.

    set x [file exe gorp.file]    
    file attrib gorp.file -type APPL
    lappend x [file exe gorp.file]
} {0 1}
test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pc} {
    # On pc, must be a .exe, .com, etc.
    
    set x [file exe gorp.file]
    makeFile foo gorp.exe
    lappend x [file exe gorp.exe]
    file delete gorp.exe
    set x
................................................................................
    catch {file nativename ~nOsUcHuSeR}
} 1

# The test below has to be done in /tmp rather than the current
# directory in order to guarantee (?) a local file system:  some
# NFS file systems won't do the stuff below correctly.

if {$tcl_platform(platform) == "unix"} {
    file delete /tmp/tcl.foo.dir/file
    removeDirectory /tmp/tcl.foo.dir
    makeDirectory /tmp/tcl.foo.dir
    makeFile 12345 /tmp/tcl.foo.dir/file
    exec chmod 000 /tmp/tcl.foo.dir
    if {$user != "root"} {
	test cmdAH-19.11 {Tcl_FileObjCmd: exists} {

	    file exists /tmp/tcl.foo.dir/file
	} 0
    }
    exec chmod 775 /tmp/tcl.foo.dir
    file delete /tmp/tcl.foo.dir/file
    removeDirectory /tmp/tcl.foo.dir

}

# Stat related commands

catch {testsetplatform $platform}
file delete gorp.file
makeFile "Test string" gorp.file
catch {exec chmod 765 gorp.file}
................................................................................

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-25.2 {Tcl_FileObjCmd: owned} {
    file owned gorp.file
} 1
test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unixOnly && !root} {
    file owned /
} 0

# readlink

test cmdAH-26.1 {Tcl_FileObjCmd: readlink} {
    list [catch {file readlink a b} msg] $msg
................................................................................
    lsort [array names stat]
} {atime ctime dev gid ino mode mtime nlink size type uid}
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-28.5 {Tcl_FileObjCmd: stat} {unix} {
    catch {unset stat}
    file stat gorp.file stat
    expr $stat(mode)&0777
} {501}
test cmdAH-28.6 {Tcl_FileObjCmd: stat} {
    string tolower [list [catch {file stat _bogus_ stat} msg] \
	    $msg $errorCode]
................................................................................

    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} {pc} {
    # stat of root directory was failing.
    # don't care about answer, just that test runs.

    # relative paths that resolve to root
    set old [pwd]
    cd c:/
    file stat c: stat	    
................................................................................
    file stat . stat
    cd $old

    file stat / stat
    file stat c:/ stat
    file stat c:/. stat
} {}
test cmdAH-28.10 {Tcl_FileObjCmd: stat} {pc 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} {pc 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
................................................................................
catch {exec chmod 777 dir.file}
file delete -force dir.file
file delete gorp.file
file delete link.file

cd $cmdAHwd

::test::cleanupTests
return

#
# 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.1.2.8 1999/03/23 20:06:12 hershey Exp $

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]}

................................................................................
    list [catch {file readable a b} msg] $msg
} {1 {wrong # args: should be "file readable name"}}
testchmod 444 gorp.file
test cmdAH-16.2 {Tcl_FileObjCmd: readable} {
    file readable gorp.file
} 1
testchmod 333 gorp.file
test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly notRoot} {
    file reada gorp.file
} 0

# 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-17.2 {Tcl_FileObjCmd: writable} {notRoot} {
    file writable gorp.file
} 0
testchmod 222 gorp.file
test cmdAH-17.3 {Tcl_FileObjCmd: writable} {
    file writable gorp.file
} 1

................................................................................

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-18.2 {Tcl_FileObjCmd: executable} {
    file executable gorp.file
} 0
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.   
    
    testchmod 775 gorp.file
    file exe gorp.file
} 1

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-18.5 {Tcl_FileObjCmd: executable} {pcOnly} {
    # On pc, must be a .exe, .com, etc.
    
    set x [file exe gorp.file]
    makeFile foo gorp.exe
    lappend x [file exe gorp.exe]
    file delete gorp.exe
    set x
................................................................................
    catch {file nativename ~nOsUcHuSeR}
} 1

# The test below has to be done in /tmp rather than the current
# directory in order to guarantee (?) a local file system:  some
# NFS file systems won't do the stuff below correctly.

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



    set result [file exists /tmp/tcl.foo.dir/file]


    exec chmod 775 /tmp/tcl.foo.dir
    removeFile /tmp/tcl.foo.dir/file
    removeDirectory /tmp/tcl.foo.dir
    set result
} 0

# Stat related commands

catch {testsetplatform $platform}
file delete gorp.file
makeFile "Test string" gorp.file
catch {exec chmod 765 gorp.file}
................................................................................

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-25.2 {Tcl_FileObjCmd: owned} {
    file owned gorp.file
} 1
test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unixOnly notRoot} {
    file owned /
} 0

# readlink

test cmdAH-26.1 {Tcl_FileObjCmd: readlink} {
    list [catch {file readlink a b} msg] $msg
................................................................................
    lsort [array names stat]
} {atime ctime dev gid ino mode mtime nlink size type uid}
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-28.5 {Tcl_FileObjCmd: stat} {unixOnly} {
    catch {unset stat}
    file stat gorp.file stat
    expr $stat(mode)&0777
} {501}
test cmdAH-28.6 {Tcl_FileObjCmd: stat} {
    string tolower [list [catch {file stat _bogus_ stat} msg] \
	    $msg $errorCode]
................................................................................

    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 . 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
................................................................................
catch {exec chmod 777 dir.file}
file delete -force dir.file
file delete gorp.file
file delete link.file

cd $cmdAHwd

::tcltest::cleanupTests
return

#
# 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: cmdIL.test,v 1.1.2.4 1999/03/11 18:49:27 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test cmdIL-1.1 {Tcl_LsortObjCmd procedure} {
    list [catch {lsort} msg] $msg
} {1 {wrong # args: should be "lsort ?options? list"}}
test cmdIL-1.2 {Tcl_LsortObjCmd procedure} {
................................................................................
test cmdIL-4.22 {DictionaryCompare procedure, case} {
    lsort -dictionary {ABcd aBCd}
} {ABcd aBCd}
test cmdIL-4.23 {DictionaryCompare procedure, case} {
    lsort -dictionary {ABcd AbCd}
} {ABcd AbCd}
test cmdIL-4.24 {DictionaryCompare procedure, international characters} {hasIsoLocale} {
    ::test::set_iso8859_1_locale
    set result [lsort -dictionary "a b c A B C \xe3 \xc4"]
    ::test::restore_locale
    set result
} "A a B b C c \xe3 \xc4"
test cmdIL-4.25 {DictionaryCompare procedure, international characters} {hasIsoLocale} {
    ::test::set_iso8859_1_locale
    set result [lsort -dictionary "a23\xe3 a23\xc5 a23\xe4"]
    ::test::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 {
	set viewelem ""
................................................................................
	}
	lappend viewlist $viewelem
    }
    set viewlist
} [list "abc" "abc\\200"]

# cleanup
::test::cleanupTests
return

#
# 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: cmdIL.test,v 1.1.2.5 1999/03/23 20:06:13 hershey Exp $

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
} {1 {wrong # args: should be "lsort ?options? list"}}
test cmdIL-1.2 {Tcl_LsortObjCmd procedure} {
................................................................................
test cmdIL-4.22 {DictionaryCompare procedure, case} {
    lsort -dictionary {ABcd aBCd}
} {ABcd aBCd}
test cmdIL-4.23 {DictionaryCompare procedure, case} {
    lsort -dictionary {ABcd AbCd}
} {ABcd AbCd}
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 {
	set viewelem ""
................................................................................
	}
	lappend viewlist $viewelem
    }
    set viewlist
} [list "abc" "abc\\200"]

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:27 hershey Exp $

if {[info commands testcmdinfo] == {}} {
    puts "This application hasn't been compiled with the \"testcmdinfo\""
    puts "command, so I can't test Tcl_GetCommandInfo etc."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test cmdinfo-1.1 {command procedure and clientData} {
    testcmdinfo create x1
    testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
................................................................................
    rename cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2
    eval lappend y [testcmdtoken name $x]
} {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2}

# cleanup
catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1}
catch {rename x1 ""}
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:13 hershey Exp $

if {[info commands testcmdinfo] == {}} {
    puts "This application hasn't been compiled with the \"testcmdinfo\""
    puts "command, so I can't test Tcl_GetCommandInfo etc."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test cmdinfo-1.1 {command procedure and clientData} {
    testcmdinfo create x1
    testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
................................................................................
    rename cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2
    eval lappend y [testcmdtoken name $x]
} {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2}

# cleanup
catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1}
catch {rename x1 ""}
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:28 hershey Exp $

if {[lsearch [namespace children] ::test] == -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
................................................................................
# 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
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:14 hershey 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
................................................................................
# 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

#
# 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.1.2.2 1999/03/11 18:49:28 hershey Exp $

if {[lsearch [namespace children] ::test] == -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."
................................................................................
        set y  [expr round($x)]
    }
    p
} 3

# cleanup
unset a
::test::cleanupTests
return

#
# 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.1.2.3 1999/03/23 20:06:14 hershey 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."
................................................................................
        set y  [expr round($x)]
    }
    p
} 3

# cleanup
unset a
::tcltest::cleanupTests
return

#
# 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.1.2.2 1999/03/11 18:49:29 hershey Exp $

if {[lsearch [namespace children] ::test] == -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."
................................................................................
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}
::test::cleanupTests
return

#
# 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.1.2.3 1999/03/23 20:06:15 hershey 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."
................................................................................
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

#
# 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.1.2.4 1999/03/11 18:49:29 hershey Exp $

if {[lsearch [namespace children] ::test] == -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.

catch {rename p ""}
................................................................................

# cleanup
catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}
catch {unset y}
catch {unset a}
::test::cleanupTests
return

#
# 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.1.2.5 1999/03/23 20:06:15 hershey Exp $

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.

catch {rename p ""}
................................................................................

# cleanup
catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}
catch {unset y}
catch {unset a}
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:29 hershey Exp $

if {[lsearch [namespace children] ::test] == -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
} {a b c d e f g}
test concat-1.2 {merging lists together} {
................................................................................
    concat x y "  a b c	\n\t  " "   "  " def "
} {x y a b c def}
test concat-4.3 {pruning off extra white space sets length correctly} {
    llength [concat { {{a}} }]
} 1

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:16 hershey Exp $

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
} {a b c d e f g}
test concat-1.2 {merging lists together} {
................................................................................
    concat x y "  a b c	\n\t  " "   "  " def "
} {x y a b c def}
test concat-4.3 {pruning off extra white space sets length correctly} {
    llength [concat { {{a}} }]
} 1

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:30 hershey Exp $

if {[info commands testdcall] == {}} {
    puts "This application hasn't been compiled with the \"testdcall\""
    puts "command, so I can't test Tcl_CallWhenDeleted."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test dcall-1.1 {deletion callbacks} {
    lsort -increasing [testdcall 1 2 3]
} {1 2 3}
test dcall-1.2 {deletion callbacks} {
................................................................................
    lsort -increasing [testdcall 20 21 22 -21]
} {20 22}
test dcall-1.6 {deletion callbacks} {
    lsort -increasing [testdcall 20 21 22 -21 -22 -20]
} {}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:16 hershey Exp $

if {[info commands testdcall] == {}} {
    puts "This application hasn't been compiled with the \"testdcall\""
    puts "command, so I can't test Tcl_CallWhenDeleted."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test dcall-1.1 {deletion callbacks} {
    lsort -increasing [testdcall 1 2 3]
} {1 2 3}
test dcall-1.2 {deletion callbacks} {
................................................................................
    lsort -increasing [testdcall 20 21 22 -21]
} {20 22}
test dcall-1.6 {deletion callbacks} {
    lsort -increasing [testdcall 20 21 22 -21 -22 -20]
} {}

# cleanup
::tcltest::cleanupTests
return

# defs.tcl --
#
#	This file contains support code for the Tcl 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.1.2.2 1999/03/12 19:51:30 hershey Exp $






# Ensure that we have a minimal auto_path so we don't pick up extra junk.
set auto_path [list [info library]]


# create the "test" namespace for all testing variables and procedures
namespace eval test {
    foreach proc [list test cleanupTests dotests saveState restoreState \
	    normalizeMsg makeFile removeFile makeDirectory removeDirectory \
	    viewFile safeFetch bytestring set_iso8859_1_locale restore_locale \
	    setTmpDir] {




	namespace export $proc
    }

    # ::test::verbose defaults to "b"
    variable verbose "b"

    # matchingTests defaults to the empty list
    variable matchingTests {}

    # skippingTests defaults to the empty list
    variable skippingTests {}

    # Tests should not rely on the current working directory.
    # Files that are part of the test suite should be accessed relative to
    # ::test::testsDir.

    set originalDir [pwd]
    set tDir [file join $originalDir [file dirname [info script]]]
    cd $tDir
    variable testsDir [pwd]
    cd $originalDir

................................................................................

    variable numTestFiles 0
    variable testSingleFile true
    variable currentFailure false
    variable failFiles {}

    # Tests should remove all files they create.  The test suite will
    # check tmpDir for files created by the tests.  ::test::filesMade
    # keeps track of such files created using the test::makeFile and
    # test::makeDirectory procedures.  ::test::filesExisted stores
    # the names of pre-existing files.

    variable filesMade {}
    variable filesExisted {}

    # initialize ::test::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]
}





# 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 {}
}























































































































































































































# ::test::setTmpDir --
#
#	Set the ::test::tmpDir to the specified value.  If the path
#	is relative, make it absolute.  If the file exists but is not
#	a dir, then return an error.  If the dir does not already
#	exist, create it.  If you cannot create it, then return an error.
#
# Arguments:
#	value	the new value of ::test::tmpDir
#
# Results:
#	::test::tmpDir is set to <value> and created if it didn't already
#	exist.  The working dir is changed to ::test::tmpDir.

proc ::test::setTmpDir {value} {

    set ::test::tmpDir $value

    if {[string compare [file pathtype $::test::tmpDir] absolute] != 0} {
	set ::test::tmpDir [file join [pwd] $::test::tmpDir]
    }
    if {[file exists $::test::tmpDir]} {
	if {![file isdir $::test::tmpDir]} {
	    puts stderr "Error:  bad argument \"$value\" to -tmpdir:"
	    puts stderr "            \"$::test::tmpDir\""
	    puts stderr "        is not a directory"
	    exit
	}
    } else {
	file mkdir $::test::tmpDir
    }

    # change the working dir to tmpDir and add the existing files in
    # tmpDir to the filesExisted list.
    cd $::test::tmpDir
    foreach file [glob -nocomplain [file join [pwd] *]] {
	lappend ::test::filesExisted $file
    }
}

# ::test::processCmdLineArgs --
#
#	Use command line args to set the tmpDir, verbose, skippingTests, and
#	matchingTests variables.
#
# Arguments:
#	none
#
# Results:
#	::test::verbose is set to <value>

proc ::test::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 {
................................................................................
    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., -tmpdir == -t).


    foreach arg {-verbose -match -skip -constraints -tmpdir} {
	set abbrev [string range $arg 0 1]
	if {([info exists flag($abbrev)]) && \
		([lsearch $flagArray $arg] < [lsearch $flagArray $abbrev])} {
	    set flag($arg) $flag($abbrev)
	}
    }

    # Set ::test::tmpDir to the arg of the -tmpdir flag, if given.
    # ::test::tmpDir defaults to [pwd].
    # Save the names of files that already exist in ::test::tmpDir.
    if {[info exists flag(-tmpdir)]} {
	::test::setTmpDir $flag(-tmpdir)
    } else {
	set ::test::tmpDir [pwd]
    }
    foreach file [glob -nocomplain [file join $::test::tmpDir *]] {
	lappend ::test::filesExisted [file tail $file]
    }

    # Set ::test::verbose to the arg of the -verbose flag, if given
    if {[info exists flag(-verbose)]} {
	set ::test::verbose $flag(-verbose)
    }

    # Set ::test::matchingTests to the arg of the -match flag, if given
    if {[info exists flag(-match)]} {
	set ::test::matchingTests $flag(-match)
    }

    # Set ::test::skippingTests to the arg of the -skip flag, if given
    if {[info exists flag(-skip)]} {
	set ::test::skippingTests $flag(-skip)
    }

    # Use the -constraints flag, if given, so turn on the following
    # constraints:  notIfCompiled, knownBug, nonPortable
    if {[info exists flag(-constraints)]} {
	set constrList $flag(-constraints)
    } else {
	set constrList {}
    }
    foreach elt [list notIfCompiled knownBug nonPortable] {

	set ::test::testConfig($elt) [expr {[lsearch $constrList $elt] != -1}]
    }
    if {$::test::testConfig(nonPortable) == 0} {
	puts "(will skip non-portable tests)"
    }
}
test::processCmdLineArgs


# Check configuration information that will determine which tests
# to run.  To do this, create an array ::test::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.
#	notIfCompiled -	1 means this that it is safe to run tests that
#                       might fail if the bytecode compiler is used. This
#                       element is set to 1 if the -allComp flag was used.
#                       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.
#			You can run these tests by using the -constraint
#			command line option with "knownBug" in the argument
#			list.
#       knownBug -      The test is known to fail and the bug is not yet
#                       fixed. The test will be run only if the flag
#                       -allBuggy is used (intended for Tcl dev. group
#                       internal use only).  You can run these tests by
#			using the -constraint command line option with
#			"knownBug" in the argument list.
#	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.  You can
#			run these tests by using the -constraint command
#			line option with "nonPortable" in the argument list.
#	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.
#       hasIsoLocale  - 1 means the tests that need to switch to an iso
#                       locale can be run.
#

catch {unset ::test::testConfig}

# The following trace procedure makes it so that we can safely refer to
# non-existent members of the ::test::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 ::test::testConfig("X") is defined.

trace variable ::test::testConfig r ::test::safeFetch

proc ::test::safeFetch {n1 n2 op} {
    if {($n2 != {}) && ([info exists ::test::testConfig($n2)] == 0)} {
	set ::test::testConfig($n2) 0
    }
}

set ::test::testConfig(unixOnly) 	[expr {$tcl_platform(platform) == "unix"}]
set ::test::testConfig(macOnly) 	[expr {$tcl_platform(platform) == "macintosh"}]
set ::test::testConfig(pcOnly)		[expr {$tcl_platform(platform) == "windows"}]

set ::test::testConfig(unix)		$::test::testConfig(unixOnly)
set ::test::testConfig(mac)		$::test::testConfig(macOnly)
set ::test::testConfig(pc)		$::test::testConfig(pcOnly)

set ::test::testConfig(unixOrPc)	[expr {$::test::testConfig(unix) || $::test::testConfig(pc)}]
set ::test::testConfig(macOrPc)		[expr {$::test::testConfig(mac) || $::test::testConfig(pc)}]
set ::test::testConfig(macOrUnix)	[expr {$::test::testConfig(mac) || $::test::testConfig(unix)}]

set ::test::testConfig(nt)		[expr {$tcl_platform(os) == "Windows NT"}]
set ::test::testConfig(95)		[expr {$tcl_platform(os) == "Windows 95"}]
set ::test::testConfig(win32s)		[expr {$tcl_platform(os) == "Win32s"}]

# The following config switches are used to mark tests that should work,
# but have been temporarily disabled on certain platforms because they don't
# and we haven't gotten around to fixing the underlying problem.

set ::test::testConfig(tempNotPc) 	[expr {!$::test::testConfig(pc)}]
set ::test::testConfig(tempNotMac) 	[expr {!$::test::testConfig(mac)}]
set ::test::testConfig(tempNotUnix)	[expr {!$::test::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 ::test::testConfig(pcCrash) 	[expr {!$::test::testConfig(pc)}]
set ::test::testConfig(macCrash) 	[expr {!$::test::testConfig(mac)}]
set ::test::testConfig(unixCrash)	[expr {!$::test::testConfig(unix)}]

if {[catch {set f [open defs r]}]} {
    set ::test::testConfig(nonBlockFiles) 1
} else {
    if {[catch {fconfigure $f -blocking off}] == 0} {
	set ::test::testConfig(nonBlockFiles) 1
    } else {
	set ::test::testConfig(nonBlockFiles) 0
    }
    close $f
}

# 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 ::test::testConfig(root) 1
    }
}

# 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 ::test::testConfig(asyncPipeClose) 0
    } else {
	set ::test::testConfig(asyncPipeClose) 1
    }
} else {
    set ::test::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 ::test::testConfig(eformat) 1
if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
    set ::test::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 ::test::testConfig(unixExecs) 1
if {$tcl_platform(platform) == "macintosh"} {
    set ::test::testConfig(unixExecs) 0
}
if {($::test::testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} {
    if {[catch {exec cat defs}] == 1} {
	set ::test::testConfig(unixExecs) 0
    }
    if {($::test::testConfig(unixExecs) == 1) && ([catch {exec echo hello}] == 1)} {
	set ::test::testConfig(unixExecs) 0
    }
    if {($::test::testConfig(unixExecs) == 1) && \
		([catch {exec sh -c echo hello}] == 1)} {
	set ::test::testConfig(unixExecs) 0
    }
    if {($::test::testConfig(unixExecs) == 1) && ([catch {exec wc defs}] == 1)} {
	set ::test::testConfig(unixExecs) 0
    }
    if {$::test::testConfig(unixExecs) == 1} {
	exec echo hello > removeMe
        if {[catch {exec rm removeMe}] == 1} {
	    set ::test::testConfig(unixExecs) 0
	}
    }
    if {($::test::testConfig(unixExecs) == 1) && ([catch {exec sleep 1}] == 1)} {
	set ::test::testConfig(unixExecs) 0
    }
    if {($::test::testConfig(unixExecs) == 1) && \
		([catch {exec fgrep unixExecs defs}] == 1)} {
	set ::test::testConfig(unixExecs) 0
    }
    if {($::test::testConfig(unixExecs) == 1) && ([catch {exec ps}] == 1)} {
	set ::test::testConfig(unixExecs) 0
    }
    if {($::test::testConfig(unixExecs) == 1) && \
		([catch {exec echo abc > removeMe}] == 0) && \
		([catch {exec chmod 644 removeMe}] == 1) && \
		([catch {exec rm removeMe}] == 0)} {
	set ::test::testConfig(unixExecs) 0
    } else {
	catch {exec rm -f removeMe}
    }
    if {($::test::testConfig(unixExecs) == 1) && \
		([catch {exec mkdir removeMe}] == 1)} {
	set ::test::testConfig(unixExecs) 0
    } else {
	catch {exec rm -r removeMe}
    }
    if {$::test::testConfig(unixExecs) == 0} {
	puts "(will skip tests that depend on Unix-style executables)"
    }
}

# ::test::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 ::test::cleanupTests {{all 0}} {
    # remove files and directories created by the tests
    foreach file $::test::filesMade {
	if {[file exists $file]} {
	    catch {file delete -force $file}
	}
    }

    set tail [file tail [info script]]
    if {$all || $::test::testSingleFile} {
	# print stats
	puts -nonewline stdout "$tail:"
	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    puts -nonewline stdout "\t$index\t$::test::numTests($index)"
	}
	puts stdout ""

	# print number test files sourced
	# print names of files that ran tests which failed
	if {$all} {
	    puts stdout "Sourced $::test::numTestFiles Test Files."
	    set ::test::numTestFiles 0
	    if {[llength $::test::failFiles] > 0} {
		puts stdout "Files with failing tests: $::test::failFiles"
		set ::test::failFiles {}
	    }
	}












	# report the names of files in ::test::tmpDir that were not pre-existing.
	set currentFiles {}
	foreach file [glob -nocomplain [file join $::test::tmpDir *]] {
	    lappend currentFiles [file tail $file]
	}
	set filesNew {}
	foreach file $currentFiles {
	    if {[lsearch $::test::filesExisted $file] == -1} {
		lappend filesNew $file
	    }
	}
	if {[llength $filesNew] > 0} {
	    puts stdout "Warning: created files:\t$filesNew"
	}

	# reset filesMade, filesExisted, and numTests
	set ::test::filesMade {}
	set ::test::filesExisted $currentFiles
	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    set ::test::numTests($index) 0






	}
    } 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 ::test::numTestFiles
	if {($::test::currentFailure) && \
		([lsearch $::test::failFiles $tail] == -1)} {
	    lappend ::test::failFiles $tail
	}
	set ::test::currentFailure false
    }
}


# test --
#
# This procedure runs a test and prints an error message if the test fails.
# If ::test::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
# ::test::matchingTests variable, if it matches an element in
# ::test::skippingTests, 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 "::test::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 ::test::test {name description script expectedAnswer args} {
    incr ::test::numTests(Total)

    # skip the test if it's name matches an element of skippingTests
    foreach pattern $::test::skippingTests {
	if {[string match $pattern $name]} {
	    incr ::test::numTests(Skipped)
	    return
	}
    }
    # skip the test if it's name doesn't match any element of matchingTests
    if {[llength $::test::matchingTests] > 0} {
	set ok 0
	foreach pattern $::test::matchingTests {
	    if {[string match $pattern $name]} {
		set ok 1
		break
	    }
        }
	if {!$ok} {
	    incr ::test::numTests(Skipped)
	    return
	}
    }
    set i [llength $args]
    if {$i == 0} {
	set constraints {}
    } elseif {$i == 1} {
................................................................................
	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 
	    # $::test::testConfig(a) || $::test::testConfig(b).

 	    regsub -all {[.a-zA-Z0-9]+} $constraints {$::test::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 ::test::testConfig($constraint)]
			|| !$::test::testConfig($constraint)} {
		    set doTest 0


		    break
		}
	    }
	}
	if {$doTest == 0} {
	    incr ::test::numTests(Skipped)
	    if {[string first s $::test::verbose] != -1} {
		puts stdout "++++ $name SKIPPED: $constraints"







	    }
	    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 ::test::numTests(Failed)
	set ::test::currentFailure true
	if {[string first b $::test::verbose] == -1} {
	    set script ""
	}
	puts stdout "\n==== $name $description FAILED"
	if {$script != ""} {
	    puts stdout "==== Contents of test case:"
	    puts stdout $script
	}
................................................................................
	    }
	} else {
	    puts stdout "---- Result was:\n$actualAnswer"
	}
	puts stdout "---- Result should have been:\n$expectedAnswer"
	puts stdout "==== $name FAILED\n" 
    } else { 
	incr ::test::numTests(Passed)
	if {[string first p $::test::verbose] != -1} {
	    puts stdout "++++ $name PASSED"
	}
    }
}

proc ::test::dotests {file args} {
    set savedTests $::test::matchingTests
    set ::test::matchingTests $args
    source $file
    set ::test::matchingTests $savedTests
}

proc ::test::openfiles {} {
    if {[catch {testchannel open} result]} {
	return {}
    }
    return $result
}

proc ::test::leakfiles {old} {
    if {[catch {testchannel open} new]} {
        return {}
    }
    set leak {}
    foreach p $new {
    	if {[lsearch $old $p] < 0} {
	    lappend leak $p
	}
    }
    return $leak
}

set ::test::saveState {}

proc ::test::saveState {} {
    uplevel #0 {set ::test::saveState [list [info procs] [info vars]]}
}

proc ::test::restoreState {} {
    foreach p [info procs] {
	if {[lsearch [lindex $::test::saveState 0] $p] < 0} {
	    rename $p {}
	}
    }
    foreach p [uplevel #0 {info vars}] {
	if {[lsearch [lindex $::test::saveState 1] $p] < 0} {
	    uplevel #0 "unset $p"
	}
    }
}

proc ::test::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 ::test::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 $::test::filesMade $fullName] == -1} {
	lappend ::test::filesMade $fullName
    }
}

proc ::test::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 ::test::makeDirectory {name} {
    file mkdir $name

    set fullName [file join [pwd] $name]
    if {[lsearch $::test::filesMade $fullName] == -1} {
	lappend ::test::filesMade $fullName
    }
}

proc ::test::removeDirectory {name} {
    file delete -force $name
}

proc ::test::viewFile {name} {
    global tcl_platform
    if {($tcl_platform(platform) == "macintosh") || \
		($::test::testConfig(unixExecs) == 0)} {
	set f [open $name]
	set data [read -nonewline $f]
	close $f
	return $data
    } else {
	exec cat $name
    }
................................................................................
#    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 ::test::bytestring {string} {
    encoding convertfrom identity $string
}

# Locate tcltest executable

set tcltest [info nameofexecutable]

if {$tcltest == "{}"} {
    set tcltest {}
    puts stdout "Unable to find tcltest executable, multiple process tests will fail."
}

set ::test::testConfig(stdio) 0
if {$tcl_platform(os) != "Win32s"} {
    # Don't even try running another copy of tcltest under win32s, or you 
    # get an error dialog about multiple instances.

    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 ::test::testConfig(stdio) 1
    }
    catch {file delete -force tmp}
}

if {($tcl_platform(platform) == "windows") && ($::test::testConfig(stdio) == 0)} {
    puts stdout "(will skip tests that redirect stdio of exec'd 32-bit applications)"
}

catch {socket} msg
set ::test::testConfig(socket) [expr {$msg != "sockets are not available on this system"}]

if {$::test::testConfig(socket) == 0} {
    puts stdout "(will skip tests that use sockets)"
}

#
# Internationalization / ISO support procs     -- dl
#
if {[info commands testlocale]==""} {
    # No testlocale command, no tests...
    # (it could be that we are a sub interp and we could just load
    # the Tcltest package but that would interfere with tests
    # that tests packages/loading in slaves...)
    set ::test::testConfig(hasIsoLocale) 0
} else {
    proc ::test::set_iso8859_1_locale {} {
	set ::test::previousLocale [testlocale ctype]
	testlocale ctype $::test::isoLocale
    }

    proc ::test::restore_locale {} {
	testlocale ctype $::test::previousLocale
    }

    if {![info exists ::test::isoLocale]} {
	set ::test::isoLocale fr
        switch $tcl_platform(platform) {
	    "unix" {
		# Try some 'known' values for some platforms:
		switch -exact -- $tcl_platform(os) {
		    "FreeBSD" {
			set ::test::isoLocale fr_FR.ISO_8859-1
		    }
		    HP-UX {
			set ::test::isoLocale fr_FR.iso88591
		    }
		    Linux -
		    IRIX {
			set ::test::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 ::test::isoLocale iso_8859_1
		    }
		}
	    }
	    "windows" {
		set ::test::isoLocale French
	    }
	}
    }

    set ::test::testConfig(hasIsoLocale) \
	    [string length [::test::set_iso8859_1_locale]]
    ::test::restore_locale

    if {$::test::testConfig(hasIsoLocale) == 0} {
	puts "(will skip tests that need to set an iso8859-1 locale)"
    }







} 

























































































# Need to catch the import because it fails if defs.tcl is sourced
# more than once.
catch {namespace import ::test::*}

# 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.1.2.3 1999/03/23 20:06:16 hershey 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 "test" namespace for all testing variables and procedures
namespace eval tcltest {
    set procList [list test cleanupTests dotests saveState restoreState \
	    normalizeMsg makeFile removeFile makeDirectory removeDirectory \
	    viewFile safeFetch bytestring set_iso8859_1_locale restore_locale \
	    setTmpDir]
    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"

    # matchingTests defaults to the empty list
    variable matchingTests {}

    # skippingTests defaults to the empty list
    variable skippingTests {}

    # 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

................................................................................

    variable numTestFiles 0
    variable testSingleFile true
    variable currentFailure false
    variable failFiles {}

    # Tests should remove all files they create.  The test suite will
    # check tmpDir 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 {}

    # 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
	}
    }

    # By default, non-portable tests are skipped.
    set ::tcltest::testConfig(nonPortable) 0

    # By default, tests that expost known bugs are skipped.
    set ::tcltest::testConfig(knownBug) 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::setTmpDir --
#
#	Set the ::tcltest::tmpDir to the specified value.  If the path
#	is relative, make it absolute.  If the file exists but is not
#	a dir, then return an error.  If the dir does not already
#	exist, create it.  If you cannot create it, then return an error.
#
# Arguments:
#	value	the new value of ::tcltest::tmpDir
#
# Results:
#	::tcltest::tmpDir is set to <value> and created if it didn't already
#	exist.  The working dir is changed to ::tcltest::tmpDir.

proc ::tcltest::setTmpDir {value} {

    set ::tcltest::tmpDir $value

    if {[string compare [file pathtype $::tcltest::tmpDir] absolute] != 0} {
	set ::tcltest::tmpDir [file join [pwd] $::tcltest::tmpDir]
    }
    if {[file exists $::tcltest::tmpDir]} {
	if {![file isdir $::tcltest::tmpDir]} {
	    puts stderr "Error:  bad argument \"$value\" to -tmpdir:"
	    puts stderr "            \"$::tcltest::tmpDir\""
	    puts stderr "        is not a directory"
	    exit
	}
    } else {
	file mkdir $::tcltest::tmpDir
    }

    # change the working dir to tmpDir and add the existing files in
    # tmpDir to the filesExisted list.
    cd $::tcltest::tmpDir
    foreach file [glob -nocomplain [file join [pwd] *]] {
	lappend ::tcltest::filesExisted $file
    }
}

# ::tcltest::processCmdLineArgs --
#
#	Use command line args to set the tmpDir, verbose, skippingTests, and
#	matchingTests variables.
#
# 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 {
................................................................................
    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., -tmpdir == -t).
    # Note that -verbose cannot be abbreviated to -v in wish because it conflicts
    # with the wish option -visual.
    foreach arg {-verbose -match -skip -constraints -tmpdir} {
	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::tmpDir to the arg of the -tmpdir flag, if given.
    # ::tcltest::tmpDir defaults to [pwd].
    # Save the names of files that already exist in ::tcltest::tmpDir.
    if {[info exists flag(-tmpdir)]} {
	::tcltest::setTmpDir $flag(-tmpdir)
    } else {
	set ::tcltest::tmpDir [pwd]
    }
    foreach file [glob -nocomplain [file join $::tcltest::tmpDir *]] {
	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::matchingTests to the arg of the -match flag, if given
    if {[info exists flag(-match)]} {
	set ::tcltest::matchingTests $flag(-match)
    }

    # Set ::tcltest::skippingTests to the arg of the -skip flag, if given
    if {[info exists flag(-skip)]} {
	set ::tcltest::skippingTests $flag(-skip)
    }

    # Use the -constraints flag, if given, to turn on the following
    # constraints:  knownBug and nonPortable
    if {[info exists flag(-constraints)]} {
	set constrList $flag(-constraints)
    } else {
	set constrList {}
    }
    foreach elt [list knownBug nonPortable] {
	set ::tcltest::testConfig($elt) \
		[expr {[lsearch -exact $constrList $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}} {
    # remove files and directories created by the tests
    foreach file $::tcltest::filesMade {
	if {[file exists $file]} {
	    catch {file delete -force $file}
	}
    }

    set tail [file tail [info script]]
    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.
	if {$::tcltest::numTests(Skipped) > 0} {
	    puts stdout "Number of tests skipped for each constraint:"
	    foreach constraint [lsort [array names ::tcltest::skippedBecause]] {
		puts stdout \
			"\t$::tcltest::skippedBecause($constraint)\t$constraint"
		unset ::tcltest::skippedBecause($constraint)
	    }
	}

	# report the names of files in ::tcltest::tmpDir that were not pre-existing.
	set currentFiles {}
	foreach file [glob -nocomplain [file join $::tcltest::tmpDir *]] {
	    lappend currentFiles [file tail $file]
	}
	set filesNew {}
	foreach file $currentFiles {
	    if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
		lappend filesNew $file
	    }
	}
	if {[llength $filesNew] > 0} {
	    puts stdout "Warning: created files:\t$filesNew"
	}

	# reset filesMade, filesExisted, and numTests
	set ::tcltest::filesMade {}
	set ::tcltest::filesExisted $currentFiles
	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::matchingTests variable, if it matches an element in
# ::tcltest::skippingTests, 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 skippingTests
    foreach pattern $::tcltest::skippingTests {
	if {[string match $pattern $name]} {
	    incr ::tcltest::numTests(Skipped)
	    return
	}
    }
    # skip the test if it's name doesn't match any element of matchingTests
    if {[llength $::tcltest::matchingTests] > 0} {
	set ok 0
	foreach pattern $::tcltest::matchingTests {
	    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} {
................................................................................
	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
	}
................................................................................
	    }
	} 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"
	}
    }
}

proc ::tcltest::dotests {file args} {
    set savedTests $::tcltest::matchingTests
    set ::tcltest::matchingTests $args
    source $file
    set ::tcltest::matchingTests $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
    }
................................................................................
#    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

set tcltest [info nameofexecutable]

if {$tcltest == "{}"} {
    set tcltest {}
    puts stdout "Unable to find tcltest executable, multiple process tests will fail."
}

set ::tcltest::testConfig(stdio) 0




catch {
    catch {file delete -force tmp}
    set f [open tmp w]
    puts $f {
	exit
    }
    close $f
    # The following 2 lines cannot be run on Windows in Tk8.1b2
    # This bug is logged as a pipe bug (bugID 1495).

    if {($tcl_platform(os) != "windows") || (![info exists tk_version])} {
	set f [open "|[list $tcltest tmp]" r]
	close $f
    }
    set ::tcltest::testConfig(stdio) 1
}
catch {file delete -force tmp}






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 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
	}
	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::*}

# 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.1.2.3 1999/03/11 18:49:31 hershey Exp $

if {[info commands testdstring] == {}} {
    puts "This application hasn't been compiled with the \"testdstring\""
    puts "command, so I can't test Tcl_DStringAppend et al."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test dstring-1.1 {appending and retrieving} {
    testdstring free
    testdstring append "abc" -1
    list [testdstring get] [testdstring length]
................................................................................
    lappend result [testdstring gresult special]
    testdstring append z 1
    lappend result [testdstring get]
} {{} {This is a specially-allocated stringz}}

# cleanup
testdstring free
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:17 hershey Exp $

if {[info commands testdstring] == {}} {
    puts "This application hasn't been compiled with the \"testdstring\""
    puts "command, so I can't test Tcl_DStringAppend et al."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test dstring-1.1 {appending and retrieving} {
    testdstring free
    testdstring append "abc" -1
    list [testdstring get] [testdstring length]
................................................................................
    lappend result [testdstring gresult special]
    testdstring append z 1
    lappend result [testdstring get]
} {{} {This is a specially-allocated stringz}}

# cleanup
testdstring free
::tcltest::cleanupTests
return

#
# 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.1.2.4 1999/03/11 18:49:32 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc toutf {args} {
    global x
    lappend x "toutf $args"
}
................................................................................
test encoding-22.1 {EscapeFromUtfProc} {
} {}

# EscapeFreeProc, GetTableEncoding, unilen
# are fully tested by the rest of this file

# cleanup
::test::cleanupTests
return

#
# 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.1.2.5 1999/03/23 20:06:17 hershey 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"
}
................................................................................
test encoding-22.1 {EscapeFromUtfProc} {
} {}

# EscapeFreeProc, GetTableEncoding, unilen
# are fully tested by the rest of this file

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.4 1999/03/11 18:49:32 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

#
# These tests will run on any platform (and indeed crashed
# on the Mac).  So put them before you test for the existance
# of exec.
................................................................................
    child eval {set env(test) garbage}
    set names [array names env]
    interp delete child
    set ix [lsearch $names test]
    catch {unset env(test)}
    expr {$ix >= 0}
} {1}
#



if {[info commands exec] == ""} {
    puts "exec not implemented for this machine"
    return
}

if {$tcl_platform(os) == "Win32s"} {
    puts "Cannot run multiple copies of tcl at the same time under Win32s"
    return
}
   
set f [open printenv w]
puts $f {
    proc lrem {listname name} {
	upvar $listname list
	set i [lsearch $list $name]
	if {$i >= 0} {
	    set list [lreplace $list $i $i]
................................................................................
# ('saved' env vars)
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} {
    getenv
} {}

set env(NAME1) "test string"
test env-2.2 {adding environment variables} {
    getenv
} {NAME1=test string}

set env(NAME2) "more"
test env-2.3 {adding environment variables} {
    getenv
} {NAME1=test string
NAME2=more}

set env(XYZZY) "garbage"
test env-2.4 {adding environment variables} {
    getenv
} {NAME1=test string
NAME2=more
XYZZY=garbage}

set env(NAME2) "new value"
test env-3.1 {changing environment variables} {
    getenv


} {NAME1=test string
NAME2=new value
XYZZY=garbage}

unset env(NAME2)
test env-4.1 {unsetting environment variables} {
    getenv


} {NAME1=test string
XYZZY=garbage}
unset env(NAME1)

test env-4.2 {unsetting environment variables} {
    getenv
} {XYZZY=garbage}
unset env(XYZZY)



test env-4.3 {setting international environment variables} {
    set env(\ua7) \ub6
    getenv
} "\ua7=\ub6"
test env-4.4 {changing international environment variables} {
    set env(\ua7) \ua7
    getenv
} "\ua7=\ua7"
test env-4.5 {unsetting international environment variables} {
    set env(\ub6) \ua7
    unset env(\ua7)
    getenv
} "\ub6=\ua7"
unset env(\ub6)



# Restore the environment variables at the end of the test.

foreach name [array names env] {
    unset env($name)
}
foreach name [array names env2] {
    set env($name) $env2($name)
}

# cleanup
file delete printenv
::test::cleanupTests
return

# 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.1.2.5 1999/03/23 20:06:18 hershey Exp $

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
# on the Mac).  So put them before you test for the existance
# of exec.
................................................................................
    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] != ""}]









set f [open printenv w]
puts $f {
    proc lrem {listname name} {
	upvar $listname list
	set i [lsearch $list $name]
	if {$i >= 0} {
	    set list [lreplace $list $i $i]
................................................................................
# ('saved' env vars)
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} {execCommandExists} {
    getenv
} {}

set env(NAME1) "test string"
test env-2.2 {adding environment variables} {execCommandExists} {
    getenv
} {NAME1=test string}

set env(NAME2) "more"
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} {execCommandExists} {
    getenv
} {NAME1=test string
NAME2=more
XYZZY=garbage}

set env(NAME2) "new value"
test env-3.1 {changing environment variables} {execCommandExists} {
    set result [getenv]
    unset env(NAME2)
    set result
} {NAME1=test string
NAME2=new value
XYZZY=garbage}


test env-4.1 {unsetting environment variables} {execCommandExists} {
    set result [getenv]
    unset env(NAME1)
    set result
} {NAME1=test string
XYZZY=garbage}


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"

# Restore the environment variables at the end of the test.

foreach name [array names env] {
    unset env($name)
}
foreach name [array names env2] {
    set env($name) $env2($name)
}

# cleanup
file delete printenv
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:33 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc foo {} {
    global errorInfo
    set a [catch {format [error glorp2]} b]
    error {Human-generated}
................................................................................
test error-6.1 {catch must reset error state} {
    catch {error outer [catch {error inner inner.errorInfo inner.errorCode}]}
    list $errorCode $errorInfo
} {NONE 1}

# cleanup
catch {rename p ""}
::test::cleanupTests
return 

# 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.1.2.4 1999/03/23 20:06:18 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc foo {} {
    global errorInfo
    set a [catch {format [error glorp2]} b]
    error {Human-generated}
................................................................................
test error-6.1 {catch must reset error state} {
    catch {error outer [catch {error inner inner.errorInfo inner.errorCode}]}
    list $errorCode $errorInfo
} {NONE 1}

# cleanup
catch {rename p ""}
::tcltest::cleanupTests
return 

# 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.1.2.3 1999/03/11 18:49:33 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test eval-1.1 {single argument} {
    eval {format 22}
} 22
test eval-1.2 {multiple arguments} {
................................................................................
    invoked from within
\"eval {
	set a 1
	error \"test error\"
    }\""

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:19 hershey Exp $

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}
} 22
test eval-1.2 {multiple arguments} {
................................................................................
    invoked from within
\"eval {
	set a 1
	error \"test error\"
    }\""

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:49:34 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {testfilehandler create 0 off off}] == 0 } {
    test event-1.1 {Tcl_CreateFileHandler, reading} {
	testfilehandler close
	testfilehandler create 0 readable off
................................................................................
    } {{} readable}
}

# cleanup
foreach i [after info] {
    after cancel $i
}
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:19 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {testfilehandler create 0 off off}] == 0 } {
    test event-1.1 {Tcl_CreateFileHandler, reading} {
	testfilehandler close
	testfilehandler create 0 readable off
................................................................................
    } {{} readable}
}

# cleanup
foreach i [after info] {
    after cancel $i
}
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:34 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}


# 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 {$::test::testConfig(stdio) == 0} {
    return
}

set f [open echo w]
puts $f {
    puts -nonewline [lindex $argv 0]
    foreach str [lrange $argv 1 end] {
	puts -nonewline " $str"
    }
................................................................................
puts $f {
    exit $argv
}
close $f

# Basic operations.

test exec-1.1 {basic exec operation} {
    exec $tcltest echo a b c
} "a b c"
test exec-1.2 {pipelining} {
    exec $tcltest echo a b c d | $tcltest cat | $tcltest cat
} "a b c d"
test exec-1.3 {pipelining} {
    set a [exec $tcltest echo a b c d | $tcltest cat | $tcltest wc]
    list [scan $a "%d %d %d" b c d] $b $c
} {3 1 4}
set arg {12345678901234567890123456789012345678901234567890}
set arg "$arg$arg$arg$arg$arg$arg"
test exec-1.4 {long command lines} {
    exec $tcltest echo $arg
} $arg
set arg {}

# I/O redirection: input from Tcl command.

test exec-2.1 {redirecting input from immediate source} {
    exec $tcltest cat << "Sample text"
} {Sample text}
test exec-2.2 {redirecting input from immediate source} {
    exec << "Sample text" $tcltest cat | $tcltest cat
} {Sample text}
test exec-2.3 {redirecting input from immediate source} {
    exec $tcltest cat << "Sample text" | $tcltest cat
} {Sample text}
test exec-2.4 {redirecting input from immediate source} {
    exec $tcltest cat | $tcltest cat << "Sample text"
} {Sample text}
test exec-2.5 {redirecting input from immediate source} {
    exec $tcltest cat "<<Joined to arrows"
} {Joined to arrows}

# I/O redirection: output to file.

file delete gorp.file
test exec-3.1 {redirecting output to file} {
    exec $tcltest echo "Some simple words" > gorp.file
    exec $tcltest cat gorp.file
} "Some simple words"
test exec-3.2 {redirecting output to file} {
    exec $tcltest echo "More simple words" | >gorp.file $tcltest cat | $tcltest cat
    exec $tcltest cat gorp.file
} "More simple words"
test exec-3.3 {redirecting output to file} {
    exec > gorp.file $tcltest echo "Different simple words" | $tcltest cat | $tcltest cat
    exec $tcltest cat gorp.file
} "Different simple words"
test exec-3.4 {redirecting output to file} {
    exec $tcltest echo "Some simple words" >gorp.file
    exec $tcltest cat gorp.file
} "Some simple words"
test exec-3.5 {redirecting output to file} {
    exec $tcltest echo "First line" >gorp.file
    exec $tcltest echo "Second line" >> gorp.file
    exec $tcltest cat gorp.file
} "First line\nSecond line"
test exec-3.6 {redirecting output to file} {
    exec $tcltest echo "First line" >gorp.file
    exec $tcltest echo "Second line" >>gorp.file
    exec $tcltest cat gorp.file
} "First line\nSecond line"
test exec-3.7 {redirecting output to file} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec $tcltest echo "More text" >@ $f
    exec $tcltest echo >@$f "Even more"
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"

# I/O redirection: output and stderr to file.

file delete gorp.file
test exec-4.1 {redirecting output and stderr to file} {
    exec $tcltest echo "test output" >& gorp.file
    exec $tcltest cat gorp.file
} "test output"
test exec-4.2 {redirecting output and stderr to file} {
    list [exec $tcltest sh -c "echo foo bar 1>&2" >&gorp.file] \
	    [exec $tcltest cat gorp.file]
} {{} {foo bar}}
test exec-4.3 {redirecting output and stderr to file} {
    exec $tcltest echo "first line" > gorp.file
    list [exec $tcltest sh -c "echo foo bar 1>&2" >>&gorp.file] \
	    [exec $tcltest cat gorp.file]
} "{} {first line\nfoo bar}"
test exec-4.4 {redirecting output and stderr to file} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec $tcltest echo "More text" >&@ $f
    exec $tcltest echo >&@$f "Even more"
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"
test exec-4.5 {redirecting output and stderr to file} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec >&@ $f $tcltest sh -c "echo foo bar 1>&2"
    exec >&@$f $tcltest sh -c "echo xyzzy 1>&2"
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} "Line 1\nfoo bar\nxyzzy\nLine 3"

# I/O redirection: input from file.

exec $tcltest echo "Just a few thoughts" > gorp.file
test exec-5.1 {redirecting input from file} {
    exec $tcltest cat < gorp.file
} {Just a few thoughts}
test exec-5.2 {redirecting input from file} {
    exec $tcltest cat | $tcltest cat < gorp.file
} {Just a few thoughts}
test exec-5.3 {redirecting input from file} {
    exec $tcltest cat < gorp.file | $tcltest cat
} {Just a few thoughts}
test exec-5.4 {redirecting input from file} {
    exec < gorp.file $tcltest cat | $tcltest cat
} {Just a few thoughts}
test exec-5.5 {redirecting input from file} {
    exec $tcltest cat <gorp.file
} {Just a few thoughts}
test exec-5.6 {redirecting input from file} {
    set f [open gorp.file r]
    set result [exec $tcltest cat <@ $f]
    close $f
    set result
} {Just a few thoughts}
test exec-5.7 {redirecting input from file} {
    set f [open gorp.file r]
    set result [exec <@$f $tcltest cat]
    close $f
    set result
} {Just a few thoughts}

# I/O redirection: standard error through a pipeline.

test exec-6.1 {redirecting stderr through a pipeline} {
    exec $tcltest sh -c "echo foo bar" |& $tcltest cat
} "foo bar"
test exec-6.2 {redirecting stderr through a pipeline} {
    exec $tcltest sh -c "echo foo bar 1>&2" |& $tcltest cat
} "foo bar"
test exec-6.3 {redirecting stderr through a pipeline} {
    exec $tcltest sh -c "echo foo bar 1>&2" \
	|& $tcltest sh -c "echo second msg 1>&2 ; cat" |& $tcltest cat
} "second msg\nfoo bar"

# I/O redirection: combinations.

file delete gorp.file2
test exec-7.1 {multiple I/O redirections} {
    exec << "command input" > gorp.file2 $tcltest cat < gorp.file
    exec $tcltest cat gorp.file2
} {Just a few thoughts}
test exec-7.2 {multiple I/O redirections} {
    exec < gorp.file << "command input" $tcltest cat
} {command input}

# Long input to command and output from command.

set a "0123456789 xxxxxxxxx abcdefghi ABCDEFGHIJK\n"
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
test exec-8.1 {long input and output} {
    exec $tcltest cat << $a
} $a

# More than 20 arguments to exec.

test exec-8.1 {long input and output} {
    exec $tcltest echo 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23}

# Commands that return errors.

test exec-9.1 {commands returning errors} {
    set x [catch {exec gorp456} msg]
    list $x [string tolower $msg] [string tolower $errorCode]
} {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}}
test exec-9.2 {commands returning errors} {
    string tolower [list [catch {exec $tcltest echo foo | foo123} msg] $msg $errorCode]
} {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}}
test exec-9.3 {commands returning errors} {
    list [catch {exec $tcltest sleep 1 | $tcltest exit 43 | $tcltest sleep 1} msg] $msg
} {1 {child process exited abnormally}}
test exec-9.4 {commands returning errors} {
    list [catch {exec $tcltest exit 43 | $tcltest echo "foo bar"} msg] $msg
} {1 {foo bar
child process exited abnormally}}
test exec-9.5 {commands returning errors} {
    list [catch {exec gorp456 | $tcltest echo a b c} msg] [string tolower $msg]
} {1 {couldn't execute "gorp456": no such file or directory}}
test exec-9.6 {commands returning errors} {
    list [catch {exec $tcltest sh -c "echo error msg 1>&2"} msg] $msg
} {1 {error msg}}
test exec-9.7 {commands returning errors} {
    list [catch {exec $tcltest sh -c "echo error msg 1>&2" \
		     | $tcltest sh -c "echo error msg 1>&2"} msg] $msg
} {1 {error msg
error msg}}
test exec-9.8 {commands returning errors} {
    set f [open err w]
    puts $f {
	puts stdout out
	puts stderr err
    }
    close $f
    list [catch {exec $tcltest err} msg] $msg
} {1 {out
err}}

# Errors in executing the Tcl command, as opposed to errors in the
# processes that are invoked.

test exec-10.1 {errors in exec invocation} {
    list [catch {exec} msg] $msg
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
test exec-10.2 {errors in exec invocation} {
    list [catch {exec | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.3 {errors in exec invocation} {
    list [catch {exec cat |} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.4 {errors in exec invocation} {
    list [catch {exec cat | | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.5 {errors in exec invocation} {
    list [catch {exec cat | |& cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.6 {errors in exec invocation} {
    list [catch {exec cat |&} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.7 {errors in exec invocation} {
    list [catch {exec cat <} msg] $msg
} {1 {can't specify "<" as last word in command}}
test exec-10.8 {errors in exec invocation} {
    list [catch {exec cat >} msg] $msg
} {1 {can't specify ">" as last word in command}}
test exec-10.9 {errors in exec invocation} {
    list [catch {exec cat <<} msg] $msg
} {1 {can't specify "<<" as last word in command}}
test exec-10.10 {errors in exec invocation} {
    list [catch {exec cat >>} msg] $msg
} {1 {can't specify ">>" as last word in command}}
test exec-10.11 {errors in exec invocation} {
    list [catch {exec cat >&} msg] $msg
} {1 {can't specify ">&" as last word in command}}
test exec-10.12 {errors in exec invocation} {
    list [catch {exec cat >>&} msg] $msg
} {1 {can't specify ">>&" as last word in command}}
test exec-10.13 {errors in exec invocation} {
    list [catch {exec cat >@} msg] $msg
} {1 {can't specify ">@" as last word in command}}
test exec-10.14 {errors in exec invocation} {
    list [catch {exec cat <@} msg] $msg
} {1 {can't specify "<@" as last word in command}}
test exec-10.15 {errors in exec invocation} {
    list [catch {exec cat < a/b/c} msg] [string tolower $msg]
} {1 {couldn't read file "a/b/c": no such file or directory}}
test exec-10.16 {errors in exec invocation} {
    list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
test exec-10.17 {errors in exec invocation} {
    list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
set f [open gorp.file w]
test exec-10.18 {errors in exec invocation} {
    list [catch {exec cat <@ $f} msg] $msg
} "1 {channel \"$f\" wasn't opened for reading}"
close $f
set f [open gorp.file r]
test exec-10.19 {errors in exec invocation} {
    list [catch {exec cat >@ $f} msg] $msg
} "1 {channel \"$f\" wasn't opened for writing}"
close $f
test exec-10.20 {errors in exec invocation} {
    list [catch {exec ~non_existent_user/foo/bar} msg] $msg
} {1 {user "non_existent_user" doesn't exist}}
test exec-10.21 {errors in exec invocation} {
    list [catch {exec $tcltest true | ~xyzzy_bad_user/x | false} msg] $msg
} {1 {user "xyzzy_bad_user" doesn't exist}}

# Commands in background.

test exec-11.1 {commands in background} {
    set x [lindex [time {exec $tcltest sleep 2 &}] 0]
    expr $x<1000000
} 1
test exec-11.2 {commands in background} {
    list [catch {exec $tcltest echo a &b} msg] $msg
} {0 {a &b}}
test exec-11.3 {commands in background} {
    llength [exec $tcltest sleep 1 &]
} 1
test exec-11.4 {commands in background} {
    llength [exec $tcltest sleep 1 | $tcltest sleep 1 | $tcltest sleep 1 &]
} 3
test exec-11.5 {commands in background} {
    set f [open gorp.file w]
    puts $f { catch { exec [info nameofexecutable] echo foo & } }
    close $f
    string compare "foo" [exec $tcltest gorp.file]
} 0

# Make sure that background commands are properly reaped when
# they eventually die.

exec $tcltest sleep 3
test exec-12.1 {reaping background processes} {unixOnly nonPortable} {

    for {set i 0} {$i < 20} {incr i} {
	exec echo foo > /dev/null &
    }
    exec sleep 1
    catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg
    lindex $msg 0
} 0
test exec-12.2 {reaping background processes} {unixOnly nonPortable} {

    exec sleep 2 | sleep 2 | sleep 2 &
    catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
    set x [lindex $msg 0]
    exec sleep 3
    catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
    list $x [lindex $msg 0]
} {3 0}
test exec-12.3 {reaping background processes} {unixOnly nonPortable} {

    exec sleep 1000 &
    exec sleep 1000 &
    set x [exec ps | fgrep "sleep" | fgrep -v fgrep]
    set pids {}
    foreach i [split $x \n] {
	lappend pids [lindex $i 0]
    }
................................................................................
    }
    catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg
    list $x [lindex $msg 0]
} {2 0}

# Make sure "errorCode" is set correctly.

test exec-13.1 {setting errorCode variable} {
    list [catch {exec $tcltest cat < a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.2 {setting errorCode variable} {
    list [catch {exec $tcltest cat > a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.3 {setting errorCode variable} {
    set x [catch {exec _weird_cmd_} msg]
    list $x [string tolower $msg] [lindex $errorCode 0] \
	    [string tolower [lrange $errorCode 2 end]]
} {1 {couldn't execute "_weird_cmd_": no such file or directory} POSIX {{no such file or directory}}}

# Switches before the first argument

test exec-14.1 {-keepnewline switch} {
    exec -keepnewline $tcltest echo foo
} "foo\n"
test exec-14.2 {-keepnewline switch} {
    list [catch {exec -keepnewline} msg] $msg
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
test exec-14.3 {unknown switch} {
    list [catch {exec -gorp} msg] $msg
} {1 {bad switch "-gorp": must be -keepnewline or --}}
test exec-14.4 {-- switch} {
    list [catch {exec -- -gorp} msg] [string tolower $msg]
} {1 {couldn't execute "-gorp": no such file or directory}}

# Redirecting standard error separately from standard output

test exec-15.1 {standard error redirection} {
    exec $tcltest echo "First line" > gorp.file
    list [exec $tcltest sh -c "echo foo bar 1>&2" 2> gorp.file] \
	    [exec $tcltest cat gorp.file]
} {{} {foo bar}}
test exec-15.2 {standard error redirection} {
    list [exec $tcltest sh -c "echo foo bar 1>&2" \
		| $tcltest echo biz baz >gorp.file 2> gorp.file2] \
	    [exec $tcltest cat gorp.file] \
	    [exec $tcltest cat gorp.file2]
} {{} {biz baz} {foo bar}}
test exec-15.3 {standard error redirection} {
    list [exec $tcltest sh -c "echo foo bar 1>&2" \
	        | $tcltest echo biz baz 2>gorp.file > gorp.file2] \
	    [exec $tcltest cat gorp.file] \
	    [exec $tcltest cat gorp.file2]
} {{} {foo bar} {biz baz}}
test exec-15.4 {standard error redirection} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec $tcltest sh -c "echo foo bar 1>&2" 2>@ $f
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} {Line 1
foo bar
Line 3}
test exec-15.5 {standard error redirection} {
    exec $tcltest echo "First line" > gorp.file
    exec $tcltest sh -c "echo foo bar 1>&2" 2>> gorp.file
    exec $tcltest cat gorp.file
} {First line
foo bar}
test exec-15.6 {standard error redirection} {
    exec $tcltest sh -c "echo foo bar 1>&2" > gorp.file2 2> gorp.file \
	    >& gorp.file 2> gorp.file2 | $tcltest echo biz baz
    list [exec $tcltest cat gorp.file] [exec $tcltest cat gorp.file2]
} {{biz baz} {foo bar}}

test exec-16.1 {flush output before exec} {
    set f [open gorp.file w]
    puts $f "First line"
    exec $tcltest echo "Second line" >@ $f
    puts $f "Third line"
    close $f
    exec $tcltest cat gorp.file
} {First line
Second line
Third line}
test exec-16.2 {flush output before exec} {} {
    set f [open gorp.file w]
    puts $f "First line"
    exec $tcltest << {puts stderr {Second line}} >&@ $f > gorp.file2
    puts $f "Third line"
    close $f
    exec $tcltest cat gorp.file
} {First line
Second line
Third line}

test exec-17.1 { inheriting standard I/O } {
    set f [open script w]
    puts $f {close stdout
	set f [open gorp.file w]
	catch {exec [info nameofexecutable] echo foobar &}
	exec [info nameofexecutable] sleep 2
	close $f
    }
................................................................................
} {{foobar
}}

# cleanup
file delete script gorp.file gorp.file2
file delete echo cat wc sh sleep exit
file delete err
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:20 hershey Exp $

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]
    foreach str [lrange $argv 1 end] {
	puts -nonewline " $str"
    }
................................................................................
puts $f {
    exit $argv
}
close $f

# Basic operations.

test exec-1.1 {basic exec operation} {execCommandExists stdio} {
    exec $tcltest echo a b c
} "a b c"
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} {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} {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} {execCommandExists stdio} {
    exec $tcltest cat << "Sample text"
} {Sample text}
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} {execCommandExists stdio} {
    exec $tcltest cat << "Sample text" | $tcltest cat
} {Sample text}
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} {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} {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} {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} {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} {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} {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} {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} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec $tcltest echo "More text" >@ $f
    exec $tcltest echo >@$f "Even more"
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"

# I/O redirection: output and stderr to file.

file delete gorp.file
test exec-4.1 {redirecting output and stderr to file} {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} {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} {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} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec $tcltest echo "More text" >&@ $f
    exec $tcltest echo >&@$f "Even more"
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"
test exec-4.5 {redirecting output and stderr to file} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec >&@ $f $tcltest sh -c "echo foo bar 1>&2"
    exec >&@$f $tcltest sh -c "echo xyzzy 1>&2"
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} "Line 1\nfoo bar\nxyzzy\nLine 3"

# I/O redirection: input from file.

exec $tcltest echo "Just a few thoughts" > gorp.file
test exec-5.1 {redirecting input from file} {execCommandExists stdio} {
    exec $tcltest cat < gorp.file
} {Just a few thoughts}
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} {execCommandExists stdio} {
    exec $tcltest cat < gorp.file | $tcltest cat
} {Just a few thoughts}
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} {execCommandExists stdio} {
    exec $tcltest cat <gorp.file
} {Just a few thoughts}
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} {execCommandExists stdio} {
    set f [open gorp.file r]
    set result [exec <@$f $tcltest cat]
    close $f
    set result
} {Just a few thoughts}

# I/O redirection: standard error through a pipeline.

test exec-6.1 {redirecting stderr through a pipeline} {execCommandExists stdio} {
    exec $tcltest sh -c "echo foo bar" |& $tcltest cat
} "foo bar"
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} {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.

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} {execCommandExists stdio} {
    exec < gorp.file << "command input" $tcltest cat
} {command input}

# Long input to command and output from command.

set a "0123456789 xxxxxxxxx abcdefghi ABCDEFGHIJK\n"
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
test exec-8.1 {long input and output} {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} {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} {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} {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} {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} {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} {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} {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} {execCommandExists stdio} {
    list [catch {exec} msg] $msg
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
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} {execCommandExists stdio} {
    list [catch {exec cat |} msg] $msg
} {1 {illegal use of | or |& in command}}
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} {execCommandExists stdio} {
    list [catch {exec cat | |& cat} msg] $msg
} {1 {illegal use of | or |& in command}}
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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {execCommandExists stdio} {
    set x [lindex [time {exec $tcltest sleep 2 &}] 0]
    expr $x<1000000
} 1
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} {execCommandExists stdio} {
    llength [exec $tcltest sleep 1 &]
} 1
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} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f { catch { exec [info nameofexecutable] echo foo & } }
    close $f
    string compare "foo" [exec $tcltest gorp.file]
} 0

# Make sure that background commands are properly reaped when
# they eventually die.

exec $tcltest sleep 3
test exec-12.1 {reaping background processes} \
	{execCommandExists stdio unixOnly nonPortable} {
    for {set i 0} {$i < 20} {incr i} {
	exec echo foo > /dev/null &
    }
    exec sleep 1
    catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg
    lindex $msg 0
} 0
test exec-12.2 {reaping background processes} \
	{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]
    exec sleep 3
    catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
    list $x [lindex $msg 0]
} {3 0}
test exec-12.3 {reaping background processes} \
	{execCommandExists stdio unixOnly nonPortable} {
    exec sleep 1000 &
    exec sleep 1000 &
    set x [exec ps | fgrep "sleep" | fgrep -v fgrep]
    set pids {}
    foreach i [split $x \n] {
	lappend pids [lindex $i 0]
    }
................................................................................
    }
    catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg
    list $x [lindex $msg 0]
} {2 0}

# Make sure "errorCode" is set correctly.

test exec-13.1 {setting errorCode variable} {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} {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} {execCommandExists stdio} {
    set x [catch {exec _weird_cmd_} msg]
    list $x [string tolower $msg] [lindex $errorCode 0] \
	    [string tolower [lrange $errorCode 2 end]]
} {1 {couldn't execute "_weird_cmd_": no such file or directory} POSIX {{no such file or directory}}}

# Switches before the first argument

test exec-14.1 {-keepnewline switch} {execCommandExists stdio} {
    exec -keepnewline $tcltest echo foo
} "foo\n"
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} {execCommandExists stdio} {
    list [catch {exec -gorp} msg] $msg
} {1 {bad switch "-gorp": must be -keepnewline or --}}
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} {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} {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} {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} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec $tcltest sh -c "echo foo bar 1>&2" 2>@ $f
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} {Line 1
foo bar
Line 3}
test exec-15.5 {standard error redirection} {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} {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} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "First line"
    exec $tcltest echo "Second line" >@ $f
    puts $f "Third line"
    close $f
    exec $tcltest cat gorp.file
} {First line
Second line
Third line}
test exec-16.2 {flush output before exec} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "First line"
    exec $tcltest << {puts stderr {Second line}} >&@ $f > gorp.file2
    puts $f "Third line"
    close $f
    exec $tcltest cat gorp.file
} {First line
Second line
Third line}

test exec-17.1 { inheriting standard I/O } {execCommandExists stdio} {
    set f [open script w]
    puts $f {close stdout
	set f [open gorp.file w]
	catch {exec [info nameofexecutable] echo foobar &}
	exec [info nameofexecutable] sleep 2
	close $f
    }
................................................................................
} {{foobar
}}

# cleanup
file delete script gorp.file gorp.file2
file delete echo cat wc sh sleep exit
file delete err
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:49:35 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
................................................................................
catch {rename foo ""}
catch {rename p ""}
catch {rename {} ""}
catch {rename { } ""}
catch {unset x}
catch {unset y}
catch {unset msg}
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:20 hershey Exp $

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 ""}
catch {unset x}
catch {unset y}
................................................................................
catch {rename foo ""}
catch {rename p ""}
catch {rename {} ""}
catch {rename { } ""}
catch {unset x}
catch {unset y}
catch {unset msg}
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:35 hershey Exp $

if {[lsearch [namespace children] ::test] == -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."
................................................................................
    puts "Warning: this machine contains a defective Pentium processor"
    puts "that performs arithmetic incorrectly.  I recommend that you"
    puts "call Intel customer service immediately at 1-800-628-8686"
    puts "to request a replacement processor."
}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:21 hershey 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."
................................................................................
    puts "Warning: this machine contains a defective Pentium processor"
    puts "that performs arithmetic incorrectly.  I recommend that you"
    puts "call Intel customer service immediately at 1-800-628-8686"
    puts "to request a replacement processor."
}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:49:36 hershey Exp $

if {[lsearch [namespace children] ::test] == -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."
................................................................................
        set y  [expr round($x)]
    }
    p
} 3

# cleanup
unset a
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:21 hershey 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."
................................................................................
        set y  [expr round($x)]
    }
    p
} 3

# cleanup
unset a
::tcltest::cleanupTests
return

# This file tests the tclFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.

#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fCmd.test,v 1.1.2.5 1999/03/11 18:49:36 hershey Exp $
#

if {[string compare test [info procs test]] == 1} then {source defs}



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."
    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."
    return
}













proc createfile {file {string a}} {
    set f [open $file w]
    puts -nonewline $f $string
    close $f
    return $string
}
................................................................................
proc contents {file} {
    set f [open $file r]
    set r [read $f]
    close $f
    set r
}

set ::test::testConfig(NT) 0
set ::test::testConfig(95) 0

switch $tcl_platform(os) {
    "Windows NT" {set ::test::testConfig(NT) 1}
    "Windows 95" {set ::test::testConfig(95) 1}
}

set ::test::testConfig(fileSharing) 0
set ::test::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 ::test::testConfig(fileSharing) 1
    	set ::test::testConfig(notFileSharing) 0
    }
    file delete -force foo.dir
}

set ::test::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 ::test::testConfig(xdev) 1
	}
    }
}

set root [lindex [file split [pwd]] 0]

# A really long file name
................................................................................
set long "abcdefghihjllmnopqrstuvwxyz01234567890"
append long $long
append long $long
append long $long
append long $long
append long $long

test fCmd-1.1 {TclFileRenameCmd} {
    cleanup
    createfile tf1
    file rename tf1 tf2
    glob tf*
} {tf2}

test fCmd-2.1 {TclFileCopyCmd} {
    cleanup
    createfile tf1
    file copy tf1 tf2
    lsort [glob tf*]
} {tf1 tf2}

test fCmd-3.1 {FileCopyRename: FileForceOption fails} {
    list [catch {file rename -xyz} msg] $msg
} {1 {bad option "-xyz": should be -force or --}}
test fCmd-3.2 {FileCopyRename: not enough args} {
    list [catch {file rename xyz} msg] $msg
} {1 {wrong # args: should be "file rename ?options? source ?source ...? target"}}
test fCmd-3.3 {FileCopyRename: Tcl_TranslateFileName fails} {
    list [catch {file rename xyz ~nonexistantuser} msg] $msg
} {1 {user "nonexistantuser" doesn't exist}}
test fCmd-3.4 {FileCopyRename: Tcl_TranslateFileName passes} {
    cleanup
    list [catch {file copy tf1 ~} msg] $msg
} {1 {error copying "tf1": no such file or directory}}
test fCmd-3.5 {FileCopyRename: target doesn't exist: stat(target) != 0} {
    cleanup
    list [catch {file rename tf1 tf2 tf3} msg] $msg
} {1 {error renaming: target "tf3" is not a directory}}
test fCmd-3.6 {FileCopyRename: target tf3 is not a directory: !S_ISDIR(target)} {

    cleanup
    createfile tf3
    list [catch {file rename tf1 tf2 tf3} msg] $msg
} {1 {error renaming: target "tf3" is not a directory}}
test fCmd-3.7 {FileCopyRename: target exists & is directory} {
    cleanup
    file mkdir td1
    createfile tf1 tf1
    file rename tf1 td1
    contents [file join td1 tf1]
} {tf1}
test fCmd-3.8 {FileCopyRename: too many arguments: argc - i > 2} {
    cleanup
    list [catch {file rename tf1 tf2 tf3} msg] $msg
} {1 {error renaming: target "tf3" is not a directory}}
test fCmd-3.9 {FileCopyRename: too many arguments: argc - i > 2} {
    cleanup
    list [catch {file copy -force -- tf1 tf2 tf3} msg] $msg
} {1 {error copying: target "tf3" is not a directory}}
test fCmd-3.10 {FileCopyRename: just 2 arguments} {
    cleanup
    createfile tf1 tf1
    file rename tf1 tf2
    contents tf2
} {tf1}
test fCmd-3.11 {FileCopyRename: just 2 arguments} {
    cleanup
    createfile tf1 tf1
    file rename -force -force -- tf1 tf2
    contents tf2
} {tf1}
test fCmd-3.12 {FileCopyRename: move each source: 1 source} {
    cleanup
    createfile tf1 tf1
    file mkdir td1
    file rename tf1 td1
    contents [file join td1 tf1]
} {tf1}
test fCmd-3.13 {FileCopyRename: move each source: multiple sources} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    createfile tf3 tf3
    createfile tf4 tf4
    file mkdir td1
    file rename tf1 tf2 tf3 tf4 td1
    list [contents [file join td1 tf1]] [contents [file join td1 tf2]] \
	[contents [file join td1 tf3]] [contents [file join td1 tf4]]
} {tf1 tf2 tf3 tf4}
test fCmd-3.14 {FileCopyRename: FileBasename fails} {
    cleanup
    file mkdir td1
    list [catch {file rename ~nonexistantuser td1} msg] $msg
} {1 {user "nonexistantuser" doesn't exist}}
test fCmd-3.15 {FileCopyRename: source[0] == '\0'} {unixOrPc} {
    cleanup
    file mkdir td1
    list [catch {file rename / td1} msg] $msg
} {1 {error renaming "/" to "td1": file already exists}}
test fCmd-3.16 {FileCopyRename: break on first error} {
    cleanup
    createfile tf1 
    createfile tf2 
    createfile tf3 
    createfile tf4 
    file mkdir td1
    createfile [file join td1 tf3]
    list [catch {file rename tf1 tf2 tf3 tf4 td1} msg] $msg
} [subst {1 {error renaming "tf3" to "[file join td1 tf3]": file already exists}}]

test fCmd-4.1 {TclFileMakeDirsCmd: make each dir: 1 dir} {
    cleanup
    file mkdir td1
    glob td*
} {td1}
test fCmd-4.2 {TclFileMakeDirsCmd: make each dir: multiple dirs} {
    cleanup
    file mkdir td1 td2 td3
    lsort [glob td*]
} {td1 td2 td3}
test fCmd-4.3 {TclFileMakeDirsCmd: stops on first error} {
    cleanup
    createfile tf1
    catch {file mkdir td1 td2 tf1 td3 td4}
    glob td1 td2 tf1 td3 td4
} {td1 td2 tf1}
test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName fails} {
    cleanup
    list [catch {file mkdir ~nonexistantuser} msg] $msg
} {1 {user "nonexistantuser" doesn't exist}}
test fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\0'} {

    cleanup
    list [catch {file mkdir ""} msg] $msg
} {1 {can't create directory "": no such file or directory}}
test fCmd-4.6 {TclFileMakeDirsCmd: one level deep} {
    cleanup
    file mkdir td1
    glob td1
} {td1}
test fCmd-4.7 {TclFileMakeDirsCmd: multi levels deep} {
    cleanup
    file mkdir [file join td1 td2 td3 td4]
    glob td1 [file join td1 td2]
} "td1 [file join td1 td2]"
test fCmd-4.8 {TclFileMakeDirsCmd: already exist: lstat(target) == 0} {












    cleanup
    file mkdir td1
    set x [file exist td1]
    file mkdir td1
    list $x [file exist td1]
} {1 1}
test fCmd-4.9 {TclFileMakeDirsCmd: exists, not dir} {
    cleanup
    createfile tf1
    list [catch {file mkdir tf1} msg] $msg
} [subst {1 {can't create directory "[file join tf1]": file already exists}}]
test fCmd-4.10 {TclFileMakeDirsCmd: exists, is dir} {
    cleanup
    file mkdir td1
    set x [file exist td1]
    file mkdir td1
    list $x [file exist td1]
} {1 1}
test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {unixOnly} {

    cleanup
    file mkdir td1/td2/td3
    testchmod 000 td1/td2
    set msg [list [catch {file mkdir td1/td2/td3/td4} msg] $msg]
    testchmod 755 td1/td2
    set msg
} {1 {can't create directory "td1/td2/td3": permission denied}}
test fCmd-4.12 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {macOnly} {
    cleanup
    list [catch {file mkdir nonexistantvolume:} msg] $msg
} {1 {can't create directory "nonexistantvolume:": invalid argument}}
test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} {
    cleanup
    set x [file exist td1]
    file mkdir td1
    list $x [file exist td1]
} {0 1}
test fCmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {unixOnly} {

    cleanup
    file delete -force foo
    file mkdir foo
    file attr foo -perm 040000
    set result [list [catch {file mkdir foo/tf1} msg] $msg]
    file delete -force foo
    set result
} {1 {can't create directory "foo/tf1": permission denied}}
test fCmd-4.15 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {macOnly} {
    list [catch {file mkdir ${root}:} msg] $msg
} [subst {1 {can't create directory "${root}:": no such file or directory}}]
test fCmd-4.16 {TclFileMakeDirsCmd: TclpCreateDirectory succeeds} {
    cleanup
    file mkdir tf1
    file exists tf1
} {1}

test fCmd-5.1 {TclFileDeleteCmd: FileForceOption fails} {
    list [catch {file delete -xyz} msg] $msg
} {1 {bad option "-xyz": should be -force or --}}
test fCmd-5.2 {TclFileDeleteCmd: not enough args} {
    list [catch {file delete -force -force} msg] $msg
} {1 {wrong # args: should be "file delete ?options? file ?file ...?"}}
test fCmd-5.3 {TclFileDeleteCmd: 1 file} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    file delete tf2
    glob tf* td*
} {tf1 td1}
test fCmd-5.4 {TclFileDeleteCmd: multiple files} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    set x [list [file exist tf1] [file exist tf2] [file exist td1]]
    file delete tf1 td1 tf2
    lappend x [file exist tf1] [file exist tf2] [file exist tf3]
} {1 1 1 0 0 0}
test fCmd-5.5 {TclFileDeleteCmd: stop at first error} {unixOrPc} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    catch {file delete tf1 td1 $root tf2}
    list [file exist tf1] [file exist tf2] [file exist td1]
} {0 1 0}
test fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} {
    list [catch {file delete ~nonexistantuser} msg] $msg
} {1 {user "nonexistantuser" doesn't exist}}
test fCmd-5.7 {TclFileDeleteCmd: Tcl_TranslateFileName succeeds} {
    catch {file delete ~/tf1}
    createfile ~/tf1
    file delete ~/tf1
} {}
test fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} {
    cleanup
    set x [file exist tf1]
    file delete tf1
    list $x [file exist tf1]
} {0 0}    
test fCmd-5.9 {TclFileDeleteCmd: is directory} {
    cleanup
    file mkdir td1
    file delete td1
    file exist td1
} {0}
test fCmd-5.10 {TclFileDeleteCmd: TclpRemoveDirectory fails} {
    cleanup
    file mkdir td1/td2
    list [catch {file delete td1} msg] $msg
} {1 {error deleting "td1": directory not empty}}

test fCmd-6.1 {CopyRenameOneFile: bad source} {
    # can't test this, because it's caught by FileCopyRename
} {}
test fCmd-6.2 {CopyRenameOneFile: bad target} {
    # can't test this, because it's caught by FileCopyRename
} {}
test fCmd-6.3 {CopyRenameOneFile: lstat(source) != 0} {
    cleanup
    list [catch {file rename tf1 tf2} msg] $msg
} {1 {error renaming "tf1": no such file or directory}}
test fCmd-6.4 {CopyRenameOneFile: lstat(source) == 0} {






    cleanup
    createfile tf1
    file rename tf1 tf2
    glob tf*
} {tf2}
test fCmd-6.5 {CopyRenameOneFile: lstat(target) != 0} {
    cleanup
    createfile tf1
    file rename tf1 tf2
    glob tf*
} {tf2}
test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    createfile tf1
    set msg [list [catch {file rename tf1 td1} msg] $msg]
    testchmod 755 td1
    set msg
................................................................................
    list [catch {file rename tf1 $long} msg] $msg
} [subst {1 {error renaming "tf1" to "$long": file name too long}}]
test fCmd-6.8 {CopyRenameOneFile: errno != ENOENT} {macOnly} {
    cleanup
    createfile tf1
    list [catch {file rename tf1 $long} msg] $msg
} [subst {1 {error renaming "tf1" to "$long": file name too long}}]
test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} {unixOnly} {
    cleanup
    createfile tf1
    file rename tf1 tf2
    glob tf*
} {tf2}
test fCmd-6.10 {CopyRenameOneFile: lstat(target) == 0} {
    cleanup
    createfile tf1
    createfile tf2
    list [catch {file rename tf1 tf2} msg] $msg
} {1 {error renaming "tf1" to "tf2": file already exists}}
test fCmd-6.11 {CopyRenameOneFile: force == 0} {
    cleanup
    createfile tf1
    createfile tf2
    list [catch {file rename tf1 tf2} msg] $msg
} {1 {error renaming "tf1" to "tf2": file already exists}}
test fCmd-6.12 {CopyRenameOneFile: force != 0} {
    cleanup
    createfile tf1
    createfile tf2
    file rename -force tf1 tf2
    glob tf*
} {tf2}
test fCmd-6.13 {CopyRenameOneFile: source is dir, target is file} {
    cleanup
    file mkdir td1
    file mkdir td2
    createfile [file join td2 td1]
    list [catch {file rename -force td1 td2} msg] $msg
} [subst {1 {can't overwrite file "[file join td2 td1]" with directory "td1"}}]
test fCmd-6.14 {CopyRenameOneFile: source is file, target is dir} {
    cleanup
    createfile tf1
    file mkdir [file join td1 tf1]
    list [catch {file rename -force tf1 td1} msg] $msg
} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]
test fCmd-6.15 {CopyRenameOneFile: TclpRenameFile succeeds} {
    cleanup
    file mkdir [file join td1 td2]
    file mkdir td2
    createfile [file join td2 tf1]
    file rename -force td2 td1
    file exists [file join td1 td2 tf1]
} {1}
test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} {
    cleanup
    file mkdir [file join td1 td2]
    createfile [file join td1 td2 tf1]
    file mkdir td2
    list [catch {file rename -force td2 td1} msg] $msg
} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}]
test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} {!$::test::testConfig(win32s) || ($root == "C:/")} {
    # Don't run this test under Win32s on a drive mounted from an NT 
    # machine; it causes the NT machine to die.


    cleanup
    list [catch {file rename -force $root tf1} msg] $msg
} [subst {1 {error renaming "$root" to "tf1": trying to rename a volume or move a directory into itself}}]
test fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} {
    cleanup
    file mkdir [file join td1 td2]
    createfile [file join td1 td2 tf1]
    file mkdir td2
    list [catch {file rename -force td2 td1} msg] $msg
} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}]
test fCmd-6.19 {CopyRenameOneFile: errno == EXDEV} {unixOnly} {
    cleanup /tmp
    createfile tf1
    file rename tf1 /tmp
    glob tf* /tmp/tf1
} {/tmp/tf1}
test fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} {pcOnly} {
    catch {file delete -force c:/[email protected] d:/[email protected]}
................................................................................
	list d:/[email protected]
    } else {
	set msg [glob c:/[email protected] d:/[email protected]]
	file delete -force d:/[email protected]
	set msg
    }
} {d:/[email protected]}
test fCmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} {unixOnly} {

    cleanup /tmp
    file mkdir td1
    file rename td1 /tmp
    glob td* /tmp/td*
} {/tmp/td1}
test fCmd-6.22 {CopyRenameOneFile: copy/rename: !S_ISDIR(source)} {unixOnly} {

    cleanup /tmp
    createfile tf1
    file rename tf1 /tmp
    glob tf* /tmp/tf*
} {/tmp/tf1}
test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly xdev} {

    cleanup /tmp
    file mkdir td1/td2/td3
    exec chmod 000 td1
    set msg [list [catch {file rename td1 /tmp} msg] $msg]
    exec chmod 755 td1
    set msg 
} {1 {error renaming "td1": permission denied}}
test fCmd-6.24 {CopyRenameOneFile: error uses original name} {unixOnly} {

    cleanup
    file mkdir ~/td1/td2
    exec chmod 000 [file join [file dirname ~] [file tail ~] td1]
    set msg [list [catch {file copy ~/td1 td1} msg] $msg]
    exec chmod 755 [file join [file dirname ~] [file tail ~] td1]
    file delete -force ~/td1
    set msg
} {1 {error copying "~/td1": permission denied}}
test fCmd-6.25 {CopyRenameOneFile: error uses original name} {unixOnly} {

    cleanup
    file mkdir td2
    file mkdir ~/td1
    exec chmod 000 [file join [file dirname ~] [file tail ~] td1]
    set msg [list [catch {file copy td2 ~/td1} msg] $msg]
    exec chmod 755 [file join [file dirname ~] [file tail ~] td1]
    file delete -force ~/td1
    set msg
} {1 {error copying "td2" to "~/td1/td2": permission denied}}
test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} {unixOnly} {

    cleanup
    file mkdir ~/td1/td2
    exec chmod 000 [file join [file dirname ~] [file tail ~] td1 td2]
    set msg [list [catch {file copy ~/td1 td1} msg] $msg]
    exec chmod 755 [file join [file dirname ~] [file tail ~] td1 td2]
    file delete -force ~/td1
    set msg
} "1 {error copying \"~/td1\" to \"td1\": \"[file join [file dirname ~] [file tail ~] td1 td2]\": permission denied}"
test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly xdev} {

    cleanup /tmp
    file mkdir td1/td2/td3
    file mkdir /tmp/td1
    createfile /tmp/td1/tf1
    list [catch {file rename -force td1 /tmp} msg] $msg
} {1 {error renaming "td1" to "/tmp/td1": file already exists}}
test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly xdev} {

    cleanup /tmp
    file mkdir td1/td2/td3
    exec chmod 000 td1/td2/td3 
    set msg [list [catch {file rename td1 /tmp} msg] $msg]
    exec chmod 755 td1/td2/td3 
    set msg
} {1 {error renaming "td1" to "/tmp/td1": "td1/td2/td3": permission denied}}
test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} {unixOnly xdev} {

    cleanup /tmp
    file mkdir td1/td2/td3
    file rename td1 /tmp
    glob td* /tmp/td1/t*
} {/tmp/td1/td2}
test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} {unixOnly} {

    cleanup
    file mkdir foo/bar
    file attr foo -perm 040555
    set msg [list [catch {file rename foo/bar /tmp} msg] $msg]
    catch {file delete /tmp/bar}
    catch {file attr foo -perm 040777}
    catch {file delete -force foo}
    set msg
} {1 {can't unlink "foo/bar": permission denied}}
test fCmd-6.31 {CopyRenameOneFile: TclpDeleteFile passed} {unixOnly xdev} {

    catch {cleanup /tmp}
    file mkdir /tmp/td1
    createfile /tmp/td1/tf1
    file rename /tmp/td1/tf1 tf1
    list [file exists /tmp/td1/tf1] [file exists tf1]
} {0 1}
test fCmd-6.32 {CopyRenameOneFile: copy} {
    cleanup
    list [catch {file copy tf1 tf2} msg] $msg
} {1 {error copying "tf1": no such file or directory}}
catch {cleanup /tmp}

test fCmd-7.1 {FileForceOption: none} {
    cleanup
    file mkdir [file join tf1 tf2]
    list [catch {file delete tf1} msg] $msg
} {1 {error deleting "tf1": directory not empty}}
test fCmd-7.2 {FileForceOption: -force} {
    cleanup
    file mkdir [file join tf1 tf2]
    file delete -force tf1
} {}
test fCmd-7.3 {FileForceOption: --} {
    createfile -tf1
    file delete -- -tf1
} {}
test fCmd-7.4 {FileForceOption: bad option} {
    createfile -tf1
    set msg [list [catch {file delete -tf1} msg] $msg]
    file delete -- -tf1
    set msg
} {1 {bad option "-tf1": should be -force or --}}
test fCmd-7.5 {FileForceOption: multiple times through loop} {
    createfile --
    createfile -force
    file delete -force -force -- -- -force
    list [catch {glob -- -- -force} msg] $msg
} {1 {no files matched glob patterns "-- -force"}}

test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} {unixOnly} {

    file mkdir td1
    file attr td1 -perm 040000
    set result [list [catch {file rename ~$user td1} msg] $msg]
    file delete -force td1
    set result
} "1 {error renaming \"~$user\" to \"td1/[file tail ~$user]\": permission denied}"

test fCmd-9.1 {file rename: comprehensive: EACCES} {unixOnly} {
    cleanup
    file mkdir td1
    file mkdir td2
    file attr td2 -perm 040000
    set result [list [catch {file rename td1 td2/} msg] $msg]
    file delete -force td2
    file delete -force td1
    set result
} {1 {error renaming "td1" to "td2/td1": permission denied}}
test fCmd-9.2 {file rename: comprehensive: source doesn't exist} {
    cleanup
    list [catch {file rename tf1 tf2} msg] $msg
} {1 {error renaming "tf1": no such file or directory}}
test fCmd-9.3 {file rename: comprehensive: file to new name} {
    cleanup
    createfile tf1
    createfile tf2
    testchmod 444 tf2
    file rename tf1 tf3
    file rename tf2 tf4
    list [lsort [glob tf*]] [file writable tf3] [file writable tf4]
} {{tf3 tf4} 1 0}    
test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc} {
    cleanup
    file mkdir td1 td2
    testchmod 555 td2
    file rename td1 td3
    file rename td2 td4
    list [lsort [glob td*]] [file writable td3] [file writable td4]
} {{td3 td4} 1 0}    
test fCmd-9.5 {file rename: comprehensive: file to self} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testchmod 444 tf2
    file rename -force tf1 tf1
    file rename -force tf2 tf2
    list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2]
} {tf1 tf2 1 0}    
test fCmd-9.6 {file rename: comprehensive: dir to self} {unixOrPc} {
    cleanup
    file mkdir td1
    file mkdir td2
    testchmod 555 td2
    file rename -force td1 .
    file rename -force td2 .
    list [lsort [glob td*]] [file writable td1] [file writable td2]
} {{td1 td2} 1 0}    
test fCmd-9.7 {file rename: comprehensive: file to existing file} {
    cleanup
    createfile tf1
    createfile tf2
    createfile tfs1
    createfile tfs2
    createfile tfs3
    createfile tfs4
................................................................................
    set msg [list [catch {file rename tf1 tf2} msg] $msg]
    file rename -force tfs1 tfd1
    file rename -force tfs2 tfd2
    file rename -force tfs3 tfd3
    file rename -force tfs4 tfd4
    list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] 
} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0}
test fCmd-9.8 {file rename: comprehensive: dir to empty dir} {
    # Under unix, you can rename a read-only directory, but you can't
    # move it into another directory.

    cleanup
    file mkdir td1
    file mkdir [file join td2 td1]
    file mkdir tds1
................................................................................
    } else {
	set w3 0
	set w4 0
    }
    list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \
    [file writable [file join tdd2 tds2]] $w3 $w4
} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}]
test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} {
    cleanup
    file mkdir tds1
    file mkdir tds2
    file mkdir [file join tdd1 tds1 xxx]
    file mkdir [file join tdd2 tds2 xxx]
    if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {
	testchmod 555 tds2
................................................................................
    if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {
	set w2 [file writable tds2]
    } else {
	set w2 0
    }
    list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2
} [subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}]
test fCmd-9.10 {file rename: comprehensive: file to new name and dir} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    testchmod 444 tf2
    file rename tf1 [file join td1 tf3]
    file rename tf2 [file join td1 tf4]
    list [catch {glob tf*}] [lsort [glob [file join td1 t*]]] \
    [file writable [file join td1 tf3]] [file writable [file join td1 tf4]]
} [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}]
test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} {
    cleanup
    file mkdir td1
    file mkdir td2
    file mkdir td3
    if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {
	testchmod 555 td2
    }
................................................................................
	set w4 [file writable [file join td3 td4]]
    } else {
        set w4 0
    }
    list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \
    [file writable [file join td3 td3]] $w4
} [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}]
test fCmd-9.12 {file rename: comprehensive: target exists} {
    cleanup
    file mkdir [file join td1 td2] [file join td2 td1]
    if {$tcl_platform(platform) != "macintosh"} {
    	testchmod 555 [file join td2 td1]
    }
    file mkdir [file join td3 td4] [file join td4 td3]
    file rename -force td3 td4
................................................................................
    set msg [list [file exists td3] [file exists [file join td4 td3 td4]] \
    [catch {file rename td1 td2} msg] $msg]
    if {$tcl_platform(platform) != "macintosh"} {
    	testchmod 755 [file join td2 td1]
    }
    set msg
} [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}]
test fCmd-9.13 {file rename: comprehensive: can't overwrite target} {
    cleanup
    file mkdir [file join td1 td2] [file join td2 td1 td4]
    list [catch {file rename -force td1 td2} msg] $msg
} [subst {1 {error renaming "td1" to "[file join td2 td1]": file already exists}}]
test fCmd-9.14 {file rename: comprehensive: dir into self} {
    cleanup
    file mkdir td1
    list [glob td*] [list [catch {file rename td1 td1} msg] $msg]
} [subst {td1 {1 {error renaming "td1" to "[file join td1 td1]": trying to rename a volume or move a directory into itself}}}]
test fCmd-9.15 {file rename: comprehensive: source and target incompatible} {

    cleanup
    file mkdir td1
    createfile tf1
    list [catch {file rename -force td1 tf1} msg] $msg
} {1 {can't overwrite file "tf1" with directory "td1"}}
test fCmd-9.16 {file rename: comprehensive: source and target incompatible} {

    cleanup
    file mkdir td1/tf1
    createfile tf1
    list [catch {file rename -force tf1 td1} msg] $msg
} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]

test fCmd-10.1 {file copy: comprehensive: source doesn't exist} {
    cleanup
    list [catch {file copy tf1 tf2} msg] $msg
} {1 {error copying "tf1": no such file or directory}}
test fCmd-10.2 {file copy: comprehensive: file to new name} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testchmod 444 tf2
    file copy tf1 tf3
    file copy tf2 tf4
    list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4]
} {{tf1 tf2 tf3 tf4} tf1 tf2 1 0}
test fCmd-10.3 {file copy: comprehensive: dir to new name} {unixOrPc} {
    cleanup
    file mkdir [file join td1 tdx]
    file mkdir [file join td2 tdy]
    testchmod 555 td2
    file copy td1 td3
    file copy td2 td4
    set msg [list [lsort [glob td*]] [glob [file join td3 t*]] \
................................................................................
	    [glob [file join td4 t*]] [file writable td3] [file writable td4]]
    if {$tcl_platform(platform) != "macintosh"} {
    	testchmod 755 td2
    	testchmod 755 td4
    }
    set msg
} [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0}]
test fCmd-10.4 {file copy: comprehensive: file to existing file} {
    cleanup
    createfile tf1
    createfile tf2
    createfile tfs1
    createfile tfs2
    createfile tfs3
    createfile tfs4
................................................................................
    set msg [list [catch {file copy tf1 tf2} msg] $msg]
    file copy -force tfs1 tfd1
    file copy -force tfs2 tfd2
    file copy -force tfs3 tfd3
    file copy -force tfs4 tfd4
    list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] 
} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0}
test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {
    cleanup
    file mkdir td1
    file mkdir [file join td2 td1]
    file mkdir tds1
    file mkdir tds2
    file mkdir tds3
    file mkdir tds4
................................................................................
    set a1 [list [catch {file copy td1 td2} msg] $msg]
    set a2 [list [catch {file copy -force tds1 tdd1} msg] $msg]
    set a3 [catch {file copy -force tds2 tdd2}]
    set a4 [catch {file copy -force tds3 tdd3}]
    set a5 [catch {file copy -force tds4 tdd4}]
    list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 
} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}]
test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} {unixOrPc} {

    cleanup
    file mkdir tds1
    file mkdir tds2
    file mkdir [file join tdd1 tds1 xxx]
    file mkdir [file join tdd2 tds2 xxx]
    testchmod 555 tds2
    set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg]
    set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg]
    list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2]
} [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}]
test fCmd-10.7 {file rename: comprehensive: file to new name and dir} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    testchmod 444 tf2
    file copy tf1 [file join td1 tf3]
    file copy tf2 [file join td1 tf4]
    list [lsort [glob tf*]] [lsort [glob [file join td1 t*]]] \
    [file writable [file join td1 tf3]] [file writable [file join td1 tf4]]
} [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}]
test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} {unixOrPc} {

    cleanup
    file mkdir td1
    file mkdir td2
    file mkdir td3
    testchmod 555 td2
    file copy td1 [file join td3 td3]
    file copy td2 [file join td3 td4]
    list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \
    [file writable [file join td3 td3]] [file writable [file join td3 td4]]
} [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}]
test fCmd-10.9 {file copy: comprehensive: source and target incompatible} {

    cleanup
    file mkdir td1
    createfile tf1
    list [catch {file copy -force td1 tf1} msg] $msg
} {1 {can't overwrite file "tf1" with directory "td1"}}
test fCmd-10.10 {file copy: comprehensive: source and target incompatible} {

    cleanup
    file mkdir [file join td1 tf1]
    createfile tf1
    list [catch {file copy -force tf1 td1} msg] $msg
} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]
cleanup    

# old tests    

test fCmd-11.1 {TclFileRenameCmd: -- option } {
    catch {file delete -force -- -tfa1}
    set s [createfile -tfa1]
    file rename -- -tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && ![file exists -tfa1]]
    file delete tfa2
    set result
} {1}

test fCmd-11.2 {TclFileRenameCmd: bad option } {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]
    set r1 [catch {file rename -x tfa1 tfa2}]
    set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]]
    file delete tfa1
    set result
} {1}

test fCmd-11.3 {TclFileRenameCmd: bad \# args} {
    catch {file rename -- }
} {1}

test fCmd-11.4 {TclFileRenameCmd: target filename translation failing} {
     global env
     set temp $env(HOME)
     unset env(HOME)
     set result [catch {file rename tfa ~/foobar }]
     set env(HOME) $temp
     set result
 } {1}

test fCmd-11.5 {TclFileRenameCmd: more than one source and target is not a directory} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
    createfile tfa1 
    createfile tfa2 
    createfile tfa3 
    set result [catch {file rename tfa1 tfa2 tfa3}]
    file delete tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-11.6 {TclFileRenameCmd: : single file into directory  } {
    catch {file delete -force -- tfa1 tfad}
    set s [createfile tfa1]
    file mkdir tfad
    file rename tfa1 tfad
    set result [expr [checkcontent tfad/tfa1 $s] && ![file exists tfa1]]
    file delete -force tfad
    set result
} {1}

test fCmd-11.7 {TclFileRenameCmd: : multiple files into directory  } {
    catch {file delete -force -- tfa1 tfa2 tfad}
    set s1 [createfile tfa1 ]
    set s2 [createfile tfa2 ]
    file mkdir tfad
    file rename tfa1 tfa2 tfad
    set r1 [checkcontent tfad/tfa1 $s1]
    set r2 [checkcontent tfad/tfa2 $s2]
................................................................................
    
    set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfa2]]
	    
    file delete -force tfad
    set result
} {1}

test fCmd-11.8 {TclFileRenameCmd: error renaming file to directory } {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfa $s]
    set r3 [file isdir tfad]
................................................................................
    file delete -force tfa tfad
    set result
} {1}

#
# Coverage tests for renamefile() ;
#
test fCmd-12.1 {renamefile: source filename translation failing} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set result [catch {file rename ~/tfa1 tfa2}]
    set env(HOME) $temp
    set result
} {1}

test fCmd-12.2 {renamefile: src filename translation failing} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set s [createfile tfa1]
    file mkdir tfad
    set result [catch {file rename tfa1 ~/tfa2 tfad}]
    set env(HOME) $temp
    file delete -force tfad
    set result
} {1}

test fCmd-12.3 {renamefile: stat failing on source} {
    catch {file delete -force -- tfa1 tfa2}
    set r1 [catch {file rename tfa1 tfa2}]
    expr {$r1 && ![file exists tfa1] && ![file exists tfa2]}
} {1}

test fCmd-12.4 {renamefile: error renaming file to directory } {
    catch {file delete -force -- tfa tfad}
    set s1 [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfa $s1]
    set r3 [file isdir tfad/tfa]
    set result [expr $r1 && $r2 && $r3]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-12.5 {renamefile: error renaming directory to file } {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa
    file mkdir tfad
    set s [createfile tfad/tfa]
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfad/tfa $s]
    set r3 [file isdir tfad]
    set r4 [file isdir tfa]
    set result [expr $r1 && $r2 && $r3 && $r4 ]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-12.6 {renamefile: TclRenameFile succeeding } {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    file rename tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && ![file exists tfa1]]
    file delete tfa2
    set result
} {1}

test fCmd-12.7 {renamefile: renaming directory into offspring} {
    catch {file delete -force -- tfad}
    file mkdir tfad
    file mkdir tfad/dir
    set result [catch {file rename tfad tfad/dir}]
    file delete -force tfad 
    set result
} {1}

test fCmd-12.8 {renamefile: generic error } {unixOnly} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/dir
    exec chmod 555 tfa
    set result [catch {file rename tfa/dir tfa2}]
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}


test fCmd-12.9 {renamefile: moving a file across volumes } {unixOnly} {
    catch {file delete -force -- tfa /tmp/tfa}
    set s [createfile tfa ]
    file rename tfa /tmp
    set result [expr [checkcontent /tmp/tfa $s] && ![file exists tfa]]
    file delete /tmp/tfa
    set result
} {1}

test fCmd-12.10 {renamefile: moving a directory across volumes } {unixOnly} {

    catch {file delete -force -- tfad /tmp/tfad}
    file mkdir tfad
    set s [createfile tfad/a ]
    file rename tfad /tmp
    set restul [expr [checkcontent /tmp/tfad/a $s] && ![file exists tfad]]
    file delete -force /tmp/tfad
    set result
} {1}

#
# Coverage tests for TclCopyFilesCmd()
#
test fCmd-13.1 {TclCopyFilesCmd: -force option } {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]
    file copy -force  tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-13.2 {TclCopyFilesCmd: -- option } {
    catch {file delete -force -- tfa1}
    set s [createfile -tfa1]
    file copy --  -tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] &&  [checkcontent -tfa1 $s]]
    file delete -- -tfa1 tfa2
    set result
} {1}

test fCmd-13.3 {TclCopyFilesCmd: bad option } {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]
    set r1 [catch {file copy -x tfa1 tfa2}]
    set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]]
    file delete tfa1
    set result
} {1}

test fCmd-13.4 {TclCopyFilesCmd: bad \# args} {
    catch {file copy -- }
} {1}

test fCmd-13.5 {TclCopyFilesCmd: target filename translation failing} {
     global env
     set temp $env(HOME)
    unset env(HOME)
     set result [catch {file copy tfa ~/foobar }]
     set env(HOME) $temp
     set result
 } {1}

test fCmd-13.6 {TclCopyFilesCmd: more than one source and target is not a directory} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
    createfile tfa1 
    createfile tfa2 
    createfile tfa3 
    set result [catch {file copy tfa1 tfa2 tfa3}]
    file delete tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-13.7 {TclCopyFilesCmd: : single file into directory  } {
    catch {file delete -force -- tfa1 tfad}
    set s [createfile tfa1]
    file mkdir tfad
    file copy tfa1 tfad
    set result [expr [checkcontent tfad/tfa1 $s] &&  [checkcontent tfa1 $s]]
    file delete -force tfad tfa1
    set result
} {1}

test fCmd-13.8 {TclCopyFilesCmd: : multiple files into directory  } {
    catch {file delete -force -- tfa1 tfa2 tfad}
    set s1 [createfile tfa1 ]
    set s2 [createfile tfa2 ]
    file mkdir tfad
    file copy tfa1 tfa2 tfad
    set r1 [checkcontent tfad/tfa1 $s1]
    set r2 [checkcontent tfad/tfa2 $s2]
................................................................................
    set r4 [checkcontent tfa2 $s2]
    set result [expr $r1 && $r2 && $r3 && $r4 ]
	    
    file delete -force tfad tfa1 tfa2
    set result
} {1}

test fCmd-13.9 {TclCopyFilesCmd: error copying file to directory } {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file copy tfa tfad}]
    set r2 [expr [checkcontent tfa $s] && [file isdir tfad/tfa]]
    set r3 [file isdir tfad]
................................................................................
    file delete -force tfa tfad
    set result
} {1}

#
# Coverage tests for copyfile()
# 
test fCmd-14.1 {copyfile: source filename translation failing} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set result [catch {file copy ~/tfa1 tfa2}]
    set env(HOME) $temp
    set result
} {1}

test fCmd-14.2 {copyfile: dst filename translation failing} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set s [createfile tfa1]
    file mkdir tfad
    set r1 [catch {file copy tfa1 ~/tfa2 tfad}]
    set result [expr $r1 && [checkcontent tfad/tfa1 $s]]
    set env(HOME) $temp
    file delete -force tfa1 tfad
    set result
} {1}

test fCmd-14.3 {copyfile: stat failing on source} {
    catch {file delete -force -- tfa1 tfa2}
    set r1 [catch {file copy tfa1 tfa2}]
    expr $r1 && ![file exists tfa1] && ![file exists tfa2]
} {1}

test fCmd-14.4 {copyfile: error copying file to directory } {
    catch {file delete -force -- tfa tfad}
    set s1 [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file copy tfa tfad}]
    set r2 [checkcontent tfa $s1]
    set r3 [file isdir tfad]
    set r4 [file isdir tfad/tfa]
    set result [expr $r1 && $r2 && $r3 && $r4 ]
    file delete -force tfa tfad
    set result
} {1}

 test fCmd-14.5 {copyfile: error copying directory to file } {
     catch {file delete -force -- tfa tfad}
     file mkdir tfa
     file mkdir tfad
     set s [createfile tfad/tfa]
     set r1 [catch {file copy tfa tfad}]
     set r2 [checkcontent tfad/tfa $s]
     set r3 [file isdir tfad]
     set r4 [file isdir tfa]
     set result [expr $r1 && $r2 && $r3 && $r4 ]
     file delete -force tfa tfad
     set result
} {1}

test fCmd-14.6 {copyfile: copy file succeeding } {
    catch {file delete -force -- tfa tfa2}
    set s [createfile tfa]
    file copy tfa tfa2
    set result [expr  [checkcontent tfa $s] && [checkcontent tfa2 $s]]
    file delete tfa tfa2
    set result
} {1}

test fCmd-14.7 {copyfile: copy directory succeeding } {
    catch {file delete -force -- tfa tfa2}
    file mkdir tfa
    set s [createfile tfa/file]
    file copy tfa tfa2
    set result [expr [checkcontent tfa/file $s] && [checkcontent tfa2/file $s]]
    file delete -force tfa tfa2
    set result
} {1}

test fCmd-14.8 {copyfile: copy directory failing } {unixOnly} {
    catch {file delete -force -- tfa}
    file mkdir tfa/dir/a/b/c
    exec chmod 000 tfa/dir
    set r1 [catch {file copy tfa tfa2}]
    exec chmod 777 tfa/dir
    set result $r1
    file delete -force tfa tfa2
    set result
} {1}

#
# Coverage tests for TclMkdirCmd()
#
test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} {
    global env
    set temp $env(HOME)
    unset env(HOME) 
    set result [catch {file mkdir ~/tfa}]
    set env(HOME) $temp
    set result
} {1}
#
# Can Tcl_SplitPath return argc == 0? If so them we need a
# test for that code.
#
test fCmd-15.2 {TclMakeDirsCmd - one directory } {
    catch {file delete -force -- tfa}
    file mkdir tfa
    set result [file isdirectory tfa]
    file delete tfa
    set result
} {1}

test fCmd-15.3 {TclMakeDirsCmd: - two directories } {
    catch {file delete -force -- tfa1 tfa2}
    file mkdir tfa1 tfa2
    set result [expr [file isdirectory tfa1] && [file isdirectory tfa2]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-15.4 {TclMakeDirsCmd - stat failing } {unixOnly} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/file
    exec chmod 000 tfa
    set result [catch {file mkdir tfa/file}]
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}

test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep } {

    catch {file delete -force -- tfa}
    file mkdir tfa/a/b/c
    set result [file isdir tfa/a/b/c]
    file delete -force tfa
    set result
} {1}

    
test fCmd-15.6 {TclMakeDirsCmd: - trying to overwrite a file } {
    catch {file delete -force -- tfa}
    set s [createfile tfa]
    set r1 [catch {file mkdir tfa}]
    set r2 [file isdir tfa]
    set r3 [file exists tfa]
    set result [expr $r1 && !$r2 && $r3 && [checkcontent tfa $s]]
    file delete tfa
    set result
} {1}

test fCmd-15.7 {TclMakeDirsCmd - making several directories } {
    catch {file delete -force -- tfa1 tfa2}
    file mkdir tfa1 tfa2/a/b/c
    set result [expr [file isdir tfa1] && [file isdir tfa2/a/b/c]]
    file delete -force tfa1 tfa2
    set result
} {1}

test fCmd-15.8 {TclFileMakeDirsCmd: trying to create an existing dir} {
    file mkdir tfa
    file mkdir tfa
    set result [file isdir tfa]
    file delete tfa
    set result
} {1}


# Coverage tests for TclDeleteFilesCommand()
test fCmd-16.1 { test the -- argument } {
    catch {file delete -force -- tfa}
    createfile tfa
    file delete -- tfa
    file exists tfa
} {0}

test fCmd-16.2 { test the -force and -- arguments } {
    catch {file delete -force -- tfa}
    createfile tfa
    file delete -force -- tfa
    file exists tfa
} {0}

test fCmd-16.3 { test bad option } {
    catch {file delete -force -- tfa}
    createfile tfa
    set result [catch {file delete -dog tfa}]
    file delete tfa
    set result
} {1}

test fCmd-16.4 { test not enough args } {
    catch {file delete}
} {1}

test fCmd-16.5 { test not enough args with options } {
    catch {file delete --}
} {1}

test fCmd-16.6 {delete: source filename translation failing} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set result [catch {file delete ~/tfa}]
    set env(HOME) $temp
    set result
} {1}

test fCmd-16.7 {remove a non-empty directory without -force } {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/a
    set result [catch  {file delete tfa }]
    file delete -force tfa
    set result
} {1}

test fCmd-16.8 {remove a normal file } {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/a
    set result [catch  {file delete tfa }]
    file delete -force tfa
    set result
} {1}

test fCmd-16.9 {error while deleting file } {unixOnly} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/a
    exec chmod 555 tfa
    set result [catch  {file delete tfa/a }]
    #######
    #######  If any directory in a tree that is being removed does not 
................................................................................
    #######  This is also the case with "rm -rf"
    #######
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}

test fCmd-16.10 {deleting multiple files } {
    catch {file delete -force -- tfa1 tfa2}
    createfile tfa1
    createfile tfa2
    file delete tfa1 tfa2
    expr ![file exists tfa1] && ![file exists tfa2]
} {1}

test fCmd-16.11 { TclFileDeleteCmd: removing a nonexistant file} {
    catch {file delete -force -- tfa}
    file delete tfa
    set result 1
} {1}

# More coverage tests for mkpath()
 test fCmd-17.1 {mkdir stat failing on target but not ENOENT } {unixOnly} {
     catch {file delete -force -- tfa1}
     file mkdir tfa1
     exec chmod 555 tfa1
     set result [catch {file mkdir tfa1/tfa2}]
     exec chmod 777 tfa1
     file delete -force tfa1
     set result
} {1}

test fCmd-17.2 {mkdir several levels deep - relative } {
    catch {file delete -force -- tfa}
    file mkdir tfa/a/b
    set result [file isdir tfa/a/b ]
    file delete tfa/a/b tfa/a tfa
    set result
} {1}

test fCmd-17.3 {mkdir several levels deep - absolute } {
    catch {file delete -force -- tfa}
    set f [file join [pwd] tfa a ]
    file mkdir $f
    set result [file isdir $f ]
    file delete $f [file join [pwd] tfa]
    set result
} {1}

#
# Functionality tests for TclFileRenameCmd()
#

test fCmd-18.1 {TclFileRenameCmd: rename (first form) in the same directory} {

    catch {file delete -force -- tfad}
    file mkdir tfad/dir
    cd tfad/dir
    set s [createfile foo ]
    file rename  foo bar
    file rename bar ./foo
    file rename ./foo bar
................................................................................
    file rename foo [file join [pwd] bar]
    set result [expr [checkcontent bar $s] && ![file exists foo]]
    cd ../..
    file delete -force tfad
    set result
} {1}

test fCmd-18.2 {TclFileRenameCmd: single dir to nonexistant } {
    catch {file delete -force -- tfa1 tfa2}
    file mkdir tfa1
    file rename tfa1 tfa2
    set result [expr [file exists tfa2] && ![file exists tfa1]]
    file delete tfa2
    set result
} {1}

test fCmd-18.3 {TclFileRenameCmd: mixed dirs and files into directory  } {
    catch {file delete -force -- tfa1 tfad1 tfad2}
    set s [createfile tfa1 ]
    file mkdir tfad1 tfad2
    file rename tfa1 tfad1 tfad2
    set r1 [checkcontent  tfad2/tfa1 $s]
    set r2 [file isdir tfad2/tfad1]
    set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfad1]]
    file delete tfad2/tfa1
    file delete -force tfad2
    set result
} {1}

test fCmd-18.4 {TclFileRenameCmd: attempt to replace non-dir with dir } {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad
    set r1 [catch {file rename tfad tfa}]
    set r2 [checkcontent tfa $s]
    set r3 [file isdir tfad]
    set result [expr $r1 && $r2 && $r3 ]
    file delete tfa tfad
    set result
} {1}

test fCmd-18.5 {TclFileRenameCmd: attempt to replace dir with non-dir } {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfa $s]
    set r3 [file isdir tfad/tfa]
    set result [expr $r1 && $r2 && $r3 ]
................................................................................
    file delete -force  tfa tfad
    set result
} {1}

#
# On Windows there is no easy way to determine if two files are the same
#
test fCmd-18.6 {TclFileRenameCmd: rename a file to itself} {macOrUnix}  {
    catch {file delete -force -- tfa}
    set s [createfile tfa]
    set r1 [catch {file rename tfa tfa}]
    set result [expr $r1 && [checkcontent tfa $s]]
    file delete tfa
    set result
} {1}

test fCmd-18.7 {TclFileRenameCmd: rename dir on top of another empty dir w/o -force} {

    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set result [expr $r1 && [file isdir tfa]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-18.8 {TclFileRenameCmd: rename dir on top of another empty dir w/ -force} {

    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa
    file rename -force tfa tfad
    set result [expr ![file isdir tfa]]
    file delete -force tfad
    set result
} {1}

test fCmd-18.9 {TclFileRenameCmd: rename dir on top of a non-empty dir w/o -force} {

    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa/file
    set r1 [catch {file rename tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} {

    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa/file
    set r1 [catch {file rename -force tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-18.11 {TclFileRenameCmd: rename a non-existant file} {
    catch {file delete -force -- tfa1}
    set r1 [catch {file rename tfa1 tfa2}]
    set result [expr $r1 && ![file exists tfa1] && ![file exists tfa2]]
} {1}

test fCmd-18.12 {TclFileRenameCmd : rename a symbolic link to file} {unixOnly} {

    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    set s [createfile tfa1]
    exec ln -s tfa1 tfa2
    file rename tfa2 tfa3
    set t [file type tfa3]
    set result [expr { $t == "link" }]
    file delete tfa1 tfa3
    set result
} {1}

test fCmd-18.13 {TclFileRenameCmd : rename a symbolic link to dir} {unixOnly} {

    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    file mkdir tfa1
    exec ln -s tfa1 tfa2
    file rename tfa2 tfa3
    set t [file type tfa3]
    set result [expr { $t == "link" }]
    file delete tfa1 tfa3
    set result
} {1}

test fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} {unixOnly} {

    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    file mkdir tfa1/a/b/c/d
    file mkdir tfa2
    set f [file join [pwd] tfa1/a/b] 
    set f2 [file join [pwd] {tfa2/b alias}]
    exec ln -s $f $f2
................................................................................
    set r1 [file isdir tfa3]
    set r2 [file exists tfa1/a/b/c]
    set result [expr $r1 && !$r2]
    file delete -force tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-18.15 {TclFileRenameCmd : rename a file to a symlink dir} {unixOnly} {

    catch {file delete -force -- tfa1 tfa2 tfalink}
	
    file mkdir tfa1
    set s [createfile tfa2]
    exec ln -s tfa1 tfalink

    file rename tfa2 tfalink
    set result [checkcontent tfa1/tfa2 $s ]
    file delete -force tfa1 tfalink
    set result
} {1}

test fCmd-18.16 {TclFileRenameCmd : rename a dangling symlink} {unixOnly} {
    catch {file delete -force -- tfa1 tfalink}
	
    file mkdir tfa1
    exec ln -s tfa1 tfalink
    file delete tfa1 
    file rename tfalink tfa2
    set result [expr [string compare [file type tfa2] "link"] == 0]
................................................................................
    set result
} {1}


#
# Coverage tests for TclUnixRmdir
#
test fCmd-19.1 { remove empty directory } {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file delete tfa
    file exists tfa
} {0}

test fCmd-19.2 { rmdir error besides EEXIST} {unixOnly} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    exec chmod 555 tfa
    set result [catch {file delete tfa/a}]
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}

test fCmd-19.3 { recursive remove } {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    file delete -force tfa
    file exists tfa
} {0}

................................................................................
#
#

#
# Coverage tests for TraverseUnixTree(), called from TclDeleteFilesCmd
#

test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } {unixOnly} {

    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    exec chmod 000 tfa/a
    set result [catch {file delete -force tfa}]
    exec chmod 777 tfa/a
    file delete -force tfa
................................................................................
    set result
} {1}


#
# Feature testing for TclCopyFilesCmd
# 
test fCmd-21.1 {copy : single file to nonexistant } {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    file copy tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-21.2 {copy : single dir to nonexistant } {
    catch {file delete -force -- tfa1 tfa2}
    file mkdir tfa1
    file copy tfa1 tfa2
    set result [expr [file isdir tfa2] && [file isdir tfa1]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-21.3 {copy : single file into directory  } {
    catch {file delete -force -- tfa1 tfad}
    set s [createfile tfa1]
    file mkdir tfad
    file copy tfa1 tfad
    set result [expr [checkcontent tfad/tfa1 $s] && [checkcontent tfa1 $s]]
    file delete -force tfa1 tfad
    set result
} {1}

test fCmd-21.4 {copy : more than one source and target is not a directory} {

    catch {file delete -force -- tfa1 tfa2 tfa3}
    createfile tfa1 
    createfile tfa2 
    createfile tfa3 
    set result [catch {file copy tfa1 tfa2 tfa3}]
    file delete tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-21.5 {copy : multiple files into directory  } {
    catch {file delete -force -- tfa1 tfa2 tfad}
    set s1 [createfile tfa1 ]
    set s2 [createfile tfa2 ]
    file mkdir tfad
    file copy tfa1 tfa2 tfad
    set r1 [checkcontent tfad/tfa1 $s1]
    set r2 [checkcontent tfad/tfa2 $s2]
................................................................................
    set r3 [checkcontent tfa1 $s1]
    set r4 [checkcontent tfa2 $s2]
    set result [expr $r1 && $r2 && $r3 && $r4]
    file delete -force tfa1 tfa2 tfad
    set result
} {1}

test fCmd-21.6 {copy : mixed dirs and files into directory  } {notFileSharing} {

    catch {file delete -force -- tfa1 tfad1 tfad2}
    set s [createfile tfa1 ]
    file mkdir tfad1 tfad2
    file copy tfa1 tfad1 tfad2
    set r1 [checkcontent [file join tfad2 tfa1] $s]
    set r2 [file isdir [file join tfad2 tfad1]]
    set r3 [checkcontent tfa1 $s]
    set result [expr $r1 && $r2 && $r3 && [file isdir tfad1]]
    file delete -force tfa1 tfad1 tfad2
    set result
} {1}

test fCmd-21.7 {TclCopyFilesCmd : copy a dangling link } {unixOnly} {
    file mkdir tfad1
    exec ln -s tfad1 tfalink
    file delete tfad1
    file copy tfalink tfalink2
    set result [string match [file type tfalink2] link]
    file delete tfalink tfalink2 
    set result
} {1}

test fCmd-21.8 {TclCopyFilesCmd : copy a link } {unixOnly} {
    file mkdir tfad1
    exec ln -s tfad1 tfalink
    file copy tfalink tfalink2
    set r1 [file type tfalink]
    set r2 [file type tfalink2]
    set r3 [file isdir tfad1]
    set result [expr {("$r1" == "link" ) && ("$r2" == "link" ) && $r3}]
    file delete tfad1 tfalink tfalink2
    set result
} {1}

test fCmd-21.9 {TclCopyFilesCmd : copy dir with a link in it } {unixOnly} {
    file mkdir tfad1
    exec ln -s "[pwd]/tfad1" tfad1/tfalink
    file copy tfad1 tfad2
    set result [string match [file type tfad2/tfalink] link]
    file delete -force tfad1 tfad2
    set result
} {1}

test fCmd-21.10 {TclFileCopyCmd: copy dir on top of another empty dir w/o -force} {

    catch {file delete -force -- tfa tfad}
    file mkdir tfa [file join tfad tfa]
    set r1 [catch {file copy tfa tfad}]
    set result [expr $r1 && [file isdir tfa]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-21.11 {TclFileCopyCmd: copy dir on top of a dir w/o -force} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa [file join tfad tfa file]
    set r1 [catch {file copy tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-21.12 {TclFileCopyCmd: copy dir on top of a non-empty dir w/ -force} {

    catch {file delete -force -- tfa tfad}
    file mkdir tfa [file join tfad tfa file]
    set r1 [catch {file copy -force tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]]
    file delete -force tfa tfad
    set result
} {1}
   
#
# Coverage testing for TclpRenameFile
#
test fCmd-22.1 { TclpRenameFile : rename and overwrite in a single dir } {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    set s2 [createfile tfa2 q]
	
    set r1 [catch {rename tfa1 tfa2}]
    file rename -force tfa1 tfa2
    set result [expr $r1 && [checkcontent tfa2 $s]]
    file delete [glob tfa1 tfa2]
    set result
} {1}

test fCmd-22.2 { TclpRenameFile : attempt to overwrite itself } {macOrUnix} {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]	
    file rename -force tfa1 tfa1
    set result [checkcontent tfa1 $s]
    file delete tfa1 
    set result
} {1}

test fCmd-22.3 { TclpRenameFile : rename dir to existing dir } {
    catch {file delete -force -- d1 tfad}
    file mkdir d1 [file join tfad d1]
    set r1 [catch {file rename d1 tfad}]
    set result [expr $r1 && [file isdir d1] && [file isdir [file join tfad d1]]]
    file delete -force d1 tfad
    set result
} {1}

test fCmd-22.4 { TclpRenameFile : rename dir to dir several levels deep } {
    catch {file delete -force -- d1 tfad}
    file mkdir d1 [file join tfad a b c]
    file rename d1 [file join tfad a b c d1]
    set result [expr ![file isdir d1] && [file isdir [file join tfad a b c d1]]]
    file delete -force [glob d1 tfad]
    set result
} {1}


#
# TclMacCopyFile needs to be redone.
#
test fCmd-22.5 { TclMacCopyFile : copy and overwrite in a single dir } {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    set s2 [createfile tfa2 q]

    set r1 [catch {file copy tfa1 tfa2}]
    file copy -force tfa1 tfa2
    set result [expr $r1 && [checkcontent tfa2 $s] && [checkcontent tfa1 $s]]
................................................................................
#

#
# TclMacRmdir
# Error cases are not covered.
#

test fCmd-23.1 { TclMacRmdir : trying to remove a nonempty directory } {
    catch {file delete -force -- tfad}
	
    file mkdir [file join tfad dir]
	
    set result [catch {file delete tfad}]
    file delete -force tfad 
    set result
} {1}

#
# TclMacDeleteFile	
# Error cases are not covered.
#
test fCmd-24.1 { TclMacDeleteFile : deleting a normal file } {
    catch {file delete -force -- tfa1}
	
    createfile tfa1
    file delete tfa1
    file exists tfa1
} {0}

#
# TclMacCopyDirectory
# Error cases are not covered.
#
test fCmd-25.1 { TclMacCopyDirectory : copying a normal directory} {notFileSharing} {

    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir [file join tfad1 a b c]
    file copy tfad1 tfad2
    set result [expr [file isdir [file join tfad1 a b c]] && [file isdir [file join tfad2 a b c]]]
    file delete -force tfad1 tfad2
    set result
} {1}

test fCmd-25.2 { TclMacCopyDirectory : copying a short path normal directory} {notFileSharing} {

    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    file copy tfad1 tfad2
    set result [expr [file isdir tfad1] && [file isdir tfad2]]
    file delete tfad1 tfad2
    set result
} {1}

test fCmd-25.3 { TclMacCopyDirectory : copying dirs between different dirs} {notFileSharing} {

    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir [file join tfad1 x y z]
    file mkdir [file join tfad2 dir]
    file copy tfad1 [file join tfad2 dir]
    set result [expr [file isdir [file join tfad1 x y z]] && [file isdir [file join tfad2 dir tfad1 x y z]]]
    file delete -force tfad1 tfad2
................................................................................
    set result
} {1}

#
# Functionality tests for TclDeleteFilesCmd
#

test fCmd-26.1 { TclDeleteFilesCmd : delete symlink} {unixOnly} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    exec ln -s tfad1 tfalink
    file delete tfalink

    set r1 [file isdir tfad1]
................................................................................
    set r2 [file exists tfalink]
    
    set result [expr $r1 && !$r2]
    file delete tfad1
    set result
} {1}

test fCmd-26.2 { TclDeleteFilesCmd : delete dir with symlink} {unixOnly} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    file mkdir tfad2
    exec ln -s tfad1 [file join tfad2 link]
    file delete -force tfad2

................................................................................
    set r2 [file exists tfad2]
    
    set result [expr $r1 && !$r2]
    file delete tfad1
    set result
} {1}

test fCmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    exec ln -s tfad1 tfad2
    file delete tfad1
    file delete tfad2

................................................................................
test fCmd-27.4 {TclFileAttrsCmd - getting one option} {
    catch {file delete -force -- foo.tmp}
    createfile foo.tmp
    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lindex $attrs 0]}] [file delete -force -- foo.tmp]
} {0 {}}

set ::test::testConfig(tclGroup) 0
if {($tcl_platform(platform) == "macintosh") \
	|| ($tcl_platform(platform) == "windows")} {
    set ::test::testConfig(tclGroup) 1
} elseif {[catch {exec {groups}} groupList] == 0} {
    if {[lsearch $groupList tcl] != -1} {
	set ::test::testConfig(tclGroup) 1

    }


}

test fCmd-27.5 {TclFileAttrsCmd - setting one option} {tclGroup} {
    catch {file delete -force -- foo.tmp}
    createfile foo.tmp
    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lrange $attrs 0 1]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}
test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {tclGroup} {
    catch {file delete -force -- foo.tmp}
    createfile foo.tmp
    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}

# cleanup
cleanup
::test::cleanupTests
return

# This file tests the tclFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# 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.1.2.6 1999/03/23 20:06:22 hershey Exp $
#

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."
    return
}

set platform [testgetplatform]







if {"[info commands testchmod]" != "testchmod"} {
    puts "Skipping fCmd tests. This application does not seem to have the"
    puts "testchmod command that is needed to run these tests."
    return
}

# 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
    close $f
    return $string
}
................................................................................
proc contents {file} {
    set f [open $file r]
    set r [read $f]
    close $f
    set r
}









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 ::tcltest::testConfig(fileSharing) 1
    	set ::tcltest::testConfig(notFileSharing) 0
    }
    file delete -force foo.dir
}

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 ::tcltest::testConfig(xdev) 1
	}
    }
}

set root [lindex [file split [pwd]] 0]

# A really long file name
................................................................................
set long "abcdefghihjllmnopqrstuvwxyz01234567890"
append long $long
append long $long
append long $long
append long $long
append long $long

test fCmd-1.1 {TclFileRenameCmd} {notRoot} {
    cleanup
    createfile tf1
    file rename tf1 tf2
    glob tf*
} {tf2}

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} {notRoot} {
    list [catch {file rename -xyz} msg] $msg
} {1 {bad option "-xyz": should be -force or --}}
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} {notRoot} {
    list [catch {file rename xyz ~nonexistantuser} msg] $msg
} {1 {user "nonexistantuser" doesn't exist}}
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} {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 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} {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} {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} {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} {notRoot} {
    cleanup
    createfile tf1 tf1
    file rename tf1 tf2
    contents tf2
} {tf1}
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} {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} {notRoot} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    createfile tf3 tf3
    createfile tf4 tf4
    file mkdir td1
    file rename tf1 tf2 tf3 tf4 td1
    list [contents [file join td1 tf1]] [contents [file join td1 tf2]] \
	[contents [file join td1 tf3]] [contents [file join td1 tf4]]
} {tf1 tf2 tf3 tf4}
test fCmd-3.14 {FileCopyRename: FileBasename fails} {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'} {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} {notRoot} {
    cleanup
    createfile tf1 
    createfile tf2 
    createfile tf3 
    createfile tf4 
    file mkdir td1
    createfile [file join td1 tf3]
    list [catch {file rename tf1 tf2 tf3 tf4 td1} msg] $msg
} [subst {1 {error renaming "tf3" to "[file join td1 tf3]": file already exists}}]

test fCmd-4.1 {TclFileMakeDirsCmd: make each dir: 1 dir} {notRoot} {
    cleanup
    file mkdir td1
    glob td*
} {td1}
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} {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} {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'} \
	{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} {notRoot} {
    cleanup
    file mkdir td1
    glob td1
} {td1}
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} {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} {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} {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 notRoot} {
    cleanup
    file mkdir td1/td2/td3
    testchmod 000 td1/td2
    set msg [list [catch {file mkdir td1/td2/td3/td4} msg] $msg]
    testchmod 755 td1/td2
    set msg
} {1 {can't create directory "td1/td2/td3": permission denied}}
test fCmd-4.12 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {macOnly} {
    cleanup
    list [catch {file mkdir nonexistantvolume:} msg] $msg
} {1 {can't create directory "nonexistantvolume:": invalid argument}}
test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} {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 notRoot} {
    cleanup
    file delete -force foo
    file mkdir foo
    file attr foo -perm 040000
    set result [list [catch {file mkdir foo/tf1} msg] $msg]
    file delete -force foo
    set result
} {1 {can't create directory "foo/tf1": permission denied}}
test fCmd-4.15 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {macOnly} {
    list [catch {file mkdir ${root}:} msg] $msg
} [subst {1 {can't create directory "${root}:": no such file or directory}}]
test fCmd-4.16 {TclFileMakeDirsCmd: TclpCreateDirectory succeeds} {notRoot} {
    cleanup
    file mkdir tf1
    file exists tf1
} {1}

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} {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} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    file delete tf2
    glob tf* td*
} {tf1 td1}
test fCmd-5.4 {TclFileDeleteCmd: multiple files} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    set x [list [file exist tf1] [file exist tf2] [file exist td1]]
    file delete tf1 td1 tf2
    lappend x [file exist tf1] [file exist tf2] [file exist tf3]
} {1 1 1 0 0 0}
test fCmd-5.5 {TclFileDeleteCmd: stop at first error} {notRoot unixOrPc} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    catch {file delete tf1 td1 $root tf2}
    list [file exist tf1] [file exist tf2] [file exist td1]
} {0 1 0}
test fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} {notRoot} {
    list [catch {file delete ~nonexistantuser} msg] $msg
} {1 {user "nonexistantuser" doesn't exist}}
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} {notRoot} {
    cleanup
    set x [file exist tf1]
    file delete tf1
    list $x [file exist tf1]
} {0 0}    
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} {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} {notRoot} {
    # can't test this, because it's caught by FileCopyRename
} {}
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} {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} {notRoot} {
    cleanup
    createfile tf1
    file rename tf1 tf2
    glob tf*
} {tf2}
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 notRoot} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    createfile tf1
    set msg [list [catch {file rename tf1 td1} msg] $msg]
    testchmod 755 td1
    set msg
................................................................................
    list [catch {file rename tf1 $long} msg] $msg
} [subst {1 {error renaming "tf1" to "$long": file name too long}}]
test fCmd-6.8 {CopyRenameOneFile: errno != ENOENT} {macOnly} {
    cleanup
    createfile tf1
    list [catch {file rename tf1 $long} msg] $msg
} [subst {1 {error renaming "tf1" to "$long": file name too long}}]
test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} {unixOnly notRoot} {
    cleanup
    createfile tf1
    file rename tf1 tf2
    glob tf*
} {tf2}
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} {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} {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} {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} {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} {notRoot} {
    cleanup
    file mkdir [file join td1 td2]
    file mkdir td2
    createfile [file join td2 tf1]
    file rename -force td2 td1
    file exists [file join td1 td2 tf1]
} {1}
test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} {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} {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} {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 notRoot} {
    cleanup /tmp
    createfile tf1
    file rename tf1 /tmp
    glob tf* /tmp/tf1
} {/tmp/tf1}
test fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} {pcOnly} {
    catch {file delete -force c:/[email protected] d:/[email protected]}
................................................................................
	list d:/[email protected]
    } else {
	set msg [glob c:/[email protected] d:/[email protected]]
	file delete -force d:/[email protected]
	set msg
    }
} {d:/[email protected]}
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 notRoot} {
    cleanup /tmp
    createfile tf1
    file rename tf1 /tmp
    glob tf* /tmp/tf*
} {/tmp/tf1}
test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} \
	{unixOnly notRoot xdev} {
    cleanup /tmp
    file mkdir td1/td2/td3
    exec chmod 000 td1
    set msg [list [catch {file rename td1 /tmp} msg] $msg]
    exec chmod 755 td1
    set msg 
} {1 {error renaming "td1": permission denied}}
test fCmd-6.24 {CopyRenameOneFile: error uses original name} \
	{unixOnly notRoot} {
    cleanup
    file mkdir ~/td1/td2
    exec chmod 000 [file join [file dirname ~] [file tail ~] td1]
    set msg [list [catch {file copy ~/td1 td1} msg] $msg]
    exec chmod 755 [file join [file dirname ~] [file tail ~] td1]
    file delete -force ~/td1
    set msg
} {1 {error copying "~/td1": permission denied}}
test fCmd-6.25 {CopyRenameOneFile: error uses original name} \
	{unixOnly notRoot} {
    cleanup
    file mkdir td2
    file mkdir ~/td1
    exec chmod 000 [file join [file dirname ~] [file tail ~] td1]
    set msg [list [catch {file copy td2 ~/td1} msg] $msg]
    exec chmod 755 [file join [file dirname ~] [file tail ~] td1]
    file delete -force ~/td1
    set msg
} {1 {error copying "td2" to "~/td1/td2": permission denied}}
test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} \
	{unixOnly notRoot} {
    cleanup
    file mkdir ~/td1/td2
    exec chmod 000 [file join [file dirname ~] [file tail ~] td1 td2]
    set msg [list [catch {file copy ~/td1 td1} msg] $msg]
    exec chmod 755 [file join [file dirname ~] [file tail ~] td1 td2]
    file delete -force ~/td1
    set msg
} "1 {error copying \"~/td1\" to \"td1\": \"[file join [file dirname ~] [file tail ~] td1 td2]\": permission denied}"
test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} \
	{unixOnly 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 notRoot xdev} {
    cleanup /tmp
    file mkdir td1/td2/td3
    exec chmod 000 td1/td2/td3 
    set msg [list [catch {file rename td1 /tmp} msg] $msg]
    exec chmod 755 td1/td2/td3 
    set msg
} {1 {error renaming "td1" to "/tmp/td1": "td1/td2/td3": permission denied}}
test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} \
	{unixOnly 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 notRoot} {
    cleanup
    file mkdir foo/bar
    file attr foo -perm 040555
    set msg [list [catch {file rename foo/bar /tmp} msg] $msg]
    catch {file delete /tmp/bar}
    catch {file attr foo -perm 040777}
    catch {file delete -force foo}
    set msg
} {1 {can't unlink "foo/bar": 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} {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} {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} {notRoot} {
    cleanup
    file mkdir [file join tf1 tf2]
    file delete -force tf1
} {}
test fCmd-7.3 {FileForceOption: --} {notRoot} {
    createfile -tf1
    file delete -- -tf1
} {}
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} {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 notRoot} {
    file mkdir td1
    file attr td1 -perm 040000
    set result [list [catch {file rename ~$user td1} msg] $msg]
    file delete -force td1
    set result
} "1 {error renaming \"~$user\" to \"td1/[file tail ~$user]\": permission denied}"

test fCmd-9.1 {file rename: comprehensive: EACCES} {unixOnly notRoot} {
    cleanup
    file mkdir td1
    file mkdir td2
    file attr td2 -perm 040000
    set result [list [catch {file rename td1 td2/} msg] $msg]
    file delete -force td2
    file delete -force td1
    set result
} {1 {error renaming "td1" to "td2/td1": permission denied}}
test fCmd-9.2 {file rename: comprehensive: source doesn't exist} {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} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    testchmod 444 tf2
    file rename tf1 tf3
    file rename tf2 tf4
    list [lsort [glob tf*]] [file writable tf3] [file writable tf4]
} {{tf3 tf4} 1 0}    
test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc notRoot} {
    cleanup
    file mkdir td1 td2
    testchmod 555 td2
    file rename td1 td3
    file rename td2 td4
    list [lsort [glob td*]] [file writable td3] [file writable td4]
} {{td3 td4} 1 0}    
test fCmd-9.5 {file rename: comprehensive: file to self} {notRoot} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testchmod 444 tf2
    file rename -force tf1 tf1
    file rename -force tf2 tf2
    list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2]
} {tf1 tf2 1 0}    
test fCmd-9.6 {file rename: comprehensive: dir to self} {notRoot unixOrPc} {
    cleanup
    file mkdir td1
    file mkdir td2
    testchmod 555 td2
    file rename -force td1 .
    file rename -force td2 .
    list [lsort [glob td*]] [file writable td1] [file writable td2]
} {{td1 td2} 1 0}    
test fCmd-9.7 {file rename: comprehensive: file to existing file} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    createfile tfs1
    createfile tfs2
    createfile tfs3
    createfile tfs4
................................................................................
    set msg [list [catch {file rename tf1 tf2} msg] $msg]
    file rename -force tfs1 tfd1
    file rename -force tfs2 tfd2
    file rename -force tfs3 tfd3
    file rename -force tfs4 tfd4
    list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] 
} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0}
test fCmd-9.8 {file rename: comprehensive: dir to empty dir} {notRoot} {
    # Under unix, you can rename a read-only directory, but you can't
    # move it into another directory.

    cleanup
    file mkdir td1
    file mkdir [file join td2 td1]
    file mkdir tds1
................................................................................
    } else {
	set w3 0
	set w4 0
    }
    list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \
    [file writable [file join tdd2 tds2]] $w3 $w4
} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}]
test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} {notRoot} {
    cleanup
    file mkdir tds1
    file mkdir tds2
    file mkdir [file join tdd1 tds1 xxx]
    file mkdir [file join tdd2 tds2 xxx]
    if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {
	testchmod 555 tds2
................................................................................
    if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {
	set w2 [file writable tds2]
    } else {
	set w2 0
    }
    list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2
} [subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}]
test fCmd-9.10 {file rename: comprehensive: file to new name and dir} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    testchmod 444 tf2
    file rename tf1 [file join td1 tf3]
    file rename tf2 [file join td1 tf4]
    list [catch {glob tf*}] [lsort [glob [file join td1 t*]]] \
    [file writable [file join td1 tf3]] [file writable [file join td1 tf4]]
} [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}]
test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} {notRoot} {
    cleanup
    file mkdir td1
    file mkdir td2
    file mkdir td3
    if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {
	testchmod 555 td2
    }
................................................................................
	set w4 [file writable [file join td3 td4]]
    } else {
        set w4 0
    }
    list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \
    [file writable [file join td3 td3]] $w4
} [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}]
test fCmd-9.12 {file rename: comprehensive: target exists} {notRoot} {
    cleanup
    file mkdir [file join td1 td2] [file join td2 td1]
    if {$tcl_platform(platform) != "macintosh"} {
    	testchmod 555 [file join td2 td1]
    }
    file mkdir [file join td3 td4] [file join td4 td3]
    file rename -force td3 td4
................................................................................
    set msg [list [file exists td3] [file exists [file join td4 td3 td4]] \
    [catch {file rename td1 td2} msg] $msg]
    if {$tcl_platform(platform) != "macintosh"} {
    	testchmod 755 [file join td2 td1]
    }
    set msg
} [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}]
test fCmd-9.13 {file rename: comprehensive: can't overwrite target} {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} {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} \
	{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} \
	{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} {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} {notRoot} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testchmod 444 tf2
    file copy tf1 tf3
    file copy tf2 tf4
    list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4]
} {{tf1 tf2 tf3 tf4} tf1 tf2 1 0}
test fCmd-10.3 {file copy: comprehensive: dir to new name} {notRoot unixOrPc} {
    cleanup
    file mkdir [file join td1 tdx]
    file mkdir [file join td2 tdy]
    testchmod 555 td2
    file copy td1 td3
    file copy td2 td4
    set msg [list [lsort [glob td*]] [glob [file join td3 t*]] \
................................................................................
	    [glob [file join td4 t*]] [file writable td3] [file writable td4]]
    if {$tcl_platform(platform) != "macintosh"} {
    	testchmod 755 td2
    	testchmod 755 td4
    }
    set msg
} [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0}]
test fCmd-10.4 {file copy: comprehensive: file to existing file} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    createfile tfs1
    createfile tfs2
    createfile tfs3
    createfile tfs4
................................................................................
    set msg [list [catch {file copy tf1 tf2} msg] $msg]
    file copy -force tfs1 tfd1
    file copy -force tfs2 tfd2
    file copy -force tfs3 tfd3
    file copy -force tfs4 tfd4
    list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] 
} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0}
test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {notRoot} {
    cleanup
    file mkdir td1
    file mkdir [file join td2 td1]
    file mkdir tds1
    file mkdir tds2
    file mkdir tds3
    file mkdir tds4
................................................................................
    set a1 [list [catch {file copy td1 td2} msg] $msg]
    set a2 [list [catch {file copy -force tds1 tdd1} msg] $msg]
    set a3 [catch {file copy -force tds2 tdd2}]
    set a4 [catch {file copy -force tds3 tdd3}]
    set a5 [catch {file copy -force tds4 tdd4}]
    list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 
} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}]
test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} \
	{notRoot unixOrPc} {
    cleanup
    file mkdir tds1
    file mkdir tds2
    file mkdir [file join tdd1 tds1 xxx]
    file mkdir [file join tdd2 tds2 xxx]
    testchmod 555 tds2
    set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg]
    set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg]
    list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2]
} [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}]
test fCmd-10.7 {file rename: comprehensive: file to new name and dir} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    testchmod 444 tf2
    file copy tf1 [file join td1 tf3]
    file copy tf2 [file join td1 tf4]
    list [lsort [glob tf*]] [lsort [glob [file join td1 t*]]] \
    [file writable [file join td1 tf3]] [file writable [file join td1 tf4]]
} [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}]
test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} \
	{notRoot unixOrPc} {
    cleanup
    file mkdir td1
    file mkdir td2
    file mkdir td3
    testchmod 555 td2
    file copy td1 [file join td3 td3]
    file copy td2 [file join td3 td4]
    list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \
    [file writable [file join td3 td3]] [file writable [file join td3 td4]]
} [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}]
test fCmd-10.9 {file copy: comprehensive: source and target incompatible} \
	{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} \
	{notRoot} {
    cleanup
    file mkdir [file join td1 tf1]
    createfile tf1
    list [catch {file copy -force tf1 td1} msg] $msg
} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]
cleanup    

# old tests    

test fCmd-11.1 {TclFileRenameCmd: -- option } {notRoot} {
    catch {file delete -force -- -tfa1}
    set s [createfile -tfa1]
    file rename -- -tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && ![file exists -tfa1]]
    file delete tfa2
    set result
} {1}

test fCmd-11.2 {TclFileRenameCmd: bad option } {notRoot} {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]
    set r1 [catch {file rename -x tfa1 tfa2}]
    set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]]
    file delete tfa1
    set result
} {1}

test fCmd-11.3 {TclFileRenameCmd: bad \# args} {
    catch {file rename -- }
} {1}

test fCmd-11.4 {TclFileRenameCmd: target filename translation failing} {notRoot} {
     global env
     set temp $env(HOME)
     unset env(HOME)
     set result [catch {file rename tfa ~/foobar }]
     set env(HOME) $temp
     set result
 } {1}

test fCmd-11.5 {TclFileRenameCmd: > 1 source & target is not a dir} {notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
    createfile tfa1 
    createfile tfa2 
    createfile tfa3 
    set result [catch {file rename tfa1 tfa2 tfa3}]
    file delete tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-11.6 {TclFileRenameCmd: : single file into directory} {notRoot} {
    catch {file delete -force -- tfa1 tfad}
    set s [createfile tfa1]
    file mkdir tfad
    file rename tfa1 tfad
    set result [expr [checkcontent tfad/tfa1 $s] && ![file exists tfa1]]
    file delete -force tfad
    set result
} {1}

test fCmd-11.7 {TclFileRenameCmd: : multiple files into directory} {notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfad}
    set s1 [createfile tfa1 ]
    set s2 [createfile tfa2 ]
    file mkdir tfad
    file rename tfa1 tfa2 tfad
    set r1 [checkcontent tfad/tfa1 $s1]
    set r2 [checkcontent tfad/tfa2 $s2]
................................................................................
    
    set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfa2]]
	    
    file delete -force tfad
    set result
} {1}

test fCmd-11.8 {TclFileRenameCmd: error renaming file to directory} {notRoot} {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfa $s]
    set r3 [file isdir tfad]
................................................................................
    file delete -force tfa tfad
    set result
} {1}

#
# Coverage tests for renamefile() ;
#
test fCmd-12.1 {renamefile: source filename translation failing} {notRoot} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set result [catch {file rename ~/tfa1 tfa2}]
    set env(HOME) $temp
    set result
} {1}

test fCmd-12.2 {renamefile: src filename translation failing} {notRoot} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set s [createfile tfa1]
    file mkdir tfad
    set result [catch {file rename tfa1 ~/tfa2 tfad}]
    set env(HOME) $temp
    file delete -force tfad
    set result
} {1}

test fCmd-12.3 {renamefile: stat failing on source} {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} {notRoot} {
    catch {file delete -force -- tfa tfad}
    set s1 [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfa $s1]
    set r3 [file isdir tfad/tfa]
    set result [expr $r1 && $r2 && $r3]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-12.5 {renamefile: error renaming directory to file} {notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa
    file mkdir tfad
    set s [createfile tfad/tfa]
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfad/tfa $s]
    set r3 [file isdir tfad]
    set r4 [file isdir tfa]
    set result [expr $r1 && $r2 && $r3 && $r4 ]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-12.6 {renamefile: TclRenameFile succeeding} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    file rename tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && ![file exists tfa1]]
    file delete tfa2
    set result
} {1}

test fCmd-12.7 {renamefile: renaming directory into offspring} {notRoot} {
    catch {file delete -force -- tfad}
    file mkdir tfad
    file mkdir tfad/dir
    set result [catch {file rename tfad tfad/dir}]
    file delete -force tfad 
    set result
} {1}

test fCmd-12.8 {renamefile: generic error} {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/dir
    exec chmod 555 tfa
    set result [catch {file rename tfa/dir tfa2}]
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}


test fCmd-12.9 {renamefile: moving a file across volumes} {unixOnly notRoot} {
    catch {file delete -force -- tfa /tmp/tfa}
    set s [createfile tfa ]
    file rename tfa /tmp
    set result [expr [checkcontent /tmp/tfa $s] && ![file exists tfa]]
    file delete /tmp/tfa
    set result
} {1}

test fCmd-12.10 {renamefile: moving a directory across volumes } \
	{unixOnly notRoot} {
    catch {file delete -force -- tfad /tmp/tfad}
    file mkdir tfad
    set s [createfile tfad/a ]
    file rename tfad /tmp
    set restul [expr [checkcontent /tmp/tfad/a $s] && ![file exists tfad]]
    file delete -force /tmp/tfad
    set result
} {1}

#
# Coverage tests for TclCopyFilesCmd()
#
test fCmd-13.1 {TclCopyFilesCmd: -force option} {notRoot} {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]
    file copy -force  tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-13.2 {TclCopyFilesCmd: -- option} {notRoot} {
    catch {file delete -force -- tfa1}
    set s [createfile -tfa1]
    file copy --  -tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] &&  [checkcontent -tfa1 $s]]
    file delete -- -tfa1 tfa2
    set result
} {1}

test fCmd-13.3 {TclCopyFilesCmd: bad option} {notRoot} {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]
    set r1 [catch {file copy -x tfa1 tfa2}]
    set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]]
    file delete tfa1
    set result
} {1}

test fCmd-13.4 {TclCopyFilesCmd: bad \# args} {notRoot} {
    catch {file copy -- }
} {1}

test fCmd-13.5 {TclCopyFilesCmd: target filename translation failing} {
     global env
     set temp $env(HOME)
    unset env(HOME)
     set result [catch {file copy tfa ~/foobar }]
     set env(HOME) $temp
     set result
 } {1}

test fCmd-13.6 {TclCopyFilesCmd: > 1 source & target is not a dir} {notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
    createfile tfa1 
    createfile tfa2 
    createfile tfa3 
    set result [catch {file copy tfa1 tfa2 tfa3}]
    file delete tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-13.7 {TclCopyFilesCmd: single file into directory} {notRoot} {
    catch {file delete -force -- tfa1 tfad}
    set s [createfile tfa1]
    file mkdir tfad
    file copy tfa1 tfad
    set result [expr [checkcontent tfad/tfa1 $s] &&  [checkcontent tfa1 $s]]
    file delete -force tfad tfa1
    set result
} {1}

test fCmd-13.8 {TclCopyFilesCmd: multiple files into directory} {notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfad}
    set s1 [createfile tfa1 ]
    set s2 [createfile tfa2 ]
    file mkdir tfad
    file copy tfa1 tfa2 tfad
    set r1 [checkcontent tfad/tfa1 $s1]
    set r2 [checkcontent tfad/tfa2 $s2]
................................................................................
    set r4 [checkcontent tfa2 $s2]
    set result [expr $r1 && $r2 && $r3 && $r4 ]
	    
    file delete -force tfad tfa1 tfa2
    set result
} {1}

test fCmd-13.9 {TclCopyFilesCmd: error copying file to directory} {notRoot} {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file copy tfa tfad}]
    set r2 [expr [checkcontent tfa $s] && [file isdir tfad/tfa]]
    set r3 [file isdir tfad]
................................................................................
    file delete -force tfa tfad
    set result
} {1}

#
# Coverage tests for copyfile()
# 
test fCmd-14.1 {copyfile: source filename translation failing} {notRoot} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set result [catch {file copy ~/tfa1 tfa2}]
    set env(HOME) $temp
    set result
} {1}

test fCmd-14.2 {copyfile: dst filename translation failing} {notRoot} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set s [createfile tfa1]
    file mkdir tfad
    set r1 [catch {file copy tfa1 ~/tfa2 tfad}]
    set result [expr $r1 && [checkcontent tfad/tfa1 $s]]
    set env(HOME) $temp
    file delete -force tfa1 tfad
    set result
} {1}

test fCmd-14.3 {copyfile: stat failing on source} {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} {notRoot} {
    catch {file delete -force -- tfa tfad}
    set s1 [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file copy tfa tfad}]
    set r2 [checkcontent tfa $s1]
    set r3 [file isdir tfad]
    set r4 [file isdir tfad/tfa]
    set result [expr $r1 && $r2 && $r3 && $r4 ]
    file delete -force tfa tfad
    set result
} {1}

 test fCmd-14.5 {copyfile: error copying directory to file} {notRoot} {
     catch {file delete -force -- tfa tfad}
     file mkdir tfa
     file mkdir tfad
     set s [createfile tfad/tfa]
     set r1 [catch {file copy tfa tfad}]
     set r2 [checkcontent tfad/tfa $s]
     set r3 [file isdir tfad]
     set r4 [file isdir tfa]
     set result [expr $r1 && $r2 && $r3 && $r4 ]
     file delete -force tfa tfad
     set result
} {1}

test fCmd-14.6 {copyfile: copy file succeeding} {notRoot} {
    catch {file delete -force -- tfa tfa2}
    set s [createfile tfa]
    file copy tfa tfa2
    set result [expr  [checkcontent tfa $s] && [checkcontent tfa2 $s]]
    file delete tfa tfa2
    set result
} {1}

test fCmd-14.7 {copyfile: copy directory succeeding} {notRoot} {
    catch {file delete -force -- tfa tfa2}
    file mkdir tfa
    set s [createfile tfa/file]
    file copy tfa tfa2
    set result [expr [checkcontent tfa/file $s] && [checkcontent tfa2/file $s]]
    file delete -force tfa tfa2
    set result
} {1}

test fCmd-14.8 {copyfile: copy directory failing} {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa/dir/a/b/c
    exec chmod 000 tfa/dir
    set r1 [catch {file copy tfa tfa2}]
    exec chmod 777 tfa/dir
    set result $r1
    file delete -force tfa tfa2
    set result
} {1}

#
# Coverage tests for TclMkdirCmd()
#
test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} {notRoot} {
    global env
    set temp $env(HOME)
    unset env(HOME) 
    set result [catch {file mkdir ~/tfa}]
    set env(HOME) $temp
    set result
} {1}
#
# Can Tcl_SplitPath return argc == 0? If so them we need a
# test for that code.
#
test fCmd-15.2 {TclMakeDirsCmd - one directory } {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    set result [file isdirectory tfa]
    file delete tfa
    set result
} {1}

test fCmd-15.3 {TclMakeDirsCmd: - two directories} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    file mkdir tfa1 tfa2
    set result [expr [file isdirectory tfa1] && [file isdirectory tfa2]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-15.4 {TclMakeDirsCmd - stat failing} {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/file
    exec chmod 000 tfa
    set result [catch {file mkdir tfa/file}]
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}

test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep} \
	{notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa/a/b/c
    set result [file isdir tfa/a/b/c]
    file delete -force tfa
    set result
} {1}

    
test fCmd-15.6 {TclMakeDirsCmd: - trying to overwrite a file} {notRoot} {
    catch {file delete -force -- tfa}
    set s [createfile tfa]
    set r1 [catch {file mkdir tfa}]
    set r2 [file isdir tfa]
    set r3 [file exists tfa]
    set result [expr $r1 && !$r2 && $r3 && [checkcontent tfa $s]]
    file delete tfa
    set result
} {1}

test fCmd-15.7 {TclMakeDirsCmd - making several directories} {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]]
    file delete -force tfa1 tfa2
    set result
} {1}

test fCmd-15.8 {TclFileMakeDirsCmd: trying to create an existing dir} {notRoot} {
    file mkdir tfa
    file mkdir tfa
    set result [file isdir tfa]
    file delete tfa
    set result
} {1}


# Coverage tests for TclDeleteFilesCommand()
test fCmd-16.1 { test the -- argument } {notRoot} {
    catch {file delete -force -- tfa}
    createfile tfa
    file delete -- tfa
    file exists tfa
} {0}

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 } {notRoot} {
    catch {file delete -force -- tfa}
    createfile tfa
    set result [catch {file delete -dog tfa}]
    file delete tfa
    set result
} {1}

test fCmd-16.4 { test not enough args } {notRoot} {
    catch {file delete}
} {1}

test fCmd-16.5 { test not enough args with options } {notRoot} {
    catch {file delete --}
} {1}

test fCmd-16.6 {delete: source filename translation failing} {notRoot} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set result [catch {file delete ~/tfa}]
    set env(HOME) $temp
    set result
} {1}

test fCmd-16.7 {remove a non-empty directory without -force } {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/a
    set result [catch  {file delete tfa }]
    file delete -force tfa
    set result
} {1}

test fCmd-16.8 {remove a normal file } {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/a
    set result [catch  {file delete tfa }]
    file delete -force tfa
    set result
} {1}

test fCmd-16.9 {error while deleting file } {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/a
    exec chmod 555 tfa
    set result [catch  {file delete tfa/a }]
    #######
    #######  If any directory in a tree that is being removed does not 
................................................................................
    #######  This is also the case with "rm -rf"
    #######
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}

test fCmd-16.10 {deleting multiple files} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    createfile tfa1
    createfile tfa2
    file delete tfa1 tfa2
    expr ![file exists tfa1] && ![file exists tfa2]
} {1}

test fCmd-16.11 { TclFileDeleteCmd: removing a nonexistant file} {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 notRoot} {
     catch {file delete -force -- tfa1}
     file mkdir tfa1
     exec chmod 555 tfa1
     set result [catch {file mkdir tfa1/tfa2}]
     exec chmod 777 tfa1
     file delete -force tfa1
     set result
} {1}

test fCmd-17.2 {mkdir several levels deep - relative } {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa/a/b
    set result [file isdir tfa/a/b ]
    file delete tfa/a/b tfa/a tfa
    set result
} {1}

test fCmd-17.3 {mkdir several levels deep - absolute } {notRoot} {
    catch {file delete -force -- tfa}
    set f [file join [pwd] tfa a ]
    file mkdir $f
    set result [file isdir $f ]
    file delete $f [file join [pwd] tfa]
    set result
} {1}

#
# Functionality tests for TclFileRenameCmd()
#

test fCmd-18.1 {TclFileRenameCmd: rename (first form) in the same directory} \
	{notRoot} {
    catch {file delete -force -- tfad}
    file mkdir tfad/dir
    cd tfad/dir
    set s [createfile foo ]
    file rename  foo bar
    file rename bar ./foo
    file rename ./foo bar
................................................................................
    file rename foo [file join [pwd] bar]
    set result [expr [checkcontent bar $s] && ![file exists foo]]
    cd ../..
    file delete -force tfad
    set result
} {1}

test fCmd-18.2 {TclFileRenameCmd: single dir to nonexistant} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    file mkdir tfa1
    file rename tfa1 tfa2
    set result [expr [file exists tfa2] && ![file exists tfa1]]
    file delete tfa2
    set result
} {1}

test fCmd-18.3 {TclFileRenameCmd: mixed dirs and files into directory} {notRoot} {
    catch {file delete -force -- tfa1 tfad1 tfad2}
    set s [createfile tfa1 ]
    file mkdir tfad1 tfad2
    file rename tfa1 tfad1 tfad2
    set r1 [checkcontent  tfad2/tfa1 $s]
    set r2 [file isdir tfad2/tfad1]
    set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfad1]]
    file delete tfad2/tfa1
    file delete -force tfad2
    set result
} {1}

test fCmd-18.4 {TclFileRenameCmd: attempt to replace non-dir with dir} {notRoot} {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad
    set r1 [catch {file rename tfad tfa}]
    set r2 [checkcontent tfa $s]
    set r3 [file isdir tfad]
    set result [expr $r1 && $r2 && $r3 ]
    file delete tfa tfad
    set result
} {1}

test fCmd-18.5 {TclFileRenameCmd: attempt to replace dir with non-dir} {notRoot} {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfa $s]
    set r3 [file isdir tfad/tfa]
    set result [expr $r1 && $r2 && $r3 ]
................................................................................
    file delete -force  tfa tfad
    set result
} {1}

#
# On Windows there is no easy way to determine if two files are the same
#
test fCmd-18.6 {TclFileRenameCmd: rename a file to itself} {macOrUnix notRoot} {
    catch {file delete -force -- tfa}
    set s [createfile tfa]
    set r1 [catch {file rename tfa tfa}]
    set result [expr $r1 && [checkcontent tfa $s]]
    file delete tfa
    set result
} {1}

test fCmd-18.7 {TclFileRenameCmd: rename dir on top of another empty dir w/o -force} \
	{notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set result [expr $r1 && [file isdir tfa]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-18.8 {TclFileRenameCmd: rename dir on top of another empty dir w/ -force} \
	{notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa
    file rename -force tfa tfad
    set result [expr ![file isdir tfa]]
    file delete -force tfad
    set result
} {1}

test fCmd-18.9 {TclFileRenameCmd: rename dir on top of a non-empty dir w/o -force} \
	{notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa/file
    set r1 [catch {file rename tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} \
	{notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa/file
    set r1 [catch {file rename -force tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-18.11 {TclFileRenameCmd: rename a non-existant file} {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 notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    set s [createfile tfa1]
    exec ln -s tfa1 tfa2
    file rename tfa2 tfa3
    set t [file type tfa3]
    set result [expr { $t == "link" }]
    file delete tfa1 tfa3
    set result
} {1}

test fCmd-18.13 {TclFileRenameCmd : rename a symbolic link to dir} \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    file mkdir tfa1
    exec ln -s tfa1 tfa2
    file rename tfa2 tfa3
    set t [file type tfa3]
    set result [expr { $t == "link" }]
    file delete tfa1 tfa3
    set result
} {1}

test fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    file mkdir tfa1/a/b/c/d
    file mkdir tfa2
    set f [file join [pwd] tfa1/a/b] 
    set f2 [file join [pwd] {tfa2/b alias}]
    exec ln -s $f $f2
................................................................................
    set r1 [file isdir tfa3]
    set r2 [file exists tfa1/a/b/c]
    set result [expr $r1 && !$r2]
    file delete -force tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-18.15 {TclFileRenameCmd : rename a file to a symlink dir} \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfalink}
	
    file mkdir tfa1
    set s [createfile tfa2]
    exec ln -s tfa1 tfalink

    file rename tfa2 tfalink
    set result [checkcontent tfa1/tfa2 $s ]
    file delete -force tfa1 tfalink
    set result
} {1}

test fCmd-18.16 {TclFileRenameCmd: rename a dangling symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfalink}
	
    file mkdir tfa1
    exec ln -s tfa1 tfalink
    file delete tfa1 
    file rename tfalink tfa2
    set result [expr [string compare [file type tfa2] "link"] == 0]
................................................................................
    set result
} {1}


#
# Coverage tests for TclUnixRmdir
#
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 notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    exec chmod 555 tfa
    set result [catch {file delete tfa/a}]
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}

test fCmd-19.3 { recursive remove } {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    file delete -force tfa
    file exists tfa
} {0}

................................................................................
#
#

#
# Coverage tests for TraverseUnixTree(), called from TclDeleteFilesCmd
#

test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    exec chmod 000 tfa/a
    set result [catch {file delete -force tfa}]
    exec chmod 777 tfa/a
    file delete -force tfa
................................................................................
    set result
} {1}


#
# Feature testing for TclCopyFilesCmd
# 
test fCmd-21.1 {copy : single file to nonexistant } {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    file copy tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-21.2 {copy : single dir to nonexistant } {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    file mkdir tfa1
    file copy tfa1 tfa2
    set result [expr [file isdir tfa2] && [file isdir tfa1]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-21.3 {copy : single file into directory  } {notRoot} {
    catch {file delete -force -- tfa1 tfad}
    set s [createfile tfa1]
    file mkdir tfad
    file copy tfa1 tfad
    set result [expr [checkcontent tfad/tfa1 $s] && [checkcontent tfa1 $s]]
    file delete -force tfa1 tfad
    set result
} {1}

test fCmd-21.4 {copy : more than one source and target is not a directory} \
	{notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
    createfile tfa1 
    createfile tfa2 
    createfile tfa3 
    set result [catch {file copy tfa1 tfa2 tfa3}]
    file delete tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-21.5 {copy : multiple files into directory  } {notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfad}
    set s1 [createfile tfa1 ]
    set s2 [createfile tfa2 ]
    file mkdir tfad
    file copy tfa1 tfa2 tfad
    set r1 [checkcontent tfad/tfa1 $s1]
    set r2 [checkcontent tfad/tfa2 $s2]
................................................................................
    set r3 [checkcontent tfa1 $s1]
    set r4 [checkcontent tfa2 $s2]
    set result [expr $r1 && $r2 && $r3 && $r4]
    file delete -force tfa1 tfa2 tfad
    set result
} {1}

test fCmd-21.6 {copy: mixed dirs and files into directory} \
	{notRoot notFileSharing} {
    catch {file delete -force -- tfa1 tfad1 tfad2}
    set s [createfile tfa1 ]
    file mkdir tfad1 tfad2
    file copy tfa1 tfad1 tfad2
    set r1 [checkcontent [file join tfad2 tfa1] $s]
    set r2 [file isdir [file join tfad2 tfad1]]
    set r3 [checkcontent tfa1 $s]
    set result [expr $r1 && $r2 && $r3 && [file isdir tfad1]]
    file delete -force tfa1 tfad1 tfad2
    set result
} {1}

test fCmd-21.7 {TclCopyFilesCmd: copy a dangling link} {unixOnly notRoot} {
    file mkdir tfad1
    exec ln -s tfad1 tfalink
    file delete tfad1
    file copy tfalink tfalink2
    set result [string match [file type tfalink2] link]
    file delete tfalink tfalink2 
    set result
} {1}

test fCmd-21.8 {TclCopyFilesCmd : copy a link } {unixOnly notRoot} {
    file mkdir tfad1
    exec ln -s tfad1 tfalink
    file copy tfalink tfalink2
    set r1 [file type tfalink]
    set r2 [file type tfalink2]
    set r3 [file isdir tfad1]
    set result [expr {("$r1" == "link" ) && ("$r2" == "link" ) && $r3}]
    file delete tfad1 tfalink tfalink2
    set result
} {1}

test fCmd-21.9 {TclCopyFilesCmd: copy dir with a link in it} {unixOnly notRoot} {
    file mkdir tfad1
    exec ln -s "[pwd]/tfad1" tfad1/tfalink
    file copy tfad1 tfad2
    set result [string match [file type tfad2/tfalink] link]
    file delete -force tfad1 tfad2
    set result
} {1}

test fCmd-21.10 {TclFileCopyCmd: copy dir on top of another empty dir w/o -force} \
	{notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa [file join tfad tfa]
    set r1 [catch {file copy tfa tfad}]
    set result [expr $r1 && [file isdir tfa]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-21.11 {TclFileCopyCmd: copy dir on top of a dir w/o -force} {notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa [file join tfad tfa file]
    set r1 [catch {file copy tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-21.12 {TclFileCopyCmd: copy dir on top of a non-empty dir w/ -force} \
	{notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa [file join tfad tfa file]
    set r1 [catch {file copy -force tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]]
    file delete -force tfa tfad
    set result
} {1}
   
#
# Coverage testing for TclpRenameFile
#
test fCmd-22.1 {TclpRenameFile: rename and overwrite in a single dir} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    set s2 [createfile tfa2 q]
	
    set r1 [catch {rename tfa1 tfa2}]
    file rename -force tfa1 tfa2
    set result [expr $r1 && [checkcontent tfa2 $s]]
    file delete [glob tfa1 tfa2]
    set result
} {1}

test fCmd-22.2 {TclpRenameFile: attempt to overwrite itself} {macOrUnix notRoot} {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]	
    file rename -force tfa1 tfa1
    set result [checkcontent tfa1 $s]
    file delete tfa1 
    set result
} {1}

test fCmd-22.3 { TclpRenameFile : rename dir to existing dir } {notRoot} {
    catch {file delete -force -- d1 tfad}
    file mkdir d1 [file join tfad d1]
    set r1 [catch {file rename d1 tfad}]
    set result [expr $r1 && [file isdir d1] && [file isdir [file join tfad d1]]]
    file delete -force d1 tfad
    set result
} {1}

test fCmd-22.4 {TclpRenameFile: rename dir to dir several levels deep} {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]
    set result [expr ![file isdir d1] && [file isdir [file join tfad a b c d1]]]
    file delete -force [glob d1 tfad]
    set result
} {1}


#
# TclMacCopyFile needs to be redone.
#
test fCmd-22.5 {TclMacCopyFile: copy and overwrite in a single dir} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    set s2 [createfile tfa2 q]

    set r1 [catch {file copy tfa1 tfa2}]
    file copy -force tfa1 tfa2
    set result [expr $r1 && [checkcontent tfa2 $s] && [checkcontent tfa1 $s]]
................................................................................
#

#
# TclMacRmdir
# Error cases are not covered.
#

test fCmd-23.1 {TclMacRmdir: trying to remove a nonempty directory} {notRoot} {
    catch {file delete -force -- tfad}
	
    file mkdir [file join tfad dir]
	
    set result [catch {file delete tfad}]
    file delete -force tfad 
    set result
} {1}

#
# TclMacDeleteFile	
# Error cases are not covered.
#
test fCmd-24.1 {TclMacDeleteFile: deleting a normal file} {notRoot} {
    catch {file delete -force -- tfa1}
	
    createfile tfa1
    file delete tfa1
    file exists tfa1
} {0}

#
# TclMacCopyDirectory
# Error cases are not covered.
#
test fCmd-25.1 { TclMacCopyDirectory : copying a normal directory} \
	{notRoot notFileSharing} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir [file join tfad1 a b c]
    file copy tfad1 tfad2
    set result [expr [file isdir [file join tfad1 a b c]] && [file isdir [file join tfad2 a b c]]]
    file delete -force tfad1 tfad2
    set result
} {1}

test fCmd-25.2 { TclMacCopyDirectory : copying a short path normal directory} \
	{notRoot notFileSharing} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    file copy tfad1 tfad2
    set result [expr [file isdir tfad1] && [file isdir tfad2]]
    file delete tfad1 tfad2
    set result
} {1}

test fCmd-25.3 { TclMacCopyDirectory : copying dirs between different dirs} \
	{notRoot notFileSharing} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir [file join tfad1 x y z]
    file mkdir [file join tfad2 dir]
    file copy tfad1 [file join tfad2 dir]
    set result [expr [file isdir [file join tfad1 x y z]] && [file isdir [file join tfad2 dir tfad1 x y z]]]
    file delete -force tfad1 tfad2
................................................................................
    set result
} {1}

#
# Functionality tests for TclDeleteFilesCmd
#

test fCmd-26.1 { TclDeleteFilesCmd : delete symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    exec ln -s tfad1 tfalink
    file delete tfalink

    set r1 [file isdir tfad1]
................................................................................
    set r2 [file exists tfalink]
    
    set result [expr $r1 && !$r2]
    file delete tfad1
    set result
} {1}

test fCmd-26.2 { TclDeleteFilesCmd : delete dir with symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    file mkdir tfad2
    exec ln -s tfad1 [file join tfad2 link]
    file delete -force tfad2

................................................................................
    set r2 [file exists tfad2]
    
    set result [expr $r1 && !$r2]
    file delete tfad1
    set result
} {1}

test fCmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    exec ln -s tfad1 tfad2
    file delete tfad1
    file delete tfad2

................................................................................
test fCmd-27.4 {TclFileAttrsCmd - getting one option} {
    catch {file delete -force -- foo.tmp}
    createfile foo.tmp
    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lindex $attrs 0]}] [file delete -force -- foo.tmp]
} {0 {}}

# 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} {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} {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

# This file tests the filename manipulation routines.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.

#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fileName.test,v 1.1.2.3 1999/03/11 18:49:37 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}



if {[info commands testsetplatform] == {}} {
    puts "This application hasn't been compiled with the \"testsetplatform\""
    puts "command, so I can't test the filename conversion procedures."
    return 
} 

................................................................................
close [open globTest/x1.c w]
close [open globTest/y1.c w]
close [open globTest/z1.c w]
close [open "globTest/weird name.c" w]
close [open globTest/a1/b1/x2.c w]
close [open globTest/a1/b2/y2.c w]

# Cannot create a file with the following names under Win32s.  We have to
# skip the tests that are checking the difference between a "." or "," in
# the file name vs. a "." or "," in the glob pattern.

catch {close [open globTest/.1 w]}
catch {close [open globTest/x,z1.c w]}

test filename-11.14 {Tcl_GlobCmd} {
    list [catch {glob ~/globTest} msg] $msg
} [list 0 [list [file join $env(HOME) globTest]]]
test filename-11.15 {Tcl_GlobCmd} {
................................................................................
} "0 $globPreResult$x1"
test filename-13.7 {globbing with brace substitution} {
    list [catch {glob globTest/\{x\}1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-13.8 {globbing with brace substitution} {
    list [catch {glob globTest/\{x\{\}\}1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-13.9 {globbing with brace substitution} {!win32s} {
    list [lsort [catch {glob globTest/\{x,y\}1.c} msg]] $msg
} [list 0 [list $globPreResult$x1 $globPreResult$y1]]
test filename-13.10 {globbing with brace substitution} {!win32s} {
    list [lsort [catch {glob globTest/\{x,,y\}1.c} msg]] $msg
} [list 0 [list $globPreResult$x1 $globPreResult$y1]]
test filename-13.11 {globbing with brace substitution} {unixOrPc && !win32s} {
    list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg
} {0 {globTest/x1.c globTest/x,z1.c globTest/z1.c}}
test filename-13.12 {globbing with brace substitution} {macOnly} {
    list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg
} {0 {:globTest:x1.c :globTest:x,z1.c :globTest:z1.c}}
test filename-13.13 {globbing with brace substitution} {
    lsort [glob globTest/{a,b,x,y}1.c]
................................................................................
test filename-13.21 {globbing with brace substitution} {macOnly} {
    lsort [glob globTest/{a,x}1/*/{x,y}*]
} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c}
test filename-13.22 {globbing with brace substitution} {
    list [catch {glob globTest/\{a,x\}1/*/\{} msg] $msg
} {1 {unmatched open-brace in file name}}

test filename-14.1 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
    lsort [glob g*/*.c]
} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.1 {asterisks, question marks, and brackets} {win32s} {
    lsort [glob g*/*.c]
} {globtest/weirdn~1.c globtest/x1.c globtest/y1.c globtest/z1.c}
test filename-14.2 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob g*/*.c]
} {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob globTest/?1.c]
} {globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.4 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob globTest/?1.c]
} {:globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
    lsort [glob */*/*/*.c]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
test filename-14.5 {asterisks, question marks, and brackets} {win32s} {
    lsort [glob */*/*/*.c]
} {globtest/a1/b1/x2.c globtest/a1/b2/y2.c}
test filename-14.6 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob */*/*/*.c]
} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c}
test filename-14.7 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
    lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.7 {asterisks, question marks, and brackets} {win32s} {
    lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 globTest/weirdn~1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.8 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob globTest/*]
} {:globTest:.1 :globTest:a1 :globTest:a2 :globTest:a3 {:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.9 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
    lsort [glob globTest/.*]
} {globTest/. globTest/.. globTest/.1}
test filename-14.9 {asterisks, question marks, and brackets} {win32s} {
    lsort [glob globTest/.*]
} {globTest/. globTest/..}
test filename-14.10 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob globTest/.*]
} {:globTest:.1}
test filename-14.11 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob globTest/*/*]
} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3}
test filename-14.12 {asterisks, question marks, and brackets} {macOnly} {
................................................................................
    global env
    set temp $env(HOME)
    set env(HOME) [file join $env(HOME) globTest]
    set result [list [catch {glob ~/z*} msg] $msg]
    set env(HOME) $temp
    set result
} [list 0 [list [file join $env(HOME) globTest z1.c]]]
test filename-14.18 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
    list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg
} {0 {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}}
test filename-14.18 {asterisks, question marks, and brackets} {win32s} {
    list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg
} {0 {globTest/weirdn~1.c globTest/x1.c globTest/y1.c globTest/z1.c}}
test filename-14.19 {asterisks, question marks, and brackets} {macOnly} {
    list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg
} {0 {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}}
test filename-14.20 {asterisks, question marks, and brackets} {
    list [catch {glob -nocomplain goo/*} msg] $msg
} {0 {}}
test filename-14.21 {asterisks, question marks, and brackets} {
................................................................................
    glob /
} /
test filename-14.24 {slash globbing} {pcOnly} {
    glob {\\}
} /

# The following tests are only valid for Unix systems.

if {$tcl_platform(platform) == "unix"} {
    # On some systems, like AFS, "000" protection doesn't prevent
    # access by owner, so the following test is not portable.

    exec chmod 000 globTest/a1
    test filename-15.1 {unix specific globbing} {nonPortable} {
	string tolower [list [catch {glob globTest/a1/*} msg]  $msg $errorCode]
    } {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}}
    test filename-15.2 {unix specific no complain: no errors} {nonPortable} {
	glob -nocomplain globTest/a1/*
    } {}
    test filename-15.3 {unix specific no complain: no errors, good result} {nonPortable knownBug} {

	# test fails because if an error occur , the interp's result
	# is reset...
	glob -nocomplain globTest/a2 globTest/a1/* globTest/a3
    } {globTest/a2 globTest/a3}

    exec chmod 755 globTest/a1
    test filename-15.4 {unix specific no complain: no errors, good result} {nonPortable knownBug} {

	# test fails because if an error occur , the interp's result
	# is reset... (or you don't run at sunscript where the
	# outser and demailly's users exists
	glob -nocomplain ~ouster ~foo ~demailly
    } {/home/ouster /home/demailly}
    test filename-15.5 {unix specific globbing} {nonPortable} {
	glob ~ouster/.csh*
    } "/home/ouster/.cshrc"
    close [open globTest/odd\\\[\]*?\{\}name w]
    test filename-15.6 {unix specific globbing} {
	global env
	set temp $env(HOME)
	set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name
	set result [list [catch {glob ~} msg] $msg]
	set env(HOME) $temp
	set result
    } [list 0 [list [glob ~]/globTest/odd\\\[\]*?\{\}name]]
    exec rm -f globTest/odd\\\[\]*?\{\}name
}

# The following tests are only valid for Windows systems.

if {$tcl_platform(platform) == "windows"} {
    set temp [pwd]
    cd c:/
    catch {

	removeDirectory globTest
	makeDirectory globTest
	close [open globTest/x1.BAT w]
	close [open globTest/y1.Bat w]
	close [open globTest/z1.bat w]
    }
    
    test filename-16.1 {windows specific globbing} {!win32s} {
	lsort [glob globTest/*.bat]
    } {globTest/x1.BAT globTest/y1.Bat globTest/z1.bat}
    test filename-16.1 {windows specific globbing} {win32s} {
	lsort [glob globTest/*.bat]
    } {globTest/x1.bat globTest/y1.bat globTest/z1.bat}
    test filename-16.2 {windows specific globbing} {
	glob c:
    } c:
    test filename-16.3 {windows specific globbing} {
	glob c:\\\\
	} c:/
    test filename-16.4 {windows specific globbing} {
	glob c:/
    } c:/
    test filename-16.5 {windows specific globbing} {!win32s} {
	glob c:*Test
    } c:globTest
    test filename-16.5 {windows specific globbing} {win32s} {
	glob c:*Test
    } c:globtest
    test filename-16.6 {windows specific globbing} {!win32s} {
	glob c:\\\\*Test
    } c:/globTest
    test filename-16.6 {windows specific globbing} {win32s} {
	glob c:\\\\*Test
    } c:/globtest
    test filename-16.7 {windows specific globbing} {!win32s} {
	glob c:/*Test
    } c:/globTest
    test filename-16.7 {windows specific globbing} {win32s} {
	glob c:/*Test
    } c:/globtest
    test filename-16.8 {windows specific globbing} {!win32s} {
	lsort [glob c:globTest/*.bat]
    } {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat}
    test filename-16.8 {windows specific globbing} {win32s} {
	lsort [glob c:globTest/*.bat]
    } {c:globTest/x1.bat c:globTest/y1.bat c:globTest/z1.bat}
    test filename-16.9 {windows specific globbing} {!win32s} {
	lsort [glob c:/globTest/*.bat]
    } {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat}
    test filename-16.9 {windows specific globbing} {win32s} {
	lsort [glob c:/globTest/*.bat]
    } {c:/globTest/x1.bat c:/globTest/y1.bat c:/globTest/z1.bat}
    test filename-16.10 {windows specific globbing} {!win32s} {
	lsort [glob c:globTest\\\\*.bat]
    } {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat}
    test filename-16.10 {windows specific globbing} {win32s} {
	lsort [glob c:globTest\\\\*.bat]
    } {c:globTest/x1.bat c:globTest/y1.bat c:globTest/z1.bat}
    test filename-16.11 {windows specific globbing} {!win32s} {
	lsort [glob c:\\\\globTest\\\\*.bat]
    } {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat}
    test filename-16.11 {windows specific globbing} {win32s} {
	lsort [glob c:\\\\globTest\\\\*.bat]
    } {c:/globTest/x1.bat c:/globTest/y1.bat c:/globTest/z1.bat}


    removeDirectory globTest

    if {($::test::testConfig(nonPortable) != 0) && [catch {cd //gaspode/d}] == 0} {
	removeDirectory globTest
	makeDirectory globTest

	close [open globTest/x1.BAT w]
	close [open globTest/y1.Bat w]
	close [open globTest/z1.bat w]





	test filename-16.12 {windows specific globbing} {
	    glob //gaspode/d/*Test
	} //gaspode/d/globTest
	test filename-16.13 {windows specific globbing} {
	    glob {\\\\gaspode\\d\\*Test}
	} //gaspode/d/globTest

	removeDirectory globTest
    }	    

    cd $temp
}

# cleanup
removeDirectory globTest

set env(HOME) $oldhome
testsetplatform $platform
catch {unset oldhome platform temp result}
::test::cleanupTests
return

# This file tests the filename manipulation routines.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# 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.1.2.4 1999/03/23 20:06:22 hershey Exp $

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."
    return 
} 

................................................................................
close [open globTest/x1.c w]
close [open globTest/y1.c w]
close [open globTest/z1.c w]
close [open "globTest/weird name.c" w]
close [open globTest/a1/b1/x2.c w]
close [open globTest/a1/b2/y2.c w]





catch {close [open globTest/.1 w]}
catch {close [open globTest/x,z1.c w]}

test filename-11.14 {Tcl_GlobCmd} {
    list [catch {glob ~/globTest} msg] $msg
} [list 0 [list [file join $env(HOME) globTest]]]
test filename-11.15 {Tcl_GlobCmd} {
................................................................................
} "0 $globPreResult$x1"
test filename-13.7 {globbing with brace substitution} {
    list [catch {glob globTest/\{x\}1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-13.8 {globbing with brace substitution} {
    list [catch {glob globTest/\{x\{\}\}1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-13.9 {globbing with brace substitution} {
    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} {
    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} {
    list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg
} {0 {globTest/x1.c globTest/x,z1.c globTest/z1.c}}
test filename-13.12 {globbing with brace substitution} {macOnly} {
    list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg
} {0 {:globTest:x1.c :globTest:x,z1.c :globTest:z1.c}}
test filename-13.13 {globbing with brace substitution} {
    lsort [glob globTest/{a,b,x,y}1.c]
................................................................................
test filename-13.21 {globbing with brace substitution} {macOnly} {
    lsort [glob globTest/{a,x}1/*/{x,y}*]
} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c}
test filename-13.22 {globbing with brace substitution} {
    list [catch {glob globTest/\{a,x\}1/*/\{} msg] $msg
} {1 {unmatched open-brace in file name}}

test filename-14.1 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob g*/*.c]
} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}



test filename-14.2 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob g*/*.c]
} {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob globTest/?1.c]
} {globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.4 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob globTest/?1.c]
} {:globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc} {
    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} {
    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.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} {
    lsort [glob globTest/.*]
} {globTest/. globTest/.. globTest/.1}



test filename-14.10 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob globTest/.*]
} {:globTest:.1}
test filename-14.11 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob globTest/*/*]
} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3}
test filename-14.12 {asterisks, question marks, and brackets} {macOnly} {
................................................................................
    global env
    set temp $env(HOME)
    set env(HOME) [file join $env(HOME) globTest]
    set result [list [catch {glob ~/z*} msg] $msg]
    set env(HOME) $temp
    set result
} [list 0 [list [file join $env(HOME) globTest z1.c]]]
test filename-14.18 {asterisks, question marks, and brackets} {unixOrPc} {
    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.19 {asterisks, question marks, and brackets} {macOnly} {
    list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg
} {0 {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}}
test filename-14.20 {asterisks, question marks, and brackets} {
    list [catch {glob -nocomplain goo/*} msg] $msg
} {0 {}}
test filename-14.21 {asterisks, question marks, and brackets} {
................................................................................
    glob /
} /
test filename-14.24 {slash globbing} {pcOnly} {
    glob {\\}
} /

# 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.

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}

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.


set temp [pwd]
catch {cd c:/}
catch {
    cd c:/
    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} {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}




catch {
    removeDirectory globTest



    makeDirectory globTest

    close [open globTest/x1.BAT w]
    close [open globTest/y1.Bat w]
    close [open globTest/z1.bat w]
}

# the following tests rely upon the //gaspode/d directory's existence
set ::tcltest::testConfig(gaspodeExists) [expr {[catch {cd //gaspode/d}] == 0}]

test filename-16.12 {windows specific globbing} {pcOnly nonPortable gaspodeExists} {
    glob //gaspode/d/*Test
} //gaspode/d/globTest
test filename-16.13 {windows specific globbing} {pcOnly nonPortable gaspodeExists} {
    glob {\\\\gaspode\\d\\*Test}
} //gaspode/d/globTest







# cleanup
removeDirectory globTest
cd $temp
set env(HOME) $oldhome
testsetplatform $platform
catch {unset oldhome platform temp result}
::tcltest::cleanupTests
return

#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for-old.test,v 1.1.2.3 1999/03/11 18:49:38 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}

# Check "for" and its use of continue and break.

catch {unset a i}
test for-old-1.1 {for tests} {
................................................................................
    for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} {
	set a [concat $a $i]
    }
    set a
} {1 2 3}

# cleanup
::test::cleanupTests
return

#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for-old.test,v 1.1.2.4 1999/03/23 20:06:23 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}

# Check "for" and its use of continue and break.

catch {unset a i}
test for-old-1.1 {for tests} {
................................................................................
    for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} {
	set a [concat $a $i]
    }
    set a
} {1 2 3}

# cleanup
::tcltest::cleanupTests
return

# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for.test,v 1.1.2.3 1999/03/11 18:49:38 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}

# Basic "for" operation.

test for-1.1 {TclCompileForCmd: missing initial command} {
    list [catch {for} msg] $msg
................................................................................
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
} {}

# cleanup
::test::cleanupTests
return

# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for.test,v 1.1.2.4 1999/03/23 20:06:24 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}

# Basic "for" operation.

test for-1.1 {TclCompileForCmd: missing initial command} {
    list [catch {for} msg] $msg
................................................................................
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
} {}

# cleanup
::tcltest::cleanupTests
return

#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: foreach.test,v 1.1.2.3 1999/03/11 18:49:39 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}

catch {unset a}
catch {unset x}

# Basic "foreach" operation.
................................................................................
    catch {break foo} msg
    set msg
} {wrong # args: should be "break"}

# cleanup
catch {unset a}
catch {unset x}
::test::cleanupTests
return

#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: foreach.test,v 1.1.2.4 1999/03/23 20:06:25 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}

catch {unset a}
catch {unset x}

# Basic "foreach" operation.
................................................................................
    catch {break foo} msg
    set msg
} {wrong # args: should be "break"}

# cleanup
catch {unset a}
catch {unset x}
::tcltest::cleanupTests
return

#
# Copyright (c) 1991-1994 The Regents of the University of California.
# 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.1.2.4 1999/03/11 18:49:39 hershey Exp $

if {[info commands test] != "test"} {
    source defs
}

# The following code is needed because some versions of SCO Unix have
# a round-off error in sprintf which would cause some of the tests to
................................................................................
}

# cleanup
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
::test::cleanupTests
return

#
# Copyright (c) 1991-1994 The Regents of the University of California.
# 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.1.2.5 1999/03/23 20:06:25 hershey Exp $

if {[info commands test] != "test"} {
    source defs
}

# The following code is needed because some versions of SCO Unix have
# a round-off error in sprintf which would cause some of the tests to
................................................................................
}

# cleanup
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:49:40 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test get-1.1 {Tcl_GetInt procedure} {
    set x 44
    incr x { 	  22}
} {66}
................................................................................
    list [catch {format %g clip} msg] $msg
} {1 {expected floating-point number but got "clip"}}
test get-2.4 {Tcl_GetInt procedure} {nonPortable} {
    list [catch {format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001} msg] $msg $errorCode
} {1 {floating-point value too small to represent} {ARITH UNDERFLOW {floating-point value too small to represent}}}

# cleanup
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:26 hershey Exp $

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
    incr x { 	  22}
} {66}
................................................................................
    list [catch {format %g clip} msg] $msg
} {1 {expected floating-point number but got "clip"}}
test get-2.4 {Tcl_GetInt procedure} {nonPortable} {
    list [catch {format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001} msg] $msg $errorCode
} {1 {floating-point value too small to represent} {ARITH UNDERFLOW {floating-point value too small to represent}}}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:40 hershey Exp $
  
if {[catch {history}]} {
    puts stdout "This version of Tcl was built without the history command;\n"
    puts stdout "history tests will be skipped.\n"
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set num [history nextid]
history keep 3
history add {set a 12345}
history add {set b [format {A test %s} string]}
................................................................................
test history-9.1 {miscellaneous} {catch {history gorp} msg} 1
test history-9.2 {miscellaneous} {
    catch {history gorp} msg
    set msg
} {bad option "gorp": must be add, change, clear, event, info, keep, nextid, or redo}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:26 hershey Exp $
  
if {[catch {history}]} {
    puts stdout "This version of Tcl was built without the history command;\n"
    puts stdout "history tests will be skipped.\n"
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set num [history nextid]
history keep 3
history add {set a 12345}
history add {set b [format {A test %s} string]}
................................................................................
test history-9.1 {miscellaneous} {catch {history gorp} msg} 1
test history-9.2 {miscellaneous} {
    catch {history gorp} msg
    set msg
} {bad option "gorp": must be add, change, clear, event, info, keep, nextid, or redo}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.4 1999/03/11 18:49:41 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {package require http 2.0}]} {
    if {[info exist http2]} {
	catch {puts "Cannot load http 2.0 package"}
	return
................................................................................
if {[info exists httpthread]} {
    testthread send -async $httpthread {
	testthread exit
    }
} else {
    close $listen
}
::test::cleanupTests
return

# 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.1.2.5 1999/03/23 20:06:27 hershey Exp $

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 "Cannot load http 2.0 package"}
	return
................................................................................
if {[info exists httpthread]} {
    testthread send -async $httpthread {
	testthread exit
    }
} else {
    close $listen
}
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:41 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {package require http 1.0}]} {
    if {[info exist httpold]} {
	catch {puts "Cannot load http 1.0 package"}
	return
................................................................................
<h2>GET http://$url</h2>
</body></html>"

# cleanup
unset url
unset port
close $listen
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:27 hershey 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 "Cannot load http 1.0 package"}
	return
................................................................................
<h2>GET http://$url</h2>
</body></html>"

# cleanup
unset url
unset port
close $listen
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:42 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test if-old-1.1 {taking proper branch} {
    set a {}
    if 0 {set a 1} else {set a 2}
    set a
................................................................................
    list [catch {if 0 then foo elseif 0 bar els} msg] $msg
} {1 {invalid command name "els"}}
test if-old-4.11 {error conditions} {
    list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg
} {1 {error in else clause}}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:28 hershey Exp $

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 {}
    if 0 {set a 1} else {set a 2}
    set a
................................................................................
    list [catch {if 0 then foo elseif 0 bar els} msg] $msg
} {1 {invalid command name "els"}}
test if-old-4.11 {error conditions} {
    list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg
} {1 {error in else clause}}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.4 1999/03/11 18:49:42 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Basic "if" operation.

catch {unset a}
test if-1.1 {TclCompileIfCmd: missing if/elseif test} {
................................................................................
} def

test if-9.1 {if cmd with namespace qualifiers} {
    ::if {1} {set x 4}
} 4

# cleanup
::test::cleanupTests
return

#
# 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.1.2.5 1999/03/23 20:06:28 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Basic "if" operation.

catch {unset a}
test if-1.1 {TclCompileIfCmd: missing if/elseif test} {
................................................................................
} def

test if-9.1 {if cmd with namespace qualifiers} {
    ::if {1} {set x 4}
} 4

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:43 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}

test incr-old-1.1 {basic incr operation} {
    set x 23
................................................................................
} {1 {expected integer but got "+"}}
test incr-old-2.10 {incr errors} {
    set x {20 x}
    list [catch {incr x 1} msg] $msg
} {1 {expected integer but got "20 x"}}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:29 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}

test incr-old-1.1 {basic incr operation} {
    set x 23
................................................................................
} {1 {expected integer but got "+"}}
test incr-old-2.10 {incr errors} {
    set x {20 x}
    list [catch {incr x 1} msg] $msg
} {1 {expected integer but got "20 x"}}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:49:43 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Basic "incr" operation.

catch {unset x}
catch {unset i}
................................................................................
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
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:29 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Basic "incr" operation.

catch {unset x}
catch {unset i}
................................................................................
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

#
# 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.1.2.3 1999/03/11 18:49:44 hershey Exp $

if {[info commands testindexobj] == {}} {
    puts "This application hasn't been compiled with the \"testindexobj\""
    puts "command, so I can't test Tcl_GetIndexFromObj etc."
    return 
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test indexObj-1.1 {exact match} {
    testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} {
................................................................................
test indexObj-4.1 {free old internal representation} {
    set x {a b}
    lindex $x 1
    testindexobj 1 1 $x abc def {a b} zzz
} {2}

# cleanup
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:30 hershey Exp $

if {[info commands testindexobj] == {}} {
    puts "This application hasn't been compiled with the \"testindexobj\""
    puts "command, so I can't test Tcl_GetIndexFromObj etc."
    return 
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test indexObj-1.1 {exact match} {
    testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} {
................................................................................
test indexObj-4.1 {free old internal representation} {
    set x {a b}
    lindex $x 1
    testindexobj 1 1 $x abc def {a b} zzz
} {2}

# cleanup
::tcltest::cleanupTests
return

# 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: info.test,v 1.1.2.3 1999/03/11 18:49:45 hershey Exp $

if {[lsearch [namespace children] ::test] == -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_info2 {
        namespace import ::test_ns_info1::*
        proc r {} {}
        list [info procs] [info procs p*]
    }
} {{p q r} p}

set self info.test
if {$tcl_platform(os) == "Win32s"} {
    set self info~1.tes
}

test info-16.1 {info script option} {
    list [catch {info script x} msg] $msg
} {1 {wrong # args: should be "info script"}}
test info-16.2 {info script option} {
    file tail [info sc]
} $self
removeFile gorp.info
makeFile "info script\n" gorp.info
test info-16.3 {info script option} {
    list [source gorp.info] [file tail [info script]]
} [list gorp.info $self]
test info-16.4 {resetting "info script" after errors} {
    catch {source ~_nobody_/foo}
    file tail [info script]
} $self
test info-16.5 {resetting "info script" after errors} {
    catch {source _nonexistent_}
    file tail [info script]
} $self
removeFile gorp.info

test info-17.1 {info sharedlibextension option} {
    list [catch {info sharedlibextension foo} msg] $msg
} {1 {wrong # args: should be "info sharedlibextension"}}

test info-18.1 {info tclversion option} {
................................................................................
} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-20.5 {miscellaneous error conditions} {
    list [catch {info s} msg] $msg
} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}

# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::test::cleanupTests
return

# 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: info.test,v 1.1.2.4 1999/03/23 20:06:30 hershey 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_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]
} "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 info.test]
test info-16.4 {resetting "info script" after errors} {
    catch {source ~_nobody_/foo}
    file tail [info script]
} "info.test"
test info-16.5 {resetting "info script" after errors} {
    catch {source _nonexistent_}
    file tail [info script]
} "info.test"
removeFile gorp.info

test info-17.1 {info sharedlibextension option} {
    list [catch {info sharedlibextension foo} msg] $msg
} {1 {wrong # args: should be "info sharedlibextension"}}

test info-18.1 {info tclversion option} {
................................................................................
} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-20.5 {miscellaneous error conditions} {
    list [catch {info s} msg] $msg
} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}

# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:49:45 hershey Exp $

if {[lsearch [namespace children] ::test] == -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_*]}

# Six cases - white box testing
................................................................................


# we use a sub interp and auto_reset and double the tests because there is 2
# places where auto_loading occur (before loading the indexes files and after)

set testInterp [interp create]
interp eval $testInterp [list set argv $argv]
interp eval $testInterp [list source [file join $::test::testsDir defs.tcl]]

interp eval $testInterp {

if {[string compare test [info procs test]] == 1} then {source defs}

auto_reset
catch {rename parray {}}

test init-2.0 {load parray - stage 1} {
    set ret [catch {namespace eval ::test {parray}} error]
    rename parray {} ; # remove it, for the next test - that should not fail.
    list $ret $error
} {1 {no value given for parameter "a" to "parray"}}


test init-2.1 {load parray - stage 2} {
    set ret [catch {namespace eval ::test {parray}} error]
    list $ret $error
} {1 {no value given for parameter "a" to "parray"}}


auto_reset
catch {rename ::safe::setLogCmd {}}
#unset auto_index(::safe::setLogCmd)
................................................................................

auto_reset
package require http 2.0
catch {rename ::http::geturl {}}

test init-2.8 {load http::geturl (package)} {
    # 3 ':' on purpose
    set ret [catch {namespace eval ::test {http:::geturl}} error]
    # removing it, for the next test. should not fail.
    rename ::http::geturl {} ; 
    list $ret $error
} {1 {no value given for parameter "url" to "http:::geturl"}}


test init-3.0 {random stuff in the auto_index, should still work} {
................................................................................
    foo:::bar::blah
} 1

}

# cleanup
interp delete $testInterp
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:30 hershey Exp $

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_*]}

# Six cases - white box testing
................................................................................


# we use a sub interp and auto_reset and double the tests because there is 2
# places where auto_loading occur (before loading the indexes files and after)

set testInterp [interp create]
interp eval $testInterp [list set 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}

auto_reset
catch {rename parray {}}

test init-2.0 {load parray - stage 1} {
    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 ::tcltest {parray}} error]
    list $ret $error
} {1 {no value given for parameter "a" to "parray"}}


auto_reset
catch {rename ::safe::setLogCmd {}}
#unset auto_index(::safe::setLogCmd)
................................................................................

auto_reset
package require http 2.0
catch {rename ::http::geturl {}}

test init-2.8 {load http::geturl (package)} {
    # 3 ':' on purpose
    set ret [catch {namespace eval ::tcltest {http:::geturl}} error]
    # removing it, for the next test. should not fail.
    rename ::http::geturl {} ; 
    list $ret $error
} {1 {no value given for parameter "url" to "http:::geturl"}}


test init-3.0 {random stuff in the auto_index, should still work} {
................................................................................
    foo:::bar::blah
} 1

}

# cleanup
interp delete $testInterp
::tcltest::cleanupTests
return

#
# 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: interp.test,v 1.1.2.6 1999/03/11 18:49:46 hershey Exp $

if {[lsearch [namespace children] ::test] == -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}
................................................................................
    lappend l [interp hidden a]
    a alias bar {}
    lappend l [interp aliases a]
    lappend l [interp hidden a]
    interp delete a
    set l
} {{} bar {} bar bar {} {}}
test interp-23.2 {testing hiding vs aliases} {pc || unix} {
    catch {interp delete a}
    interp create a -safe
    set l ""
    lappend l [lsort [interp hidden a]]
    a alias bar bar
    lappend l [interp aliases a]
    lappend l [lsort [interp hidden a]]
................................................................................
#     set res [list [interp eval $i {namespace eval test {bar test1}}]]
#     $i hide test::bar;
#     $i alias test::bar mfoo::bar $i;
#     set res [concat $res [interp eval $i {test::bar test2}]];
#     namespace delete mfoo;
#     interp delete $i;
#     set res
# } {{slave bar called (foo-slave) (bar test1) (::test) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}}

#test interp-27.8 {hiding, namespaces and integrity} {
#    namespace eval foo {
#	variable v 3;
#	proc bar {} {variable v; set v}
#	# next command would currently generate an unknown command "bar" error.
#	interp hide {} bar;
................................................................................
    $i alias ns::cmd {}
} {}

# cleanup
foreach i [interp slaves] {
  interp delete $i
}
::test::cleanupTests
return

#
# 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: interp.test,v 1.1.2.7 1999/03/23 20:06:31 hershey Exp $

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}
................................................................................
    lappend l [interp hidden a]
    a alias bar {}
    lappend l [interp aliases a]
    lappend l [interp hidden a]
    interp delete a
    set l
} {{} bar {} bar bar {} {}}
test interp-23.2 {testing hiding vs aliases} {unixOrPc} {
    catch {interp delete a}
    interp create a -safe
    set l ""
    lappend l [lsort [interp hidden a]]
    a alias bar bar
    lappend l [interp aliases a]
    lappend l [lsort [interp hidden a]]
................................................................................
#     set res [list [interp eval $i {namespace eval test {bar test1}}]]
#     $i hide test::bar;
#     $i alias test::bar mfoo::bar $i;
#     set res [concat $res [interp eval $i {test::bar test2}]];
#     namespace delete mfoo;
#     interp delete $i;
#     set res
# } {{slave bar called (foo-slave) (bar test1) (::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 {
#	variable v 3;
#	proc bar {} {variable v; set v}
#	# next command would currently generate an unknown command "bar" error.
#	interp hide {} bar;
................................................................................
    $i alias ns::cmd {}
} {}

# cleanup
foreach i [interp slaves] {
  interp delete $i
}
::tcltest::cleanupTests
return

# 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.1.2.8 1999/03/11 18:49:46 hershey Exp $

if {[lsearch [namespace children] ::test] == -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"
    puts "testchannel command that is needed to run these tests."
    return
}

::test::saveState

removeFile test1
removeFile pipe




# set up a long data file for some of the following tests

set f [open longfile w]
fconfigure $f -eofchar {} -translation lf
for { set i 0 } { $i < 100 } { incr i} {
    puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
\#123456789abcdef01
................................................................................
	    close $f
	    exit 0
	}
    }
    vwait forever
} cat

set thisScript [file join $::test::testsDir [info script]]

# These tests are disabled until we decide what to do with "unsupported0".
#
#test io-1.1 {unsupported0 command} {
#    removeFile test1
#    set f1 [open iocmd.test]
#    set f2 [open test1 w]
................................................................................
    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} {pc} {
    set f [open test1 w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} [list [list \x1a ""] {auto crlf}]
test io-20.3 {Tcl_CreateChannel: initial settings} {unix} {
    set f [open test1 w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} {{{} {}} {auto lf}}
test io-20.4 {Tcl_CreateChannel: initial settings} {mac} {
    set f [open test1 w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} {{{} {}} {auto cr}}
test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio} {
    set f [open script w]
................................................................................
    }
    lappend l [file size test1]
    flush $f
    lappend l [file size test1]
    close $f
    set l
} {0 60 72}
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 {}
    set l ""
    lappend l [file size test1]
    for {set i 0} {$i < 12} {incr i} {
	puts $f hello
    }
    lappend l [file size test1]
    close $f
    lappend l [file size test1]
    set l
} {0 60 72}
test io-27.6 {FlushChannel, async flushing, async close} {stdio && asyncPipeClose} {

    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {
	set f [open output w]
	fconfigure $f -translation lf -buffering none -eofchar {}
	while {![eof stdin]} {
................................................................................
    x eval close $f
    interp delete x
    set f [open test1 r]
    set l [gets $f]
    close $f
    set l
} abcdef
test io-28.3 {CloseChannel, not called before output queue is empty} {stdio asyncPipeClose nonPortable} {

    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {

	# Need to not have eof char appended on close, because the other
	# side of the pipe already closed, so that writing would cause an
................................................................................
    close $f
    after 100
    set f [open test3 r]
    set x [read $f]
    close $f
    set x
} "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
    set x [gets $f]
    close $f
    set x
} {Line1}
................................................................................
    }
    if {$counter == 1000} {
	set result "file size only [file size output]"
    } else {
	set result ok
    }
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader} {stdio && asyncPipeClose} {

    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {set f [open output w]}
    puts $f {fconfigure $f -translation lf}
    set x [list while {![eof stdin]}]
    set x "$x {"
................................................................................
    puts $f "line 1"
    close $f
    set f [open test3 r]
    lappend x [gets $f]
    close $f
    set x
} {0600 {line 1}}
test io-40.3 {POSIX open access modes: CREAT} {$::test::testConfig(unix) && ([exec umask] == 2)} {
    # This test only works if your umask is 2, like ouster's.
    removeFile test3
    set f [open test3 {WRONLY CREAT}]
    close $f
    file stat test3 stats
    format "0%o" [expr $stats(mode)&0777]
} 0664
................................................................................
    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 {$::test::testConfig(stdio) && $::test::testConfig(unixExecs)} {

catch {set f2 [open "|[list cat -u]" r+]}
catch {set f3 [open "|[list cat -u]" r+]}

test io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {
    set result {}
    fileevent $f readable "script 1"
    lappend result [fileevent $f readable] [fileevent $f writable]
    fileevent $f writable "write script"
    lappend result [fileevent $f readable] [fileevent $f writable]
    fileevent $f readable {}
    lappend result [fileevent $f readable] [fileevent $f writable]
    fileevent $f writable {}
    lappend result [fileevent $f readable] [fileevent $f writable]
} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
test io-43.2 {Tcl_FileeventCmd: deleting when many present} {
    set result {}
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
    fileevent $f r "read f"
    fileevent $f2 r "read f2"
    fileevent $f3 r "read f3"
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
    fileevent $f2 r {}
................................................................................
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
    fileevent $f3 r {}
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
    fileevent $f r {}
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
} {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}}

test io-44.1 {FileEventProc procedure: normal read event} {
    fileevent $f2 readable {
	set x [gets $f2]; fileevent $f2 readable {}
    }
    puts $f2 text; flush $f2
    set x initial
    vwait x
    set x
} {text}
test io-44.2 {FileEventProc procedure: error in read event} {
    proc bgerror args {
	global x
	set x $args
    }
    fileevent $f2 readable {error bogus}
    puts $f2 text; flush $f2
    set x initial
    vwait x
    rename bgerror {}
    list $x [fileevent $f2 readable]
} {bogus {}}
test io-44.3 {FileEventProc procedure: normal write event} {
    fileevent $f2 writable {
	lappend x "triggered"
	incr count -1
	if {$count <= 0} {
	    fileevent $f2 writable {}
	}
    }
................................................................................
    set x initial
    set count 3
    vwait x
    vwait x
    vwait x
    set x
} {initial triggered triggered triggered}
test io-44.4 {FileEventProc procedure: eror in write event} {
    proc bgerror args {
	global x
	set x $args
    }
    fileevent $f2 writable {error bad-write}
    set x initial
    vwait x
    rename bgerror {}
    list $x [fileevent $f2 writable]
} {bad-write {}}
test io-44.5 {FileEventProc procedure: end of file} {
    set f4 [open "|[list $tcltest cat << foo]" r]
    fileevent $f4 readable {
	if {[gets $f4 line] < 0} {
	    lappend x eof
	    fileevent $f4 readable {}
	} else {
	    lappend x $line
................................................................................
    close $f4
    set x
} {initial foo eof}

catch {close $f2}
catch {close $f3}

}
	# Closes if {($platform(platform) != "macintosh") && \
	#		($::test::testConfig(unixExecs) == 1)} clause

close $f
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {
    set f [open foo r]
    fileevent $f readable {
	lappend x "binding triggered: \"[gets $f]\""
................................................................................
    vwait x
    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] {
    ::test::removeFile $file
}
restoreState
::test::cleanupTests
return

# 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.1.2.9 1999/03/23 20:06:32 hershey Exp $

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"
    puts "testchannel command that is needed to run these tests."
    return
}

::tcltest::saveState

removeFile test1
removeFile pipe

# some tests can only be run is umask is 2
set ::tcltest::testConfig(umask2) [expr {[exec umask] == 2}]

# set up a long data file for some of the following tests

set f [open longfile w]
fconfigure $f -eofchar {} -translation lf
for { set i 0 } { $i < 100 } { incr i} {
    puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
\#123456789abcdef01
................................................................................
	    close $f
	    exit 0
	}
    }
    vwait forever
} cat

set thisScript [file join $::tcltest::testsDir [info script]]

# These tests are disabled until we decide what to do with "unsupported0".
#
#test io-1.1 {unsupported0 command} {
#    removeFile test1
#    set f1 [open iocmd.test]
#    set f2 [open test1 w]
................................................................................
    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]
................................................................................
    }
    lappend l [file size test1]
    flush $f
    lappend l [file size test1]
    close $f
    set l
} {0 60 72}
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 {}
    set l ""
    lappend l [file size test1]
    for {set i 0} {$i < 12} {incr i} {
	puts $f hello
    }
    lappend l [file size test1]
    close $f
    lappend l [file size test1]
    set l
} {0 60 72}
test io-27.6 {FlushChannel, async flushing, async close} \
	{stdio asyncPipeClose} {
    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {
	set f [open output w]
	fconfigure $f -translation lf -buffering none -eofchar {}
	while {![eof stdin]} {
................................................................................
    x eval close $f
    interp delete x
    set f [open test1 r]
    set l [gets $f]
    close $f
    set l
} abcdef
test io-28.3 {CloseChannel, not called before output queue is empty} \
	{stdio asyncPipeClose nonPortable} {
    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {

	# Need to not have eof char appended on close, because the other
	# side of the pipe already closed, so that writing would cause an
................................................................................
    close $f
    after 100
    set f [open test3 r]
    set x [read $f]
    close $f
    set x
} "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
    set x [gets $f]
    close $f
    set x
} {Line1}
................................................................................
    }
    if {$counter == 1000} {
	set result "file size only [file size output]"
    } else {
	set result ok
    }
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
	{stdio asyncPipeClose} {
    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {set f [open output w]}
    puts $f {fconfigure $f -translation lf}
    set x [list while {![eof stdin]}]
    set x "$x {"
................................................................................
    puts $f "line 1"
    close $f
    set f [open test3 r]
    lappend x [gets $f]
    close $f
    set x
} {0600 {line 1}}
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}]
    close $f
    file stat test3 stats
    format "0%o" [expr $stats(mode)&0777]
} 0664
................................................................................
    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
#



catch {set f2 [open "|[list cat -u]" r+]}
catch {set f3 [open "|[list cat -u]" r+]}

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]
    fileevent $f writable "write script"
    lappend result [fileevent $f readable] [fileevent $f writable]
    fileevent $f readable {}
    lappend result [fileevent $f readable] [fileevent $f writable]
    fileevent $f writable {}
    lappend result [fileevent $f readable] [fileevent $f writable]
} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
test io-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"
    fileevent $f2 r "read f2"
    fileevent $f3 r "read f3"
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
    fileevent $f2 r {}
................................................................................
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
    fileevent $f3 r {}
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
    fileevent $f r {}
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
} {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}}

test io-44.1 {FileEventProc procedure: normal read event} {stdio unixExecs} {
    fileevent $f2 readable {
	set x [gets $f2]; fileevent $f2 readable {}
    }
    puts $f2 text; flush $f2
    set x initial
    vwait x
    set x
} {text}
test io-44.2 {FileEventProc procedure: error in read event} {stdio unixExecs} {
    proc bgerror args {
	global x
	set x $args
    }
    fileevent $f2 readable {error bogus}
    puts $f2 text; flush $f2
    set x initial
    vwait x
    rename bgerror {}
    list $x [fileevent $f2 readable]
} {bogus {}}
test io-44.3 {FileEventProc procedure: normal write event} {stdio unixExecs} {
    fileevent $f2 writable {
	lappend x "triggered"
	incr count -1
	if {$count <= 0} {
	    fileevent $f2 writable {}
	}
    }
................................................................................
    set x initial
    set count 3
    vwait x
    vwait x
    vwait x
    set x
} {initial triggered triggered triggered}
test io-44.4 {FileEventProc procedure: eror in write event} {stdio unixExecs} {
    proc bgerror args {
	global x
	set x $args
    }
    fileevent $f2 writable {error bad-write}
    set x initial
    vwait x
    rename bgerror {}
    list $x [fileevent $f2 writable]
} {bad-write {}}
test io-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} {
	    lappend x eof
	    fileevent $f4 readable {}
	} else {
	    lappend x $line
................................................................................
    close $f4
    set x
} {initial foo eof}

catch {close $f2}
catch {close $f3}





close $f
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {
    set f [open foo r]
    fileevent $f readable {
	lappend x "binding triggered: \"[gets $f]\""
................................................................................
    vwait x
    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

# 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.1.2.4 1999/03/11 18:49:47 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

removeFile test1
removeFile pipe

set executable [list [info nameofexecutable]]
................................................................................
test iocmd-8.18 {fconfigure command / unix tty channel} {nonPortable unixOnly} {
	# might fail if /dev/ttya is unavailable
	set tty [open /dev/ttya]
	set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
	close $tty;
	set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}}
test iocmd-8.19 {fconfigure command / win tty channel} {pcOnly && !win32s} {
	# None of the com port functions are implemented on Win32s.
	# Also, might fail if com1 is unavailable
	set tty [open com1]
	set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
	close $tty;
	set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}}

test iocmd-9.1 {eof command} {
................................................................................
} {1 {expected integer but got "foo"}}

close $rfile
close $wfile

# cleanup
foreach file [list test1 test2 test3 test4] {
    ::test::removeFile $file
}
# delay long enough for background processes to finish
after 500
foreach file [list test5 pipe output] {
    ::test::removeFile $file
}
::test::cleanupTests
return

# 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.1.2.5 1999/03/23 20:06:33 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

removeFile test1
removeFile pipe

set executable [list [info nameofexecutable]]
................................................................................
test iocmd-8.18 {fconfigure command / unix tty channel} {nonPortable unixOnly} {
	# might fail if /dev/ttya is unavailable
	set tty [open /dev/ttya]
	set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
	close $tty;
	set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}}
test iocmd-8.19 {fconfigure command / win tty channel} {pcOnly} {

	# might fail if com1 is unavailable
	set tty [open com1]
	set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
	close $tty;
	set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}}

test iocmd-9.1 {eof command} {
................................................................................
} {1 {expected integer but got "foo"}}

close $rfile
close $wfile

# cleanup
foreach file [list test1 test2 test3 test4] {
    ::tcltest::removeFile $file
}
# delay long enough for background processes to finish
after 500
foreach file [list test5 pipe output] {
    ::tcltest::removeFile $file
}
::tcltest::cleanupTests
return

# errors. No output means no errors were found. 
# 
# 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.1.2.4 1999/03/11 18:49:48 hershey Exp $
 
if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set unsetScript {
    catch {unset testStat1(size)}
    catch {unset testStat2(size)}
    catch {unset testStat3(size)}
................................................................................
    catch {testopenfilechannelproc delete TestOpenFileChannelProc3} err11

    list $err9 $err10 $err11
} {{"TestOpenFileChannelProc1": could not be deleteed} {"TestOpenFileChannelProc2": could not be deleteed} {"TestOpenFileChannelProc3": could not be deleteed}}
}

# cleanup
::test::cleanupTests
return

# errors. No output means no errors were found. 
# 
# 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.1.2.5 1999/03/23 20:06:33 hershey Exp $
 
if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set unsetScript {
    catch {unset testStat1(size)}
    catch {unset testStat2(size)}
    catch {unset testStat3(size)}
................................................................................
    catch {testopenfilechannelproc delete TestOpenFileChannelProc3} err11

    list $err9 $err10 $err11
} {{"TestOpenFileChannelProc1": could not be deleteed} {"TestOpenFileChannelProc2": could not be deleteed} {"TestOpenFileChannelProc3": could not be deleteed}}
}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:48 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test join-1.1 {basic join commands} {
    join {a b c} xyz
} axyzbxyzc
test join-1.2 {basic join commands} {
................................................................................
} 9

test join-3.2 {join is binary ok} {
  string length [join "a\0b a\0b a\0b"]
} 11

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:34 hershey Exp $

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
} axyzbxyzc
test join-1.2 {basic join commands} {
................................................................................
} 9

test join-3.2 {join is binary ok} {
  string length [join "a\0b a\0b a\0b"]
} 11

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:49 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test lindex-1.1 {basic tests} {
    lindex {a b c} 0} a
test lindex-1.2 {basic tests} {
    lindex {a {b c d} x} 1} {b c d}
................................................................................
    lindex {ab "c d \" x" y} 1
} {c d " x}
test lindex-3.4 {quoted elements} {
    lindex {a b {c d "e} {f g"}} 2
} {c d "e}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:34 hershey Exp $

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
test lindex-1.2 {basic tests} {
    lindex {a {b c d} x} 1} {b c d}
................................................................................
    lindex {ab "c d \" x" y} 1
} {c d " x}
test lindex-3.4 {quoted elements} {
    lindex {a b {c d "e} {f g"}} 2
} {c d "e}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:49 hershey Exp $

if {[info commands testlink] == {}} {
    puts "This application hasn't been compiled with the \"testlink\""
    puts "command, so I can't test Tcl_LinkVar et al."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

foreach i {int real bool string} {
    catch {unset $i}
}
test link-1.1 {reading C variables from Tcl} {
................................................................................
testlink set 0 0 0 -
testlink delete
foreach i {int real bool string} {
    catch {unset $i}
}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:35 hershey Exp $

if {[info commands testlink] == {}} {
    puts "This application hasn't been compiled with the \"testlink\""
    puts "command, so I can't test Tcl_LinkVar et al."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

foreach i {int real bool string} {
    catch {unset $i}
}
test link-1.1 {reading C variables from Tcl} {
................................................................................
testlink set 0 0 0 -
testlink delete
foreach i {int real bool string} {
    catch {unset $i}
}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:50 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset lis}
catch {rename p ""}

test linsert-1.1 {linsert command} {
................................................................................
    set lis [format "a \"%s\" c" "b"]
    linsert $lis 0 [string length $lis]
} "7 a b c"

# cleanup
catch {unset lis}
catch {rename p ""}
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:35 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset lis}
catch {rename p ""}

test linsert-1.1 {linsert command} {
................................................................................
    set lis [format "a \"%s\" c" "b"]
    linsert $lis 0 [string length $lis]
} "7 a b c"

# cleanup
catch {unset lis}
catch {rename p ""}
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:51 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# First, a bunch of individual tests

test list-1.1 {basic tests} {list a b c} {a b c}
test list-1.2 {basic tests} {list {a b} c} {{a b} c}
................................................................................
    return [concat $result $list]
}
test list-3.1 {SetListFromAny and lrange/concat results} {
    slowsort {fred julie alex carol bill annie}
} {alex annie bill carol fred julie}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:36 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# First, a bunch of individual tests

test list-1.1 {basic tests} {list a b c} {a b c}
test list-1.2 {basic tests} {list {a b} c} {{a b} c}
................................................................................
    return [concat $result $list]
}
test list-3.1 {SetListFromAny and lrange/concat results} {
    slowsort {fred julie alex carol bill annie}
} {alex annie bill carol fred julie}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:49:51 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} {
    set t [testobj types]
    set first [string first "list" $t]
................................................................................
} "foo\x00help"

test listobj-9.1 {UpdateStringOfList} {
    string length [list foo\x00help]
} 8

# cleanup
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:36 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} {
    set t [testobj types]
    set first [string first "list" $t]
................................................................................
} "foo\x00help"

test listobj-9.1 {UpdateStringOfList} {
    string length [list foo\x00help]
} 8

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:52 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test llength-1.1 {length of list} {
    llength {a b c d}
} 4
test llength-1.2 {length of list} {
................................................................................
    list [catch {llength 123 2} msg] $msg
} {1 {wrong # args: should be "llength list"}}
test llength-2.3 {error conditions} {
    list [catch {llength "a b c \{"} msg] $msg
} {1 {unmatched open brace in list}}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:37 hershey Exp $

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}
} 4
test llength-1.2 {length of list} {
................................................................................
    list [catch {llength 123 2} msg] $msg
} {1 {wrong # args: should be "llength list"}}
test llength-2.3 {error conditions} {
    list [catch {llength "a b c \{"} msg] $msg
} {1 {unmatched open brace in list}}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.4 1999/03/11 18:49:52 hershey Exp $

if {[lsearch [namespace children] ::test] == -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"} {
................................................................................
	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
::test::cleanupTests
return

#
# 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.1.2.5 1999/03/23 20:06:38 hershey Exp $

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"} {
................................................................................
	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

# 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.1.2.3 1999/03/11 18:49:53 hershey Exp $

if {[lsearch [namespace children] ::test] == -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
} {b c}
test lrange-1.2 {range of list elements} {
................................................................................
    list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-2.6 {error conditions} {
    list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:39 hershey Exp $

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
} {b c}
test lrange-1.2 {range of list elements} {
................................................................................
    list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-2.6 {error conditions} {
    list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:54 hershey Exp $

if {[lsearch [namespace children] ::test] == -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
} {a 2 3 4 5}
test lreplace-1.2 {lreplace command} {
................................................................................
        return "a b c"
    }
    p
} "a b c"

# cleanup
catch {unset foo}
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:39 hershey Exp $

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
} {a 2 3 4 5}
test lreplace-1.2 {lreplace command} {
................................................................................
        return "a b c"
    }
    p
} "a b c"

# cleanup
catch {unset foo}
::tcltest::cleanupTests
return

# 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.1.2.4 1999/03/11 18:49:54 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set x {abcd bbcd 123 234 345}
test lsearch-1.1 {lsearch command} {
    lsearch $x 123
} 2
................................................................................
    set x one
    append x \x00
    append x two
    lsearch -exact [list foo one\000two bar] $x
} 1

# cleanup
::test::cleanupTests
return

# 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.1.2.5 1999/03/23 20:06:40 hershey Exp $

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} {
    lsearch $x 123
} 2
................................................................................
    set x one
    append x \x00
    append x two
    lsearch -exact [list foo one\000two bar] $x
} 1

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:49:54 hershey Exp $
#

if {$tcl_platform(platform) != "macintosh"} {
    puts "skipping: Mac only tests..."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {file delete -force foo.dir}
file mkdir foo.dir
if {[catch {file attributes foo.dir -readonly 1}]} {
    set ::test::testConfig(fileSharing) 0
    set ::test::testConfig(notFileSharing) 1
} else {
    set ::test::testConfig(fileSharing) 1
    set ::test::testConfig(notFileSharing) 0
}
file delete -force foo.dir

test macFCmd-1.1 {GetFileFinderAttributes - no file} {
    catch {file delete -force foo.file}
    list [catch {file attributes foo.file -creator} msg] $msg
} {1 {couldn't get attributes for file ":foo.file": no such file or directory}}
test macFCmd-1.2 {GetFileFinderAttributes - creator} {
    catch {file delete -force foo.file}
    catch {close [open foo.file w]}
    list [catch {file attributes foo.file -creator} msg] $msg [file delete -force foo.file]

} {0 {MPW } {}}
test macFCmd-1.3 {GetFileFinderAttributes - type} {
    catch {file delete -force foo.file}
    catch {close [open foo.file w]}
    list [catch {file attributes foo.file -type} msg] $msg [file delete -force foo.file]

} {0 TEXT {}}
test macFCmd-1.4 {GetFileFinderAttributes - not hidden} {
    catch {file delete -force foo.file}
    catch {close [open foo.file w]}
    list [catch {file attributes foo.file -hidden} msg] $msg [file delete -force foo.file]

} {0 0 {}}
test macFCmd-1.5 {GetFileFinderAttributes - hidden} {
    catch {file delete -force foo.file}
    catch {close [open foo.file w]}
    file attributes foo.file -hidden 1
    list [catch {file attributes foo.file -hidden} msg] $msg [file delete -force foo.file]

} {0 1 {}}
test macFCmd-1.6 {GetFileFinderAttributes - folder creator} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -creator} msg] $msg [file delete -force foo.dir]

} {0 Fldr {}}
test macFCmd-1.7 {GetFileFinderAttributes - folder type} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -type} msg] $msg [file delete -force foo.dir]

} {0 Fldr {}}
test macFCmd-1.8 {GetFileFinderAttributes - folder hidden} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -hidden} msg] $msg [file delete -force foo.dir]

} {0 0 {}}

test macFCmd-2.1 {GetFileReadOnly - bad file} {
    catch {file delete -force foo.file}
    list [catch {file attributes foo.file -readonly} msg] $msg
} {1 {couldn't get attributes for file ":foo.file": no such file or directory}}
test macFCmd-2.2 {GetFileReadOnly - file not read only} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    list [catch {file attributes foo.file -readonly} msg] $msg [file delete -force foo.file]

} {0 0 {}}
test macFCmd-2.3 {GetFileReadOnly - file read only} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    file attributes foo.file -readonly 1
    list [catch {file attributes foo.file -readonly} msg] $msg [file delete -force foo.file]

} {0 1 {}}
test macFCmd-2.4 {GetFileReadOnly - directory not read only} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -readonly} msg] $msg [file delete -force foo.dir]

} {0 0 {}}
test macFCmd-2.5 {GetFileReadOnly - directory read only} {fileSharing} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    file attributes foo.dir -readonly 1
    list [catch {file attributes foo.dir -readonly} msg] $msg [file delete -force foo.dir]

} {0 1 {}}

test macFCmd-3.1 {SetFileFinderAttributes - bad file} {
    catch {file delete -force foo.file}
    list [catch {file attributes foo.file -creator FOOO} msg] $msg
} {1 {couldn't set attributes for file ":foo.file": no such file or directory}}
test macFCmd-3.2 {SetFileFinderAttributes - creator} {
    catch {file delete -force foo.file}
    close [open foo.file w]

    list [catch {file attributes foo.file -creator FOOO} msg] $msg [file attributes foo.file -creator] [file delete -force foo.file]
} {0 {} FOOO {}}
test macFCmd-3.3 {SetFileFinderAttributes - bad creator} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    list [catch {file attributes foo.file -creator 0} msg] $msg [file delete -force foo.file]

} {1 {expected Macintosh OS type but got "0"} {}}
test macFCmd-3.4 {SetFileFinderAttributes - hidden} {
    catch {file delete -force foo.file}
    close [open foo.file w]

    list [catch {file attributes foo.file -hidden 1} msg] $msg [file attributes foo.file -hidden] [file delete -force foo.file]
} {0 {} 1 {}}
test macFCmd-3.5 {SetFileFinderAttributes - type} {
    catch {file delete -force foo.file}
    close [open foo.file w]

    list [catch {file attributes foo.file -type FOOO} msg] $msg [file attributes foo.file -type] [file delete -force foo.file]
} {0 {} FOOO {}}
test macFCmd-3.6 {SetFileFinderAttributes - bad type} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    list [catch {file attributes foo.file -type 0} msg] $msg [file delete -force foo.file]

} {1 {expected Macintosh OS type but got "0"} {}}
test macFCmd-3.7 {SetFileFinderAttributes - directory} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -creator FOOO} msg] $msg [file delete -force foo.dir]

} {1 {cannot set -creator: ":foo.dir" is a directory} {}}

test macFCmd-4.1 {SetFileReadOnly - bad file} {
    catch {file delete -force foo.file}
    list [catch {file attributes foo.file -readonly 1} msg] $msg
} {1 {couldn't set attributes for file ":foo.file": no such file or directory}}
test macFCmd-4.2 {SetFileReadOnly - file not readonly} {
    catch {file delete -force foo.file}
    close [open foo.file w]

    list [catch {file attributes foo.file -readonly 0} msg] $msg [file attributes foo.file -readonly] [file delete -force foo.file]
} {0 {} 0 {}}
test macFCmd-4.3 {SetFileReadOnly - file readonly} {
    catch {file delete -force foo.file}
    close [open foo.file w]

    list [catch {file attributes foo.file -readonly 1} msg] $msg [file attributes foo.file -readonly] [file delete -force foo.file]
} {0 {} 1 {}}
test macFCmd-4.4 {SetFileReadOnly - directory not readonly} {fileSharing} {

    catch {file delete -force foo.dir}
    file mkdir foo.dir

    list [catch {file attributes foo.dir -readonly 0} msg] $msg [file attributes foo.dir -readonly] [file delete -force foo.dir]
} {0 {} 0 {}}
test macFCmd-4.5 {SetFileReadOnly - directory not readonly} {notFileSharing} {

    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -readonly 0} msg] $msg [file delete -force foo.dir]

} {1 {cannot set a directory to read-only when File Sharing is turned off} {}}
test macFCmd-4.6 {SetFileReadOnly - directory readonly} {fileSharing} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir

    list [catch {file attributes foo.dir -readonly 1} msg] $msg [file attributes foo.dir -readonly] [file delete -force foo.dir]
} {0 {} 1 {}}
test macFCmd-4.7 {SetFileReadOnly - directory readonly} {notFileSharing} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -readonly 1} msg] $msg [file delete -force foo.dir]

} {1 {cannot set a directory to read-only when File Sharing is turned off} {}}

# cleanup
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:40 hershey Exp $
#






if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {file delete -force foo.dir}
file mkdir foo.dir
if {[catch {file attributes foo.dir -readonly 1}]} {
    set ::tcltest::testConfig(fileSharing) 0
    set ::tcltest::testConfig(notFileSharing) 1
} else {
    set ::tcltest::testConfig(fileSharing) 1
    set ::tcltest::testConfig(notFileSharing) 0
}
file delete -force foo.dir

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} {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]
} {0 {MPW } {}}
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]
} {0 TEXT {}}
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]
} {0 0 {}}
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]
} {0 1 {}}
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]
} {0 Fldr {}}
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]
} {0 Fldr {}}
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]
} {0 0 {}}

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} {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]
} {0 0 {}}
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]
} {0 1 {}}
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]
} {0 0 {}}
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]
} {0 1 {}}

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} {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]
} {0 {} FOOO {}}
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]
} {1 {expected Macintosh OS type but got "0"} {}}
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]
} {0 {} 1 {}}
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]
} {0 {} FOOO {}}
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]
} {1 {expected Macintosh OS type but got "0"} {}}
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]
} {1 {cannot set -creator: ":foo.dir" is a directory} {}}

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} {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]
} {0 {} 0 {}}
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]
} {0 {} 1 {}}
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]
} {0 {} 0 {}}
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]
} {1 {cannot set a directory to read-only when File Sharing is turned off} {}}
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]
} {0 {} 1 {}}
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]
} {1 {cannot set a directory to read-only when File Sharing is turned off} {}}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:55 hershey Exp $

if {[lsearch [namespace children] ::test] == -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 {} {
	global a
    
................................................................................
    while compiling
"set tst $a([winfo name "
    (compiling body of proc "tstProc", line 4)
    invoked from within
"tstProc"}}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:40 hershey Exp $

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 {} {
	global a
    
................................................................................
    while compiling
"set tst $a([winfo name "
    (compiling body of proc "tstProc", line 4)
    invoked from within
"tstProc"}}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.4 1999/03/11 18:49:55 hershey Exp $

if {[lsearch [namespace children] ::test] == -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
................................................................................
    file delete [string tolower [file join msgdir $l.msg]]
}

# Clean out the msg catalogs
::msgcat::mclocale $oldlocale
file delete msgdir

::test::cleanupTests
return

#
# 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.1.2.5 1999/03/23 20:06:41 hershey 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
................................................................................
    file delete [string tolower [file join msgdir $l.msg]]
}

# Clean out the msg catalogs
::msgcat::mclocale $oldlocale
file delete msgdir

::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:56 hershey Exp $

if {[lsearch [namespace children] ::test] == -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_*]}

test namespace-old-1.1 {usage for "namespace" command} {
................................................................................
catch {unset msg}
catch {unset x}
catch {unset test_ns_var_global}
catch {unset cmd}
eval namespace delete [namespace children :: test_ns_*]

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:41 hershey Exp $

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_*]}

test namespace-old-1.1 {usage for "namespace" command} {
................................................................................
catch {unset msg}
catch {unset x}
catch {unset test_ns_var_global}
catch {unset cmd}
eval namespace delete [namespace children :: test_ns_*]

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:49:56 hershey Exp $

if {[lsearch [namespace children] ::test] == -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_*]}

test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
................................................................................

# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
eval namespace delete [namespace children :: test_ns_*]
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:42 hershey Exp $

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_*]}

test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
................................................................................

# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
eval namespace delete [namespace children :: test_ns_*]
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:49:57 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} {
    set r 1
    foreach {t} {list boolean cmdName bytecode string int double} {
        set first [string first $t [testobj types]]
................................................................................
    lappend result [testobj refcount 1]
    lappend result [testobj refcount 2]
} {{} 1024 1024 int 4 4 0 boolean 3 2}

testobj freeallvars

# cleanup
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:42 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} {
    set r 1
    foreach {t} {list boolean cmdName bytecode string int double} {
        set first [string first $t [testobj types]]
................................................................................
    lappend result [testobj refcount 1]
    lappend result [testobj refcount 2]
} {{} 1024 1024 int 4 4 0 boolean 3 2}

testobj freeallvars

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:49:58 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# the package we are going to test
package require opt 0.4.1

# we are using implementation specifics to test the package
................................................................................
    set key [::tcl::OptKeyRegister {{args -list {a b c} "args..."}}]
    ::tcl::OptKeyParse $key {}
    ::tcl::OptKeyDelete $key
    set args
} {a b c}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:43 hershey Exp $

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.4.1

# we are using implementation specifics to test the package
................................................................................
    set key [::tcl::OptKeyRegister {{args -list {a b c} "args..."}}]
    ::tcl::OptKeyParse $key {}
    ::tcl::OptKeyDelete $key
    set args
} {a b c}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:49:58 hershey Exp $

# 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] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}




test osa-1.1 {Tcl_OSAComponentCmd} {
    list [catch AppleScript msg] $msg
} {1 {wrong # args: should be "AppleScript option ?arg ...?"}}
test osa-1.2 {Tcl_OSAComponentCmd} {
    list [catch {AppleScript x} msg] $msg
} {1 {bad option "x": should be compile, decompile, delete, execute, info, load, run or store}}

test osa-1.3 {TclOSACompileCmd} {
    list [catch {AppleScript compile} msg] $msg
} {1 {wrong # args: should be "AppleScript compile ?options? code"}}

# cleanup
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:44 hershey Exp $












if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# 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} {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} {macOnly appleScript} {
    list [catch {AppleScript compile} msg] $msg
} {1 {wrong # args: should be "AppleScript compile ?options? code"}}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.8 1999/03/11 18:49:58 hershey Exp $

if {[info commands testparser] == {}} {
    puts "This application hasn't been compiled with the \"testparser\""
    puts "command, so I can't test the Tcl parser."
    return 
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

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} {
................................................................................
} 0
test parse-15.57 {CommandComplete procedure} {
    info complete "# Comment should be complete command"
} 1

# cleanup
catch {unset a}
::test::cleanupTests
return

#
# 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.1.2.9 1999/03/23 20:06:44 hershey Exp $

if {[info commands testparser] == {}} {
    puts "This application hasn't been compiled with the \"testparser\""
    puts "command, so I can't test the Tcl parser."
    return 
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

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} {
................................................................................
} 0
test parse-15.57 {CommandComplete procedure} {
    info complete "# Comment should be complete command"
} 1

# cleanup
catch {unset a}
::tcltest::cleanupTests
return

#
# 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.1.2.2 1999/03/11 18:49:59 hershey Exp $

# Note that the Tcl expression parser (tclParseExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
# of "<<" are integers.

if {[info commands testexprparser] == {}} {
    puts "This application hasn't been compiled with the \"testexprparser\""
    puts "command, so I can't test the Tcl expression parser."
    return 
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

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} {
................................................................................
} {- {} 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
::test::cleanupTests
return

#
# 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.1.2.3 1999/03/23 20:06:45 hershey Exp $

# Note that the Tcl expression parser (tclParseExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
# of "<<" are integers.

if {[info commands testexprparser] == {}} {
    puts "This application hasn't been compiled with the \"testexprparser\""
    puts "command, so I can't test the Tcl expression parser."
    return 
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

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} {
................................................................................
} {- {} 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

# 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.1.2.2 1999/03/11 18:50:00 hershey Exp $

if {[lsearch [namespace children] ::test] == -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
................................................................................
    info complete "xyz \[abc \{abc\]"
} {0}
test parseOld-15.5 {TclScriptEnd procedure} {
    info complete "xyz \[abc"
} {0}

# cleanup
::test::cleanupTests
return

# 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.1.2.3 1999/03/23 20:06:45 hershey 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
................................................................................
    info complete "xyz \[abc \{abc\]"
} {0}
test parseOld-15.5 {TclScriptEnd procedure} {
    info complete "xyz \[abc"
} {0}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:50:00 hershey Exp $

# If pid is not defined just return with no error
# Some platforms may not have the pid command implemented
if {[info commands pid] == ""} {
    puts "pid is not implemented for this machine"
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {removeFile test1}

test pid-1.1 {pid command} {
    regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
................................................................................
    list [catch {pid a b} msg] $msg
} {1 {wrong # args: should be "pid ?channelId?"}}
test pid-1.5 {pid command} {
    list [catch {pid gorp} msg] $msg
} {1 {can not find channel named "gorp"}}

# cleanup
catch {::test::removeFile test1}
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:46 hershey Exp $

# If pid is not defined just return with no error
# Some platforms may not have the pid command implemented
if {[info commands pid] == ""} {
    puts "pid is not implemented for this machine"
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {removeFile test1}

test pid-1.1 {pid command} {
    regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
................................................................................
    list [catch {pid a b} msg] $msg
} {1 {wrong # args: should be "pid ?channelId?"}}
test pid-1.5 {pid command} {
    list [catch {pid gorp} msg] $msg
} {1 {can not find channel named "gorp"}}

# cleanup
catch {::tcltest::removeFile test1}
::tcltest::cleanupTests
return

#
# 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.1.2.5 1999/03/12 19:51:31 hershey Exp $

if {[lsearch [namespace children] ::test] == -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 argv $argv]
interp eval $i [list source [file join $::test::testsDir defs.tcl]]
interp eval $i {

eval package forget [package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
set auto_path ""
................................................................................
package unknown $oldPkgUnknown
concat

}

# cleanup
interp delete $i
::test::cleanupTests
return

#
# 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.1.2.6 1999/03/23 20:06:46 hershey Exp $

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 argv $argv]
interp eval $i [list source [file join $::tcltest::testsDir defs.tcl]]
interp eval $i {

eval package forget [package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
set auto_path ""
................................................................................
package unknown $oldPkgUnknown
concat

}

# cleanup
interp delete $i
::tcltest::cleanupTests
return

#
# 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: pkgMkIndex.test,v 1.4.2.4 1999/03/12 22:32:38 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# temporarily copy the pkg and pkg1 dirs from testsDir to tmpDir
if {"$::test::testsDir" != "$::test::tmpDir"} {
    set origPkgDir [file join $::test::testsDir pkg]
    set newPkgDir [file join $::test::tmpDir 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 oldDir [pwd]
lappend auto_path [file join $::test::tmpDir pkg1]

namespace eval pkgtest {
    # Namespace for procs we can discard
}

# pkgtest::parseArgs --
#
................................................................................
source [file join pkg pkg2_b.tcl]}} {pkg5:1.0 {source [file join pkg pkg5.tcl]}}}"

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 $::test::testsDir ../unix/dltest/pkga[info sharedlibextension]]
if {[file exists $x]} {
    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[info sharedlibextension] 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)"
}

# cleanup
namespace delete pkgtest
cd $::test::tmpDir
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"}
}
::test::cleanupTests
return

#
# 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: pkgMkIndex.test,v 1.4.2.5 1999/03/23 20:06:47 hershey Exp $

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::tmpDir"} {
    set origPkgDir [file join $::tcltest::testsDir pkg]
    set newPkgDir [file join $::tcltest::tmpDir 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 oldDir [pwd]
lappend auto_path [file join $::tcltest::tmpDir pkg1]

namespace eval pkgtest {
    # Namespace for procs we can discard
}

# pkgtest::parseArgs --
#
................................................................................
source [file join pkg pkg2_b.tcl]}} {pkg5:1.0 {source [file join pkg pkg5.tcl]}}}"

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 $::tcltest::testsDir ../unix/dltest/pkga[info sharedlibextension]]
if {[file exists $x]} {
    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[info sharedlibextension] 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)"
}

# cleanup
namespace delete pkgtest
cd $::tcltest::tmpDir
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

# 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: @(#) 

if {[lsearch [namespace children] ::test] == -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 user}

# cleanup
::test::cleanupTests
return

# 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: @(#) 

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 user}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:50:02 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {rename t1 ""}
catch {rename foo ""}

proc tproc {} {return a; return b}
................................................................................
    }
    t1 1
} 20

# cleanup
catch {rename t1 ""}
catch {rename foo ""}
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:47 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {rename t1 ""}
catch {rename foo ""}

proc tproc {} {return a; return b}
................................................................................
    }
    t1 1
} 20

# cleanup
catch {rename t1 ""}
catch {rename foo ""}
::tcltest::cleanupTests
return

#
# 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.1.2.4 1999/03/11 18:50:02 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename {} ""}
catch {unset msg}
................................................................................
    catch {rename t ""}
    set result
} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}

# cleanup
catch {rename p ""}
catch {rename t ""}
::test::cleanupTests
return

#
# 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.1.2.5 1999/03/23 20:06:48 hershey Exp $

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 ""}
catch {rename {} ""}
catch {unset msg}
................................................................................
    catch {rename t ""}
    set result
} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}

# cleanup
catch {rename p ""}
catch {rename t ""}
::tcltest::cleanupTests
return

# 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.1.2.2 1999/03/11 18:50:03 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test pwd-1.1 {simple pwd} {
	catch pwd
} 0
test pwd-1.2 {simple pwd} {
	expr [string length pwd]>0
} 1

# cleanup
::test::cleanupTests
return

# 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.1.2.3 1999/03/23 20:06:48 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test pwd-1.1 {simple pwd} {
	catch pwd
} 0
test pwd-1.2 {simple pwd} {
	expr [string length pwd]>0
} 1

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.4 1999/03/23 04:13:53 stanton Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# 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
................................................................................
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
::test::cleanupTests
return

# 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.1.2.5 1999/03/23 20:06:49 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# 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
................................................................................
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

# Copyright (c) 1991-1993 The Regents of the University of California.
# 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.1.2.7 1999/03/11 18:50:03 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset foo}
test regexp-1.1 {basic regexp operation} {
    regexp ab*c abbbc
} 1
................................................................................
    for {set i 1} {$i<10} {incr i} {
	regsub -all "BEGIN_TABLE " $filedata "" newfiledata
    }
    set x done
} {done}

# cleanup
::test::cleanupTests
return

# Copyright (c) 1991-1993 The Regents of the University of California.
# 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.1.2.8 1999/03/23 20:06:49 hershey Exp $

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} {
    regexp ab*c abbbc
} 1
................................................................................
    for {set i 1} {$i<10} {incr i} {
	regsub -all "BEGIN_TABLE " $filedata "" newfiledata
    }
    set x done
} {done}

# cleanup
::tcltest::cleanupTests
return

#
# In order for these tests to run, the registry package must be on the
# auto_path or the registry package must have been loaded already.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.  All rights reserved.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# RCS: @(#) $Id: registry.test,v 1.1.2.5 1999/03/11 18:50:04 hershey Exp $

if {$tcl_platform(platform) != "windows"} {
    puts "skipping: Windows only tests..."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {$::test::testConfig(win32s)} {
    puts "Skipping registry tests under Win32s"
    return
}



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
}

switch $tcl_platform(os) {
    "Windows NT" {set ::test::testConfig(NT) 1}
    "Windows 95" {set ::test::testConfig(95) 1}
}

# determine the current locale
set old [testlocale all]
if {[testlocale all ""] == "English_United States.1252"} {
    # error messages from registry package are already localized.

    set ::test::testConfig(english) 1
}
testlocale all $old
unset old

set hostname [info hostname]

test registry-1.1 {argument parsing for registry command} {
    list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry option ?arg arg ...?"}}
test registry-1.2 {argument parsing for registry command} {
    list [catch {registry foo} msg] $msg
} {1 {bad option "foo": must be delete, get, keys, set, type, or values}}

test registry-1.3 {argument parsing for registry command} {
    list [catch {registry d} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
test registry-1.4 {argument parsing for registry command} {
    list [catch {registry delete} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
test registry-1.5 {argument parsing for registry command} {
    list [catch {registry delete foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}

test registry-1.6 {argument parsing for registry command} {
    list [catch {registry g} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}
test registry-1.7 {argument parsing for registry command} {
    list [catch {registry get} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}
test registry-1.8 {argument parsing for registry command} {
    list [catch {registry get foo} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}
test registry-1.9 {argument parsing for registry command} {
    list [catch {registry get foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}

test registry-1.10 {argument parsing for registry command} {
    list [catch {registry k} msg] $msg
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}
test registry-1.11 {argument parsing for registry command} {
    list [catch {registry keys} msg] $msg
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}
test registry-1.12 {argument parsing for registry command} {
    list [catch {registry keys foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}

test registry-1.13 {argument parsing for registry command} {
    list [catch {registry s} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
test registry-1.14 {argument parsing for registry command} {
    list [catch {registry set} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
test registry-1.15 {argument parsing for registry command} {
    list [catch {registry set foo bar} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
test registry-1.16 {argument parsing for registry command} {
    list [catch {registry set foo bar baz blat gorp} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}

test registry-1.17 {argument parsing for registry command} {
    list [catch {registry t} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}
test registry-1.18 {argument parsing for registry command} {
    list [catch {registry type} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}
test registry-1.19 {argument parsing for registry command} {
    list [catch {registry type foo} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}
test registry-1.20 {argument parsing for registry command} {
    list [catch {registry type foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}

test registry-1.21 {argument parsing for registry command} {
    list [catch {registry v} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
test registry-1.22 {argument parsing for registry command} {
    list [catch {registry values} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
test registry-1.23 {argument parsing for registry command} {
    list [catch {registry values foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}

test registry-2.1 {DeleteKey: bad key} {
    list [catch {registry delete foo} msg] $msg
} {1 {bad root name "foo": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-2.2 {DeleteKey: bad key} {
    list [catch {registry delete HKEY_CLASSES_ROOT} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-2.3 {DeleteKey: bad key} {
    list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-2.4 {DeleteKey: subkey at root level} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry keys HKEY_CLASSES_ROOT TclFoobar
} {}
test registry-2.5 {DeleteKey: subkey below root level} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test
    registry delete HKEY_CLASSES_ROOT\\TclFoobar\\test
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar\\test]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-2.6 {DeleteKey: recursive delete} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar]
    set result
} {}
test registry-2.7 {DeleteKey: trailing backslashes} {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} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
} {}


test registry-3.1 {DeleteValue} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test1 blort
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test2 blat
    registry delete HKEY_CLASSES_ROOT\\TclFoobar\\baz test1
    set result [registry values HKEY_CLASSES_ROOT\\TclFoobar\\baz]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} test2
test registry-3.2 {DeleteValue: bad key} {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} {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-4.1 {GetKeyNames: bad key} {english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-4.2 {GetKeyNames} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz
    set result [registry keys HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz}
test registry-4.3 {GetKeyNames: remote key} {nonPortable 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} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-4.5 {GetKeyNames: patterns} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz blat}
test registry-4.6 {GetKeyNames: names with spaces} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz\ bar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{baz bar} blat}

test registry-5.1 {GetType} {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} {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} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar none
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} none
test registry-5.4 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} sz
test registry-5.5 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar sz
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} sz
test registry-5.6 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar expand_sz
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} expand_sz
test registry-5.7 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 binary
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} binary
test registry-5.8 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 dword
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} dword
test registry-5.9 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 dword_big_endian
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} dword_big_endian
test registry-5.10 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 link
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} link
test registry-5.11 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar multi_sz
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} multi_sz
test registry-5.12 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 resource_list
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} resource_list
test registry-5.13 {GetType: unknown types} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 24
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 24

test registry-6.1 {GetValue} {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} {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} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar none
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.4 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.5 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.6 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar expand_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.7 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 binary
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1
test registry-6.8 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 0x20 dword
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 32
test registry-6.9 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 0x20 dword_big_endian
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 32
test registry-6.10 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 link
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1
test registry-6.11 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.12 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {foo\ bar baz} multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{foo bar} baz}
test registry-6.13 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {} multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-6.14 {GetValue: truncation of multivalues with null elements} {

    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {a {} b} multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} a
test registry-6.15 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 resource_list
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1
test registry-6.16 {GetValue: unknown types} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 24
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1

test registry-7.1 {GetValueNames: bad key} {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} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar
    set result [registry values HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} baz
test registry-7.3 {GetValueNames} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1
    registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2
    registry set HKEY_CLASSES_ROOT\\TclFoobar {} foobar3
    set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{} baz blat}
test registry-7.4 {GetValueNames: remote key} {nonPortable english} {
    registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar baz blat
    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} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry values HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-7.6 {GetValueNames: patterns} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1
    registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2
    registry set HKEY_CLASSES_ROOT\\TclFoobar foo foobar3
    set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz blat}
test registry-7.7 {GetValueNames: names with spaces} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz\ bar foobar1
    registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2
    registry set HKEY_CLASSES_ROOT\\TclFoobar foo foobar3
    set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{baz bar} blat}

test registry-8.1 {OpenSubKey} {nonPortable english} {
    list [catch {registry keys {\\petrouchka\HKEY_LOCAL_MACHINE}} msg] $msg
} {1 {unable to open key: Access is denied.}}
test registry-8.2 {OpenSubKey} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} TclFoobar
test registry-8.3 {OpenSubKey} {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} {
    list [catch {registry values \\} msg] $msg
} "1 {bad key \"\\\": must start with a valid root}"
test registry-9.2 {ParseKeyName: bad keys} {
    list [catch {registry values \\foobar} msg] $msg
} {1 {bad key "\foobar": must start with a valid root}}
test registry-9.3 {ParseKeyName: bad keys} {
    list [catch {registry values \\\\} msg] $msg
} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-9.4 {ParseKeyName: bad keys} {
    list [catch {registry values \\\\\\} msg] $msg
} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-9.5 {ParseKeyName: bad keys} {english} {
    list [catch {registry values \\\\\\HKEY_CLASSES_ROOT} msg] $msg
} {1 {unable to open key: The network address is invalid.}}
test registry-9.6 {ParseKeyName: bad keys} {
    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} {
    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} {
    list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-9.9 {ParseKeyName: null keys} {english} {
    list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar\\baz} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}

test registry-10.1 {RecursiveDeleteKey} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar]
    set result
} {}
test registry-10.2 {RecursiveDeleteKey} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3
    set result [registry delete HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test4]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}

test registry-11.1 {SetValue: recursive creation} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat foobar
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar\\baz blat]
} foobar
test registry-11.2 {SetValue: modification} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat foobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat frob
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar\\baz blat]
} frob
test registry-11.3 {SetValue: failure} {nonPortable english} {
    list [catch {registry set {\\petrouchka\HKEY_CLASSES_ROOT\TclFoobar} bar foobar} msg] $msg
} {1 {unable to open key: Access is denied.}}


# cleanup
unset hostname
::test::cleanupTests
return

#
# In order for these tests to run, the registry package must be on the
# auto_path or the registry package must have been loaded already.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.  All rights reserved.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# RCS: @(#) $Id: registry.test,v 1.1.2.6 1999/03/23 20:06:50 hershey 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]] tclreg*.dll]] 0]

	load $lib registry
    }] {
	puts "Unable to find the registry package. Skipping registry tests."
	return
    }




}

# determine the current locale
set old [testlocale all]
if {[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} {pcOnly} {
    list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry option ?arg arg ...?"}}
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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {pcOnly} {
    list [catch {registry delete HKEY_CLASSES_ROOT} msg] $msg
} {1 {bad key: cannot delete root keys}}
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} {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} {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} {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} {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} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
} {}


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
    registry delete HKEY_CLASSES_ROOT\\TclFoobar\\baz test1
    set result [registry values HKEY_CLASSES_ROOT\\TclFoobar\\baz]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} test2
test registry-3.2 {DeleteValue: bad key} {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} {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-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} {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} {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} {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} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz blat}
test registry-4.6 {GetKeyNames: names with spaces} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz\ bar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{baz bar} blat}

test registry-5.1 {GetType} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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-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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} {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} \
	{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} {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} {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-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} {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} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1
    registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2
    registry set HKEY_CLASSES_ROOT\\TclFoobar {} foobar3
    set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{} baz blat}
test registry-7.4 {GetValueNames: remote key} {pcOnly nonPortable english} {
    registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar baz blat
    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} {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} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1
    registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2
    registry set HKEY_CLASSES_ROOT\\TclFoobar foo foobar3
    set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz blat}
test registry-7.7 {GetValueNames: names with spaces} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz\ bar foobar1
    registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2
    registry set HKEY_CLASSES_ROOT\\TclFoobar foo foobar3
    set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{baz bar} blat}

test registry-8.1 {OpenSubKey} {pcOnly nonPortable english} {
    list [catch {registry keys {\\petrouchka\HKEY_LOCAL_MACHINE}} msg] $msg
} {1 {unable to open key: Access is denied.}}
test registry-8.2 {OpenSubKey} {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} {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} {pcOnly} {
    list [catch {registry values \\} msg] $msg
} "1 {bad key \"\\\": must start with a valid root}"
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} {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} {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} {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} {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} {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} {pcOnly} {
    list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg
} {1 {bad key: cannot delete root 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} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar]
    set result
} {}
test registry-10.2 {RecursiveDeleteKey} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3
    set result [registry delete HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test4]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}

test registry-11.1 {SetValue: recursive creation} {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} {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} {pcOnly nonPortable english} {
    list [catch {registry set {\\petrouchka\HKEY_CLASSES_ROOT\TclFoobar} bar foobar} msg] $msg
} {1 {unable to open key: Access is denied.}}


# cleanup
unset hostname
::tcltest::cleanupTests
return

# Source this file in the remote server you are using to test Tcl against.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: remote.tcl,v 1.1.2.1 1998/09/24 23:59:35 stanton Exp $

# Initialize message delimitor

# Initialize command array
catch {unset command}
set command(0) ""
set callerSocket ""
................................................................................

if {[catch {set serverSocket \
	[socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} {
    puts "Server on $serverAddress:$serverPort cannot start: $msg"
} else {
    vwait __server_wait_variable__
}

# Source this file in the remote server you are using to test Tcl against.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: remote.tcl,v 1.1.2.2 1999/03/23 20:06:50 hershey Exp $

# Initialize message delimitor

# Initialize command array
catch {unset command}
set command(0) ""
set callerSocket ""
................................................................................

if {[catch {set serverSocket \
	[socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} {
    puts "Server on $serverAddress:$serverPort cannot start: $msg"
} else {
    vwait __server_wait_variable__
}

# 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.1.2.3 1999/03/11 18:50:05 hershey Exp $

if {[lsearch [namespace children] ::test] == -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
# own special-purpose unknown command.

................................................................................
    catch {x} msg
    set msg
} {called "incr" with too many arguments}

# cleanup
catch {rename incr {}}
catch {rename incr.old incr}
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:51 hershey Exp $

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
# own special-purpose unknown command.

................................................................................
    catch {x} msg
    set msg
} {called "incr" with too many arguments}

# cleanup
catch {rename incr {}}
catch {rename incr.old incr}
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:50:05 hershey Exp $

# Only run this test on Macintosh systems
if {$tcl_platform(platform) != "macintosh"} {
    puts "skipping: Mac only tests..."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test resource-1.1 {resource tests} {
    list [catch {resource} msg] $msg
} {1 {wrong # args: should be "resource option ?arg ...?"}}
test resource-1.2 {resource tests} {
    list [catch {resource _bad_} msg] $msg
} {1 {bad option "_bad_": must be close, delete, files, list, open, read, types, or write}}

# resource open & close tests
test resource-2.1 {resource open & close tests} {
    list [catch {resource open} msg] $msg
} {1 {wrong # args: should be "resource open fileName ?permissions?"}}
test resource-2.2 {resource open & close tests} {
    list [catch {resource open resource.test r extraArg} msg] $msg
} {1 {wrong # args: should be "resource open fileName ?permissions?"}}
test resource-2.3 {resource open & close tests} {
    list [catch {resource open resource.test bad_perms} msg] $msg
} {1 {illegal access mode "bad_perms"}}
test resource-2.4 {resource open & close tests} {
    list [catch {resource open _bad_file_} msg] $msg
} {1 {file does not exist}}
test resource-2.5 {resource open & close tests} {
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {error "don't source me"}
    set id [resource open rsrc.file]
    resource close $id
    file delete rsrc.file
} {}
test resource-2.6 {resource open & close tests} {
    catch {file delete rsrc.file}
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {A test string}
    set id [resource open rsrc.file]
    set result [string compare [resource open rsrc.file] $id]
    lappend result [resource read TEXT fileRsrcName $id]
    resource close $id
    file delete rsrc.file
    set result
} {0 {A test string}}
test resource-2.7 {resource open & close tests} {
    catch {file delete rsrc.file}
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {error "don't source me"}
    set id [resource open rsrc.file r]
    set result [catch {resource open rsrc.file w} mssg]
    resource close $id
    file delete rsrc.file
    lappend result $mssg
    set result
} {1 {Resource already open with different permissions.}}
test resource-2.8 {resource open & close tests} {
    list [catch {resource close} msg] $msg
} {1 {wrong # args: should be "resource close resourceRef"}}
test resource-2.9 {resource open & close tests} {
    list [catch {resource close foo bar} msg] $msg
} {1 {wrong # args: should be "resource close resourceRef"}}
test resource-2.10 {resource open & close tests} {
    list [catch {resource close _bad_resource_} msg] $msg
} {1 {invalid resource file reference "_bad_resource_"}}
test resource-2.11 {resource open & close tests} {
    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} {
    set result [catch {resource close application} mssg]
    lappend result $mssg
} {1 {can't close "application" resource file}}

# Tests for listing resources
test resource-3.1 {resource list tests} {
    list [catch {resource list} msg] $msg
} {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}}
test resource-3.2 {resource list tests} {
    list [catch {resource list _bad_type_} msg] $msg
} {1 {expected Macintosh OS type but got "_bad_type_"}}
test resource-3.3 {resource list tests} {
    list [catch {resource list TEXT _bad_ref_} msg] $msg
} {1 {invalid resource file reference "_bad_ref_"}}
test resource-3.4 {resource list tests} {
    list [catch {resource list TEXT _bad_ref_ extraArg} msg] $msg
} {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}}
test resource-3.5 {resource list tests} {
    catch {file delete rsrc.file}
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {error "don't source me"}
    set id [resource open rsrc.file]
    catch "resource list TEXT $id" result
    resource close $id
    set result
} {fileRsrcName}
test resource-3.6 {resource list tests} {
    # There should not be any resource of this type
    resource list XXXX
} {}
test resource-3.7 {resource list tests} {
    set resourceList [resource list STR#]
    if {[lsearch $resourceList {Tcl Environment Variables}] == -1} {
        set result {couldn't find resource that should exist}
    } else {
        set result ok
    }
} {ok}

# Tests for reading resources
test resource-4.1 {resource read tests} {
    list [catch {resource read} msg] $msg
} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}}
test resource-4.2 {resource read tests} {
    list [catch {resource read TEXT} msg] $msg
} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}}
test resource-4.3 {resource read tests} {
    list [catch {resource read STR# {_non_existant_resource_}} msg] $msg
} {1 {could not load resource}}
test resource-4.4 {resource read tests} {
    # The following resource should exist and load OK without error
    catch {resource read STR# {Tcl Environment Variables}}
} {0}

# Tests for getting resource types
test resource-5.1 {resource types tests} {
    list [catch {resource types _bad_ref_} msg] $msg
} {1 {invalid resource file reference "_bad_ref_"}}
test resource-5.2 {resource types tests} {
    list [catch {resource types _bad_ref_ extraArg} msg] $msg
} {1 {wrong # args: should be "resource types ?resourceRef?"}}
test resource-5.3 {resource types tests} {
    # This should never cause an error
    catch {resource types}
} {0}
test resource-5.4 {resource types tests} {
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {error "don't source me"}
    set id [resource open rsrc.file]
    set result [resource types $id]
    resource close $id
    set result
} {TEXT}

# resource write tests
test resource-6.1 {resource write tests} {
    list [catch {resource write} msg] $msg
} {1 {wrong # args: should be "resource write ?-id resourceId? ?-name resourceName? ?-file resourceRef? ?-force? resourceType data"}}
test resource-6.2 {resource write tests} {
    list [catch {resource write _bad_type_ data} msg] $msg
} {1 {expected Macintosh OS type but got "_bad_type_"}}
test resource-6.3 {resource write tests} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource close $id
    set id [resource open rsrc2.file r]
    set result [catch {resource write -file $id -name Hello TEXT foo} errMsg]
    lappend result [string compare $errMsg "cannot write to resource file \"$id\", it was opened read only"]
    lappend result [lsearch [resource list TEXT $id] Hello]
    resource close $id
    file delete rsrc2.file
    set result   
} {1 0 -1}
test resource-6.4 {resource write tests} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource write -file $id -name Hello TEXT {set x "our test data"}
    source -rsrc Hello rsrc2.file
    resource close $id
    file delete rsrc2.file
    set x
} {our test data}
test resource-6.5 {resource write tests} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource write -file $id -id 256 TEXT {HAHAHAHAHAHAHA}
    set result [catch {resource write -file $id -id 256 TEXT {HOHOHOHOHOHO}} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {the resource 256 already exists, use "-force" to overwrite it.}}
test resource-6.6 {resource write tests} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 256  -file rsrc2.file  -protected {error "don't tread on me"}
    set id [resource open rsrc2.file w]
    set result [catch {resource write -id 256 -force -file $id TEXT {NAHNAHNANAHNAH}} mssg] 
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {could not write resource id 256 of type TEXT, it was protected.}}
test resource-6.7 {resource write tests} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource write -file $id -id 256 -name FOO TEXT {set x [list "our first test data"]}
    resource write -file $id -id 256 -name BAR -force TEXT {set x [list "our second test data"]}
    source -rsrcid 256 rsrc2.file
    lappend x [resource list TEXT $id]
    resource close $id
    file delete rsrc2.file
    set x
} {{our second test data} BAR}

#Tests for listing open resource files
test resource-7.1 {resource file tests} {
    catch {resource files foo bar} mssg
    set mssg
} {wrong # args: should be "resource files ?resourceId?"}
test resource-7.2 {resource file tests} {
    catch {file delete rsrc2.file}
    set rsrcFiles [resource files]
    set id [resource open rsrc2.file w]
    set result [string compare $rsrcFiles [lrange [resource files] 1 end]]
    lappend result [string compare $id [lrange [resource files] 0 0]]
    resource close $id
    file delete rsrc2.file
    set result
} {0 0}
test resource-7.3 {resource file tests} {
    set result 0
    foreach file [resource files] {
        if {[catch {resource types $file}] != 0} {
            set result 1
        }
    }
    set result
} {0}
test resource-7.4 {resource file tests} {
    catch {resource files __NO_SUCH_RESOURCE__} mssg
    set mssg
} {invalid resource file reference "__NO_SUCH_RESOURCE__"}
test resource-7.5 {resource file tests} {
    set sys [resource files System]
    string compare $sys [file join $env(SYS_FOLDER) System]
} {0}
test resource-7.6 {resource file tests} {
    set app [resource files application]
    string compare $app [info nameofexecutable]
} {0}

#Tests for the resource delete command
test resource-8.1 {resource delete tests} {
    list [catch {resource delete} msg] $msg
} {1 {wrong # args: should be "resource delete ?-id resourceId? ?-name resourceName? ?-file resourceRef? resourceType"}}
test resource-8.2 {resource delete tests} {
    list [catch {resource delete TEXT} msg] $msg
} {1 {you must specify either "-id" or "-name" or both to "resource delete"}}
test resource-8.3 {resource delete tests} {
    set result [catch {resource delete -file ffffff -id 128 TEXT} mssg]
    lappend result $mssg    
} {1 {invalid resource file reference "ffffff"}}    
test resource-8.4 {resource delete tests} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
    set id [resource open rsrc2.file r]
    set result [catch {resource delete -id 128 -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result [string compare $mssg "cannot delete from resource file \"$id\", it was opened read only"]   
} {1 0}
test resource-8.5 {resource delete tests} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
    set id [resource open rsrc2.file w]
    set result [catch {resource delete -id 128 -file $id _bad_type_} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {expected Macintosh OS type but got "_bad_type_"}}
test resource-8.5 {resource delete tests} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    set result [catch {resource delete -id 128 -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {resource not found}}
test resource-8.6 {resource delete tests} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    set result [catch {resource delete -name foo -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {resource not found}}
test resource-8.7 {resource delete tests} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource write -file $id -name foo -id 128 TEXT {some stuff}
    resource write -file $id -name bar -id 129 TEXT {some stuff}
    set result [catch {resource delete -name foo -id 129 -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {"-id" and "-name" values do not point to the same resource}}
test resource-8.8 {resource delete tests} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 256  -file rsrc2.file  -protected {error "don't tread on me"}
    set id [resource open rsrc2.file w]
    set result [catch {resource delete -id 256 -file $id TEXT } mssg] 
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {resource cannot be deleted: it is protected.}}
test resource-8.9 {resource delete tests} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
    set id [resource open rsrc2.file w]
    set result [resource list TEXT $id]
    resource delete -id 128 -file $id TEXT
    lappend result [resource list TEXT $id]
    resource close $id
    file delete rsrc2.file
    set result
} {fileRsrcName {}}
    
# Tests for the Mac version of the source command
catch {file delete rsrc.file}

testWriteTextResource -rsrc fileRsrcName -rsrcid 128 \
    -file rsrc.file  {set rsrc_foo 1}
test resource-9.1 {source command} {
    catch {unset rsrc_foo}
    source -rsrc fileRsrcName rsrc.file
    list [catch {set rsrc_foo} msg] $msg
} {0 1}
test resource-9.2 {source command} {
    catch {unset rsrc_foo}
    list [catch {source -rsrc no_resource rsrc.file} msg] $msg
} {1 {The resource "no_resource" could not be loaded from rsrc.file.}}
test resource-9.3 {source command} {
    catch {unset rsrc_foo}
    source -rsrcid 128 rsrc.file
    list [catch {set rsrc_foo} msg] $msg
} {0 1}
test resource-9.4 {source command} {
    catch {unset rsrc_foo}
    list [catch {source -rsrcid bad_int rsrc.file} msg] $msg
} {1 {expected integer but got "bad_int"}}
test resource-9.5 {source command} {
    catch {unset rsrc_foo}
    list [catch {source -rsrcid 100 rsrc.file} msg] $msg
} {1 {The resource "ID=100" could not be loaded from rsrc.file.}}

# cleanup
catch {file delete rsrc.file}
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:51 hershey Exp $







if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

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} {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} {macOnly} {
    list [catch {resource open} msg] $msg
} {1 {wrong # args: should be "resource open fileName ?permissions?"}}
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} {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} {macOnly} {
    list [catch {resource open _bad_file_} msg] $msg
} {1 {file does not exist}}
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} {macOnly} {
    catch {file delete rsrc.file}
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {A test string}
    set id [resource open rsrc.file]
    set result [string compare [resource open rsrc.file] $id]
    lappend result [resource read TEXT fileRsrcName $id]
    resource close $id
    file delete rsrc.file
    set result
} {0 {A test string}}
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]
    set result [catch {resource open rsrc.file w} mssg]
    resource close $id
    file delete rsrc.file
    lappend result $mssg
    set result
} {1 {Resource already open with different permissions.}}
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} {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} {macOnly} {
    list [catch {resource close _bad_resource_} msg] $msg
} {1 {invalid resource file reference "_bad_resource_"}}
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} {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} {macOnly} {
    list [catch {resource list} msg] $msg
} {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}}
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} {macOnly} {
    list [catch {resource list TEXT _bad_ref_} msg] $msg
} {1 {invalid resource file reference "_bad_ref_"}}
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} {macOnly} {
    catch {file delete rsrc.file}
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {error "don't source me"}
    set id [resource open rsrc.file]
    catch "resource list TEXT $id" result
    resource close $id
    set result
} {fileRsrcName}
test resource-3.6 {resource list tests} {macOnly} {
    # There should not be any resource of this type
    resource list XXXX
} {}
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}
    } else {
        set result ok
    }
} {ok}

# Tests for reading resources
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} {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} {macOnly} {
    list [catch {resource read STR# {_non_existant_resource_}} msg] $msg
} {1 {could not load resource}}
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} {macOnly} {
    list [catch {resource types _bad_ref_} msg] $msg
} {1 {invalid resource file reference "_bad_ref_"}}
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} {macOnly} {
    # This should never cause an error
    catch {resource types}
} {0}
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]
    resource close $id
    set result
} {TEXT}

# 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} {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} {macOnly} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource close $id
    set id [resource open rsrc2.file r]
    set result [catch {resource write -file $id -name Hello TEXT foo} errMsg]
    lappend result [string compare $errMsg "cannot write to resource file \"$id\", it was opened read only"]
    lappend result [lsearch [resource list TEXT $id] Hello]
    resource close $id
    file delete rsrc2.file
    set result   
} {1 0 -1}
test resource-6.4 {resource write tests} {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"}
    source -rsrc Hello rsrc2.file
    resource close $id
    file delete rsrc2.file
    set x
} {our test data}
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}
    set result [catch {resource write -file $id -id 256 TEXT {HOHOHOHOHOHO}} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {the resource 256 already exists, use "-force" to overwrite it.}}
test resource-6.6 {resource write tests} {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]
    set result [catch {resource write -id 256 -force -file $id TEXT {NAHNAHNANAHNAH}} mssg] 
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {could not write resource id 256 of type TEXT, it was protected.}}
test resource-6.7 {resource write tests} {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"]}
    resource write -file $id -id 256 -name BAR -force TEXT {set x [list "our second test data"]}
    source -rsrcid 256 rsrc2.file
    lappend x [resource list TEXT $id]
    resource close $id
    file delete rsrc2.file
    set x
} {{our second test data} BAR}

#Tests for listing open resource files
test resource-7.1 {resource file tests} {macOnly} {
    catch {resource files foo bar} mssg
    set mssg
} {wrong # args: should be "resource files ?resourceId?"}
test resource-7.2 {resource file tests} {macOnly} {
    catch {file delete rsrc2.file}
    set rsrcFiles [resource files]
    set id [resource open rsrc2.file w]
    set result [string compare $rsrcFiles [lrange [resource files] 1 end]]
    lappend result [string compare $id [lrange [resource files] 0 0]]
    resource close $id
    file delete rsrc2.file
    set result
} {0 0}
test resource-7.3 {resource file tests} {macOnly} {
    set result 0
    foreach file [resource files] {
        if {[catch {resource types $file}] != 0} {
            set result 1
        }
    }
    set result
} {0}
test resource-7.4 {resource file tests} {macOnly} {
    catch {resource files __NO_SUCH_RESOURCE__} mssg
    set mssg
} {invalid resource file reference "__NO_SUCH_RESOURCE__"}
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} {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} {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} {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} {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} {macOnly} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
    set id [resource open rsrc2.file r]
    set result [catch {resource delete -id 128 -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result [string compare $mssg "cannot delete from resource file \"$id\", it was opened read only"]   
} {1 0}
test resource-8.5 {resource delete tests} {macOnly} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
    set id [resource open rsrc2.file w]
    set result [catch {resource delete -id 128 -file $id _bad_type_} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {expected Macintosh OS type but got "_bad_type_"}}
test resource-8.5 {resource delete tests} {macOnly} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    set result [catch {resource delete -id 128 -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {resource not found}}
test resource-8.6 {resource delete tests} {macOnly} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    set result [catch {resource delete -name foo -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {resource not found}}
test resource-8.7 {resource delete tests} {macOnly} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource write -file $id -name foo -id 128 TEXT {some stuff}
    resource write -file $id -name bar -id 129 TEXT {some stuff}
    set result [catch {resource delete -name foo -id 129 -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {"-id" and "-name" values do not point to the same resource}}
test resource-8.8 {resource delete tests} {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]
    set result [catch {resource delete -id 256 -file $id TEXT } mssg] 
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {resource cannot be deleted: it is protected.}}
test resource-8.9 {resource delete tests} {macOnly} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
    set id [resource open rsrc2.file w]
    set result [resource list TEXT $id]
    resource delete -id 128 -file $id TEXT
    lappend result [resource list TEXT $id]
    resource close $id
    file delete rsrc2.file
    set result
} {fileRsrcName {}}
    
# Tests for the Mac version of the source command
catch {file delete rsrc.file}
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} {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} {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} {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} {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.}}

# cleanup
catch {file delete rsrc.file}
::tcltest::cleanupTests
return

# 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] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test result-1.1 {Tcl_SaveInterpResult} {
    testsaveresult small {set x 42} 0
} {small result}
test result-1.2 {Tcl_SaveInterpResult} {
................................................................................
} {{1 2 3 4}}
test result-4.5 {Tcl_SetObjErrorCode - five args} {
    catch {testsetobjerrorcode 1 2 3 4 5}
    list [set errorCode]
} {{1 2 3 4 5}}

# cleanup
::test::cleanupTests
return

# 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]
}

test result-1.1 {Tcl_SaveInterpResult} {
    testsaveresult small {set x 42} 0
} {small result}
test result-1.2 {Tcl_SaveInterpResult} {
................................................................................
} {{1 2 3 4}}
test result-4.5 {Tcl_SetObjErrorCode - five args} {
    catch {testsetobjerrorcode 1 2 3 4 5}
    list [set errorCode]
} {{1 2 3 4 5}}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.4 1999/03/11 18:50:06 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

foreach i [interp slaves] {
  interp delete $i
}

................................................................................
            [safe::interpDelete $i];
} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}


}

# cleanup
::test::cleanupTests
return

#
# 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.1.2.5 1999/03/23 20:06:52 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

foreach i [interp slaves] {
  interp delete $i
}

................................................................................
            [safe::interpDelete $i];
} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}


}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.5 1999/03/11 18:50:06 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test scan-1.1 {BuildCharSet, CharInSet} {
    list [scan foo {%[^o]} x] $x
} {1 f}
test scan-1.2 {BuildCharSet, CharInSet} {
................................................................................
    list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d
} {2 1 2 {} {}}
#
# The behavior for scaning intergers larger than MAX_INT is
# not defined by the ANSI spec.  Some implementations wrap the
# input (-16) some return MAX_INT.
#
test scan-5.11 {integer scanning} {nonportable} {
    set a {}; set b {};
    list [scan "4294967280 4294967280" "%u %d" a b] $a \
	    [expr {$b == -16 || $b == 0x7fffffff}]
} {2 4294967280 1}

test scan-6.1 {floating-point scanning} {
    set a {}; set b {}; set c {}; set d {}
................................................................................
} 13.6
test scan-11.5 {alignment in results array (TCL_ALIGN)} {
    scan "1234567890123456789 13.6" "%s %f" a b
    set b
} 13.6

# cleanup
::test::cleanupTests
return

# 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.1.2.6 1999/03/23 20:06:52 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test scan-1.1 {BuildCharSet, CharInSet} {
    list [scan foo {%[^o]} x] $x
} {1 f}
test scan-1.2 {BuildCharSet, CharInSet} {
................................................................................
    list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d
} {2 1 2 {} {}}
#
# The behavior for scaning intergers larger than MAX_INT is
# not defined by the ANSI spec.  Some implementations wrap the
# input (-16) some return MAX_INT.
#
test scan-5.11 {integer scanning} {nonPortable} {
    set a {}; set b {};
    list [scan "4294967280 4294967280" "%u %d" a b] $a \
	    [expr {$b == -16 || $b == 0x7fffffff}]
} {2 4294967280 1}

test scan-6.1 {floating-point scanning} {
    set a {}; set b {}; set c {}; set d {}
................................................................................
} 13.6
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

# 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.1.2.2 1999/03/11 18:50:07 hershey Exp $

if {[lsearch [namespace children] ::test] == -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
................................................................................

test sec-1.1 {tcl_endOfPreviousWord} {
    catch {tcl_startOfPreviousWord x {[BUG]}}
    CB
} 0

# cleanup
::test::cleanupTests
return

# 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.1.2.3 1999/03/23 20:06:53 hershey 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
................................................................................

test sec-1.1 {tcl_endOfPreviousWord} {
    catch {tcl_startOfPreviousWord x {[BUG]}}
    CB
} 0

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:50:07 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc ignore args {}

# Simple variable operations.

................................................................................
# scalars by other tests.
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset aVaRnAmE}

# cleanup
::test::cleanupTests
return 

# 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.1.2.4 1999/03/23 20:06:53 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc ignore args {}

# Simple variable operations.

................................................................................
# scalars by other tests.
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset aVaRnAmE}

# cleanup
::tcltest::cleanupTests
return 

#
# 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.1.2.3 1999/03/11 18:50:08 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}
catch {unset i}

test set-1.1 {TclCompileSetCmd: missing variable name} {
................................................................................

# cleanup
catch {unset a}
catch {unset b}
catch {unset i}
catch {unset x}
catch {unset z}
::test::cleanupTests
return 

#
# 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.1.2.4 1999/03/23 20:06:54 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}
catch {unset i}

test set-1.1 {TclCompileSetCmd: missing variable name} {
................................................................................

# cleanup
catch {unset a}
catch {unset b}
catch {unset i}
catch {unset x}
catch {unset z}
::tcltest::cleanupTests
return 

#
# 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.1.2.6 1999/03/12 19:51:32 hershey Exp $

# Running socket tests with a remote server:
# ------------------------------------------
# 
# Some tests in socket.test depend on the existence of a remote server to
# which they connect. The remote server must be an instance of tcltest and it
# must run the script found in the file "remote.tcl" in this directory. You
................................................................................
# either in Tcl or in the environment; if they are, it attempts to connect to
# the server. If the connection is successful, the tests using the remote
# server will be performed; otherwise, it will attempt to start the remote
# server (via exec) on platforms that support this, on the local host,
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {$::test::testConfig(socket) == 0} {
    puts "skipping: tests require sockets"
    return
}

#
# If remoteServerIP or remoteServerPort are not set, check in the
# environment variables for externally set values.
#

if {![info exists remoteServerIP]} {
    if {[info exists env(remoteServerIP)]} {
................................................................................
if {$doTestsWithRemoteServer} {
    catch {close $commandSocket}
    if {[catch {set commandSocket [socket $remoteServerIP \
						$remoteServerPort]}] != 0} {
	if {[info commands exec] == ""} {
	    set noRemoteTestReason "can't exec"
	    set doTestsWithRemoteServer 0
	} elseif {$::test::testConfig(win32s)} {
	    set noRemoteTestReason "\ncan't run multiple instances of tcltest under win32s."
	    set doTestsWithRemoteServer 0
	} else {
	    set remoteServerIP 127.0.0.1
	    set remoteFile [file join [pwd] remote.tcl]
	    if {[catch {set remoteProcChan \
				[open "|[list $tcltest $remoteFile \
					-serverIsSilent \
					-port $remoteServerPort \
................................................................................
	}
    } else {
	fconfigure $commandSocket -translation crlf -buffering line
    }
}

# Some tests are run only if we are doing testing against a remote server.
set ::test::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 {$::test::verbose != ""} {
	puts "Reason for not doing remote tests: $noRemoteTestReason"
    }
}

#
# If we do the tests, define a command to send a command to the
# remote server.
................................................................................
	    } else {
		append resp $line "\n"
	    }
	}
    }
}

test socket-1.1 {arg parsing for socket command} {
    list [catch {socket -server} msg] $msg
} {1 {no argument given for -server option}}
test socket-1.2 {arg parsing for socket command} {
    list [catch {socket -server foo} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.3 {arg parsing for socket command} {
    list [catch {socket -myaddr} msg] $msg
} {1 {no argument given for -myaddr option}}
test socket-1.4 {arg parsing for socket command} {
    list [catch {socket -myaddr 127.0.0.1} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.5 {arg parsing for socket command} {
    list [catch {socket -myport} msg] $msg
} {1 {no argument given for -myport option}}
test socket-1.6 {arg parsing for socket command} {
    list [catch {socket -myport xxxx} msg] $msg
} {1 {expected integer but got "xxxx"}}
test socket-1.7 {arg parsing for socket command} {
    list [catch {socket -myport 2522} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.8 {arg parsing for socket command} {
    list [catch {socket -froboz} msg] $msg
} {1 {bad option "-froboz": must be -async, -myaddr, -myport, or -server}}
test socket-1.9 {arg parsing for socket command} {
    list [catch {socket -server foo -myport 2521 3333} msg] $msg
} {1 {Option -myport is not valid for servers}}
test socket-1.10 {arg parsing for socket command} {
    list [catch {socket host 2528 -junk} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.11 {arg parsing for socket command} {
    list [catch {socket -server callback 2520 --} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.12 {arg parsing for socket command} {
    list [catch {socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}

test socket-2.1 {tcp connection} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x timed_out"]
	set f [socket -server accept 2828]
	proc accept {file addr port} {
	    global x
................................................................................
} {ready done {}}

if [info exists port] {
    incr port
} else { 
    set port [expr 2048 + [pid]%1024]
}
test socket-2.2 {tcp connection with client port specified} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket -server accept 2828]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} [list ready "hello $port"]
test socket-2.3 {tcp connection with client interface specified} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket  -server accept 2828]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready {hello 127.0.0.1}}
test socket-2.4 {tcp connection with server interface specified} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket -server accept -myaddr [info hostname] 2828]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready hello}
test socket-2.5 {tcp connection with redundant server port} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket -server accept 2828]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready hello}
test socket-2.6 {tcp connection} {} {
    set status ok
    if {![catch {set sock [socket 127.0.0.1 2828]}]} {
	if {![catch {gets $sock}]} {
	    set status broken
	}
	close $sock
    }
    set status
} ok
test socket-2.7 {echo server, one line} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
	set f [socket -server accept 2828]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
................................................................................
    puts $s "hello abcdefghijklmnop"
    set x [gets $s]
    close $s
    set y [gets $f]
    close $f
    list $x $y
} {{hello abcdefghijklmnop} done}
test socket-2.8 {echo server, loop 50 times, single connection} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set f [socket -server accept 2828]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
            fconfigure $s -buffering line
................................................................................
	}
    }
    close $s
    catch {set x [gets $f]}
    close $f
    set x
} {done 50}
test socket-2.9 {socket conflict} {stdio} {
    set s [socket -server accept 2828]
    removeFile script
    set f [open script w]
    puts -nonewline $f {socket -server accept 2828}
    close $f
    set f [open "|[list $tcltest script]" r]
    gets $f
................................................................................
    set x [list [catch {close $f} msg] $msg]
    close $s
    set x
} {1 {couldn't open socket: address already in use
    while executing
"socket -server accept 2828"
    (file "script" line 1)}}
test socket-2.10 {close on accept, accepted socket lives} {
    set done 0
    set timer [after 20000 "set done timed_out"]
    set ss [socket -server accept 2830]
    proc accept {s a p} {
	global ss
	close $ss
	fileevent $s readable "readit $s"
................................................................................
    set cs [socket [info hostname] 2830]
    puts $cs hello
    close $cs
    vwait done
    after cancel $timer
    set done
} 1
test socket-2.11 {detecting new data} {
    proc accept {s a p} {
	global sock
	set sock $s
    }

    set s [socket -server accept 2400]
    set sock ""
................................................................................
    close $s2
    close $s
    close $sock
    set result
} {one {} two}


test socket-3.1 {socket conflict} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set f [socket -server accept 2828]
	puts ready
	gets stdin
	close $f
................................................................................
    gets $f
    set x [list [catch {socket -server accept 2828} msg] \
		$msg]
    puts $f bye
    close $f
    set x
} {1 {couldn't open socket: address already in use}}
test socket-3.2 {server with several clients} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set t1 [after 30000 "set x timed_out"]
	set t2 [after 31000 "set x timed_out"]
	set t3 [after 32000 "set x timed_out"]
	set counter 0
................................................................................
    close $s2
    close $s3
    lappend x [gets $f]
    close $f
    set x
} {ready done}

test socket-4.1 {server with several clients} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	gets stdin
	set s [socket 127.0.0.1 2828]
	fconfigure $s -buffering line
	for {set i 0} {$i < 100} {incr i} {
................................................................................
    puts $p2 bye
    puts $p3 bye
    close $p1
    close $p2
    close $p3
    set l
} {{p1 bye done} {p2 bye done} {p3 bye done}}
test socket-4.2 {byte order problems, socket numbers, htons} {
    set x ok
    if {[catch {socket -server dodo 0x3000} msg]} {
	set x $msg
    } else {
	close $msg
    }
    set x
} ok

test socket-5.1 {byte order problems, socket numbers, htons} {unixOnly} {
    #
    # THIS TEST WILL FAIL if you are running as superuser.
    #

    set x {couldn't open socket: not owner}
    if {![catch {socket -server dodo 0x1} msg]} {
        set x {htons problem, should be disallowed, are you running as SU?}
	close $msg
    }
    set x
} {couldn't open socket: not owner}
test socket-5.2 {byte order problems, socket numbers, htons} {
    set x {couldn't open socket: port number too high}
    if {![catch {socket -server dodo 0x10000} msg]} {
	set x {port resolution problem, should be disallowed}
	close $msg
    }
    set x
} {couldn't open socket: port number too high}
test socket-5.3 {byte order problems, socket numbers, htons} {unixOnly} {
    #
    # THIS TEST WILL FAIL if you are running as superuser.
    #

    set x {couldn't open socket: not owner}
    if {![catch {socket -server dodo 21} msg]} {
	set x {htons problem, should be disallowed, are you running as SU?}
	close $msg
    }
    set x
} {couldn't open socket: not owner}

test socket-6.1 {accept callback error} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	gets stdin
	socket 127.0.0.1 2848
    }
    close $f
................................................................................
    vwait x
    after cancel $timer
    close $s
    rename bgerror {}
    set x
} {{divide by zero}}

test socket-7.1 {testing socket specific options} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	socket -server accept 2820
	proc accept args {
	    global x
	    set x done
................................................................................
    close $s
    close $f
    set l ""
    lappend l [string compare [lindex $p 0] 127.0.0.1]
    lappend l [string compare [lindex $p 2] 2820]
    lappend l [llength $p]
} {0 0 3}
test socket-7.2 {testing socket specific options} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	socket -server accept 2821
	proc accept args {
	    global x
	    set x done
................................................................................
    close $s
    close $f
    set l ""
    lappend l [llength $p]
    lappend l [lindex $p 0]
    lappend l [expr [lindex $p 2] == 2821]
} {3 127.0.0.1 0}
test socket-7.3 {testing socket specific options} {
    set s [socket -server accept 2822]
    set l [fconfigure $s]
    close $s
    update
    llength $l
} 12
test socket-7.4 {testing socket specific options} {
    set s [socket -server accept 2823]
    proc accept {s a p} {
	global x
	set x [fconfigure $s -sockname]
	close $s
    }
    set s1 [socket [info hostname] 2823]
................................................................................
    vwait x
    after cancel $timer
    close $s
    close $s1
    set l ""
    lappend l [lindex $x 2] [llength $x]
} {2823 3}
test socket-7.5 {testing socket specific options} {unixOrPc} {
    set s [socket -server accept 2829]
    proc accept {s a p} {
	global x
	set x [fconfigure $s -sockname]
	close $s
    }
    set s1 [socket 127.0.0.1 2829]
................................................................................
    after cancel $timer
    close $s
    close $s1
    set l ""
    lappend l [lindex $x 0] [lindex $x 2] [llength $x]
} {127.0.0.1 2829 3}

test socket-8.1 {testing -async flag on sockets} {
    # NOTE: This test may fail on some Solaris 2.4 systems. If it does,
    # check that you have these patches installed (using showrev -p):
    #
    # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
    # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
    # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03,
    # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01,
................................................................................
    vwait x
    set z [gets $s1]
    close $s
    close $s1
    set z
} bye

test socket-9.1 {testing spurious events} {
    set len 0
    set spurious 0
    set done 0
    proc readlittle {s} {
	global spurious done len
	set l [read $s 1]
	if {[string length $l] == 0} {
................................................................................
    close $c
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    close $s
    list $spurious $len
} {0 50}
test socket-9.2 {testing async write, fileevents, flush on close} {} {
    set firstblock ""
    for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
    set secondblock ""
    for {set i 0} {$i < 16} {incr i} {
	set secondblock "b$secondblock$secondblock"
    }
    set l [socket -server accept 2832]
................................................................................
    fileevent $s readable "readit $s"
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    close $l
    set count
} 65566
test socket-9.3 {testing EOF stickyness} {
    proc count_to_eof {s} {
	global count done timer
	set l [gets $s]
	if {[eof $s]} {
	    incr count
	    if {$count > 9} {
		close $s
................................................................................
    vwait done
    close $s
    set count
} {eof is sticky}

removeFile script

test socket-10.1 {testing socket accept callback error handling} {
    set goterror 0
    proc bgerror args {global goterror; set goterror 1}
    set s [socket -server accept 2898]
    proc accept {s a p} {close $s; error}
    set c [socket 127.0.0.1 2898]
    vwait goterror
    close $s
    close $c
    set goterror
} 1

test socket-11.1 {tcp connection} {doTestsWithRemoteServer} {
    sendCommand {
	set socket9_1_test_server [socket -server accept 2834]
	proc accept {s a p} {
	    puts $s done
	    close $s
	}
    }
    set s [socket $remoteServerIP 2834]
    set r [gets $s]
    close $s
    sendCommand {close $socket9_1_test_server}
    set r
} done
test socket-11.2 {client specifies its port} {doTestsWithRemoteServer} {
    if {[info exists port]} {
	incr port
    } else {
	set port [expr 2048 + [pid]%1024]
    }
    sendCommand {
	set socket9_2_test_server [socket -server accept 2835]
................................................................................
    if {$r == $port} {
	set result ok
    } else {
	set result broken
    }
    set result
} ok
test socket-11.3 {trying to connect, no server} {doTestsWithRemoteServer} {
    set status ok
    if {![catch {set s [socket $remoteServerIp 2836]}]} {
	if {![catch {gets $s}]} {
	    set status broken
	}
	close $s
    }
    set status
} ok
test socket-11.4 {remote echo, one line} {doTestsWithRemoteServer} {
    sendCommand {
	set socket10_6_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fileevent $s readable [list echo $s]
	    fconfigure $s -buffering line -translation crlf
	}
	proc echo {s} {
................................................................................
    fconfigure $f -translation crlf -buffering line
    puts $f hello
    set r [gets $f]
    close $f
    sendCommand {close $socket10_6_test_server}
    set r
} hello
test socket-11.5 {remote echo, 50 lines} {doTestsWithRemoteServer} {
    sendCommand {
	set socket10_7_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fileevent $s readable [list echo $s]
	    fconfigure $s -buffering line -translation crlf
	}
	proc echo {s} {
................................................................................
} 50
# Macintosh sockets can have more than one server per port
if {$tcl_platform(platform) == "macintosh"} {
    set conflictResult {0 2836}
} else {
    set conflictResult {1 {couldn't open socket: address already in use}}
}
test socket-11.6 {socket conflict} {doTestsWithRemoteServer} {
    set s1 [socket -server accept 2836]
    if {[catch {set s2 [socket -server accept 2836]} msg]} {
	set result [list 1 $msg]
    } else {
	set result [list 0 [lindex [fconfigure $s2 -sockname] 2]]
	close $s2
    }
    close $s1
    set result
} $conflictResult
test socket-11.7 {server with several clients} {doTestsWithRemoteServer} {
    sendCommand {
	set socket10_9_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fconfigure $s -buffering line
	    fileevent $s readable [list echo $s]
	}
	proc echo {s} {
................................................................................
    }
    close $s1
    close $s2
    close $s3
    sendCommand {close $socket10_9_test_server}
    set i
} 100    
test socket-11.8 {client with several servers} {doTestsWithRemoteServer} {
    sendCommand {
	set s1 [socket -server "accept 4003" 4003]
	set s2 [socket -server "accept 4004" 4004]
	set s3 [socket -server "accept 4005" 4005]
	proc accept {mp s a p} {
	    puts $s $mp
	    close $s
................................................................................
    sendCommand {
	close $s1
	close $s2
	close $s3
    }
    set l
} {4003 {} 1 4004 {} 1 4005 {} 1}
test socket-11.9 {accept callback error} {doTestsWithRemoteServer} {
    set s [socket -server accept 2836]
    proc accept {s a p} {expr 10 / 0}
    proc bgerror args {
	global x
	set x $args
    }
    if {[catch {sendCommand {
................................................................................
    set timer [after 10000 "set x timed_out"]
    vwait x
    after cancel $timer
    close $s
    rename bgerror {}
    set x
} {{divide by zero}}
test socket-11.10 {testing socket specific options} {doTestsWithRemoteServer} {
    sendCommand {
	set socket10_12_test_server [socket -server accept 2836]
	proc accept {s a p} {close $s}
    }
    set s [socket $remoteServerIP 2836]
    set p [fconfigure $s -peername]
    set n [fconfigure $s -sockname]
    set l ""
    lappend l [lindex $p 2] [llength $p] [llength $p]
    close $s
    sendCommand {close $socket10_12_test_server}
    set l
} {2836 3 3}
test socket-11.11 {testing spurious events} {doTestsWithRemoteServer} {
    sendCommand {
	set socket10_13_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fconfigure $s -translation "auto lf"
	    after 100 writesome $s
	}
	proc writesome {s} {
................................................................................
    fileevent $c readable "readlittle $c"
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    sendCommand {close $socket10_13_test_server}
    list $spurious $len
} {0 2690}
test socket-11.12 {testing EOF stickyness} {doTestsWithRemoteServer} {
    set counter 0
    set done 0
    proc count_up {s} {
	global counter done after_id
	set l [gets $s]
	if {[eof $s]} {
	    incr counter
................................................................................
    fileevent $c readable "count_up $c"
    set after_id [after 1000 timed_out]
    vwait done
    sendCommand {close $socket10_14_test_server}
    set done
} {EOF is sticky}
test socket-11.13 {testing async write, async flush, async close} \
	{doTestsWithRemoteServer} {
    proc readit {s} {
	global count done
	set l [read $s]
	incr count [string length $l]
	if {[eof $s]} {
	    close $s
	    set done 1
................................................................................
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    sendCommand {close $l}
    set count
} 65566

test socket-12.1 {testing inheritance of server sockets} {doTestsWithRemoteServer} {

    removeFile script1
    removeFile script2

    # Script1 is just a 10 second delay.  If the server socket
    # is inherited, it will be held open for 10 seconds

    set f [open script1 w]
................................................................................
	set x {server socket was inherited}
    }

    removeFile script1
    removeFile script2
    set x
} {server socket was not inherited}
test socket-12.2 {testing inheritance of client sockets} {doTestsWithRemoteServer} {

    removeFile script1
    removeFile script2

    # Script1 is just a 10 second delay.  If the server socket
    # is inherited, it will be held open for 10 seconds

    set f [open script1 w]
................................................................................
    if {!$failed} {
	vwait failed
    }
    removeFile script1
    removeFile script2
    set x
} {client socket was not inherited}
test socket-12.3 {testing inheritance of accepted sockets} {doTestsWithRemoteServer} {

    removeFile script1
    removeFile script2

    set f [open script1 w]
    puts $f {
	after 10000 exit
	vwait forever
................................................................................
# cleanup
if {[string match sock* $commandSocket] == 1} {
   puts $commandSocket exit
   flush $commandSocket
}
catch {close $commandSocket}
catch {close $remoteProcChan}
::test::cleanupTests
flush stdout

#
# 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.1.2.7 1999/03/23 20:06:54 hershey Exp $

# Running socket tests with a remote server:
# ------------------------------------------
# 
# Some tests in socket.test depend on the existence of a remote server to
# which they connect. The remote server must be an instance of tcltest and it
# must run the script found in the file "remote.tcl" in this directory. You
................................................................................
# either in Tcl or in the environment; if they are, it attempts to connect to
# the server. If the connection is successful, the tests using the remote
# server will be performed; otherwise, it will attempt to start the remote
# server (via exec) on platforms that support this, on the local host,
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}






#
# If remoteServerIP or remoteServerPort are not set, check in the
# environment variables for externally set values.
#

if {![info exists remoteServerIP]} {
    if {[info exists env(remoteServerIP)]} {
................................................................................
if {$doTestsWithRemoteServer} {
    catch {close $commandSocket}
    if {[catch {set commandSocket [socket $remoteServerIP \
						$remoteServerPort]}] != 0} {
	if {[info commands exec] == ""} {
	    set noRemoteTestReason "can't exec"
	    set doTestsWithRemoteServer 0



	} else {
	    set remoteServerIP 127.0.0.1
	    set remoteFile [file join [pwd] remote.tcl]
	    if {[catch {set remoteProcChan \
				[open "|[list $tcltest $remoteFile \
					-serverIsSilent \
					-port $remoteServerPort \
................................................................................
	}
    } else {
	fconfigure $commandSocket -translation crlf -buffering line
    }
}

# Some tests are run only if we are doing testing against a remote server.
set ::tcltest::testConfig(doTestsWithRemoteServer) $doTestsWithRemoteServer
if {$doTestsWithRemoteServer == 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"
    }
}

#
# If we do the tests, define a command to send a command to the
# remote server.
................................................................................
	    } else {
		append resp $line "\n"
	    }
	}
    }
}

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} {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} {socket} {
    list [catch {socket -myaddr} msg] $msg
} {1 {no argument given for -myaddr option}}
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} {socket} {
    list [catch {socket -myport} msg] $msg
} {1 {no argument given for -myport option}}
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} {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} {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} {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} {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} {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} {socket} {
    list [catch {socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}

test socket-2.1 {tcp connection} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x timed_out"]
	set f [socket -server accept 2828]
	proc accept {file addr port} {
	    global x
................................................................................
} {ready done {}}

if [info exists port] {
    incr port
} else { 
    set port [expr 2048 + [pid]%1024]
}
test socket-2.2 {tcp connection with client port specified} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket -server accept 2828]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} [list ready "hello $port"]
test socket-2.3 {tcp connection with client interface specified} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket  -server accept 2828]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready {hello 127.0.0.1}}
test socket-2.4 {tcp connection with server interface specified} {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]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready hello}
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]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready hello}
test socket-2.6 {tcp connection} {socket} {
    set status ok
    if {![catch {set sock [socket 127.0.0.1 2828]}]} {
	if {![catch {gets $sock}]} {
	    set status broken
	}
	close $sock
    }
    set status
} ok
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]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
................................................................................
    puts $s "hello abcdefghijklmnop"
    set x [gets $s]
    close $s
    set y [gets $f]
    close $f
    list $x $y
} {{hello abcdefghijklmnop} done}
test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set f [socket -server accept 2828]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
            fconfigure $s -buffering line
................................................................................
	}
    }
    close $s
    catch {set x [gets $f]}
    close $f
    set x
} {done 50}
test socket-2.9 {socket conflict} {socket stdio} {
    set s [socket -server accept 2828]
    removeFile script
    set f [open script w]
    puts -nonewline $f {socket -server accept 2828}
    close $f
    set f [open "|[list $tcltest script]" r]
    gets $f
................................................................................
    set x [list [catch {close $f} msg] $msg]
    close $s
    set x
} {1 {couldn't open socket: address already in use
    while executing
"socket -server accept 2828"
    (file "script" line 1)}}
test socket-2.10 {close on accept, accepted socket lives} {socket} {
    set done 0
    set timer [after 20000 "set done timed_out"]
    set ss [socket -server accept 2830]
    proc accept {s a p} {
	global ss
	close $ss
	fileevent $s readable "readit $s"
................................................................................
    set cs [socket [info hostname] 2830]
    puts $cs hello
    close $cs
    vwait done
    after cancel $timer
    set done
} 1
test socket-2.11 {detecting new data} {socket} {
    proc accept {s a p} {
	global sock
	set sock $s
    }

    set s [socket -server accept 2400]
    set sock ""
................................................................................
    close $s2
    close $s
    close $sock
    set result
} {one {} two}


test socket-3.1 {socket conflict} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set f [socket -server accept 2828]
	puts ready
	gets stdin
	close $f
................................................................................
    gets $f
    set x [list [catch {socket -server accept 2828} msg] \
		$msg]
    puts $f bye
    close $f
    set x
} {1 {couldn't open socket: address already in use}}
test socket-3.2 {server with several clients} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set t1 [after 30000 "set x timed_out"]
	set t2 [after 31000 "set x timed_out"]
	set t3 [after 32000 "set x timed_out"]
	set counter 0
................................................................................
    close $s2
    close $s3
    lappend x [gets $f]
    close $f
    set x
} {ready done}

test socket-4.1 {server with several clients} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	gets stdin
	set s [socket 127.0.0.1 2828]
	fconfigure $s -buffering line
	for {set i 0} {$i < 100} {incr i} {
................................................................................
    puts $p2 bye
    puts $p3 bye
    close $p1
    close $p2
    close $p3
    set l
} {{p1 bye done} {p2 bye done} {p3 bye done}}
test socket-4.2 {byte order problems, socket numbers, htons} {socket} {
    set x ok
    if {[catch {socket -server dodo 0x3000} msg]} {
	set x $msg
    } else {
	close $msg
    }
    set x
} ok

test socket-5.1 {byte order problems, socket numbers, htons} \



	{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?}
	close $msg
    }
    set x
} {couldn't open socket: not owner}
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}
	close $msg
    }
    set x
} {couldn't open socket: port number too high}
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?}
	close $msg
    }
    set x
} {couldn't open socket: not owner}

test socket-6.1 {accept callback error} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	gets stdin
	socket 127.0.0.1 2848
    }
    close $f
................................................................................
    vwait x
    after cancel $timer
    close $s
    rename bgerror {}
    set x
} {{divide by zero}}

test socket-7.1 {testing socket specific options} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	socket -server accept 2820
	proc accept args {
	    global x
	    set x done
................................................................................
    close $s
    close $f
    set l ""
    lappend l [string compare [lindex $p 0] 127.0.0.1]
    lappend l [string compare [lindex $p 2] 2820]
    lappend l [llength $p]
} {0 0 3}
test socket-7.2 {testing socket specific options} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	socket -server accept 2821
	proc accept args {
	    global x
	    set x done
................................................................................
    close $s
    close $f
    set l ""
    lappend l [llength $p]
    lappend l [lindex $p 0]
    lappend l [expr [lindex $p 2] == 2821]
} {3 127.0.0.1 0}
test socket-7.3 {testing socket specific options} {socket} {
    set s [socket -server accept 2822]
    set l [fconfigure $s]
    close $s
    update
    llength $l
} 12
test socket-7.4 {testing socket specific options} {socket} {
    set s [socket -server accept 2823]
    proc accept {s a p} {
	global x
	set x [fconfigure $s -sockname]
	close $s
    }
    set s1 [socket [info hostname] 2823]
................................................................................
    vwait x
    after cancel $timer
    close $s
    close $s1
    set l ""
    lappend l [lindex $x 2] [llength $x]
} {2823 3}
test socket-7.5 {testing socket specific options} {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 127.0.0.1 2829]
................................................................................
    after cancel $timer
    close $s
    close $s1
    set l ""
    lappend l [lindex $x 0] [lindex $x 2] [llength $x]
} {127.0.0.1 2829 3}

test socket-8.1 {testing -async flag on sockets} {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):
    #
    # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
    # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
    # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03,
    # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01,
................................................................................
    vwait x
    set z [gets $s1]
    close $s
    close $s1
    set z
} bye

test socket-9.1 {testing spurious events} {socket} {
    set len 0
    set spurious 0
    set done 0
    proc readlittle {s} {
	global spurious done len
	set l [read $s 1]
	if {[string length $l] == 0} {
................................................................................
    close $c
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    close $s
    list $spurious $len
} {0 50}
test socket-9.2 {testing async write, fileevents, flush on close} {socket} {
    set firstblock ""
    for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
    set secondblock ""
    for {set i 0} {$i < 16} {incr i} {
	set secondblock "b$secondblock$secondblock"
    }
    set l [socket -server accept 2832]
................................................................................
    fileevent $s readable "readit $s"
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    close $l
    set count
} 65566
test socket-9.3 {testing EOF stickyness} {socket} {
    proc count_to_eof {s} {
	global count done timer
	set l [gets $s]
	if {[eof $s]} {
	    incr count
	    if {$count > 9} {
		close $s
................................................................................
    vwait done
    close $s
    set count
} {eof is sticky}

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 127.0.0.1 2898]
    vwait goterror
    close $s
    close $c
    set goterror
} 1

test socket-11.1 {tcp connection} {socket doTestsWithRemoteServer} {
    sendCommand {
	set socket9_1_test_server [socket -server accept 2834]
	proc accept {s a p} {
	    puts $s done
	    close $s
	}
    }
    set s [socket $remoteServerIP 2834]
    set r [gets $s]
    close $s
    sendCommand {close $socket9_1_test_server}
    set r
} done
test socket-11.2 {client specifies its port} {socket doTestsWithRemoteServer} {
    if {[info exists port]} {
	incr port
    } else {
	set port [expr 2048 + [pid]%1024]
    }
    sendCommand {
	set socket9_2_test_server [socket -server accept 2835]
................................................................................
    if {$r == $port} {
	set result ok
    } else {
	set result broken
    }
    set result
} ok
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}]} {
	    set status broken
	}
	close $s
    }
    set status
} ok
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} {
	    fileevent $s readable [list echo $s]
	    fconfigure $s -buffering line -translation crlf
	}
	proc echo {s} {
................................................................................
    fconfigure $f -translation crlf -buffering line
    puts $f hello
    set r [gets $f]
    close $f
    sendCommand {close $socket10_6_test_server}
    set r
} hello
test socket-11.5 {remote echo, 50 lines} {socket doTestsWithRemoteServer} {
    sendCommand {
	set socket10_7_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fileevent $s readable [list echo $s]
	    fconfigure $s -buffering line -translation crlf
	}
	proc echo {s} {
................................................................................
} 50
# Macintosh sockets can have more than one server per port
if {$tcl_platform(platform) == "macintosh"} {
    set conflictResult {0 2836}
} else {
    set conflictResult {1 {couldn't open socket: address already in use}}
}
test socket-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]
    } else {
	set result [list 0 [lindex [fconfigure $s2 -sockname] 2]]
	close $s2
    }
    close $s1
    set result
} $conflictResult
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} {
	    fconfigure $s -buffering line
	    fileevent $s readable [list echo $s]
	}
	proc echo {s} {
................................................................................
    }
    close $s1
    close $s2
    close $s3
    sendCommand {close $socket10_9_test_server}
    set i
} 100    
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]
	set s3 [socket -server "accept 4005" 4005]
	proc accept {mp s a p} {
	    puts $s $mp
	    close $s
................................................................................
    sendCommand {
	close $s1
	close $s2
	close $s3
    }
    set l
} {4003 {} 1 4004 {} 1 4005 {} 1}
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 {
	global x
	set x $args
    }
    if {[catch {sendCommand {
................................................................................
    set timer [after 10000 "set x timed_out"]
    vwait x
    after cancel $timer
    close $s
    rename bgerror {}
    set x
} {{divide by zero}}
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}
    }
    set s [socket $remoteServerIP 2836]
    set p [fconfigure $s -peername]
    set n [fconfigure $s -sockname]
    set l ""
    lappend l [lindex $p 2] [llength $p] [llength $p]
    close $s
    sendCommand {close $socket10_12_test_server}
    set l
} {2836 3 3}
test socket-11.11 {testing spurious events} {socket doTestsWithRemoteServer} {
    sendCommand {
	set socket10_13_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fconfigure $s -translation "auto lf"
	    after 100 writesome $s
	}
	proc writesome {s} {
................................................................................
    fileevent $c readable "readlittle $c"
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    sendCommand {close $socket10_13_test_server}
    list $spurious $len
} {0 2690}
test socket-11.12 {testing EOF stickyness} {socket doTestsWithRemoteServer} {
    set counter 0
    set done 0
    proc count_up {s} {
	global counter done after_id
	set l [gets $s]
	if {[eof $s]} {
	    incr counter
................................................................................
    fileevent $c readable "count_up $c"
    set after_id [after 1000 timed_out]
    vwait done
    sendCommand {close $socket10_14_test_server}
    set done
} {EOF is sticky}
test socket-11.13 {testing async write, async flush, async close} \
	{socket doTestsWithRemoteServer} {
    proc readit {s} {
	global count done
	set l [read $s]
	incr count [string length $l]
	if {[eof $s]} {
	    close $s
	    set done 1
................................................................................
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    sendCommand {close $l}
    set count
} 65566

test socket-12.1 {testing inheritance of server sockets} \
	{socket doTestsWithRemoteServer} {
    removeFile script1
    removeFile script2

    # Script1 is just a 10 second delay.  If the server socket
    # is inherited, it will be held open for 10 seconds

    set f [open script1 w]
................................................................................
	set x {server socket was inherited}
    }

    removeFile script1
    removeFile script2
    set x
} {server socket was not inherited}
test socket-12.2 {testing inheritance of client sockets} \
	{socket doTestsWithRemoteServer} {
    removeFile script1
    removeFile script2

    # Script1 is just a 10 second delay.  If the server socket
    # is inherited, it will be held open for 10 seconds

    set f [open script1 w]
................................................................................
    if {!$failed} {
	vwait failed
    }
    removeFile script1
    removeFile script2
    set x
} {client socket was not inherited}
test socket-12.3 {testing inheritance of accepted sockets} \
	{socket doTestsWithRemoteServer} {
    removeFile script1
    removeFile script2

    set f [open script1 w]
    puts $f {
	after 10000 exit
	vwait forever
................................................................................
# cleanup
if {[string match sock* $commandSocket] == 1} {
   puts $commandSocket exit
   flush $commandSocket
}
catch {close $commandSocket}
catch {close $remoteProcChan}
::tcltest::cleanupTests
flush stdout
return

# 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.1.2.3 1999/03/11 18:50:09 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test source-1.1 {source command} {
    set x "old x value"
    set y "old y value"
    set z "old z value"
................................................................................
    set x {}
    makeFile [list set x "a b\0c"] source.file
    source source.file
    string length $x
} 5

# cleanup
catch {::test::removeFile source.file}
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:55 hershey Exp $

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"
    set y "old y value"
    set z "old z value"
................................................................................
    set x {}
    makeFile [list set x "a b\0c"] source.file
    source source.file
    string length $x
} 5

# cleanup
catch {::tcltest::removeFile source.file}
::tcltest::cleanupTests
return

# 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.1.2.2 1999/03/11 18:50:09 hershey Exp $

if {[lsearch [namespace children] ::test] == -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 "
} {a {} b {} {} c {} {}}
test split-1.2 {basic split commands} {
................................................................................
    list [catch split msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
test split-2.2 {split errors} {
    list [catch {split a b c} msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}

# cleanup
::test::cleanupTests
return

# 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.1.2.3 1999/03/23 20:06:55 hershey Exp $

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 "
} {a {} b {} {} c {} {}}
test split-1.2 {basic split commands} {
................................................................................
    list [catch split msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
test split-2.2 {split errors} {
    list [catch {split a b c} msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}

# cleanup
::tcltest::cleanupTests
return

# generates output for errors.  No output means no errors were found.
#
# 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.2.1 1999/03/11 18:50:10 hershey Exp $

if {[lsearch [namespace children] ::test] == -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.

test stack-1.1 {maxNestingDepth reached on infinite recursion} {
    proc recurse {} { return [recurse] }
    catch {recurse} rv
    rename recurse {}
    set rv
} {too many nested calls to Tcl_EvalObj (infinite loop?)}

# cleanup
::test::cleanupTests
return

# generates output for errors.  No output means no errors were found.
#
# 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.2.2 1999/03/23 20:06:56 hershey Exp $

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.

test stack-1.1 {maxNestingDepth reached on infinite recursion} {
    proc recurse {} { return [recurse] }
    catch {recurse} rv
    rename recurse {}
    set rv
} {too many nested calls to Tcl_EvalObj (infinite loop?)}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:50:11 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test string-1.1 {string compare} {
    string compare abcde abdef
} -1
test string-1.2 {string compare} {
................................................................................
    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 string-15.2 {error conditions} {
    list [catch {string} msg] $msg
} {1 {wrong # args: should be "string option arg ?arg ...?"}}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:56 hershey Exp $

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
} -1
test string-1.2 {string compare} {
................................................................................
    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 string-15.2 {error conditions} {
    list [catch {string} msg] $msg
} {1 {wrong # args: should be "string option arg ?arg ...?"}}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:50:11 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test stringObj-1.1 {string type registration} {
    set t [testobj types]
    set first [string first "string" $t]
    set result [expr {$first != -1}]
................................................................................
	    [teststringobj length 2] [teststringobj length2 2] \
	    [teststringobj get 2]
} {5 10 5 5 abcde}

testobj freeallvars

# cleanup
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:57 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test stringObj-1.1 {string type registration} {
    set t [testobj types]
    set first [string first "string" $t]
    set result [expr {$first != -1}]
................................................................................
	    [teststringobj length 2] [teststringobj length2 2] \
	    [teststringobj get 2]
} {5 10 5 5 abcde}

testobj freeallvars

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:50:11 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test subst-1.1 {basics} {
    list [catch {subst} msg] $msg
} {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}}
test subst-1.2 {basics} {
................................................................................
} {abc $x 3 \A}
test subst-7.7 {switches} {
    set x 123
    subst -nov -nob -noc {abc $x [expr 1+2] \\\x41}
} {abc $x [expr 1+2] \\\x41}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:57 hershey Exp $

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
} {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}}
test subst-1.2 {basics} {
................................................................................
} {abc $x 3 \A}
test subst-7.7 {switches} {
    set x 123
    subst -nov -nob -noc {abc $x [expr 1+2] \\\x41}
} {abc $x [expr 1+2] \\\x41}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.4 1999/03/11 18:50:12 hershey Exp $

if {[lsearch [namespace children] ::test] == -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}
} 1
test switch-1.2 {simple patterns} {
................................................................................
    	1 {set msg 1}
        2 {}
        default {set msg 2}
    }
} {}

# cleanup
::test::cleanupTests
return

# 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.1.2.5 1999/03/23 20:06:58 hershey Exp $

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}
} 1
test switch-1.2 {simple patterns} {
................................................................................
    	1 {set msg 1}
        2 {}
        default {set msg 2}
    }
} {}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.2 1999/03/11 18:50:12 hershey Exp $

if {[info command testthread] == ""} {
    puts "skipping: tests require the testthread command"
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set mainthread [testthread names]
proc ThreadReap {} {
    global mainthread
    testthread errorproc ThreadNullError
................................................................................
    set serverthread [testthread create]
    set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg]
    list $x $msg $errorCode
} {1 ERR CODE}
ThreadReap

# cleanup
::test::cleanupTests
return

#
# 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.1.2.3 1999/03/23 20:06:58 hershey Exp $

if {[info command testthread] == ""} {
    puts "skipping: tests require the testthread command"
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set mainthread [testthread names]
proc ThreadReap {} {
    global mainthread
    testthread errorproc ThreadNullError
................................................................................
    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

#
# 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.1.2.3 1999/03/11 18:50:13 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test timer-1.1 {Tcl_CreateTimerHandler procedure} {
    foreach i [after info] {
	after cancel $i
    }
................................................................................
    set x before
    after 300
    update
    set x
} {before after2 after4}

# cleanup
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:06:58 hershey Exp $

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] {
	after cancel $i
    }
................................................................................
    set x before
    after 300
    update
    set x
} {before after2 after4}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:50:13 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc traceScalar {name1 name2 op} {
    global info
    set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg]
}
................................................................................
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.

catch {unset x}
catch {unset y}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:06:59 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc traceScalar {name1 name2 op} {
    global info
    set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg]
}
................................................................................
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.

catch {unset x}
catch {unset y}

# cleanup
::tcltest::cleanupTests
return

# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixFCmd.test,v 1.1.2.4 1999/03/11 18:50:14 hershey Exp $

if {$tcl_platform(platform) != "unix"} {
    puts "skipping: Unix only tests..."
    return
}

if {[lsearch [namespace children] ::test] == -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






}

proc openup {path} {
    testchmod 777 $path
    if {[file isdirectory $path]} {
	catch {
	    foreach p [glob [file join $path *]] {
................................................................................
		openup $file
		file delete -force -- $file
	    }
	}
    }
}

test unixFCmd-1.1 {TclpRenameFile: EACCES} {
    cleanup
    file mkdir td1/td2/td3
    exec chmod 000 td1/td2
    set msg [list [catch {file rename td1/td2/td3 td2} msg] $msg]
    exec chmod 755 td1/td2
    set msg
} {1 {error renaming "td1/td2/td3": permission denied}}
test unixFCmd-1.2 {TclpRenameFile: EEXIST} {
    cleanup
    file mkdir td1/td2
    file mkdir td2
    list [catch {file rename td2 td1} msg] $msg
} {1 {error renaming "td2" to "td1/td2": file already exists}}
test unixFCmd-1.3 {TclpRenameFile: EINVAL} {
    cleanup
    file mkdir td1
    list [catch {file rename td1 td1} msg] $msg
} {1 {error renaming "td1" to "td1/td1": trying to rename a volume or move a directory into itself}}
test unixFCmd-1.4 {TclpRenameFile: EISDIR} {
    # can't make it happen
} {}
test unixFCmd-1.5 {TclpRenameFile: ENOENT} {
    cleanup
    file mkdir td1
    list [catch {file rename td2 td1} msg] $msg
} {1 {error renaming "td2": no such file or directory}}
test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} {
    # can't make it happen
} {}
test unixFCmd-1.7 {TclpRenameFile: EXDEV} {
    cleanup
    file mkdir foo/bar
    file attr foo -perm 040555
    set msg [list [catch {file rename foo/bar /tmp} msg] $msg]
    catch {file delete /tmp/bar}
    catch {file attr foo -perm 040777}
    catch {file delete -force foo}
    set msg
} {1 {can't unlink "foo/bar": permission denied}}
test unixFCmd-1.8 {Checking EINTR Bug} nonPortable {
    testalarm 
    after 2000
    list [testgotsig] [testgotsig]
} {1 0}
test unixFCmd-1.9 {Checking EINTR Bug} nonPortable {
    cleanup
    set f [open tfalarm w]
    puts $f {
	after 2000
	puts "hello world"
	exit 0
    }
................................................................................
    close $f
    testalarm 
    set pipe [open "|[info nameofexecutable] tfalarm" r+]
    set line [read $pipe 1]
    catch {close $pipe}
    list $line [testgotsig]
} {h 1}
test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} {

    cleanup
    exec touch tf1
    exec touch tf2
    file copy -force tf1 tf2
} {}
test unixFCmd-2.2 {TclpCopyFile: src is symlink} {
    cleanup
    exec ln -s tf1 tf2
    file copy tf2 tf3
    file type tf3
} {link}
test unixFCmd-2.3 {TclpCopyFile: src is block} {
    cleanup
    set null "/dev/null"
    while {[file type $null] != "characterSpecial"} {
	set null [file join [file dirname $null] [file readlink $null]]
    }
    # file copy $null tf1
} {}
test unixFCmd-2.4 {TclpCopyFile: src is fifo} {
    cleanup
    if [catch {exec mknod tf1 p}] {
	list 1
    } else {
	file copy tf1 tf2
	expr {"[file type tf1]" == "[file type tf2]"}
    }
} {1}
test unixFCmd-2.5 {TclpCopyFile: copy attributes} {
    cleanup
    exec touch tf1
    exec chmod 472 tf1
    file copy tf1 tf2
    string range [exec ls -l tf2] 0 9
} {-r--rwx-w-}

test unixFCmd-3.1 {CopyFile not done} {
} {}

test unixFCmd-4.1 {TclpDeleteFile not done} {
} {}

test unixFCmd-5.1 {TclpCreateDirectory not done} {
} {}

test unixFCmd-6.1 {TclpCopyDirectory not done} {
} {}

test unixFCmd-7.1 {TclpRemoveDirectory not done} {
} {}

test unixFCmd-8.1 {TraverseUnixTree not done} {
} {}

test unixFCmd-9.1 {TraversalCopy not done} {
} {}

test unixFCmd-10.1 {TraversalDelete not done} {
} {}

test unixFCmd-11.1 {CopyFileAttrs not done} {
} {}

set ::test::testConfig(tclGroup) 0
if {[catch {exec {groups}} groupList] == 0} {
    if {[lsearch $groupList tcl] != -1} {
	set ::test::testConfig(tclGroup) 1
    }
}

test unixFCmd-12.1 {GetGroupAttribute - file not found} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -group} msg] $msg
} {1 {could not read "foo.test": no such file or directory}}
test unixFCmd-12.2 {GetGroupAttribute - file found} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]
    list [catch {file attributes foo.test -group}] [file delete -force -- foo.test]
} {0 {}}

test unixFCmd-13.1 {GetOwnerAttribute - file not found} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -group} msg] $msg
} {1 {could not read "foo.test": no such file or directory}}
test unixFCmd-13.2 {GetOwnerAttribute} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]

    list [catch {file attributes foo.test -owner} msg] [string compare $msg $user] [file delete -force -- foo.test]
} {0 0 {}}

test unixFCmd-14.1 {GetPermissionsAttribute - file not found} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -permissions} msg] $msg
} {1 {could not read "foo.test": no such file or directory}}
test unixFCmd-14.2 {GetPermissionsAttribute} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]
    list [catch {file attribute foo.test -permissions}] [file delete -force -- foo.test]

} {0 {}}










#groups hard to test
test unixFCmd-15.1 {SetGroupAttribute - invalid group} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -group foozzz} msg] $msg [file delete -force -- foo.test]

} {1 {could not set group for file "foo.test": group "foozzz" does not exist} {}}
test unixFCmd-15.2 {SetGroupAttribute - invalid file} {tclGroup} {

    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -group tcl} msg] $msg
} {1 {could not set group for file "foo.test": no such file or directory}}

#changing owners hard to do
test unixFCmd-16.1 {SetOwnerAttribute - current owner} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]

    list [catch {file attributes foo.test -owner $user} msg] $msg [string compare [file attributes foo.test -owner] $user] [file delete -force -- foo.test]

} {0 {} 0 {}}
test unixFCmd-16.2 {SetOwnerAttribute - invalid file} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -owner $user} msg] $msg
} {1 {could not set owner for file "foo.test": no such file or directory}}
test unixFCmd-16.3 {SetOwnerAttribute - invalid owner} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -owner foozzz} msg] $msg
} {1 {could not set owner for file "foo.test": user "foozzz" does not exist}}


test unixFCmd-17.1 {SetPermissionsAttribute} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]
    list [catch {file attributes foo.test -permissions 0000} msg] $msg [file attributes foo.test -permissions] [file delete -force -- foo.test]


} {0 {} 00000 {}}
test unixFCmd-17.2 {SetPermissionsAttribute} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -permissions 0000} msg] $msg
} {1 {could not set permissions for file "foo.test": no such file or directory}}
test unixFCmd-17.3 {SetPermissionsAttribute} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]
    list [catch {file attributes foo.test -permissions foo} msg] $msg [file delete -force -- foo.test]

} {1 {expected integer but got "foo"} {}}
test unixFCmd-18.1 {Unix pwd} {nonPortable} {
    # This test is nonportable because SunOS generates a weird error
    # message when the current directory isn't readable.
    set cd [pwd]
    set nd $cd/tstdir
    file mkdir $nd
    cd $nd
    exec chmod 000 $nd
................................................................................
    exec chmod 755 $nd
    file delete $nd
    set r
} {1 {error getting working directory name:}}

# cleanup
cleanup
::test::cleanupTests
return

# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixFCmd.test,v 1.1.2.5 1999/03/23 20:07:00 hershey Exp $






if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# 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} {
    testchmod 777 $path
    if {[file isdirectory $path]} {
	catch {
	    foreach p [glob [file join $path *]] {
................................................................................
		openup $file
		file delete -force -- $file
	    }
	}
    }
}

test unixFCmd-1.1 {TclpRenameFile: EACCES} {unixOnly notRoot} {
    cleanup
    file mkdir td1/td2/td3
    exec chmod 000 td1/td2
    set msg [list [catch {file rename td1/td2/td3 td2} msg] $msg]
    exec chmod 755 td1/td2
    set msg
} {1 {error renaming "td1/td2/td3": permission denied}}
test unixFCmd-1.2 {TclpRenameFile: EEXIST} {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} {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} {unixOnly notRoot} {
    # can't make it happen
} {}
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} {emptyTest unixOnly notRoot} {
    # can't make it happen
} {}
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]
    catch {file delete /tmp/bar}
    catch {file attr foo -perm 040777}
    catch {file delete -force foo}
    set msg
} {1 {can't unlink "foo/bar": 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} {unixOnly notRoot nonPortable} {
    cleanup
    set f [open tfalarm w]
    puts $f {
	after 2000
	puts "hello world"
	exit 0
    }
................................................................................
    close $f
    testalarm 
    set pipe [open "|[info nameofexecutable] tfalarm" r+]
    set line [read $pipe 1]
    catch {close $pipe}
    list $line [testgotsig]
} {h 1}
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} {unixOnly notRoot} {
    cleanup
    exec ln -s tf1 tf2
    file copy tf2 tf3
    file type tf3
} {link}
test unixFCmd-2.3 {TclpCopyFile: src is block} {unixOnly notRoot} {
    cleanup
    set null "/dev/null"
    while {[file type $null] != "characterSpecial"} {
	set null [file join [file dirname $null] [file readlink $null]]
    }
    # file copy $null tf1
} {}
test unixFCmd-2.4 {TclpCopyFile: src is fifo} {unixOnly notRoot} {
    cleanup
    if [catch {exec mknod tf1 p}] {
	list 1
    } else {
	file copy tf1 tf2
	expr {"[file type tf1]" == "[file type tf2]"}
    }
} {1}
test unixFCmd-2.5 {TclpCopyFile: copy attributes} {unixOnly notRoot} {
    cleanup
    exec touch tf1
    exec chmod 472 tf1
    file copy tf1 tf2
    string range [exec ls -l tf2] 0 9
} {-r--rwx-w-}

test unixFCmd-3.1 {CopyFile not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-4.1 {TclpDeleteFile not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-5.1 {TclpCreateDirectory not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-6.1 {TclpCopyDirectory not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-7.1 {TclpRemoveDirectory not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-8.1 {TraverseUnixTree not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-9.1 {TraversalCopy not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-10.1 {TraversalDelete not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-11.1 {CopyFileAttrs not done} {emptyTest unixOnly notRoot} {
} {}








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 read "foo.test": no such file or directory}}
test unixFCmd-12.2 {GetGroupAttribute - file found} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]
    list [catch {file attributes foo.test -group}] [file delete -force -- foo.test]
} {0 {}}

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 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]
} {0 0 {}}

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 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]
} {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} {unixOnly notRoot} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -group foozzz} msg] \
	    $msg [file delete -force -- foo.test]
} {1 {could not set group for file "foo.test": group "foozzz" does not exist} {}}
test unixFCmd-15.2 {SetGroupAttribute - invalid file} \
	{unixOnly notRoot foundGroup} {
    catch {file delete -force -- foo.test}
    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} {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]
} {0 {} 0 {}}
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} {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} {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]
} {0 {} 00000 {}}
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} {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]
} {1 {expected integer but got "foo"} {}}
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]
    set nd $cd/tstdir
    file mkdir $nd
    cd $nd
    exec chmod 000 $nd
................................................................................
    exec chmod 755 $nd
    file delete $nd
    set r
} {1 {error getting working directory name:}}

# cleanup
cleanup
::tcltest::cleanupTests
return

# generates output for errors.  No output means no errors were found.
#
# 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.1.2.2 1999/03/11 18:50:14 hershey Exp $

if {$tcl_platform(platform) != "unix"} {
    puts "skipping: Unix only tests..."
    return
}

if {[lsearch [namespace children] ::test] == -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"
    return
}


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} {
    set env(PATH) ""
    testfindexecutable junk
} $absPath
test unixFile-1.2 {Tcl_FindExecutable} {
    set env(PATH) "/dummy"
    testfindexecutable junk
} {}
test unixFile-1.3 {Tcl_FindExecutable} {
    set env(PATH) "/dummy:[pwd]"
    testfindexecutable junk
} $absPath
test unixFile-1.4 {Tcl_FindExecutable} {
    set env(PATH) "/dummy:"
    testfindexecutable junk
} $absPath
test unixFile-1.5 {Tcl_FindExecutable} {
    set env(PATH) "/dummy:/dummy"
    testfindexecutable junk
} {}
test unixFile-1.6 {Tcl_FindExecutable} {
    set env(PATH) "/dummy::/dummy"
    testfindexecutable junk
} $absPath
test unixFile-1.7 {Tcl_FindExecutable} {
    set env(PATH) ":/dummy"
    testfindexecutable junk
} $absPath

# cleanup
set env(PATH) $oldPath
file delete junk
::test::cleanupTests
return

# generates output for errors.  No output means no errors were found.
#
# 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.1.2.3 1999/03/23 20:07:00 hershey 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 \"testfindexecutable\""
    puts "command, so I can't test the Tcl_FindExecutable function"
    return
}

catch {
    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} {unixOnly} {
    set env(PATH) ""
    testfindexecutable junk
} $absPath
test unixFile-1.2 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) "/dummy"
    testfindexecutable junk
} {}
test unixFile-1.3 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) "/dummy:[pwd]"
    testfindexecutable junk
} $absPath
test unixFile-1.4 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) "/dummy:"
    testfindexecutable junk
} $absPath
test unixFile-1.5 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) "/dummy:/dummy"
    testfindexecutable junk
} {}
test unixFile-1.6 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) "/dummy::/dummy"
    testfindexecutable junk
} $absPath
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

#
# 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.1.2.4 1999/03/12 23:28:30 surles Exp $

if {$tcl_platform(platform) != "unix"} {
    puts "skipping: Unix only tests..."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {csh -c "setenv LANG japanese"}] == 0} {
    set ::test::testConfig(japanese) 1
}

catch {set oldlibrary $env(TCL_LIBRARY); unset env(TCL_LIBRARY)}
catch {set oldlang $env(LANG)}
set env(LANG) C

test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {
    set x {}

    set f [open "|[list $tcltest]" w+]
    exec kill -PIPE [pid $f]
    lappend x [catch {close $f}]

    set f [open "|[list $tcltest]" w+]
................................................................................
    fconfigure $f -buffering none
    puts $f {puts $tcl_libPath; exit}
    set path [gets $f]
    close $f
    return $path
}

test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} {
    set origDir [testgetdefenc]
    testsetdefenc slappy
    set path [testgetdefenc]
    testsetdefenc $origDir
    set path
} {slappy}
test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} {
    set path [getlibpath]

    set installLib lib/tcl[info tclversion]
    if {[string match {*[ab]*} [info patchlevel]]} {
	set developLib tcl[info patchlevel]/library
    } else {
        set developLib tcl[info tclversion]/library
................................................................................
    set prefix [file dirname [file dirname $tcltest]]

    set x {}
    lappend x [string compare [lindex $path 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} {
    # ((str != NULL) && (str[0] != '\0')) 

    set env(TCL_LIBRARY) sparkly
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lindex $path 0
} "sparkly"
test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} {
    # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0))

    set env(TCL_LIBRARY) /a/b/tcl1.7
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lrange $path 0 1
} [list /a/b/tcl1.7 /a/b/tcl[info tclversion]]
test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} {
    # Child process translates env variable from native encoding.

    set env(TCL_LIBRARY) "\xa7"
    set x [lindex [getlibpath] 0]
    unset env(TCL_LIBRARY)
    unset env(LANG)

    set x
} "\xa7"
test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} {

    # cannot test
} {}
test unixInit-2.6 {TclpInitLibraryPath: executable relative} {
    file delete -force /tmp/sparkly
    file mkdir /tmp/sparkly/bin
    file copy $tcltest /tmp/sparkly/bin/tcltest

    file mkdir /tmp/sparkly/lib/tcl[info tclversion]
    close [open /tmp/sparkly/lib/tcl[info tclversion]/init.tcl w]

    set x [lrange [getlibpath /tmp/sparkly/bin/tcltest] 0 2]
    file delete -force /tmp/sparkly
    set x
} [list /tmp/sparkly/lib/tcl[info tclversion] /tmp/tcl[info patchlevel]/library]
test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} {

    # would need test command to get defaultLibDir and compare it to
    # [lindex $auto_path end]
} {}
test unixInit-3.1 {TclpSetInitialEncodings} {
    set env(LANG) C

    set f [open "|[list $tcltest]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f
    unset env(LANG)

    set enc
} {iso8859-1}
test unixInit-3.1 {TclpSetInitialEncodings} {japanese nonPortable} {
    set env(LANG) japanese

    set f [open "|[list $tcltest]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f
    unset env(LANG)

    set enc
} {euc-jp}
    
test unixInit-4.1 {TclpSetVariables} {
    # just make sure they exist

    set a [list $tcl_library $tcl_pkgPath $tcl_platform(os)]
    set a [list $tcl_platform(osVersion) $tcl_platform(machine)]
    set tcl_platform(platform)
} "unix"

test unixInit-5.1 {Tcl_Init} {
    # test initScript
} {}

test unixInit-6.1 {Tcl_SourceRCFile} {
} {}
    
# cleanup
catch {unset env(TCL_LIBRARY); set env(TCL_LIBRARY) $oldlibrary}
catch {unset env(LANG); set env(LANG) $oldlang}
::test::cleanupTests
return

#
# 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.1.2.5 1999/03/23 20:07:01 hershey Exp $






if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {csh -c "setenv LANG japanese"}] == 0} {
    set ::tcltest::testConfig(japanese) 1
}

catch {set oldlibrary $env(TCL_LIBRARY); unset env(TCL_LIBRARY)}
catch {set oldlang $env(LANG)}
set env(LANG) C

test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly} {
    set x {}

    set f [open "|[list $tcltest]" w+]
    exec kill -PIPE [pid $f]
    lappend x [catch {close $f}]

    set f [open "|[list $tcltest]" w+]
................................................................................
    fconfigure $f -buffering none
    puts $f {puts $tcl_libPath; exit}
    set path [gets $f]
    close $f
    return $path
}

test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} {unixOnly} {
    set origDir [testgetdefenc]
    testsetdefenc slappy
    set path [testgetdefenc]
    testsetdefenc $origDir
    set path
} {slappy}
test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} {unixOnly} {
    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} {
    # ((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} {
    # ((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} {
    # 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} {
    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 2]
    file delete -force /tmp/sparkly
    set x
} [list /tmp/sparkly/lib/tcl[info tclversion] /tmp/tcl[info patchlevel]/library]
test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \
	{emptyTest unixOnly} {
    # would need test command to get defaultLibDir and compare it to
    # [lindex $auto_path end]
} {}
test unixInit-3.1 {TclpSetInitialEncodings} {unixOnly} {
    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.1 {TclpSetInitialEncodings} {unixOnly japanese nonPortable} {
    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

#
# 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.1.2.3 1999/03/11 18:50:15 hershey Exp $

if {$tcl_platform(platform) != "unix"} {
    puts "skipping: Unix only tests..."
    return
}

# The tests should not be run if you have a notifier which is unable to
# detect infinite vwaits, as the tests below will hang. The presence of
# the "testthread" command indicates that this is the case.

if {"[info commands testthread]" == "testthread"} {
    puts "skipping: tests require the testthread command..."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test unixNotfy-1.1 {Tcl_DeleteFileHandler} {
    catch {vwait x}
    set f [open foo w]
    fileevent $f writable {set x 1}
    vwait x
    close $f
    list [catch {vwait x} msg] $msg
} {1 {can't wait for variable "x":  would wait forever}}
test unixNotfy-1.2 {Tcl_DeleteFileHandler} {
    catch {vwait x}
    set f1 [open foo w]
    set f2 [open foo2 w]
    fileevent $f1 writable {set x 1}
    fileevent $f2 writable {set y 1}
    vwait x
    close $f1
................................................................................
    close $f2
    list [catch {vwait x} msg] $msg
} {1 {can't wait for variable "x":  would wait forever}}

# cleanup
file delete foo
file delete foo2
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:07:01 hershey 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 "testthread" command indicates that this is the case.

if {"[info commands testthread]" == "testthread"} {
    puts "skipping: tests require the testthread command..."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test unixNotfy-1.1 {Tcl_DeleteFileHandler} {unixOnly} {
    catch {vwait x}
    set f [open foo w]
    fileevent $f writable {set x 1}
    vwait x
    close $f
    list [catch {vwait x} msg] $msg
} {1 {can't wait for variable "x":  would wait forever}}
test unixNotfy-1.2 {Tcl_DeleteFileHandler} {unixOnly} {
    catch {vwait x}
    set f1 [open foo w]
    set f2 [open foo2 w]
    fileevent $f1 writable {set x 1}
    fileevent $f2 writable {set y 1}
    vwait x
    close $f1
................................................................................
    close $f2
    list [catch {vwait x} msg] $msg
} {1 {can't wait for variable "x":  would wait forever}}

# cleanup
file delete foo
file delete foo2
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:50:15 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}
catch {rename unknown unknown.old}

test unknown-1.1 {non-existent "unknown" command} {
................................................................................
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}
::test::cleanupTests
return 

# 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.1.2.4 1999/03/23 20:07:01 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}
catch {rename unknown unknown.old}

test unknown-1.1 {non-existent "unknown" command} {
................................................................................
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}
::tcltest::cleanupTests
return 

# 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.1.2.3 1999/03/11 18:50:16 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc a {x y} {
    newset z [expr $x+$y]
    return $z
}
................................................................................
    set y [info level 1]
}
a2
test uplevel-5.1 {info level} {set x} 1
test uplevel-5.2 {info level} {set y} a3

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:07:02 hershey Exp $

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]
    return $z
}
................................................................................
    set y [info level 1]
}
a2
test uplevel-5.1 {info level} {set x} 1
test uplevel-5.2 {info level} {set y} a3

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:50:17 hershey Exp $

if {[lsearch [namespace children] ::test] == -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}
    proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
    p1 foo bar
................................................................................
	set a(b) 1234
	foo
    } {1234}
}
catch {unset a}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:07:02 hershey Exp $

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}
    proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
    p1 foo bar
................................................................................
	set a(b) 1234
	foo
    } {1234}
}
catch {unset a}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.4 1999/03/11 18:50:17 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
    set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
................................................................................
test utf-23.1 {TclUniCharIsDigit} {
} {}

test utf-23.1 {TclUniCharIsSpace} {
} {}

# cleanup
::test::cleanupTests
return

#
# 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.1.2.5 1999/03/23 20:07:03 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
    set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
................................................................................
test utf-23.1 {TclUniCharIsDigit} {
} {}

test utf-23.1 {TclUniCharIsSpace} {
} {}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.4 1999/03/11 18:50:18 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test util-1.1 {TclFindElement procedure - binary element in middle of list} {
    lindex {0 foo\x00help 1} 1
} "foo\x00help"
test util-1.2 {TclFindElement procedure - binary element at end of list} {
................................................................................
    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

# cleanup
::test::cleanupTests
return

#
# 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.1.2.5 1999/03/23 20:07:03 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test util-1.1 {TclFindElement procedure - binary element in middle of list} {
    lindex {0 foo\x00help 1} 1
} "foo\x00help"
test util-1.2 {TclFindElement procedure - binary element at end of list} {
................................................................................
    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

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.5 1999/03/11 18:50:18 hershey Exp $
#

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {rename p ""}
catch {namespace delete test_ns_var}
catch {unset xx}
catch {unset x}
................................................................................
catch {unset y}
catch {unset i}
catch {unset a}
catch {unset xxxxx}
catch {unset aaaaa}

# cleanup
::test::cleanupTests
return

#
# 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.1.2.6 1999/03/23 20:07:04 hershey Exp $
#

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}
catch {unset xx}
catch {unset x}
................................................................................
catch {unset y}
catch {unset i}
catch {unset a}
catch {unset xxxxx}
catch {unset aaaaa}

# cleanup
::tcltest::cleanupTests
return

# 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.1.2.3 1999/03/11 18:50:19 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test while-old-1.1 {basic while loops} {
    set count 0
    while {$count < 10} {set count [expr $count+1]}
    set count
................................................................................
} {}
test while-old-5.2 {while return result} {
    set x 1
    while {$x} {set x 0}
} {}

# cleanup
::test::cleanupTests
return

# 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.1.2.4 1999/03/23 20:07:04 hershey Exp $

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
    while {$count < 10} {set count [expr $count+1]}
    set count
................................................................................
} {}
test while-old-5.2 {while return result} {
    set x 1
    while {$x} {set x 0}
} {}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.3 1999/03/11 18:50:19 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Basic "while" operation.

catch {unset i}
catch {unset a}
................................................................................
	set a [concat $a $i]
        incr i
    }
    set a
} {1 3}

# cleanup
::test::cleanupTests
return

#
# 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.1.2.4 1999/03/23 20:07:04 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Basic "while" operation.

catch {unset i}
catch {unset a}
................................................................................
	set a [concat $a $i]
        incr i
    }
    set a
} {1 3}

# cleanup
::tcltest::cleanupTests
return

#
# 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.1.2.4 1999/03/11 18:50:19 hershey Exp $
#

if {$tcl_platform(platform) != "windows"} {
    puts "skipping: Windows only tests..."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc createfile {file {string a}} {
    set f [open $file w]
    puts -nonewline $f $string
    close $f
................................................................................
	}
	if {$x != ""} {
	    catch {eval file delete -force -- $x}
	}
    }
}

set ::test::testConfig(cdrom) 0
set ::test::testConfig(exdev) 0

# find a CD-ROM so we can test read-only filesystems.

set cdrom {}
set nodrive x:
foreach p {d e f g h i j k l m n o p q r s t u v w x y z} {
    set name ${p}:/dummy~~.fil
................................................................................
	        return $f
	    }
	}
    }
    return ""
}

if {$cdrom == ""} {
    puts "Couldn't find a CD-ROM.  Skipping tests that access CD-ROM."
    puts "If you have a CD-ROM, insert a data disk and rerun tests."
} else {
    set ::test::testConfig(cdrom) 1
    set cdfile [findfile $cdrom]
}

if {[file exists c:/] && [file exists d:/]} {
    catch {file delete d:/tf1}
    if {[catch {close [open d:/tf1 w]}] == 0} {
	file delete d:/tf1
	set ::test::testConfig(exdev) 1
    }
}

file delete -force -- td1
set foo [catch {open td1 w} testfile]
if {$foo} {
    set ::test::testConfig(longFileNames) 0
} else {
    close $testfile
    set ::test::testConfig(longFileNames) 1
    file delete -force -- td1
}

# A really long file name
# length of longname is 1216 chars, which should be greater than any static
# buffer or allowable filename.

................................................................................
append longname $longname

# Uses the "testfile" command instead of the "file" command.  The "file"
# command provides several layers of sanity checks on the arguments and
# it can be difficult to actually forward "insane" arguments to the
# low-level posix emulation layer.

test winFCmd-1.1 {TclpRenameFile: errno: EACCES} {cdrom} {
    list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} {
    cleanup
    file mkdir td1/td2/td3
    file mkdir td2
    list [catch {testfile mv td2 td1/td2} msg] $msg
} {1 EEXIST} 
test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} {!$::test::testConfig(win32s) || ("[lindex [file split [pwd]] end]" == "C:/")} {
    # Don't run this test under Win32s on a drive mounted from an NT 
    # machine; it causes the NT machine to die.

    cleanup
    list [catch {testfile mv / td1} msg] $msg
} {1 EINVAL}
test winFCmd-1.4 {TclpRenameFile: errno: EINVAL} {
    cleanup
    file mkdir td1
    list [catch {testfile mv td1 td1/td2} msg] $msg
} {1 EINVAL}
test winFCmd-1.5 {TclpRenameFile: errno: EISDIR} {
    cleanup
    file mkdir td1
    createfile tf1
    list [catch {testfile mv tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-1.6 {TclpRenameFile: errno: ENOENT} {
    cleanup
    list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT}
test winFCmd-1.7 {TclpRenameFile: errno: ENOENT} {
    cleanup
    list [catch {testfile mv "" tf2} msg] $msg
} {1 ENOENT}
test winFCmd-1.8 {TclpRenameFile: errno: ENOENT} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 ""} msg] $msg
} {1 ENOENT}
test winFCmd-1.9 {TclpRenameFile: errno: ENOTDIR} {
    cleanup
    file mkdir td1
    createfile tf1
    list [catch {testfile mv td1 tf1} msg] $msg
} {1 ENOTDIR}
test winFCmd-1.10 {TclpRenameFile: errno: EXDEV} {exdev} {
    file delete -force d:/tf1
    file mkdir c:/tf1
    set msg [list [catch {testfile mv c:/tf1 d:/tf1} msg] $msg]
    file delete -force c:/tf1
    set msg
} {1 EXDEV}
test winFCmd-1.11 {TclpRenameFile: errno: EACCES} {
    cleanup
    set fd [open tf1 w]
    set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-1.12 {TclpRenameFile: errno: EACCES} {
    cleanup
    createfile tf1
    set fd [open tf2 w]
    set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-1.13 {TclpRenameFile: errno: EACCES} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {95} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 nul} msg] $msg
} {1 EACCES}
test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {nt} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 nul} msg] $msg
} {1 EEXIST}
test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} {
    cleanup
    createfile tf1 tf1
    testfile mv tf1 tf2
    list [file exists tf1] [contents tf2]
} {0 tf1}
test winFCmd-1.17 {TclpRenameFile: MoveFile() == FALSE} {
    cleanup
    list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT} 
test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} {
    cleanup
    list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT} 
test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.20 {TclpRenameFile: src is dir} {!95} {
    # under 95, this would actually succeed and move the current dir out from 
    # under the current process!

    cleanup
    file delete /tf1
    list [catch {testfile mv [pwd] /tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.21 {TclpRenameFile: long src} {
    cleanup
    list [catch {testfile mv $longname tf1} msg] $msg
} {1 ENAMETOOLONG}
test winFCmd-1.22 {TclpRenameFile: long dst} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 $longname} msg] $msg
} {1 ENAMETOOLONG}
test winFCmd-1.23 {TclpRenameFile: move dir into self} {
    cleanup
    file mkdir td1
    list [catch {testfile mv [pwd]/td1 td1/td2} msg] $msg
} {1 EINVAL}
test winFCmd-1.24 {TclpRenameFile: move a root dir} {!$::test::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!  Neat security hole in NT.

    cleanup
    list [catch {testfile mv / c:/} msg] $msg
} {1 EINVAL}
test winFCmd-1.25 {TclpRenameFile: cross file systems} {cdrom} {
    cleanup
    file mkdir td1
    list [catch {testfile mv td1 $cdrom/td1} msg] $msg
} {1 EXDEV} 
test winFCmd-1.26 {TclpRenameFile: readonly fs} {cdrom} {
    cleanup
    list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-1.27 {TclpRenameFile: open file} {
    cleanup
    set fd [open tf1 w]
    set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}    
test winFCmd-1.28 {TclpRenameFile: errno == EEXIST} {
    cleanup
    createfile tf1
    createfile tf2
    testfile mv tf1 tf2
    list [file exist tf1] [file exist tf2]
} {0 1}
test winFCmd-1.29 {TclpRenameFile: src is dir} {
    cleanup
    file mkdir td1
    createfile tf1
    list [catch {testfile mv td1 tf1} msg] $msg
} {1 ENOTDIR} 
test winFCmd-1.30 {TclpRenameFile: dst is dir} {
    cleanup
    file mkdir td1
    file mkdir td2/td2
    list [catch {testfile mv td1 td2} msg] $msg
} {1 EEXIST}
test winFCmd-1.31 {TclpRenameFile: TclpRemoveDirectory fails} {
    cleanup
    file mkdir td1
    file mkdir td2/td2
    list [catch {testfile mv td1 td2} msg] $msg
} {1 EEXIST}
test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} {
    cleanup
    file mkdir td1/td2
    file mkdir td2
    testfile mv td1 td2
    list [file exist td1] [file exist td2] [file exist td2/td2]
} {0 1 1}
test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} {exdev} {

    file mkdir d:/td1
    testchmod 000 d:/td1
    set msg [list [catch {testfile mv c:/windows d:/td1} msg] $msg]
    set msg "$msg [file writable d:/td1]"
    file delete d:/td1
    set msg
} {1 EXDEV 0}
test winFCmd-1.34 {TclpRenameFile: src is dir, dst is not} {
    file mkdir td1
    createfile tf1
    list [catch {testfile mv td1 tf1} msg] $msg
} {1 ENOTDIR}
test winFCmd-1.35 {TclpRenameFile: src is not dir, dst is} {
    file mkdir td1
    createfile tf1
    list [catch {testfile mv tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-1.36 {TclpRenameFile: src and dst not dir} {
    createfile tf1 tf1
    createfile tf2 tf2
    testfile mv tf1 tf2
    contents tf2
} {tf1}
test winFCmd-1.37 {TclpRenameFile: need to restore temp file} {
    # Can't figure out how to cause this. 
    # Need a file that can't be copied.
} {}

test winFCmd-2.1 {TclpCopyFile: errno: EACCES} {cdrom} {
    cleanup
    list [catch {testfile cp $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-2.2 {TclpCopyFile: errno: EISDIR} {
    cleanup
    file mkdir td1
    list [catch {testfile cp td1 tf1} msg] $msg
} {1 EISDIR}
test winFCmd-2.3 {TclpCopyFile: errno: EISDIR} {
    cleanup
    createfile tf1
    file mkdir td1
    list [catch {testfile cp tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-2.4 {TclpCopyFile: errno: ENOENT} {
    cleanup
    list [catch {testfile cp tf1 tf2} msg] $msg
} {1 ENOENT}
test winFCmd-2.5 {TclpCopyFile: errno: ENOENT} {
    cleanup
    list [catch {testfile cp "" tf2} msg] $msg
} {1 ENOENT}
test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} {
    cleanup
    createfile tf1
    list [catch {testfile cp tf1 ""} msg] $msg
} {1 ENOENT}
test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {!nt} {
    cleanup
    createfile tf1
    set fd [open tf2 w]
    set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
................................................................................
    cleanup
    list [catch {testfile cp nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} {95} {
    cleanup
    list [catch {testfile cp nul tf1} msg] $msg
} {1 ENOENT}
test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} {
    cleanup
    createfile tf1 tf1
    testfile cp tf1 tf2
    list [contents tf1] [contents tf2]
} {tf1 tf1}
test winFCmd-2.11 {TclpCopyFile: CopyFile succeeds} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testfile cp tf1 tf2
    list [contents tf1] [contents tf2]
} {tf1 tf1}
test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} {
    cleanup
    createfile tf1 tf1
    testchmod 000 tf1
    testfile cp tf1 tf2
    list [contents tf2] [file writable tf2]
} {tf1 0}
test winFCmd-2.13 {TclpCopyFile: CopyFile fails} {
    cleanup
    createfile tf1
    file mkdir td1
    list [catch {testfile cp tf1 td1} msg] $msg
} {1 EISDIR} 
test winFCmd-2.14 {TclpCopyFile: errno == EACCES} {
    cleanup
    file mkdir td1
    list [catch {testfile cp td1 tf1} msg] $msg
} {1 EISDIR}
test winFCmd-2.15 {TclpCopyFile: src is directory} {
    cleanup
    file mkdir td1
    list [catch {testfile cp td1 tf1} msg] $msg
} {1 EISDIR}
test winFCmd-2.16 {TclpCopyFile: dst is directory} {
    cleanup
    createfile tf1
    file mkdir td1
    list [catch {testfile cp tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-2.17 {TclpCopyFile: dst is readonly} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testchmod 000 tf2
    testfile cp tf1 tf2
    list [file writable tf2] [contents tf2]
} {1 tf1}
................................................................................
    testchmod 000 tf2
    set fd [open tf2]
    set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
    close $fd
    set msg "$msg [file writable tf2]"
} {1 EACCES 0}    

test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} {cdrom} {
    list [catch {testfile rm $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-3.2 {TclpDeleteFile: errno: EISDIR} {
    cleanup
    file mkdir td1
    list [catch {testfile rm td1} msg] $msg
} {1 EISDIR} 
test winFCmd-3.3 {TclpDeleteFile: errno: ENOENT} {
    cleanup
    list [catch {testfile rm tf1} msg] $msg
} {1 ENOENT}
test winFCmd-3.4 {TclpDeleteFile: errno: ENOENT} {
    cleanup
    list [catch {testfile rm ""} msg] $msg
} {1 ENOENT}
test winFCmd-3.5 {TclpDeleteFile: errno: EACCES} {
    cleanup
    set fd [open tf1 w]
    set msg [list [catch {testfile rm tf1} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-3.6 {TclpDeleteFile: errno: EACCES} {
    cleanup
    list [catch {testfile rm nul} msg] $msg
} {1 EACCES}
test winFCmd-3.7 {TclpDeleteFile: DeleteFile succeeds} {
    cleanup
    createfile tf1
    testfile rm tf1
    file exist tf1
} {0}
test winFCmd-3.8 {TclpDeleteFile: DeleteFile fails} {
    cleanup
    file mkdir td1
    list [catch {testfile rm td1} msg] $msg
} {1 EISDIR}
test winFCmd-3.9 {TclpDeleteFile: errno == EACCES} {
    cleanup
    set fd [open tf1 w]
    set msg [list [catch {testfile rm tf1} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-3.10 {TclpDeleteFile: path is readonly} {
    cleanup
    createfile tf1
    testchmod 000 tf1
    testfile rm tf1
    file exists tf1
} {0}
test winFCmd-3.11 {TclpDeleteFile: still can't remove path} {
    cleanup
    set fd [open tf1 w]
    testchmod 000 tf1
    set msg [list [catch {testfile rm tf1} msg] $msg]
    close $fd
    set msg
} {1 EACCES}

test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {cdrom nt} {
    list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg
} {1 EACCES}
test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} {cdrom 95} {
    list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg
} {1 ENOSPC}
test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} {
    cleanup
    file mkdir td1
    list [catch {testfile mkdir td1} msg] $msg
} {1 EEXIST}
test winFCmd-4.4 {TclpCreateDirectory: errno: ENOENT} {
    cleanup
    list [catch {testfile mkdir td1/td2} msg] $msg
} {1 ENOENT}
test winFCmd-4.5 {TclpCreateDirectory: CreateDirectory succeeds} {
    cleanup
    testfile mkdir td1
    file type td1
} {directory}

test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} {
    cleanup
    file mkdir td1
    testfile cpdir td1 td2
    list [file type td1] [file type td2]
} {directory directory}

test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    testfile rmdir td1
    file exist td1
} {0}
test winFCmd-6.2 {TclpRemoveDirectory: errno: EEXIST} {
    cleanup
    file mkdir td1/td2
    list [catch {testfile rmdir td1} msg] $msg
} {1 {td1 EEXIST}}
test winFCmd-6.3 {TclpRemoveDirectory: errno: EACCES} {
    # can't test this w/o removing everything on your hard disk first!
    # testfile rmdir /
} {}
test winFCmd-6.4 {TclpRemoveDirectory: errno: ENOENT} {
    cleanup
    list [catch {testfile rmdir td1} msg] $msg
} {1 {td1 ENOENT}}
test winFCmd-6.5 {TclpRemoveDirectory: errno: ENOENT} {
    cleanup
    list [catch {testfile rmdir ""} msg] $msg
} {1 ENOENT}
test winFCmd-6.6 {TclpRemoveDirectory: errno: ENOTDIR} {
    cleanup
    createfile tf1
    list [catch {testfile rmdir tf1} msg] $msg
} {1 {tf1 ENOTDIR}}
test winFCmd-6.7 {TclpRemoveDirectory: RemoveDirectory succeeds} {
    cleanup
    file mkdir td1
    testfile rmdir td1
    file exists td1
} {0}
test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} {
    cleanup
    createfile tf1
    list [catch {testfile rmdir tf1} msg] $msg
} {1 {tf1 ENOTDIR}}
test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    testfile rmdir td1
    file exists td1
} {0}
test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {!nt} {
    cleanup
    list [catch {testfile rmdir nul} msg] $msg
} {1 {nul EACCES}}
test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {nt} {
    cleanup
    list [catch {testfile rmdir /} msg] $msg
} {1 {\ EACCES}}
test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {!nt} {
    cleanup
    createfile tf1
    list [catch {testfile rmdir tf1} msg] $msg
} {1 {tf1 ENOTDIR}}
test winFCmd-6.13 {TclpRemoveDirectory: write-protected} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    testfile rmdir td1
    file exists td1
} {0}
test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {!nt} {
    cleanup
    file mkdir td1/td2
    list [catch {testfile rmdir td1} msg] $msg
} {1 {td1 EEXIST}}
test winFCmd-6.15 {TclpRemoveDirectory: !recursive} {
    cleanup
    file mkdir td1/td2
    list [catch {testfile rmdir td1} msg] $msg
} {1 {td1 EEXIST}}
test winFCmd-6.16 {TclpRemoveDirectory: recursive, but errno != EEXIST} {
    cleanup
    createfile tf1
    list [catch {testfile rmdir -force tf1} msg] $msg
} {1 {tf1 ENOTDIR}}
test winFCmd-6.17 {TclpRemoveDirectory: calls TraverseWinTree} {
    cleanup
    file mkdir td1/td2
    testfile rmdir -force td1
    file exists td1
} {0}

test winFCmd-7.1 {TraverseWinTree: targetPtr == NULL} {
    cleanup
    file mkdir td1/td2/td3
    testfile rmdir -force td1
    file exists td1
} {0}
test winFCmd-7.2 {TraverseWinTree: targetPtr != NULL} {
    cleanup
    file mkdir td1/td2/td3
    testfile cpdir td1 td2
    list [file exists td1] [file exists td2]
} {1 1}
test winFCmd-7.3 {TraverseWinTree: sourceAttr == -1} {
    cleanup
    list [catch {testfile cpdir td1 td2} msg] $msg
} {1 {td1 ENOENT}}
test winFCmd-7.4 {TraverseWinTree: source isn't directory} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} {tf1}
test winFCmd-7.5 {TraverseWinTree: call TraversalCopy: DOTREE_F} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} {tf1}
test winFCmd-7.6 {TraverseWinTree: call TraversalDelete: DOTREE_F} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile rmdir -force td1
    file exists td1
} {0}
test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} {tf1}    
test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {!nt && cdrom} {
    list [catch {testfile rmdir $cdrom/} msg] $msg
} "1 {$cdrom\\ EEXIST}"
test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} {nt cdrom} {
    list [catch {testfile rmdir $cdrom/} msg] $msg
} "1 {$cdrom\\ EACCES}"
test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} {

    # can't make it happen
} {}
test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    list [file exists td2] [file writable td2]
} {1 0}
test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile rmdir -force td1
    file exists td1
} {0}
test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} {tf1}    
test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {!nt} {
    cleanup
    file mkdir td1
    list [catch {testfile cpdir td1 /} msg] $msg
} {1 {\ EEXIST}}
test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {nt} {
    cleanup
    file mkdir td1
    list [catch {testfile cpdir td1 /} msg] $msg
} {1 {\ EACCES}}
test winFCmd-7.16 {TraverseWinTree: recurse on files: no files} {
    cleanup
    file mkdir td1
    testfile cpdir td1 td2
} {}
test winFCmd-7.17 {TraverseWinTree: recurse on files: one file} {
    cleanup
    file mkdir td1
    createfile td1/td2
    testfile cpdir td1 td2
    glob td2/*
} {td2/td2}
test winFCmd-7.18 {TraverseWinTree: recurse on files: several files and dir} {

    cleanup
    file mkdir td1
    createfile td1/tf1
    createfile td1/tf2
    file mkdir td1/td2/td3
    createfile td1/tf3
    createfile td1/tf4
    testfile cpdir td1 td2
    lsort [glob td2/*]
} {td2/td2 td2/tf1 td2/tf2 td2/tf3 td2/tf4}
test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    list [file exists td2] [file writable td2]
} {1 0}
test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} {

    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile rmdir -force td1
    file exists td1
} {0}
test winFCmd-7.21 {TraverseWinTree: fill errorPtr} {
    cleanup
    list [catch {testfile cpdir td1 td2} msg] $msg
} {1 {td1 ENOENT}}

test winFCmd-8.1 {TraversalCopy: DOTREE_F} {
    cleanup
    file mkdir td1
    list [catch {testfile cpdir td1 td1} msg] $msg
} {1 {td1 EEXIST}}
test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} {
    cleanup
    file mkdir td1/td2
    testchmod 000 td1
    testfile cpdir td1 td2
    list [file writable td1] [file writable td1/td2]
} {0 1}
test winFCmd-8.3 {TraversalCopy: DOTREE_POSTD} {
    cleanup
    file mkdir td1
    testfile cpdir td1 td2
} {}

test winFCmd-9.1 {TraversalDelete: DOTREE_F} {
    cleanup
    file mkdir td1
    createfile td1/tf1
    testfile rmdir -force td1
} {}
test winFCmd-9.2 {TraversalDelete: DOTREE_F} {95} {
    cleanup
    file mkdir td1
    set fd [open td1/tf1 w]
    set msg [list [catch {testfile rmdir -force td1} msg] $msg]
    close $fd
    set msg
} {1 {td1\tf1 EACCES}}
test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} {
    cleanup
    file mkdir td1/td2
    testchmod 000 td1
    testfile rmdir -force td1
    file exists td1
} {0}
test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} {
    cleanup
    file mkdir td1/td1/td3/td4/td5
    testfile rmdir -force td1
} {}

test winFCmd-10.1 {AttributesPosixError - get} {
    cleanup
    list [catch {file attributes td1 -archive} msg] $msg
} {1 {could not read "td1": no such file or directory}}
test winFCmd-10.2 {AttributesPosixError - set} {
    cleanup
    list [catch {file attributes td1 -archive 0} msg] $msg
} {1 {could not read "td1": no such file or directory}}

test winFCmd-11.1 {GetWinFileAttributes} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -archive} msg] $msg [cleanup]
} {0 1 {}}
test winFCmd-11.2 {GetWinFileAttributes} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -readonly} msg] $msg [cleanup]
} {0 0 {}}
test winFCmd-11.3 {GetWinFileAttributes} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -hidden} msg] $msg [cleanup]
} {0 0 {}}
test winFCmd-11.4 {GetWinFileAttributes} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -system} msg] $msg [cleanup]
} {0 0 {}}
test winfcmd-11.5 {GetWinFileAttributes} {
    # attr of relative paths that resolve to root was failing
    # don't care about answer, just that test runs.

    set old [pwd]
    cd c:/
    file attr c:	    
    file attr c:.
    file attr . 
    cd $old
} {}

test winFCmd-12.1 {ConvertFileNameFormat} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-12.2 {ConvertFileNameFormat} {
    cleanup
    file mkdir td1
    close [open td1/td1 w]
    list [catch {string tolower [file attributes td1/td1 -longname]} msg] $msg [cleanup]
} {0 td1/td1 {}}
test winFCmd-12.3 {ConvertFileNameFormat} {
    cleanup
    file mkdir td1
    file mkdir td1/td2
    close [open td1/td3 w]
    list [catch {string tolower [file attributes td1/td2/../td3 -longname]} msg] $msg [cleanup]
} {0 td1/td2/../td3 {}}
test winFCmd-12.4 {ConvertFileNameFormat} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes ./td1 -longname]} msg] $msg [cleanup]
} {0 ./td1 {}}
test winFCmd-12.5 {ConvertFileNameFormat: absolute path} {
    list [file attributes / -longname] [file attributes \\ -longname]
} {/ /}
test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} {
    catch {file delete -force -- c:/td1}
    close [open c:/td1 w]
    list [catch {string tolower [file attributes c:/td1 -longname]} msg] $msg [file delete -force -- c:/td1]
} {0 c:/td1 {}}
test winFCmd-12.7 {ConvertFileNameFormat} {nonPortable} {
    string tolower [file attributes //bisque/tcl/ws -longname]
} {//bisque/tcl/ws}
test winFCmd-12.8 {ConvertFileNameFormat} {longFileNames} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-12.9 {ConvertFileNameFormat} {win32s} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-12.10 {ConvertFileNameFormat} {longFileNames} {
    cleanup
    close [open td1td1td1 w]
    list [catch {file attributes td1td1td1 -shortname}] [cleanup]
} {0 {}}
test winFCmd-12.11 {ConvertFileNameFormat} {longFileNames} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup]
} {0 td1 {}}

test winFCmd-13.1 {GetWinFileLongName} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}

test winFCmd-14.1 {GetWinFileShortName} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup]
} {0 td1 {}}

test winFCmd-15.1 {SetWinFileAttributes} {
    cleanup
    list [catch {file attributes td1 -archive 0} msg] $msg
} {1 {could not read "td1": no such file or directory}}
test winFCmd-15.2 {SetWinFileAttributes - archive} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -archive 1} msg] $msg [file attributes td1 -archive] [cleanup]
} {0 {} 1 {}}
test winFCmd-15.3 {SetWinFileAttributes - archive} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -archive 0} msg] $msg [file attributes td1 -archive] [cleanup]
} {0 {} 0 {}}
test winFCmd-15.4 {SetWinFileAttributes - hidden} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -hidden 1} msg] $msg [file attributes td1 -hidden] [file attributes td1 -hidden 0] [cleanup]
} {0 {} 1 {} {}}
test winFCmd-15.5 {SetWinFileAttributes - hidden} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -hidden 0} msg] $msg [file attributes td1 -hidden] [cleanup]
} {0 {} 0 {}}
test winFCmd-15.6 {SetWinFileAttributes - readonly} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -readonly 1} msg] $msg [file attributes td1 -readonly] [cleanup]
} {0 {} 1 {}}
test winFCmd-15.7 {SetWinFileAttributes - readonly} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -readonly 0} msg] $msg [file attributes td1 -readonly] [cleanup]
} {0 {} 0 {}}
test winFCmd-15.8 {SetWinFileAttributes - system} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -system 1} msg] $msg [file attributes td1 -system] [cleanup]
} {0 {} 1 {}}
test winFCmd-15.9 {SetWinFileAttributes - system} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -system 0} msg] $msg [file attributes td1 -system] [cleanup]
} {0 {} 0 {}}
test winFCmd-15.10 {SetWinFileAttributes - failing} {cdrom} {
    cleanup
    catch {file attributes $cdfile -archive 1}
} {1}

cleanup

return


foreach source {tef ted tnf tnd "" nul com1} {
    foreach chmodsrc {000 755} {
        foreach dest "tfn tfe tdn tdempty tdfull td1/td2 $p $p/td1 {} nul" {
	    foreach chmoddst {000 755} {
		puts hi
		cleanup
		file delete -force ted tef
		file mkdir ted
		createfile tef
		createfile tfe
		file mkdir tdempty
		file mkdir tdfull/td1/td2

		catch {testchmod $chmodsrc $source}
		catch {testchmod $chmoddst $dest}

		if [catch {file rename $source $dest} msg] {
		    puts "file rename $source ($chmodsrc) $dest ($chmoddst)"
		    puts $msg





		}




	    }
	}
    }
}

# cleanup
::test::cleanupTests
return

#
# 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.1.2.5 1999/03/23 20:07:05 hershey Exp $
#






if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc createfile {file {string a}} {
    set f [open $file w]
    puts -nonewline $f $string
    close $f
................................................................................
	}
	if {$x != ""} {
	    catch {eval file delete -force -- $x}
	}
    }
}

set ::tcltest::testConfig(cdrom) 0
set ::tcltest::testConfig(exdev) 0

# find a CD-ROM so we can test read-only filesystems.

set cdrom {}
set nodrive x:
foreach p {d e f g h i j k l m n o p q r s t u v w x y z} {
    set name ${p}:/dummy~~.fil
................................................................................
	        return $f
	    }
	}
    }
    return ""
}

if {$cdrom != ""} {



    set ::tcltest::testConfig(cdrom) 1
    set cdfile [findfile $cdrom]
}

if {[file exists c:/] && [file exists d:/]} {
    catch {file delete d:/tf1}
    if {[catch {close [open d:/tf1 w]}] == 0} {
	file delete d:/tf1
	set ::tcltest::testConfig(exdev) 1
    }
}

file delete -force -- td1
set foo [catch {open td1 w} testfile]
if {$foo} {
    set ::tcltest::testConfig(longFileNames) 0
} else {
    close $testfile
    set ::tcltest::testConfig(longFileNames) 1
    file delete -force -- td1
}

# A really long file name
# length of longname is 1216 chars, which should be greater than any static
# buffer or allowable filename.

................................................................................
append longname $longname

# Uses the "testfile" command instead of the "file" command.  The "file"
# command provides several layers of sanity checks on the arguments and
# it can be difficult to actually forward "insane" arguments to the
# low-level posix emulation layer.

test winFCmd-1.1 {TclpRenameFile: errno: EACCES} {pcOnly cdrom} {
    list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
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} {pcOnly} {



    cleanup
    list [catch {testfile mv / td1} msg] $msg
} {1 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} {pcOnly} {
    cleanup
    file mkdir td1
    createfile tf1
    list [catch {testfile mv tf1 td1} msg] $msg
} {1 EISDIR}
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} {pcOnly} {
    cleanup
    list [catch {testfile mv "" tf2} msg] $msg
} {1 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} {pcOnly} {
    cleanup
    file mkdir td1
    createfile tf1
    list [catch {testfile mv td1 tf1} msg] $msg
} {1 ENOTDIR}
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} {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} {pcOnly} {
    cleanup
    createfile tf1
    set fd [open tf2 w]
    set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-1.13 {TclpRenameFile: errno: EACCES} {pcOnly} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {95} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 nul} msg] $msg
} {1 EACCES}
test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {nt} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 nul} msg] $msg
} {1 EEXIST}
test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} {pcOnly} {
    cleanup
    createfile tf1 tf1
    testfile mv tf1 tf2
    list [file exists tf1] [contents tf2]
} {0 tf1}
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} {pcOnly} {
    cleanup
    list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT} 
test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {pcOnly} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
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: long src} {pcOnly} {
    cleanup
    list [catch {testfile mv $longname tf1} msg] $msg
} {1 ENAMETOOLONG}
test winFCmd-1.22 {TclpRenameFile: long dst} {pcOnly} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 $longname} msg] $msg
} {1 ENAMETOOLONG}
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.24 {TclpRenameFile: move a root dir} {pcOnly} {



    cleanup
    list [catch {testfile mv / c:/} msg] $msg
} {1 EINVAL}
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.26 {TclpRenameFile: readonly fs} {pcOnly cdrom} {
    cleanup
    list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
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.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.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.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.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.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.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]
    set msg "$msg [file writable d:/td1]"
    file delete d:/td1
    set msg
} {1 EXDEV 0}
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.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.36 {TclpRenameFile: src and dst not dir} {pcOnly} {
    createfile tf1 tf1
    createfile tf2 tf2
    testfile mv tf1 tf2
    contents tf2
} {tf1}
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} {pcOnly cdrom} {
    cleanup
    list [catch {testfile cp $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
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} {pcOnly} {
    cleanup
    createfile tf1
    file mkdir td1
    list [catch {testfile cp tf1 td1} msg] $msg
} {1 EISDIR}
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} {pcOnly} {
    cleanup
    list [catch {testfile cp "" tf2} msg] $msg
} {1 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} {95} {
    cleanup
    createfile tf1
    set fd [open tf2 w]
    set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
................................................................................
    cleanup
    list [catch {testfile cp nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} {95} {
    cleanup
    list [catch {testfile cp nul tf1} msg] $msg
} {1 ENOENT}
test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} {pcOnly} {
    cleanup
    createfile tf1 tf1
    testfile cp tf1 tf2
    list [contents tf1] [contents tf2]
} {tf1 tf1}
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} {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} {pcOnly} {
    cleanup
    createfile tf1
    file mkdir td1
    list [catch {testfile cp tf1 td1} msg] $msg
} {1 EISDIR} 
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} {pcOnly} {
    cleanup
    file mkdir td1
    list [catch {testfile cp td1 tf1} msg] $msg
} {1 EISDIR}
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} {pcOnly} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testchmod 000 tf2
    testfile cp tf1 tf2
    list [file writable tf2] [contents tf2]
} {1 tf1}
................................................................................
    testchmod 000 tf2
    set fd [open tf2]
    set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
    close $fd
    set msg "$msg [file writable tf2]"
} {1 EACCES 0}    

test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} {pcOnly cdrom} {
    list [catch {testfile rm $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
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} {pcOnly} {
    cleanup
    list [catch {testfile rm tf1} msg] $msg
} {1 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} {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} {pcOnly} {
    cleanup
    list [catch {testfile rm nul} msg] $msg
} {1 EACCES}
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} {pcOnly} {
    cleanup
    file mkdir td1
    list [catch {testfile rm td1} msg] $msg
} {1 EISDIR}
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