1# defs.tcl --
2#
3#	This file contains support code for the Tcl/Tk test suite.It is
4#	It is normally sourced by the individual files in the test suite
5#	before they run their tests.  This improved approach to testing
6#	was designed and initially implemented by Mary Ann May-Pumphrey
7#	of Sun Microsystems.
8#
9# Copyright (c) 1990-1994 The Regents of the University of California.
10# Copyright (c) 1994-1996 Sun Microsystems, Inc.
11# Copyright (c) 1998-1999 by Scriptics Corporation.
12# All rights reserved.
13#
14# RCS: @(#) $Id: defs.tcl,v 1.1 2002/03/25 13:56:21 rolf Exp $
15
16# Initialize wish shell
17
18if {[info exists tk_version]} {
19    tk appname tktest
20    wm title . tktest
21} else {
22
23    # Ensure that we have a minimal auto_path so we don't pick up extra junk.
24
25    set auto_path [list [info library]]
26}
27
28# create the "tcltest" namespace for all testing variables and procedures
29
30namespace eval tcltest {
31    set procList [list test cleanupTests dotests saveState restoreState \
32	    normalizeMsg makeFile removeFile makeDirectory removeDirectory \
33	    viewFile bytestring set_iso8859_1_locale restore_locale \
34	    safeFetch threadReap]
35    if {[info exists tk_version]} {
36	lappend procList setupbg dobg bgReady cleanupbg fixfocus
37    }
38    foreach proc $procList {
39	namespace export $proc
40    }
41
42    # ::tcltest::verbose defaults to "b"
43
44    variable verbose "b"
45
46    # match defaults to the empty list
47
48    variable match {}
49
50    # skip defaults to the empty list
51
52    variable skip {}
53
54    # Tests should not rely on the current working directory.
55    # Files that are part of the test suite should be accessed relative to
56    # ::tcltest::testsDir.
57
58    set originalDir [pwd]
59    set tDir [file join $originalDir [file dirname [info script]]]
60    cd $tDir
61    variable testsDir [pwd]
62    cd $originalDir
63
64    # Count the number of files tested (0 if all.tcl wasn't called).
65    # The all.tcl file will set testSingleFile to false, so stats will
66    # not be printed until all.tcl calls the cleanupTests proc.
67    # The currentFailure var stores the boolean value of whether the
68    # current test file has had any failures.  The failFiles list
69    # stores the names of test files that had failures.
70
71    variable numTestFiles 0
72    variable testSingleFile true
73    variable currentFailure false
74    variable failFiles {}
75
76    # Tests should remove all files they create.  The test suite will
77    # check the current working dir for files created by the tests.
78    # ::tcltest::filesMade keeps track of such files created using the
79    # ::tcltest::makeFile and ::tcltest::makeDirectory procedures.
80    # ::tcltest::filesExisted stores the names of pre-existing files.
81
82    variable filesMade {}
83    variable filesExisted {}
84
85    # ::tcltest::numTests will store test files as indices and the list
86    # of files (that should not have been) left behind by the test files.
87
88    array set ::tcltest::createdNewFiles {}
89
90    # initialize ::tcltest::numTests array to keep track fo the number of
91    # tests that pass, fial, and are skipped.
92
93    array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
94
95    # initialize ::tcltest::skippedBecause array to keep track of
96    # constraints that kept tests from running
97
98    array set ::tcltest::skippedBecause {}
99
100    # tests that use thread need to know which is the main thread
101
102    variable ::tcltest::mainThread 1
103    if {[info commands testthread] != {}} {
104	set ::tcltest::mainThread [testthread names]
105    }
106}
107
108# If there is no "memory" command (because memory debugging isn't
109# enabled), generate a dummy command that does nothing.
110
111if {[info commands memory] == ""} {
112    proc memory args {}
113}
114
115# ::tcltest::initConfig --
116#
117# Check configuration information that will determine which tests
118# to run.  To do this, create an array ::tcltest::testConfig.  Each
119# element has a 0 or 1 value.  If the element is "true" then tests
120# with that constraint will be run, otherwise tests with that constraint
121# will be skipped.  See the README file for the list of built-in
122# constraints defined in this procedure.
123#
124# Arguments:
125#	none
126#
127# Results:
128#	The ::tcltest::testConfig array is reset to have an index for
129#	each built-in test constraint.
130
131proc ::tcltest::initConfig {} {
132
133    global tcl_platform tcl_interactive tk_version
134
135    catch {unset ::tcltest::testConfig}
136
137    # The following trace procedure makes it so that we can safely refer to
138    # non-existent members of the ::tcltest::testConfig array without causing an
139    # error.  Instead, reading a non-existent member will return 0.  This is
140    # necessary because tests are allowed to use constraint "X" without ensuring
141    # that ::tcltest::testConfig("X") is defined.
142
143    trace variable ::tcltest::testConfig r ::tcltest::safeFetch
144
145    proc ::tcltest::safeFetch {n1 n2 op} {
146	if {($n2 != {}) && ([info exists ::tcltest::testConfig($n2)] == 0)} {
147	    set ::tcltest::testConfig($n2) 0
148	}
149    }
150
151    set ::tcltest::testConfig(unixOnly) \
152	    [expr {$tcl_platform(platform) == "unix"}]
153    set ::tcltest::testConfig(macOnly) \
154	    [expr {$tcl_platform(platform) == "macintosh"}]
155    set ::tcltest::testConfig(pcOnly) \
156	    [expr {$tcl_platform(platform) == "windows"}]
157
158    set ::tcltest::testConfig(unix) $::tcltest::testConfig(unixOnly)
159    set ::tcltest::testConfig(mac) $::tcltest::testConfig(macOnly)
160    set ::tcltest::testConfig(pc) $::tcltest::testConfig(pcOnly)
161
162    set ::tcltest::testConfig(unixOrPc) \
163	    [expr {$::tcltest::testConfig(unix) || $::tcltest::testConfig(pc)}]
164    set ::tcltest::testConfig(macOrPc) \
165	    [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(pc)}]
166    set ::tcltest::testConfig(macOrUnix) \
167	    [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(unix)}]
168
169    set ::tcltest::testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}]
170    set ::tcltest::testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}]
171
172    # The following config switches are used to mark tests that should work,
173    # but have been temporarily disabled on certain platforms because they don't
174    # and we haven't gotten around to fixing the underlying problem.
175
176    set ::tcltest::testConfig(tempNotPc) [expr {!$::tcltest::testConfig(pc)}]
177    set ::tcltest::testConfig(tempNotMac) [expr {!$::tcltest::testConfig(mac)}]
178    set ::tcltest::testConfig(tempNotUnix) [expr {!$::tcltest::testConfig(unix)}]
179
180    # The following config switches are used to mark tests that crash on
181    # certain platforms, so that they can be reactivated again when the
182    # underlying problem is fixed.
183
184    set ::tcltest::testConfig(pcCrash) [expr {!$::tcltest::testConfig(pc)}]
185    set ::tcltest::testConfig(macCrash) [expr {!$::tcltest::testConfig(mac)}]
186    set ::tcltest::testConfig(unixCrash) [expr {!$::tcltest::testConfig(unix)}]
187
188    # Set the "fonts" constraint for wish apps
189
190    if {[info exists tk_version]} {
191	set ::tcltest::testConfig(fonts) 1
192	catch {destroy .e}
193	entry .e -width 0 -font {Helvetica -12} -bd 1
194	.e insert end "a.bcd"
195	if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
196	    set ::tcltest::testConfig(fonts) 0
197	}
198	destroy .e
199	catch {destroy .t}
200	text .t -width 80 -height 20 -font {Times -14} -bd 1
201	pack .t
202	.t insert end "This is\na dot."
203	update
204	set x [list [.t bbox 1.3] [.t bbox 2.5]]
205	destroy .t
206	if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} {
207	    set ::tcltest::testConfig(fonts) 0
208	}
209    }
210
211    # Skip empty tests
212
213    set ::tcltest::testConfig(emptyTest) 0
214
215    # By default, tests that expost known bugs are skipped.
216
217    set ::tcltest::testConfig(knownBug) 0
218
219    # By default, non-portable tests are skipped.
220
221    set ::tcltest::testConfig(nonPortable) 0
222
223    # Some tests require user interaction.
224
225    set ::tcltest::testConfig(userInteraction) 0
226
227    # Some tests must be skipped if the interpreter is not in interactive mode
228
229    set ::tcltest::testConfig(interactive) $tcl_interactive
230
231    # Some tests must be skipped if you are running as root on Unix.
232    # Other tests can only be run if you are running as root on Unix.
233
234    set ::tcltest::testConfig(root) 0
235    set ::tcltest::testConfig(notRoot) 1
236    set user {}
237    if {$tcl_platform(platform) == "unix"} {
238	catch {set user [exec whoami]}
239	if {$user == ""} {
240	    catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
241	}
242	if {($user == "root") || ($user == "")} {
243	    set ::tcltest::testConfig(root) 1
244	    set ::tcltest::testConfig(notRoot) 0
245	}
246    }
247
248    # Set nonBlockFiles constraint: 1 means this platform supports
249    # setting files into nonblocking mode.
250
251    if {[catch {set f [open defs r]}]} {
252	set ::tcltest::testConfig(nonBlockFiles) 1
253    } else {
254	if {[catch {fconfigure $f -blocking off}] == 0} {
255	    set ::tcltest::testConfig(nonBlockFiles) 1
256	} else {
257	    set ::tcltest::testConfig(nonBlockFiles) 0
258	}
259	close $f
260    }
261
262    # Set asyncPipeClose constraint: 1 means this platform supports
263    # async flush and async close on a pipe.
264    #
265    # Test for SCO Unix - cannot run async flushing tests because a
266    # potential problem with select is apparently interfering.
267    # (Mark Diekhans).
268
269    if {$tcl_platform(platform) == "unix"} {
270	if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
271	    set ::tcltest::testConfig(asyncPipeClose) 0
272	} else {
273	    set ::tcltest::testConfig(asyncPipeClose) 1
274	}
275    } else {
276	set ::tcltest::testConfig(asyncPipeClose) 1
277    }
278
279    # Test to see if we have a broken version of sprintf with respect
280    # to the "e" format of floating-point numbers.
281
282    set ::tcltest::testConfig(eformat) 1
283    if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
284	set ::tcltest::testConfig(eformat) 0
285    }
286
287    # Test to see if execed commands such as cat, echo, rm and so forth are
288    # present on this machine.
289
290    set ::tcltest::testConfig(unixExecs) 1
291    if {$tcl_platform(platform) == "macintosh"} {
292	set ::tcltest::testConfig(unixExecs) 0
293    }
294    if {($::tcltest::testConfig(unixExecs) == 1) && \
295	    ($tcl_platform(platform) == "windows")} {
296	if {[catch {exec cat defs}] == 1} {
297	    set ::tcltest::testConfig(unixExecs) 0
298	}
299	if {($::tcltest::testConfig(unixExecs) == 1) && \
300		([catch {exec echo hello}] == 1)} {
301	    set ::tcltest::testConfig(unixExecs) 0
302	}
303	if {($::tcltest::testConfig(unixExecs) == 1) && \
304		([catch {exec sh -c echo hello}] == 1)} {
305	    set ::tcltest::testConfig(unixExecs) 0
306	}
307	if {($::tcltest::testConfig(unixExecs) == 1) && \
308		([catch {exec wc defs}] == 1)} {
309	    set ::tcltest::testConfig(unixExecs) 0
310	}
311	if {$::tcltest::testConfig(unixExecs) == 1} {
312	    exec echo hello > removeMe
313	    if {[catch {exec rm removeMe}] == 1} {
314		set ::tcltest::testConfig(unixExecs) 0
315	    }
316	}
317	if {($::tcltest::testConfig(unixExecs) == 1) && \
318		([catch {exec sleep 1}] == 1)} {
319	    set ::tcltest::testConfig(unixExecs) 0
320	}
321	if {($::tcltest::testConfig(unixExecs) == 1) && \
322		([catch {exec fgrep unixExecs defs}] == 1)} {
323	    set ::tcltest::testConfig(unixExecs) 0
324	}
325	if {($::tcltest::testConfig(unixExecs) == 1) && \
326		([catch {exec ps}] == 1)} {
327	    set ::tcltest::testConfig(unixExecs) 0
328	}
329	if {($::tcltest::testConfig(unixExecs) == 1) && \
330		([catch {exec echo abc > removeMe}] == 0) && \
331		([catch {exec chmod 644 removeMe}] == 1) && \
332		([catch {exec rm removeMe}] == 0)} {
333	    set ::tcltest::testConfig(unixExecs) 0
334	} else {
335	    catch {exec rm -f removeMe}
336	}
337	if {($::tcltest::testConfig(unixExecs) == 1) && \
338		([catch {exec mkdir removeMe}] == 1)} {
339	    set ::tcltest::testConfig(unixExecs) 0
340	} else {
341	    catch {exec rm -r removeMe}
342	}
343    }
344}
345
346::tcltest::initConfig
347
348
349# ::tcltest::processCmdLineArgs --
350#
351#	Use command line args to set the verbose, skip, and
352#	match variables.  This procedure must be run after
353#	constraints are initialized, because some constraints can be
354#	overridden.
355#
356# Arguments:
357#	none
358#
359# Results:
360#	::tcltest::verbose is set to <value>
361
362proc ::tcltest::processCmdLineArgs {} {
363    global argv
364
365    # The "argv" var doesn't exist in some cases, so use {}
366    # The "argv" var doesn't exist in some cases.
367
368    if {(![info exists argv]) || ([llength $argv] < 2)} {
369	set flagArray {}
370    } else {
371	set flagArray $argv
372    }
373
374    if {[catch {array set flag $flagArray}]} {
375	puts stderr "Error:  odd number of command line args specified:"
376	puts stderr "        $argv"
377	exit
378    }
379
380    # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
381    # Note that -verbose cannot be abbreviated to -v in wish because it
382    # conflicts with the wish option -visual.
383
384    foreach arg {-verbose -match -skip -constraints} {
385	set abbrev [string range $arg 0 1]
386	if {([info exists flag($abbrev)]) && \
387		([lsearch -exact $flagArray $arg] < \
388		[lsearch -exact $flagArray $abbrev])} {
389	    set flag($arg) $flag($abbrev)
390	}
391    }
392
393    # Set ::tcltest::workingDir to [pwd].
394    # Save the names of files that already exist in ::tcltest::workingDir.
395
396    set ::tcltest::workingDir [pwd]
397    foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
398	lappend ::tcltest::filesExisted [file tail $file]
399    }
400
401    # Set ::tcltest::verbose to the arg of the -verbose flag, if given
402
403    if {[info exists flag(-verbose)]} {
404	set ::tcltest::verbose $flag(-verbose)
405    }
406
407    # Set ::tcltest::match to the arg of the -match flag, if given
408
409    if {[info exists flag(-match)]} {
410	set ::tcltest::match $flag(-match)
411    }
412
413    # Set ::tcltest::skip to the arg of the -skip flag, if given
414
415    if {[info exists flag(-skip)]} {
416	set ::tcltest::skip $flag(-skip)
417    }
418
419    # Use the -constraints flag, if given, to turn on constraints that are
420    # turned off by default: userInteractive knownBug nonPortable.  This
421    # code fragment must be run after constraints are initialized.
422
423    if {[info exists flag(-constraints)]} {
424	foreach elt $flag(-constraints) {
425	    set ::tcltest::testConfig($elt) 1
426	}
427    }
428}
429
430::tcltest::processCmdLineArgs
431
432
433# ::tcltest::cleanupTests --
434#
435# Remove files and dirs created using the makeFile and makeDirectory
436# commands since the last time this proc was invoked.
437#
438# Print the names of the files created without the makeFile command
439# since the tests were invoked.
440#
441# Print the number tests (total, passed, failed, and skipped) since the
442# tests were invoked.
443#
444
445proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
446    set tail [file tail [info script]]
447
448    # Remove files and directories created by the :tcltest::makeFile and
449    # ::tcltest::makeDirectory procedures.
450    # Record the names of files in ::tcltest::workingDir that were not
451    # pre-existing, and associate them with the test file that created them.
452
453    if {!$calledFromAllFile} {
454
455	foreach file $::tcltest::filesMade {
456	    if {[file exists $file]} {
457		catch {file delete -force $file}
458	    }
459	}
460	set currentFiles {}
461	foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
462	    lappend currentFiles [file tail $file]
463	}
464	set newFiles {}
465	foreach file $currentFiles {
466	    if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
467		lappend newFiles $file
468	    }
469	}
470	set ::tcltest::filesExisted $currentFiles
471	if {[llength $newFiles] > 0} {
472	    set ::tcltest::createdNewFiles($tail) $newFiles
473	}
474    }
475
476    if {$calledFromAllFile || $::tcltest::testSingleFile} {
477
478	# print stats
479
480	puts -nonewline stdout "$tail:"
481	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
482	    puts -nonewline stdout "\t$index\t$::tcltest::numTests($index)"
483	}
484	puts stdout ""
485
486	# print number test files sourced
487	# print names of files that ran tests which failed
488
489	if {$calledFromAllFile} {
490	    puts stdout "Sourced $::tcltest::numTestFiles Test Files."
491	    set ::tcltest::numTestFiles 0
492	    if {[llength $::tcltest::failFiles] > 0} {
493		puts stdout "Files with failing tests: $::tcltest::failFiles"
494		set ::tcltest::failFiles {}
495	    }
496	}
497
498	# if any tests were skipped, print the constraints that kept them
499	# from running.
500
501	set constraintList [array names ::tcltest::skippedBecause]
502	if {[llength $constraintList] > 0} {
503	    puts stdout "Number of tests skipped for each constraint:"
504	    foreach constraint [lsort $constraintList] {
505		puts stdout \
506			"\t$::tcltest::skippedBecause($constraint)\t$constraint"
507		unset ::tcltest::skippedBecause($constraint)
508	    }
509	}
510
511	# report the names of test files in ::tcltest::createdNewFiles, and
512	# reset the array to be empty.
513
514	set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
515	if {[llength $testFilesThatTurded] > 0} {
516	    puts stdout "Warning: test files left files behind:"
517	    foreach testFile $testFilesThatTurded {
518		puts "\t$testFile:\t$::tcltest::createdNewFiles($testFile)"
519		unset ::tcltest::createdNewFiles($testFile)
520	    }
521	}
522
523	# reset filesMade, filesExisted, and numTests
524
525	set ::tcltest::filesMade {}
526	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
527	    set ::tcltest::numTests($index) 0
528	}
529
530	# exit only if running Tk in non-interactive mode
531
532	global tk_version tcl_interactive
533	if {[info exists tk_version] && !$tcl_interactive} {
534	    exit
535	}
536    } else {
537
538	# if we're deferring stat-reporting until all files are sourced,
539	# then add current file to failFile list if any tests in this file
540	# failed
541
542	incr ::tcltest::numTestFiles
543	if {($::tcltest::currentFailure) && \
544		([lsearch -exact $::tcltest::failFiles $tail] == -1)} {
545	    lappend ::tcltest::failFiles $tail
546	}
547	set ::tcltest::currentFailure false
548    }
549}
550
551
552# test --
553#
554# This procedure runs a test and prints an error message if the test fails.
555# If ::tcltest::verbose has been set, it also prints a message even if the
556# test succeeds.  The test will be skipped if it doesn't match the
557# ::tcltest::match variable, if it matches an element in
558# ::tcltest::skip, or if one of the elements of "constraints" turns
559# out not to be true.
560#
561# Arguments:
562# name -		Name of test, in the form foo-1.2.
563# description -		Short textual description of the test, to
564#			help humans understand what it does.
565# constraints -		A list of one or more keywords, each of
566#			which must be the name of an element in
567#			the array "::tcltest::testConfig".  If any of these
568#			elements is zero, the test is skipped.
569#			This argument may be omitted.
570# script -		Script to run to carry out the test.  It must
571#			return a result that can be checked for
572#			correctness.
573# expectedAnswer -	Expected result from script.
574
575proc ::tcltest::test {name description script expectedAnswer args} {
576    incr ::tcltest::numTests(Total)
577
578    # skip the test if it's name matches an element of skip
579
580    foreach pattern $::tcltest::skip {
581	if {[string match $pattern $name]} {
582	    incr ::tcltest::numTests(Skipped)
583	    return
584	}
585    }
586    # skip the test if it's name doesn't match any element of match
587
588    if {[llength $::tcltest::match] > 0} {
589	set ok 0
590	foreach pattern $::tcltest::match {
591	    if {[string match $pattern $name]} {
592		set ok 1
593		break
594	    }
595        }
596	if {!$ok} {
597	    incr ::tcltest::numTests(Skipped)
598	    return
599	}
600    }
601    set i [llength $args]
602    if {$i == 0} {
603	set constraints {}
604    } elseif {$i == 1} {
605
606	# "constraints" argument exists;  shuffle arguments down, then
607	# make sure that the constraints are satisfied.
608
609	set constraints $script
610	set script $expectedAnswer
611	set expectedAnswer [lindex $args 0]
612	set doTest 0
613	if {[string match {*[$\[]*} $constraints] != 0} {
614
615	    # full expression, e.g. {$foo > [info tclversion]}
616
617	    catch {set doTest [uplevel #0 expr $constraints]}
618
619	} elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
620
621	    # something like {a || b} should be turned into
622	    # $::tcltest::testConfig(a) || $::tcltest::testConfig(b).
623
624 	    regsub -all {[.a-zA-Z0-9]+} $constraints \
625		    {$::tcltest::testConfig(&)} c
626	    catch {set doTest [eval expr $c]}
627	} else {
628
629	    # just simple constraints such as {unixOnly fonts}.
630
631	    set doTest 1
632	    foreach constraint $constraints {
633		if {![info exists ::tcltest::testConfig($constraint)]
634			|| !$::tcltest::testConfig($constraint)} {
635		    set doTest 0
636
637		    # store the constraint that kept the test from running
638
639		    set constraints $constraint
640		    break
641		}
642	    }
643	}
644	if {$doTest == 0} {
645	    incr ::tcltest::numTests(Skipped)
646	    if {[string first s $::tcltest::verbose] != -1} {
647		puts stdout "++++ $name SKIPPED: $constraints"
648	    }
649
650	    # add the constraint to the list of constraints the kept tests
651	    # from running
652
653	    if {[info exists ::tcltest::skippedBecause($constraints)]} {
654		incr ::tcltest::skippedBecause($constraints)
655	    } else {
656		set ::tcltest::skippedBecause($constraints) 1
657	    }
658	    return
659	}
660    } else {
661	error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
662    }
663    memory tag $name
664    set code [catch {uplevel $script} actualAnswer]
665    if {$code != 0 || [string compare $actualAnswer $expectedAnswer] != 0} {
666	incr ::tcltest::numTests(Failed)
667	set ::tcltest::currentFailure true
668	if {[string first b $::tcltest::verbose] == -1} {
669	    set script ""
670	}
671	puts stdout "\n==== $name $description FAILED"
672	if {$script != ""} {
673	    puts stdout "==== Contents of test case:"
674	    puts stdout $script
675	}
676	if {$code != 0} {
677	    if {$code == 1} {
678		puts stdout "==== Test generated error:"
679		puts stdout $actualAnswer
680	    } elseif {$code == 2} {
681		puts stdout "==== Test generated return exception;  result was:"
682		puts stdout $actualAnswer
683	    } elseif {$code == 3} {
684		puts stdout "==== Test generated break exception"
685	    } elseif {$code == 4} {
686		puts stdout "==== Test generated continue exception"
687	    } else {
688		puts stdout "==== Test generated exception $code;  message was:"
689		puts stdout $actualAnswer
690	    }
691	} else {
692	    puts stdout "---- Result was:\n$actualAnswer"
693	}
694	puts stdout "---- Result should have been:\n$expectedAnswer"
695	puts stdout "==== $name FAILED\n"
696    } else {
697	incr ::tcltest::numTests(Passed)
698	if {[string first p $::tcltest::verbose] != -1} {
699	    puts stdout "++++ $name PASSED"
700	}
701    }
702}
703
704# ::tcltest::dotests --
705#
706#	takes two arguments--the name of the test file (such
707#	as "parse.test"), and a pattern selecting the tests you want to
708#	execute.  It sets ::tcltest::matching to the second argument, calls
709#	"source" on the file specified in the first argument, and restores
710#	::tcltest::matching to its pre-call value at the end.
711#
712# Arguments:
713#	file    name of tests file to source
714#	args    pattern selecting the tests you want to execute
715#
716# Results:
717#	none
718
719proc ::tcltest::dotests {file args} {
720    set savedTests $::tcltest::match
721    set ::tcltest::match $args
722    source $file
723    set ::tcltest::match $savedTests
724}
725
726proc ::tcltest::openfiles {} {
727    if {[catch {testchannel open} result]} {
728	return {}
729    }
730    return $result
731}
732
733proc ::tcltest::leakfiles {old} {
734    if {[catch {testchannel open} new]} {
735        return {}
736    }
737    set leak {}
738    foreach p $new {
739    	if {[lsearch $old $p] < 0} {
740	    lappend leak $p
741	}
742    }
743    return $leak
744}
745
746set ::tcltest::saveState {}
747
748proc ::tcltest::saveState {} {
749    uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
750}
751
752proc ::tcltest::restoreState {} {
753    foreach p [info procs] {
754	if {[lsearch [lindex $::tcltest::saveState 0] $p] < 0} {
755	    rename $p {}
756	}
757    }
758    foreach p [uplevel #0 {info vars}] {
759	if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
760	    uplevel #0 "unset $p"
761	}
762    }
763}
764
765proc ::tcltest::normalizeMsg {msg} {
766    regsub "\n$" [string tolower $msg] "" msg
767    regsub -all "\n\n" $msg "\n" msg
768    regsub -all "\n\}" $msg "\}" msg
769    return $msg
770}
771
772# makeFile --
773#
774# Create a new file with the name <name>, and write <contents> to it.
775#
776# If this file hasn't been created via makeFile since the last time
777# cleanupTests was called, add it to the $filesMade list, so it will
778# be removed by the next call to cleanupTests.
779#
780proc ::tcltest::makeFile {contents name} {
781    set fd [open $name w]
782    fconfigure $fd -translation lf
783    if {[string index $contents [expr {[string length $contents] - 1}]] == "\n"} {
784	puts -nonewline $fd $contents
785    } else {
786	puts $fd $contents
787    }
788    close $fd
789
790    set fullName [file join [pwd] $name]
791    if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
792	lappend ::tcltest::filesMade $fullName
793    }
794}
795
796proc ::tcltest::removeFile {name} {
797    file delete $name
798}
799
800# makeDirectory --
801#
802# Create a new dir with the name <name>.
803#
804# If this dir hasn't been created via makeDirectory since the last time
805# cleanupTests was called, add it to the $directoriesMade list, so it will
806# be removed by the next call to cleanupTests.
807#
808proc ::tcltest::makeDirectory {name} {
809    file mkdir $name
810
811    set fullName [file join [pwd] $name]
812    if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
813	lappend ::tcltest::filesMade $fullName
814    }
815}
816
817proc ::tcltest::removeDirectory {name} {
818    file delete -force $name
819}
820
821proc ::tcltest::viewFile {name} {
822    global tcl_platform
823    if {($tcl_platform(platform) == "macintosh") || \
824		($::tcltest::testConfig(unixExecs) == 0)} {
825	set f [open $name]
826	set data [read -nonewline $f]
827	close $f
828	return $data
829    } else {
830	exec cat $name
831    }
832}
833
834#
835# Construct a string that consists of the requested sequence of bytes,
836# as opposed to a string of properly formed UTF-8 characters.
837# This allows the tester to
838# 1. Create denormalized or improperly formed strings to pass to C procedures
839#    that are supposed to accept strings with embedded NULL bytes.
840# 2. Confirm that a string result has a certain pattern of bytes, for instance
841#    to confirm that "\xe0\0" in a Tcl script is stored internally in
842#    UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
843#
844# Generally, it's a bad idea to examine the bytes in a Tcl string or to
845# construct improperly formed strings in this manner, because it involves
846# exposing that Tcl uses UTF-8 internally.
847
848proc ::tcltest::bytestring {string} {
849    encoding convertfrom identity $string
850}
851
852# Locate tcltest executable
853
854if {![info exists tk_version]} {
855    set tcltest [info nameofexecutable]
856
857    if {$tcltest == "{}"} {
858	set tcltest {}
859    }
860}
861
862set ::tcltest::testConfig(stdio) 0
863catch {
864    catch {file delete -force tmp}
865    set f [open tmp w]
866    puts $f {
867	exit
868    }
869    close $f
870
871    set f [open "|[list $tcltest tmp]" r]
872    close $f
873
874    set ::tcltest::testConfig(stdio) 1
875}
876catch {file delete -force tmp}
877
878# Deliberately call the socket with the wrong number of arguments.  The error
879# message you get will indicate whether sockets are available on this system.
880
881catch {socket} msg
882set ::tcltest::testConfig(socket) \
883	[expr {$msg != "sockets are not available on this system"}]
884
885#
886# Internationalization / ISO support procs     -- dl
887#
888
889if {[info commands testlocale]==""} {
890
891    # No testlocale command, no tests...
892    # (it could be that we are a sub interp and we could just load
893    # the Tcltest package but that would interfere with tests
894    # that tests packages/loading in slaves...)
895
896    set ::tcltest::testConfig(hasIsoLocale) 0
897} else {
898    proc ::tcltest::set_iso8859_1_locale {} {
899	set ::tcltest::previousLocale [testlocale ctype]
900	testlocale ctype $::tcltest::isoLocale
901    }
902
903    proc ::tcltest::restore_locale {} {
904	testlocale ctype $::tcltest::previousLocale
905    }
906
907    if {![info exists ::tcltest::isoLocale]} {
908	set ::tcltest::isoLocale fr
909        switch $tcl_platform(platform) {
910	    "unix" {
911
912		# Try some 'known' values for some platforms:
913
914		switch -exact -- $tcl_platform(os) {
915		    "FreeBSD" {
916			set ::tcltest::isoLocale fr_FR.ISO_8859-1
917		    }
918		    HP-UX {
919			set ::tcltest::isoLocale fr_FR.iso88591
920		    }
921		    Linux -
922		    IRIX {
923			set ::tcltest::isoLocale fr
924		    }
925		    default {
926
927			# Works on SunOS 4 and Solaris, and maybe others...
928			# define it to something else on your system
929			#if you want to test those.
930
931			set ::tcltest::isoLocale iso_8859_1
932		    }
933		}
934	    }
935	    "windows" {
936		set ::tcltest::isoLocale French
937	    }
938	}
939    }
940
941    set ::tcltest::testConfig(hasIsoLocale) \
942	    [string length [::tcltest::set_iso8859_1_locale]]
943    ::tcltest::restore_locale
944}
945
946#
947# procedures that are Tk specific
948#
949
950if {[info exists tk_version]} {
951
952    # If the main window isn't already mapped (e.g. because the tests are
953    # being run automatically) , specify a precise size for it so that the
954    # user won't have to position it manually.
955
956    if {![winfo ismapped .]} {
957	wm geometry . +0+0
958	update
959    }
960
961    # The following code can be used to perform tests involving a second
962    # process running in the background.
963
964    # Locate the tktest executable
965
966    set ::tcltest::tktest [info nameofexecutable]
967    if {$::tcltest::tktest == "{}"} {
968	set ::tcltest::tktest {}
969	puts stdout \
970		"Unable to find tktest executable, skipping multiple process tests."
971    }
972
973    # Create background process
974
975    proc ::tcltest::setupbg args {
976	if {$::tcltest::tktest == ""} {
977	    error "you're not running tktest so setupbg should not have been called"
978	}
979	if {[info exists ::tcltest::fd] && ($::tcltest::fd != "")} {
980	    cleanupbg
981	}
982
983	# The following code segment cannot be run on Windows in Tk8.1b2
984	# This bug is logged as a pipe bug (bugID 1495).
985
986	global tcl_platform
987	if {$tcl_platform(platform) != "windows"} {
988	    set ::tcltest::fd [open "|[list $::tcltest::tktest -geometry +0+0 -name tktest] $args" r+]
989	    puts $::tcltest::fd "puts foo; flush stdout"
990	    flush $::tcltest::fd
991	    if {[gets $::tcltest::fd data] < 0} {
992		error "unexpected EOF from \"$::tcltest::tktest\""
993	    }
994	    if {[string compare $data foo]} {
995		error "unexpected output from background process \"$data\""
996	    }
997	    fileevent $::tcltest::fd readable bgReady
998	}
999    }
1000
1001    # Send a command to the background process, catching errors and
1002    # flushing I/O channels
1003
1004    proc ::tcltest::dobg {command} {
1005	puts $::tcltest::fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout"
1006	flush $::tcltest::fd
1007	set ::tcltest::bgDone 0
1008	set ::tcltest::bgData {}
1009	tkwait variable ::tcltest::bgDone
1010	set ::tcltest::bgData
1011    }
1012
1013    # Data arrived from background process.  Check for special marker
1014    # indicating end of data for this command, and make data available
1015    # to dobg procedure.
1016
1017    proc ::tcltest::bgReady {} {
1018	set x [gets $::tcltest::fd]
1019	if {[eof $::tcltest::fd]} {
1020	    fileevent $::tcltest::fd readable {}
1021	    set ::tcltest::bgDone 1
1022	} elseif {$x == "**DONE**"} {
1023	    set ::tcltest::bgDone 1
1024	} else {
1025	    append ::tcltest::bgData $x
1026	}
1027    }
1028
1029    # Exit the background process, and close the pipes
1030
1031    proc ::tcltest::cleanupbg {} {
1032	catch {
1033	    puts $::tcltest::fd "exit"
1034	    close $::tcltest::fd
1035	}
1036	set ::tcltest::fd ""
1037    }
1038
1039    # Clean up focus after using generate event, which
1040    # can leave the window manager with the wrong impression
1041    # about who thinks they have the focus. (BW)
1042
1043    proc ::tcltest::fixfocus {} {
1044	catch {destroy .focus}
1045	toplevel .focus
1046	wm geometry .focus +0+0
1047	entry .focus.e
1048	.focus.e insert 0 "fixfocus"
1049	pack .focus.e
1050	update
1051	focus -force .focus.e
1052	destroy .focus
1053    }
1054}
1055
1056# threadReap --
1057#
1058#	Kill all threads except for the main thread.
1059#	Do nothing if testthread is not defined.
1060#
1061# Arguments:
1062#	none.
1063#
1064# Results:
1065#	Returns the number of existing threads.
1066
1067if {[info commands testthread] != {}} {
1068    proc ::tcltest::threadReap {} {
1069	testthread errorproc ThreadNullError
1070	while {[llength [testthread names]] > 1} {
1071	    foreach tid [testthread names] {
1072		if {$tid != $::tcltest::mainThread} {
1073		    catch {testthread send -async $tid {testthread exit}}
1074		    update
1075		}
1076	    }
1077	}
1078	testthread errorproc ThreadError
1079	return [llength [testthread names]]
1080    }
1081} else {
1082    proc ::tcltest::threadReap {} {
1083	return 1
1084    }
1085}
1086
1087# Need to catch the import because it fails if defs.tcl is sourced
1088# more than once.
1089
1090catch {namespace import ::tcltest::*}
1091return
1092