tcltest.tcl

This Source-Navigator, an IDE for C/C++/Fortran/Java/Tcl/PHP/Python and a host of other languages.

    if {[info exists flag(-skip)]} {
	set ::tcltest::skip $flag(-skip)
    }

    # Handle the -file and -notfile flags
    if {[info exists flag(-file)]} {
	set ::tcltest::matchFiles $flag(-file)
    }
    if {[info exists flag(-notfile)]} {
	set ::tcltest::skipFiles $flag(-notfile)
    }

    # Use the -constraints flag, if given, to turn on constraints that are
    # turned off by default: userInteractive knownBug nonPortable.  This
    # code fragment must be run after constraints are initialized.

    if {[info exists flag(-constraints)]} {
	foreach elt $flag(-constraints) {
	    set ::tcltest::testConstraints($elt) 1
	}
    }

    # Use the -limitconstraints flag, if given, to tell the harness to limit
    # tests run to those that were specified using the -constraints flag.  If
    # the -constraints flag was not specified, print out an error and exit.
    if {[info exists flag(-limitconstraints)]} {
	if {![info exists flag(-constraints)]} {
	    puts "You can only use the -limitconstraints flag with \
		    -constraints"
	    exit 1
	}
	set ::tcltest::limitConstraints $flag(-limitconstraints)
	foreach elt [array names ::tcltest::testConstraints] {
	    if {[lsearch -exact $flag(-constraints) $elt] == -1} {
		set ::tcltest::testConstraints($elt) 0
	    }
	}
    }

    # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if
    # given.
    # 
    # If the path is relative, make it absolute.  If the file exists but
    # is not a dir, then return an error.
    #
    # If ::tcltest::temporaryDirectory does not already exist, create it.
    # If you cannot create it, then return an error.

    set tmpDirError ""
    if {[info exists flag(-tmpdir)]} {
	set ::tcltest::temporaryDirectory $flag(-tmpdir)
	
	MakeAbsolutePath ::tcltest::temporaryDirectory
	set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: "
    }
    if {[file exists $::tcltest::temporaryDirectory]} {
	::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError
    } else {
	file mkdir $::tcltest::temporaryDirectory
    }

    normalizePath ::tcltest::temporaryDirectory

    # Set the ::tcltest::testsDirectory to the arg of -testdir, if
    # given.
    # 
    # If the path is relative, make it absolute.  If the file exists but
    # is not a dir, then return an error.
    #
    # If ::tcltest::temporaryDirectory does not already exist return an error.
    
    set testDirError ""
    if {[info exists flag(-testdir)]} {
	set ::tcltest::testsDirectory $flag(-testdir)
	
	MakeAbsolutePath ::tcltest::testsDirectory
	set testDirError "bad argument \"$flag(-testdir)\" to -testdir: "
    }
    if {[file exists $::tcltest::testsDirectory]} {
	::tcltest::CheckDirectory r $::tcltest::testsDirectory $testDirError
    } else {
	::tcltest::PrintError "$testDirError \"$::tcltest::testsDirectory\" \
		does not exist"
	exit 1
    }
    
    normalizePath ::tcltest::testsDirectory
    
    # Save the names of files that already exist in
    # the output directory.
    foreach file [glob -nocomplain \
	    [file join $::tcltest::temporaryDirectory *]] {
	lappend ::tcltest::filesExisted [file tail $file]
    }

    # If an alternate error or output files are specified, change the
    # default channels.

    if {[info exists flag(-outfile)]} {
	set tmp $flag(-outfile)
	MakeAbsolutePath tmp $::tcltest::temporaryDirectory
	set ::tcltest::outputChannel [open $tmp w]
    } 

    if {[info exists flag(-errfile)]} {
	set tmp $flag(-errfile)
	MakeAbsolutePath tmp $::tcltest::temporaryDirectory
	set ::tcltest::errorChannel [open $tmp w]
    }

    # If a load script was specified, either directly or through
    # a file, remember it for later usage.
    
    if {[info exists flag(-load)] &&  \
	    ([lsearch -exact $flagArray -load] > \
	    [lsearch -exact $flagArray -loadfile])} {
	    set ::tcltest::loadScript $flag(-load)
    }
    
    if {[info exists flag(-loadfile)] && \
	    ([lsearch -exact $flagArray -loadfile] > \
	    [lsearch -exact $flagArray -load]) } {
	set tmp $flag(-loadfile)
	MakeAbsolutePath tmp $::tcltest::temporaryDirectory
	set tmp [open $tmp r]
	set ::tcltest::loadScript [read $tmp]
	close $tmp
    }

    # If the user specifies debug testing, print out extra information during
    # the run.
    if {[info exists flag(-debug)]} {
	set ::tcltest::debug $flag(-debug)
    }

    # Handle -preservecore
    if {[info exists flag(-preservecore)]} {
	set ::tcltest::preserveCore $flag(-preservecore)
    }

    # Call the hook
    ::tcltest::processCmdLineArgsHook [array get flag]

    # Spit out everything you know if we're at a debug level 2 or greater

    DebugPuts    2 "Flags passed into tcltest:"
    DebugPArray  2 flag
    DebugPuts    2 "::tcltest::debug              = $::tcltest::debug"
    DebugPuts    2 "::tcltest::testsDirectory     = $::tcltest::testsDirectory"
    DebugPuts    2 "::tcltest::workingDirectory   = $::tcltest::workingDirectory"
    DebugPuts    2 "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory"
    DebugPuts    2 "::tcltest::outputChannel      = $::tcltest::outputChannel"
    DebugPuts    2 "::tcltest::errorChannel       = $::tcltest::errorChannel"
    DebugPuts    2 "Original environment (::tcltest::originalEnv):"
    DebugPArray  2 ::tcltest::originalEnv
    DebugPuts    2 "Constraints:"
    DebugPArray  2 ::tcltest::testConstraints
}

