tcltest.tcl

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

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

    set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \
	    "Windows NT"]
    set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) \
	    "Windows 95"]
    set ::tcltest::testConstraints(98) [string equal $tcl_platform(os) \
	    "Windows 98"]

    # The following Constraints switches are used to mark tests that should
    # work, but have been temporarily disabled on certain platforms because
    # they don't and we haven't gotten around to fixing the underlying
    # problem. 

    set ::tcltest::testConstraints(tempNotPc) \
	    [expr {!$::tcltest::testConstraints(pc)}]
    set ::tcltest::testConstraints(tempNotMac) \
	    [expr {!$::tcltest::testConstraints(mac)}]
    set ::tcltest::testConstraints(tempNotUnix) \
	    [expr {!$::tcltest::testConstraints(unix)}]

    # The following Constraints switches are used to mark tests that crash on
    # certain platforms, so that they can be reactivated again when the
    # underlying problem is fixed.

    set ::tcltest::testConstraints(pcCrash) \
	    [expr {!$::tcltest::testConstraints(pc)}]
    set ::tcltest::testConstraints(macCrash) \
	    [expr {!$::tcltest::testConstraints(mac)}]
    set ::tcltest::testConstraints(unixCrash) \
	    [expr {!$::tcltest::testConstraints(unix)}]

    # Skip empty tests

    set ::tcltest::testConstraints(emptyTest) 0

    # By default, tests that expose known bugs are skipped.

    set ::tcltest::testConstraints(knownBug) 0

    # By default, non-portable tests are skipped.

    set ::tcltest::testConstraints(nonPortable) 0

    # Some tests require user interaction.

    set ::tcltest::testConstraints(userInteraction) 0

    # Some tests must be skipped if the interpreter is not in interactive mode
    
    if {[info exists tcl_interactive]} {
	set ::tcltest::testConstraints(interactive) $::tcl_interactive
    } else {
	set ::tcltest::testConstraints(interactive) 0
    }

    # Some tests can only be run if the installation came from a CD image
    # instead of a web image
    # Some tests must be skipped if you are running as root on Unix.
    # Other tests can only be run if you are running as root on Unix.

    set ::tcltest::testConstraints(root) 0
    set ::tcltest::testConstraints(notRoot) 1
    set user {}
    if {[string equal $tcl_platform(platform) "unix"]} {
	catch {set user [exec whoami]}
	if {[string equal $user ""]} {
	    catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
	}
	if {([string equal $user "root"]) || ([string equal $user ""])} {
	    set ::tcltest::testConstraints(root) 1
	    set ::tcltest::testConstraints(notRoot) 0
	}
    }

    # Set nonBlockFiles constraint: 1 means this platform supports
    # setting files into nonblocking mode.

    if {[catch {set f [open defs r]}]} {
	set ::tcltest::testConstraints(nonBlockFiles) 1
    } else {
	if {[catch {fconfigure $f -blocking off}] == 0} {
	    set ::tcltest::testConstraints(nonBlockFiles) 1
	} else {
	    set ::tcltest::testConstraints(nonBlockFiles) 0
	}
	close $f
    }

    # Set asyncPipeClose constraint: 1 means this platform supports
    # async flush and async close on a pipe.
    #
    # Test for SCO Unix - cannot run async flushing tests because a
    # potential problem with select is apparently interfering.
    # (Mark Diekhans).

    if {[string equal $tcl_platform(platform) "unix"]} {
	if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
	    set ::tcltest::testConstraints(asyncPipeClose) 0
	} else {
	    set ::tcltest::testConstraints(asyncPipeClose) 1
	}
    } else {
	set ::tcltest::testConstraints(asyncPipeClose) 1
    }

    # Test to see if we have a broken version of sprintf with respect
    # to the "e" format of floating-point numbers.

    set ::tcltest::testConstraints(eformat) 1
    if {![string equal "[format %g 5e-5]" "5e-05"]} {
	set ::tcltest::testConstraints(eformat) 0
    }

    # Test to see if execed commands such as cat, echo, rm and so forth are
    # present on this machine.

    set ::tcltest::testConstraints(unixExecs) 1
    if {[string equal $tcl_platform(platform) "macintosh"]} {
	set ::tcltest::testConstraints(unixExecs) 0
    }
    if {($::tcltest::testConstraints(unixExecs) == 1) && \
	    ([string equal $tcl_platform(platform) "windows"])} {
	if {[catch {exec cat defs}] == 1} {
	    set ::tcltest::testConstraints(unixExecs) 0
	}
	if {($::tcltest::testConstraints(unixExecs) == 1) && \
		([catch {exec echo hello}] == 1)} {
	    set ::tcltest::testConstraints(unixExecs) 0
	}
	if {($::tcltest::testConstraints(unixExecs) == 1) && \
		([catch {exec sh -c echo hello}] == 1)} {
	    set ::tcltest::testConstraints(unixExecs) 0
	}
	if {($::tcltest::testConstraints(unixExecs) == 1) && \
		([catch {exec wc defs}] == 1)} {
	    set ::tcltest::testConstraints(unixExecs) 0
	}
	if {$::tcltest::testConstraints(unixExecs) == 1} {
	    exec echo hello > removeMe
	    if {[catch {exec rm removeMe}] == 1} {
		set ::tcltest::testConstraints(unixExecs) 0
	    }
	}
	if {($::tcltest::testConstraints(unixExecs) == 1) && \
		([catch {exec sleep 1}] == 1)} {
	    set ::tcltest::testConstraints(unixExecs) 0
	}
	if {($::tcltest::testConstraints(unixExecs) == 1) && \
		([catch {exec fgrep unixExecs defs}] == 1)} {
	    set ::tcltest::testConstraints(unixExecs) 0
	}
	if {($::tcltest::testConstraints(unixExecs) == 1) && \
		([catch {exec ps}] == 1)} {
	    set ::tcltest::testConstraints(unixExecs) 0
	}
	if {($::tcltest::testConstraints(unixExecs) == 1) && \
		([catch {exec echo abc > removeMe}] == 0) && \
		([catch {exec chmod 644 removeMe}] == 1) && \
		([catch {exec rm removeMe}] == 0)} {
	    set ::tcltest::testConstraints(unixExecs) 0
	} else {
	    catch {exec rm -f removeMe}
	}
	if {($::tcltest::testConstraints(unixExecs) == 1) && \
		([catch {exec mkdir removeMe}] == 1)} {
	    set ::tcltest::testConstraints(unixExecs) 0
	} else {
	    catch {exec rm -r removeMe}
	}
    }

    # Locate tcltest executable

    if {![info exists tk_version]} {
	set tcltest [info nameofexecutable]

	if {$tcltest == "{}"} {
	    set tcltest {}
	}
    }

    set ::tcltest::testConstraints(stdio) 0
    catch {
	catch {file delete -force tmp}
	set f [open tmp w]
	puts $f {
	    exit
	}
	close $f

	set f [open "|[list $tcltest tmp]" r]
	close $f
	
	set ::tcltest::testConstraints(stdio) 1
    }
    catch {file delete -force tmp}

    # Deliberately call socket with the wrong number of arguments.  The error
    # message you get will indicate whether sockets are available on this
    # system. 

    catch {socket} msg
    set ::tcltest::testConstraints(socket) \
	    [expr {$msg != "sockets are not available on this system"}]
    
    # Check for internationalization

    if {[info commands testlocale] == ""} {
	# No testlocale command, no tests...
	set ::tcltest::testConstraints(hasIsoLocale) 0
    } else {
	set ::tcltest::testConstraints(hasIsoLocale) \
		[string length [::tcltest::set_iso8859_1_locale]]
	::tcltest::restore_locale
    }
}   

