Tcl Source Code

declare 40 generic {
    int TclGetOpenMode(Tcl_Interp *interp, const char *str, int *seekFlagPtr)
}
declare 41 generic {
    Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
declare 42 generic {
    CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr)
}
# Removed in Tcl 8.5a2
#declare 43 generic {
#    int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv,
#	    int flags)
#}
declare 44 generic {

#}
# Removed in 8.4b2:
#declare 100 generic {
#    Tcl_Obj *TclSetIndexedScalar(Tcl_Interp *interp, int localIndex,
#	    Tcl_Obj *objPtr, int flags)
#}
declare 101 generic {
    CONST86 char *TclSetPreInitScript(const char *string)
}
declare 102 generic {
    void TclSetupEnv(Tcl_Interp *interp)
}
declare 103 generic {
    int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto,
	    int *portPtr)

#ifndef TCL_NO_STACK_CHECK
MODULE_SCOPE int        TclpGetCStackParams(int **stackBoundPtr);
#endif
MODULE_SCOPE int	TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
MODULE_SCOPE Tcl_Obj *	TclpTempFileName(void);
MODULE_SCOPE Tcl_Obj *	TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep,
			    int len);
MODULE_SCOPE int	TclpDeleteFile(const void *path);
MODULE_SCOPE void	TclpFinalizeCondition(Tcl_Condition *condPtr);
MODULE_SCOPE void	TclpFinalizeMutex(Tcl_Mutex *mutexPtr);
MODULE_SCOPE void	TclpFinalizePipes(void);
MODULE_SCOPE void	TclpFinalizeSockets(void);
MODULE_SCOPE int	TclpThreadCreate(Tcl_ThreadId *idPtr,
			    Tcl_ThreadCreateProc proc, ClientData clientData,
			    int stackSize, int flags);

EXTERN TclObjCmdProcType TclGetObjInterpProc(void);
/* 40 */
EXTERN int		TclGetOpenMode(Tcl_Interp *interp, const char *str,
				int *seekFlagPtr);
/* 41 */
EXTERN Tcl_Command	TclGetOriginalCommand(Tcl_Command command);
/* 42 */
EXTERN CONST86 char *	TclpGetUserHome(const char *name,
				Tcl_DString *bufferPtr);
/* Slot 43 is reserved */
/* 44 */
EXTERN int		TclGuessPackageName(const char *fileName,
				Tcl_DString *bufPtr);
/* 45 */
EXTERN int		TclHideUnsafeCommands(Tcl_Interp *interp);

EXTERN void		TclResetShadowedCmdRefs(Tcl_Interp *interp,
				Command *newCmdPtr);
/* 98 */
EXTERN int		TclServiceIdle(void);
/* Slot 99 is reserved */
/* Slot 100 is reserved */
/* 101 */
EXTERN CONST86 char *	TclSetPreInitScript(const char *string);
/* 102 */
EXTERN void		TclSetupEnv(Tcl_Interp *interp);
/* 103 */
EXTERN int		TclSockGetPort(Tcl_Interp *interp, const char *str,
				const char *proto, int *portPtr);
/* 104 */
EXTERN int		TclSockMinimumBuffers(int sock, int size);

    void (*reserved35)(void);
    void (*reserved36)(void);
    int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */
    int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */
    TclObjCmdProcType (*tclGetObjInterpProc) (void); /* 39 */
    int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */
    Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */
    CONST86 char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */
    void (*reserved43)(void);
    int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */
    int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */
    int (*tclInExit) (void); /* 46 */
    void (*reserved47)(void);
    void (*reserved48)(void);
    void (*reserved49)(void);

    void (*reserved94)(void);
    void (*reserved95)(void);
    int (*tclRenameCommand) (Tcl_Interp *interp, const char *oldName, const char *newName); /* 96 */
    void (*tclResetShadowedCmdRefs) (Tcl_Interp *interp, Command *newCmdPtr); /* 97 */
    int (*tclServiceIdle) (void); /* 98 */
    void (*reserved99)(void);
    void (*reserved100)(void);
    CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */
    void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */
    int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */
    int (*tclSockMinimumBuffers) (int sock, int size); /* 104 */
    void (*reserved105)(void);
    void (*reserved106)(void);
    void (*reserved107)(void);
    void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */

/*
 * A pointer to a string that holds an initialization script that if non-NULL
 * is evaluated in Tcl_Init() prior to the built-in initialization script
 * above. This variable can be modified by the function below.
 */

static const char *tclPreInitScript = NULL;

/* Forward declaration */
struct Target;

/*
 * struct Alias:
 *

 *
 * Side effects:
 *	Changes the way Tcl_Init() routine behaves.
 *
 *----------------------------------------------------------------------
 */

const char *
TclSetPreInitScript(
    const char *string)		/* Pointer to a script. */
{
    const char *prevString = tclPreInitScript;
    tclPreInitScript = string;
    return(prevString);
}

/*
 *----------------------------------------------------------------------
 *

}

static void
ExitProcOdd(
    ClientData clientData)	/* Integer value to print. */
{
    char buf[16 + TCL_INTEGER_SPACE];
    size_t len;

    sprintf(buf, "odd %d\n", PTR2INT(clientData));
    len = strlen(buf);
    if (len != (size_t) write(1, buf, len)) {
		Tcl_Panic("ExitProcOdd: unable to write to stdout");
    }
}

