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