# ::tcltest::PrintUsageInfoHook
#
#       Hook used for customization of display of usage information.
#

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

# ::tcltest::PrintUsageInfo
#
#	Prints out the usage information for package tcltest.  This can be
#       customized with the redefinition of ::tcltest::PrintUsageInfoHook.
#
# Arguments:
#	none
#

proc ::tcltest::PrintUsageInfo {} {
    puts [format "Usage: [file tail [info nameofexecutable]] \
	    script ?-help? ?flag value? ... \n\
	    Available flags (and valid input values) are: \n\
	    -help          \t Display this usage information. \n\
	    -verbose level \t Takes any combination of the values \n\
	    \t                 'p', 's' and 'b'.  Test suite will \n\
	    \t                 display all passed tests if 'p' is \n\
	    \t                 specified, all skipped tests if 's' \n\
	    \t                 is specified, and the bodies of \n\
	    \t                 failed tests if 'b' is specified. \n\
	    \t                 The default value is 'b'. \n\
	    -constraints list\t Do not skip the listed constraints\n\
	    -limitconstraints bool\t Only run tests with the constraints\n\
	    \t                 listed in -constraints.\n\
	    -match pattern \t Run all tests within the specified \n\
	    \t                 files that match the glob pattern \n\
	    \t                 given. \n\
	    -skip pattern  \t Skip all tests within the set of \n\
	    \t                 specified tests (via -match) and \n\
	    \t                 files that match the glob pattern \n\
	    \t                 given. \n\
	    -file pattern  \t Run tests in all test files that \n\
	    \t                 match the glob pattern given. \n\
	    -notfile pattern\t Skip all test files that match the \n\
	    \t                 glob pattern given. \n\
	    -preservecore level \t If 2, save any core files produced \n\
	    \t                 during testing in the directory \n\
	    \t                 specified by -tmpdir. If 1, notify the\n\
	    \t                 user if core files are created. The default \n\
	    \t                 is $::tcltest::preserveCore. \n\
	    -tmpdir directory\t Save temporary files in the specified\n\
	    \t                 directory.  The default value is \n\
	    \t                 $::tcltest::temporaryDirectory. \n\
	    -testdir directories\t Search tests in the specified\n\
	    \t                 directories.  The default value is \n\
	    \t                 $::tcltest::testsDirectory. \n\
	    -outfile file    \t Send output from test runs to the \n\
	    \t                 specified file.  The default is \n\
	    \t                 stdout. \n\
	    -errfile file    \t Send errors from test runs to the \n\
	    \t                 specified file.  The default is \n\
	    \t                 stderr. \n\
	    -loadfile file   \t Read the script to load the tested \n\
	    \t                 commands from the specified file. \n\
	    -load script     \t Specifies the script to load the tested \n\
	    \t                 commands. \n\
	    -debug level     \t Internal debug flag."]
    ::tcltest::PrintUsageInfoHook
    return
}

