tcltest.tcl

Swarm,由圣塔菲研究所开发,用于复杂适应系统(CAS)仿真及其他

# tcltest.tcl --
#
#	This file contains support code for the Tcl test suite.  It
#       defines the tcltest namespace and finds and defines the output
#       directory, constraints available, output and error channels,
#	etc. used by Tcl tests.  See the tcltest man page for more
#	details.
#
#       This design was based on the Tcl testing approach designed and
#       initially implemented by Mary Ann May-Pumphrey of Sun
#	Microsystems.
#
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2000 by Ajuba Solutions
# Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)
# All rights reserved.
#
# RCS: @(#) $Id: tcltest.tcl,v 1.78.2.10 2004/05/26 16:24:37 dgp Exp $

package require Tcl 8.3		;# uses [glob -directory]
namespace eval tcltest {

    # When the version number changes, be sure to update the pkgIndex.tcl file,
    # and the install directory in the Makefiles.  When the minor version
    # changes (new feature) be sure to update the man page as well.
    variable Version 2.2.6

    # Compatibility support for dumb variables defined in tcltest 1
    # Do not use these.  Call [package provide Tcl] and [info patchlevel]
    # yourself.  You don't need tcltest to wrap it for you.
    variable version [package provide Tcl]
    variable patchLevel [info patchlevel]

##### Export the public tcltest procs; several categories
    #
    # Export the main functional commands that do useful things
    namespace export cleanupTests loadTestedCommands makeDirectory \
	makeFile removeDirectory removeFile runAllTests test

    # Export configuration commands that control the functional commands
    namespace export configure customMatch errorChannel interpreter \
	    outputChannel testConstraint

    # Export commands that are duplication (candidates for deprecation)
    namespace export bytestring		;# dups [encoding convertfrom identity]
    namespace export debug		;#	[configure -debug]
    namespace export errorFile		;#	[configure -errfile]
    namespace export limitConstraints	;#	[configure -limitconstraints]
    namespace export loadFile		;#	[configure -loadfile]
    namespace export loadScript		;#	[configure -load]
    namespace export match		;#	[configure -match]
    namespace export matchFiles		;#	[configure -file]
    namespace export matchDirectories	;#	[configure -relateddir]
    namespace export normalizeMsg	;#	application of [customMatch]
    namespace export normalizePath	;#	[file normalize] (8.4)
    namespace export outputFile		;#	[configure -outfile]
    namespace export preserveCore	;#	[configure -preservecore]
    namespace export singleProcess	;#	[configure -singleproc]
    namespace export skip		;#	[configure -skip]
    namespace export skipFiles		;#	[configure -notfile]
    namespace export skipDirectories	;#	[configure -asidefromdir]
    namespace export temporaryDirectory	;#	[configure -tmpdir]
    namespace export testsDirectory	;#	[configure -testdir]
    namespace export verbose		;#	[configure -verbose]
    namespace export viewFile		;#	binary encoding [read]
    namespace export workingDirectory	;#	[cd] [pwd]

    # Export deprecated commands for tcltest 1 compatibility
    namespace export getMatchingFiles mainThread restoreState saveState \
	    threadReap

    # tcltest::normalizePath --
    #
    #     This procedure resolves any symlinks in the path thus creating
    #     a path without internal redirection. It assumes that the
    #     incoming path is absolute.
    #
    # Arguments
    #     pathVar - name of variable containing path to modify.
    #
    # Results
    #     The path is modified in place.
    #
    # Side Effects:
    #     None.
    #
    proc normalizePath {pathVar} {
	upvar $pathVar path
	set oldpwd [pwd]
	catch {cd $path}
	set path [pwd]
	cd $oldpwd
	return $path
    }

##### Verification commands used to test values of variables and options
    #
    # Verification command that accepts everything
    proc AcceptAll {value} {
	return $value
    }

    # Verification command that accepts valid Tcl lists
    proc AcceptList { list } {
	return [lrange $list 0 end]
    }

    # Verification command that accepts a glob pattern
    proc AcceptPattern { pattern } {
	return [AcceptAll $pattern]
    }

    # Verification command that accepts integers
    proc AcceptInteger { level } {
	return [incr level 0]
    }

    # Verification command that accepts boolean values
    proc AcceptBoolean { boolean } {
	return [expr {$boolean && $boolean}]
    }

    # Verification command that accepts (syntactically) valid Tcl scripts
    proc AcceptScript { script } {
	if {![info complete $script]} {
	    return -code error "invalid Tcl script: $script"
	}
	return $script
    }

    # Verification command that accepts (converts to) absolute pathnames
    proc AcceptAbsolutePath { path } {
	return [file join [pwd] $path]
    }

