tcltest.tcl

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

# 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.
# All rights reserved.
# 
# RCS: @(#) $Id: tcltest.tcl,v 1.1 2003/02/05 10:54:49 mdejong Exp $

package provide tcltest 1.0

# create the "tcltest" namespace for all testing variables and procedures

namespace eval tcltest { 

    # Export the public tcltest procs
    set procList [list test cleanupTests saveState restoreState \
	    normalizeMsg makeFile removeFile makeDirectory removeDirectory \
	    viewFile bytestring safeFetch threadReap getMatchingFiles \
	    loadTestedCommands normalizePath]
    foreach proc $procList {
	namespace export $proc
    }

    # ::tcltest::verbose defaults to "b"
    if {![info exists verbose]} {
	variable verbose "b"
    }

    # Match and skip patterns default to the empty list, except for
    # matchFiles, which defaults to all .test files in the testsDirectory

    if {![info exists match]} {
	variable match {}
    }
    if {![info exists skip]} {
	variable skip {}
    }
    if {![info exists matchFiles]} {
	variable matchFiles {*.test}
    }
    if {![info exists skipFiles]} {
	variable skipFiles {}
    }

    # By default, don't save core files
    if {![info exists preserveCore]} {
	variable preserveCore 0
    }

    # output goes to stdout by default
    if {![info exists outputChannel]} {
	variable outputChannel stdout
    }

    # errors go to stderr by default
    if {![info exists errorChannel]} {
	variable errorChannel stderr
    }

    # debug output doesn't get printed by default; debug level 1 spits
    # up only the tests that were skipped because they didn't match or were 
    # specifically skipped.  A debug level of 2 would spit up the tcltest
    # variables and flags provided; a debug level of 3 causes some additional
    # output regarding operations of the test harness.  The tcltest package
    # currently implements only up to debug level 3.
    if {![info exists debug]} {
	variable debug 0
    }

    # Save any arguments that we might want to pass through to other programs. 
    # This is used by the -args flag.
    if {![info exists parameters]} {
	variable parameters {}
    }

    # Count the number of files tested (0 if all.tcl wasn't called).
    # The all.tcl file will set testSingleFile to false, so stats will
    # not be printed until all.tcl 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.

    if {![info exists numTestFiles]} {
	variable numTestFiles 0
    }
    if {![info exists testSingleFile]} {
	variable testSingleFile true
    }
    if {![info exists currentFailure]} {
	variable currentFailure false
    }
    if {![info exists failFiles]} {
	variable failFiles {}
    }

    # Tests should remove all files they create.  The test suite will
    # check the current working dir for files created by the tests.
    # ::tcltest::filesMade keeps track of such files created using the
    # ::tcltest::makeFile and ::tcltest::makeDirectory procedures.
    # ::tcltest::filesExisted stores the names of pre-existing files.

    if {![info exists filesMade]} {
	variable filesMade {}
    }
    if {![info exists filesExisted]} {
	variable filesExisted {}
    }

    # ::tcltest::numTests will store test files as indices and the list
    # of files (that should not have been) left behind by the test files.

    if {![info exists createdNewFiles]} {
	variable createdNewFiles
	array set ::tcltest::createdNewFiles {}
    }

    # initialize ::tcltest::numTests array to keep track fo the number of
    # tests that pass, fail, and are skipped.

    if {![info exists numTests]} {
	variable numTests
	array set ::tcltest::numTests \
		[list Total 0 Passed 0 Skipped 0 Failed	0] 
    }

    # initialize ::tcltest::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. 

    if {![info exists skippedBecause]} {
	variable skippedBecause
	array set ::tcltest::skippedBecause {}
    }

    # initialize the ::tcltest::testConstraints array to keep track of valid
    # predefined constraints (see the explanation for the
    # ::tcltest::initConstraints proc for more details).

    if {![info exists testConstraints]} {
	variable testConstraints
	array set ::tcltest::testConstraints {}
    }

    # Don't run only the constrained tests by default

    if {![info exists limitConstraints]} {
	variable limitConstraints false
    }

    # A test application has to know how to load the tested commands into
    # the interpreter.

    if {![info exists loadScript]} {
	variable loadScript {}
    }

    # tests that use threads need to know which is the main thread

    if {![info exists mainThread]} {
	variable mainThread 1
	if {[info commands thread::id] != {}} {
	    set mainThread [thread::id]
	} elseif {[info commands testthread] != {}} {
	    set mainThread [testthread id]
	}
    }