# ::tcltest::CheckDirectory --
#
#     This procedure checks whether the specified path is a readable
#     and/or writable directory. If one of the conditions is not
#     satisfied an error is printed and the application aborted. The
#     procedure assumes that the caller already checked the existence
#     of the path.
#
# Arguments
#     rw      Information what attributes to check. Allowed values:
#             r, w, rw, wr. If 'r' is part of the value the directory
#             must be readable. 'w' associates to 'writable'.
#     dir     The directory to check.
#     errMsg  The string to prepend to the actual error message before
#             printing it.
#
# Results
#     none
#

proc ::tcltest::CheckDirectory {rw dir errMsg} {
    # Allowed values for 'rw': r, w, rw, wr

    if {![file isdir $dir]} { 
	::tcltest::PrintError "$errMsg \"$dir\" is not a directory"
	exit 1
    } elseif {([string first w $rw] >= 0) && ![file writable $dir]} {
	::tcltest::PrintError "$errMsg \"$dir\" is not writeable"
	exit 1
    } elseif {([string first r $rw] >= 0) && ![file readable $dir]} {
	::tcltest::PrintError "$errMsg \"$dir\" is not readable"
	exit 1
    }
}

# ::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 contains the name of the variable containing the path to modify.
#
# Results
#     The path is modified in place.
#