    # Verification command that accepts existing readable directories
    proc AcceptReadable { path } {
	if {![file readable $path]} {
	    return -code error "\"$path\" is not readable"
	}
	return $path
    }
    proc AcceptDirectory { directory } {
	set directory [AcceptAbsolutePath $directory]
	if {![file exists $directory]} {
	    return -code error "\"$directory\" does not exist"
	}
	if {![file isdir $directory]} {
	    return -code error "\"$directory\" is not a directory"
	}
	return [AcceptReadable $directory]
    }

##### Initialize internal arrays of tcltest, but only if the caller
    # has not already pre-initialized them.  This is done to support
    # compatibility with older tests that directly access internals
    # rather than go through command interfaces.
    #
    proc ArrayDefault {varName value} {
	variable $varName
	if {[array exists $varName]} {
	    return
	}
	if {[info exists $varName]} {
	    # Pre-initialized value is a scalar: destroy it!
	    unset $varName
	}
	array set $varName $value
    }

    # save the original environment so that it can be restored later
    ArrayDefault originalEnv [array get ::env]

    # initialize numTests array to keep track of the number of tests
    # that pass, fail, and are skipped.
    ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]

    # createdNewFiles will store test files as indices and the list of
    # files (that should not have been) left behind by the test files
    # as values.
    ArrayDefault createdNewFiles {}

    # initialize skippedBecause array to keep track of constraints that
    # kept tests from running; a constraint name of "userSpecifiedSkip"
    # means that the test appeared on the list of tests that matched the
    # -skip value given to the flag; "userSpecifiedNonMatch" means that
    # the test didn't match the argument given to the -match flag; both
    # of these constraints are counted only if tcltest::debug is set to
    # true.
    ArrayDefault skippedBecause {}

    # initialize the testConstraints array to keep track of valid
    # predefined constraints (see the explanation for the
    # InitConstraints proc for more details).
    ArrayDefault testConstraints {}