    # save the original environment so that it can be restored later
    
    if {![info exists originalEnv]} {
	variable originalEnv
	array set ::tcltest::originalEnv [array get ::env]
    }

    # Set ::tcltest::workingDirectory to [pwd]. The default output directory
    # for Tcl tests is the working directory.

    if {![info exists workingDirectory]} {
	variable workingDirectory [pwd]
    }
    if {![info exists temporaryDirectory]} {
	variable temporaryDirectory $workingDirectory
    }

    # Tests should not rely on the current working directory.
    # Files that are part of the test suite should be accessed relative to 
    # ::tcltest::testsDirectory.

    if {![info exists testsDirectory]} {
	set oldpwd [pwd]
	catch {cd [file join [file dirname [info script]] .. .. tests]}
	variable testsDirectory [pwd]
	cd $oldpwd
	unset oldpwd
    }

    # the variables and procs that existed when ::tcltest::saveState was
    # called are stored in a variable of the same name
    if {![info exists saveState]} {
	variable saveState {}
    }

    # Internationalization support
    if {![info exists isoLocale]} {
	variable isoLocale fr
        switch $tcl_platform(platform) {
	    "unix" {

		# Try some 'known' values for some platforms:

		switch -exact -- $tcl_platform(os) {
		    "FreeBSD" {
			set ::tcltest::isoLocale fr_FR.ISO_8859-1
		    }
		    HP-UX {
			set ::tcltest::isoLocale fr_FR.iso88591
		    }
		    Linux -
		    IRIX {
			set ::tcltest::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 ::tcltest::isoLocale iso_8859_1
		    }
		}
	    }
	    "windows" {
		set ::tcltest::isoLocale French
	    }
	}
    }

    # Set the location of the execuatble
    if {![info exists tcltest]} {
	variable tcltest [info nameofexecutable]
    }

    # save the platform information so it can be restored later
    if {![info exists originalTclPlatform]} {
	variable originalTclPlatform [array get tcl_platform]
    }

    # If a core file exists, save its modification time.
    if {![info exists coreModificationTime]} {
	if {[file exists [file join $::tcltest::workingDirectory core]]} {
	    variable coreModificationTime [file mtime [file join \
		    $::tcltest::workingDirectory core]]
	}
    }

    # Tcl version numbers
    if {![info exists version]} {
	variable version 8.3
    }
    if {![info exists patchLevel]} {
	variable patchLevel 8.3.0
    }
}   

# ::tcltest::Debug* --
#
#     Internal helper procedures to write out debug information
#     dependent on the chosen level. A test shell may overide
#     them, f.e. to redirect the output into a different
#     channel, or even into a GUI.

# ::tcltest::DebugPuts --
#
#     Prints the specified string if the current debug level is
#     higher than the provided level argument.
#
# Arguments:
#     level   The lowest debug level triggering the output
#     string  The string to print out.
#
# Results:
#     Prints the string. Nothing else is allowed.
#

proc ::tcltest::DebugPuts {level string} {
    variable debug
    if {$debug >= $level} {
	puts $string
    }
}

# ::tcltest::DebugPArray --
#
#     Prints the contents of the specified array if the current
#       debug level is higher than the provided level argument
#
# Arguments:
#     level           The lowest debug level triggering the output
#     arrayvar        The name of the array to print out.
#
# Results:
#     Prints the contents of the array. Nothing else is allowed.
#

proc ::tcltest::DebugPArray {level arrayvar} {
    variable debug

    if {$debug >= $level} {
	catch {upvar  $arrayvar $arrayvar}
	parray $arrayvar
    }
}

# ::tcltest::DebugDo --
#
#     Executes the script if the current debug level is greater than
#       the provided level argument
#
# Arguments:
#     level   The lowest debug level triggering the execution.
#     script  The tcl script executed upon a debug level high enough.
#
# Results:
#     Arbitrary side effects, dependent on the executed script.
#

proc ::tcltest::DebugDo {level script} {
    variable debug

    if {$debug >= $level} {
	uplevel $script
    }
}

# ::tcltest::AddToSkippedBecause --
#
#	Increments the variable used to track how many tests were skipped
#       because of a particular constraint.
#
# Arguments:
#	constraint     The name of the constraint to be modified
#
# Results:
#	Modifies ::tcltest::skippedBecause; sets the variable to 1 if didn't
#       previously exist - otherwise, it just increments it.

