Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/tcltest.test@bde4ae8d615e (annotated)

sl@0	1	# This file contains a collection of tests for one or more of the Tcl
sl@0	2	# built-in commands. Sourcing this file into Tcl runs the tests and
sl@0	3	# generates output for errors. No output means no errors were found.
sl@0	4	#
sl@0	5	# Copyright (c) 1998-1999 by Scriptics Corporation.
sl@0	6	# Copyright (c) 2000 by Ajuba Solutions
sl@0	7	# All rights reserved.
sl@0	8	#
sl@0	9	# RCS: @(#) $Id: tcltest.test,v 1.37.2.11 2006/03/19 22:47:30 vincentdarley Exp $
sl@0	10
sl@0	11	# Note that there are several places where the value of
sl@0	12	# tcltest::currentFailure is stored/reset in the -setup/-cleanup
sl@0	13	# of a test that has a body that runs [test] that will fail.
sl@0	14	# This is a workaround of using the same tcltest code that we are
sl@0	15	# testing to run the test itself. Ditto on things like [verbose].
sl@0	16	#
sl@0	17	# It would be better to have the -body of the tests run the tcltest
sl@0	18	# commands in a slave interp so the [test] being tested would not
sl@0	19	# interfere with the [test] doing the testing.
sl@0	20	#
sl@0	21
sl@0	22	if {[catch {package require tcltest 2.1}]} {
sl@0	23	puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
sl@0	24	return
sl@0	25	}
sl@0	26
sl@0	27	namespace eval ::tcltest::test {
sl@0	28
sl@0	29	namespace import ::tcltest::*
sl@0	30
sl@0	31	makeFile {
sl@0	32	package require tcltest
sl@0	33	namespace import ::tcltest::test
sl@0	34	test a-1.0 {test a} {
sl@0	35	list 0
sl@0	36	} {0}
sl@0	37	test b-1.0 {test b} {
sl@0	38	list 1
sl@0	39	} {0}
sl@0	40	test c-1.0 {test c} {knownBug} {
sl@0	41	} {}
sl@0	42	test d-1.0 {test d} {
sl@0	43	error "foo" foo 9
sl@0	44	} {}
sl@0	45	tcltest::cleanupTests
sl@0	46	exit
sl@0	47	} test.tcl
sl@0	48
sl@0	49	cd [temporaryDirectory]
sl@0	50	testConstraint exec [llength [info commands exec]]
sl@0	51	# test -help
sl@0	52	# Child processes because -help [exit]s.
sl@0	53	test tcltest-1.1 {tcltest -help} {exec} {
sl@0	54	set result [catch {exec [interpreter] test.tcl -help} msg]
sl@0	55	list $result [regexp Usage $msg]
sl@0	56	} {1 1}
sl@0	57	test tcltest-1.2 {tcltest -help -something} {exec} {
sl@0	58	set result [catch {exec [interpreter] test.tcl -help -something} msg]
sl@0	59	list $result [regexp Usage $msg]
sl@0	60	} {1 1}
sl@0	61	test tcltest-1.3 {tcltest -h} {exec} {
sl@0	62	set result [catch {exec [interpreter] test.tcl -h} msg]
sl@0	63	list $result [regexp Usage $msg]
sl@0	64	} {1 0}
sl@0	65
sl@0	66	# -verbose, implicit & explicit testing of [verbose]
sl@0	67	proc slave {msgVar args} {
sl@0	68	upvar 1 $msgVar msg
sl@0	69
sl@0	70	interp create [namespace current]::i
sl@0	71	# Fake the slave interp into dumping output to a file
sl@0	72	i eval {namespace eval ::tcltest {}}
sl@0	73	i eval "set tcltest::outputChannel\
sl@0	74	\[[list open [set of [makeFile {} output]] w]]"
sl@0	75	i eval "set tcltest::errorChannel\
sl@0	76	\[[list open [set ef [makeFile {} error]] w]]"
sl@0	77	i eval [list set argv0 [lindex $args 0]]
sl@0	78	i eval [list set argv [lrange $args 1 end]]
sl@0	79	i eval [list package ifneeded tcltest [package provide tcltest] \
sl@0	80	[package ifneeded tcltest [package provide tcltest]]]
sl@0	81	i eval {proc exit args {}}
sl@0	82
sl@0	83	# Need to capture output in msg
sl@0	84
sl@0	85	set code [catch {i eval {source $argv0}} foo]
sl@0	86	if $code {
sl@0	87	#puts "$code: $foo\n$::errorInfo"
sl@0	88	}
sl@0	89	i eval {close $tcltest::outputChannel}
sl@0	90	interp delete [namespace current]::i
sl@0	91	set f [open $of]
sl@0	92	set msg [read -nonewline $f]
sl@0	93	close $f
sl@0	94	set f [open $ef]
sl@0	95	set err [read -nonewline $f]
sl@0	96	close $f
sl@0	97	removeFile output
sl@0	98	removeFile error
sl@0	99	if {[string length $err]} {
sl@0	100	set code 1
sl@0	101	append msg \n$err
sl@0	102	}
sl@0	103	return $code
sl@0	104
sl@0	105	# return [catch {uplevel 1 [linsert $args 0 exec [interpreter]]} msg]
sl@0	106	}
sl@0	107	test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} {
sl@0	108	set result [slave msg test.tcl]
sl@0	109	list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
sl@0	110	[regexp c-1.0 $msg] \
sl@0	111	[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
sl@0	112	} {0 1 0 0 1}
sl@0	113	test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} {
sl@0	114	set result [slave msg test.tcl -verbose 'b']
sl@0	115	list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
sl@0	116	[regexp c-1.0 $msg] \
sl@0	117	[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
sl@0	118	} {0 1 0 0 1}
sl@0	119	test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} {
sl@0	120	set result [slave msg test.tcl -verbose 'p']
sl@0	121	list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
sl@0	122	[regexp c-1.0 $msg] \
sl@0	123	[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
sl@0	124	} {0 0 1 0 1}
sl@0	125	test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} {
sl@0	126	set result [slave msg test.tcl -verbose 's']
sl@0	127	list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
sl@0	128	[regexp c-1.0 $msg] \
sl@0	129	[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
sl@0	130	} {0 0 0 1 1}
sl@0	131	test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} {
sl@0	132	set result [slave msg test.tcl -verbose 'ps']
sl@0	133	list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
sl@0	134	[regexp c-1.0 $msg] \
sl@0	135	[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
sl@0	136	} {0 0 1 1 1}
sl@0	137	test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} {
sl@0	138	set result [slave msg test.tcl -verbose 'psb']
sl@0	139	list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
sl@0	140	[regexp c-1.0 $msg] \
sl@0	141	[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
sl@0	142	} {0 1 1 1 1}
sl@0	143
sl@0	144	test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} {
sl@0	145	set result [slave msg test.tcl -verbose "pass skip body"]
sl@0	146	list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
sl@0	147	[regexp c-1.0 $msg] \
sl@0	148	[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
sl@0	149	} {0 1 1 1 1}
sl@0	150
sl@0	151	test tcltest-2.6 {tcltest -verbose 't'} {
sl@0	152	-constraints {unixOrPc}
sl@0	153	-body {
sl@0	154	set result [slave msg test.tcl -verbose 't']
sl@0	155	list $result $msg
sl@0	156	}
sl@0	157	-result {^0 .a-1.0 start.b-1.0 start}
sl@0	158	-match regexp
sl@0	159	}
sl@0	160
sl@0	161	test tcltest-2.6a {tcltest -verbose 'start'} {
sl@0	162	-constraints {unixOrPc}
sl@0	163	-body {
sl@0	164	set result [slave msg test.tcl -verbose start]
sl@0	165	list $result $msg
sl@0	166	}
sl@0	167	-result {^0 .a-1.0 start.b-1.0 start}
sl@0	168	-match regexp
sl@0	169	}
sl@0	170
sl@0	171	test tcltest-2.7 {tcltest::verbose} {
sl@0	172	-body {
sl@0	173	set oldVerbosity [verbose]
sl@0	174	verbose bar
sl@0	175	set currentVerbosity [verbose]
sl@0	176	verbose foo
sl@0	177	set newVerbosity [verbose]
sl@0	178	verbose $oldVerbosity
sl@0	179	list $currentVerbosity $newVerbosity
sl@0	180	}
sl@0	181	-result {body {}}
sl@0	182	}
sl@0	183
sl@0	184	test tcltest-2.8 {tcltest -verbose 'error'} {
sl@0	185	-constraints {unixOrPc}
sl@0	186	-body {
sl@0	187	set result [slave msg test.tcl -verbose error]
sl@0	188	list $result $msg
sl@0	189	}
sl@0	190	-result {errorInfo: foo.*errorCode: 9}
sl@0	191	-match regexp
sl@0	192	}
sl@0	193	# -match, [match]
sl@0	194	test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} {
sl@0	195	set result [slave msg test.tcl -match a* -verbose 'ps']
sl@0	196	list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
sl@0	197	[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
sl@0	198	} {0 1 0 0 1}
sl@0	199	test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} {
sl@0	200	set result [slave msg test.tcl -match b* -verbose 'ps']
sl@0	201	list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
sl@0	202	[regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
sl@0	203	} {0 0 1 0 1}
sl@0	204	test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} {
sl@0	205	set result [slave msg test.tcl -match c* -verbose 'ps']
sl@0	206	list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
sl@0	207	[regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg]
sl@0	208	} {0 0 0 1 1}
sl@0	209	test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} {
sl@0	210	set result [slave msg test.tcl -match {a* b*} -verbose 'ps']
sl@0	211	list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
sl@0	212	[regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
sl@0	213	} {0 1 1 0 1}
sl@0	214
sl@0	215	test tcltest-3.5 {tcltest::match} {
sl@0	216	-body {
sl@0	217	set oldMatch [match]
sl@0	218	match foo
sl@0	219	set currentMatch [match]
sl@0	220	match bar
sl@0	221	set newMatch [match]
sl@0	222	match $oldMatch
sl@0	223	list $currentMatch $newMatch
sl@0	224	}
sl@0	225	-result {foo bar}
sl@0	226	}
sl@0	227
sl@0	228	# -skip, [skip]
sl@0	229	test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} {
sl@0	230	set result [slave msg test.tcl -skip a* -verbose 'ps']
sl@0	231	list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
sl@0	232	[regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
sl@0	233	} {0 0 1 1 1}
sl@0	234	test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} {
sl@0	235	set result [slave msg test.tcl -skip b* -verbose 'ps']
sl@0	236	list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
sl@0	237	[regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
sl@0	238	} {0 1 0 1 1}
sl@0	239	test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} {
sl@0	240	set result [slave msg test.tcl -skip c* -verbose 'ps']
sl@0	241	list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
sl@0	242	[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
sl@0	243	} {0 1 1 0 1}
sl@0	244	test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} {
sl@0	245	set result [slave msg test.tcl -skip {a* b*} -verbose 'ps']
sl@0	246	list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
sl@0	247	[regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
sl@0	248	} {0 0 0 1 1}
sl@0	249	test tcltest-4.5 {tcltest -match 'a* b' -skip 'b'} {unixOrPc} {
sl@0	250	set result [slave msg test.tcl -match {a* b} -skip b -verbose 'ps']
sl@0	251	list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
sl@0	252	[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
sl@0	253	} {0 1 0 0 1}
sl@0	254
sl@0	255	test tcltest-4.6 {tcltest::skip} {
sl@0	256	-body {
sl@0	257	set oldSkip [skip]
sl@0	258	skip foo
sl@0	259	set currentSkip [skip]
sl@0	260	skip bar
sl@0	261	set newSkip [skip]
sl@0	262	skip $oldSkip
sl@0	263	list $currentSkip $newSkip
sl@0	264	}
sl@0	265	-result {foo bar}
sl@0	266	}
sl@0	267
sl@0	268	# -constraints, -limitconstraints, [testConstraint],
sl@0	269	# $constraintsSpecified, [limitConstraints]
sl@0	270	test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} {
sl@0	271	set result [slave msg test.tcl -constraints knownBug -verbose 'ps']
sl@0	272	list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
sl@0	273	[regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg]
sl@0	274	} {0 1 1 1 1}
sl@0	275	test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} {
sl@0	276	set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1]
sl@0	277	list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
sl@0	278	[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
sl@0	279	} {0 0 0 1 1}
sl@0	280
sl@0	281	test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} {
sl@0	282	-body {
sl@0	283	set r1 [testConstraint tcltestFakeConstraint]
sl@0	284	set r2 [testConstraint tcltestFakeConstraint 4]
sl@0	285	set r3 [testConstraint tcltestFakeConstraint]
sl@0	286	list $r1 $r2 $r3
sl@0	287	}
sl@0	288	-result {0 4 4}
sl@0	289	-cleanup {unset ::tcltest::testConstraints(tcltestFakeConstraint)}
sl@0	290	}
sl@0	291
sl@0	292	# Removed this test of internals of tcltest. Those internals have changed.
sl@0	293	#test tcltest-5.4 {tcltest::constraintsSpecified} {
sl@0	294	# -setup {
sl@0	295	# set constraintlist $::tcltest::constraintsSpecified
sl@0	296	# set ::tcltest::constraintsSpecified {}
sl@0	297	# }
sl@0	298	# -body {
sl@0	299	# set r1 $::tcltest::constraintsSpecified
sl@0	300	# testConstraint tcltestFakeConstraint1 1
sl@0	301	# set r2 $::tcltest::constraintsSpecified
sl@0	302	# testConstraint tcltestFakeConstraint2 1
sl@0	303	# set r3 $::tcltest::constraintsSpecified
sl@0	304	# list $r1 $r2 $r3
sl@0	305	# }
sl@0	306	# -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}}
sl@0	307	# -cleanup {
sl@0	308	# set ::tcltest::constraintsSpecified $constraintlist
sl@0	309	# unset ::tcltest::testConstraints(tcltestFakeConstraint1)
sl@0	310	# unset ::tcltest::testConstraints(tcltestFakeConstraint2)
sl@0	311	# }
sl@0	312	#}
sl@0	313
sl@0	314	test tcltest-5.5 {InitConstraints: list of built-in constraints} \
sl@0	315	-constraints {!singleTestInterp} \
sl@0	316	-setup {tcltest::InitConstraints} \
sl@0	317	-body { lsort [array names ::tcltest::testConstraints] } \
sl@0	318	-result [lsort {
sl@0	319	95 98 asyncPipeClose eformat emptyTest exec hasIsoLocale interactive
sl@0	320	knownBug mac macCrash macOnly macOrPc macOrUnix macOrWin nonBlockFiles
sl@0	321	nonPortable notRoot nt pc pcCrash pcOnly root singleTestInterp socket
sl@0	322	stdio tempNotMac tempNotPc tempNotUnix tempNotWin unix unixCrash unixExecs
sl@0	323	unixOnly unixOrPc unixOrWin userInteraction win winCrash winOnly
sl@0	324	}]
sl@0	325
sl@0	326	# Removed this broken test. Its usage of [limitConstraints] was not
sl@0	327	# in agreement with the documentation. [limitConstraints] is supposed
sl@0	328	# to take an optional boolean argument, and "knownBug" ain't no boolean!
sl@0	329	#test tcltest-5.6 {tcltest::limitConstraints} {
sl@0	330	# -setup {
sl@0	331	# set keeplc $::tcltest::limitConstraints
sl@0	332	# set keepkb [testConstraint knownBug]
sl@0	333	# }
sl@0	334	# -body {
sl@0	335	# set r1 [limitConstraints]
sl@0	336	# set r2 [limitConstraints knownBug]
sl@0	337	# set r3 [limitConstraints]
sl@0	338	# list $r1 $r2 $r3
sl@0	339	# }
sl@0	340	# -cleanup {
sl@0	341	# limitConstraints $keeplc
sl@0	342	# testConstraint knownBug $keepkb
sl@0	343	# }
sl@0	344	# -result {false knownBug knownBug}
sl@0	345	#}
sl@0	346
sl@0	347	# -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile]
sl@0	348	set printerror [makeFile {
sl@0	349	package require tcltest
sl@0	350	namespace import ::tcltest::*
sl@0	351	puts [outputChannel] "a test"
sl@0	352	::tcltest::PrintError "a really short string"
sl@0	353	::tcltest::PrintError "a really really really really really really long \
sl@0	354	string containing \"quotes\" and other bad bad stuff"
sl@0	355	::tcltest::PrintError "a really really long string containing a \
sl@0	356	\"Path/that/is/really/long/and/contains/no/spaces\""
sl@0	357	::tcltest::PrintError "a really really long string containing a \
sl@0	358	\"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\""
sl@0	359	::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
sl@0	360	exit
sl@0	361	} printerror.tcl]
sl@0	362
sl@0	363	test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
sl@0	364	-constraints unixOrPc
sl@0	365	-body {
sl@0	366	slave msg $printerror
sl@0	367	return $msg
sl@0	368	}
sl@0	369	-result {a test.*a really}
sl@0	370	-match regexp
sl@0	371	}
sl@0	372	test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} {
sl@0	373	slave msg $printerror -outfile a.tmp
sl@0	374	set result1 [catch {exec grep "a test" a.tmp}]
sl@0	375	set result2 [catch {exec grep "a really" a.tmp}]
sl@0	376	list [regexp "a test" $msg] [regexp "a really" $msg] \
sl@0	377	$result1 $result2 [file exists a.tmp] [file delete a.tmp]
sl@0	378	} {0 1 0 1 1 {}}
sl@0	379	test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} {
sl@0	380	slave msg $printerror -errfile a.tmp
sl@0	381	set result1 [catch {exec grep "a test" a.tmp}]
sl@0	382	set result2 [catch {exec grep "a really" a.tmp}]
sl@0	383	list [regexp "a test" $msg] [regexp "a really" $msg] \
sl@0	384	$result1 $result2 [file exists a.tmp] [file delete a.tmp]
sl@0	385	} {1 0 1 0 1 {}}
sl@0	386	test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc unixExecs} {
sl@0	387	slave msg $printerror -outfile a.tmp -errfile b.tmp
sl@0	388	set result1 [catch {exec grep "a test" a.tmp}]
sl@0	389	set result2 [catch {exec grep "a really" b.tmp}]
sl@0	390	list [regexp "a test" $msg] [regexp "a really" $msg] \
sl@0	391	$result1 $result2 \
sl@0	392	[file exists a.tmp] [file delete a.tmp] \
sl@0	393	[file exists b.tmp] [file delete b.tmp]
sl@0	394	} {0 0 0 0 1 {} 1 {}}
sl@0	395
sl@0	396	test tcltest-6.5 {tcltest::errorChannel - retrieval} {
sl@0	397	-setup {
sl@0	398	set of [errorChannel]
sl@0	399	set ::tcltest::errorChannel stderr
sl@0	400	}
sl@0	401	-body {
sl@0	402	errorChannel
sl@0	403	}
sl@0	404	-result {stderr}
sl@0	405	-cleanup {
sl@0	406	set ::tcltest::errorChannel $of
sl@0	407	}
sl@0	408	}
sl@0	409
sl@0	410	test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} {
sl@0	411	-setup {
sl@0	412	set ef [makeFile {} efile]
sl@0	413	set of [errorFile]
sl@0	414	set ::tcltest::errorChannel stderr
sl@0	415	set ::tcltest::errorFile stderr
sl@0	416	}
sl@0	417	-body {
sl@0	418	set f0 [errorChannel]
sl@0	419	set f1 [errorFile]
sl@0	420	set f2 [errorFile $ef]
sl@0	421	set f3 [errorChannel]
sl@0	422	set f4 [errorFile]
sl@0	423	subst {$f0;$f1;$f2;$f3;$f4}
sl@0	424	}
sl@0	425	-result {stderr;stderr;.efile;file[0-9a-f]+;.efile}
sl@0	426	-match regexp
sl@0	427	-cleanup {
sl@0	428	errorFile $of
sl@0	429	removeFile efile
sl@0	430	}
sl@0	431	}
sl@0	432	test tcltest-6.7 {tcltest::outputChannel - retrieval} {
sl@0	433	-setup {
sl@0	434	set of [outputChannel]
sl@0	435	set ::tcltest::outputChannel stdout
sl@0	436	}
sl@0	437	-body {
sl@0	438	outputChannel
sl@0	439	}
sl@0	440	-result {stdout}
sl@0	441	-cleanup {
sl@0	442	set tcltest::outputChannel $of
sl@0	443	}
sl@0	444	}
sl@0	445
sl@0	446	test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} {
sl@0	447	-setup {
sl@0	448	set ef [makeFile {} efile]
sl@0	449	set of [outputFile]
sl@0	450	set ::tcltest::outputChannel stdout
sl@0	451	set ::tcltest::outputFile stdout
sl@0	452	}
sl@0	453	-body {
sl@0	454	set f0 [outputChannel]
sl@0	455	set f1 [outputFile]
sl@0	456	set f2 [outputFile $ef]
sl@0	457	set f3 [outputChannel]
sl@0	458	set f4 [outputFile]
sl@0	459	subst {$f0;$f1;$f2;$f3;$f4}
sl@0	460	}
sl@0	461	-result {stdout;stdout;.efile;file[0-9a-f]+;.efile}
sl@0	462	-match regexp
sl@0	463	-cleanup {
sl@0	464	outputFile $of
sl@0	465	removeFile efile
sl@0	466	}
sl@0	467	}
sl@0	468
sl@0	469	# -debug, [debug]
sl@0	470	# Must use child processes to test -debug because it always writes
sl@0	471	# messages to stdout, and we have no way to capture stdout of a
sl@0	472	# slave interp
sl@0	473	test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} {
sl@0	474	catch {exec [interpreter] test.tcl -debug 0} msg
sl@0	475	regexp "Flags passed into tcltest" $msg
sl@0	476	} {0}
sl@0	477	test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} {
sl@0	478	catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg
sl@0	479	list [regexp userSpecifiedSkip $msg] \
sl@0	480	[regexp "Flags passed into tcltest" $msg]
sl@0	481	} {1 0}
sl@0	482	test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrPc} {
sl@0	483	catch {exec [interpreter] test.tcl -debug 1 -match b*} msg
sl@0	484	list [regexp userSpecifiedNonMatch $msg] \
sl@0	485	[regexp "Flags passed into tcltest" $msg]
sl@0	486	} {1 0}
sl@0	487	test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrPc} {
sl@0	488	catch {exec [interpreter] test.tcl -debug 2} msg
sl@0	489	list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
sl@0	490	} {1 0}
sl@0	491	test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrPc} {
sl@0	492	catch {exec [interpreter] test.tcl -debug 3} msg
sl@0	493	list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
sl@0	494	} {1 1}
sl@0	495
sl@0	496	test tcltest-7.6 {tcltest::debug} {
sl@0	497	-setup {
sl@0	498	set old $::tcltest::debug
sl@0	499	set ::tcltest::debug 0
sl@0	500	}
sl@0	501	-body {
sl@0	502	set f1 [debug]
sl@0	503	set f2 [debug 1]
sl@0	504	set f3 [debug]
sl@0	505	set f4 [debug 2]
sl@0	506	set f5 [debug]
sl@0	507	list $f1 $f2 $f3 $f4 $f5
sl@0	508	}
sl@0	509	-result {0 1 1 2 2}
sl@0	510	-cleanup {
sl@0	511	set ::tcltest::debug $old
sl@0	512	}
sl@0	513	}
sl@0	514	removeFile test.tcl
sl@0	515
sl@0	516	# directory tests
sl@0	517
sl@0	518	set a [makeFile {
sl@0	519	package require tcltest
sl@0	520	tcltest::makeFile {} a.tmp
sl@0	521	puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]"
sl@0	522	exit
sl@0	523	} a.tcl]
sl@0	524
sl@0	525	set tdiaf [makeFile {} thisdirectoryisafile]
sl@0	526
sl@0	527	set normaldirectory [makeDirectory normaldirectory]
sl@0	528	normalizePath normaldirectory
sl@0	529
sl@0	530	# -tmpdir, [temporaryDirectory]
sl@0	531	test tcltest-8.1 {tcltest a.tcl -tmpdir a} {unixOrPc} {
sl@0	532	file delete -force thisdirectorydoesnotexist
sl@0	533	slave msg $a -tmpdir thisdirectorydoesnotexist
sl@0	534	list [file exists [file join thisdirectorydoesnotexist a.tmp]] \
sl@0	535	[file delete -force thisdirectorydoesnotexist]
sl@0	536	} {1 {}}
sl@0	537	test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
sl@0	538	-constraints unixOrPc
sl@0	539	-body {
sl@0	540	slave msg $a -tmpdir $tdiaf
sl@0	541	set msg
sl@0	542	}
sl@0	543	-result {not a directory}
sl@0	544	-match glob
sl@0	545	}
sl@0	546
sl@0	547	# Test non-writeable directories, non-readable directories with directory flags
sl@0	548	set notReadableDir [file join [temporaryDirectory] notreadable]
sl@0	549	set notWriteableDir [file join [temporaryDirectory] notwriteable]
sl@0	550
sl@0	551	makeDirectory notreadable
sl@0	552	makeDirectory notwriteable
sl@0	553
sl@0	554	switch $tcl_platform(platform) {
sl@0	555	"unix" {
sl@0	556	file attributes $notReadableDir -permissions 00333
sl@0	557	file attributes $notWriteableDir -permissions 00555
sl@0	558	}
sl@0	559	default {
sl@0	560	catch {file attributes $notWriteableDir -readonly 1}
sl@0	561	catch {testchmod 000 $notWriteableDir}
sl@0	562	}
sl@0	563	}
sl@0	564
sl@0	565	test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unix notRoot} {
sl@0	566	slave msg $a -tmpdir $notReadableDir
sl@0	567	string match {not readable} $msg
sl@0	568	} {1}
sl@0	569
sl@0	570	test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc notRoot} {
sl@0	571	slave msg $a -tmpdir $notWriteableDir
sl@0	572	string match {not writeable} $msg
sl@0	573	} {1}
sl@0	574
sl@0	575	test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {unixOrPc} {
sl@0	576	slave msg $a -tmpdir $normaldirectory
sl@0	577	# The join is necessary because the message can be split on multiple lines
sl@0	578	list [file exists [file join $normaldirectory a.tmp]] \
sl@0	579	[file delete [file join $normaldirectory a.tmp]]
sl@0	580	} {1 {}}
sl@0	581	cd [workingDirectory]
sl@0	582
sl@0	583	test tcltest-8.6 {temporaryDirectory} {
sl@0	584	-setup {
sl@0	585	set old $::tcltest::temporaryDirectory
sl@0	586	set ::tcltest::temporaryDirectory $normaldirectory
sl@0	587	}
sl@0	588	-body {
sl@0	589	set f1 [temporaryDirectory]
sl@0	590	set f2 [temporaryDirectory [workingDirectory]]
sl@0	591	set f3 [temporaryDirectory]
sl@0	592	list $f1 $f2 $f3
sl@0	593	}
sl@0	594	-result "[list $normaldirectory [workingDirectory] [workingDirectory]]"
sl@0	595	-cleanup {
sl@0	596	set ::tcltest::temporaryDirectory $old
sl@0	597	}
sl@0	598	}
sl@0	599
sl@0	600	test tcltest-8.6a {temporaryDirectory - test format 2} -setup {
sl@0	601	set old $::tcltest::temporaryDirectory
sl@0	602	set ::tcltest::temporaryDirectory $normaldirectory
sl@0	603	} -body {
sl@0	604	set f1 [temporaryDirectory]
sl@0	605	set f2 [temporaryDirectory [workingDirectory]]
sl@0	606	set f3 [temporaryDirectory]
sl@0	607	list $f1 $f2 $f3
sl@0	608	} -cleanup {
sl@0	609	set ::tcltest::temporaryDirectory $old
sl@0	610	} -result [list $normaldirectory [workingDirectory] [workingDirectory]]
sl@0	611
sl@0	612	cd [temporaryDirectory]
sl@0	613	# -testdir, [testsDirectory]
sl@0	614	test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {unixOrPc} {
sl@0	615	file delete -force thisdirectorydoesnotexist
sl@0	616	slave msg $a -testdir thisdirectorydoesnotexist
sl@0	617	string match "does not exist" $msg
sl@0	618	} {1}
sl@0	619
sl@0	620	test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {unixOrPc} {
sl@0	621	slave msg $a -testdir $tdiaf
sl@0	622	string match "not a directory" $msg
sl@0	623	} {1}
sl@0	624
sl@0	625	test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {unix notRoot} {
sl@0	626	slave msg $a -testdir $notReadableDir
sl@0	627	string match {not readable} $msg
sl@0	628	} {1}
sl@0	629
sl@0	630
sl@0	631	test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {unixOrPc} {
sl@0	632	slave msg $a -testdir $normaldirectory
sl@0	633	# The join is necessary because the message can be split on multiple lines
sl@0	634	list [string first "testdir: $normaldirectory" [join $msg]] \
sl@0	635	[file exists [file join [temporaryDirectory] a.tmp]] \
sl@0	636	[file delete [file join [temporaryDirectory] a.tmp]]
sl@0	637	} {0 1 {}}
sl@0	638	cd [workingDirectory]
sl@0	639
sl@0	640	set current [pwd]
sl@0	641	test tcltest-8.14 {testsDirectory} {
sl@0	642	-setup {
sl@0	643	set old $::tcltest::testsDirectory
sl@0	644	set ::tcltest::testsDirectory $normaldirectory
sl@0	645	}
sl@0	646	-body {
sl@0	647	set f1 [testsDirectory]
sl@0	648	set f2 [testsDirectory $current]
sl@0	649	set f3 [testsDirectory]
sl@0	650	list $f1 $f2 $f3
sl@0	651	}
sl@0	652	-result "[list $normaldirectory $current $current]"
sl@0	653	-cleanup {
sl@0	654	set ::tcltest::testsDirectory $old
sl@0	655	}
sl@0	656	}
sl@0	657
sl@0	658	# [workingDirectory]
sl@0	659	test tcltest-8.60 {::workingDirectory} {
sl@0	660	-setup {
sl@0	661	set old $::tcltest::workingDirectory
sl@0	662	set current [pwd]
sl@0	663	set ::tcltest::workingDirectory $normaldirectory
sl@0	664	cd $normaldirectory
sl@0	665	}
sl@0	666	-body {
sl@0	667	set f1 [workingDirectory]
sl@0	668	set f2 [pwd]
sl@0	669	set f3 [workingDirectory $current]
sl@0	670	set f4 [pwd]
sl@0	671	set f5 [workingDirectory]
sl@0	672	list $f1 $f2 $f3 $f4 $f5
sl@0	673	}
sl@0	674	-result "[list $normaldirectory \
sl@0	675	$normaldirectory \
sl@0	676	$current \
sl@0	677	$current \
sl@0	678	$current]"
sl@0	679	-cleanup {
sl@0	680	set ::tcltest::workingDirectory $old
sl@0	681	cd $current
sl@0	682	}
sl@0	683	}
sl@0	684
sl@0	685	# clean up from directory testing
sl@0	686
sl@0	687	switch $tcl_platform(platform) {
sl@0	688	"unix" {
sl@0	689	file attributes $notReadableDir -permissions 777
sl@0	690	file attributes $notWriteableDir -permissions 777
sl@0	691	}
sl@0	692	default {
sl@0	693	catch {file attributes $notWriteableDir -readonly 0}
sl@0	694	}
sl@0	695	}
sl@0	696
sl@0	697	file delete -force $notReadableDir $notWriteableDir
sl@0	698	removeFile a.tcl
sl@0	699	removeFile thisdirectoryisafile
sl@0	700	removeDirectory normaldirectory
sl@0	701
sl@0	702	# -file, -notfile, [matchFiles], [skipFiles]
sl@0	703	test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup {
sl@0	704	set old [testsDirectory]
sl@0	705	testsDirectory [file dirname [info script]]
sl@0	706	} -body {
sl@0	707	slave msg [file join [testsDirectory] all.tcl] -file d*.test
sl@0	708	set msg
sl@0	709	} -cleanup {
sl@0	710	testsDirectory $old
sl@0	711	} -match regexp -result {dstring\.test}
sl@0	712
sl@0	713	test tcltest-9.2 {-file d*.tcl} -constraints {unixOrPc} -setup {
sl@0	714	set old [testsDirectory]
sl@0	715	testsDirectory [file dirname [info script]]
sl@0	716	} -body {
sl@0	717	slave msg [file join [testsDirectory] all.tcl] \
sl@0	718	-file d.test -notfile dstring
sl@0	719	regexp {dstring\.test} $msg
sl@0	720	} -cleanup {
sl@0	721	testsDirectory $old
sl@0	722	} -result 0
sl@0	723
sl@0	724	test tcltest-9.3 {matchFiles} {
sl@0	725	-body {
sl@0	726	set old [matchFiles]
sl@0	727	matchFiles foo
sl@0	728	set current [matchFiles]
sl@0	729	matchFiles bar
sl@0	730	set new [matchFiles]
sl@0	731	matchFiles $old
sl@0	732	list $current $new
sl@0	733	}
sl@0	734	-result {foo bar}
sl@0	735	}
sl@0	736
sl@0	737	test tcltest-9.4 {skipFiles} {
sl@0	738	-body {
sl@0	739	set old [skipFiles]
sl@0	740	skipFiles foo
sl@0	741	set current [skipFiles]
sl@0	742	skipFiles bar
sl@0	743	set new [skipFiles]
sl@0	744	skipFiles $old
sl@0	745	list $current $new
sl@0	746	}
sl@0	747	-result {foo bar}
sl@0	748	}
sl@0	749
sl@0	750	test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup {
sl@0	751	set d [makeDirectory tmp]
sl@0	752	makeDirectory foo $d
sl@0	753	makeFile {} fee $d
sl@0	754	file copy [file join [file dirname [info script]] all.tcl] $d
sl@0	755	} -body {
sl@0	756	slave msg [file join [temporaryDirectory] all.tcl] -file f*
sl@0	757	regexp {exiting with errors:} $msg
sl@0	758	} -cleanup {
sl@0	759	file delete [file join $d all.tcl]
sl@0	760	removeFile fee $d
sl@0	761	removeDirectory foo $d
sl@0	762	removeDirectory tmp
sl@0	763	} -result 0
sl@0	764
sl@0	765	# -preservecore, [preserveCore]
sl@0	766	set mc [makeFile {
sl@0	767	package require tcltest
sl@0	768	namespace import ::tcltest::test
sl@0	769	test makecore {make a core file} {
sl@0	770	set f [open core w]
sl@0	771	close $f
sl@0	772	} {}
sl@0	773	::tcltest::cleanupTests
sl@0	774	return
sl@0	775	} makecore.tcl]
sl@0	776
sl@0	777	cd [temporaryDirectory]
sl@0	778	test tcltest-10.1 {-preservecore 0} {unixOrPc} {
sl@0	779	slave msg $mc -preservecore 0
sl@0	780	file delete core
sl@0	781	regexp "Core file produced" $msg
sl@0	782	} {0}
sl@0	783	test tcltest-10.2 {-preservecore 1} {unixOrPc} {
sl@0	784	slave msg $mc -preservecore 1
sl@0	785	file delete core
sl@0	786	regexp "Core file produced" $msg
sl@0	787	} {1}
sl@0	788	test tcltest-10.3 {-preservecore 2} {unixOrPc} {
sl@0	789	slave msg $mc -preservecore 2
sl@0	790	file delete core
sl@0	791	list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
sl@0	792	[regexp "core-" $msg] [file delete core-makecore]
sl@0	793	} {1 1 1 {}}
sl@0	794	test tcltest-10.4 {-preservecore 3} {unixOrPc} {
sl@0	795	slave msg $mc -preservecore 3
sl@0	796	file delete core
sl@0	797	list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
sl@0	798	[regexp "core-" $msg] [file delete core-makecore]
sl@0	799	} {1 1 1 {}}
sl@0	800
sl@0	801	# Removing this test. It makes no sense to test the ability of
sl@0	802	# [preserveCore] to accept an invalid value that will cause errors
sl@0	803	# in other parts of tcltest's operation.
sl@0	804	#test tcltest-10.5 {preserveCore} {
sl@0	805	# -body {
sl@0	806	# set old [preserveCore]
sl@0	807	# set result [preserveCore foo]
sl@0	808	# set result2 [preserveCore]
sl@0	809	# preserveCore $old
sl@0	810	# list $result $result2
sl@0	811	# }
sl@0	812	# -result {foo foo}
sl@0	813	#}
sl@0	814	removeFile makecore.tcl
sl@0	815
sl@0	816	# -load, -loadfile, [loadScript], [loadFile]
sl@0	817	set contents {
sl@0	818	package require tcltest
sl@0	819	namespace import tcltest::*
sl@0	820	puts [outputChannel] $::tcltest::loadScript
sl@0	821	exit
sl@0	822	}
sl@0	823	set loadfile [makeFile $contents load.tcl]
sl@0	824
sl@0	825	test tcltest-12.1 {-load xxx} {unixOrPc} {
sl@0	826	slave msg $loadfile -load xxx
sl@0	827	set msg
sl@0	828	} {xxx}
sl@0	829
sl@0	830	# Using child process because of -debug usage.
sl@0	831	test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} {
sl@0	832	catch {exec [interpreter] $loadfile -debug 2 -loadfile $loadfile} msg
sl@0	833	list \
sl@0	834	[regexp {tcltest} [join [list $msg] [split $msg \n]]] \
sl@0	835	[regexp {loadScript} [join [list $msg] [split $msg \n]]]
sl@0	836	} {1 1}
sl@0	837
sl@0	838	test tcltest-12.3 {loadScript} {
sl@0	839	-setup {
sl@0	840	set old $::tcltest::loadScript
sl@0	841	set ::tcltest::loadScript {}
sl@0	842	}
sl@0	843	-body {
sl@0	844	set f1 [loadScript]
sl@0	845	set f2 [loadScript xxx]
sl@0	846	set f3 [loadScript]
sl@0	847	list $f1 $f2 $f3
sl@0	848	}
sl@0	849	-result {{} xxx xxx}
sl@0	850	-cleanup {
sl@0	851	set ::tcltest::loadScript $old
sl@0	852	}
sl@0	853	}
sl@0	854
sl@0	855	test tcltest-12.4 {loadFile} {
sl@0	856	-setup {
sl@0	857	set olds $::tcltest::loadScript
sl@0	858	set ::tcltest::loadScript {}
sl@0	859	set oldf $::tcltest::loadFile
sl@0	860	set ::tcltest::loadFile {}
sl@0	861	}
sl@0	862	-body {
sl@0	863	set f1 [loadScript]
sl@0	864	set f2 [loadFile]
sl@0	865	set f3 [loadFile $loadfile]
sl@0	866	set f4 [loadScript]
sl@0	867	set f5 [loadFile]
sl@0	868	list $f1 $f2 $f3 $f4 $f5
sl@0	869	}
sl@0	870	-result "[list {} {} $loadfile $contents $loadfile]\n"
sl@0	871	-cleanup {
sl@0	872	set ::tcltest::loadScript $olds
sl@0	873	set ::tcltest::loadFile $oldf
sl@0	874	}
sl@0	875	}
sl@0	876	removeFile load.tcl
sl@0	877
sl@0	878	# [interpreter]
sl@0	879	test tcltest-13.1 {interpreter} {
sl@0	880	-setup {
sl@0	881	set old $::tcltest::tcltest
sl@0	882	set ::tcltest::tcltest tcltest
sl@0	883	}
sl@0	884	-body {
sl@0	885	set f1 [interpreter]
sl@0	886	set f2 [interpreter tclsh]
sl@0	887	set f3 [interpreter]
sl@0	888	list $f1 $f2 $f3
sl@0	889	}
sl@0	890	-result {tcltest tclsh tclsh}
sl@0	891	-cleanup {
sl@0	892	set ::tcltest::tcltest $old
sl@0	893	}
sl@0	894	}
sl@0	895
sl@0	896	# -singleproc, [singleProcess]
sl@0	897	set spd [makeDirectory singleprocdir]
sl@0	898	makeFile {
sl@0	899	set foo 1
sl@0	900	} single1.test $spd
sl@0	901
sl@0	902	makeFile {
sl@0	903	unset foo
sl@0	904	} single2.test $spd
sl@0	905
sl@0	906	set allfile [makeFile {
sl@0	907	package require tcltest
sl@0	908	namespace import tcltest::*
sl@0	909	testsDirectory [file join [temporaryDirectory] singleprocdir]
sl@0	910	runAllTests
sl@0	911	} all-single.tcl $spd]
sl@0	912	cd [workingDirectory]
sl@0	913
sl@0	914	test tcltest-14.1 {-singleproc - single process} {
sl@0	915	-constraints {unixOrPc}
sl@0	916	-body {
sl@0	917	slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
sl@0	918	set msg
sl@0	919	}
sl@0	920	-result {Test file error: can't unset .foo.: no such variable}
sl@0	921	-match regexp
sl@0	922	}
sl@0	923
sl@0	924	test tcltest-14.2 {-singleproc - multiple process} {
sl@0	925	-constraints {unixOrPc}
sl@0	926	-body {
sl@0	927	slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory]
sl@0	928	set msg
sl@0	929	}
sl@0	930	-result {single1.test.single2.test.all\-single.tcl:.Total.0.Passed.0.Skipped.0.Failed.0}
sl@0	931	-match regexp
sl@0	932	}
sl@0	933
sl@0	934	test tcltest-14.3 {singleProcess} {
sl@0	935	-setup {
sl@0	936	set old $::tcltest::singleProcess
sl@0	937	set ::tcltest::singleProcess 0
sl@0	938	}
sl@0	939	-body {
sl@0	940	set f1 [singleProcess]
sl@0	941	set f2 [singleProcess 1]
sl@0	942	set f3 [singleProcess]
sl@0	943	list $f1 $f2 $f3
sl@0	944	}
sl@0	945	-result {0 1 1}
sl@0	946	-cleanup {
sl@0	947	set ::tcltest::singleProcess $old
sl@0	948	}
sl@0	949	}
sl@0	950	removeFile single1.test $spd
sl@0	951	removeFile single2.test $spd
sl@0	952	removeDirectory singleprocdir
sl@0	953
sl@0	954	# -asidefromdir, -relateddir, [matchDirectories], [skipDirectories]
sl@0	955
sl@0	956	# Before running these tests, need to set up test subdirectories with their own
sl@0	957	# all.tcl files.
sl@0	958
sl@0	959	set dtd [makeDirectory dirtestdir]
sl@0	960	set dtd1 [makeDirectory dirtestdir2.1 $dtd]
sl@0	961	set dtd2 [makeDirectory dirtestdir2.2 $dtd]
sl@0	962	set dtd3 [makeDirectory dirtestdir2.3 $dtd]
sl@0	963	makeFile {
sl@0	964	package require tcltest
sl@0	965	namespace import -force tcltest::*
sl@0	966	testsDirectory [file join [temporaryDirectory] dirtestdir]
sl@0	967	runAllTests
sl@0	968	} all.tcl $dtd
sl@0	969	makeFile {
sl@0	970	package require tcltest
sl@0	971	namespace import -force tcltest::*
sl@0	972	testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1]
sl@0	973	runAllTests
sl@0	974	} all.tcl $dtd1
sl@0	975	makeFile {
sl@0	976	package require tcltest
sl@0	977	namespace import -force tcltest::*
sl@0	978	testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.2]
sl@0	979	runAllTests
sl@0	980	} all.tcl $dtd2
sl@0	981	makeFile {
sl@0	982	package require tcltest
sl@0	983	namespace import -force tcltest::*
sl@0	984	testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3]
sl@0	985	runAllTests
sl@0	986	} all.tcl $dtd3
sl@0	987
sl@0	988	test tcltest-15.1 {basic directory walking} {
sl@0	989	-constraints {unixOrPc}
sl@0	990	-body {
sl@0	991	if {[slave msg \
sl@0	992	[file join $dtd all.tcl] \
sl@0	993	-tmpdir [temporaryDirectory]] == 1} {
sl@0	994	error $msg
sl@0	995	}
sl@0	996	}
sl@0	997	-match regexp
sl@0	998	-returnCodes 1
sl@0	999	-result {Tests located in:.dirtestdir.Tests located in:.dirtestdir2.[123].Tests located in:.dirtestdir2.[123].Tests located in:.*dirtestdir2.[123]}
sl@0	1000	}
sl@0	1001
sl@0	1002	test tcltest-15.2 {-asidefromdir} {
sl@0	1003	-constraints {unixOrPc}
sl@0	1004	-body {
sl@0	1005	if {[slave msg \
sl@0	1006	[file join $dtd all.tcl] \
sl@0	1007	-asidefromdir dirtestdir2.3 \
sl@0	1008	-tmpdir [temporaryDirectory]] == 1} {
sl@0	1009	error $msg
sl@0	1010	}
sl@0	1011	}
sl@0	1012	-match regexp
sl@0	1013	-returnCodes 1
sl@0	1014	-result {Tests located in:.dirtestdir.Tests located in:.dirtestdir2.[12].Tests located in:.dirtestdir2.[12].dirtestdir2.[12] test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sl@0	1015	Error: No test files remain after applying your match and skip patterns!
sl@0	1016	Error: No test files remain after applying your match and skip patterns!
sl@0	1017	Error: No test files remain after applying your match and skip patterns!$}
sl@0	1018	}
sl@0	1019
sl@0	1020	test tcltest-15.3 {-relateddir, non-existent dir} {
sl@0	1021	-constraints {unixOrPc}
sl@0	1022	-body {
sl@0	1023	if {[slave msg \
sl@0	1024	[file join $dtd all.tcl] \
sl@0	1025	-relateddir [file join [temporaryDirectory] dirtestdir0] \
sl@0	1026	-tmpdir [temporaryDirectory]] == 1} {
sl@0	1027	error $msg
sl@0	1028	}
sl@0	1029	}
sl@0	1030	-returnCodes 1
sl@0	1031	-match regexp
sl@0	1032	-result {[^~]\|dirtestdir[^2]}
sl@0	1033	}
sl@0	1034
sl@0	1035	test tcltest-15.4 {-relateddir, subdir} {
sl@0	1036	-constraints {unixOrPc}
sl@0	1037	-body {
sl@0	1038	if {[slave msg \
sl@0	1039	[file join $dtd all.tcl] \
sl@0	1040	-relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} {
sl@0	1041	error $msg
sl@0	1042	}
sl@0	1043	}
sl@0	1044	-returnCodes 1
sl@0	1045	-match regexp
sl@0	1046	-result {Tests located in:.*dirtestdir2.[^23]}
sl@0	1047	}
sl@0	1048	test tcltest-15.5 {-relateddir, -asidefromdir} {
sl@0	1049	-constraints {unixOrPc}
sl@0	1050	-body {
sl@0	1051	if {[slave msg \
sl@0	1052	[file join $dtd all.tcl] \
sl@0	1053	-relateddir "dirtestdir2.1 dirtestdir2.2" \
sl@0	1054	-asidefromdir dirtestdir2.2 \
sl@0	1055	-tmpdir [temporaryDirectory]] == 1} {
sl@0	1056	error $msg
sl@0	1057	}
sl@0	1058	}
sl@0	1059	-match regexp
sl@0	1060	-returnCodes 1
sl@0	1061	-result {Tests located in:.*dirtestdir2.[^23]}
sl@0	1062	}
sl@0	1063
sl@0	1064	test tcltest-15.6 {matchDirectories} {
sl@0	1065	-setup {
sl@0	1066	set old [matchDirectories]
sl@0	1067	set ::tcltest::matchDirectories {}
sl@0	1068	}
sl@0	1069	-body {
sl@0	1070	set r1 [matchDirectories]
sl@0	1071	set r2 [matchDirectories foo]
sl@0	1072	set r3 [matchDirectories]
sl@0	1073	list $r1 $r2 $r3
sl@0	1074	}
sl@0	1075	-cleanup {
sl@0	1076	set ::tcltest::matchDirectories $old
sl@0	1077	}
sl@0	1078	-result {{} foo foo}
sl@0	1079	}
sl@0	1080
sl@0	1081	test tcltest-15.7 {skipDirectories} {
sl@0	1082	-setup {
sl@0	1083	set old [skipDirectories]
sl@0	1084	set ::tcltest::skipDirectories {}
sl@0	1085	}
sl@0	1086	-body {
sl@0	1087	set r1 [skipDirectories]
sl@0	1088	set r2 [skipDirectories foo]
sl@0	1089	set r3 [skipDirectories]
sl@0	1090	list $r1 $r2 $r3
sl@0	1091	}
sl@0	1092	-cleanup {
sl@0	1093	set ::tcltest::skipDirectories $old
sl@0	1094	}
sl@0	1095	-result {{} foo foo}
sl@0	1096	}
sl@0	1097	removeDirectory dirtestdir2.3 $dtd
sl@0	1098	removeDirectory dirtestdir2.2 $dtd
sl@0	1099	removeDirectory dirtestdir2.1 $dtd
sl@0	1100	removeDirectory dirtestdir
sl@0	1101
sl@0	1102	# TCLTEST_OPTIONS
sl@0	1103	test tcltest-19.1 {TCLTEST_OPTIONS default} -setup {
sl@0	1104	if {[info exists ::env(TCLTEST_OPTIONS)]} {
sl@0	1105	set oldoptions $::env(TCLTEST_OPTIONS)
sl@0	1106	} else {
sl@0	1107	set oldoptions none
sl@0	1108	}
sl@0	1109	# set this to { } instead of just {} to get around quirk in
sl@0	1110	# Windows env handling that removes empty elements from env array.
sl@0	1111	set ::env(TCLTEST_OPTIONS) { }
sl@0	1112	interp create slave1
sl@0	1113	slave1 eval [list set argv {-debug 2}]
sl@0	1114	slave1 alias puts puts
sl@0	1115	interp create slave2
sl@0	1116	slave2 alias puts puts
sl@0	1117	} -cleanup {
sl@0	1118	interp delete slave2
sl@0	1119	interp delete slave1
sl@0	1120	if {$oldoptions == "none"} {
sl@0	1121	unset ::env(TCLTEST_OPTIONS)
sl@0	1122	} else {
sl@0	1123	set ::env(TCLTEST_OPTIONS) $oldoptions
sl@0	1124	}
sl@0	1125	} -body {
sl@0	1126	slave1 eval [package ifneeded tcltest [package provide tcltest]]
sl@0	1127	slave1 eval tcltest::debug
sl@0	1128	set ::env(TCLTEST_OPTIONS) "-debug 3"
sl@0	1129	slave2 eval [package ifneeded tcltest [package provide tcltest]]
sl@0	1130	slave2 eval tcltest::debug
sl@0	1131	} -result {^3$} -match regexp -output\
sl@0	1132	{tcltest::debug\s+= 2.*tcltest::debug\s+= 3}
sl@0	1133
sl@0	1134	# Begin testing of tcltest procs ...
sl@0	1135
sl@0	1136	cd [temporaryDirectory]
sl@0	1137	# PrintError
sl@0	1138	test tcltest-20.1 {PrintError} {unixOrPc} {
sl@0	1139	set result [slave msg $printerror]
sl@0	1140	list $result [regexp "Error: a really short string" $msg] \
sl@0	1141	[regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \
sl@0	1142	[regexp " \"Really" $msg] [regexp Problem $msg]
sl@0	1143	} {1 1 1 1 1 1}
sl@0	1144	cd [workingDirectory]
sl@0	1145	removeFile printerror.tcl
sl@0	1146
sl@0	1147	# test::test
sl@0	1148	test tcltest-21.0 {name and desc but no args specified} -setup {
sl@0	1149	set v [verbose]
sl@0	1150	} -cleanup {
sl@0	1151	verbose $v
sl@0	1152	} -body {
sl@0	1153	verbose {}
sl@0	1154	test tcltest-21.0.0 bar
sl@0	1155	} -result {}
sl@0	1156
sl@0	1157	test tcltest-21.1 {expect with glob} {
sl@0	1158	-body {
sl@0	1159	list a b c d e
sl@0	1160	}
sl@0	1161	-match glob
sl@0	1162	-result {[ab] b c d e}
sl@0	1163	}
sl@0	1164
sl@0	1165	test tcltest-21.2 {force a test command failure} {
sl@0	1166	-body {
sl@0	1167	test tcltest-21.2.0 {
sl@0	1168	return 2
sl@0	1169	} {1}
sl@0	1170	}
sl@0	1171	-returnCodes 1
sl@0	1172	-result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
sl@0	1173	}
sl@0	1174
sl@0	1175	test tcltest-21.3 {test command with setup} {
sl@0	1176	-setup {
sl@0	1177	set foo 1
sl@0	1178	}
sl@0	1179	-body {
sl@0	1180	set foo
sl@0	1181	}
sl@0	1182	-cleanup {unset foo}
sl@0	1183	-result {1}
sl@0	1184	}
sl@0	1185
sl@0	1186	test tcltest-21.4 {test command with cleanup failure} {
sl@0	1187	-setup {
sl@0	1188	if {[info exists foo]} {
sl@0	1189	unset foo
sl@0	1190	}
sl@0	1191	set fail $::tcltest::currentFailure
sl@0	1192	set v [verbose]
sl@0	1193	}
sl@0	1194	-body {
sl@0	1195	verbose {}
sl@0	1196	test tcltest-21.4.0 {foo-1} {
sl@0	1197	-cleanup {unset foo}
sl@0	1198	}
sl@0	1199	}
sl@0	1200	-result {^$}
sl@0	1201	-match regexp
sl@0	1202	-cleanup {verbose $v; set ::tcltest::currentFailure $fail}
sl@0	1203	-output "Test cleanup failed:.*can't unset \"foo\": no such variable"
sl@0	1204	}
sl@0	1205
sl@0	1206	test tcltest-21.5 {test command with setup failure} {
sl@0	1207	-setup {
sl@0	1208	if {[info exists foo]} {
sl@0	1209	unset foo
sl@0	1210	}
sl@0	1211	set fail $::tcltest::currentFailure
sl@0	1212	}
sl@0	1213	-body {
sl@0	1214	test tcltest-21.5.0 {foo-2} {
sl@0	1215	-setup {unset foo}
sl@0	1216	}
sl@0	1217	}
sl@0	1218	-result {^$}
sl@0	1219	-match regexp
sl@0	1220	-cleanup {set ::tcltest::currentFailure $fail}
sl@0	1221	-output "Test setup failed:.*can't unset \"foo\": no such variable"
sl@0	1222	}
sl@0	1223
sl@0	1224	test tcltest-21.6 {test command - setup occurs before cleanup & before script} {
sl@0	1225	-setup {set v [verbose]; set fail $::tcltest::currentFailure}
sl@0	1226	-body {
sl@0	1227	verbose {}
sl@0	1228	test tcltest-21.6.0 {foo-3} {
sl@0	1229	-setup {
sl@0	1230	if {[info exists foo]} {
sl@0	1231	unset foo
sl@0	1232	}
sl@0	1233	set foo 1
sl@0	1234	set expected 2
sl@0	1235	}
sl@0	1236	-body {
sl@0	1237	incr foo
sl@0	1238	set foo
sl@0	1239	}
sl@0	1240	-cleanup {
sl@0	1241	if {$foo != 2} {
sl@0	1242	puts [outputChannel] "foo is wrong"
sl@0	1243	} else {
sl@0	1244	puts [outputChannel] "foo is 2"
sl@0	1245	}
sl@0	1246	}
sl@0	1247	-result {$expected}
sl@0	1248	}
sl@0	1249	}
sl@0	1250	-cleanup {verbose $v; set ::tcltest::currentFailure $fail}
sl@0	1251	-result {^$}
sl@0	1252	-match regexp
sl@0	1253	-output "foo is 2"
sl@0	1254	}
sl@0	1255
sl@0	1256	test tcltest-21.7 {test command - bad flag} {
sl@0	1257	-setup {set fail $::tcltest::currentFailure}
sl@0	1258	-cleanup {set ::tcltest::currentFailure $fail}
sl@0	1259	-body {
sl@0	1260	test tcltest-21.7.0 {foo-4} {
sl@0	1261	-foobar {}
sl@0	1262	}
sl@0	1263	}
sl@0	1264	-returnCodes 1
sl@0	1265	-result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
sl@0	1266	}
sl@0	1267
sl@0	1268	# alternate test command format (these are the same as 21.1-21.6, with the
sl@0	1269	# exception of being in the all-inline format)
sl@0	1270
sl@0	1271	test tcltest-21.7a {expect with glob} \
sl@0	1272	-body {list a b c d e} \
sl@0	1273	-result {[ab] b c d e} \
sl@0	1274	-match glob
sl@0	1275
sl@0	1276	test tcltest-21.8 {force a test command failure} \
sl@0	1277	-setup {set fail $::tcltest::currentFailure} \
sl@0	1278	-body {
sl@0	1279	test tcltest-21.8.0 {
sl@0	1280	return 2
sl@0	1281	} {1}
sl@0	1282	} \
sl@0	1283	-returnCodes 1 \
sl@0	1284	-cleanup {set ::tcltest::currentFailure $fail} \
sl@0	1285	-result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
sl@0	1286
sl@0	1287	test tcltest-21.9 {test command with setup} \
sl@0	1288	-setup {set foo 1} \
sl@0	1289	-body {set foo} \
sl@0	1290	-cleanup {unset foo} \
sl@0	1291	-result {1}
sl@0	1292
sl@0	1293	test tcltest-21.10 {test command with cleanup failure} -setup {
sl@0	1294	if {[info exists foo]} {
sl@0	1295	unset foo
sl@0	1296	}
sl@0	1297	set fail $::tcltest::currentFailure
sl@0	1298	set v [verbose]
sl@0	1299	} -cleanup {
sl@0	1300	verbose $v
sl@0	1301	set ::tcltest::currentFailure $fail
sl@0	1302	} -body {
sl@0	1303	verbose {}
sl@0	1304	test tcltest-21.10.0 {foo-1} -cleanup {unset foo}
sl@0	1305	} -result {^$} -match regexp \
sl@0	1306	-output {Test cleanup failed:.*can't unset \"foo\": no such variable}
sl@0	1307
sl@0	1308	test tcltest-21.11 {test command with setup failure} -setup {
sl@0	1309	if {[info exists foo]} {
sl@0	1310	unset foo
sl@0	1311	}
sl@0	1312	set fail $::tcltest::currentFailure
sl@0	1313	} -cleanup {set ::tcltest::currentFailure $fail} -body {
sl@0	1314	test tcltest-21.11.0 {foo-2} -setup {unset foo}
sl@0	1315	} -result {^$} -output {Test setup failed:.*can't unset \"foo\": no such variable} -match regexp
sl@0	1316
sl@0	1317	test tcltest-21.12 {
sl@0	1318	test command - setup occurs before cleanup & before script
sl@0	1319	} -setup {
sl@0	1320	set fail $::tcltest::currentFailure
sl@0	1321	set v [verbose]
sl@0	1322	} -cleanup {
sl@0	1323	verbose $v
sl@0	1324	set ::tcltest::currentFailure $fail
sl@0	1325	} -body {
sl@0	1326	verbose {}
sl@0	1327	test tcltest-21.12.0 {foo-3} -setup {
sl@0	1328	if {[info exists foo]} {
sl@0	1329	unset foo
sl@0	1330	}
sl@0	1331	set foo 1
sl@0	1332	set expected 2
sl@0	1333	} -body {
sl@0	1334	incr foo
sl@0	1335	set foo
sl@0	1336	} -cleanup {
sl@0	1337	if {$foo != 2} {
sl@0	1338	puts [outputChannel] "foo is wrong"
sl@0	1339	} else {
sl@0	1340	puts [outputChannel] "foo is 2"
sl@0	1341	}
sl@0	1342	} -result {$expected}
sl@0	1343	} -result {^$} -output {foo is 2} -match regexp
sl@0	1344
sl@0	1345	# test all.tcl usage (runAllTests); simulate .test file failure, as well as
sl@0	1346	# crashes to determine whether or not these errors are logged.
sl@0	1347
sl@0	1348	set atd [makeDirectory alltestdir]
sl@0	1349	makeFile {
sl@0	1350	package require tcltest
sl@0	1351	namespace import -force tcltest::*
sl@0	1352	testsDirectory [file join [temporaryDirectory] alltestdir]
sl@0	1353	runAllTests
sl@0	1354	} all.tcl $atd
sl@0	1355	makeFile {
sl@0	1356	exit 1
sl@0	1357	} exit.test $atd
sl@0	1358	makeFile {
sl@0	1359	error "throw an error"
sl@0	1360	} error.test $atd
sl@0	1361	makeFile {
sl@0	1362	package require tcltest
sl@0	1363	namespace import -force tcltest::*
sl@0	1364	test foo-1.1 {foo} {
sl@0	1365	-body { return 1 }
sl@0	1366	-result {1}
sl@0	1367	}
sl@0	1368	cleanupTests
sl@0	1369	} test.test $atd
sl@0	1370
sl@0	1371	# Must use a child process because stdout/stderr parsing can't be
sl@0	1372	# duplicated in slave interp.
sl@0	1373	test tcltest-22.1 {runAllTests} {
sl@0	1374	-constraints {unixOrPc}
sl@0	1375	-body {
sl@0	1376	exec [interpreter] \
sl@0	1377	[file join $atd all.tcl] \
sl@0	1378	-verbose t -tmpdir [temporaryDirectory]
sl@0	1379	}
sl@0	1380	-match regexp
sl@0	1381	-result "Test files exiting with errors:.error.test.exit.test"
sl@0	1382	}
sl@0	1383	removeDirectory alltestdir
sl@0	1384
sl@0	1385	# makeFile, removeFile, makeDirectory, removeDirectory, viewFile
sl@0	1386	test tcltest-23.1 {makeFile} {
sl@0	1387	-setup {
sl@0	1388	set mfdir [file join [temporaryDirectory] mfdir]
sl@0	1389	file mkdir $mfdir
sl@0	1390	}
sl@0	1391	-body {
sl@0	1392	makeFile {} t1.tmp
sl@0	1393	makeFile {} et1.tmp $mfdir
sl@0	1394	list [file exists [file join [temporaryDirectory] t1.tmp]] \
sl@0	1395	[file exists [file join $mfdir et1.tmp]]
sl@0	1396	}
sl@0	1397	-cleanup {
sl@0	1398	file delete -force $mfdir \
sl@0	1399	[file join [temporaryDirectory] t1.tmp]
sl@0	1400	}
sl@0	1401	-result {1 1}
sl@0	1402	}
sl@0	1403	test tcltest-23.2 {removeFile} {
sl@0	1404	-setup {
sl@0	1405	set mfdir [file join [temporaryDirectory] mfdir]
sl@0	1406	file mkdir $mfdir
sl@0	1407	makeFile {} t1.tmp
sl@0	1408	makeFile {} et1.tmp $mfdir
sl@0	1409	if {![file exists [file join [temporaryDirectory] t1.tmp]] \|\| \
sl@0	1410	![file exists [file join $mfdir et1.tmp]]} {
sl@0	1411	error "file creation didn't work"
sl@0	1412	}
sl@0	1413	}
sl@0	1414	-body {
sl@0	1415	removeFile t1.tmp
sl@0	1416	removeFile et1.tmp $mfdir
sl@0	1417	list [file exists [file join [temporaryDirectory] t1.tmp]] \
sl@0	1418	[file exists [file join $mfdir et1.tmp]]
sl@0	1419	}
sl@0	1420	-cleanup {
sl@0	1421	file delete -force $mfdir \
sl@0	1422	[file join [temporaryDirectory] t1.tmp]
sl@0	1423	}
sl@0	1424	-result {0 0}
sl@0	1425	}
sl@0	1426	test tcltest-23.3 {makeDirectory} {
sl@0	1427	-body {
sl@0	1428	set mfdir [file join [temporaryDirectory] mfdir]
sl@0	1429	file mkdir $mfdir
sl@0	1430	makeDirectory d1
sl@0	1431	makeDirectory d2 $mfdir
sl@0	1432	list [file exists [file join [temporaryDirectory] d1]] \
sl@0	1433	[file exists [file join $mfdir d2]]
sl@0	1434	}
sl@0	1435	-cleanup {
sl@0	1436	file delete -force [file join [temporaryDirectory] d1] $mfdir
sl@0	1437	}
sl@0	1438	-result {1 1}
sl@0	1439	}
sl@0	1440	test tcltest-23.4 {removeDirectory} {
sl@0	1441	-setup {
sl@0	1442	set mfdir [makeDirectory mfdir]
sl@0	1443	makeDirectory t1
sl@0	1444	makeDirectory t2 $mfdir
sl@0	1445	if {![file exists $mfdir] \|\| \
sl@0	1446	![file exists [file join [temporaryDirectory] $mfdir t2]]} {
sl@0	1447	error "setup failed - directory not created"
sl@0	1448	}
sl@0	1449	}
sl@0	1450	-body {
sl@0	1451	removeDirectory t1
sl@0	1452	removeDirectory t2 $mfdir
sl@0	1453	list [file exists [file join [temporaryDirectory] t1]] \
sl@0	1454	[file exists [file join $mfdir t2]]
sl@0	1455	}
sl@0	1456	-result {0 0}
sl@0	1457	}
sl@0	1458	test tcltest-23.5 {viewFile} {
sl@0	1459	-body {
sl@0	1460	set mfdir [file join [temporaryDirectory] mfdir]
sl@0	1461	file mkdir $mfdir
sl@0	1462	makeFile {foobar} t1.tmp
sl@0	1463	makeFile {foobarbaz} t2.tmp $mfdir
sl@0	1464	list [viewFile t1.tmp] [viewFile t2.tmp $mfdir]
sl@0	1465	}
sl@0	1466	-result {foobar foobarbaz}
sl@0	1467	-cleanup {
sl@0	1468	file delete -force $mfdir
sl@0	1469	removeFile t1.tmp
sl@0	1470	}
sl@0	1471	}
sl@0	1472
sl@0	1473	# customMatch
sl@0	1474	proc matchNegative { expected actual } {
sl@0	1475	set match 0
sl@0	1476	foreach a $actual e $expected {
sl@0	1477	if { $a != $e } {
sl@0	1478	set match 1
sl@0	1479	break
sl@0	1480	}
sl@0	1481	}
sl@0	1482	return $match
sl@0	1483	}
sl@0	1484
sl@0	1485	test tcltest-24.0 {
sl@0	1486	customMatch: syntax
sl@0	1487	} -body {
sl@0	1488	list [catch {customMatch} result] $result
sl@0	1489	} -result [list 1 "wrong # args: should be \"customMatch mode script\""]
sl@0	1490
sl@0	1491	test tcltest-24.1 {
sl@0	1492	customMatch: syntax
sl@0	1493	} -body {
sl@0	1494	list [catch {customMatch foo} result] $result
sl@0	1495	} -result [list 1 "wrong # args: should be \"customMatch mode script\""]
sl@0	1496
sl@0	1497	test tcltest-24.2 {
sl@0	1498	customMatch: syntax
sl@0	1499	} -body {
sl@0	1500	list [catch {customMatch foo bar baz} result] $result
sl@0	1501	} -result [list 1 "wrong # args: should be \"customMatch mode script\""]
sl@0	1502
sl@0	1503	test tcltest-24.3 {
sl@0	1504	customMatch: argument checking
sl@0	1505	} -body {
sl@0	1506	list [catch {customMatch bad "a \{ b"} result] $result
sl@0	1507	} -result [list 1 "invalid customMatch script; can't evaluate after completion"]
sl@0	1508
sl@0	1509	test tcltest-24.4 {
sl@0	1510	test: valid -match values
sl@0	1511	} -body {
sl@0	1512	list [catch {
sl@0	1513	test tcltest-24.4.0 {} \
sl@0	1514	-match [namespace current]::noSuchMode
sl@0	1515	} result] $result
sl@0	1516	} -match glob -result {1 bad -match value}
sl@0	1517
sl@0	1518	test tcltest-24.5 {
sl@0	1519	test: valid -match values
sl@0	1520	} -setup {
sl@0	1521	customMatch [namespace current]::alwaysMatch "format 1 ;#"
sl@0	1522	} -body {
sl@0	1523	list [catch {
sl@0	1524	test tcltest-24.5.0 {} \
sl@0	1525	-match [namespace current]::noSuchMode
sl@0	1526	} result] $result
sl@0	1527	} -match glob -result {1 bad -match value: must be alwaysMatch,}
sl@0	1528
sl@0	1529	test tcltest-24.6 {
sl@0	1530	customMatch: -match script that always matches
sl@0	1531	} -setup {
sl@0	1532	customMatch [namespace current]::alwaysMatch "format 1 ;#"
sl@0	1533	set v [verbose]
sl@0	1534	} -body {
sl@0	1535	verbose {}
sl@0	1536	test tcltest-24.6.0 {} -match [namespace current]::alwaysMatch \
sl@0	1537	-body {format 1} -result 0
sl@0	1538	} -cleanup {
sl@0	1539	verbose $v
sl@0	1540	} -result {} -output {} -errorOutput {}
sl@0	1541
sl@0	1542	test tcltest-24.7 {
sl@0	1543	customMatch: replace default -exact matching
sl@0	1544	} -setup {
sl@0	1545	set saveExactMatchScript $::tcltest::CustomMatch(exact)
sl@0	1546	customMatch exact "format 1 ;#"
sl@0	1547	set v [verbose]
sl@0	1548	} -body {
sl@0	1549	verbose {}
sl@0	1550	test tcltest-24.7.0 {} -body {format 1} -result 0
sl@0	1551	} -cleanup {
sl@0	1552	verbose $v
sl@0	1553	customMatch exact $saveExactMatchScript
sl@0	1554	unset saveExactMatchScript
sl@0	1555	} -result {} -output {}
sl@0	1556
sl@0	1557	test tcltest-24.9 {
sl@0	1558	customMatch: error during match
sl@0	1559	} -setup {
sl@0	1560	proc errorDuringMatch args {return -code error "match returned error"}
sl@0	1561	customMatch [namespace current]::errorDuringMatch \
sl@0	1562	[namespace code errorDuringMatch]
sl@0	1563	set v [verbose]
sl@0	1564	set fail $::tcltest::currentFailure
sl@0	1565	} -body {
sl@0	1566	verbose {}
sl@0	1567	test tcltest-24.9.0 {} -match [namespace current]::errorDuringMatch
sl@0	1568	} -cleanup {
sl@0	1569	verbose $v
sl@0	1570	set ::tcltest::currentFailure $fail
sl@0	1571	} -match glob -result {} -output {FAILEDmatch returned error*}
sl@0	1572
sl@0	1573	test tcltest-24.10 {
sl@0	1574	customMatch: bad return from match command
sl@0	1575	} -setup {
sl@0	1576	proc nonBooleanReturn args {return foo}
sl@0	1577	customMatch nonBooleanReturn [namespace code nonBooleanReturn]
sl@0	1578	set v [verbose]
sl@0	1579	set fail $::tcltest::currentFailure
sl@0	1580	} -body {
sl@0	1581	verbose {}
sl@0	1582	test tcltest-24.10.0 {} -match nonBooleanReturn
sl@0	1583	} -cleanup {
sl@0	1584	verbose $v
sl@0	1585	set ::tcltest::currentFailure $fail
sl@0	1586	} -match glob -result {} -output {FAILEDexpected boolean value*}
sl@0	1587
sl@0	1588	test tcltest-24.11 {
sl@0	1589	test: -match exact
sl@0	1590	} -body {
sl@0	1591	set result {A B C}
sl@0	1592	} -match exact -result {A B C}
sl@0	1593
sl@0	1594	test tcltest-24.12 {
sl@0	1595	test: -match exact match command eval in ::, not caller namespace
sl@0	1596	} -setup {
sl@0	1597	set saveExactMatchScript $::tcltest::CustomMatch(exact)
sl@0	1598	customMatch exact [list string equal]
sl@0	1599	set v [verbose]
sl@0	1600	proc string args {error {called [string] in caller namespace}}
sl@0	1601	} -body {
sl@0	1602	verbose {}
sl@0	1603	test tcltest-24.12.0 {} -body {format 1} -result 1
sl@0	1604	} -cleanup {
sl@0	1605	rename string {}
sl@0	1606	verbose $v
sl@0	1607	customMatch exact $saveExactMatchScript
sl@0	1608	unset saveExactMatchScript
sl@0	1609	} -match exact -result {} -output {}
sl@0	1610
sl@0	1611	test tcltest-24.13 {
sl@0	1612	test: -match exact failure
sl@0	1613	} -setup {
sl@0	1614	set saveExactMatchScript $::tcltest::CustomMatch(exact)
sl@0	1615	customMatch exact [list string equal]
sl@0	1616	set v [verbose]
sl@0	1617	set fail $::tcltest::currentFailure
sl@0	1618	} -body {
sl@0	1619	verbose {}
sl@0	1620	test tcltest-24.13.0 {} -body {format 1} -result 0
sl@0	1621	} -cleanup {
sl@0	1622	set ::tcltest::currentFailure $fail
sl@0	1623	verbose $v
sl@0	1624	customMatch exact $saveExactMatchScript
sl@0	1625	unset saveExactMatchScript
sl@0	1626	} -match glob -result {} -output {FAILEDResult was:
sl@0	1627	1*(exact matching):
sl@0	1628	0*}
sl@0	1629
sl@0	1630	test tcltest-24.14 {
sl@0	1631	test: -match glob
sl@0	1632	} -body {
sl@0	1633	set result {A B C}
sl@0	1634	} -match glob -result {A B*}
sl@0	1635
sl@0	1636	test tcltest-24.15 {
sl@0	1637	test: -match glob failure
sl@0	1638	} -setup {
sl@0	1639	set v [verbose]
sl@0	1640	set fail $::tcltest::currentFailure
sl@0	1641	} -body {
sl@0	1642	verbose {}
sl@0	1643	test tcltest-24.15.0 {} -match glob -body {format {A B C}} \
sl@0	1644	-result {A B* }
sl@0	1645	} -cleanup {
sl@0	1646	set ::tcltest::currentFailure $fail
sl@0	1647	verbose $v
sl@0	1648	} -match glob -result {} -output {FAILEDResult was:
sl@0	1649	*(glob matching):
sl@0	1650	*}
sl@0	1651
sl@0	1652	test tcltest-24.16 {
sl@0	1653	test: -match regexp
sl@0	1654	} -body {
sl@0	1655	set result {A B C}
sl@0	1656	} -match regexp -result {A B.*}
sl@0	1657
sl@0	1658	test tcltest-24.17 {
sl@0	1659	test: -match regexp failure
sl@0	1660	} -setup {
sl@0	1661	set fail $::tcltest::currentFailure
sl@0	1662	set v [verbose]
sl@0	1663	} -body {
sl@0	1664	verbose {}
sl@0	1665	test tcltest-24.17.0 {} -match regexp -body {format {A B C}} \
sl@0	1666	-result {A B.* X}
sl@0	1667	} -cleanup {
sl@0	1668	set ::tcltest::currentFailure $fail
sl@0	1669	verbose $v
sl@0	1670	} -match glob -result {} -output {FAILEDResult was:
sl@0	1671	*(regexp matching):
sl@0	1672	*}
sl@0	1673
sl@0	1674	test tcltest-24.18 {
sl@0	1675	test: -match custom forget namespace qualification
sl@0	1676	} -setup {
sl@0	1677	set fail $::tcltest::currentFailure
sl@0	1678	set v [verbose]
sl@0	1679	customMatch negative matchNegative
sl@0	1680	} -body {
sl@0	1681	verbose {}
sl@0	1682	test tcltest-24.18.0 {} -match negative -body {format {A B C}} \
sl@0	1683	-result {A B X}
sl@0	1684	} -cleanup {
sl@0	1685	set ::tcltest::currentFailure $fail
sl@0	1686	verbose $v
sl@0	1687	} -match glob -result {} -output {FAILEDError testing result:*}
sl@0	1688
sl@0	1689	test tcltest-24.19 {
sl@0	1690	test: -match custom
sl@0	1691	} -setup {
sl@0	1692	set v [verbose]
sl@0	1693	customMatch negative [namespace code matchNegative]
sl@0	1694	} -body {
sl@0	1695	verbose {}
sl@0	1696	test tcltest-24.19.0 {} -match negative -body {format {A B C}} \
sl@0	1697	-result {A B X}
sl@0	1698	} -cleanup {
sl@0	1699	verbose $v
sl@0	1700	} -match exact -result {} -output {}
sl@0	1701
sl@0	1702	test tcltest-24.20 {
sl@0	1703	test: -match custom failure
sl@0	1704	} -setup {
sl@0	1705	set fail $::tcltest::currentFailure
sl@0	1706	set v [verbose]
sl@0	1707	customMatch negative [namespace code matchNegative]
sl@0	1708	} -body {
sl@0	1709	verbose {}
sl@0	1710	test tcltest-24.20.0 {} -match negative -body {format {A B C}} \
sl@0	1711	-result {A B C}
sl@0	1712	} -cleanup {
sl@0	1713	set ::tcltest::currentFailure $fail
sl@0	1714	verbose $v
sl@0	1715	} -match glob -result {} -output {FAILEDResult was:
sl@0	1716	*(negative matching):
sl@0	1717	*}
sl@0	1718
sl@0	1719	test tcltest-25.1 {
sl@0	1720	constraint of setup/cleanup (Bug 589859)
sl@0	1721	} -setup {
sl@0	1722	set foo 0
sl@0	1723	} -body {
sl@0	1724	# Buggy tcltest will generate result of 2
sl@0	1725	test tcltest-25.1.0 {} -constraints knownBug -setup {
sl@0	1726	incr foo
sl@0	1727	} -body {
sl@0	1728	incr foo
sl@0	1729	} -cleanup {
sl@0	1730	incr foo
sl@0	1731	} -match glob -result *
sl@0	1732	set foo
sl@0	1733	} -cleanup {
sl@0	1734	unset foo
sl@0	1735	} -result 0
sl@0	1736
sl@0	1737	test tcltest-25.2 {
sl@0	1738	puts -nonewline (Bug 612786)
sl@0	1739	} -body {
sl@0	1740	puts -nonewline stdout bla
sl@0	1741	puts -nonewline stdout bla
sl@0	1742	} -output {blabla}
sl@0	1743
sl@0	1744	test tcltest-25.3 {
sl@0	1745	reported return code (Bug 611922)
sl@0	1746	} -setup {
sl@0	1747	set fail $::tcltest::currentFailure
sl@0	1748	set v [verbose]
sl@0	1749	} -body {
sl@0	1750	verbose {}
sl@0	1751	test tcltest-25.3.0 {} -body {
sl@0	1752	error foo
sl@0	1753	}
sl@0	1754	} -cleanup {
sl@0	1755	set ::tcltest::currentFailure $fail
sl@0	1756	verbose $v
sl@0	1757	} -match glob -output {generated error; Return code was: 1}
sl@0	1758
sl@0	1759	test tcltest-26.1 {Bug/RFE 1017151} -setup {
sl@0	1760	makeFile {
sl@0	1761	package require tcltest
sl@0	1762	set errorInfo "Should never see this"
sl@0	1763	tcltest::test tcltest-26.1.0 {
sl@0	1764	no errorInfo when only return code mismatch
sl@0	1765	} -body {
sl@0	1766	set x 1
sl@0	1767	} -returnCodes error -result 1
sl@0	1768	tcltest::cleanupTests
sl@0	1769	} test.tcl
sl@0	1770	} -body {
sl@0	1771	slave msg [file join [temporaryDirectory] test.tcl]
sl@0	1772	set msg
sl@0	1773	} -cleanup {
sl@0	1774	removeFile test.tcl
sl@0	1775	} -match glob -result {*
sl@0	1776	---- Return code should have been one of: 1
sl@0	1777	==== tcltest-26.1.0 FAILED*}
sl@0	1778
sl@0	1779	test tcltest-26.2 {Bug/RFE 1017151} -setup {
sl@0	1780	makeFile {
sl@0	1781	package require tcltest
sl@0	1782	set errorInfo "Should never see this"
sl@0	1783	tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body {
sl@0	1784	error "body error"
sl@0	1785	} -cleanup {
sl@0	1786	error "cleanup error"
sl@0	1787	} -result 1
sl@0	1788	tcltest::cleanupTests
sl@0	1789	} test.tcl
sl@0	1790	} -body {
sl@0	1791	slave msg [file join [temporaryDirectory] test.tcl]
sl@0	1792	set msg
sl@0	1793	} -cleanup {
sl@0	1794	removeFile test.tcl
sl@0	1795	} -match glob -result {*
sl@0	1796	---- errorInfo: body error
sl@0	1797	*
sl@0	1798	---- errorInfo(cleanup): cleanup error*}
sl@0	1799
sl@0	1800	cleanupTests
sl@0	1801	}
sl@0	1802
sl@0	1803	namespace delete ::tcltest::test
sl@0	1804	return

author	sl@SLION-WIN7.fritz.box
	Fri, 15 Jun 2012 03:10:57 +0200
changeset 0	bde4ae8d615e
permissions	-rw-r--r--