proc ::tcltest::normalizePath {pathVar} {
    upvar $pathVar path

    set oldpwd [pwd]
    catch {cd $path}
    set path [pwd]
    cd $oldpwd
}

# ::tcltest::MakeAbsolutePath --
#
#     This procedure checks whether the incoming path is absolute or not.
#     Makes it absolute if it was not.
#
# Arguments
#     pathVar contains the name of the variable containing the path to modify.
#     prefix  is optional, contains the path to use to make the other an
#             absolute one. The current working directory is used if it was
#             not specified.
#
# Results
#     The path is modified in place.
#

proc ::tcltest::MakeAbsolutePath {pathVar {prefix {}}} {
    upvar $pathVar path

    if {![string equal [file pathtype $path] "absolute"]} { 
	if {$prefix == {}} {
	    set prefix [pwd]
	}

	set path [file join $prefix $path] 
    }
}

# ::tcltest::processCmdLineArgsFlagsHook --
#
#	This hook is used to add to the list of command line arguments that are
#       processed by ::tcltest::processCmdLineArgs. 
#

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

# ::tcltest::processCmdLineArgsHook --
#
#	This hook is used to actually process the flags added by
#       ::tcltest::processCmdLineArgsAddFlagsHook.
#
# Arguments:
#	flags      The flags that have been pulled out of argv
#

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

# ::tcltest::processCmdLineArgs --
#
#	Use command line args to set the verbose, skip, and
#	match, outputChannel, errorChannel, debug, and temporaryDirectory
#       variables.   
#
#       This procedure must be run after constraints are initialized, because
#       some constraints can be overridden.
#
# Arguments:
#	none
#
# Results:
#	Sets the above-named variables in the tcltest namespace.

proc ::tcltest::processCmdLineArgs {} {
    global argv

    # The "argv" var doesn't exist in some cases, so use {}.

    if {(![info exists argv]) || ([llength $argv] < 1)} {
	set flagArray {}
    } else {
	set flagArray $argv
    }
    
    # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
    # Note that -verbose cannot be abbreviated to -v in wish because it
    # conflicts with the wish option -visual.

    # Process -help first
    if {([lsearch -exact $flagArray {-help}] != -1) || \
	    ([lsearch -exact $flagArray {-h}] != -1)} {
	::tcltest::PrintUsageInfo
	exit 1
    }

    if {[catch {array set flag $flagArray}]} {
	::tcltest::PrintError "odd number of arguments specified on command line: \ 
	$argv"
	::tcltest::PrintUsageInfo
	exit 1
    }

    # -help is not listed since it has already been processed
    lappend defaultFlags -verbose -match -skip -constraints \
	    -outfile -errfile -debug -tmpdir -file -notfile \
	    -preservecore -limitconstraints -args -testdir \
	    -load -loadfile
    set defaultFlags [concat $defaultFlags \
	    [ ::tcltest::processCmdLineArgsAddFlagsHook ]]

    foreach arg $defaultFlags {
	set abbrev [string range $arg 0 1]
	if {([info exists flag($abbrev)]) && \
		([lsearch -exact $flagArray $arg] < [lsearch -exact \
		$flagArray $abbrev])} { 
	    set flag($arg) $flag($abbrev)
	}
    }

    # Set ::tcltest::parameters to the arg of the -args flag, if given
    if {[info exists flag(-args)]} {
	set ::tcltest::parameters $flag(-args)
    }

    # Set ::tcltest::verbose to the arg of the -verbose flag, if given

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

    # Set ::tcltest::match to the arg of the -match flag, if given.  

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

    # Set ::tcltest::skip to the arg of the -skip flag, if given