# ::tcltest::loadTestedCommands --
#
#     Uses the specified script to load the commands to test. Allowed to
#     be empty, as the tested commands could have been compiled into the
#     interpreter.
#
# Arguments
#     none
#
# Results
#     none

proc ::tcltest::loadTestedCommands {} {
    if {$::tcltest::loadScript == {}} {
	return
    }
    
    uplevel #0 $::tcltest::loadScript
}

# ::tcltest::cleanupTests --
#
# Remove files and dirs created using the makeFile and makeDirectory
# commands since the last time this proc was invoked.
#
# Print the names of the files created without the makeFile command
# since the tests were invoked.
#
# Print the number tests (total, passed, failed, and skipped) since the
# tests were invoked.
# 
# Restore original environment (as reported by special variable env).

proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {

    set testFileName [file tail [info script]]

    # Call the cleanup hook
    ::tcltest::cleanupTestsHook 

    # Remove files and directories created by the :tcltest::makeFile and
    # ::tcltest::makeDirectory procedures.
    # Record the names of files in ::tcltest::workingDirectory that were not
    # pre-existing, and associate them with the test file that created them.

    if {!$calledFromAllFile} {
	foreach file $::tcltest::filesMade {
	    if {[file exists $file]} {
		catch {file delete -force $file}
	    }
	}
	set currentFiles {}
	foreach file [glob -nocomplain \
		[file join $::tcltest::temporaryDirectory *]] {
	    lappend currentFiles [file tail $file]
	}
	set newFiles {}
	foreach file $currentFiles {
	    if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
		lappend newFiles $file
	    }
	}
	set ::tcltest::filesExisted $currentFiles
	if {[llength $newFiles] > 0} {
	    set ::tcltest::createdNewFiles($testFileName) $newFiles
	}
    }

    if {$calledFromAllFile || $::tcltest::testSingleFile} {

	# print stats

	puts -nonewline $::tcltest::outputChannel "$testFileName:"
	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    puts -nonewline $::tcltest::outputChannel \
		    "\t$index\t$::tcltest::numTests($index)"
	}
	puts $::tcltest::outputChannel ""

	# print number test files sourced
	# print names of files that ran tests which failed

	if {$calledFromAllFile} {
	    puts $::tcltest::outputChannel \
		    "Sourced $::tcltest::numTestFiles Test Files."
	    set ::tcltest::numTestFiles 0
	    if {[llength $::tcltest::failFiles] > 0} {
		puts $::tcltest::outputChannel \
			"Files with failing tests: $::tcltest::failFiles"
		set ::tcltest::failFiles {}
	    }
	}

	# if any tests were skipped, print the constraints that kept them
	# from running.

	set constraintList [array names ::tcltest::skippedBecause]
	if {[llength $constraintList] > 0} {
	    puts $::tcltest::outputChannel \
		    "Number of tests skipped for each constraint:"
	    foreach constraint [lsort $constraintList] {
		puts $::tcltest::outputChannel \
			"\t$::tcltest::skippedBecause($constraint)\t$constraint"
		unset ::tcltest::skippedBecause($constraint)
	    }
	}

	# report the names of test files in ::tcltest::createdNewFiles, and
	# reset the array to be empty.

	set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
	if {[llength $testFilesThatTurded] > 0} {
	    puts $::tcltest::outputChannel "Warning: files left behind:"
	    foreach testFile $testFilesThatTurded {
		puts $::tcltest::outputChannel \
			"\t$testFile:\t$::tcltest::createdNewFiles($testFile)"
		unset ::tcltest::createdNewFiles($testFile)
	    }
	}

	# reset filesMade, filesExisted, and numTests

	set ::tcltest::filesMade {}
	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    set ::tcltest::numTests($index) 0
	}

	# exit only if running Tk in non-interactive mode

	global tk_version tcl_interactive
	if {[info exists tk_version] && ![info exists tcl_interactive]} {
	    exit
	}
    } else {

	# if we're deferring stat-reporting until all files are sourced,
	# then add current file to failFile list if any tests in this file
	# failed

	incr ::tcltest::numTestFiles
	if {($::tcltest::currentFailure) && \
		([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} {
	    lappend ::tcltest::failFiles $testFileName
	}
	set ::tcltest::currentFailure false

	# restore the environment to the state it was in before this package
	# was loaded

	set newEnv {}
	set changedEnv {}
	set removedEnv {}
	foreach index [array names ::env] {
	    if {![info exists ::tcltest::originalEnv($index)]} {
		lappend newEnv $index
		unset ::env($index)
	    } else {
		if {$::env($index) != $::tcltest::originalEnv($index)} {
		    lappend changedEnv $index
		    set ::env($index) $::tcltest::originalEnv($index)
		}
	    }
	}
	foreach index [array names ::tcltest::originalEnv] {
	    if {![info exists ::env($index)]} {
		lappend removedEnv $index
		set ::env($index) $::tcltest::originalEnv($index)
	    }
	}
	if {[llength $newEnv] > 0} {
	    puts $::tcltest::outputChannel \
		    "env array elements created:\t$newEnv"
	}
	if {[llength $changedEnv] > 0} {
	    puts $::tcltest::outputChannel \
		    "env array elements changed:\t$changedEnv"
	}
	if {[llength $removedEnv] > 0} {
	    puts $::tcltest::outputChannel \
		    "env array elements removed:\t$removedEnv"
	}

	set changedTclPlatform {}
	foreach index [array names ::tcltest::originalTclPlatform] {
	    if {$::tcl_platform($index) != \
		    $::tcltest::originalTclPlatform($index)} { 
		lappend changedTclPlatform $index
		set ::tcl_platform($index) \
			$::tcltest::originalTclPlatform($index) 
	    }
	}
	if {[llength $changedTclPlatform] > 0} {
	    puts $::tcltest::outputChannel \
		    "tcl_platform array elements changed:\t$changedTclPlatform"
	} 

	if {[file exists [file join $::tcltest::workingDirectory core]]} {
	    if {$::tcltest::preserveCore > 1} {
		puts $::tcltest::outputChannel "produced core file! \
			Moving file to: \
			[file join $::tcltest::temporaryDirectory core-$name]"
		flush $::tcltest::outputChannel
		catch {file rename -force \
			[file join $::tcltest::workingDirectory core] \
			[file join $::tcltest::temporaryDirectory \
			core-$name]} msg
		if {[string length $msg] > 0} {
		    ::tcltest::PrintError "Problem renaming file: $msg"
		}
	    } else {
		# Print a message if there is a core file and (1) there
		# previously wasn't one or (2) the new one is different from
		# the old one. 

		if {[info exists ::tcltest::coreModificationTime]} {
		    if {$::tcltest::coreModificationTime != [file mtime \
			    [file join $::tcltest::workingDirectory core]]} {
			puts $::tcltest::outputChannel "A core file was created!"
		    }
		} else {
		    puts $::tcltest::outputChannel "A core file was created!"
		} 
	    }
	}
    }
}

# ::tcltest::cleanupTestsHook --
#
#	This hook allows a harness that builds upon tcltest to specify
#       additional things that should be done at cleanup.
#

if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} {
    proc ::tcltest::cleanupTestsHook {} {}
}