proc ::tcltest::AddToSkippedBecause { constraint } {
    # add the constraint to the list of constraints that kept tests
    # from running

    if {[info exists ::tcltest::skippedBecause($constraint)]} {
	incr ::tcltest::skippedBecause($constraint)
    } else {
	set ::tcltest::skippedBecause($constraint) 1
    }
    return
}

# ::tcltest::PrintError --
#
#	Prints errors to ::tcltest::errorChannel and then flushes that
#       channel, making sure that all messages are < 80 characters per line.
#
# Arguments:
#	errorMsg     String containing the error to be printed
#

proc ::tcltest::PrintError {errorMsg} {
    set InitialMessage "Error:  "
    set InitialMsgLen  [string length $InitialMessage]
    puts -nonewline $::tcltest::errorChannel $InitialMessage

    # Keep track of where the end of the string is.
    set endingIndex [string length $errorMsg]

    if {$endingIndex < 80} {
	puts $::tcltest::errorChannel $errorMsg
    } else {
	# Print up to 80 characters on the first line, including the
	# InitialMessage. 
	set beginningIndex [string last " " [string range $errorMsg 0 \
		[expr {80 - $InitialMsgLen}]]]
	puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex]

	while {$beginningIndex != "end"} {
	    puts -nonewline $::tcltest::errorChannel \
		    [string repeat " " $InitialMsgLen]  
	    if {[expr {$endingIndex - $beginningIndex}] < 72} {
		puts $::tcltest::errorChannel [string trim \
			[string range $errorMsg $beginningIndex end]]
		set beginningIndex end
	    } else {
		set newEndingIndex [expr [string last " " [string range \
			$errorMsg $beginningIndex \
			[expr {$beginningIndex + 72}]]] + $beginningIndex]
		if {($newEndingIndex <= 0) \
			|| ($newEndingIndex <= $beginningIndex)} {
		    set newEndingIndex end
		}
		puts $::tcltest::errorChannel [string trim \
			[string range $errorMsg \
			$beginningIndex $newEndingIndex]]
		set beginningIndex $newEndingIndex
	    }
	}
    }
    flush $::tcltest::errorChannel
    return
}

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

# ::tcltest::initConstraints --
#
# Check Constraintsuration information that will determine which tests
# to run.  To do this, create an array ::tcltest::testConstraints.  Each
# element has a 0 or 1 value.  If the element is "true" then tests
# with that constraint will be run, otherwise tests with that constraint
# will be skipped.  See the tcltest man page for the list of built-in
# constraints defined in this procedure.
#
# Arguments:
#	none
#
# Results:
#	The ::tcltest::testConstraints array is reset to have an index for
#	each built-in test constraint.

proc ::tcltest::initConstraints {} {
    global tcl_platform tcl_interactive tk_version

    # The following trace procedure makes it so that we can safely refer to
    # non-existent members of the ::tcltest::testConstraints array without
    # causing an error.  Instead, reading a non-existent member will return 0.
    # This is necessary because tests are allowed to use constraint "X" without
    # ensuring that ::tcltest::testConstraints("X") is defined.

    trace variable ::tcltest::testConstraints r ::tcltest::safeFetch

    proc ::tcltest::safeFetch {n1 n2 op} {
	if {($n2 != {}) && ([info exists ::tcltest::testConstraints($n2)] == 0)} {
	    set ::tcltest::testConstraints($n2) 0
	}
    }

    ::tcltest::initConstraintsHook

    set ::tcltest::testConstraints(unixOnly) \
	    [string equal $tcl_platform(platform) "unix"]
    set ::tcltest::testConstraints(macOnly) \
	    [string equal $tcl_platform(platform) "macintosh"]
    set ::tcltest::testConstraints(pcOnly) \
	    [string equal $tcl_platform(platform) "windows"]

    set ::tcltest::testConstraints(unix) $::tcltest::testConstraints(unixOnly)
    set ::tcltest::testConstraints(mac) $::tcltest::testConstraints(macOnly)
    set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly)

    set ::tcltest::testConstraints(unixOrPc) \
	    [expr {$::tcltest::testConstraints(unix) \
	    || $::tcltest::testConstraints(pc)}]
    set ::tcltest::testConstraints(macOrPc) \
	    [expr {$::tcltest::testConstraints(mac) \