static void
ExitProcEven(
    ClientData clientData)	/* Integer value to print. */
{
    char buf[16 + TCL_INTEGER_SPACE];
    size_t len;

    sprintf(buf, "even %d\n", PTR2INT(clientData));
    len = strlen(buf);
    if (len != (size_t) write(1, buf, len)) {
		Tcl_Panic("ExitProcEven: unable to write to stdout");
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TestexprlongCmd --
 *

}

if {[info commands ::apply] eq {}} {
    return
}

testConstraint memory [llength [info commands memory]]

# Tests for wrong number of arguments

test apply-1.1 {too few arguments} -returnCodes error -body {
    apply

} -result {wrong # args: should be "apply lambdaExpr ?arg ...?"}

# Tests for malformed lambda

test apply-2.0 {malformed lambda} -returnCodes error -body {
    set lambda a
    apply $lambda

} -result {can't interpret "a" as a lambda expression}
test apply-2.1 {malformed lambda} -returnCodes error -body {
    set lambda [list a b c d]
    apply $lambda

} -result {can't interpret "a b c d" as a lambda expression}
test apply-2.2 {malformed lambda} {
    set lambda [list {{}} boo]
    list [catch {apply $lambda} msg] $msg $::errorInfo

} {1 {argument with no name} {argument with no name
    (parsing lambda expression "{{}} boo")
    invoked from within
"apply $lambda"}}
test apply-2.3 {malformed lambda} {
    set lambda [list {{a b c}} boo]
    list [catch {apply $lambda} msg] $msg $::errorInfo

} {1 {too many fields in argument specifier "a b c"} {too many fields in argument specifier "a b c"
    (parsing lambda expression "{{a b c}} boo")
    invoked from within
"apply $lambda"}}
test apply-2.4 {malformed lambda} {
    set lambda [list a(1) boo]
    list [catch {apply $lambda} msg] $msg $::errorInfo

} {1 {formal parameter "a(1)" is an array element} {formal parameter "a(1)" is an array element
    (parsing lambda expression "a(1) boo")
    invoked from within
"apply $lambda"}}
test apply-2.5 {malformed lambda} {
    set lambda [list a::b boo]
    list [catch {apply $lambda} msg] $msg $::errorInfo

} {1 {formal parameter "a::b" is not a simple name} {formal parameter "a::b" is not a simple name
    (parsing lambda expression "a::b boo")
    invoked from within
"apply $lambda"}}

# Tests for runtime errors in the lambda expression

    namespace eval ::NONEXIST::FOR::SURE {}
    set lambda [list x {set x 1} NONEXIST::FOR::SURE]
    apply $lambda x
    namespace delete ::NONEXIST
    apply $lambda x
} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found}

test apply-4.1 {error in arguments to lambda expression} -body {
    set lambda [list x {set x 1}]
    apply $lambda

} -returnCodes error -result {wrong # args: should be "apply lambdaExpr x"}
test apply-4.2 {error in arguments to lambda expression} -body {
    set lambda [list x {set x 1}]
    apply $lambda a b

} -returnCodes error -result {wrong # args: should be "apply lambdaExpr x"}
test apply-4.3 {error in arguments to lambda expression} -body {

    interp alias {} foo {} ::apply [list x {set x 1}]
    foo a b
} -cleanup {
    rename foo {}
} -returnCodes error -result {wrong # args: should be "foo x"}
test apply-4.4 {error in arguments to lambda expression} -body {

    interp alias {} foo {} ::apply [list x {set x 1}] a
    foo b
} -cleanup {
    rename foo {}
} -returnCodes error -result {wrong # args: should be "foo"}
test apply-4.5 {error in arguments to lambda expression} -body {
    set lambda [list x {set x 1}]
    namespace eval a {
	namespace ensemble create -command ::bar -map {id {::a::const foo}}
	proc const val { return $val }
	proc alias {object slot = command args} {
	    set map [namespace ensemble configure $object -map]
	    dict set map $slot [linsert $args 0 $command]
	    namespace ensemble configure $object -map $map
	}
	proc method {object name params body} {
	    set params [linsert $params 0 self]
	    alias $object $name = ::apply [list $params $body] $object
	}
	method ::bar boo x {return "[expr {$x*$x}] - $self"}
    }
    bar boo
} -cleanup {
    namespace delete ::a
} -returnCodes error -result {wrong # args: should be "bar boo x"}

test apply-5.1 {runtime error in lambda expression} {
    set lambda [list {} {error foo}]
    set res [catch {apply $lambda}]
    list $res $::errorInfo
} {1 {foo
    while executing

	::apply [lrange $lam 0 end]
	set tmp $end
	set end [getbytes]
    }
    set leakedBytes [expr {$end - $tmp}]
} -cleanup {
    rename getbytes {}
    unset -nocomplain lam end i tmp leakedBytes
} -result 0
test apply-9.2 {leaking internal rep} -setup {
    proc getbytes {} {
	set lines [split [memory info] "\n"]
	lindex $lines 3 3
    }
} -constraints memory -body {
    set end [getbytes]
    for {set i 0} {$i < 5} {incr i} {
	::apply [list {} {set a 1}]
	set tmp $end
	set end [getbytes]
    }
    set leakedBytes [expr {$end - $tmp}]
} -cleanup {
    rename getbytes {}
    unset -nocomplain end i tmp leakedBytes
} -result 0
test apply-9.3 {leaking internal rep} -setup {
    proc getbytes {} {
	set lines [split [memory info] "\n"]
	lindex $lines 3 3
    }
} -constraints memory -body {
    set end [getbytes]
    for {set i 0} {$i < 5} {incr i} {
	set x [list {} {set a 1} ::NS::THAT::DOES::NOT::EXIST]
	catch {::apply $x}
	set x {}
	set tmp $end
	set end [getbytes]
    }
    set leakedBytes [expr {$end - $tmp}]
} -cleanup {
    rename getbytes {}
    unset -nocomplain end i x tmp leakedBytes
} -result 0

# Tests for the avoidance of recompilation

# cleanup

namespace delete testApply

::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:

} -cleanup {
    removeFile BREAKtest
} -returnCodes error -match glob -result {command returned bad code: 2
    while executing
"return -code return"
    (file "*BREAKtest" line 2)}

test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -constraints {
    testevalex
} -body {
    testevalex {a[set b [format cd]}
} -returnCodes error -result {missing close-bracket}

# Some lists for expansion tests to work with
set l1 [list a {b b} c d]
set l2 [list e f {g g} h]
proc l3 {} {
    list i j k {l l}

	default {
	    return 0
	}
    }
}

testConstraint ieeeFloatingPoint [testIEEE]

# ----------------------------------------------------------------------

test binary-0.1 {DupByteArrayInternalRep} {
    set hdr [binary format cc 0 0316]
    set buf hellomatt
    set data $hdr
    append data $buf

test binary-71.8 {binary decode hex} -body {
    binary decode hex -strict "61 61"
} -returnCodes error -result {invalid hexadecimal digit " " at position 2}
test binary-71.9 {binary decode hex} -body {
    set r [binary decode hex "6"]
    list [string length $r] $r
} -result {0 {}}
test binary-71.10 {binary decode hex} -body {
    string length [binary decode hex " "]
} -result 0

test binary-72.1 {binary encode base64} -body {
    binary encode base64
} -returnCodes error -match glob -result "wrong # args: *"
test binary-72.2 {binary encode base64} -body {
    binary encode base64 abc
} -result {YWJj}

    set r [binary decode base64 YWJ]
    list [string length $r] $r
} -result {2 ab}
test binary-73.23 {binary decode base64} -body {
    set r [binary decode base64 YWJj]
    list [string length $r] $r
} -result {3 abc}
test binary-73.24 {binary decode base64} -body {
    string length [binary decode base64 " "]
} -result 0

test binary-74.1 {binary encode uuencode} -body {
    binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
    binary encode uuencode abc
} -result {86)C}

} -result {abc}
test binary-75.3 {binary decode uuencode} -body {
    binary decode uuencode {}
} -result {}
test binary-75.4 {binary decode uuencode} -body {
    binary decode uuencode [string repeat "86)C" 20]
} -result [string repeat abc 20]
test binary-75.5 {binary decode uuencode} -body {
    binary decode uuencode "``\$\"`P0``0(#"
} -result "\0\1\2\3\4\0\1\2\3"
test binary-75.6 {binary decode uuencode} -body {
    string length [binary decode uuencode {`}]
} -result 0
test binary-75.7 {binary decode uuencode} -body {
    string length [binary decode uuencode {``}]
} -result 1
test binary-75.8 {binary decode uuencode} -body {
    string length [binary decode uuencode {```}]
} -result 2
test binary-75.9 {binary decode uuencode} -body {
    string length [binary decode uuencode {````}]
} -result 3
test binary-75.10 {binary decode uuencode} -body {
    set s "[string repeat 86)C 10]\n[string repeat 86)C 10]"
    binary decode uuencode $s
} -result [string repeat abc 20]
test binary-75.11 {binary decode uuencode} -body {

    set s "04)\# "
    binary decode uuencode $s
} -result ABC
test binary-75.25 {binary decode uuencode} -body {
    set s "04)\#z"
    binary decode uuencode $s
} -returnCodes error -match glob -result {invalid uuencode character "z" at position 4}
test binary-75.26 {binary decode uuencode} -body {
    string length [binary decode uuencode " "]
} -result 0

test binary-76.1 {binary string appending growth algorithm} unix {
    # Create zero-length byte array first
    set f [open /dev/null rb]
    chan configure $f -blocking 0
    set str [read $f 2]
    close $f
    # Append to it
    string length [append str [binary format a* foo]]
} 3
test binary-76.2 {binary string appending growth algorithm} win {
    # Create zero-length byte array first
    set f [open NUL rb]
    chan configure $f -blocking 0
    set str [read $f 2]
    close $f
    # Append to it
    string length [append str [binary format a* foo]]
} 3

# ----------------------------------------------------------------------
# cleanup

::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

    chan close $f
    chan close $f2
    set result
} {{
out
} {err
}}
# This test relies on the fact that stdout is used before stderr.
test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec} {
    set f [open $path(test1) w]
    chan puts -nonewline $f { chan close stdin
	chan close stdout
	chan close stderr
	set f  [}
    chan puts $f [list open $path(test1) r]]
    chan puts $f "set f2 \[[list open $path(test2) w]]"

    set f  [open $path(test2) r]
    set f2 [open $path(test3) r]
    lappend result [chan read $f] [chan read $f2]
    chan close $f
    chan close $f2
    set result
} {{ chan close stdin

stdout
} {stderr
}}
catch {interp delete z}
test chan-io-14.5 {Tcl_GetChannel: stdio name translation} -setup {
    interp create z
} -body {
    chan eof stdin
    catch {z eval chan flush stdin} msg1

    chan close $f
    lappend l [lsort [testchannel open]]
    set x [list $consoleFileNames \
		[lsort [list {*}$consoleFileNames $f]] \
		$consoleFileNames]
    string compare $l $x
} 0
test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup {
    file delete $path(script)
} -constraints {stdio unix testchannel openpipe} -body {
    set f [open $path(script) w]
    chan puts $f {
	chan close stdin
	chan puts [testchannel open]
    }
    chan close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    set l [chan gets $f]
    chan close $f
    lsort $l
} -result {file1 file2}
test chan-io-28.6 {Tcl_CloseEx (half-close) pipe} -setup {
    set cat [makeFile {
	fconfigure stdout -buffering line
	while {[gets stdin line]>=0} {puts $line}
	puts DONE
	exit 0
    } cat.tcl]

	$errorCode
} {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}}
test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} -setup {
    catch {unset x}
} -body {
    set x 44
    list [catch {file lstat $gorpfile x} msg] $msg $errorCode
} -result {1 {can't set "x(dev)": variable isn't array} {TCL LOOKUP VARNAME x}}
catch {unset stat}
# mkdir
set dirA [file join [temporaryDirectory] a]
set dirB [file join [temporaryDirectory] a]
test cmdAH-23.7 {Tcl_FileObjCmd: mkdir} -setup {
    catch {file delete -force $dirA}
} -body {

    file stat _bogus_
} -result {wrong # args: should be "file stat name varName"}
test cmdAH-28.2 {Tcl_FileObjCmd: stat} -returnCodes error -body {
    file stat _bogus_ a b
} -result {wrong # args: should be "file stat name varName"}
test cmdAH-28.3 {Tcl_FileObjCmd: stat} -setup {
    catch {unset stat}
    set stat(blocks) [set stat(blksize) {}]
} -body {
    file stat $gorpfile stat
    unset stat(blocks) stat(blksize); # Ignore these fields; not always set
    lsort [array names stat]
} -result {atime ctime dev gid ino mode mtime nlink size type uid}
test cmdAH-28.4 {Tcl_FileObjCmd: stat} -setup {
    catch {unset stat}
} -body {
    file stat $gorpfile stat
    list $stat(nlink) $stat(size) $stat(type)

# Some tests for Tcl_ReturnObjCmd are in proc-old.test

test cmdMZ-return-1.0 {return checks for bad option values} -body {
    return -options foo
} -returnCodes error -match glob -result {bad -options value:*}
test cmdMZ-return-1.1 {return checks for bad option values} -body {
    return -code err
} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
test cmdMZ-return-1.2 {return checks for bad option values} -body {
    return -code 0x100000000
} -returnCodes error -match glob -result {bad completion code "0x100000000": must be ok, error, return, break, continue*, or an integer}
test cmdMZ-return-1.3 {return checks for bad option values} -body {
    return -level foo
} -returnCodes error -match glob -result {bad -level value: *}
test cmdMZ-return-1.4 {return checks for bad option values} -body {
    return -level -1
} -returnCodes error -match glob -result {bad -level value: *}
test cmdMZ-return-1.5 {return checks for bad option values} -body {

} -returnCodes continue -result {}
test cmdMZ-return-2.8 {return option handling} -body {
    return -level 0 -code -1
} -returnCodes -1 -result {}
test cmdMZ-return-2.9 {return option handling} -body {
    return -level 0 -code 10
} -returnCodes 10 -result {}
test cmdMZ-return-2.10 {return option handling} -body {
    list [catch {return -level 0 -code error} -> foo] [dictSort $foo]
} -match glob -result {1 {-code 1 -errorcode NONE -errorinfo {
    while executing
"return -level 0 -code error"} -errorline 1 -errorstack * -level 0}}
test cmdMZ-return-2.11 {return option handling} {
    list [catch {return -level 0 -code break} -> foo] [dictSort $foo]
} {3 {-code 3 -level 0}}
test cmdMZ-return-2.12 {return option handling} -body {
    return -level 0 -code error -options {-code ok}
} -returnCodes ok -result {}
test cmdMZ-return-2.13 {return option handling} -body {
    return -level 0 -code error -options {-code err}
} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
test cmdMZ-return-2.14 {return option handling} -body {
    return -level 0 -code error -options {-code foo -options {-code break}}
} -returnCodes break -result {}
test cmdMZ-return-2.15 {return opton handling} -setup {
    proc p {} {
	return -code error -errorcode {a b} c
    }

	return -code error -errorcode a\ b c
    }
} -body {
    list [catch p result] $result $::errorCode
} -cleanup {
    rename p {}
} -result {1 c {a b}}
test cmdMZ-return-2.18 {return option handling} {
    list [catch {return -code error -errorstack [list CALL a CALL b] yo} -> foo] [dictSort $foo] [info errorstack]
} {2 {-code 1 -errorcode NONE -errorstack {CALL a CALL b} -level 1} {CALL a CALL b}}

# Check that the result of a [return -options $opts $result] is
# indistinguishable from that of the originally caught script, no matter what
# the script is/does. (TIP 90)
foreach {testid script} {
    cmdMZ-return-3.0 {}
    cmdMZ-return-3.1 {format x}
    cmdMZ-return-3.2 {set}
    cmdMZ-return-3.3 {set a 1}
    cmdMZ-return-3.4 {error}
    cmdMZ-return-3.5 {error foo}
    cmdMZ-return-3.6 {error foo bar}
    cmdMZ-return-3.7 {error foo bar baz}
    cmdMZ-return-3.8 {return -level 0}
    cmdMZ-return-3.9 {return -code error}
    cmdMZ-return-3.10 {return -code error -errorinfo foo}
    cmdMZ-return-3.11 {return -code error -errorinfo foo -errorcode bar}
    cmdMZ-return-3.12 {return -code error -errorinfo foo -errorcode bar -errorline 10}
    cmdMZ-return-3.12.1 {return -code error -errorinfo foo -errorcode bar -errorline 10 -errorstack baz}
    cmdMZ-return-3.13 {return -options {x y z 2}}
    cmdMZ-return-3.14 {return -level 3 -code break sdf}
} {
    test $testid "check that return after a catch is same:\n$script" {
	set one [list [catch $script foo bar] $foo [dictSort $bar] \
		$::errorCode $::errorInfo]
	set two [list [catch {return -options $bar $foo} foo2 bar2] \

	    if {[a]} {
		if b {}
	    }   
	}   
    }
    list [catch foo msg] $msg
} {0 1}
test compile-3.6 {TclCompileCatchCmd: error in storing result [Bug 3098302]} {*}{
     -setup {
	 namespace eval catchtest {
	     variable result1 {}
	 }
	 trace add variable catchtest::result1 write catchtest::failtrace
	 proc catchtest::failtrace {n1 n2 op} {
	     return -code error "trace on $n1 fails by request"
	 }
     }
    -body {
	proc catchtest::x {} {
	    variable result1
	    set count 0
	    for {set i 0} {$i < 10} {incr i} {
		set status2 [catch {
		    set status1 [catch {
			return -code error -level 0 "original failure"
		    } result1 options1]
		} result2 options2]
		incr count
	    }
	    list $count $result2
	}
	catchtest::x
    }
    -result {10 {can't set "result1": trace on result1 fails by request}}
    -cleanup {namespace delete catchtest}
}


test compile-4.1 {TclCompileForCmd: command substituted test expression} {
    set i 0
    set j 0
    # Should be "forever"
    for {} [expr $i < 3] {} {
	set j [incr i]

	interp delete foo
	set tmp $end
	set end [getbytes]
    }
    set leakedBytes [expr {$end - $tmp}]
} -cleanup {
    rename getbytes {}
    unset -nocomplain end i tmp leakedBytes
} -result 0
# Special test for a memory error in a preliminary fix of [Bug 467523]. 
# It requires executing a helpfile.  Presumably the child process is
# used because when this test fails, it crashes.
test compile-12.2 {testing error on literal deletion} -constraints {memory exec} -body {
    set sourceFile [makeFile {
	for {set i 0} {$i < 5} {incr i} {

# This test file covers the dictionary object type and the dict command used
# to work with values of that type.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors.  No output means no errors were found.
#
# Copyright (c) 2003-2009 Donal K. Fellows
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: dict.test,v 1.29 2008/05/09 03:51:33 kennykb Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
    proc memtest script {
	set end [lindex [split [memory info] \n] 3 3]
	for {set i 0} {$i < 5} {incr i} {
	    uplevel 1 $script
	    set tmp $end
	    set end [lindex [split [memory info] \n] 3 3]
	}








	expr {$end - $tmp}
    }


}

test dict-1.1 {dict command basic syntax} -returnCodes error -body {
    dict
} -result {wrong # args: should be "dict subcommand ?arg ...?"}
test dict-1.2 {dict command basic syntax} -returnCodes error -body {
    dict ?
} -match glob -result {unknown or ambiguous subcommand "?": must be *}

test dict-2.1 {dict create command} {
    dict create
} {}
test dict-2.2 {dict create command} {
    dict create a b
} {a b}
test dict-2.3 {dict create command} -body {
    set result {}
    set dict [dict create a b c d]
    # Can't compare directly as ordering of values is undefined
    foreach key {a c} {
	set idx [lsearch -exact $dict $key]
	if {$idx & 1} {
	    error "found $key at odd index $idx in $dict"
	}
	lappend result [lindex $dict [expr {$idx+1}]]
    }
    return $result
} -cleanup {
    unset result dict key idx
} -result {b d}
test dict-2.4 {dict create command} -returnCodes error -body {
    dict create a
} -result {wrong # args: should be "dict create ?key value ...?"}
test dict-2.5 {dict create command} -returnCodes error -body {
    dict create a b c
} -result {wrong # args: should be "dict create ?key value ...?"}
test dict-2.6 {dict create command - initialse refcount field!} -body {
    # Bug 715751 will show up in memory debuggers like purify
    for {set i 0} {$i<10} {incr i} {
	set dictv [dict create a 0]
	set share [dict values $dictv]
	list [dict incr dictv a]
    }
} -cleanup {
    unset i dictv share
} -result {}
test dict-2.7 {dict create command - #-quoting in string rep} {
    dict create # #comment
} {{#} #comment}
test dict-2.8 {dict create command - #-quoting in string rep} -body {
    dict create #a x #b x
} -match glob -result {{#?} x #? x}

test dict-3.10 {dict get command} -returnCodes error -body {
    dict get {a {p q r s} b {u v x y}} c z
} -result {key "c" not known in dictionary}
test dict-3.11 {dict get command} {dict get [dict create a b c d] a} b
test dict-3.12 {dict get command} -returnCodes error -body {
    dict get
} -result {wrong # args: should be "dict get dictionary ?key ...?"}
test dict-3.13 {dict get command} -body {
    set dict [dict get {a b c d}]
    if {$dict eq "a b c d"} {
	return OK
    } elseif {$dict eq "c d a b"} {
	return reordered
    } else {
	return $dict
    }
} -cleanup {
    unset dict
} -result OK
test dict-3.14 {dict get command} -returnCodes error -body {
    dict get {a b c d} a c
} -result {missing value to go with key}
test dict-3.15 {compiled dict get error cleanliness - Bug 2431847} -body {
    apply {{} {
	dict set a(z) b c
	dict get $a(z) d
    }}
} -returnCodes error -result {key "d" not known in dictionary}
test dict-3.16 {dict/list shimmering - Bug 3004007} {set l [list p 1 p 2 q 3];dict get $l q;set l} {p 1 p 2 q 3}
test dict-3.17 {dict/list shimmering - Bug 3004007} {set l [list p 1 p 2 q 3];dict get $l q;llength $l} 6

test dict-4.1 {dict replace command} {
    dict replace {a b c d}
} {a b c d}
test dict-4.2 {dict replace command} {
    dict replace {a b c d} e f
} {a b c d e f}
test dict-4.3 {dict replace command} {
    dict replace {a b c d} c f
} {a b c f}
test dict-4.4 {dict replace command} {
    dict replace {a b c d} c x a y
} {a y c x}
test dict-4.5 {dict replace command} -returnCodes error -body {
    dict replace
} -result {wrong # args: should be "dict replace dictionary ?key value ...?"}
test dict-4.6 {dict replace command} -returnCodes error -body {
    dict replace {a a} a
} -result {wrong # args: should be "dict replace dictionary ?key value ...?"}
test dict-4.7 {dict replace command} -returnCodes error -body {
    dict replace {a a a} a b
} -result {missing value to go with key}
test dict-4.8 {dict replace command} -returnCodes error -body {
    dict replace [list a a a] a b
} -result {missing value to go with key}
test dict-4.9 {dict replace command} {dict replace [list a a] a b} {a b}
test dict-4.10 {dict replace command} {dict replace [list a a] a b a c} {a c}

test dict-5.1 {dict remove command} {dict remove {a b c d} a} {c d}
test dict-5.2 {dict remove command} {dict remove {a b c d} c} {a b}
test dict-5.3 {dict remove command} {dict remove {a b c d} a c} {}
test dict-5.4 {dict remove command} {dict remove {a b c d} c a} {}
test dict-5.5 {dict remove command} {
    dict remove {a b c d}
} {a b c d}
test dict-5.6 {dict remove command} {dict remove {a b} c} {a b}
test dict-5.7 {dict remove command} -returnCodes error -body {
    dict remove
} -result {wrong # args: should be "dict remove dictionary ?key ...?"}

test dict-6.1 {dict keys command} {dict keys {a b}} a
test dict-6.2 {dict keys command} {dict keys {c d}} c

test dict-10.3 {dict info command} -returnCodes error -body {
    dict info {} x
} -result {wrong # args: should be "dict info dictionary"}
test dict-10.4 {dict info command} -returnCodes error -body {
    dict info x
} -result {missing value to go with key}

test dict-11.1 {dict incr command: unshared value} -body {
    set dictv [dict create \
	    a [string index "=0=" 1] \
	    b [expr {1+2}] \
	    c [expr {wide(0x80000000)+1}]]
    dict incr dictv a
} -cleanup {
    unset dictv
} -result {a 1 b 3 c 2147483649}
test dict-11.2 {dict incr command: unshared value} -body {
    set dictv [dict create \
	    a [string index "=0=" 1] \
	    b [expr {1+2}] \
	    c [expr {wide(0x80000000)+1}]]
    dict incr dictv b
} -cleanup {
    unset dictv
} -result {a 0 b 4 c 2147483649}
test dict-11.3 {dict incr command: unshared value} -body {
    set dictv [dict create \
	    a [string index "=0=" 1] \
	    b [expr {1+2}] \
	    c [expr {wide(0x80000000)+1}]]
    dict incr dictv c
} -cleanup {
    unset dictv
} -result {a 0 b 3 c 2147483650}
test dict-11.4 {dict incr command: shared value} -body {
    set dictv [dict create a 0 b [expr {1+2}] c [expr {wide(0x80000000)+1}]]
    set sharing [dict values $dictv]
    dict incr dictv a
} -cleanup {
    unset dictv sharing
} -result {a 1 b 3 c 2147483649}
test dict-11.5 {dict incr command: shared value} -body {
    set dictv [dict create a 0 b [expr {1+2}] c [expr {wide(0x80000000)+1}]]
    set sharing [dict values $dictv]
    dict incr dictv b
} -cleanup {
    unset dictv sharing
} -result {a 0 b 4 c 2147483649}
test dict-11.6 {dict incr command: shared value} -body {
    set dictv [dict create a 0 b [expr {1+2}] c [expr {wide(0x80000000)+1}]]
    set sharing [dict values $dictv]
    dict incr dictv c
} -cleanup {
    unset dictv sharing
} -result {a 0 b 3 c 2147483650}
test dict-11.7 {dict incr command: unknown values} -body {
    set dictv [dict create a 0 b [expr {1+2}] c [expr {wide(0x80000000)+1}]]
    dict incr dictv d
} -cleanup {

    unset dictv
} -result {a 0 b 3 c 2147483649 d 1}
test dict-11.8 {dict incr command} -body {
    set dictv {a 1}
    dict incr dictv a 2
} -cleanup {
    unset dictv
} -result {a 3}
test dict-11.9 {dict incr command} -returnCodes error -body {
    set dictv {a dummy}
    dict incr dictv a
} -cleanup {
    unset dictv
} -result {expected integer but got "dummy"}
test dict-11.10 {dict incr command} -returnCodes error -body {
    set dictv {a 1}
    dict incr dictv a dummy
} -cleanup {
    unset dictv
} -result {expected integer but got "dummy"}
test dict-11.11 {dict incr command} -setup {
    unset -nocomplain dictv
} -body {
    dict incr dictv a
} -cleanup {
    unset dictv
} -result {a 1}
test dict-11.12 {dict incr command} -returnCodes error -body {
    set dictv a
    dict incr dictv a
} -cleanup {
    unset dictv
} -result {missing value to go with key}
test dict-11.13 {dict incr command} -returnCodes error -body {
    set dictv a
    dict incr dictv a a a
} -cleanup {
    unset dictv
} -result {wrong # args: should be "dict incr varName key ?increment?"}
test dict-11.14 {dict incr command} -returnCodes error -body {
    set dictv a
    dict incr dictv
} -cleanup {
    unset dictv
} -result {wrong # args: should be "dict incr varName key ?increment?"}
test dict-11.15 {dict incr command: write failure} -setup {
    unset -nocomplain dictVar
} -body {
    set dictVar(block) {}
    dict incr dictVar a
} -returnCodes error -cleanup {
    unset dictVar
} -result {can't set "dictVar": variable is array}
test dict-11.16 {dict incr command: compilation} {
    apply {{} {
	set v {a 0 b 0 c 0}
	dict incr v a
	dict incr v b 1
	dict incr v c 2
	dict incr v d 3
	list [dict get $v a] [dict get $v b] [dict get $v c] [dict get $v d]
    }}
} {1 1 2 3}
test dict-11.17 {dict incr command: compilation} {
    apply {{} {
	set dictv {a 1}
	dict incr dictv a 2
    }}
} {a 3}

test dict-12.1 {dict lappend command} -body {
    set dictv {a a}
    dict lappend dictv a
} -cleanup {
    unset dictv
} -result {a a}
test dict-12.2 {dict lappend command} -body {
    set dictv {a a}
    set sharing [dict values $dictv]
    dict lappend dictv a b
} -cleanup {
    unset dictv sharing
} -result {a {a b}}
test dict-12.3 {dict lappend command} -body {
    set dictv {a a}
    dict lappend dictv a b c
} -cleanup {
    unset dictv
} -result {a {a b c}}
test dict-12.2.1 {dict lappend command} -body {
    set dictv [dict create a [string index =a= 1]]
    dict lappend dictv a b
} -cleanup {
    unset dictv
} -result {a {a b}}
test dict-12.4 {dict lappend command} -body {
    set dictv {}
    dict lappend dictv a x y z
} -cleanup {
    unset dictv
} -result {a {x y z}}
test dict-12.5 {dict lappend command} -body {
    unset -nocomplain dictv
    dict lappend dictv a b
} -cleanup {
    unset dictv
} -result {a b}
test dict-12.6 {dict lappend command} -returnCodes error -body {
    set dictv a
    dict lappend dictv a a
} -cleanup {
    unset dictv
} -result {missing value to go with key}
test dict-12.7 {dict lappend command} -returnCodes error -body {
    dict lappend
} -result {wrong # args: should be "dict lappend varName key ?value ...?"}
test dict-12.8 {dict lappend command} -returnCodes error -body {
    dict lappend dictv
} -result {wrong # args: should be "dict lappend varName key ?value ...?"}
test dict-12.9 {dict lappend command} -returnCodes error -body {
    set dictv [dict create a "\{"]
    dict lappend dictv a a
} -cleanup {
    unset dictv
} -result {unmatched open brace in list}
test dict-12.10 {dict lappend command: write failure} -setup {
    unset -nocomplain dictVar
} -body {
    set dictVar(block) {}
    dict lappend dictVar a x
} -returnCodes error -cleanup {
    unset dictVar
} -result {can't set "dictVar": variable is array}
test dict-12.11 {compiled dict append: invalidate string rep - Bug 3079830} {
    apply {{} {set d {a 1 b 2 c 3}; dict lappend d b 22}}
} {a 1 b {2 22} c 3}

test dict-13.1 {dict append command} -body {
    set dictv {a a}
    dict append dictv a
} -cleanup {
    unset dictv
} -result {a a}
test dict-13.2 {dict append command} -body {
    set dictv {a a}
    set sharing [dict values $dictv]
    dict append dictv a b
} -cleanup {
    unset dictv sharing
} -result {a ab}
test dict-13.3 {dict append command} -body {
    set dictv {a a}
    dict append dictv a b c
} -cleanup {
    unset dictv
} -result {a abc}
test dict-13.2.1 {dict append command} -body {
    set dictv [dict create a [string index =a= 1]]
    dict append dictv a b
} -cleanup {
    unset dictv
} -result {a ab}
test dict-13.4 {dict append command} -body {
    set dictv {}
    dict append dictv a x y z
} -cleanup {
    unset dictv
} -result {a xyz}
test dict-13.5 {dict append command} -body {
    unset -nocomplain dictv
    dict append dictv a b
} -cleanup {
    unset dictv
} -result {a b}
test dict-13.6 {dict append command} -returnCodes error -body {
    set dictv a
    dict append dictv a a
} -cleanup {
    unset dictv
} -result {missing value to go with key}
test dict-13.7 {dict append command} -returnCodes error -body {
    dict append
} -result {wrong # args: should be "dict append varName key ?value ...?"}
test dict-13.8 {dict append command} -returnCodes error -body {
    dict append dictv
} -result {wrong # args: should be "dict append varName key ?value ...?"}
test dict-13.9 {dict append command: write failure} -setup {
    unset -nocomplain dictVar
} -body {
    set dictVar(block) {}
    dict append dictVar a x
} -returnCodes error -cleanup {
    unset dictVar
} -result {can't set "dictVar": variable is array}
test dict-13.10 {compiled dict append: crash case} {
    apply {{} {dict append dictVar a o k}}
} {a ok}
test dict-13.11 {compiled dict append: invalidate string rep - Bug 3079830} {
    apply {{} {set d {a 1 b 2 c 3}; dict append d b 22}}
} {a 1 b 222 c 3}

test dict-14.1 {dict for command: syntax} -returnCodes error -body {
    dict for
} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}
test dict-14.2 {dict for command: syntax} -returnCodes error -body {
    dict for x
} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}

} -result {must have exactly two variable names}
test dict-14.6 {dict for command: syntax} -returnCodes error -body {
    dict for {x x x} x x
} -result {must have exactly two variable names}
test dict-14.7 {dict for command: syntax} -returnCodes error -body {
    dict for "\{x" x x
} -result {unmatched open brace in list}
test dict-14.8 {dict for command} -body {
    # This test confirms that [dict keys], [dict values] and [dict for]
    # all traverse a dictionary in the same order.
    set dictv {a A b B c C}
    set keys {}
    set values {}
    dict for {k v} $dictv {
	lappend keys $k
	lappend values $v
    }
    set result [expr {
	$keys eq [dict keys $dictv] && $values eq [dict values $dictv]
    }]
    expr {$result ? "YES" : [list "NO" $dictv $keys $values]}
} -cleanup {
    unset result keys values k v dictv
} -result YES
test dict-14.9 {dict for command} {
    dict for {k v} {} {
	error "unexpected execution of 'dict for' body"
    }
} {}
test dict-14.10 {dict for command: script results} -body {
    set times 0
    dict for {k v} {a a b b} {
	incr times
	continue
	error "shouldn't get here"
    }
    return $times
} -cleanup {
    unset times k v
} -result 2
test dict-14.11 {dict for command: script results} -body {
    set times 0
    dict for {k v} {a a b b} {
	incr times
	break
	error "shouldn't get here"
    }
    return $times
} -cleanup {
    unset times k v
} -result 1
test dict-14.12 {dict for command: script results} -body {
    set times 0
    list [catch {
	dict for {k v} {a a b b} {
	    incr times
	    error test
	}
    } msg] $msg $times $::errorInfo
} -cleanup {
    unset times k v msg
} -result {1 test 1 {test
    while executing
"error test"
    ("dict for" body line 3)
    invoked from within
"dict for {k v} {a a b b} {
	    incr times
	    error test
	}"}}
test dict-14.13 {dict for command: script results} {
    apply {{} {
	dict for {k v} {a b} {
	    return ok,$k,$v
	    error "skipped return completely"
	}
	error "return didn't go far enough"
    }}
} ok,a,b
test dict-14.14 {dict for command: handle representation loss} -body {
    set dictVar {a b c d e f g h}
    set keys {}
    set values {}
    dict for {k v} $dictVar {
	if {[llength $dictVar]} {
	    lappend keys $k
	    lappend values $v
	}
    }
    list [lsort $keys] [lsort $values]
} -cleanup {
    unset dictVar keys values k v
} -result {{a c e g} {b d f h}}
test dict-14.15 {dict for command: keys are unique and iterated over once only} -setup {

    unset -nocomplain accum
    array set accum {}
} -body {
    set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
    dict for {k v} $dictVar {
	append accum($k) $v,
    }
    set result [lsort [array names accum]]
    lappend result :
    foreach k $result {
	catch {lappend result $accum($k)}
    }

    return $result
} -cleanup {
    unset dictVar k v result accum
} -result {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,}
test dict-14.16 {dict for command in compilation context} {
    apply {{} {
	set res {x x x x x x}
	dict for {k v} {a 0 b 1 c 2 d 3 e 4 f 5} {
	    lset res $v $k
	    continue
	}

	dict for {a b} $x {}
	concat "c=$y,$args"
    }} {} 1 2 3
} {c=1,2 3}
# There's probably a lot more tests to add here. Really ought to use a
# coverage tool for this job...

test dict-15.1 {dict set command} -body {
    set dictVar {}
    dict set dictVar a x
} -cleanup {
    unset dictVar
} -result {a x}
test dict-15.2 {dict set command} -body {
    set dictvar {a {}}
    dict set dictvar a b x
} -cleanup {
    unset dictvar
} -result {a {b x}}
test dict-15.3 {dict set command} -body {
    set dictvar {a {b {}}}
    dict set dictvar a b c x
} -cleanup {
    unset dictvar
} -result {a {b {c x}}}
test dict-15.4 {dict set command} -body {
    set dictVar {a y}
    dict set dictVar a x
} -cleanup {
    unset dictVar
} -result {a x}
test dict-15.5 {dict set command} -body {
    set dictVar {a {b y}}
    dict set dictVar a b x
} -cleanup {
    unset dictVar
} -result {a {b x}}
test dict-15.6 {dict set command} -body {
    set dictVar {a {b {c y}}}
    dict set dictVar a b c x
} -cleanup {
    unset dictVar
} -result {a {b {c x}}}
test dict-15.7 {dict set command: path creation} -body {
    set dictVar {}
    dict set dictVar a b x
} -cleanup {
    unset dictVar
} -result {a {b x}}
test dict-15.8 {dict set command: creates variables} -setup {
    unset -nocomplain dictVar
} -body {
    dict set dictVar a x
    return $dictVar
} -cleanup {
    unset dictVar
} -result {a x}
test dict-15.9 {dict set command: write failure} -setup {
    unset -nocomplain dictVar
} -body {
    set dictVar(block) {}
    dict set dictVar a x
} -returnCodes error -cleanup {
    unset dictVar
} -result {can't set "dictVar": variable is array}
test dict-15.10 {dict set command: syntax} -returnCodes error -body {
    dict set
} -result {wrong # args: should be "dict set varName key ?key ...? value"}
test dict-15.11 {dict set command: syntax} -returnCodes error -body {
    dict set a
} -result {wrong # args: should be "dict set varName key ?key ...? value"}
test dict-15.12 {dict set command: syntax} -returnCodes error -body {
    dict set a a
} -result {wrong # args: should be "dict set varName key ?key ...? value"}
test dict-15.13 {dict set command} -returnCodes error -body {
    set dictVar a
    dict set dictVar b c
} -cleanup {
    unset dictVar
} -result {missing value to go with key}

test dict-16.1 {dict unset command} -body {
    set dictVar {a b c d}
    dict unset dictVar a
} -cleanup {
    unset dictVar
} -result {c d}
test dict-16.2 {dict unset command} -body {
    set dictVar {a b c d}
    dict unset dictVar c
} -cleanup {
    unset dictVar
} -result {a b}
test dict-16.3 {dict unset command} -body {
    set dictVar {a b}
    dict unset dictVar c
} -cleanup {
    unset dictVar
} -result {a b}
test dict-16.4 {dict unset command} -body {
    set dictVar {a {b c d e}}
    dict unset dictVar a b
} -cleanup {
    unset dictVar
} -result {a {d e}}
test dict-16.5 {dict unset command} -returnCodes error -body {
    set dictVar a
    dict unset dictVar a
} -cleanup {
    unset dictVar
} -result {missing value to go with key}
test dict-16.6 {dict unset command} -returnCodes error -body {
    set dictVar {a b}
    dict unset dictVar c d
} -cleanup {
    unset dictVar
} -result {key "c" not known in dictionary}
test dict-16.7 {dict unset command} -setup {
    unset -nocomplain dictVar
} -body {
    list [info exists dictVar] [dict unset dictVar a] [info exists dictVar]
} -cleanup {
    unset dictVar
} -result {0 {} 1}
test dict-16.8 {dict unset command} -returnCodes error -body {
    dict unset dictVar
} -result {wrong # args: should be "dict unset varName key ?key ...?"}
test dict-16.9 {dict unset command: write failure} -setup {
    unset -nocomplain dictVar
} -body {
    set dictVar(block) {}
    dict unset dictVar a
} -returnCodes error -cleanup {
    unset dictVar
} -result {can't set "dictVar": variable is array}

test dict-17.1 {dict filter command: key} -body {
    set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
    dict filter $dictVar key a2
} -cleanup {
    unset dictVar
} -result {a2 b}
test dict-17.2 {dict filter command: key} -body {
    set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
    dict size [dict filter $dictVar key *]
} -cleanup {
    unset dictVar
} -result 6
test dict-17.3 {dict filter command: key} -body {
    set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
    dict filter $dictVar key ???
} -cleanup {
    unset dictVar
} -result {foo bar bar foo}
test dict-17.4 {dict filter command: key - no patterns} {
    dict filter {a b c d} key
} {}
test dict-17.4.1 {dict filter command: key - many patterns} {
    dict filter {a1 a a2 b b1 c b2 d foo bar bar foo} key a? b?
} {a1 a a2 b b1 c b2 d}
test dict-17.5 {dict filter command: key - bad dict} -returnCodes error -body {
    dict filter {a b c} key
} -result {missing value to go with key}
test dict-17.6 {dict filter command: value} -body {
    set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
    dict filter $dictVar value c
} -cleanup {
    unset dictVar
} -result {b1 c}
test dict-17.7 {dict filter command: value} -body {
    set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
    dict size [dict filter $dictVar value *]
} -cleanup {
    unset dictVar
} -result 6
test dict-17.8 {dict filter command: value} -body {
    set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
    dict filter $dictVar value ???
} -cleanup {
    unset dictVar
} -result {foo bar bar foo}
test dict-17.9 {dict filter command: value - no patterns} {
    dict filter {a b c d} value
} {}
test dict-17.9.1 {dict filter command: value - many patterns} {
    dict filter {a a1 b a2 c b1 foo bar bar foo d b2} value a? b?
} {a a1 b a2 c b1 d b2}
test dict-17.10 {dict filter command: value - bad dict} -body {
    dict filter {a b c} value a
} -returnCodes error -result {missing value to go with key}
test dict-17.11 {dict filter command: script} -body {
    set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
    set n 0
    list [dict filter $dictVar script {k v} {
	incr n
	expr {[string length $k] == [string length $v]}
    }] $n
} -cleanup {
    unset dictVar n k v
} -result {{foo bar bar foo} 6}
test dict-17.12 {dict filter command: script} -returnCodes error -body {
    dict filter {a b} script {k v} {
	concat $k $v
    }
} -cleanup {
    unset k v
} -result {expected boolean value but got "a b"}
test dict-17.13 {dict filter command: script} -body {
    list [catch {dict filter {a b} script {k v} {error x}} msg] $msg \
	    $::errorInfo
} -cleanup {
    unset k v msg
} -result {1 x {x
    while executing
"error x"
    ("dict filter" script line 1)
    invoked from within
"dict filter {a b} script {k v} {error x}"}}
test dict-17.14 {dict filter command: script} -setup {
    set n 0
} -body {
    list [dict filter {a b c d} script {k v} {
	incr n
	break
	error boom!
    }] $n
} -cleanup {
    unset n k v
} -result {{} 1}
test dict-17.15 {dict filter command: script} -setup {
    set n 0
} -body {
    list [dict filter {a b c d} script {k v} {
	incr n
	continue
	error boom!
    }] $n
} -cleanup {
    unset n k v
} -result {{} 2}
test dict-17.16 {dict filter command: script} {
    apply {{} {
	dict filter {a b} script {k v} {
	    return ok,$k,$v
	    error "skipped return completely"
	}
	error "return didn't go far enough"
    }}
} ok,a,b
test dict-17.17 {dict filter command: script} -body {
    dict filter {a b} script {k k} {continue}
    return $k
} -cleanup {
    unset k
} -result b
test dict-17.18 {dict filter command: script} -returnCodes error -body {
    dict filter {a b} script {k k}
} -result {wrong # args: should be "dict filter dictionary script {keyVar valueVar} filterScript"}
test dict-17.19 {dict filter command: script} -returnCodes error -body {
    dict filter {a b} script k {continue}
} -result {must have exactly two variable names}
test dict-17.20 {dict filter command: script} -returnCodes error -body {
    dict filter {a b} script "\{k v" {continue}
} -result {unmatched open brace in list}
test dict-17.21 {dict filter command} -returnCodes error -body {
    dict filter {a b}
} -result {wrong # args: should be "dict filter dictionary filterType ?arg ...?"}
test dict-17.22 {dict filter command} -returnCodes error -body {
    dict filter {a b} JUNK
} -result {bad filterType "JUNK": must be key, script, or value}
test dict-17.23 {dict filter command} -returnCodes error -body {
    dict filter a key *
} -result {missing value to go with key}

test dict-18.1 {dict-list relationship} -body {

    # Test that any internal conversion between list and dict does not change
    # the object
    set l [list 1 2 3 4 5 6 7 8 9 0 q w e r t y]
    dict values $l
    return $l
} -cleanup {
    unset l

} -result {1 2 3 4 5 6 7 8 9 0 q w e r t y}

test dict-18.2 {dict-list relationship} -body {

    # Test that the dictionary is a valid list
    set d [dict create "abc def" 0 "a\{b" 1 "c\}d" 2]
    for {set t 0} {$t < 5} {incr t} {
	llength $d
	dict lappend d "abc def" "\}\{"
	dict append  d "a\{b" "\}"
	dict incr    d "c\}d" 1
    }
    llength $d
} -cleanup {
    unset d t
} -result 6
test dict-18.3 {dict-list relationship} -body {
    set ld [list a b c d c e f g]
    list [string length $ld] [dict size $ld] [llength $ld]
} -cleanup {
    unset ld
} -result {15 3 8}
test dict-18.4 {dict-list relationship} -body {
    set ld [list a b c d c e f g]
    list [llength $ld] [dict size $ld] [llength $ld]
} -cleanup {
    unset ld
} -result {8 3 8}

# This is a test for a specific bug.
# It shows a bad ref counter when running with memdebug on.
test dict-19.1 {memory bug} {
    apply {{} {
        set successors [dict create x {c d}]
        dict set successors x a b
        dict get $successors x
    }}
} [dict create c d a b]
test dict-19.2 {dict: testing for leaks} -constraints memory -body {





    # This test is made to stress object reference management
    memtest {

	apply {{} {
	    # A shared invalid dictinary
	    set apa {a {}b c d}
	    set bepa $apa
	    catch {dict replace $apa e f}
	    catch {dict remove  $apa c d}
	    catch {dict incr    apa  a 5}

	    set apa {a 1 b 2}
	    set bepa $apa
	    trace add variable bepa write {error hej}
	    catch {dict unset bepa a}
	    trace remove variable bepa write {error hej}
	    unset bepa
	}}
    }
} -result 0
test dict-19.3 {testing for leaks - Bug 2874678} -constraints memory -body {
    set d aDictVar; # Force interpreted [dict incr]
    memtest {
	dict incr $d aKey 0
	unset $d
    }

} -cleanup {
    unset d


} -result 0

test dict-20.1 {dict merge command} {
    dict merge
} {}
test dict-20.2 {dict merge command} {
    dict merge {a b c d e f}
} {a b c d e f}
test dict-20.3 {dict merge command} -body {
    dict merge {a b c d e}
} -result {missing value to go with key} -returnCodes error
test dict-20.4 {dict merge command} {
    dict merge {a b c d} {e f g h}
} {a b c d e f g h}
test dict-20.5 {dict merge command} -body {
    dict merge {a b c d e} {e f g h}
} -result {missing value to go with key} -returnCodes error
test dict-20.6 {dict merge command} -body {
    dict merge {a b c d} {e f g h i}
} -result {missing value to go with key} -returnCodes error
test dict-20.7 {dict merge command} {
    dict merge {a b c d e f} {e x g h}
} {a b c d e x g h}
test dict-20.8 {dict merge command} {
    dict merge {a b c d} {a x c y}
} {a x c y}
test dict-20.9 {dict merge command} {
    dict merge {a b c d} {c y a x}
} {a x c y}
test dict-20.10 {dict merge command} {
    dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}
} {a - c d e f 1 - 3 4}

test dict-21.1 {dict update command} -returnCodes 1 -body {
    dict update
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
test dict-21.2 {dict update command} -returnCodes 1 -body {
    dict update v
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
test dict-21.3 {dict update command} -returnCodes 1 -body {
    dict update v k
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
test dict-21.4 {dict update command} -returnCodes 1 -body {
    dict update v k v
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
test dict-21.5 {dict update command} -body {
    set a {b c}
    set result {}
    set bb {}
    dict update a b bb {
	lappend result $a $bb
    }
    lappend result $a
} -cleanup {
    unset a result bb
} -result {{b c} c {b c}}
test dict-21.6 {dict update command} -body {
    set a {b c}
    set result {}
    set bb {}
    dict update a b bb {
	lappend result $a $bb [set bb d]
    }
    lappend result $a
} -cleanup {
    unset a result bb
} -result {{b c} c d {b d}}
test dict-21.7 {dict update command} -body {
    set a {b c}
    set result {}
    set bb {}
    dict update a b bb {
	lappend result $a $bb [unset bb]
    }
    lappend result $a
} -cleanup {
    unset a result
} -result {{b c} c {} {}}
test dict-21.8 {dict update command} -body {
    set a {b c d e}
    dict update a b v1 d v2 {
	lassign "$v1 $v2" v2 v1
    }
    return $a
} -cleanup {
    unset a v1 v2
} -result {b e d c}
test dict-21.9 {dict update command} -body {
    set a {b c d e}
    dict update a b v1 d v2 {unset a}
    info exist a
} -cleanup {
    unset v1 v2
} -result 0
test dict-21.10 {dict update command} -body {
    set a {b {c d}}
    dict update a b v1 {
	dict update v1 c v2 {
	    set v2 foo
	}
    }
    return $a
} -cleanup {
    unset a v1 v2
} -result {b {c foo}}
test dict-21.11 {dict update command} -body {
    set a {b c d e}
    dict update a b v1 d v2 {
	dict set a f g
    }
    return $a
} -cleanup {
    unset a v1 v2
} -result {b c d e f g}
test dict-21.12 {dict update command} -body {
    set a {b c d e}
    dict update a b v1 d v2 f v3 {
	set v3 g
    }
    return $a
} -cleanup {
    unset a v1 v2 v3
} -result {b c d e f g}
test dict-21.13 {dict update command: compilation} {
    apply {d {
	while 1 {
	    dict update d a alpha b beta {
		set beta $alpha
		unset alpha
		break
	    }
	}
	return $d
    }} {a 1 c 2}
} {c 2 b 1}
test dict-21.14 {dict update command: compilation} {
    apply {x {
	set indices {2 3}
	trace add variable aa write "string length \$indices ;#"
	dict update x k aa l bb {}
    }} {k 1 l 2}
} {}
test dict-21.15 {dict update command: compilation} {
    apply {x {
	set indices {2 3}
	trace add variable aa read "string length \$indices ;#"
	dict update x k aa l bb {}
    }} {k 1 l 2}
} {}
test dict-21.16 {dict update command: no recursive structures [Bug 1786481]} -body {
    set foo {a {b {c {d {e 1}}}}}
    dict update foo a t {
	dict update t b t {
	    dict update t c t {
		dict update t d t {
		    dict incr t e
		}
	    }
	}
    }
    string range [append foo OK] end-1 end
} -cleanup {
    unset foo t
} -result OK
test dict-21.17 {dict update command: no recursive structures [Bug 1786481]} {
    apply {{} {
	set foo {a {b {c {d {e 1}}}}}
	dict update foo a t {
	    dict update t b t {
		dict update t c t {
		    dict update t d t {
			dict incr t e
		    }
		}
	    }
	}

	string range [append foo OK] end-1 end
    }}
} OK

test dict-22.1 {dict with command} -body {
    dict with
} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"}
test dict-22.2 {dict with command} -body {
    dict with v
} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"}
test dict-22.3 {dict with command} -body {
    unset -nocomplain v
    dict with v {error "in body"}
} -returnCodes 1 -result {can't read "v": no such variable}
test dict-22.4 {dict with command} -body {
    set a {b c d e}
    unset -nocomplain b d
    set result [list [info exist b] [info exist d]]
    dict with a {
	lappend result [info exist b] [info exist d] $b $d
    }
    return $result
} -cleanup {
    unset a b d result
} -result {0 0 1 1 c e}
test dict-22.5 {dict with command} -body {
    set a {b c d e}
    dict with a {
	lassign "$b $d" d b
    }
    return $a
} -cleanup {
    unset a b d
} -result {b e d c}
test dict-22.6 {dict with command} -body {
    set a {b c d e}
    dict with a {
	unset b
	# This *won't* go into the dict...
	set f g
    }
    return $a
} -cleanup {
    unset a d f
} -result {d e}
test dict-22.7 {dict with command} -body {
    set a {b c d e}
    dict with a {
	dict unset a b
    }
    return $a
} -cleanup {
    unset a
} -result {d e b c}
test dict-22.8 {dict with command} -body {
    set a [dict create b c]
    dict with a {
	set b $a
    }
    return $a
} -cleanup {
    unset a b
} -result {b {b c}}
test dict-22.9 {dict with command} -body {
    set a {b {c d}}
    dict with a b {
	set c $c$c
    }
    return $a
} -cleanup {
    unset a c
} -result {b {c dd}}
test dict-22.10 {dict with command: result handling tricky case} -body {
    set a {b {c d}}
    foreach i {0 1} {
	if {$i} break
	dict with a b {
	    set a {}
	    # We're checking to see if we lose this break
	    break
	}
    }
    list $i $a
} -cleanup {
    unset a i c
} -result {0 {}}
test dict-22.11 {dict with command: no recursive structures [Bug 1786481]} -body {
    set foo {t {t {t {inner 1}}}}
    dict with foo {
	dict with t {
	    dict with t {
		dict with t {
		    incr inner
		}
	    }
	}
    }
    string range [append foo OK] end-1 end
} -cleanup {
    unset foo t inner
} -result OK

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

# RCS: @(#) $Id: error.test,v 1.16 2006/10/09 19:15:44 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

testConstraint memory [llength [info commands memory]]
namespace eval ::tcl::test::error {
if {[testConstraint memory]} {
    proc getbytes {} {
	set lines [split [memory info] \n]
	return [lindex $lines 3 3]
    }
    proc leaktest {script {iterations 3}} {
	set end [getbytes]
	for {set i 0} {$i < $iterations} {incr i} {
	    uplevel 1 $script
	    set tmp $end
	    set end [getbytes]
	}
	return [expr {$end - $tmp}]
    }
}

proc foo {} {
    global errorInfo
    set a [catch {format [error glorp2]} b]
    error {Human-generated}
}

    while executing
"error msg1"} NONE}
test error-4.5 {errorInfo and errorCode variables} {
    set ::errorCode bogus
    list [catch {error msg1 msg2 {}} msg] $msg $::errorInfo $::errorCode
} {1 msg1 msg2 {}}

test error-4.6 {errorstack via info } -body {
    proc f x {g $x$x}
    proc g x {error G:$x}
    catch {f 12}
    info errorstack
} -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1}
test error-4.7 {errorstack via options dict } -body {
    proc f x {g $x$x}
    proc g x {error G:$x}
    catch {f 12} m d
    dict get $d -errorstack
} -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1}

# Errors in error command itself

test error-5.1 {errors in error command} {
    list [catch {error} msg] $msg
} {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}}
test error-5.2 {errors in error command} {
    list [catch {error a b c d} msg] $msg

test error-6.9 {catch must reset error state} {
    proc foo {} {
	return -code error [catch {error foo bar baz}]
    }
    catch foo
    list $::errorCode
} {NONE}
test error-6.10 {catch must reset errorstack} -body {
	proc f x {g $x$x}
	proc g x {error G:$x}
	catch {f 12}
	set e1 [info errorstack]
	catch {f 13}
	set e2 [info errorstack]
	list $e1 $e2
} -match glob -result {{INNER * CALL {g 1212} CALL {f 12} UP 1} {INNER * CALL {g 1313} CALL {f 13} UP 1}}

test error-7.1 {Bug 1397843} -body {
    variable cmds
    proc EIWrite args {
	variable cmds
	lappend cmds [lindex [info level -2] 0]
    }

} -returnCodes 2 -result {bar}
test error-15.6 {try with no matching handler (break result propagates)} -body {
    try { if {1} break } on error {} { list a b c }
} -returnCodes 3 -result {}
test error-15.7 {try with no matching handler (unknown integer result propagates)} -body {
    try { return -level 0 -code 123456 } trap {} {} { list a b c }
} -returnCodes 123456 -result {}

foreach level {0 1 2 3} {
    foreach code {0 1 2 3 4 5} {

	# Following cases have different -errorinfo; avoid false alarms
	# TODO: examine whether these difference are as they ought to be.
	if {$level == 0 && $code == 1} continue

	foreach extras {{} {-bar soom}} {

test error-15.8.$level.$code.[llength $extras] {[try] coverage} {
    set script {return -level $level -code $code {*}$extras foo}
    catch $script m1 o1
    catch {try $script} m2 o2
    set o1 [lsort -stride 2 $o1]
    set o2 [lsort -stride 2 $o2]
    expr {$o1 eq $o2 ? "ok" : "$o1\n\tis not equal to\n$o2"}
} ok

test error-15.9.$level.$code.[llength $extras] {[try] coverage} {
    set script {return -level $level -code $code {*}$extras foo}
    catch $script m1 o1
    catch {try $script finally {}} m2 o2
    set o1 [lsort -stride 2 $o1]
    set o2 [lsort -stride 2 $o2]
    expr {$o1 eq $o2 ? "ok" : "$o1\n\tis not equal to\n$o2"}
} ok

test error-15.10.$level.$code.[llength $extras] {[try] coverage} {
    set script {return -level $level -code $code {*}$extras foo}
    catch $script m1 o1
    catch {try $script on $code {x y} {return -options $y $x}} m2 o2
    set o1 [lsort -stride 2 $o1]
    set o2 [lsort -stride 2 $o2]
    expr {$o1 eq $o2 ? "ok" : "$o1\n\tis not equal to\n$o2"}
} ok

	}
    }
}

# try tests - propagation (exceptions in handlers, exception chaining)

test error-16.1 {try with successfully executed handler} {
    try { throw FOO bar } trap FOO {} { list a b c }
} {a b c}
test error-16.2 {try with exception (error) in handler} -body {

    } trap FOO {} - trap BAR {} { 
	set RES foo
    } trap {} {} - on error {} {
	set RES err
    } 
    set RES
} {err}
proc addmsg msg {
    variable RES
    lappend RES $msg
}
test error-19.6 {compiled try executes all clauses} -setup {
    set RES {}
} -body {
    apply {{} {
	try {
	    addmsg a
	    throw bar hello
	} trap bar {res opt} {
	    addmsg b
	} finally {
	    addmsg c
	}
	addmsg d
    } ::tcl::test::error}
} -cleanup {
    unset RES
} -result {a b c d}
test error-19.7 {compiled try executes all clauses} -setup {
    set RES {}
} -body {
    apply {{} {
	try {
	    addmsg a
	} on error {res opt} {
	    addmsg b
	} on ok {} {
	    addmsg c
	} finally {
	    addmsg d
	}
	addmsg e
    } ::tcl::test::error}
} -cleanup {
    unset RES
} -result {a c d e}
test error-19.8 {compiled try executes all clauses} -setup {
    set RES {}
} -body {
    apply {{} {
	try {
	    addmsg a
	    throw bar hello
	} trap bar {res opt} {
	    addmsg b
	}
	addmsg c
    } ::tcl::test::error}
} -cleanup {
    unset RES
} -result {a b c}
test error-19.9 {compiled try executes all clauses} -setup {
    set RES {}
} -body {
    apply {{} {
	try {
	    addmsg a
	} on error {res opt} {
	    addmsg b
	} on ok {} {
	    addmsg c
	}
	addmsg d
    } ::tcl::test::error}
} -cleanup {
    unset RES
} -result {a c d}
test error-19.10 {compiled try with chained clauses} -setup {
    set RES {}
} -body {
    list [apply {{} {
	try {
	    return good
	} on return {res} - on ok {res} {
	    addmsg ok
	    addmsg $res
	    return handler
	} finally {
	    addmsg finally
	}
    } ::tcl::test::error}] $RES
} -cleanup {
    unset RES
} -result {handler {ok good finally}}
test error-19.11 {compiled try and errors on variable write} -setup {
    set RES {}
} -body {
    apply {{} {
	array set foo {bar boo}
	set bar unset
	catch {
	    try {
		addmsg body
		return a
	    } on return {bar foo} {
		addmsg handler
		return b
	    } finally {
		addmsg finally,$bar
	    }
	} msg
	addmsg $msg
    } ::tcl::test::error}
} -cleanup {
    unset RES
} -result {body finally,a {can't set "foo": variable is array}}
test error-19.12 {interpreted try and errors on variable write} -setup {
    set RES {}
} -body {
    apply {try {
	array set foo {bar boo}
	set bar unset
	catch {
	    $try {
		addmsg body
		return a
	    } on return {bar foo} {
		addmsg handler
		return b
	    } finally {
		addmsg finally,$bar
	    }
	} msg
	addmsg $msg
    } ::tcl::test::error} try
} -cleanup {
    unset RES
} -result {body finally,a {can't set "foo": variable is array}}
test error-19.13 {compiled try and errors on variable write} -setup {
    set RES {}
} -body {
    apply {{} {
	array set foo {bar boo}
	set bar unset
	catch {
	    try {
		addmsg body
		return a
	    } on return {bar foo} - on error {bar foo} {
		addmsg handler
		return b
	    } finally {
		addmsg finally,$bar
	    }
	} msg
	addmsg $msg
    } ::tcl::test::error}
} -cleanup {
    unset RES
} -result {body finally,a {can't set "foo": variable is array}}
rename addmsg {}

# FIXME test what vars get set on fallthough ... what is the correct behavior?
# It would seem appropriate to set at least those for the matching handler and
# the executed body; possibly for each handler we fall through as well?

# negative case try tests - bad "on" handler

test error-20.1 {bad code name in on handler} -body {
    try { list a b c } on err {} {}
} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
test error-20.2 {bad code value in on handler} -body {
    try { list a b c } on 34985723094872345 {} {}
} -returnCodes error -match glob -result {bad completion code "34985723094872345": must be ok, error, return, break, continue*, or an integer}

test error-21.1 {memory leaks in try: Bug 2910044} memory {
    leaktest {
	try {string repeat x 10} on ok {} {}
    }
} 0
test error-21.2 {memory leaks in try: Bug 2910044} memory {
    leaktest {
	try {error [string repeat x 10]} on error {} {}
    }
} 0
test error-21.3 {memory leaks in try: Bug 2910044} memory {
    leaktest {
	try {throw FOO [string repeat x 10]} trap FOO {} {}
    }
} 0
test error-21.4 {memory leaks in try: Bug 2910044} memory {
    leaktest {
	try {string repeat x 10}
    }
} 0
test error-21.5 {memory leaks in try: Bug 2910044} memory {
    leaktest {
	try {string repeat x 10} on ok {} {} finally {string repeat y 10}
    }
} 0
test error-21.6 {memory leaks in try: Bug 2910044} memory {
    leaktest {
	try {
	    error [string repeat x 10]
	} on error {} {} finally {
	    string repeat y 10
	}
    }
} 0
test error-21.7 {memory leaks in try: Bug 2910044} memory {
    leaktest {
	try {
	    throw FOO [string repeat x 10]
	} trap FOO {} {} finally {
	    string repeat y 10
	}
    }
} 0
test error-21.8 {memory leaks in try: Bug 2910044} memory {
    leaktest {
	try {string repeat x 10} finally {string repeat y 10}
    }
} 0

# negative case try tests - bad "trap" handler
# what is the effect if we attempt to trap an errorcode that is not a list?
# nested try
# catch inside try
# no tests for bad varslist?
# -errorcode but code!=1 doesn't trap

} 0
test expr-38.6 {abs and -0 [Bug 1893815]} {
    ::tcl::mathfunc::abs -0.0
} 0.0
test expr-38.7 {abs and -0 [Bug 1893815]} {
    ::tcl::mathfunc::abs -1e-324
} 0.0
test expr-38.8 {abs and 0.0 [Bug 2954959]} {
    ::tcl::mathfunc::abs 0.0
} 0.0
test expr-38.9 {abs and 0.0 [Bug 2954959]} {
    expr {abs(0.0)}
} 0.0
test expr-38.10 {abs and -0x0 [Bug 2954959]} {
    expr {abs(-0x0)}
} 0
test expr-38.11 {abs and 0x0 [Bug 2954959]} {
    ::tcl::mathfunc::abs { 	0x0}
} { 	0x0}
test expr-38.12 {abs and -0x0 [Bug 2954959]} {
    ::tcl::mathfunc::abs { 	-0x0}
} 0
test expr-38.13 {abs and 0.0 [Bug 2954959]} {
    ::tcl::mathfunc::abs 1e-324
} 1e-324

testConstraint testexprlongobj   [llength [info commands testexprlongobj]]
testConstraint testexprdoubleobj [llength [info commands testexprdoubleobj]]

test expr-39.1 {Check that Tcl_ExprLongObj doesn't modify interpreter result if no error} testexprlongobj {
    testexprlongobj 4+1
} {This is a result: 5}

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint winVista 0
testConstraint win2000orXP 0
testConstraint winOlderThan2000 0
# Don't know how to determine this constraint correctly
testConstraint notNetworkFilesystem 0
testConstraint 95or98 [expr {[testConstraint 95] || [testConstraint 98]}]
testConstraint 2000orNewer [expr {[testConstraint win] && ![testConstraint 95or98]}]
testConstraint reg 0
if {[testConstraint win]} {
    catch {
	# Is the registry extension already static to this shell?
	if [catch {load {} Registry; set ::reglib {}}] {
	    # try the location given to use on the commandline to tcltest
	    ::tcltest::loadTestedCommands
	    load $::reglib Registry
	}
	testConstraint reg 1
    }
}

# Find a group that exists on this Unix system, or else skip tests that
# require Unix groups.
testConstraint foundGroup [expr {![testConstraint unix]}]
if {[testConstraint unix]} {
    catch {
	set groupList [exec groups]
	set group [lindex $groupList 0]
	testConstraint foundGroup 1
    }
}

# Also used in winFCmd...
if {[testConstraint winOnly]} {
    set major [string index $tcl_platform(osVersion) 0]
    if {[testConstraint nt] && $major > 4} {
        if {$major > 5} {
            testConstraint winVista 1
        } elseif {$major == 5} {
            testConstraint win2000orXP 1
        }
    } else {
        testConstraint winOlderThan2000 1
    }
}

testConstraint darwin9 [expr {[testConstraint unix] &&
	$tcl_platform(os) eq "Darwin" &&
	int([string range $tcl_platform(osVersion) 0 \
	[string first . $tcl_platform(osVersion)]]) >= 9}]
testConstraint notDarwin9 [expr {![testConstraint darwin9]}]

} -body {
    createfile tf1
    createfile tf2
    file mkdir td1
    set x [list [file exists tf1] [file exists tf2] [file exists td1]]
    file delete tf1 td1 tf2
    lappend x [file exists tf1] [file exists tf2] [file exists tf3]
} -cleanup {cleanup} -result {1 1 1 0 0 0}
test fCmd-5.5 {TclFileDeleteCmd: stop at first error} -setup {
    cleanup
} -constraints {notRoot unixOrPc} -body {
    createfile tf1
    createfile tf2
    file mkdir td1
    catch {file delete tf1 td1 $root tf2}
    list [file exists tf1] [file exists tf2] [file exists td1]
} -cleanup {cleanup} -result {0 1 0}
test fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} -constraints {notRoot} -body {
    file delete ~_totally_bogus_user
} -returnCodes error -result {user "_totally_bogus_user" doesn't exist}
test fCmd-5.7 {TclFileDeleteCmd: Tcl_TranslateFileName succeeds} -setup {
    catch {file delete ~/tf1}
} -constraints {notRoot} -body {
    createfile ~/tf1

    testchmod 444 tf2
    file rename tf1 tf3
    file rename tf2 tf4
    list [lsort [glob tf*]] [file writable tf3] [file writable tf4]
} -result {{tf3 tf4} 1 0}
test fCmd-9.4 {file rename: comprehensive: dir to new name} -setup {
    cleanup
} -constraints {unixOrPc notRoot testchmod notDarwin9 win2000orXP} -body {
    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]
} -cleanup {
    cleanup
} -result {{td3 td4} 1 0}
test fCmd-9.5 {file rename: comprehensive: file to self} -setup {
    cleanup
} -constraints {notRoot testchmod} -body {
    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]
} -result {tf1 tf2 1 0}
test fCmd-9.6 {file rename: comprehensive: dir to self} -setup {
    cleanup
} -constraints {notRoot unixOrPc testchmod win2000orXP} -body {
    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]
} -result {{td1 td2} 1 0}

test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} -setup {
    cleanup
} -constraints {notRoot testchmod} -body {
    file mkdir tds1
    file mkdir tds2
    file mkdir [file join tdd1 tds1 xxx]
    file mkdir [file join tdd2 tds2 xxx]
    if {!([testConstraint unix] || [testConstraint winVista])} {
	testchmod 555 tds2
    }
    set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg]
    set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg]
    if {[testConstraint unix] || [testConstraint winVista]} {
	set w2 0
    } else {
	set w2 [file writable tds2]
    }
    list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2
} -match glob -result \
    [subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file *}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file *}} 1 0}]

} -result [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} -setup {
    cleanup
} -constraints {notRoot testchmod} -body {
    file mkdir td1
    file mkdir td2
    file mkdir td3
    if {!([testConstraint unix] || [testConstraint winVista])} {
	testchmod 555 td2
    }
    file rename td1 [file join td3 td3]
    file rename td2 [file join td3 td4]
    if {[testConstraint unix] || [testConstraint winVista]} {
        set w4 0
    } else {
	set w4 [file writable [file join td3 td4]]
    }
    list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \
    [file writable [file join td3 td3]] $w4
} -result [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}]

	    [glob -directory td4 t*] [file writable td3] [file writable td4]
} -cleanup {
    testchmod 755 td2
    testchmod 755 td4
} -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0]
test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup {
    cleanup
} -constraints {notRoot 2000orNewer testchmod} -body {
    # On Windows with ACLs, copying a directory is defined like this
    file mkdir [file join td1 tdx]
    file mkdir [file join td2 tdy]
    testchmod 555 td2
    file copy td1 td3
    file copy td2 td4
    list [lsort [glob td*]] [glob -directory td3 t*] \

    file copy td1 [file join td3 td3]
    file copy td2 [file join td3 td4]
    list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \
    [file writable [file join td3 td3]] [file writable [file join td3 td4]]
} -result [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}]
test fCmd-10.8.1 {file rename: comprehensive: dir to new name and dir} -setup {
    cleanup
} -constraints {notRoot 2000orNewer testchmod} -body {
    # On Windows with ACLs, copying a directory is defined like this
    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]

removeFile abc2.file
removeFile abc.file
removeDirectory abc2.dir
removeDirectory abc.dir

test fCmd-30.1 {file writable on 'My Documents'} -setup {
    # Get the localized version of the folder name by looking in the registry.
    set mydocsname [registry get {HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders} Personal]
} -constraints {2000orNewer reg} -body {
    file writable $mydocsname
} -result 1
test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {2000orNewer} -body {
    expr {[info exists env(USERPROFILE)]
          && [file exists $env(USERPROFILE)/NTUSER.DAT]
          && [file readable $env(USERPROFILE)/NTUSER.DAT]}

} -result {1}
test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {2000orNewer} -body {
    set r {}
    if {[info exists env(SystemDrive)]} {
        set path $env(SystemDrive)/pagefile.sys
        lappend r exists [file exists $path]
        lappend r readable [file readable $path]
        lappend r stat [catch {file stat $path a} e] $e
    }
    return $r
} -result {exists 1 readable 0 stat 0 {}}

# cleanup
cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

} globTest
test filename-14.29 {Bug 2710920} {unixOrPc} {
    file extension [lindex [lsort [glob globTest/*/]] 0]
} {}
test filename-14.30 {Bug 2710920} {unixOrPc} {
    file rootname [lindex [lsort [glob globTest/*/]] 0]
} globTest/a1/

test filename-14.31 {Bug 2918610} -setup {
    set d [makeDirectory foo]
    makeFile {} bar.soom $d
} -body {
    foreach fn [glob $d/bar.soom] {
        set root [file rootname $fn]
        close [open $root {WRONLY CREAT}]
    }
    llength [glob -directory $d *]
} -cleanup {
    file delete -force $d/bar
    removeFile bar.soom $d
    removeDirectory foo
} -result 2

unset globname

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

test filename-16.17 {windows specific globbing} -constraints {win} -body {
    cd C:/
    # Ensure correct trimming of tails with absolute and volume relative
    # globbing.
    list [glob -nocomplain -tails -dir C:/ *] \
	[glob -nocomplain -tails -dir C: *]
} -match compareWords -result equal

# Put the working directory back now that we're done with globbing in C:/
if {[testConstraint win]} {
    cd $oldDir
}

test filename-17.1 {windows specific special files} {testsetplatform} {
    testsetplatform win
    list [file pathtype com1] [file pathtype con] [file pathtype lpt3] \
	[file pathtype prn] [file pathtype nul] [file pathtype aux] \
	[file pathtype foo]
} {absolute absolute absolute absolute absolute absolute relative}

    makeFile {} TAGS $d
} -body {
    llength [glob -nocomplain -directory $d -types {} -- URGENT Urkle]
} -cleanup {
    removeFile TAGS $d
    removeDirectory foo
} -result 0

test fileName-20.5 {Bug 2837800} -setup {
    set dd [makeDirectory isolate]
    set d [makeDirectory ./~foo $dd]
    makeFile {} test $d
    set savewd [pwd]
    cd $dd
} -body {
    glob -nocomplain */test
} -cleanup {
    cd $savewd
    removeFile test $d
    removeDirectory ./~foo $dd
    removeDirectory isolate
} -result ~foo/test

test fileName-20.6 {Bug 2837800} -setup {
    # Recall that we have $env(HOME) set so that references
    # to ~ point to [temporaryDirectory]
    makeFile {} test ~
    set dd [makeDirectory isolate]
    set d [makeDirectory ./~ $dd]
    set savewd [pwd]
    cd $dd
} -body {
    glob -nocomplain */test
} -cleanup {
    cd $savewd
    removeDirectory ./~ $dd
    removeDirectory isolate
    removeFile test ~
} -result {}

test fileName-20.7 {Bug 2806250} -setup {
    set savewd [pwd]
    cd [temporaryDirectory]
    set d [makeDirectory isolate]
    makeFile {} ./~test $d
} -body {
    file exists [lindex [glob -nocomplain isolate/*] 0]
} -cleanup {
    removeFile ./~test $d
    removeDirectory isolate
    cd $savewd
} -result 1

test fileName-20.8 {Bug 2806250} -setup {
    set savewd [pwd]
    cd [temporaryDirectory]
    set d [makeDirectory isolate]
    makeFile {} ./~test $d
} -body {
    file tail [lindex [glob -nocomplain isolate/*] 0]
} -cleanup {
    removeFile ./~test $d
    removeDirectory isolate
    cd $savewd
} -result ./~test

test fileName-20.9 {} -setup {
    makeFile {} test ~
    set d [makeDirectory isolate]
    set savewd [pwd]
    cd $d
} -body {
   glob -nocomplain -directory ~ test
} -cleanup {
    cd $savewd
    removeDirectory isolate
    removeFile test ~
} -result ~/test

test fileName-20.10 {} -setup {
    set s [makeDirectory sub ~]
    makeFile {} fileName-20.10 $s
    set d [makeDirectory isolate]
    set savewd [pwd]
    cd $d
} -body {
   glob -nocomplain -directory ~ -join * fileName-20.10
} -cleanup {
    cd $savewd
    removeDirectory isolate
    removeFile fileName-20.10 $s
    removeDirectory sub ~
} -result ~/sub/fileName-20.10

# cleanup
catch {file delete -force C:/globTest}
cd [temporaryDirectory]
file delete -force globTest
cd $oldpwd
set env(HOME) $oldhome

    set testdir ~
    set res1 "Parent of ~ (/foo/bar/blah) is [file dirname $testdir]"
    set ::env(HOME) /a/b/c
    set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]"
    list $res1 $res2
} -cleanup {
    set ::env(HOME) $orig
} -match regexp -result {{Parent of ~ \(/foo/bar/blah\) is ([a-zA-Z]:)?(/cygwin)?(/foo/bar|foo:bar)} {Parent of ~ \(/a/b/c\) is ([a-zA-Z]:)?(/cygwin)?(/a/b|a:b)}}

test filesystem-6.1 {empty file name} -returnCodes error -body {
    open ""
} -result {couldn't open "": no such file or directory}
test filesystem-6.2 {empty file name} -returnCodes error -body {
    file stat "" arr
} -result {could not read "": no such file or directory}

test filesystem-6.33 {empty file name} {file writable ""} 0

# Make sure the testfilesystem hasn't been registered.
if {[testConstraint testfilesystem]} {
    while {![catch {testfilesystem 0}]} {}
}

test filesystem-7.1.1 {load from vfs} -setup {
    set dir [pwd]
} -constraints {win testsimplefilesystem} -body {
    # This may cause a crash on exit
    cd [file dirname [info nameof]]
    set dde [lindex [glob *dde*[info sharedlib]] 0]
    testsimplefilesystem 1
    # This loads dde via a complex copy-to-temp operation
    load simplefs:/$dde dde
    testsimplefilesystem 0
    return ok
    # The real result of this test is what happens when Tcl exits.
} -cleanup {
    cd $dir
} -result ok
test filesystem-7.1.2 {load from vfs, and then unload again} -setup {
    set dir [pwd]
} -constraints {win testsimplefilesystem} -body {
    # This may cause a crash on exit
    cd [file dirname [info nameof]]
    set reg [lindex [glob tclreg*[info sharedlib]] 0]
    testsimplefilesystem 1
    # This loads reg via a complex copy-to-temp operation
    load simplefs:/$reg Registry
    unload simplefs:/$reg
    testsimplefilesystem 0
    return ok
    # The real result of this test is what happens when Tcl exits.
} -cleanup {
    cd $dir
} -result ok
test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} -setup {
    set dir [pwd]

# %u output depends on word length, so this test is not portable.
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
testConstraint wideIs64bit \
	[expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]

test format-1.1 {integer formatting} {
    format "%*d %d %d %d" 6 34 16923 -12 -1
} {    34 16923 -12 -1}
test format-1.2 {integer formatting} {
    format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12
} {   6   34 16923  -12 -1 0xe 0XC}
test format-1.3 {integer formatting} longIs32bit {

} 1.000000

test format-18.1 {do not demote existing numeric values} {
    set a 0xaaaaaaaa
    # Ensure $a and $b are separate objects
    set b 0xaaaa
    append b aaaa

    set result [expr {$a == $b}]
    format %08lx $b
    lappend result [expr {$a == $b}]

    set b 0xaaaa
    append b aaaa

    lappend result [expr {$a == $b}]
    format %08x $b
    lappend result [expr {$a == $b}]
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} {
    set a [expr {0xaaaaaaaaaa + 1}]
    set b 0xaaaaaaaaab
    list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}

test format-19.1 {
    regression test - tcl-core message by Brian Griffin on
    26 0ctober 2004
} -body {
    set x 0x8fedc654
    list [expr { ~ $x }] [format %08x [expr { ~$x }]]
} -match regexp -result {-2414724693 f*701239ab}

test format-19.2 {Bug 1867855} {
    format %llx 0
} 0
test format-19.3 {Bug 2830354} {
    string length [format %340f 0]
} 340

# Note that this test may fail in future versions
test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body {
    set x [dict create a b c d]
    format %s $x
    # After this, obj in $x should be a dict with a non-NULL bytes field
    tcl::unsupported::representation $x
} -match glob -result {value is a dict with *, string representation "*".}

# cleanup
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

# Commands covered:  history
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands.  Sourcing this file into Tcl runs the tests and generates output
# for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics 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.6 2004/05/19 12:43:03 dkf Exp $
  
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

    history add {set a 12345}
    history add {set b [format {A test %s} string]}
    history add {Another test}
} else {
    # Dummy value, must be numeric
    set num 0
}

# "history event"

test history-1.1 {event option} history {history event -1} \
	{set b [format {A test %s} string]}
test history-1.2 {event option} history {history event $num} \
	{set a 12345}
test history-1.3 {event option} history {history event [expr $num+2]} \

# miscellaneous

test history-9.1 {miscellaneous} history {catch {history gorp} msg} 1
test history-9.2 {miscellaneous} history {
    catch {history gorp} msg
    set msg
} {unknown or ambiguous subcommand "gorp": must be add, change, clear, event, info, keep, nextid, or redo}

# cleanup
::tcltest::cleanupTests
return

# Functionality covered: this file contains a collection of tests for the auto
# loading and namespaces.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# 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.18 2007/12/13 15:26:06 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}

# Six cases - white box testing

test init-1.1 {auto_qualify - absolute cmd - namespace} {
    auto_qualify ::foo::bar ::blue
} ::foo::bar

test init-1.2 {auto_qualify - absolute cmd - global} {
    auto_qualify ::global ::sub
} global

test init-1.3 {auto_qualify - no colons cmd - global} {
    auto_qualify nocolons ::
} nocolons 

test init-1.4 {auto_qualify - no colons cmd - namespace} {
    auto_qualify nocolons ::sub
} {::sub::nocolons nocolons}

test init-1.5 {auto_qualify - colons in cmd - global} {
    auto_qualify foo::bar ::
} ::foo::bar

test init-1.6 {auto_qualify - colons in cmd - namespace} {
    auto_qualify foo::bar ::sub
} {::sub::foo::bar ::foo::bar}

# Some additional tests

test init-1.7 {auto_qualify - multiples colons 1} {
    auto_qualify :::foo::::bar ::blue
} ::foo::bar

test init-1.8 {auto_qualify - multiple colons 2} {
    auto_qualify :::foo ::bar
} foo


# We use a sub-interp and auto_reset and double the tests because there is 2
# places where auto_loading occur (before loading the indexes files and after)

set testInterp [interp create]
interp eval $testInterp [list set argv $argv]
interp eval $testInterp [list package require tcltest]
interp eval $testInterp [list namespace import -force ::tcltest::*]

interp eval $testInterp {

auto_reset
catch {rename parray {}}

test init-2.0 {load parray - stage 1} {
    set ret [catch {parray} error]
    rename parray {}  ;# remove it, for the next test - that should not fail.
    list $ret $error
} {1 {wrong # args: should be "parray a ?pattern?"}}


test init-2.1 {load parray - stage 2} {
    set ret [catch {parray} error]
    list $ret $error
} {1 {wrong # args: should be "parray a ?pattern?"}}


auto_reset
catch {rename ::safe::setLogCmd {}}
#unset auto_index(::safe::setLogCmd)
#unset auto_oldpath

test init-2.2 {load ::safe::setLogCmd - stage 1} {
    ::safe::setLogCmd
    rename ::safe::setLogCmd {}  ;# should not fail
} {}

test init-2.3 {load ::safe::setLogCmd - stage 2} {
    ::safe::setLogCmd
    rename ::safe::setLogCmd {}  ;# should not fail
} {}

auto_reset
catch {rename ::safe::setLogCmd {}}

test init-2.4 {load safe:::setLogCmd - stage 1} {
    safe:::setLogCmd  ;# intentionally 3 :
    rename ::safe::setLogCmd {}  ;# should not fail
} {}

test init-2.5 {load safe:::setLogCmd - stage 2} {
    safe:::setLogCmd  ;# intentionally 3 :
    rename ::safe::setLogCmd {}  ;# should not fail
} {}

auto_reset
catch {rename ::safe::setLogCmd {}}

test init-2.6 {load setLogCmd from safe:: - stage 1} {
    namespace eval safe setLogCmd 
    rename ::safe::setLogCmd {}  ;# should not fail
} {}

test init-2.7 {oad setLogCmd from safe::  - stage 2} {
    namespace eval safe setLogCmd 
    rename ::safe::setLogCmd {}  ;# should not fail
} {}



test init-2.8 {load tcl::HistAdd} -setup {
    auto_reset
    catch {rename ::tcl::HistAdd {}}
} -body {
    # 3 ':' on purpose
    list [catch {tcl:::HistAdd} error] $error
} -cleanup {
    rename ::tcl::HistAdd {}
} -result {1 {wrong # args: should be "tcl:::HistAdd event ?exec?"}}


test init-3.0 {random stuff in the auto_index, should still work} {
    set auto_index(foo:::bar::blah) {
        namespace eval foo {namespace eval bar {proc blah {} {return 1}}}
    }
    foo:::bar::blah
} 1

# Tests that compare the error stack trace generated when autoloading with
# that generated when no autoloading is necessary.  Ideally they should be the
# same.

set count 0
foreach arg [subst -nocommands -novariables {
		c
                {argument
                which spans
                multiple lines}

	auto_reset
	catch {parray a b $arg}
	set first $::errorInfo
	catch {parray a b $arg}
	set second $::errorInfo
	string equal $first $second
    } 1

    test init-4.$count.1 {::errorInfo produced by [unknown]} {
	auto_reset
	namespace eval junk [list array set $arg [list 1 2 3 4]]
	trace variable ::junk::$arg r \
		"[list error [subst {Variable \"$arg\" is write-only}]] ;# "
	catch {parray ::junk::$arg}
	set first $::errorInfo
	catch {parray ::junk::$arg}
	set second $::errorInfo
	string equal $first $second
    } 1

    incr count
}

test init-5.0 {return options passed through ::unknown} -setup {
    catch {rename xxx {}}
    set ::auto_index(::xxx) {proc ::xxx {} {
	return -code error -level 2 xxx
    }}
} -body {
    set code [catch {::xxx} foo bar]
    set code2 [catch {::xxx} foo2 bar2]
    list $code $foo $bar $code2 $foo2 $bar2
} -cleanup {
    unset ::auto_index(::xxx)
} -match glob -result {2 xxx {-errorcode NONE -code 1 -level 1} 2 xxx {-code 1 -level 1 -errorcode NONE}}

cleanupTests
}	;#  End of [interp eval $testInterp]

# cleanup
interp delete $testInterp
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:

    close $f
    close $f2
    set result
} {{
out
} {err
}}
# This test relies on the fact that stdout is used before stderr
test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec} {
    set f [open $path(test1) w]
    puts -nonewline $f { close stdin
	close stdout
	close stderr
	set f  [}
    puts $f [list open $path(test1) r]]
    puts $f "set f2 \[[list open $path(test2) w]]"

    set f  [open $path(test2) r]
    set f2 [open $path(test3) r]
    lappend result [read $f] [read $f2]
    close $f
    close $f2
    set result
} {{ close stdin

stdout
} {stderr
}}
catch {interp delete z}
test io-14.5 {Tcl_GetChannel: stdio name translation} {
    interp create z
    eof stdin
    catch {z eval flush stdin} msg1
    catch {z eval close stdin} msg2

	close stdin
	puts [testchannel open]
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    set l [gets $f]
    close $f
    lsort $l
} {file1 file2}

test io-29.1 {Tcl_WriteChars, channel not writable} {
    list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.2 {Tcl_WriteChars, empty string} {
    file delete $path(test1)

    catch {close $b}
    close $pipe
    rename ::done {}
    after 1000 ;# Give Windows time to kill the process
    removeFile err
    catch {unset ::forever}
} -result {AB BA}
test io-53.11 {Bug 2895565} -setup {
    set in [makeFile {} in]
    set f [open $in w]
    fconfigure $f -encoding utf-8 -translation binary
    puts -nonewline $f [string repeat "Ho hum\n" 11]
    close $f
    set inChan [open $in r]
    fconfigure $inChan -translation binary
    set out [makeFile {} out]
    set outChan [open $out w]
    fconfigure $outChan -encoding cp1252 -translation crlf
    proc CopyDone {bytes args} {
	variable done
	if {[llength $args]} {
	    set done "Error: '[lindex $args 0]' after $bytes bytes copied"
	} else {
	    set done "$bytes bytes copied"
	}
    }
} -body {
    variable done
    after 2000 [list set [namespace which -variable done] timeout]
    fcopy $inChan $outChan -size 40 -command [namespace which CopyDone]
    vwait [namespace which -variable done]
    set done
} -cleanup {
    close $outChan
    close $inChan
    removeFile out
    removeFile in
} -result {40 bytes copied}

test io-54.1 {Recursive channel events} {socket fileevent} {
    # This test checks to see if file events are delivered during recursive
    # event loops when there is buffered data on the channel.

    proc accept {s a p} {
	variable as

} {1 {can't write input to command: standard input was redirected} NONE}
test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
    list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} NONE}
test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
    list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} NONE}
test iocmd-11.4 {I/O to command pipelines} unixOrPc {
    list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode
} {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}}

test iocmd-12.1 {POSIX open access modes: RDONLY} {
    file delete $path(test1)
    set f [open $path(test1) w]
    puts $f "Two lines: this one"
    puts $f "and this one"
    close $f

    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt
    close $c
    rename foo {}
    set res
} -result {{read rc* 4096} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}}
test iocmd-23.9 {chan read, no data means eof} -match glob -setup {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return ""
    }
    set c [chan create {r w} foo]
} -body {
    note [read $c 2]
    note [eof $c]
    set res
} -cleanup {
    close $c
    rename foo {}
    unset res
} -result {{read rc* 4096} {} 1}
test iocmd-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glob -setup {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	error EAGAIN
    }
    set c [chan create {r w} foo]
} -body {
    note [read $c 2]
    note [eof $c]
    set res
} -cleanup {
    close $c
    rename foo {}
    unset res
} -result {{read rc* 4096} {} 0}

# --- === *** ###########################
# method write

test iocmd-24.1 {chan write, regular write} -match glob -body {
    set res {}
    proc foo {args} {

    note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt]
    note $msg
    noteOpts $opt
    close $c
    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}}
test iocmd-24.14 {chan write, no EAGAIN means that writing is allowed at this time, bug 2936225} -match glob -setup {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return 3
    }
    set c [chan create {r w} foo]
} -body {
    note [puts -nonewline $c ABC ; flush $c]
    set res
} -cleanup {
    close $c
    rename foo {}
    unset res
} -result {{write rc* ABC} {}}
test iocmd-24.15 {chan write, EAGAIN means that writing is not allowed at this time, bug 2936225} -match glob -setup {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	# Note: The EAGAIN signals that the channel cannot accept
	# write requests right now, this in turn causes the IO core to
	# request the generation of writable events (see expected
	# result below, and compare to case 24.14 above).
	error EAGAIN
    }
    set c [chan create {r w} foo]
} -body {
    note [puts -nonewline $c ABC ; flush $c]
    set res
} -cleanup {
    close $c
    rename foo {}
    unset res
} -result {{write rc* ABC} {watch rc* write} {}}

# --- === *** ###########################
# method cgetall

test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}

	after 2000
	catch { puts $chan shoo } res
	set res
    }]
    set res
} -constraints {testchannel impossible} \
    -result {Owner lost}

test iocmd-32.2 {delete interp of reflected chan} {
    # Bug 3034840
    # Run this test in an interp with memory debugging to panic
    # on the double free
    interp create slave
    slave eval {
        proc no-op args {}
        proc driver {sub args} {return {initialize finalize watch read}}
        chan event [chan create read driver] readable no-op
    }
    interp delete slave
} {}

# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and
## receiving driver operations to the originator thread.

# -*- tcl -*-
# ### ### ### ######### ######### #########

	close $c
	notes
    } c]
    rename foo {}
    set res
} -result {{read rc* 4096} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \
    -constraints {testchannel testthread}
test iocmd.tf-23.9 {chan read, no data means eof} -match glob -setup {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return ""
    }
    set c [chan create {r w} foo]
} -body {
    notes [inthread $c {
	note [read $c 2]
	note [eof $c]
	close $c
	notes
    } c]
    set res
} -cleanup {
    rename foo {}
    unset res
} -result {{read rc* 4096} {} 1} \
    -constraints {testchannel testthread}
test iocmd.tf-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glob -setup {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	error EAGAIN
    }
    set c [chan create {r w} foo]
} -body {
    notes [inthread $c {
	note [read $c 2]
	note [eof $c]
	close $c
	notes
    } c]
    set res
} -cleanup {
    rename foo {}
    unset res
} -result {{read rc* 4096} {} 0} \
    -constraints {testchannel testthread}

# --- === *** ###########################
# method write

test iocmd.tf-24.1 {chan write, regular write} -match glob -body {
    set res {}
    proc foo {args} {

	noteOpts $opt
	close $c
	notes
    } c]
    rename foo {}
    set res
} -result {{write rc* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} \
    -constraints {testchannel testthread}
test iocmd.tf-24.14 {chan write, no EAGAIN means that writing is allowed at this time, bug 2936225} -match glob -setup {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return 3
    }
    set c [chan create {r w} foo]
} -body {
    notes [inthread $c {
	note [puts -nonewline $c ABC ; flush $c]
	close $c
	notes
    } c]
    set res
} -cleanup {
    rename foo {}
    unset res
} -result {{write rc* ABC} {}} \
    -constraints {testchannel testthread}
test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at this time, bug 2936225} -match glob -setup {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	# Note: The EAGAIN signals that the channel cannot accept
	# write requests right now, this in turn causes the IO core to
	# request the generation of writable events (see expected
	# result below, and compare to case 24.14 above).
	error EAGAIN
    }
    set c [chan create {r w} foo]
} -body {
    notes [inthread $c {
	note [puts -nonewline $c ABC ; flush $c]
	close $c
	notes
    } c]
    set res
} -cleanup {
    rename foo {}
    unset res
} -result {{write rc* ABC} {watch rc* write} {}} \
    -constraints {testchannel testthread}

# --- === *** ###########################
# method cgetall

test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body {
    set res {}

set helperscript {
    if {[lsearch [namespace children] ::tcltest] == -1} {
	package require tcltest 2
	namespace import -force ::tcltest::*
    }

    proc note  {item}  {global res; lappend res $item; return}
    #proc note  {item}  {global res; lappend res $item; puts $item ; flush stdout ; return}
    proc track {}      {upvar args item; note $item; return}
    proc notes {items} {foreach i $items {note $i}}

    # Use to prevent *'s in pattern to match beyond the expected end
    # of the recording.
    proc endnote {} {note |}

    set c [chan push [tempchan] foo]
    note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt
    tempdone
    rename foo {}
    set res
} -result {{read rt* {test data
}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}}
test iortrans-4.8 {chan read, read, bug 2921116} -match glob -setup {
    set res {}
    proc foo {fd args} {
	oninit; onfinal; track
	# Kill and recreate transform while it is operating
	chan pop  $fd
	chan push $fd [list foo $fd]
    }
    set c [chan push [set c [tempchan]] [list foo $c]]
} -body {
    note [read $c]
    #note [gets $c]
    set res
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} file*}
test iortrans-4.9 {chan read, gets, bug 2921116} -match glob -setup {
    set res {}
    proc foo {fd args} {
	oninit; onfinal; track
	# Kill and recreate transform while it is operating
	chan pop  $fd
	chan push $fd [list foo $fd]
    }
    set c [chan push [set c [tempchan]] [list foo $c]]
} -body {
    note [gets $c]
    set res
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} file*}

# --- === *** ###########################
# method write (via puts)

test iortrans-5.1 {chan write, regular write} -match glob -body {
    set res {}
    proc foo {args} { oninit; onfinal; track ; return transformresult }

    note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt]
    note $msg
    noteOpts $opt
    tempdone
    rename foo {}
    set res
} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}}
test iortrans-5.11 {chan write, bug 2921116} -match glob -setup {
    set res {}
    set level 0
    proc foo {fd args} {
	oninit; onfinal; track
	# pop - invokes flush - invokes 'foo write' - infinite recursion - stop it
	global level
	if {$level} { return "" }
	incr level
	# Kill and recreate transform while it is operating
	chan pop  $fd
	chan push $fd [list foo $fd]
    }
    set c [chan push [set c [tempchan]] [list foo $c]]
} -body {
    note [puts -nonewline $c abcdef]
    note [flush $c]
    set res
} -cleanup {
    tempdone
    rename foo {}
} -result {{} {write rt* abcdef} {write rt* abcdef} {}}

# --- === *** ###########################
# method limit?, drain (via read)

test iortrans-6.1 {chan read, read limits} -match glob -body {
    set res {}
    proc foo {args} {

    }
    set c [chan push [tempchan] foo]
    seek $c 2
    tempdone
    rename foo {}
    set res
} -result {{clear rt*}}
test iortrans-7.4 {chan clear, bug 2921116} -match glob -setup {
    set res {}
    proc foo {fd args} {
	oninit clear; onfinal; track
	# Kill and recreate transform while it is operating
	chan pop  $fd
	chan push $fd [list foo $fd]
    }
    set c [chan push [set c [tempchan]] [list foo $c]]
} -body {
    seek $c 2
    set res
} -cleanup {
    tempdone
    rename foo {}
} -result {{clear rt*}}

# --- === *** ###########################
# method flush (via seek, close)

test iortrans-8.1 {seek flushes write buffers, ignores data} -match glob -body {
    set res {}
    proc foo {args} {

    close $c
    note [tempview]
    tempdone
    rename foo {}
    set res
} -result {{flush rt*} {finalize rt*} .flushed.}

test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup {
    set res {}
    proc foo {fd args} {
	oninit flush; onfinal; track
	# Kill and recreate transform while it is operating
	chan pop  $fd
	chan push $fd [list foo $fd]
    }
    set c [chan push [set c [tempchan]] [list foo $c]]
} -body {
    seek $c 2
    set res
} -cleanup {
    tempdone
    rename foo {}
} -result {{flush rt*}}

# --- === *** ###########################
# method watch - removed from TIP (rev 1.12+)

# --- === *** ###########################
# method event - removed from TIP (rev 1.12+)

	set res
    }]
    tempdone
    set res
} -constraints {testchannel impossible} \
    -result {Owner lost}


test iortrans-11.2 {delete interp of reflected transform} -body {
    interp create slave

    # Magic to get the test* commands into the slave
    load {} Tcltest slave

    # Get base channel into the slave
    set c [tempchan]
    testchannel cut $c
    interp eval slave [list testchannel splice $c]
    interp eval slave [list set c $c]

    slave eval {
        proc no-op args {}
        proc driver {c sub args} {return {initialize finalize read write}}
	set t [chan push $c [list driver $c]]
        chan event $c readable no-op
    }
    interp delete slave
} -result {} -constraints {testchannel}

# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and
## receiving driver operations to the originator thread.

# -*- tcl -*-
# ### ### ### ######### ######### #########
## Testing the reflected channel (Thread forwarding).

testConstraint teststaticpkg [llength [info commands teststaticpkg]]

# Test load-10.1 requires the 'testsimplefilesystem' command from tcltest

testConstraint testsimplefilesystem \
	[llength [info commands testsimplefilesystem]]

test load-1.1 {basic errors} {} {
    list [catch {load} msg] $msg
} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}"
test load-1.2 {basic errors} {} {
    list [catch {load a b c d} msg] $msg
} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}"
test load-1.3 {basic errors} {} {

test load-1.6 {basic errors} {} {
    list [catch {load {} Unknown} msg] $msg
} {1 {package "Unknown" isn't loaded statically}}

test load-2.1 {basic loading, with guess for package name} \
	[list $dll $loaded] {
    load [file join $testDir pkga$ext]
    list [pkga_eq abc def] [lsort [info commands pkga_*]]
} {0 {pkga_eq pkga_quote}}
interp create -safe child
test load-2.2 {loading into a safe interpreter, with package name conversion} \
	[list $dll $loaded] {
    load [file join $testDir pkgb$ext] pKgB child
    list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
	    [catch {pkgb_sub 12 10} msg2] $msg2
} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \
-body {
    list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode
} -match glob \
    -result [list 1 {cannot find symbol "Foo_Init"*} \
		 {TCL LOOKUP LOAD_SYMBOL *Foo_Init}]
test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] {
    list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg
} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}}

test load-3.1 {error in _Init procedure, same interpreter} \
	[list $dll $loaded] {
    list [catch {load [file join $testDir pkge$ext] pkge} msg] \

test load-10.1 {load from vfs} \
    -constraints [list $dll $loaded testsimplefilesystem] \
    -setup {set dir [pwd]; cd $testDir; testsimplefilesystem 1} \
    -body {list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg} \
    -result {0 {}} \
    -cleanup {testsimplefilesystem 0; cd $dir; unset dir}

# cleanup
unset ext
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

# RCS: @(#) $Id: namespace.test,v 1.72 2008/06/20 20:48:49 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

testConstraint memory [llength [info commands memory]]

#
# REMARK: the tests for 'namespace upvar' are not done here. They are to be
# found in the file 'upvar.test'.
#

# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}

    }
} -result {2 {} 2} -cleanup {
    catch {namespace delete ::test_ns_1}
    catch {namespace delete ::test_ns_2}
    catch {namespace delete ::test_ns_3}
    catch {namespace delete ::test_ns_4}
}

test namespace-51.13 {name resolution path control} -body {
    set ::result {}
    namespace eval ::test_ns_1 {
	proc foo {} {lappend ::result 1}
    }
    namespace eval ::test_ns_2 {
	proc foo {} {lappend ::result 2}
	trace add command foo delete "namespace eval ::test_ns_3 foo;#"
    }
    namespace eval ::test_ns_3 {
	proc foo {} {
	    lappend ::result 3
	    namespace delete [namespace current]
	    ::test_ns_4::bar
	}

    # Should the result be "2 {} {2 3 2 1}" instead?
} -result {2 {} {2 3 1 1}} -cleanup {
    catch {namespace delete ::test_ns_1}
    catch {namespace delete ::test_ns_2}
    catch {namespace delete ::test_ns_3}
    catch {namespace delete ::test_ns_4}
}
test namespace-51.14 {name resolution path control} -setup {
    foreach cmd [info commands foo*] {
	rename $cmd {}
    }

    namespace eval ::test_ns_1 {}
    namespace eval ::test_ns_2 {}

    namespace eval ::test_ns_3 {}
} -body {
    proc foo0 {} {}
    proc ::test_ns_1::foo1 {} {}
    proc ::test_ns_2::foo2 {} {}
    namespace eval ::test_ns_3 {
	variable result {}
	lappend result [info commands foo*]
	namespace path {::test_ns_1 ::test_ns_2}
	lappend result [info commands foo*]
	proc foo2 {} {}
	lappend result [info commands foo*]
	rename foo2 {}
	lappend result [info commands foo*]
	namespace delete ::test_ns_1
	lappend result [info commands foo*]
    }
} -cleanup {
    catch {namespace delete ::test_ns_1}
    catch {namespace delete ::test_ns_2}
    catch {namespace delete ::test_ns_3}
} -result {foo0 {foo1 foo2 foo0} {foo2 foo1 foo0} {foo1 foo2 foo0} {foo2 foo0}}
test namespace-51.15 {namespace resolution path control} -body {
    namespace eval ::test_ns_2 {
	proc foo {} {return 2}
    }
    namespace eval ::test_ns_1 {
	namespace eval test_ns_2 {
	    proc foo {} {return 1_2}

    namespace delete ::test_ns_2
}
test namespace-51.16 {Bug 1566526} {
    interp create slave
    slave eval namespace eval demo namespace path ::
    interp delete slave
} {}
test namespace-51.17 {resolution epoch handling: Bug 2898722} -setup {
    set result {}
    catch {namespace delete ::a}
} -constraints knownBug -body {
    namespace eval ::a {
	proc c {} {lappend ::result A}
	c
	namespace eval b {
	    variable d c
	    lappend ::result [catch { $d }]
	}
	lappend ::result .
	namespace eval b {
	    namespace path [namespace parent]
	    $d;[format %c 99]
	}
	lappend ::result .
	namespace eval b {
	    proc c {} {lappend ::result B}
	    $d;[format %c 99]
	}
	lappend ::result .
    }
    namespace eval ::a::b {
	$d;[format %c 99]
	lappend ::result .
	proc ::c {} {lappend ::result G}
	$d;[format %c 99]
	lappend ::result .
	rename ::a::c {}
	$d;[format %c 99]
	lappend ::result .
	rename ::a::b::c {}
	$d;[format %c 99]
    }
} -cleanup {
    namespace delete ::a
    catch {rename ::c {}}
    unset result
} -result {A 1 . A A . B B . B B . B B . B B . G G}

# TIP 181 - namespace unknown tests
test namespace-52.1 {unknown: default handler ::unknown} {
    set result [list [namespace eval foobar { namespace unknown }]]
    lappend result [namespace eval :: { namespace unknown }]
    namespace delete foobar
    set result

    1 {wrong # args: should be "ns z1 x a1"}\
    1 {wrong # args: should be "ns z2 x a1 a2"}\
    1 {wrong # args: should be "ns z2 x a1 a2"}\
    1 {wrong # args: should be "::ns::x::z0"}\
    0 {1 v}\
    1 {wrong # args: should be "ns v x z2 a2"}\
    0 {2 v v2}}

test namespace-54.1 {leak on namespace deletion} -constraints {memory} \
-setup {
    proc getbytes {} {
	set lines [split [memory info] "\n"]
	lindex $lines 3 3
    }
} -body {
    set end [getbytes]
    for {set i 0} {$i < 5} {incr i} {
	set ns ::y$i
	namespace eval $ns {}
	namespace delete $ns
	set start $end
	set end [getbytes]
    }
    set leakedBytes [expr {$end - $start}]
} -cleanup {
    rename getbytes {}
    unset i ns start end
} -result 0

# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
namespace delete {*}[namespace children :: test_ns_*]
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

# This file contains a collection of tests for Tcl's built-in object system.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2006-2008 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: oo.test,v 1.7 2008/06/19 21:29:04 dkf Exp $

package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {

test oo-0.5 {testing literal leak on interp delete} memory {
    leaktest {
	interp create foo
	foo eval {oo::object new}
	interp delete foo
    }
} 0
test oo-0.6 {cleaning the core class pair; way #1} -setup {
    interp create t
    initInterpreter t
} -body {
    t eval {
	package require TclOO
	namespace path oo
	list [catch {class destroy} m] $m [catch {object destroy} m] $m
    }
} -cleanup {
    interp delete t
} -result {0 {} 1 {invalid command name "object"}}
test oo-0.7 {cleaning the core class pair; way #2} -setup {
    interp create t
    initInterpreter t
} -body {
    t eval {
	package require TclOO
	namespace path oo
	list [catch {object destroy} m] $m [catch {class destroy} m] $m
    }
} -cleanup {
    interp delete t
} -result {0 {} 1 {invalid command name "class"}}
test oo-0.8 {leak in variable management} -setup {
    oo::class create foo
} -constraints memory -body {
    oo::define foo {
	constructor {} {
	    variable v 0
	}
    }
    leaktest {[foo new] destroy}
} -cleanup {
    foo destroy
} -result 0

test oo-1.1 {basic test of OO functionality: no classes} {
    set result {}
    lappend result [oo::object create foo]
    lappend result [oo::objdefine foo {
	method bar args {
	    global result

} -body {
    oo::define B constructor {} {A create test-oo-1.18}
    B create C
} -cleanup {
    rename test-oo-1.18 {}
    A destroy
} -result ::C
test oo-1.19 {basic test of OO functionality: teardown order} -body {
    oo::object create o
    namespace delete [info object namespace o]
    o destroy
    # Crashes on error
} -returnCodes error -result {invalid command name "o"}
test oo-1.20 {basic test of OO functionality: my teardown post rename} -body {
    oo::object create obj
    rename [info object namespace obj]::my ::AGlobalName
    obj destroy
    info commands ::AGlobalName
} -result {}

test oo-2.1 {basic test of OO functionality: constructor} -setup {
    # This is a bit complex because it needs to run in a sub-interp as
    # we're modifying the root object class's constructor
    interp create subinterp
    initInterpreter subinterp
    subinterp eval {

	}
	lappend result 1 [oo::object create foo]
	lappend result 2 [rename foo {}]
    }
} -cleanup {
    interp delete subinterp
} -result {1 ::foo died 2 {}}
test oo-3.3 {basic test of OO functionality: destructor} -setup {
    oo::class create foo
    set result {}
} -cleanup {
    foo destroy
} -body {
    oo::define foo {
	constructor {} {lappend ::result made}
	destructor {lappend ::result died}
    }
    namespace delete [info object namespace [foo new]]
    return $result
} -result {made died}
test oo-3.4 {basic test of OO functionality: my exists in destructor} -setup {
    oo::class create cls
    set result {}
} -cleanup {
    cls destroy
} -body {
    oo::define cls {
	variable state
	constructor {} {
	    proc localcmdexists {} {}
	    set state ok
	}
	forward Report lappend ::result
	destructor {
	    objmy Report [catch {set state} msg] $msg
	    objmy Report [namespace which -var state]
	    objmy Report [info commands localcmdexists]
	}
    }
    cls create obj
    rename [info object namespace obj]::my ::objmy
    obj destroy
    lappend result [info commands ::objmy]
} -match glob -result {0 ok *::state localcmdexists {}}
test oo-3.4a {basic test of OO functionality: my exists in destructor} -setup {
    oo::class create cls
    set result {}
} -cleanup {
    cls destroy
} -body {
    oo::define cls {
	variable state
	constructor {} {
	    proc localcmdexists {} {}
	    set state ok
	}
	forward Report lappend ::result
	destructor {
	    objmy Report [catch {set state} msg] $msg
	    objmy Report [namespace which -var state]
	    objmy Report [info commands localcmdexists]
	}
    }
    cls create obj
    rename [info object namespace obj]::my ::objmy
    rename obj {}
    lappend result [info commands ::objmy]
} -match glob -result {0 ok *::state localcmdexists {}}
test oo-3.5 {basic test of OO functionality: destructor: evil case for Itcl} -setup {
    oo::class create cls
    set result {}
} -cleanup {
    cls destroy
} -body {
    oo::define cls {
	variable state
	constructor {} {
	    proc localcmdexists {} {}
	    set state ok
	}
	forward Report lappend ::result
	destructor {
	    objmy Report [catch {set state} msg] $msg
	    objmy Report [namespace which -var state]
	    objmy Report [info commands localcmdexists]
	}
    }
    cls create obj
    rename [info object namespace obj]::my ::objmy
    namespace delete [info object namespace obj]
    lappend result [info commands ::objmy]
} -match glob -result {0 ok *::state localcmdexists {}}
test oo-3.5a {basic test of OO functionality: destructor: evil case for Itcl} -setup {
    oo::class create cls
    set result {}
} -cleanup {
    cls destroy
} -body {
    oo::define cls {
	variable state result
	constructor {} {
	    proc localcmdexists {} {}
	    set state ok
	    my eval {upvar 0 ::result result}
	}
	method nuke {} {
	    namespace delete [namespace current]
	    return $result
	}
	destructor {
	    lappend result [self] $state [info commands localcmdexists]
	}
    }
    cls create obj
    namespace delete [info object namespace obj]
    [cls create obj2] nuke
} -match glob -result {::obj ok localcmdexists ::obj2 ok localcmdexists}
test oo-3.6 {basic test of OO functionality: errors in destructor} -setup {
    oo::class create cls
} -cleanup {
    cls destroy
} -body {
    oo::define cls destructor {error foo}
    list [catch {[cls create obj] destroy} msg] $msg [info commands obj]
} -result {1 foo {}}
test oo-3.7 {basic test of OO functionality: errors in destructor} -setup {
    oo::class create cls
    set result {}
    proc bgerror msg {lappend ::result $msg}
} -cleanup {
    cls destroy
    rename bgerror {}
} -body {
    oo::define cls destructor {error foo}
    list [rename [cls create obj] {}] \
	[update idletasks] $result [info commands obj]
} -result {{} {} foo {}}
test oo-3.8 {basic test of OO functionality: errors in destructor} -setup {
    oo::class create cls
    set result {}
    proc bgerror msg {lappend ::result $msg}
} -cleanup {
    cls destroy
    rename bgerror {}
} -body {
    oo::define cls destructor {error foo}
    list [namespace delete [info object namespace [cls create obj]]] \
	[update idletasks] $result [info commands obj]
} -result {{} {} foo {}}
test oo-3.9 {Bug 2944404: deleting the object in the destructor} -setup {
    oo::class create cls
    set result {}
} -body {
    oo::define cls {
	destructor {
	    lappend ::result in destructor
	    [self] destroy
	}
    }
    # This used to crash
    [cls new] destroy
    return $result
} -cleanup {
    cls destroy
} -result {in destructor}

test oo-4.1 {basic test of OO functionality: export} {
    set o [oo::object new]
    set result {}
    oo::objdefine $o method Foo {} {lappend ::result Foo; return}
    lappend result [catch {$o Foo} msg] $msg
    oo::objdefine $o export Foo

    info object
} -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?arg ...?\""
test oo-16.2 {OO: object introspection} -body {
    info object class NOTANOBJECT
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
test oo-16.3 {OO: object introspection} -body {
    info object gorp oo::object
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
test oo-16.4 {OO: object introspection} -setup {
    oo::class create meta { superclass oo::class }
    [meta create instance1] create instance2
} -body {
    list [list [info object class oo::object] \
	      [info object class oo::class] \
	      [info object class meta] \

    lappend result [info object methods foo] [foo destroy]
} {{} bar {}}
test oo-16.7 {OO: object introspection} -setup {
    oo::object create foo
} -body {
    oo::objdefine foo method bar {a {b c} args} {the body}
    set result [info object methods foo]
    lappend result [info object methodtype foo bar] \
	[info object definition foo bar]
} -cleanup {
    foo destroy
} -result {bar method {{a {b c} args} {the body}}}
test oo-16.8 {OO: object introspection} {
    oo::object create foo
    oo::class create bar
    oo::objdefine foo mixin bar
    set result [list [info object mixins foo] \
		    [info object isa mixin foo bar] \
		    [info object isa mixin foo oo::class]]

} -body {
    info class superclass foo
} -returnCodes 1 -cleanup {
    foo destroy
} -result {"foo" is not a class}
test oo-17.4 {OO: class introspection} -body {
    info class gorp oo::object
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
test oo-17.5 {OO: class introspection} -setup {
    oo::class create testClass
} -body {
    testClass create foo
    testClass create bar
    testClass create spong
    lsort [info class instances testClass]
} -cleanup {
    testClass destroy
} -result {::bar ::foo ::spong}
test oo-17.6 {OO: class introspection} -setup {
    oo::class create foo
} -body {
    oo::define foo method bar {a {b c} args} {the body}
    set result [info class methods foo]
    lappend result [info class methodtype foo bar] \
	[info class definition foo bar]
} -cleanup {
    foo destroy
} -result {bar method {{a {b c} args} {the body}}}
test oo-17.7 {OO: class introspection} {
    info class superclasses oo::class
} ::oo::object
test oo-17.8 {OO: class introspection} -setup {
    oo::class create testClass
    oo::class create superClass1
    oo::class create superClass2

	}]
    }
    lappend result [inst eval set x 0]
} -cleanup {
    inst destroy
    rename foo {}
} -result {{x {} write} ok ok 0}
test oo-19.2 {OO: varname method: Bug 2883857} -setup {
    oo::class create SpecialClass
    oo::objdefine SpecialClass export createWithNamespace
    SpecialClass createWithNamespace inst ::oo_test
    oo::objdefine inst export varname eval
} -body {
    inst eval { variable x; array set x {y z} }
    inst varname x(y)
} -cleanup {
    SpecialClass destroy
} -result ::oo_test::x(y)

test oo-20.1 {OO: variable method} -body {
    oo::class create testClass {
	constructor {} {
	    my variable ok
	    set ok {}
	}

    foo destroy
} -body {
    oo::objdefine foo method demo {} {
	my variable
    }
    foo demo
} -result {}
test oo-20.13 {OO: variable method use in non-methods [Bug 2903811]} -setup {
    oo::object create fooObj
    oo::objdefine fooObj export variable
} -cleanup {
    fooObj destroy
} -body {
    apply {{} {fooObj variable x; set x ok; return}}
    apply {{} {fooObj variable x; return $x}}
} -result ok
test oo-20.14 {OO: variable method use in non-methods [Bug 2903811]} -setup {
    oo::object create fooObj
    oo::objdefine fooObj export variable
    namespace eval ns1 {}
    namespace eval ns2 {}
    set x bad
} -cleanup {
    fooObj destroy
    namespace delete ns1 ns2
    unset x
} -body {
    namespace eval ns1 {fooObj variable x; set x ok; subst ""}
    set x bad
    namespace eval ns2 {fooObj variable x; return $x}
} -result ok
test oo-20.15 {OO: variable method use in non-methods [Bug 2903811]} -setup {
    oo::object create fooObj
    oo::objdefine fooObj export variable varname
} -cleanup {
    fooObj destroy
} -body {
    apply {{} {fooObj variable x; set x ok; return}}
    return [set [fooObj varname x]]
} -result ok
test oo-20.16 {variable method: leak per instance} -setup {
    oo::class create foo
} -constraints memory -body {
    oo::define foo {
	constructor {} {
	    set [my variable v] 0
	}
    }
    leaktest {[foo new] destroy}
} -cleanup {
    foo destroy
} -result 0

test oo-21.1 {OO: inheritance ordering} -setup {
    oo::class create A
} -body {
    oo::define A method m {} {lappend ::result A}
    oo::class create B {
	superclass A

	method level {} {
	    expr {[next] - [info frame]}
	}
    }
    list [i level] [i frames] [dict get [c frame] object]
} -cleanup {
    c destroy
} -result {1 {{type source line * file * cmd {info frame 0} method frames class ::c level 0} {type source line * file * cmd {info frame 0} method frames object ::i level 0}} ::c}

# Prove that the issue in [Bug 1865054] isn't an issue any more
test oo-23.1 {Self-like derivation; complex case!} -setup {
    oo::class create SELF {
	superclass oo::class
	unexport create new
	# Next is just a convenience

    inst1 step
    inst2 step
    inst1 step
    inst2 step
    inst1 step
    list [inst1 value] [inst2 value]
} -result {3 2}
test oo-27.12 {variables declaration: leak per instance} -setup {
    oo::class create foo
} -constraints memory -body {
    oo::define foo {
	variable v
	constructor {} {
	    set v 0
	}
    }
    leaktest {[foo new] destroy}
} -cleanup {
    foo destroy
} -result 0

# A feature that's not supported because the mechanism may change without
# warning, but is supposed to work...
test oo-28.1 {scripted extensions to oo::define} -setup {
    interp create foo
    foo eval {oo::class create cls {export eval}}
} -cleanup {

    oo::objdefine obj method demo {} {
	self class
    }
    obj demo
} -returnCodes error -cleanup {
    obj destroy
} -result {method not defined by a class}

test oo-30.1 {Bug 2903011: deleting an object in a constructor} -setup {
    oo::class create cls
} -body {
    oo::define cls {constructor {} {[self] destroy}}
    cls new
} -returnCodes error -cleanup {
    cls destroy
} -result {object deleted in constructor}
test oo-30.2 {Bug 2903011: deleting an object in a constructor} -setup {
    oo::class create cls
} -body {
    oo::define cls {constructor {} {my destroy}}
    cls new
} -returnCodes error -cleanup {
    cls destroy
} -result {object deleted in constructor}

cleanupTests
return

# Local Variables:
# mode: tcl
# End:

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

catch {unset foo}

testConstraint exec [llength [info commands exec]]

test regexp-1.1 {basic regexp operation} {
    regexp ab*c abbbc
} 1
test regexp-1.2 {basic regexp operation} {
    regexp ab*c ac
} 1
test regexp-1.3 {basic regexp operation} {

} {0 1}
test regexp-1.7 {regexp utf compliance} {
    # if not UTF-8 aware, result is "0 1"
    set foo "\u4e4eb q"
    regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar
    list [string compare $foo $bar] [regexp 4 $bar]
} {0 0}

test regexp-1.8 {regexp ***= metasyntax} {
    regexp -- "***=o" "aeiou"
} 1
test regexp-1.9 {regexp ***= metasyntax} {
    set string "aeiou"
    regexp -- "***=o" $string
} 1

    list [regexp f\352te(b*)c f\352tebbbbc foo f2] $foo $f2
} [list 1 f\352tebbbbc bbbb]
test regexp-2.10 {getting substrings back from regexp} {
    set foo {}
    set f2 {}
    list [regexp f\352te(b*)c eff\352tebbbbc foo f2] $foo $f2
} [list 1 f\352tebbbbc bbbb]
test regexp-2.11 {non-capturing subgroup} {
    set foo {}
    set f2 {}
    list [regexp {str(?:a+)} straa foo f2] $foo $f2
} [list 1 straa {}]
test regexp-2.12 {non-capturing subgroup with -inline} {
    regexp -inline {str(?:a+)} straa
} {straa}
test regexp-2.13 {non-capturing and capturing subgroups} {
    set foo {}
    set f2 {}
    set f3 {}
    list [regexp {str(?:a+)(c+)} straacc foo f2 f3] $foo $f2 $f3
} [list 1 straacc cc {}]
test regexp-2.14 {non-capturing and capturing subgroups} {
    regexp -inline {str(?:a+)(c+)} straacc
} {straacc cc}
test regexp-2.15 {getting substrings back from regexp} {
    set foo NA
    set f2 NA
    list [regexp {str(?:a+)} straa foo f2] $foo $f2
} [list 1 straa {}]

test regexp-3.1 {-indices option to regexp} {
    set foo {}
    list [regexp -indices ab*c abbbbc foo] $foo
} {1 {0 5}}
test regexp-3.2 {-indices option to regexp} {
    set foo {}

    catch {unset f1}
    set f1 44
    list [catch {regexp abc abc f1(f2)} msg] $msg
} {1 {couldn't set variable "f1(f2)"}}
test regexp-6.9 {regexp errors, -start bad int check} {
    list [catch {regexp -start bogus {^$} {}} msg] $msg
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
test regexp-6.10 {regexp errors} {
    list [catch {regexp {a[} b} msg] $msg
} {1 {couldn't compile regular expression pattern: brackets [] not balanced}}

test regexp-7.1 {basic regsub operation} {
    list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
} {1 xax111aaa222xaa}
test regexp-7.2 {basic regsub operation} {
    list [regsub aa+ aaaxaa &111 foo] $foo
} {1 aaa111xaa}

} {0 {}}
test regexp-7.17 {regsub utf compliance} {
    # if not UTF-8 aware, result is "0 1"
    set foo "xyz555ijka\u4e4ebpqr"
    regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar
    list [string compare $foo $bar] [regexp 4 $bar]
} {0 0}
test regexp-7.18 {basic regsub replacement} {
    list [regsub a+ aaa {&} foo] $foo
} {1 aaa}
test regexp-7.19 {basic regsub replacement} {
    list [regsub a+ aaa {\&} foo] $foo
} {1 &}
test regexp-7.20 {basic regsub replacement} {
    list [regsub a+ aaa {\\&} foo] $foo
} {1 {\aaa}}
test regexp-7.21 {basic regsub replacement} {
    list [regsub a+ aaa {\\\&} foo] $foo
} {1 {\&}}
test regexp-7.22 {basic regsub replacement} {
    list [regsub a+ aaa {\0} foo] $foo
} {1 aaa}
test regexp-7.23 {basic regsub replacement} {
    list [regsub a+ aaa {\\0} foo] $foo
} {1 {\0}}
test regexp-7.24 {basic regsub replacement} {
    list [regsub a+ aaa {\\\0} foo] $foo
} {1 {\aaa}}
test regexp-7.25 {basic regsub replacement} {
    list [regsub a+ aaa {\\\\0} foo] $foo
} {1 {\\0}}
test regexp-7.26 {dollar zero is not a backslash replacement} {
    list [regsub a+ aaa {$0} foo] $foo
} {1 {$0}}
test regexp-7.27 {dollar zero is not a backslash replacement} {
    list [regsub a+ aaa {\0$0} foo] $foo
} {1 {aaa$0}}
test regexp-7.28 {dollar zero is not a backslash replacement} {
    list [regsub a+ aaa {\$0} foo] $foo
} {1 {\$0}}
test regexp-7.29 {dollar zero is not a backslash replacement} {
    list [regsub a+ aaa {\\} foo] $foo
} {1 \\}

test regexp-8.1 {case conversion in regsub} {
    list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
} {1 xaAAaAAay}
test regexp-8.2 {case conversion in regsub} {
    list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
} {1 xaAAaAAay}

# 8.2.3 regexp reduced stack space requirements, but this should be
# tested again
test regexp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} {
    list [regexp (.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) abcdefghijklmnopqrstuvwxyz all a b c d e f g h i j k l m n o p q r s t u v w x y z] $all $a $b $c $d $e $f $g $h $i $j $k $l $m $n $o $p $q $r $s $t $u $v $w $x $y $z
} {1 abcdefghijklmnopqrstuvwxyz a b c d e f g h i j k l m n o p q r s t u v w x y z}

test regexp-13.1 {regsub of a very large string} {
    # This test is designed to stress the memory subsystem in order to catch
    # Bug #933.  It only fails if the Tcl memory allocator is in use.


    set line {BEGIN_TABLE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END_TABLE}
    set filedata [string repeat $line 200]
    for {set i 1} {$i<10} {incr i} {
	regsub -all "BEGIN_TABLE " $filedata "" newfiledata
    }
    set x done
} {done}

    regexp .*c d
    regexp .*d e
    regexp .*e f
    set x .
    append x *a
    regexp -nocase $x bbba
} 1


test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} -constraints {
    exec
} -setup {
    set junk [makeFile {puts [regexp {} foo]} junk.tcl]
} -body {
    exec [interpreter] $junk
} -cleanup {
    removeFile junk.tcl
} -result 1

    catch {unset x}
    list [regexp -start end {\d} 1abc2de3 x] [info exists x]
} {0 0}
test regexp-15.10 {regexp -start, end relative index} {
    catch {unset x}
    list [regexp -start end-1 {\d} 1abc2de3 x] [info exists x] $x
} {1 1 3}
test regexp-15.11 {regexp -start, over end of string} {
    set x NA
    list [regexp -start 2 {.*} ab x] $x
} {1 {}}

test regexp-16.1 {regsub -start} {
    catch {unset x}
    list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
} {4 a1b/2c/3d/4e/5}
test regexp-16.2 {regsub -start} {
    catch {unset x}

} {0 abc}
test regexp-16.7 {regexp -start, end relative index} {
    list [regsub -start end a aaa b x] $x
} {0 aaa}
test regexp-16.8 {regexp -start, end relative index} {
    list [regsub -start end-1 a aaa b x] $x
} {1 aab}
test regexp-16.9 {regsub -start and -all} {
    set foo {}
    list [regsub -start 0 -all x+ axxxbxx |&| foo] $foo
} {2 a|xxx|b|xx|}
test regexp-16.10 {regsub -start and -all} {
    set foo {}
    list [regsub -start 1 -all x+ axxxbxx |&| foo] $foo
} {2 a|xxx|b|xx|}
test regexp-16.11 {regsub -start and -all} {
    set foo {}
    list [regsub -start 4 -all x+ axxxbxx |&| foo] $foo
} {1 axxxb|xx|}
test regexp-16.12 {regsub -start} {
    set foo {}
    list [regsub -start 4 x+ axxxbxx |&| foo] $foo
} {1 axxxb|xx|}
test regexp-16.13 {regsub -start and -all} {
    set foo {}
    list [regsub -start 1 -all a+ "" & foo] $foo
} {0 {}}
test regexp-16.14 {regsub -start} {
    set foo {}
    list [regsub -start 1 a+ "" & foo] $foo
} {0 {}}
test regexp-16.15 {regsub -start and -all} {
    set foo {}
    list [regsub -start 2 -all a+ "xy" & foo] $foo
} {0 xy}
test regexp-16.16 {regsub -start} {
    set foo {}
    list [regsub -start 2 a+ "xy" & foo] $foo
} {0 xy}
test regexp-16.17 {regsub -start and -all} {
    set foo {}
    list [regsub -start 1 -all y+ "xy" & foo] $foo
} {1 xy}
test regexp-16.18 {regsub -start} {
    set foo {}
    list [regsub -start 1 y+ "xy" & foo] $foo
} {1 xy}
test regexp-16.19 {regsub -start} {
    set foo {}
    list [regsub -start -1 a+ "" & foo] $foo
} {0 {}}
test regexp-16.20 {regsub -start, loss of ^$ behavior} {
    set foo NA
    list [regsub -start 1 {^$} {} & foo] $foo
} {0 {}}
test regexp-16.21 {regsub -start, loss of ^$ behavior} {
    set foo NA
    list [regsub -start 1 {^.*$} abc & foo] $foo
} {0 abc}
test regexp-16.22 {regsub -start, loss of ^$ behavior} {
    set foo NA
    list [regsub -all -start 1 {^.*$} abc & foo] $foo
} {0 abc}

test regexp-17.1 {regexp -inline} {
    regexp -inline b ababa
} {b}
test regexp-17.2 {regexp -inline} {
    regexp -inline (b) ababa
} {b b}

    regexp -all -inline -indices a(b(c)d|e(f)g)h abcdhaefgh
} {{0 4} {1 3} {2 2} {-1 -1} {5 9} {6 8} {-1 -1} {7 7}}

test regexp-19.1 {regsub null replacement} {
    regsub -all {@} {@hel@lo@} "\0a\0" result
    list $result [string length $result]
} "\0a\0hel\0a\0lo\0a\0 14"

test regexp-19.2 {regsub null replacement} {
    regsub -all {@} {@hel@lo@} "\0a\0" result
    set expected "\0a\0hel\0a\0lo\0a\0"
    string equal $result $expected
} 1

test regexp-20.1 {regsub shared object shimmering} {
    # Bug #461322
    set a abcdefghijklmnopqurstuvwxyz 
    set b $a 
    set c abcdefghijklmnopqurstuvwxyz0123456789 
    regsub $a $c $b d 
    list $d [string length $d] [string bytelength $d]
} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
test regexp-20.2 {regsub shared object shimmering with -about} {
    eval regexp -about abc
} {0 {}}

test regexp-21.1 {regsub works with empty string} {
    regsub -- ^ {} foo
} {foo}

test regexp-21.2 {regsub works with empty string} {
    regsub -- \$ {} foo
} {foo}

test regexp-21.3 {regsub works with empty string offset} {
    regsub -start 0 -- ^ {} foo
} {foo}

test regexp-21.4 {regsub works with empty string offset} {
    regsub -start 0 -- \$ {} foo
} {foo}

test regexp-21.5 {regsub works with empty string offset} {
    regsub -start 3 -- \$ {123} foo
} {123foo}

test regexp-21.6 {regexp works with empty string} {
    regexp -- ^ {}
} {1}

test regexp-21.7 {regexp works with empty string} {
    regexp -start 0 -- ^ {}
} {1}

test regexp-21.8 {regexp works with empty string offset} {
    regexp -start 3 -- ^ {123}
} {0}

test regexp-21.9 {regexp works with empty string offset} {
    regexp -start 3 -- \$ {123}
} {1}

test regexp-21.10 {multiple matches handle newlines} {
    regsub -all -lineanchor -- {^#[^\n]*\n} "#one\n#two\n#three\n" foo\n
} "foo\nfoo\nfoo\n"

test regexp-21.11 {multiple matches handle newlines} {
    regsub -all -line -- ^ "a\nb\nc" \#
} "\#a\n\#b\n\#c"

test regexp-21.12 {multiple matches handle newlines} {
    regsub -all -line -- ^ "\n\n" \#
} "\#\n\#\n\#"

test regexp-21.13 {multiple matches handle newlines} {
    regexp -all -inline -indices -line -- ^ "a\nb\nc"
} {{0 -1} {2 1} {4 3}}
test regexp-21.14 {regsub works with empty string} {
    regsub -- ^ {} &
} {}
test regexp-21.15 {regsub works with empty string} {
    regsub -- ^ {} foo&
} {foo}
test regexp-21.16 {regsub works with empty string} {
    regsub -all -- ^ {} foo&
} {foo}
test regexp-21.17 {regsub works with empty string} {
    regsub -- ^ {} {foo\0}
} {foo}
test regexp-21.18 {regsub works with empty string} {
    regsub -- ^.* {} {foo$0}
} {foo$0}
test regexp-21.19 {regsub works with empty string} {
    regsub -- ^ {input} {}
} {input}
test regexp-21.20 {regsub works with empty string} {
    regsub -- x {} {foo}
} {}

test regexp-22.1 {Bug 1810038} {
    regexp ($|^X)* {}
} 1

test regexp-22.2 {regexp compile and backrefs, Bug 1857126} {
    regexp -- {([bc])\1} bb
} 1

test regexp-23.1 {regexp -all and -line} {
    set string ""
    list \
	[regexp -all -inline -indices -line -- {^} $string] \
	[regexp -all -inline -indices -line -- {^$} $string] \
	[regexp -all -inline -indices -line -- {$} $string]
} {{{0 -1}} {{0 -1}} {{0 -1}}}
test regexp-23.2 {regexp -all and -line} {
    set string "\n"
    list \
	[regexp -all -inline -indices -line -- {^} $string] \
	[regexp -all -inline -indices -line -- {^$} $string] \
	[regexp -all -inline -indices -line -- {$} $string]
} {{{0 -1}} {{0 -1}} {{0 -1}}}
test regexp-23.3 {regexp -all and -line} {
    set string "\n\n"
    list \
	[regexp -all -inline -indices -line -- {^} $string] \
	[regexp -all -inline -indices -line -- {^$} $string] \
	[regexp -all -inline -indices -line -- {$} $string]
} {{{0 -1} {1 0}} {{0 -1} {1 0}} {{0 -1} {1 0}}}
test regexp-23.4 {regexp -all and -line} {
    set string "a"
    list \
	[regexp -all -inline -indices -line -- {^} $string] \
	[regexp -all -inline -indices -line -- {^.*$} $string] \
	[regexp -all -inline -indices -line -- {$} $string]
} {{{0 -1}} {{0 0}} {{1 0}}}
test regexp-23.5 {regexp -all and -line} {knownBug} {
    set string "a\n"
    list \
	[regexp -all -inline -indices -line -- {^} $string] \
	[regexp -all -inline -indices -line -- {^.*$} $string] \
	[regexp -all -inline -indices -line -- {$} $string]
} {{{0 -1} {2 1}} {{0 0} {2 1}} {{1 0} {2 1}}}
test regexp-23.6 {regexp -all and -line} {
    set string "\na"
    list \
	[regexp -all -inline -indices -line -- {^} $string] \
	[regexp -all -inline -indices -line -- {^.*$} $string] \
	[regexp -all -inline -indices -line -- {$} $string]
} {{{0 -1} {1 0}} {{0 -1} {1 1}} {{0 -1} {2 1}}}
test regexp-23.7 {regexp -all and -line} {knownBug} {
    set string "ab\n"
    list \
	[regexp -all -inline -indices -line -- {^} $string] \
	[regexp -all -inline -indices -line -- {^.*$} $string] \
	[regexp -all -inline -indices -line -- {$} $string]
} {{{0 -1} {3 2}} {{0 1} {3 2}} {{2 1} {3 2}}}
test regexp-23.8 {regexp -all and -line} {
    set string "a\nb"
    list \
	[regexp -all -inline -indices -line -- {^} $string] \
	[regexp -all -inline -indices -line -- {^.*$} $string] \
	[regexp -all -inline -indices -line -- {$} $string]
} {{{0 -1} {2 1}} {{0 0} {2 2}} {{1 0} {3 2}}}
test regexp-23.9 {regexp -all and -line} {knownBug} {
    set string "a\nb\n"
    list \
	[regexp -all -inline -indices -line -- {^} $string] \
	[regexp -all -inline -indices -line -- {^.*$} $string] \
	[regexp -all -inline -indices -line -- {$} $string]
} {{{0 -1} {2 1} {4 3}} {{0 0} {2 2} {4 3}} {{1 0} {3 2} {4 3}}}
test regexp-23.10 {regexp -all and -line} {
    set string "a\nb\nc"
    list \
	[regexp -all -inline -indices -line -- {^} $string] \
	[regexp -all -inline -indices -line -- {^.*$} $string] \
	[regexp -all -inline -indices -line -- {$} $string]
} {{{0 -1} {2 1} {4 3}} {{0 0} {2 2} {4 4}} {{1 0} {3 2} {5 4}}}
test regexp-23.11 {regexp -all and -line} {
    regexp -all -inline -indices -line -- {b} "abb\nb"
} {{1 1} {2 2} {4 4}}

test regexp-24.1 {regsub -all and -line} {
    foreach {v1 v2 v3} {{} {} {}} {}
    set string ""
    list \
	[regsub -line -all {^} $string {<&>} v1] $v1 \
	[regsub -line -all {^$} $string {<&>} v2] $v2 \
	[regsub -line -all {$} $string {<&>} v3] $v3
} {1 <> 1 <> 1 <>}
test regexp-24.2 {regsub -all and -line} {
    foreach {v1 v2 v3} {{} {} {}} {}
    set string "\n"
    list \
	[regsub -line -all {^} $string {<&>} v1] $v1 \
	[regsub -line -all {^$} $string {<&>} v2] $v2 \
	[regsub -line -all {$} $string {<&>} v3] $v3
} [list 2 "<>\n<>" 2 "<>\n<>" 2 "<>\n<>"]
test regexp-24.3 {regsub -all and -line} {
    foreach {v1 v2 v3} {{} {} {}} {}
    set string "\n\n"
    list \
	[regsub -line -all {^} $string {<&>} v1] $v1 \
	[regsub -line -all {^$} $string {<&>} v2] $v2 \
	[regsub -line -all {$} $string {<&>} v3] $v3
} [list 3 "<>\n<>\n<>" 3 "<>\n<>\n<>" 3 "<>\n<>\n<>"]
test regexp-24.4 {regsub -all and -line} {
    foreach {v1 v2 v3} {{} {} {}} {}
    set string "a"
    list \
	[regsub -line -all {^} $string {<&>} v1] $v1 \
	[regsub -line -all {^.*$} $string {<&>} v2] $v2 \
	[regsub -line -all {$} $string {<&>} v3] $v3
} [list 1 "<>a" 1 "<a>" 1 "a<>"]
test regexp-24.5 {regsub -all and -line} {
    foreach {v1 v2 v3} {{} {} {}} {}
    set string "a\n"
    list \
	[regsub -line -all {^} $string {<&>} v1] $v1 \
	[regsub -line -all {^.*$} $string {<&>} v2] $v2 \
	[regsub -line -all {$} $string {<&>} v3] $v3
} [list 2 "<>a\n<>" 2 "<a>\n<>" 2 "a<>\n<>"]
test regexp-24.6 {regsub -all and -line} {
    foreach {v1 v2 v3} {{} {} {}} {}
    set string "\na"
    list \
	[regsub -line -all {^} $string {<&>} v1] $v1 \
	[regsub -line -all {^.*$} $string {<&>} v2] $v2 \
	[regsub -line -all {$} $string {<&>} v3] $v3
} [list 2 "<>\n<>a" 2 "<>\n<a>" 2 "<>\na<>"]
test regexp-24.7 {regsub -all and -line} {
    foreach {v1 v2 v3} {{} {} {}} {}
    set string "ab\n"
    list \
	[regsub -line -all {^} $string {<&>} v1] $v1 \
	[regsub -line -all {^.*$} $string {<&>} v2] $v2 \
	[regsub -line -all {$} $string {<&>} v3] $v3
} [list 2 "<>ab\n<>" 2 "<ab>\n<>" 2 "ab<>\n<>"]
test regexp-24.8 {regsub -all and -line} {
    foreach {v1 v2 v3} {{} {} {}} {}
    set string "a\nb"
    list \
	[regsub -line -all {^} $string {<&>} v1] $v1 \
	[regsub -line -all {^.*$} $string {<&>} v2] $v2 \
	[regsub -line -all {$} $string {<&>} v3] $v3
} [list 2 "<>a\n<>b" 2 "<a>\n<b>" 2 "a<>\nb<>"]
test regexp-24.9 {regsub -all and -line} {
    foreach {v1 v2 v3} {{} {} {}} {}
    set string "a\nb\n"
    list \
	[regsub -line -all {^} $string {<&>} v1] $v1 \
	[regsub -line -all {^.*$} $string {<&>} v2] $v2 \
	[regsub -line -all {$} $string {<&>} v3] $v3
} [list 3 "<>a\n<>b\n<>" 3 "<a>\n<b>\n<>" 3 "a<>\nb<>\n<>"]
test regexp-24.10 {regsub -all and -line} {
    foreach {v1 v2 v3} {{} {} {}} {}
    set string "a\nb\nc"
    list \
	[regsub -line -all {^} $string {<&>} v1] $v1 \
	[regsub -line -all {^.*$} $string {<&>} v2] $v2 \
	[regsub -line -all {$} $string {<&>} v3] $v3
} [list 3 "<>a\n<>b\n<>c" 3 "<a>\n<b>\n<c>" 3 "a<>\nb<>\nc<>"]
test regexp-24.11 {regsub -all and -line} {
    regsub -line -all {b} "abb\nb" {<&>}
} "a<b><b>\n<b>"

test regexp-25.1 {regexp without -line option} {
    set foo ""
    list [regexp {a.*b} "dabc\naxyb\n" foo] $foo
} [list 1 abc\naxyb]
test regexp-25.2 {regexp without -line option} {
    set foo ""
    list [regexp {^a.*b$} "dabc\naxyb\n" foo] $foo
} {0 {}}
test regexp-25.3 {regexp with -line option} {
    set foo ""
    list [regexp -line {^a.*b$} "dabc\naxyb\n" foo] $foo
} {1 axyb}
test regexp-25.4 {regexp with -line option} {
    set foo ""
    list [regexp -line {^a.*b$} "dabc\naxyb\nxb" foo] $foo
} {1 axyb}
test regexp-25.5 {regexp without -line option} {
    set foo ""
    list [regexp {^a.*b$} "dabc\naxyb\nxb" foo] $foo
} {0 {}}
test regexp-25.6 {regexp without -line option} {
    set foo ""
    list [regexp {a.*b$} "dabc\naxyb\nxb" foo] $foo
} "1 {abc\naxyb\nxb}"
test regexp-25.7 {regexp with -lineanchor option} {
    set foo ""
    list [regexp -lineanchor {^a.*b$} "dabc\naxyb\nxb" foo] $foo
} "1 {axyb\nxb}"
test regexp-25.8 {regexp with -lineanchor and -linestop option} {
    set foo ""
    list [regexp -lineanchor -linestop {^a.*b$} "dabc\naxyb\nxb" foo] $foo
} {1 axyb}
test regexp-25.9 {regexp with -linestop option} {
    set foo ""
    list [regexp -linestop {a.*b} "ab\naxyb\nxb" foo] $foo
} {1 ab}

test regexp-26.1 {matches start of line 1 time} {
    regexp -all -inline -- {^a+} "aab\naaa"
} {aa}
test regexp-26.2 {matches start of line(s) 2 times} {
    regexp -all -inline -line -- {^a+} "aab\naaa"
} {aa aaa}
test regexp-26.3 {effect of -line -all and -start} {
    list \
	[regexp -all -inline -line -start 0 -- {^a+} "aab\naaa"] \
	[regexp -all -inline -line -start 1 -- {^a+} "aab\naaa"] \
	[regexp -all -inline -line -start 3 -- {^a+} "aab\naaa"] \
	[regexp -all -inline -line -start 4 -- {^a+} "aab\naaa"] \
} {{aa aaa} aaa aaa aaa}
# No regexp-26.4
test regexp-26.5 {match length 0, match length 1} {
    regexp -all -inline -line -- {^b*} "a\nb"
} {{} b}
test regexp-26.6 {non reporting capture group} {
    regexp -all -inline -line -- {^(?:a+|b)} "aab\naaa"
} {aa aaa}
test regexp-26.7 {Tcl bug 2826551: -line sensitive regexp and -start} {
    set match1 {}
    set match2 {}
    list \
	[regexp -start 0 -indices -line {^a} "\nab" match1] $match1 \
	[regexp -start 1 -indices -line {^a} "\nab" match2] $match2
} {1 {1 1} 1 {1 1}}
test regexp-26.8 {Tcl bug 2826551: diff regexp with -line option} {
    set data "@1\n2\n+3\n@4\n-5\n+6\n7\n@8\n9\n"
    regexp -all -inline -line {^@.*\n(?:[^@].*\n?)*} $data
} [list "@1\n2\n+3\n" "@4\n-5\n+6\n7\n" "@8\n9\n"]
test regexp-26.9 {Tcl bug 2826551: diff regexp with embedded -line option} {
    set data "@1\n2\n+3\n@4\n-5\n+6\n7\n@8\n9\n"
    regexp -all -inline {(?n)^@.*\n(?:[^@].*\n?)*} $data
} [list "@1\n2\n+3\n" "@4\n-5\n+6\n7\n" "@8\n9\n"]
test regexp-26.10 {regexp with -line option} {
    regexp -all -inline -line -- {a*} "a\n"
} {a {}}
test regexp-26.11 {regexp without -line option} {
    regexp -all -inline -- {a*} "a\n"
} {a {}}
test regexp-26.12 {regexp with -line option} {
    regexp -all -inline -line -- {a*} "b\n"
} {{} {}}
test regexp-26.13 {regexp without -line option} {
    regexp -all -inline -- {a*} "b\n"
} {{} {}}

# cleanup
::tcltest::cleanupTests
return

}

# determine the current locale
testConstraint english [expr {
    [llength [info commands testlocale]]
    && [string match "English*" [testlocale all ""]]
}]

test registry-1.1 {argument parsing for registry command} {win reg} {
    list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1b {argument parsing for registry command} {win reg} {
    list [catch {registry -64bit} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.2 {argument parsing for registry command} {win reg} {
    list [catch {registry foo} msg] $msg
} {1 {bad option "foo": must be broadcast, delete, get, keys, set, type, or values}}
test registry-1.2a {argument parsing for registry command} {win reg} {
    list [catch {registry -33bit foo} msg] $msg
} {1 {bad mode "-33bit": must be -32bit or -64bit}}

test registry-1.3 {argument parsing for registry command} {win reg} {
    list [catch {registry d} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
test registry-1.3a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit d} msg] $msg
} {1 {wrong # args: should be "registry -32bit delete keyName ?valueName?"}}
test registry-1.3b {argument parsing for registry command} {win reg} {
    list [catch {registry -64bit d} msg] $msg
} {1 {wrong # args: should be "registry -64bit delete keyName ?valueName?"}}
test registry-1.4 {argument parsing for registry command} {win reg} {
    list [catch {registry delete} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
test registry-1.5 {argument parsing for registry command} {win reg} {
    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} {win reg} {
    list [catch {registry g} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}
test registry-1.6a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit g} msg] $msg
} {1 {wrong # args: should be "registry -32bit get keyName valueName"}}
test registry-1.6b {argument parsing for registry command} {win reg} {
    list [catch {registry -64bit g} msg] $msg
} {1 {wrong # args: should be "registry -64bit get keyName valueName"}}
test registry-1.7 {argument parsing for registry command} {win reg} {
    list [catch {registry get} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}
test registry-1.8 {argument parsing for registry command} {win reg} {
    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} {win reg} {
    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} {win reg} {
    list [catch {registry k} msg] $msg
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}
test registry-1.10a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit k} msg] $msg
} {1 {wrong # args: should be "registry -32bit keys keyName ?pattern?"}}
test registry-1.10b {argument parsing for registry command} {win reg} {
    list [catch {registry -64bit k} msg] $msg
} {1 {wrong # args: should be "registry -64bit keys keyName ?pattern?"}}
test registry-1.11 {argument parsing for registry command} {win reg} {
    list [catch {registry keys} msg] $msg
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}
test registry-1.12 {argument parsing for registry command} {win reg} {
    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} {win reg} {
    list [catch {registry s} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
test registry-1.13a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit s} msg] $msg
} {1 {wrong # args: should be "registry -32bit set keyName ?valueName data ?type??"}}
test registry-1.13b {argument parsing for registry command} {win reg} {
    list [catch {registry -64bit s} msg] $msg
} {1 {wrong # args: should be "registry -64bit set keyName ?valueName data ?type??"}}
test registry-1.14 {argument parsing for registry command} {win reg} {
    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} {win reg} {
    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} {win reg} {
    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} {win reg} {
    list [catch {registry t} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}
test registry-1.17a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit t} msg] $msg
} {1 {wrong # args: should be "registry -32bit type keyName valueName"}}
test registry-1.17b {argument parsing for registry command} {win reg} {
    list [catch {registry -64bit t} msg] $msg
} {1 {wrong # args: should be "registry -64bit type keyName valueName"}}
test registry-1.18 {argument parsing for registry command} {win reg} {
    list [catch {registry type} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}
test registry-1.19 {argument parsing for registry command} {win reg} {
    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} {win reg} {
    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} {win reg} {
    list [catch {registry v} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
test registry-1.21a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit v} msg] $msg
} {1 {wrong # args: should be "registry -32bit values keyName ?pattern?"}}
test registry-1.21b {argument parsing for registry command} {win reg} {
    list [catch {registry -64bit v} msg] $msg
} {1 {wrong # args: should be "registry -64bit values keyName ?pattern?"}}
test registry-1.22 {argument parsing for registry command} {win reg} {
    list [catch {registry values} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
test registry-1.23 {argument parsing for registry command} {win reg} {
    list [catch {registry values foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}

        # This test will only succeed if the current user does not have
        # registry access on the specified machine.
        registry set {\\mom\HKEY_CURRENT_USER\TclFoobar} bar foobar
    } -returnCodes error -result {unable to open key: Access is denied.}

test registry-12.1 {BroadcastValue} -constraints {win reg} -body {
    registry broadcast
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
test registry-12.2 {BroadcastValue} -constraints {win reg} -body {
    registry broadcast "" -time
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
test registry-12.3 {BroadcastValue} -constraints {win reg} -body {
    registry broadcast "" - 500
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
test registry-12.4 {BroadcastValue} -constraints {win reg} -body {
    registry broadcast {Environment}
} -result {1 0}
test registry-12.5 {BroadcastValue} -constraints {win reg} -body {
    registry b {}
} -result {1 0}

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# tcl-indent-level: 4
# fill-column: 78
# End:

    if {$VERBOSE} {
	puts "--- Server executing the following for socket $s:"
	puts $l
	puts "---"
    }
    set callerSocket $s
    set ::errorInfo ""
    set code [catch {uplevel "#0" $l} msg]
    return [list $code $::errorInfo $msg]



}

proc __readAndExecute__ {s} {
    global command VERBOSE

    set l [gets $s]
    if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
        puts $s [__doCommands__ $command($s) $s]


	puts $s "--Marker--Marker--Marker--"
        set command($s) ""
	return
    }
    if {[string compare $l ""] == 0} {
	if {[eof $s]} {
	    if {$VERBOSE} {
		puts "Server closing $s, eof from client"
	    }
	    close $s
	}
	return
    }






    if {[eof $s]} {
	if {$VERBOSE} {
	    puts "Server closing $s, eof from client"
	}
	close $s
        unset command($s)
        return
    }
    append command($s) $l "\n"
}

proc __accept__ {s a p} {
    global command VERBOSE

    if {$VERBOSE} {
	puts "Server accepts new connection from $a:$p on $s"
    }
    set command($s) ""
    fconfigure $s -buffering line -translation crlf
    fileevent $s readable [list __readAndExecute__ $s]
}

set serverIsSilent 0
for {set i 0} {$i < $argc} {incr i} {
    if {[string compare -serverIsSilent [lindex $argv $i]] == 0} {
	set serverIsSilent 1
	break

    puts "[info hostname]. You can set these as environment variables"
    puts "from the shell. The tests will not work properly if you set"
    puts "remoteServerIP to \"localhost\" or 127.0.0.1."
    puts ""
    puts -nonewline "Type Ctrl-C to terminate--> "
    flush stdout
}

proc getPort sock {
    lindex [fconfigure $sock -sockname] 2
}

if {[catch {set serverSocket \
	[socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} {
    puts "Server on $serverAddress:$serverPort cannot start: $msg"
} else {
    puts ready
    vwait __server_wait_variable__
}

    set ::errorInfo {}
    set ::errorCode {}
} -body {
    foo
} -cleanup {
    rename foo {}
} -result {foo {} {}}
test result-6.3 {Bug 2383005} {
     catch {return -code error -errorcode {{}a} eek} m
     set m
} {bad -errorcode value: expected a list but got "{}a"}
test result-6.4 {non-list -errorstack} -body {
     catch {return -code error -errorstack {{}a} eek} m o
     list $m [dict get $o -errorcode] [dict get $o -errorstack]
} -match glob -result {{bad -errorstack value: expected a list but got "{}a"} {TCL RESULT NONLIST_ERRORSTACK} {INNER * UP 1}}
test result-6.5 {odd-sized-list -errorstack} -body {
     catch {return -code error -errorstack a eek} m o
     list $m [dict get $o -errorcode] [dict get $o -errorstack]
} -match glob -result {{forbidden odd-sized list for -errorstack: "a"} {TCL RESULT ODDSIZEDLIST_ERRORSTACK} {INNER * UP 1}}
# cleanup
cleanupTests
return

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

proc ignore args {}

# Simple variable operations.

catch {unset a}
test set-old-1.1 {basic variable setting and unsetting} {
    set a 22
} 22
test set-old-1.2 {basic variable setting and unsetting} {

    list [info exists -nocomp] [catch {unset -nocomp}]
} {0 1}

# Array command.

test set-old-8.1 {array command} {
    list [catch {array} msg] $msg
} {1 {wrong # args: should be "array subcommand ?arg ...?"}}
test set-old-8.2 {array command} {
    list [catch {array a} msg] $msg
} {1 {wrong # args: should be "array anymore arrayName searchId"}}
test set-old-8.3 {array command} {
    catch {unset a}
    list [catch {array anymore a b} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.4 {array command} {
    catch {unset a}
    set a 44

    }
    foo
} {1 {"x" isn't an array}}
test set-old-8.6 {array command} {
    catch {unset a}
    set a(22) 3
    list [catch {array gorp a} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, statistics, or unset}}
test set-old-8.7 {array command, anymore option} {
    catch {unset a}
    list [catch {array anymore a x} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} {
    proc foo {x} {
        if {$x==1} {

        }
        set a(x) 123
    }
    list [catch {foo 1} msg] $msg
} {0 0}
test set-old-8.15 {array command, get option} {
    list [catch {array get} msg] $msg
} {1 {wrong # args: should be "array get arrayName ?pattern?"}}
test set-old-8.16 {array command, get option} {
    list [catch {array get a b c} msg] $msg
} {1 {wrong # args: should be "array get arrayName ?pattern?"}}
test set-old-8.17 {array command, get option} {
    catch {unset a}
    array get a
} {}

    catch {unset a}
    set a(-glob) 1
    set a(-regexp) 1
    set a(-exact) 1
    list [catch {array names a -glob} msg] $msg
} {0 -glob}
test set-old-8.56 {array command, array statistics on a non-array} {
    catch {unset a}
    list [catch {array statistics a} msg] $msg
} [list 1 "\"a\" isn't an array"]
test set-old-8.57 {array command, array get with trivial pattern} {
    catch {unset a}
    set a(x) 1
    set a(y) 2
    array get a x
} {x 1}

test set-old-9.1 {ids for array enumeration} {
    catch {unset a}
    set a(a) 1
    list [array star a] [array star a] [array done a s-1-a; array star a] \
	    [array done a s-2-a; array d a s-3-a; array start a]
} {s-1-a s-2-a s-3-a s-1-a}

    trace var a(b) r {}
    set x [array startsearch a]
    lsort [list [array next a $x] [array next a $x]]
} {{} a}

test set-old-10.1 {array enumeration errors} {
    list [catch {array start} msg] $msg
} {1 {wrong # args: should be "array startsearch arrayName"}}
test set-old-10.2 {array enumeration errors} {
    list [catch {array start a b} msg] $msg
} {1 {wrong # args: should be "array startsearch arrayName"}}
test set-old-10.3 {array enumeration errors} {
    catch {unset a}
    list [catch {array start a} msg] $msg
} {1 {"a" isn't an array}}

} 12345
test set-old-12.2 {cleanup on procedure return} {
    proc foo {} {
	set x(1) 23456
    }
    foo
} 23456

# Must delete variables when done, since these arrays get used as
# scalars by other tests.
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset aVaRnAmE}
catch {rename foo {}}

# cleanup
::tcltest::cleanupTests
return 

# Local Variables:
# mode: tcl
# End:

package require tcltest 2
namespace import -force ::tcltest::*

# Some tests require the testthread and exec commands
testConstraint testthread [llength [info commands testthread]]
testConstraint exec [llength [info commands exec]]

# Produce a random port number in the Dynamic/Private range
# from 49152 through 65535.
proc randport {} { expr {int(rand()*16383+49152)} }

# If remoteServerIP or remoteServerPort are not set, check in the environment
# variables for externally set values.
#

if {![info exists remoteServerIP]} {
    if {[info exists env(remoteServerIP)]} {
	set remoteServerIP $env(remoteServerIP)
    }
}
if {![info exists remoteServerPort]} {
    if {[info exists env(remoteServerPort)]} {
	set remoteServerPort $env(remoteServerPort)
    } else {
        if {[info exists remoteServerIP]} {
	    set remoteServerPort 2048
        }
    }
}

if 0 {
    # activate this to time the tests
    proc test {args} {
        set name [lindex $args 0]
        puts "[lindex [time {uplevel [linsert $args 0 tcltest::test]}] 0] @@@ $name"
    }
}

foreach {af localhost} {
    any 127.0.0.1
    inet 127.0.0.1
    inet6 ::1
} {
    set ::tcl::unsupported::socketAF $af
    # Check if the family is supported and set the constraint accordingly
    testConstraint supported_$af [expr {![catch {socket -server foo 0} sock]}]
    catch {close $sock}
    
#
# Check if we're supposed to do tests against the remote server
#

set doTestsWithRemoteServer 1
if {![info exists remoteServerIP]} {
    set remoteServerIP $localhost
}
if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} {
    set remoteServerPort [randport]
}

# Attempt to connect to a remote server if one is already running. If it is
# not running or for some other reason the connect fails, attempt to start the
# remote server on the local host listening on port 2048. This is only done on
# platforms that support exec (i.e. not on the Mac). On platforms that do not
# support exec, the remote server must be started by the user before running

	set commandSocket [socket $remoteServerIP $remoteServerPort]
    }]} then {
	fconfigure $commandSocket -translation crlf -buffering line
    } elseif {![testConstraint exec]} {
	set noRemoteTestReason "can't exec"
	set doTestsWithRemoteServer 0
    } else {
	set remoteServerIP $localhost
	# Be *extra* careful in case this file is sourced from
	# a directory other than the current one...
	set remoteFile [file join [pwd] [file dirname [info script]] \
		remote.tcl]
	if {![catch {
	    set remoteProcChan [open "|[list \
		    [interpreter] $remoteFile -serverIsSilent \
		    -port $remoteServerPort -address $remoteServerIP]" w+]
	} msg]} then {
	    gets $remoteProcChan
	    if {[catch {
		set commandSocket [socket $remoteServerIP $remoteServerPort]
	    } msg] == 0} then {
		fconfigure $commandSocket -translation crlf -buffering line
	    } else {
		set noRemoteTestReason $msg
		set doTestsWithRemoteServer 0

	if {[catch {puts $commandSocket $c} msg]} {
	    error "remote server disappaered: $msg"
	}
	if {[catch {puts $commandSocket "--Marker--Marker--Marker--"} msg]} {
	    error "remote server disappeared: $msg"
	}


	while {1} {
	    set line [gets $commandSocket]
	    if {[eof $commandSocket]} {
		error "remote server disappaered"
	    }
	    if {$line eq "--Marker--Marker--Marker--"} {

		lassign $result code info value

                return -code $code -errorinfo $info $value
	    }

            append result $line "\n"
	}
    }
}

proc getPort sock {
    lindex [fconfigure $sock -sockname] 2
}


# ----------------------------------------------------------------------

test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket -server
} -returnCodes error -result {no argument given for -server option}
test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket -server foo
} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
test socket_$af-1.3 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket -myaddr
} -returnCodes error -result {no argument given for -myaddr option}
test socket_$af-1.4 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket -myaddr $localhost
} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
test socket_$af-1.5 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket -myport
} -returnCodes error -result {no argument given for -myport option}
test socket_$af-1.6 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket -myport xxxx
} -returnCodes error -result {expected integer but got "xxxx"}
test socket_$af-1.7 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket -myport 2522
} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
test socket_$af-1.8 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket -froboz
} -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, or -server}
test socket_$af-1.9 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket -server foo -myport 2521 3333
} -returnCodes error -result {option -myport is not valid for servers}
test socket_$af-1.10 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket host 2528 -junk
} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
test socket_$af-1.11 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket -server callback 2520 --
} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
test socket_$af-1.12 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket foo badport
} -returnCodes error -result {expected integer but got "badport"}
test socket_$af-1.13 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket -async -server
} -returnCodes error -result {cannot set -async option for server sockets}
test socket_$af-1.14 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket -server foo -async
} -returnCodes error -result {cannot set -async option for server sockets}

set path(script) [makeFile {} script]

test socket_$af-2.1 {tcp connection} -constraints [list socket supported_$af stdio] -setup {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f {
	set timer [after 10000 "set x timed_out"]
	set f [socket -server accept 0]
	proc accept {file addr port} {
	    global x

    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f x
    gets $f listen
} -body {
    # $x == "ready" at this point
    set sock [socket $localhost $listen]
    lappend x [gets $f]
    close $sock
    lappend x [gets $f]
} -cleanup {
    close $f
} -result {ready done {}}





test socket_$af-2.2 {tcp connection with client port specified} -setup {
    set port [randport]
    file delete $path(script)
    set f [open $path(script) w]
    puts $f {
	set timer [after 10000 "set x timeout"]
        set f [socket -server accept 0]
	proc accept {file addr port} {
            global x

	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f x
    gets $f listen
} -constraints [list socket supported_$af stdio] -body {
    # $x == "ready" at this point

    set sock [socket -myport $port $localhost $listen]
    puts $sock hello
    flush $sock
    lappend x [expr {[gets $f] eq "hello $port"}]
    close $sock
    return $x
} -cleanup {
    catch {close [socket $localhost $listen]}
    close $f
} -result {ready 1}
test socket_$af-2.3 {tcp connection with client interface specified} -setup {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket  -server accept 0]
	proc accept {file addr port} {
            global x
            puts "[gets $file] $addr"
            close $file
            set x done
	}
	puts [lindex [fconfigure $f -sockname] 2]
	puts ready
	vwait x
	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f listen
    gets $f x
} -constraints [list socket supported_$af stdio] -body {
    # $x == "ready" at this point
    set sock [socket -myaddr $localhost $localhost $listen]
    puts $sock hello
    flush $sock
    lappend x [gets $f]
    close $sock
    return $x
} -cleanup {
    close $f
} -result [list ready [list hello $localhost]]
test socket_$af-2.4 {tcp connection with server interface specified} -setup {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f [list set localhost $localhost]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket -server accept -myaddr $localhost 0]
	proc accept {file addr port} {
            global x
            puts "[gets $file]"
            close $file
            set x done
	}
	puts ready
	puts [lindex [fconfigure $f -sockname] 2]
	vwait x
	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f x
    gets $f listen
} -constraints [list socket supported_$af stdio] -body {
    # $x == "ready" at this point
    set sock [socket $localhost $listen]
    puts $sock hello
    flush $sock
    lappend x [gets $f]
    close $sock
    return $x
} -cleanup {
    close $f
} -result {ready hello}
test socket_$af-2.5 {tcp connection with redundant server port} -setup {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f {
	set timer [after 10000 "set x timeout"]
        set f [socket -server accept 0]
	proc accept {file addr port} {
            global x

	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f x
    gets $f listen
} -constraints [list socket supported_$af stdio] -body {
    # $x == "ready" at this point
    set sock [socket $localhost $listen]
    puts $sock hello
    flush $sock
    lappend x [gets $f]
    close $sock
    return $x
} -cleanup {
    close $f
} -result {ready hello}
test socket_$af-2.6 {tcp connection} -constraints [list socket supported_$af] -body {
    set status ok
    if {![catch {set sock [socket $localhost [randport]]}]} {
	if {![catch {gets $sock}]} {
	    set status broken
	}
	close $sock
    }
    set status
} -result ok
test socket_$af-2.7 {echo server, one line} -constraints [list socket supported_$af stdio] -setup {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f {
	set timer [after 10000 "set x timeout"]
	set f [socket -server accept 0]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]

	puts $x
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f
    gets $f listen
} -body {
    set s [socket $localhost $listen]
    fconfigure $s -buffering line -translation lf
    puts $s "hello abcdefghijklmnop"

    set x [gets $s]
    close $s
    list $x [gets $f]
} -cleanup {
    close $f
} -result {{hello abcdefghijklmnop} done}
removeFile script
test socket_$af-2.8 {echo server, loop 50 times, single connection} -setup {
    set path(script) [makeFile {
	set f [socket -server accept 0]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
            fconfigure $s -buffering line
        }
	proc echo {s} {

	after cancel $timer
	close $f
	puts "done $i"
    } script]
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f
    gets $f listen
} -constraints [list socket supported_$af stdio] -body {
    set s [socket $localhost $listen]
    fconfigure $s -buffering line
    catch {
	for {set x 0} {$x < 50} {incr x} {
	    puts $s "hello abcdefghijklmnop"
	    gets $s
	}
    }
    close $s
    catch {set x [gets $f]}
    return $x
} -cleanup {
    close $f
    removeFile script
} -result {done 50}
set path(script) [makeFile {} script]
test socket_$af-2.9 {socket conflict} -constraints [list socket supported_$af stdio] -body {
    set s [socket -server accept 0]
    file delete $path(script)
    set f [open $path(script) w]
    puts $f [list set ::tcl::unsupported::socketAF $::tcl::unsupported::socketAF]
    puts $f "socket -server accept [lindex [fconfigure $s -sockname] 2]"
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f
    after 100
    close $f
} -returnCodes error -cleanup {
    close $s
} -match glob -result {couldn't open socket: address already in use*}
test socket_$af-2.10 {close on accept, accepted socket lives} -setup {
    set done 0
    set timer [after 20000 "set done timed_out"]
} -constraints [list socket supported_$af] -body {
    set ss [socket -server accept 0]
    proc accept {s a p} {
	global ss
	close $ss
	fileevent $s readable "readit $s"
	fconfigure $s -trans lf
    }
    proc readit {s} {
	global done
	gets $s
	close $s
	set done 1
    }
    set cs [socket $localhost [lindex [fconfigure $ss -sockname] 2]]
    puts $cs hello
    close $cs
    vwait done
    return $done
} -cleanup {
    after cancel $timer
} -result 1
test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$af] -setup {
    proc accept {s a p} {
	global sock
	set sock $s
    }
    set s [socket -server accept 0]
    set sock ""
} -body {
    set s2 [socket $localhost [lindex [fconfigure $s -sockname] 2]]
    vwait sock
    puts $s2 one
    flush $s2
    after idle {set x 1}
    vwait x
    fconfigure $sock -blocking 0
    set result a:[gets $sock]
    lappend result b:[gets $sock]
    fconfigure $sock -blocking 1
    puts $s2 two
    flush $s2
    after idle {set x 1}
    vwait x
    fconfigure $sock -blocking 0
    lappend result c:[gets $sock]
} -cleanup {
    fconfigure $sock -blocking 1
    close $s2
    close $s
    close $sock
} -result {a:one b: c:two}

test socket_$af-3.1 {socket conflict} -constraints [list socket supported_$af stdio] -setup {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f [list set localhost $localhost]
    puts $f {
	set f [socket -server accept -myaddr $localhost 0]
	puts ready
	puts [lindex [fconfigure $f -sockname] 2]
	gets stdin
	close $f
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r+]
    gets $f
    gets $f listen
} -body {
    socket -server accept -myaddr $localhost $listen
} -cleanup {
    puts $f bye
    close $f
} -returnCodes error -result {couldn't open socket: address already in use}
test socket_$af-3.2 {server with several clients} -setup {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f [list set localhost $localhost]
    puts $f {
	set t1 [after 30000 "set x timed_out"]
	set t2 [after 31000 "set x timed_out"]
	set t3 [after 32000 "set x timed_out"]
	set counter 0
	set s [socket -server accept -myaddr $localhost 0]
	proc accept {s a p} {
	    fileevent $s readable [list echo $s]
	    fconfigure $s -buffering line
	}
	proc echo {s} {
	     global x
             set l [gets $s]

	close $s
	puts $x
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r+]
    set x [gets $f]
    gets $f listen
} -constraints [list socket supported_$af stdio] -body {
    # $x == "ready" here
    set s1 [socket $localhost $listen]
    fconfigure $s1 -buffering line
    set s2 [socket $localhost $listen]
    fconfigure $s2 -buffering line
    set s3 [socket $localhost $listen]
    fconfigure $s3 -buffering line
    for {set i 0} {$i < 100} {incr i} {
	puts $s1 hello,s1
	gets $s1
	puts $s2 hello,s2
	gets $s2
	puts $s3 hello,s3
	gets $s3
    }
    close $s1
    close $s2
    close $s3
    lappend x [gets $f]
} -cleanup {
    close $f
} -result {ready done}

test socket_$af-4.1 {server with several clients} -setup {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f [list set localhost $localhost]
    puts $f {
	set port [gets stdin]
	set s [socket $localhost $port]
	fconfigure $s -buffering line
	for {set i 0} {$i < 100} {incr i} {
	    puts $s hello
	    gets $s
	}
	close $s
	puts bye
	gets stdin
    }
    close $f
    set p1 [open "|[list [interpreter] $path(script)]" r+]
    fconfigure $p1 -buffering line
    set p2 [open "|[list [interpreter] $path(script)]" r+]
    fconfigure $p2 -buffering line
    set p3 [open "|[list [interpreter] $path(script)]" r+]
    fconfigure $p3 -buffering line
} -constraints [list socket supported_$af stdio] -body {
    proc accept {s a p} {
	fconfigure $s -buffering line
	fileevent $s readable [list echo $s]
    }
    proc echo {s} {
	global x
        set l [gets $s]
        if {[eof $s]} {
            close $s
            set x done
        } else {
            puts $s $l
        }
    }
    set t1 [after 30000 "set x timed_out"]
    set t2 [after 31000 "set x timed_out"]
    set t3 [after 32000 "set x timed_out"]
    set s [socket -server accept -myaddr $localhost 0]
    set listen [lindex [fconfigure $s -sockname] 2]
    puts $p1 $listen
    puts $p2 $listen
    puts $p3 $listen
    vwait x
    vwait x
    vwait x

    puts $p1 bye
    puts $p2 bye
    puts $p3 bye
    close $p1
    close $p2
    close $p3
} -result {{p1 bye done} {p2 bye done} {p3 bye done}}
test socket_$af-4.2 {byte order problems, socket numbers, htons} -body {
    close [socket -server dodo -myaddr $localhost 0x3000]
    return ok
} -constraints [list socket supported_$af] -result ok

test socket_$af-5.1 {byte order problems, socket numbers, htons} -body {
    if {![catch {socket -server dodo 0x1} msg]} {
	close $msg
        return {htons problem, should be disallowed, are you running as SU?}
    }
    return {couldn't open socket: not owner}
} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner}
test socket_$af-5.2 {byte order problems, socket numbers, htons} -body {
    if {![catch {socket -server dodo 0x10000} msg]} {
	close $msg
	return {port resolution problem, should be disallowed}
    }
    return {couldn't open socket: port number too high}
} -constraints [list socket supported_$af] -result {couldn't open socket: port number too high}
test socket_$af-5.3 {byte order problems, socket numbers, htons} -body {
    if {![catch {socket -server dodo 21} msg]} {
	close $msg
	return {htons problem, should be disallowed, are you running as SU?}
    }
    return {couldn't open socket: not owner}
} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner}

test socket_$af-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup {
    proc myHandler {msg options} {
	variable x $msg
    }
    set handler [interp bgerror {}]
    interp bgerror {} [namespace which myHandler]
    file delete $path(script)
} -body {
    set f [open $path(script) w]
    puts $f [list set localhost $localhost]
    puts $f {
	gets stdin port
	socket $localhost $port
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r+]
    proc accept {s a p} {expr 10 / 0}
    set s [socket -server accept -myaddr $localhost 0]
    puts $f [lindex [fconfigure $s -sockname] 2]
    close $f
    set timer [after 10000 "set x timed_out"]
    vwait x
    after cancel $timer
    close $s
    return $x
} -cleanup {
    interp bgerror {} $handler
} -result {divide by zero}

test socket_$af-7.1 {testing socket specific options} -setup {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f {
	set ss [socket -server accept 0]
	proc accept args {
	    global x
	    set x done
	}
	puts ready
	puts [lindex [fconfigure $ss -sockname] 2]
	set timer [after 10000 "set x timed_out"]
	vwait x
	after cancel $timer
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f
    gets $f listen
    set l ""
} -constraints [list socket supported_$af stdio] -body {
    set s [socket $localhost $listen]
    set p [fconfigure $s -peername]
    close $s
    lappend l [string compare [lindex $p 0] $localhost]
    lappend l [string compare [lindex $p 2] $listen]
    lappend l [llength $p]
} -cleanup {
    close $f
} -result {0 0 3}
test socket_$af-7.2 {testing socket specific options} -setup {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f [list set ::tcl::unsupported::socketAF $::tcl::unsupported::socketAF]
    puts $f {
	set ss [socket -server accept 0]
	proc accept args {
	    global x
	    set x done
	}
	puts ready
	puts [lindex [fconfigure $ss -sockname] 2]
	set timer [after 10000 "set x timed_out"]
	vwait x
	after cancel $timer
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f
    gets $f listen

} -constraints [list socket supported_$af stdio] -body {
    set s [socket $localhost $listen]





























    set p [fconfigure $s -sockname]
    close $s
    list [llength $p] \
	    [regexp {^(127\.0\.0\.1|0\.0\.0\.0|::1)$} [lindex $p 0]] \
	    [expr {[lindex $p 2] == $listen}]
} -cleanup {
    close $f
} -result {3 1 0}
test socket_$af-7.3 {testing socket specific options} -constraints [list socket supported_$af] -body {
    set s [socket -server accept -myaddr $localhost 0]
    set l [fconfigure $s]
    close $s
    update
    llength $l
} -result 14
test socket_$af-7.4 {testing socket specific options} -constraints [list socket supported_$af] -setup {
    set timer [after 10000 "set x timed_out"]
    set l ""
} -body {
    set s [socket -server accept -myaddr $localhost 0]
    proc accept {s a p} {
	global x
	set x [fconfigure $s -sockname]
	close $s
    }
    set listen [lindex [fconfigure $s -sockname] 2]
    set s1 [socket $localhost $listen]
    vwait x
    lappend l [expr {[lindex $x 2] == $listen}] [llength $x]
} -cleanup {
    after cancel $timer
    close $s
    close $s1
} -result {1 3}
test socket_$af-7.5 {testing socket specific options} -setup {
    set timer [after 10000 "set x timed_out"]
    set l ""
} -constraints [list socket supported_$af unixOrPc] -body {
    set s [socket -server accept 0]
    proc accept {s a p} {
	global x
	set x [fconfigure $s -sockname]
	close $s
    }
    set listen [lindex [fconfigure $s -sockname] 2]
    set s1 [socket $localhost $listen]
    vwait x
    lappend l [lindex $x 0] [expr {[lindex $x 2] == $listen}] [llength $x]
} -cleanup {
    after cancel $timer
    close $s
    close $s1
} -result [list $localhost 1 3]

test socket_$af-8.1 {testing -async flag on sockets} -constraints [list socket supported_$af] -body {
    # NOTE: This test may fail on some Solaris 2.4 systems. If it does, check
    # that you have these patches installed (using showrev -p):
    #
    # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
    # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
    # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03,
    # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01,
    # 101878-03, 101879-01, 101880-03, 101933-01, 101950-01, 102030-01,
    # 102057-08, 102140-01, 101920-02, 101921-09, 101922-07, 101923-03
    #
    # If after installing these patches you are still experiencing a problem,
    # please email [email protected]. We have not observed this failure on
    # Solaris 2.5, so another option (instead of installing these patches) is
    # to upgrade to Solaris 2.5.
    set s [socket -server accept -myaddr $localhost 0]
    proc accept {s a p} {
	global x
	puts $s bye
	close $s
	set x done
    }
    set s1 [socket -async $localhost [lindex [fconfigure $s -sockname] 2]]
    vwait x
    gets $s1
} -cleanup {
    close $s
    close $s1
} -result bye

test socket_$af-9.1 {testing spurious events} -constraints [list socket supported_$af] -setup {
    set len 0
    set spurious 0
    set done 0
    set timer [after 10000 "set done timed_out"]
} -body {
    proc readlittle {s} {
	global spurious done len

	    incr len [string length $l]
	}
    }
    proc accept {s a p} {
	fconfigure $s -buffering none -blocking off
	fileevent $s readable [list readlittle $s]
    }
    set s [socket -server accept -myaddr $localhost 0]
    set c [socket $localhost [lindex [fconfigure $s -sockname] 2]]
    puts -nonewline $c 01234567890123456789012345678901234567890123456789
    close $c
    vwait done
    close $s
    list $spurious $len
} -cleanup {
    after cancel $timer
} -result {0 50}
test socket_$af-9.2 {testing async write, fileevents, flush on close} -constraints [list socket supported_$af] -setup {
    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 timer [after 10000 "set done timed_out"]
    set l [socket -server accept -myaddr $localhost 0]
    proc accept {s a p} {
	fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
		-buffering line
	fileevent $s readable "readable $s"
    }
    proc readable {s} {
	set l [gets $s]
	fileevent $s readable {}
	after idle respond $s
    }
    proc respond {s} {
	global firstblock
	puts -nonewline $s $firstblock
	after idle writedata $s
    }
    proc writedata {s} {
	global secondblock
	puts -nonewline $s $secondblock
	close $s
    }
} -body {
    set s [socket $localhost [lindex [fconfigure $l -sockname] 2]]
    fconfigure $s -blocking 0 -trans lf -buffering line
    set count 0
    puts $s hello
    proc readit {s} {
	global count done
	set l [read $s]
	incr count [string length $l]
	if {[eof $s]} {
	    close $s
	    set done 1
	}
    }
    fileevent $s readable "readit $s"
    vwait done
    return $count
} -cleanup {
    close $l
    after cancel $timer
} -result 65566
test socket_$af-9.3 {testing EOF stickyness} -constraints [list socket supported_$af] -setup {
    set count 0
    set done false
    proc write_then_close {s} {
	puts $s bye
	close $s
    }
    proc accept {s a p} {
	fconfigure $s -buffering line -translation lf
	fileevent $s writable "write_then_close $s"
    }
    set s [socket -server accept -myaddr $localhost 0]
} -body {
    proc count_to_eof {s} {
	global count done
	set l [gets $s]
	if {[eof $s]} {
	    incr count
	    if {$count > 9} {
		close $s
		set done true
		set count {eof is sticky}
	    }
	}
    }
    proc timerproc {s} {
	global done count
	set done true
	set count {timer went off, eof is not sticky}
	close $s
    }
    set c [socket $localhost [lindex [fconfigure $s -sockname] 2]]
    fconfigure $c -blocking off -buffering line -translation lf
    fileevent $c readable "count_to_eof $c"
    set timer [after 1000 timerproc $c]
    vwait done
    return $count
} -cleanup {
    close $s
    after cancel $timer
} -result {eof is sticky}

removeFile script

test socket_$af-10.1 {testing socket accept callback error handling} \

    -constraints [list socket supported_$af] -setup {
    variable goterror 0
    proc myHandler {msg options} {
	variable goterror 1
    }
    set handler [interp bgerror {}]
    interp bgerror {} [namespace which myHandler]
} -body {
    set s [socket -server accept -myaddr $localhost 0]
    proc accept {s a p} {close $s; error}
    set c [socket $localhost [lindex [fconfigure $s -sockname] 2]]
    vwait goterror
    close $s
    close $c
    return $goterror
} -cleanup {
    interp bgerror {} $handler
} -result 1

test socket_$af-11.1 {tcp connection} -setup {
    set port [sendCommand {
	set server [socket -server accept 0]
	proc accept {s a p} {
	    puts $s done
	    close $s
	}
	getPort $server
    }]
} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
    set s [socket $remoteServerIP $port]
    gets $s
} -cleanup {
    close $s
    sendCommand {close $server}
} -result done
test socket_$af-11.2 {client specifies its port} -setup {

    set lport [randport]



    set rport [sendCommand {
	set server [socket -server accept 0]
	proc accept {s a p} {
	    puts $s $p
	    close $s
	}
	getPort $server
    }]
} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
    set s [socket -myport $lport $remoteServerIP $rport]
    set r [gets $s]
    expr {$r==$lport ? "ok" : "broken: $r != $port"}
} -cleanup {
    close $s
    sendCommand {close $server}
} -result ok
test socket_$af-11.3 {trying to connect, no server} -body {
    set status ok
    if {![catch {set s [socket $remoteServerIp [randport]]}]} {
	if {![catch {gets $s}]} {
	    set status broken
	}
	close $s
    }
    return $status
} -constraints [list socket supported_$af doTestsWithRemoteServer] -result ok
test socket_$af-11.4 {remote echo, one line} -setup {
    set port [sendCommand {
	set server [socket -server accept 0]
	proc accept {s a p} {
	    fileevent $s readable [list echo $s]
	    fconfigure $s -buffering line -translation crlf
	}
	proc echo {s} {
	    set l [gets $s]
	    if {[eof $s]} {
		close $s
	    } else {
		puts $s $l
	    }
	}
	getPort $server
    }]
} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
    set f [socket $remoteServerIP $port]
    fconfigure $f -translation crlf -buffering line
    puts $f hello
    gets $f
} -cleanup {
    catch {close $f}
    sendCommand {close $server}
} -result hello
test socket_$af-11.5 {remote echo, 50 lines} -setup {
    set port [sendCommand {
	set server [socket -server accept 0]
	proc accept {s a p} {
	    fileevent $s readable [list echo $s]
	    fconfigure $s -buffering line -translation crlf
	}
	proc echo {s} {
	    set l [gets $s]
	    if {[eof $s]} {
		close $s
	    } else {
		puts $s $l
	    }
	}





	getPort $server










    }]









} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
    set f [socket $remoteServerIP $port]
    fconfigure $f -translation crlf -buffering line
    for {set cnt 0} {$cnt < 50} {incr cnt} {
	puts $f "hello, $cnt"
	if {[gets $f] != "hello, $cnt"} {
	    break
	}
    }
    return $cnt
} -cleanup {
    close $f
    sendCommand {close $server}
} -result 50
test socket_$af-11.6 {socket conflict} -setup {
    set s1 [socket -server accept -myaddr $localhost 0]
} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
    set s2 [socket -server accept -myaddr $localhost [getPort $s1]]
    list [getPort $s2] [close $s2]
} -cleanup {
    close $s1
} -returnCodes error -result {couldn't open socket: address already in use}
test socket_$af-11.7 {server with several clients} -setup {
    set port [sendCommand {
	set server [socket -server accept 0]
	proc accept {s a p} {
	    fconfigure $s -buffering line
	    fileevent $s readable [list echo $s]
	}
	proc echo {s} {
	    set l [gets $s]
	    if {[eof $s]} {
		close $s
	    } else {
		puts $s $l
	    }
	}
	getPort $server
    }]
} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
    set s1 [socket $remoteServerIP $port]
    fconfigure $s1 -buffering line
    set s2 [socket $remoteServerIP $port]
    fconfigure $s2 -buffering line
    set s3 [socket $remoteServerIP $port]
    fconfigure $s3 -buffering line
    for {set i 0} {$i < 100} {incr i} {
	puts $s1 hello,s1
	gets $s1
	puts $s2 hello,s2
	gets $s2
	puts $s3 hello,s3
	gets $s3
    }
    return $i
} -cleanup {
    close $s1
    close $s2
    close $s3
    sendCommand {close $server}
} -result 100
test socket_$af-11.8 {client with several servers} -setup {
    lassign [sendCommand {
	set s1 [socket -server "accept server1" 0]
	set s2 [socket -server "accept server2" 0]
	set s3 [socket -server "accept server3" 0]
	proc accept {mp s a p} {
	    puts $s $mp
	    close $s
	}
	list [getPort $s1] [getPort $s2] [getPort $s3]
    }] p1 p2 p3
} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
    set s1 [socket $remoteServerIP $p1]
    set s2 [socket $remoteServerIP $p2]
    set s3 [socket $remoteServerIP $p3]
    list [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \
	[gets $s3] [gets $s3] [eof $s3]
} -cleanup {
    close $s1
    close $s2
    close $s3
    sendCommand {
	close $s1
	close $s2
	close $s3
    }
} -result {server1 {} 1 server2 {} 1 server3 {} 1}
test socket_$af-11.9 {accept callback error} -constraints [list socket supported_$af doTestsWithRemoteServer] -setup {


    proc myHandler {msg options} {
	variable x $msg
    }
    set handler [interp bgerror {}]
    interp bgerror {} [namespace which myHandler]
    set timer [after 10000 "set x timed_out"]
} -body {
    set s [socket -server accept 0]
    proc accept {s a p} {expr {10 / 0}}
    sendCommand "set port [getPort $s]"
    if {[catch {
	sendCommand {
	    set peername [fconfigure $callerSocket -peername]
	    set s [socket [lindex $peername 0] $port]
	    close $s
    	 }
    } msg]} then {
	close $s
	error $msg
    }
    vwait x
    return $x
} -cleanup {
    close $s
    after cancel $timer
    interp bgerror {} $handler
} -result {divide by zero}
test socket_$af-11.10 {testing socket specific options} -setup {
    set port [sendCommand {
	set server [socket -server accept 0]
	proc accept {s a p} {close $s}
	getPort $server
    }]
} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
    set s [socket $remoteServerIP $port]
    set p [fconfigure $s -peername]
    set n [fconfigure $s -sockname]
    list [expr {[lindex $p 2] == $port}] [llength $p] [llength $n]
} -cleanup {
    close $s
    sendCommand {close $server}
} -result {1 3 3}
test socket_$af-11.11 {testing spurious events} -setup {
    set port [sendCommand {
	set server [socket -server accept 0]
	proc accept {s a p} {
	    fconfigure $s -translation "auto lf"
	    after idle writesome $s
	}
	proc writesome {s} {
	    for {set i 0} {$i < 100} {incr i} {
		puts $s "line $i from remote server"
	    }
	    close $s
	}
	getPort $server
    }]
    set len 0
    set spurious 0
    set done 0
    set timer [after 40000 "set done timed_out"]
} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
    proc readlittle {s} {
	global spurious done len
	set l [read $s 1]
	if {[string length $l] == 0} {
	    if {![eof $s]} {
		incr spurious
	    } else {
		close $s
		set done 1
	    }
	} else {
	    incr len [string length $l]
	}
    }
    set c [socket $remoteServerIP $port]
    fileevent $c readable "readlittle $c"
    vwait done
    list $spurious $len $done
} -cleanup {
    after cancel $timer
    sendCommand {close $server}
} -result {0 2690 1}
test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket supported_$af doTestsWithRemoteServer] -setup {
    set counter 0
    set done 0
    set port [sendCommand {
	set server [socket -server accept 0]
	proc accept {s a p} {
	    after idle close $s
	}
	getPort $server
    }]
    proc timed_out {} {
	global c done
	set done {timed_out, EOF is not sticky}
	close $c
    }
    set after_id [after 1000 timed_out]
} -body {
    proc count_up {s} {
	global counter done
	set l [gets $s]
	if {[eof $s]} {
	    incr counter
	    if {$counter > 9} {
		set done {EOF is sticky}
		close $s
	    }
	}
    }
    set c [socket $remoteServerIP $port]
    fileevent $c readable [list count_up $c]
    vwait done
    return $done
} -cleanup {
    after cancel $after_id
    sendCommand {close $server}
} -result {EOF is sticky}
test socket_$af-11.13 {testing async write, async flush, async close} -setup {
    set port [sendCommand {
	set firstblock ""
	for {set i 0} {$i < 5} {incr i} {
		set firstblock "a$firstblock$firstblock"
	}
	set secondblock ""
	for {set i 0} {$i < 16} {incr i} {
	    set secondblock "b$secondblock$secondblock"
	}
	set l [socket -server accept 0]
	proc accept {s a p} {
	    fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
		-buffering line
	    fileevent $s readable "readable $s"
	}
	proc readable {s} {
	    set l [gets $s]
	    fileevent $s readable {}
	    after idle respond $s
	}
	proc respond {s} {
	    global firstblock
	    puts -nonewline $s $firstblock
	    after idle writedata $s
	}
	proc writedata {s} {
	    global secondblock
	    puts -nonewline $s $secondblock
	    close $s
	}
	getPort $l
    }]
    set timer [after 10000 "set done timed_out"]
} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
    proc readit {s} {
	global count done
	set l [read $s]
	incr count [string length $l]
	if {[eof $s]} {
	    close $s
	    set done 1
	}
    }
    set s [socket $remoteServerIP $port]
    fconfigure $s -blocking 0 -trans lf -buffering line
    set count 0
    puts $s hello
    fileevent $s readable "readit $s"
    vwait done
    return $count
} -cleanup {
    after cancel $timer
    sendCommand {close $l}
} -result 65566

set path(script1) [makeFile {} script1]
set path(script2) [makeFile {} script2]

test socket_$af-12.1 {testing inheritance of server sockets} -setup {
    file delete $path(script1)
    file delete $path(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 $path(script1) w]
    puts $f {
	fileevent stdin readable exit
	after 10000 exit
	vwait forever
    }
    close $f
    # Script2 creates the server socket, launches script1, and exits.
    # The server socket will now be closed unless script1 inherited it.
    set f [open $path(script2) w]
    puts $f [list set tcltest [interpreter]]
    puts $f [list set delay $path(script1)]
    puts $f [list set localhost $localhost]
    puts $f {
	set f [socket -server accept -myaddr $localhost 0]

	proc accept { file addr port } {
	    close $file
	}
	exec $tcltest $delay &
	puts [lindex [fconfigure $f -sockname] 2]
	close $f
        exit

    }
    close $f
} -constraints [list socket supported_$af stdio exec] -body {
    # Launch script2 and wait 5 seconds
    ### exec [interpreter] script2 &
    set p [open "|[list [interpreter] $path(script2)]" r]



    # If we can still connect to the server, the socket got inherited.
    if {[catch {close [socket $localhost $listen]}]} {
	return {server socket was not inherited}
    } else {
	return {server socket was inherited}
    }
} -cleanup {
    catch {close $p}
} -result {server socket was not inherited}
test socket_$af-12.2 {testing inheritance of client sockets} -setup {
    file delete $path(script1)
    file delete $path(script2)
    # Script1 is just a 20 second delay. If the server socket is inherited, it
    # will be held open for 20 seconds
    set f [open $path(script1) w]
    puts $f {
	fileevent stdin readable exit
	after 20000 exit
	vwait forever
    }
    close $f
    # Script2 opens the client socket and writes to it. It then launches
    # script1 and exits. If the child process inherited the client socket, the
    # socket will still be open.
    set f [open $path(script2) w]
    puts $f [list set tcltest [interpreter]]
    puts $f [list set delay $path(script1)]
    puts $f [list set localhost $localhost]
    puts $f {
        gets stdin port
	set f [socket $localhost $port]
        exec $tcltest $delay &
	puts $f testing
	flush $f
        exit

    }
    close $f
    # If the socket doesn't hit end-of-file in 10 seconds, the script1 process
    # must have inherited the client.
    set failed 0
    set after [after 10000 [list set failed 1]]
} -constraints [list socket supported_$af stdio exec] -body {
    # Create the server socket
    set server [socket -server accept -myaddr $localhost 0]
    proc accept { file host port } {
	# When the client connects, establish the read handler
	global server
	close $server
	fileevent $file readable [list getdata $file]
	fconfigure $file -buffering line -blocking 0
    }