# test --
#
# This procedure runs a test and prints an error message if the test fails.
# If ::tcltest::verbose has been set, it also prints a message even if the
# test succeeds.  The test will be skipped if it doesn't match the
# ::tcltest::match variable, if it matches an element in
# ::tcltest::skip, or if one of the elements of "constraints" turns
# out not to be true.
#
# Arguments:
# name -		Name of test, in the form foo-1.2.
# description -		Short textual description of the test, to
#			help humans understand what it does.
# constraints -		A list of one or more keywords, each of
#			which must be the name of an element in
#			the array "::tcltest::testConstraints".  If any of these
#			elements is zero, the test is skipped.
#			This argument may be omitted.
# script -		Script to run to carry out the test.  It must
#			return a result that can be checked for
#			correctness.
# expectedAnswer -	Expected result from script.

proc ::tcltest::test {name description script expectedAnswer args} {

    DebugPuts 3 "Running $name ($description)"

    incr ::tcltest::numTests(Total)

    # skip the test if it's name matches an element of skip

    foreach pattern $::tcltest::skip {
	if {[string match $pattern $name]} {
	    incr ::tcltest::numTests(Skipped)
	    DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedSkip}
	    return
	}
    }

    # skip the test if it's name doesn't match any element of match

    if {[llength $::tcltest::match] > 0} {
	set ok 0
	foreach pattern $::tcltest::match {
	    if {[string match $pattern $name]} {
		set ok 1
		break
	    }
        }
	if {!$ok} {
	    incr ::tcltest::numTests(Skipped)
	    DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch}
	    return
	}
    }

    set i [llength $args]
    if {$i == 0} {
	set constraints {}
	# If we're limited to the listed constraints and there aren't any
	# listed, then we shouldn't run the test.
	if {$::tcltest::limitConstraints} {
	    ::tcltest::AddToSkippedBecause userSpecifiedLimitConstraint
	    incr ::tcltest::numTests(Skipped)
	    return
	}
    } elseif {$i == 1} {

	# "constraints" argument exists;  shuffle arguments down, then
	# make sure that the constraints are satisfied.

	set constraints $script
	set script $expectedAnswer
	set expectedAnswer [lindex $args 0]
	set doTest 0
	if {[string match {*[$\[]*} $constraints] != 0} {
	    # full expression, e.g. {$foo > [info tclversion]}
	    catch {set doTest [uplevel #0 expr $constraints]}
	} elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
	    # something like {a || b} should be turned into