##### Initialize internal variables of tcltest, but only if the caller
    # has not already pre-initialized them.  This is done to support
    # compatibility with older tests that directly access internals
    # rather than go through command interfaces.
    #
    proc Default {varName value {verify AcceptAll}} {
	variable $varName
	if {![info exists $varName]} {
	    variable $varName [$verify $value]
	} else {
	    variable $varName [$verify [set $varName]]
	}
    }

    # Save any arguments that we might want to pass through to other
    # programs.  This is used by the -args flag.
    # FINDUSER
    Default parameters {}

    # Count the number of files tested (0 if runAllTests wasn't called).
    # runAllTests will set testSingleFile to false, so stats will
    # not be printed until runAllTests calls the cleanupTests proc.
    # The currentFailure var stores the boolean value of whether the
    # current test file has had any failures.  The failFiles list
    # stores the names of test files that had failures.
    Default numTestFiles 0 AcceptInteger
    Default testSingleFile true AcceptBoolean
    Default currentFailure false AcceptBoolean
    Default failFiles {} AcceptList

    # Tests should remove all files they create.  The test suite will
    # check the current working dir for files created by the tests.
    # filesMade keeps track of such files created using the makeFile and
    # makeDirectory procedures.  filesExisted stores the names of
    # pre-existing files.
    #
    # Note that $filesExisted lists only those files that exist in
    # the original [temporaryDirectory].
    Default filesMade {} AcceptList
    Default filesExisted {} AcceptList
    proc FillFilesExisted {} {
	variable filesExisted

	# Save the names of files that already exist in the scratch directory.
	foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
	    lappend filesExisted [file tail $file]
	}

	# After successful filling, turn this into a no-op.
	proc FillFilesExisted args {}
    }

    # Kept only for compatibility
    Default constraintsSpecified {} AcceptList
    trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
		[array names ::tcltest::testConstraints] ;# }

    # tests that use threads need to know which is the main thread
    Default mainThread 1
    variable mainThread
    if {[info commands thread::id] != {}} {
	set mainThread [thread::id]
    } elseif {[info commands testthread] != {}} {
	set mainThread [testthread id]
    }

    # Set workingDirectory to [pwd]. The default output directory for
    # Tcl tests is the working directory.  Whenever this value changes
    # change to that directory.
    variable workingDirectory
    trace variable workingDirectory w \
	    [namespace code {cd $workingDirectory ;#}]

    Default workingDirectory [pwd] AcceptAbsolutePath
    proc workingDirectory { {dir ""} } {
	variable workingDirectory
	if {[llength [info level 0]] == 1} {
	    return $workingDirectory
	}
	set workingDirectory [AcceptAbsolutePath $dir]
    }

    # Set the location of the execuatble
    Default tcltest [info nameofexecutable]
    trace variable tcltest w [namespace code {testConstraint stdio \
	    [eval [ConstraintInitializer stdio]] ;#}]

    # save the platform information so it can be restored later
    Default originalTclPlatform [array get ::tcl_platform]

    # If a core file exists, save its modification time.
    if {[file exists [file join [workingDirectory] core]]} {
	Default coreModTime \
		[file mtime [file join [workingDirectory] core]]
    }

    # stdout and stderr buffers for use when we want to store them
    Default outData {}
    Default errData {}

    # keep track of test level for nested test commands
    variable testLevel 0

    # the variables and procs that existed when saveState was called are
    # stored in a variable of the same name
    Default saveState {}

    # Internationalization support -- used in [SetIso8859_1_Locale] and
    # [RestoreLocale]. Those commands are used in cmdIL.test.

    if {![info exists [namespace current]::isoLocale]} {
	variable isoLocale fr
	switch -- $::tcl_platform(platform) {
	    "unix" {

		# Try some 'known' values for some platforms:

		switch -exact -- $::tcl_platform(os) {
		    "FreeBSD" {
			set isoLocale fr_FR.ISO_8859-1
		    }
		    HP-UX {
			set isoLocale fr_FR.iso88591
		    }
		    Linux -
		    IRIX {
			set isoLocale fr
		    }
		    default {

			# Works on SunOS 4 and Solaris, and maybe
			# others...  Define it to something else on your
			# system if you want to test those.

			set isoLocale iso_8859_1
		    }
		}
	    }
	    "windows" {
		set isoLocale French
	    }
	}
    }

    variable ChannelsWeOpened; array set ChannelsWeOpened {}
    # output goes to stdout by default
    Default outputChannel stdout
    proc outputChannel { {filename ""} } {
	variable outputChannel
	variable ChannelsWeOpened

	# This is very subtle and tricky, so let me try to explain.
	# (Hopefully this longer comment will be clear when I come
	# back in a few months, unlike its predecessor :) )
	# 
	# The [outputChannel] command (and underlying variable) have to
	# be kept in sync with the [configure -outfile] configuration
	# option ( and underlying variable Option(-outfile) ).  This is
	# accomplished with a write trace on Option(-outfile) that will
	# update [outputChannel] whenver a new value is written.  That
	# much is easy.
	#
	# The trick is that in order to maintain compatibility with
	# version 1 of tcltest, we must allow every configuration option
	# to get its inital value from command line arguments.  This is
	# accomplished by setting initial read traces on all the
	# configuration options to parse the command line option the first
	# time they are read.  These traces are cancelled whenever the
	# program itself calls [configure].
	# 
	# OK, then so to support tcltest 1 compatibility, it seems we want
	# to get the return from [outputFile] to trigger the read traces,
	# just in case.
	#
	# BUT!  A little known feature of Tcl variable traces is that 
	# traces are disabled during the handling of other traces.  So,
	# if we trigger read traces on Option(-outfile) and that triggers
	# command line parsing which turns around and sets an initial
	# value for Option(-outfile) -- <whew!> -- the write trace that
	# would keep [outputChannel] in sync with that new initial value
	# would not fire!
	#
	# SO, finally, as a workaround, instead of triggering read traces
	# by invoking [outputFile], we instead trigger the same set of
	# read traces by invoking [debug].  Any command that reads a
	# configuration option would do.  [debug] is just a handy one.
	# The end result is that we support tcltest 1 compatibility and
	# keep outputChannel and -outfile in sync in all cases.
	debug

	if {[llength [info level 0]] == 1} {
	    return $outputChannel
	}
	if {[info exists ChannelsWeOpened($outputChannel)]} {
	    close $outputChannel
	    unset ChannelsWeOpened($outputChannel)
	}
	switch -exact -- $filename {
	    stderr -
	    stdout {
		set outputChannel $filename
	    }
	    default {
		set outputChannel [open $filename a]
		set ChannelsWeOpened($outputChannel) 1

		# If we created the file in [temporaryDirectory], then
		# [cleanupTests] will delete it, unless we claim it was
		# already there.
		set outdir [normalizePath [file dirname \
			[file join [pwd] $filename]]]
		if {[string equal $outdir [temporaryDirectory]]} {
		    variable filesExisted
		    FillFilesExisted
		    set filename [file tail $filename]
		    if {[lsearch -exact $filesExisted $filename] == -1} {
			lappend filesExisted $filename
		    }
		}
	    }
	}
	return $outputChannel
    }