summaryrefslogtreecommitdiffstats
path: root/library/tcltest1.0/tcltest2.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/tcltest1.0/tcltest2.tcl')
-rwxr-xr-xlibrary/tcltest1.0/tcltest2.tcl3490
1 files changed, 0 insertions, 3490 deletions
diff --git a/library/tcltest1.0/tcltest2.tcl b/library/tcltest1.0/tcltest2.tcl
deleted file mode 100755
index c05732d..0000000
--- a/library/tcltest1.0/tcltest2.tcl
+++ /dev/null
@@ -1,3490 +0,0 @@
-# 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
-# All rights reserved.
-#
-# RCS: @(#) $Id: tcltest2.tcl,v 1.4 2000/10/19 18:00:58 jenn Exp $
-
-# 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 threadReap debug testConstraint \
- limitConstraints loadTestedCommands normalizePath verbose match \
- skip matchFiles skipFiles preserveCore loadScript loadFile \
- mainThread workingDirectory singleProcess interpreter runAllTests \
- outputChannel outputFile errorChannel \
- errorFile temporaryDirectory testsDirectory matchDirectories \
- skipDirectories ]
- foreach proc $procList {
- namespace export $proc
- }
-
- # tcltest::verbose defaults to {body}
- if {![info exists verbose]} {
- variable verbose {body}
- }
-
- # Match and skip patterns default to the empty list, except for
- # matchFiles, which defaults to all .test files in the testsDirectory and
- # matchDirectories, which defaults to all directories.
-
- 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 {}
- }
- if {![info exists matchDirectories]} {
- variable matchDirectories {*}
- }
- if {![info exists skipDirectories]} {
- variable skipDirectories {}
- }
-
- # 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
- }
- if {![info exists outputFile]} {
- variable outputFile stdout
- }
-
- # errors go to stderr by default
- if {![info exists errorChannel]} {
- variable errorChannel stderr
- }
- if {![info exists errorFile]} {
- variable errorFile 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 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.
-
- 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 {}
- }
-
- if {![info exists constraintsSpecified]} {
- variable constraintsSpecified {}
- }
-
- # 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 {}
- }
-
- # and the filename of the script file, if it exists
- if {![info exists loadFile]} {
- variable loadFile {}
- }
-
- # 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
- }
-
- # Default is to run each test file in a separate process
- if {![info exists singleProcess]} {
- variable singleProcess 0
- }
-
- # 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 -- used in tcltest::set_iso8859_1_locale
- # and tcltest::restore_locale. Those commands are used in cmdIL.test.
- if {![info exists previousLocale]} {
- variable previousLocale
- }
-
- 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]]
- }
- }
-
- # stdout and stderr buffers for use when we want to store them
- if {![info exists outData]} {
- variable outData {}
- }
- if {![info exists errData]} {
- variable errData {}
- }
-
- # keep track of test level for nested test commands
- variable testLevel 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.
-#
-# Side Effects:
-# None.
-#
-
-proc tcltest::DebugPuts {level string} {
- variable debug
- if {$debug >= $level} {
- puts $string
- }
- return
-}
-
-# 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.
-#
-# Side Effects:
-# None.
-#
-
-proc tcltest::DebugPArray {level arrayvar} {
- variable debug
-
- if {$debug >= $level} {
- catch {upvar $arrayvar $arrayvar}
- parray $arrayvar
- }
- return
-}
-
-# 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.
-#
-# Side Effects:
-# None.
-#
-
-proc tcltest::DebugDo {level script} {
- variable debug
-
- if {$debug >= $level} {
- uplevel $script
- }
- 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
-#
-# Side Effects:
-# None.
-#
-
-proc tcltest::CheckDirectory {rw dir errMsg} {
- # Allowed values for 'rw': r, w, rw, wr
-
- if {![file isdir $dir]} {
- set msg "$errMsg \"$dir\" is not a directory"
- error $msg
- } elseif {([string first w $rw] >= 0) && ![file writable $dir]} {
- set msg "$errMsg \"$dir\" is not writeable"
- error $msg
- } elseif {([string first r $rw] >= 0) && ![file readable $dir]} {
- set msg "$errMsg \"$dir\" is not readable"
- error $msg
- }
- return
-}
-
-# 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.
-#
-# Side Effects:
-# None.
-#
-
-proc tcltest::normalizePath {pathVar} {
- upvar $pathVar path
-
- set oldpwd [pwd]
- catch {cd $path}
- set path [pwd]
- cd $oldpwd
- return $path
-}
-
-
-# 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.
-#
-# Side Effects:
-# None.
-#
-
-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]
- }
- return $path
-}
-
-#####################################################################
-
-# tcltest::<variableName>
-#
-# Accessor functions for tcltest variables that can be modified externally.
-# These are vars that could otherwise be modified using command line
-# arguments to tcltest.
-
-# tcltest::verbose --
-#
-# Set or return the verbosity level (tcltest::verbose) for tests. This
-# determines what gets printed to the screen and when, with regard to the
-# running of the tests. The proc does not check for invalid values. It
-# assumes that a string that doesn't match its predefined keywords
-# is a string containing letter-specified verbosity levels.
-#
-# Arguments:
-# A string containing any combination of 'pbste' or a list of keywords
-# (listed in parens)
-# p = print output whenever a test passes (pass)
-# b = print the body of the test when it fails (body)
-# s = print when a test is skipped (skip)
-# t = print when a test starts (start)
-# e = print errorInfo and errorCode when a test encounters an error
-# (error)
-#
-# Results:
-# content of tcltest::verbose - this is always the character combination
-# (pbste) instead of the list form.
-#
-# Side effects:
-# None.
-
-proc tcltest::verbose { {level ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::verbose
- }
- if {[llength $level] > 1} {
- set tcltest::verbose $level
- } else {
- if {[regexp {pass|body|skip|start|error} $level]} {
- set tcltest::verbose $level
- } else {
- set levelList [split $level {}]
- set tcltest::verbose [string map {p pass b body s skip t start e
- error} $levelList]
- }
- }
- return $tcltest::verbose
-}
-
-# tcltest::isVerbose --
-#
-# Returns true if argument is one of the verbosity levels currently being
-# used; returns false otherwise.
-#
-# Arguments:
-# level
-#
-# Results:
-# boolean 1 (true) or 0 (false), depending on whether or not the level
-# provided is one of the ones stored in tcltest::verbose.
-#
-# Side effects:
-# None.
-
-proc tcltest::isVerbose {level} {
- if {[lsearch -exact [tcltest::verbose] $level] == -1} {
- return 0
- }
- return 1
-}
-
-
-
-# tcltest::match --
-#
-# Set or return the match patterns (tcltest::match) that determine which
-# tests are run.
-#
-# Arguments:
-# List containing match patterns (glob format)
-#
-# Results:
-# content of tcltest::match
-#
-# Side effects:
-# none
-
-proc tcltest::match { {matchList ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::match
- }
- set tcltest::match $matchList
-}
-
-# tcltest::skip --
-#
-# Set or return the skip patterns (tcltest::skip) that determine which
-# tests are skipped.
-#
-# Arguments:
-# List containing skip patterns (glob format)
-#
-# Results:
-# content of tcltest::skip
-#
-# Side effects:
-# None.
-
-proc tcltest::skip { {skipList ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::skip
- }
- set tcltest::skip $skipList
-}
-
-# tcltest::matchFiles --
-#
-# set or return the match patterns for file sourcing
-#
-# Arguments:
-# list containing match file list (glob format)
-#
-# Results:
-# content of tcltest::matchFiles
-#
-# Side effects:
-# None.
-
-proc tcltest::matchFiles { {matchFileList ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::matchFiles
- }
- set tcltest::matchFiles $matchFileList
-}
-
-# tcltest::skipFiles --
-#
-# set or return the skip patterns for file sourcing
-#
-# Arguments:
-# list containing the skip file list (glob format)
-#
-# Results:
-# content of tcltest::skipFiles
-#
-# Side effects:
-# None.
-
-proc tcltest::skipFiles { {skipFileList ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::skipFiles
- }
- set tcltest::skipFiles $skipFileList
-}
-
-
-# tcltest::matchDirectories --
-#
-# set or return the list of directories for matching (glob pattern list)
-#
-# Arguments:
-# list of glob patterns matching subdirectories of
-# tcltest::testsDirectory
-#
-# Results:
-# content of tcltest::matchDirectories
-#
-# Side effects:
-# None.
-
-proc tcltest::matchDirectories { {dirlist ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::matchDirectories
- }
- set tcltest::matchDirectories $dirlist
-}
-
-# tcltest::skipDirectories --
-#
-# set or return the list of directories to skip (glob pattern list)
-#
-# Arguments:
-# list of glob patterns matching directories to skip; these directories
-# are subdirectories of tcltest::testsDirectory
-#
-# Results:
-# content of tcltest::skipDirectories
-#
-# Side effects:
-# None.
-
-proc tcltest::skipDirectories { {dirlist ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::skipDirectories
- }
- set tcltest::skipDirectories $dirlist
-}
-
-# tcltest::preserveCore --
-#
-# set or return the core preservation level. This proc does not do any
-# error checking for invalid values.
-#
-# Arguments:
-# core level:
-# '0' = don't do anything with core files (default)
-# '1' = notify the user if core files are created
-# '2' = save any core files produced during testing to
-# tcltest::temporaryDirectory
-#
-# Results:
-# content of tcltest::preserveCore
-#
-# Side effects:
-# None.
-
-proc tcltest::preserveCore { {coreLevel ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::preserveCore
- }
- set tcltest::preserveCore $coreLevel
-}
-
-# tcltest::outputChannel --
-#
-# set or return the output file descriptor based on the supplied file
-# name (where tcltest puts all of its output)
-#
-# Arguments:
-# output file descriptor
-#
-# Results:
-# file descriptor corresponding to supplied file name (or currently set
-# file descriptor, if no new filename was supplied) - this is the content
-# of tcltest::outputChannel
-#
-# Side effects:
-# None.
-
-proc tcltest::outputChannel { {filename ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::outputChannel
- }
- if {($filename == "stderr") || ($filename == "stdout")} {
- set tcltest::outputChannel $filename
- } else {
- set tcltest::outputChannel [open $filename w]
- }
- return $tcltest::outputChannel
-}
-
-# tcltest::outputFile --
-#
-# set or return the output file name (where tcltest puts all of its
-# output); calls tcltest::outputChannel to set the corresponding file
-# descriptor
-#
-# Arguments:
-# output file name
-#
-# Results:
-# file name corresponding to supplied file name (or currently set
-# file name, if no new filename was supplied) - this is the content
-# of tcltest::outputFile
-#
-# Side effects:
-# if the file name supplied is relative, it will be made absolute with
-# respect to the predefined temporaryDirectory
-
-proc tcltest::outputFile { {filename ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::outputFile
- }
- if {($filename != "stderr") && ($filename != "stdout")} {
- MakeAbsolutePath filename $tcltest::temporaryDirectory
- }
- tcltest::outputChannel $filename
- set tcltest::outputFile $filename
-}
-
-# tcltest::errorChannel --
-#
-# set or return the error file descriptor based on the supplied file name
-# (where tcltest sends all its errors)
-#
-# Arguments:
-# error file name
-#
-# Results:
-# file descriptor corresponding to the supplied file name (or currently
-# set file descriptor, if no new filename was supplied) - this is the
-# content of tcltest::errorChannel
-#
-# Side effects:
-# opens the descriptor in w mode unless the filename is set to stderr or
-# stdout
-
-proc tcltest::errorChannel { {filename ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::errorChannel
- }
- if {($filename == "stderr") || ($filename == "stdout")} {
- set tcltest::errorChannel $filename
- } else {
- set tcltest::errorChannel [open $filename w]
- }
- return $tcltest::errorChannel
-}
-
-# tcltest::errorFile --
-#
-# set or return the error file name; calls tcltest::errorChannel to set
-# the corresponding file descriptor
-#
-# Arguments:
-# error file name
-#
-# Results:
-# content of tcltest::errorFile
-#
-# Side effects:
-# if the file name supplied is relative, it will be made absolute with
-# respect to the predefined temporaryDirectory
-
-proc tcltest::errorFile { {filename ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::errorFile
- }
- if {($filename != "stderr") && ($filename != "stdout")} {
- MakeAbsolutePath filename $tcltest::temporaryDirectory
- }
- set tcltest::errorFile $filename
- errorChannel $tcltest::errorFile
- return $tcltest::errorFile
-}
-
-# tcltest::debug --
-#
-# set or return the debug level for tcltest; this proc does not check for
-# invalid values
-#
-# Arguments:
-# debug level:
-# '0' = no debug output (default)
-# '1' = skipped tests
-# '2' = tcltest variables and supplied flags
-# '3' = harness operations
-#
-# Results:
-# content of tcltest::debug
-#
-# Side effects:
-# None.
-
-proc tcltest::debug { {debugLevel ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::debug
- }
- set tcltest::debug $debugLevel
-}
-
-# tcltest::testConstraint --
-#
-# sets a test constraint to a value; to do multiple constraints, call
-# this proc multiple times. also returns the value of the named
-# constraint if no value was supplied.
-#
-# Arguments:
-# constraint - name of the constraint
-# value - new value for constraint (should be boolean) - if not supplied,
-# this is a query
-#
-# Results:
-# content of tcltest::testConstraints($constraint)
-#
-# Side effects:
-# appends the constraint name to tcltest::constraintsSpecified
-
-proc tcltest::testConstraint {constraint {value ""}} {
- DebugPuts 3 "entering testConstraint $constraint $value"
- if {[llength [info level 0]] == 2} {
- return $tcltest::testConstraints($constraint)
- }
- lappend tcltest::constraintsSpecified $constraint
- set tcltest::testConstraints($constraint) $value
-}
-
-# tcltest::constraintsSpecified --
-#
-# returns a list of all the constraint names specified using
-# testConstraint
-#
-# Arguments:
-# None.
-#
-# Results:
-# list of the constraint names in tcltest::constraintsSpecified
-#
-# Side effects:
-# None.
-
-proc tcltest::constraintsSpecified {} {
- return $tcltest::constraintsSpecified
-}
-
-# tcltest::constraintList --
-#
-# returns a list of all the constraint names
-#
-# Arguments:
-# None.
-#
-# Results:
-# list of the constraint names in tcltest::testConstraints
-#
-# Side effects:
-# None.
-
-proc tcltest::constraintList {} {
- return [array names tcltest::testConstraints]
-}
-
-# tcltest::limitConstraints --
-#
-# sets the limited constraints to tcltest::limitConstraints
-#
-# Arguments:
-# list of constraint names
-#
-# Results:
-# content of tcltest::limitConstraints
-#
-# Side effects:
-# None.
-
-proc tcltest::limitConstraints { {constraintList ""} } {
- DebugPuts 3 "entering limitConstraints $constraintList"
- if {[llength [info level 0]] == 1} {
- return $tcltest::limitConstraints
- }
- set tcltest::limitConstraints $constraintList
- foreach elt [tcltest::constraintList] {
- if {[lsearch -exact [tcltest::constraintsSpecified] $elt] == -1} {
- tcltest::testConstraint $elt 0
- }
- }
- return $tcltest::limitConstraints
-}
-
-# tcltest::loadScript --
-#
-# sets the load script
-#
-# Arguments:
-# script to be set
-#
-# Results:
-# contents of tcltest::loadScript
-#
-# Side effects:
-# None.
-
-proc tcltest::loadScript { {script ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::loadScript
- }
- set tcltest::loadScript $script
-}
-
-# tcltest::loadFile --
-#
-# set the load file (containing the load script);
-# put the content of the load file into loadScript
-#
-# Arguments:
-# script's file name
-#
-# Results:
-# content of tcltest::loadFile
-#
-# Side effects:
-# None.
-
-proc tcltest::loadFile { {scriptFile ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::loadFile
- }
- MakeAbsolutePath scriptFile $tcltest::temporaryDirectory
- set tmp [open $scriptFile r]
- tcltest::loadScript [read $tmp]
- close $tmp
- set tcltest::loadFile $scriptFile
-}
-
-# tcltest::workingDirectory --
-#
-# set workingDirectory to the given path.
-# If the path is relative, make it absolute.
-# change directory to the stated working directory, if resetting the
-# value
-#
-# Arguments:
-# directory name
-#
-# Results:
-# content of tcltest::workingDirectory
-#
-# Side effects:
-# None.
-
-proc tcltest::workingDirectory { {dir ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::workingDirectory
- }
- set tcltest::workingDirectory $dir
- MakeAbsolutePath tcltest::workingDirectory
- cd $tcltest::workingDirectory
- return $tcltest::workingDirectory
-}
-
-# tcltest::temporaryDirectory --
-#
-# Set tcltest::temporaryDirectory to the given path.
-# 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 (the file mkdir isn't
-# caught and will propagate).
-#
-# Arguments:
-# directory name
-#
-# Results:
-# content of tcltest::temporaryDirectory
-#
-# Side effects:
-# None.
-
-proc tcltest::temporaryDirectory { {dir ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::temporaryDirectory
- }
- set tcltest::temporaryDirectory $dir
-
- MakeAbsolutePath tcltest::temporaryDirectory
- set tmpDirError "bad argument for temporary directory: "
-
- if {[file exists $tcltest::temporaryDirectory]} {
- tcltest::CheckDirectory rw $tcltest::temporaryDirectory $tmpDirError
- } else {
- file mkdir $tcltest::temporaryDirectory
- }
-
- normalizePath tcltest::temporaryDirectory
-}
-
-# tcltest::testsDirectory --
-#
-# Set tcltest::testsDirectory to the given path.
-# If the path is relative, make it absolute. If the file exists but
-# is not a dir, then return an error.
-#
-# If tcltest::testsDirectory does not already exist, return an error.
-#
-# Arguments:
-# directory name
-#
-# Results:
-# content of tcltest::testsDirectory
-#
-# Side effects:
-# None.
-
-proc tcltest::testsDirectory { {dir ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::testsDirectory
- }
-
- set tcltest::testsDirectory $dir
-
- MakeAbsolutePath tcltest::testsDirectory
- set testDirError "bad argument for tests directory: "
-
- if {[file exists $tcltest::testsDirectory]} {
- tcltest::CheckDirectory r $tcltest::testsDirectory $testDirError
- } else {
- set msg "$testDirError \"$tcltest::testsDirectory\" does not exist"
- error $msg
- }
-
- normalizePath tcltest::testsDirectory
-}
-
-# tcltest::singleProcess --
-#
-# sets tcltest::singleProcess to the value provided.
-#
-# Arguments:
-# value for singleProcess:
-# 1 = source each test file into the current process
-# 0 = run each test file in its own process
-#
-# Results:
-# content of tcltest::singleProcess
-#
-# Side effects:
-# None.
-
-proc tcltest::singleProcess { {value ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::singleProcess
- }
- set tcltest::singleProcess $value
-}
-
-# tcltest::interpreter --
-#
-# the interpreter name stored in tcltest::tcltest
-#
-# Arguments:
-# executable name
-#
-# Results:
-# content of tcltest::tcltest
-#
-# Side effects:
-# None.
-
-proc tcltest::interpreter { {interp ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::tcltest
- }
- set tcltest::tcltest $interp
-}
-
-# tcltest::mainThread --
-#
-# sets or returns the thread id stored in tcltest::mainThread
-#
-# Arguments:
-# thread id
-#
-# Results:
-# content of tcltest::mainThread
-#
-# Side effects:
-# None.
-
-proc tcltest::mainThread { {threadid ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::mainThread
- }
- set tcltest::mainThread $threadid
-}
-
-#####################################################################
-
-# 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.
-#
-# Side effects:
-# None.
-
-proc tcltest::AddToSkippedBecause { constraint {value 1}} {
- # add the constraint to the list of constraints that kept tests
- # from running
-
- if {[info exists tcltest::skippedBecause($constraint)]} {
- incr tcltest::skippedBecause($constraint) $value
- } else {
- set tcltest::skippedBecause($constraint) $value
- }
- 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
-#
-#
-# Results:
-# None.
-#
-# Side effects:
-# None.
-
-proc tcltest::PrintError {errorMsg} {
- set InitialMessage "Error: "
- set InitialMsgLen [string length $InitialMessage]
- puts -nonewline [errorChannel] $InitialMessage
-
- # Keep track of where the end of the string is.
- set endingIndex [string length $errorMsg]
-
- if {$endingIndex < 80} {
- puts [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 [errorChannel] [string range $errorMsg 0 $beginningIndex]
-
- while {$beginningIndex != "end"} {
- puts -nonewline [errorChannel] \
- [string repeat " " $InitialMsgLen]
- if {[expr {$endingIndex - $beginningIndex}] < 72} {
- puts [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 [errorChannel] [string trim \
- [string range $errorMsg \
- $beginningIndex $newEndingIndex]]
- set beginningIndex $newEndingIndex
- }
- }
- }
- flush [errorChannel]
- return
-}
-
-if {[namespace inscope tcltest info procs initConstraintsHook] == {}} {
- proc tcltest::initConstraintsHook {} {}
-}
-
-# tcltest::safeFetch --
-#
-# 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.
-#
-# Arguments:
-# n1 - name of the array (tcltest::testConstraints)
-# n2 - array key value (constraint name)
-# op - operation performed on tcltest::testConstraints (generally r)
-#
-# Results:
-# none
-#
-# Side effects:
-# sets tcltest::testConstraints($n2) to 0 if it's referenced but never
-# before used
-
-proc tcltest::safeFetch {n1 n2 op} {
- DebugPuts 3 "entering safeFetch $n1 $n2 $op"
- if {($n2 != {}) && ([info exists tcltest::testConstraints($n2)] == 0)} {
- tcltest::testConstraint $n2 0
- }
-}
-
-# tcltest::initConstraints --
-#
-# Check constraint 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.
-#
-# Side Effects:
-# None.
-#
-
-proc tcltest::initConstraints {} {
- global tcl_platform tcl_interactive tk_version
-
- # Safely refer to non-existent members of the tcltest::testConstraints
- # array without causing an error.
- trace variable tcltest::testConstraints r tcltest::safeFetch
-
- tcltest::initConstraintsHook
-
- tcltest::testConstraint singleTestInterp [singleProcess]
-
- # All the 'pc' constraints are here for backward compatibility and are not
- # documented. They have been replaced with equivalent 'win' constraints.
-
- tcltest::testConstraint unixOnly \
- [string equal $tcl_platform(platform) "unix"]
- tcltest::testConstraint macOnly \
- [string equal $tcl_platform(platform) "macintosh"]
- tcltest::testConstraint pcOnly \
- [string equal $tcl_platform(platform) "windows"]
- tcltest::testConstraint winOnly \
- [string equal $tcl_platform(platform) "windows"]
-
- tcltest::testConstraint unix [tcltest::testConstraint unixOnly]
- tcltest::testConstraint mac [tcltest::testConstraint macOnly]
- tcltest::testConstraint pc [tcltest::testConstraint pcOnly]
- tcltest::testConstraint win [tcltest::testConstraint winOnly]
-
- tcltest::testConstraint unixOrPc \
- [expr {[tcltest::testConstraint unix] \
- || [tcltest::testConstraint pc]}]
- tcltest::testConstraint macOrPc \
- [expr {[tcltest::testConstraint mac] \
- || [tcltest::testConstraint pc]}]
- tcltest::testConstraint unixOrWin \
- [expr {[tcltest::testConstraint unix] \
- || [tcltest::testConstraint win]}]
- tcltest::testConstraint macOrWin \
- [expr {[tcltest::testConstraint mac] \
- || [tcltest::testConstraint win]}]
- tcltest::testConstraint macOrUnix \
- [expr {[tcltest::testConstraint mac] \
- || [tcltest::testConstraint unix]}]
-
- tcltest::testConstraint nt [string equal $tcl_platform(os) "Windows NT"]
- tcltest::testConstraint 95 [string equal $tcl_platform(os) "Windows 95"]
- tcltest::testConstraint 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.
-
- tcltest::testConstraint tempNotPc \
- [expr {![tcltest::testConstraint pc]}]
- tcltest::testConstraint tempNotWin \
- [expr {![tcltest::testConstraint win]}]
- tcltest::testConstraint tempNotMac \
- [expr {![tcltest::testConstraint mac]}]
- tcltest::testConstraint tempNotUnix \
- [expr {![tcltest::testConstraint 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.
-
- tcltest::testConstraint pcCrash \
- [expr {![tcltest::testConstraint pc]}]
- tcltest::testConstraint winCrash \
- [expr {![tcltest::testConstraint win]}]
- tcltest::testConstraint macCrash \
- [expr {![tcltest::testConstraint mac]}]
- tcltest::testConstraint unixCrash \
- [expr {![tcltest::testConstraint unix]}]
-
- # Skip empty tests
-
- tcltest::testConstraint emptyTest 0
-
- # By default, tests that expose known bugs are skipped.
-
- tcltest::testConstraint knownBug 0
-
- # By default, non-portable tests are skipped.
-
- tcltest::testConstraint nonPortable 0
-
- # Some tests require user interaction.
-
- tcltest::testConstraint userInteraction 0
-
- # Some tests must be skipped if the interpreter is not in interactive mode
-
- if {[info exists tcl_interactive]} {
- tcltest::testConstraint interactive $::tcl_interactive
- } else {
- tcltest::testConstraint 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.
-
- tcltest::testConstraint root 0
- tcltest::testConstraint 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 ""])} {
- tcltest::testConstraint root 1
- tcltest::testConstraint notRoot 0
- }
- }
-
- # Set nonBlockFiles constraint: 1 means this platform supports
- # ting files into nonblocking mode.
-
- if {[catch {set f [open defs r]}]} {
- tcltest::testConstraint nonBlockFiles 1
- } else {
- if {[catch {fconfigure $f -blocking off}] == 0} {
- tcltest::testConstraint nonBlockFiles 1
- } else {
- tcltest::testConstraint 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} {
- tcltest::testConstraint asyncPipeClose 0
- } else {
- tcltest::testConstraint asyncPipeClose 1
- }
- } else {
- tcltest::testConstraint asyncPipeClose 1
- }
-
- # Test to see if we have a broken version of sprintf with respect
- # to the "e" format of floating-point numbers.
-
- tcltest::testConstraint eformat 1
- if {![string equal "[format %g 5e-5]" "5e-05"]} {
- tcltest::testConstraint eformat 0
- }
-
- # Test to see if execed commands such as cat, echo, rm and so forth are
- # present on this machine.
-
- tcltest::testConstraint unixExecs 1
- if {[string equal $tcl_platform(platform) "macintosh"]} {
- tcltest::testConstraint unixExecs 0
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([string equal $tcl_platform(platform) "windows"])} {
- if {[catch {exec cat defs}] == 1} {
- tcltest::testConstraint unixExecs 0
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec echo hello}] == 1)} {
- tcltest::testConstraint unixExecs 0
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec sh -c echo hello}] == 1)} {
- tcltest::testConstraint unixExecs 0
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec wc defs}] == 1)} {
- tcltest::testConstraint unixExecs 0
- }
- if {[tcltest::testConstraint unixExecs] == 1} {
- exec echo hello > removeMe
- if {[catch {exec rm removeMe}] == 1} {
- tcltest::testConstraint unixExecs 0
- }
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec sleep 1}] == 1)} {
- tcltest::testConstraint unixExecs 0
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec fgrep unixExecs defs}] == 1)} {
- tcltest::testConstraint unixExecs 0
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec ps}] == 1)} {
- tcltest::testConstraint unixExecs 0
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec echo abc > removeMe}] == 0) && \
- ([catch {exec chmod 644 removeMe}] == 1) && \
- ([catch {exec rm removeMe}] == 0)} {
- tcltest::testConstraint unixExecs 0
- } else {
- catch {exec rm -f removeMe}
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec mkdir removeMe}] == 1)} {
- tcltest::testConstraint unixExecs 0
- } else {
- catch {exec rm -r removeMe}
- }
- }
-
- # Locate tcltest executable
-
- if {![info exists tk_version]} {
- set tcltest::tcltest [info nameofexecutable]
-
- if {$tcltest::tcltest == "{}"} {
- set tcltest::tcltest {}
- }
- }
-
- tcltest::testConstraint 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
-
- tcltest::testConstraint 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
- tcltest::testConstraint socket \
- [expr {$msg != "sockets are not available on this system"}]
-
- # Check for internationalization
-
- if {[info commands testlocale] == ""} {
- # No testlocale command, no tests...
- tcltest::testConstraint hasIsoLocale 0
- } else {
- tcltest::testConstraint hasIsoLocale \
- [string length [tcltest::set_iso8859_1_locale]]
- tcltest::restore_locale
- }
-}
-
-#####################################################################
-
-# Handle command line arguments (from argv) and default arg settings
-# (in TCLTEST_OPTIONS).
-
-# 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
-#
-# Results:
-# none
-#
-# Side Effects:
-# 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', 'b', 't' and 'e'. Test suite will \n\
- \t display all passed tests if 'p' is \n\
- \t specified, all skipped tests if 's' \n\
- \t is specified, the bodies of \n\
- \t failed tests if 'b' is specified, \n\
- \t and when tests start if 't' is specified. \n\
- \t ErrorInfo is displayed if 'e' 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\
- -relateddir pattern\t Run tests in directories that match \n\
- \t the glob pattern given. \n\
- -asidefromdir pattern\t Skip tests in directories that match \n\
- \t the 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::processCmdLineArgsFlagsHook --
-#
-# This hook is used to add to the list of command line arguments that are
-# processed by tcltest::ProcessFlags. It is called at the beginning of
-# ProcessFlags.
-#
-
-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. It is called at the end of
-# ProcessFlags.
-#
-# Arguments:
-# flags The flags that have been pulled out of argv
-#
-
-if {[namespace inscope tcltest info procs processCmdLineArgsHook] == {}} {
- proc tcltest::processCmdLineArgsHook {flag} {}
-}
-
-# tcltest::ProcessFlags --
-#
-# process command line arguments supplied in the flagArray - this is
-# called by processCmdLineArgs
-# modifies tcltest variables according to the content of the flagArray.
-#
-# Arguments:
-# flagArray - array containing name/value pairs of flags
-#
-# Results:
-# sets tcltest variables according to their values as defined by
-# flagArray
-#
-# Side effects:
-# None.
-
-proc tcltest::ProcessFlags {flagArray} {
- # Process -help first
- if {[lsearch -exact $flagArray {-help}] != -1} {
- tcltest::PrintUsageInfo
- exit 1
- }
-
- catch {array set flag $flagArray}
-
- # -help is not listed since it has already been processed
- lappend defaultFlags -verbose -match -skip -constraints \
- -outfile -errfile -debug -tmpdir -file -notfile \
- -preservecore -limitconstraints -testdir \
- -load -loadfile -asidefromdir \
- -relateddir -singleproc
- set defaultFlags [concat $defaultFlags \
- [tcltest::processCmdLineArgsAddFlagsHook ]]
-
- # Set tcltest::verbose to the arg of the -verbose flag, if given
- if {[info exists flag(-verbose)]} {
- tcltest::verbose $flag(-verbose)
- }
-
- # Set tcltest::match to the arg of the -match flag, if given.
- if {[info exists flag(-match)]} {
- tcltest::match $flag(-match)
- }
-
- # Set tcltest::skip to the arg of the -skip flag, if given
- if {[info exists flag(-skip)]} {
- tcltest::skip $flag(-skip)
- }
-
- # Handle the -file and -notfile flags
- if {[info exists flag(-file)]} {
- tcltest::matchFiles $flag(-file)
- }
- if {[info exists flag(-notfile)]} {
- tcltest::skipFiles $flag(-notfile)
- }
-
- # Handle -relateddir and -asidefromdir flags
- if {[info exists flag(-relateddir)]} {
- tcltest::matchDirectories $flag(-relateddir)
- }
- if {[info exists flag(-asidefromdir)]} {
- tcltest::skipDirectories $flag(-asidefromdir)
- }
-
- # 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) {
- tcltest::testConstraint $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)]} {
- set msg "-limitconstraints flag can only be used with -constraints"
- error $msg
- }
- tcltest::limitConstraints $flag(-limitconstraints)
- }
-
- # Set the tcltest::temporaryDirectory to the arg of -tmpdir, if
- # given.
-
- if {[info exists flag(-tmpdir)]} {
- tcltest::temporaryDirectory $flag(-tmpdir)
- }
-
- # Set the tcltest::testsDirectory to the arg of -testdir, if
- # given.
-
- if {[info exists flag(-testdir)]} {
- tcltest::testsDirectory $flag(-testdir)
- }
-
- # If an alternate error or output files are specified, change the
- # default channels.
-
- if {[info exists flag(-outfile)]} {
- tcltest::outputFile $flag(-outfile)
- }
-
- if {[info exists flag(-errfile)]} {
- tcltest::errorFile $flag(-errfile)
- }
-
- # 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])} {
- tcltest::loadScript $flag(-load)
- }
-
- if {[info exists flag(-loadfile)] && \
- ([lsearch -exact $flagArray -loadfile] > \
- [lsearch -exact $flagArray -load]) } {
- tcltest::loadFile $flag(-loadfile)
- }
-
- # If the user specifies debug testing, print out extra information during
- # the run.
- if {[info exists flag(-debug)]} {
- tcltest::debug $flag(-debug)
- }
-
- # Handle -preservecore
- if {[info exists flag(-preservecore)]} {
- tcltest::preserveCore $flag(-preservecore)
- }
-
- # Handle -singleproc flag
- if {[info exists flag(-singleproc)]} {
- tcltest::singleProcess $flag(-singleproc)
- }
-
- # Call the hook
- tcltest::processCmdLineArgsHook [array get flag]
- return
-}
-
-# tcltest::processCmdLineArgs --
-#
-# Use command line args to set tcltest namespace variables.
-#
-# This procedure must be run after constraints are initialized, because
-# some constraints can be overridden.
-#
-# Set variables based on the contents of the environment variable
-# TCLTEST_OPTIONS first, then override with command-line options, if
-# specified.
-#
-# Arguments:
-# none
-#
-# Results:
-# Sets the above-named variables in the tcltest namespace.
-#
-# Side Effects:
-# None.
-#
-
-proc tcltest::processCmdLineArgs {} {
- global argv
-
- # If the TCLTEST_OPTIONS environment variable exists, parse it first, then
- # the argv list. The command line argument parsing will be a two-pass
- # affair from now on, so that TCLTEST_OPTIONS contain the default options.
- # These can be overridden by the command line flags.
-
- if {[info exists ::env(TCLTEST_OPTIONS)]} {
- tcltest::ProcessFlags $::env(TCLTEST_OPTIONS)
- }
-
- # The "argv" var doesn't exist in some cases, so use {}.
- if {(![info exists argv]) || ([llength $argv] < 1)} {
- set flagArray {}
- } else {
- set flagArray $argv
- }
-
- tcltest::ProcessFlags $flagArray
-
- # Spit out everything you know if we're at a debug level 2 or greater
- DebugPuts 2 "Flags passed into tcltest:"
- if {[info exists ::env(TCLTEST_OPTIONS)]} {
- DebugPuts 2 " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
- }
- if {[info exists argv]} {
- DebugPuts 2 " argv: $argv"
- }
- 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 = [outputChannel]"
- DebugPuts 2 "tcltest::errorChannel = [errorChannel]"
- DebugPuts 2 "Original environment (tcltest::originalEnv):"
- DebugPArray 2 tcltest::originalEnv
- DebugPuts 2 "Constraints:"
- DebugPArray 2 tcltest::testConstraints
- return
-}
-
-#####################################################################
-
-# Code to run the tests goes here.
-
-# tcltest::testPuts --
-#
-# Used to redefine puts in test environment.
-# Stores whatever goes out on stdout in tcltest::outData and stderr in
-# tcltest::errData before sending it on to the regular puts.
-#
-# Arguments:
-# same as standard puts
-#
-# Results:
-# none
-#
-# Side effects:
-# Intercepts puts; data that would otherwise go to stdout, stderr, or
-# file channels specified in tcltest::outputChannel and errorChannel does
-# not get sent to the normal puts function.
-
-proc tcltest::testPuts {args} {
- set len [llength $args]
- if {$len == 1} {
- # Only the string to be printed is specified
- append tcltest::outData "[lindex $args 0]\n"
- return
-# return [tcltest::normalPuts [lindex $args 0]]
- } elseif {$len == 2} {
- # Either -nonewline or channelId has been specified
- if {[regexp {^-nonewline} [lindex $args 0]]} {
- append tcltest::outData "[lindex $args end]"
- return
-# return [tcltest::normalPuts -nonewline [lindex $args end]]
- } else {
- set channel [lindex $args 0]
- }
- } elseif {$len == 3} {
- if {[lindex $args 0] == "-nonewline"} {
- # Both -nonewline and channelId are specified, unless it's an
- # error. -nonewline is supposed to be argv[0].
- set channel [lindex $args 1]
- }
- }
-
- if {[info exists channel]} {
- if {($channel == [outputChannel]) || ($channel == "stdout")} {
- append tcltest::outData "[lindex $args end]\n"
- } elseif {($channel == [errorChannel]) || ($channel == "stderr")} {
- append tcltest::errData "[lindex $args end]\n"
- }
- return
- # return [tcltest::normalPuts [lindex $args 0] [lindex $args end]]
- }
-
- # If we haven't returned by now, we don't know how to handle the input.
- # Let puts handle it.
- return [eval tcltest::normalPuts $args]
-}
-
-# tcltest::testEval --
-#
-# Evaluate the script in the test environment. If ignoreOutput is
-# false, store data sent to stderr and stdout in tcltest::outData and
-# tcltest::errData. Otherwise, ignore this output altogether.
-#
-# Arguments:
-# script Script to evaluate
-# ?ignoreOutput? Indicates whether or not to ignore output sent to
-# stdout & stderr
-#
-# Results:
-# result from running the script
-#
-# Side effects:
-# Empties the contents of tcltest::outData and tcltest::errData before
-# running a test if ignoreOutput is set to 0.
-
-proc tcltest::testEval {script {ignoreOutput 1}} {
- DebugPuts 3 "testEval called"
- if {!$ignoreOutput} {
- set tcltest::outData {}
- set tcltest::errData {}
- uplevel rename ::puts tcltest::normalPuts
- uplevel rename tcltest::testPuts ::puts
- }
- set result [uplevel $script]
- if {!$ignoreOutput} {
- uplevel rename ::puts tcltest::testPuts
- uplevel rename tcltest::normalPuts ::puts
- }
- return $result
-}
-
-# compareStrings --
-#
-# compares the expected answer to the actual answer, depending on the
-# mode provided. Mode determines whether a regexp, exact, or glob
-# comparison is done.
-#
-# Arguments:
-# actual - string containing the actual result
-# expected - pattern to be matched against
-# mode - type of comparison to be done
-#
-# Results:
-# result of the match
-#
-# Side effects:
-# None.
-
-proc tcltest::compareStrings {actual expected mode} {
- switch -- $mode {
- exact {
- set retval [string equal $actual $expected]
- }
- glob {
- set retval [string match $expected $actual]
- }
- regexp {
- set retval [regexp -- $expected $actual]
- }
- }
- return $retval
-}
-
-
-#
-# tcltest::substArguments list
-#
-# This helper function takes in a list of words, then perform a
-# substitution on the list as though each word in the list is a
-# separate argument to the Tcl function. For example, if this
-# function is invoked as:
-#
-# substArguments {$a {$a}}
-#
-# Then it is as though the function is invoked as:
-#
-# substArguments $a {$a}
-#
-# This code is adapted from Paul Duffin's function "SplitIntoWords".
-# The original function can be found on:
-#
-# http://purl.org/thecliff/tcl/wiki/858.html
-#
-# Results:
-# a list containing the result of the substitution
-#
-# Exceptions:
-# An error may occur if the list containing unbalanced quote or
-# unknown variable.
-#
-# Side Effects:
-# None.
-#
-
-proc tcltest::substArguments {argList} {
-
- # We need to split the argList up into tokens but cannot use
- # list operations as they throw away some significant
- # quoting, and [split] ignores braces as it should.
- # Therefore what we do is gradually build up a string out of
- # whitespace seperated strings. We cannot use [split] to
- # split the argList into whitespace seperated strings as it
- # throws away the whitespace which maybe important so we
- # have to do it all by hand.
-
- set result {}
- set token ""
-
- while {[string length $argList]} {
- # Look for the next word containing a quote: " { }
- if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
- $argList all]} {
- # Get the text leading up to this word, but not
- # including this word, from the argList.
- set text [string range $argList 0 \
- [expr {[lindex $all 0] - 1}]]
- # Get the word with the quote
- set word [string range $argList \
- [lindex $all 0] [lindex $all 1]]
-
- # Remove all text up to and including the word from the
- # argList.
- set argList [string range $argList \
- [expr {[lindex $all 1] + 1}] end]
- } else {
- # Take everything up to the end of the argList.
- set text $argList
- set word {}
- set argList {}
- }
-
- if {$token != {}} {
- # If we saw a word with quote before, then there is a
- # multi-word token starting with that word. In this case,
- # add the text and the current word to this token.
- append token $text $word
- } else {
- # Add the text to the result. There is no need to parse
- # the text because it couldn't be a part of any multi-word
- # token. Then start a new multi-word token with the word
- # because we need to pass this token to the Tcl parser to
- # check for balancing quotes
- append result $text
- set token $word
- }
-
- if { [catch {llength $token} length] == 0 && $length == 1} {
- # The token is a valid list so add it to the result.
- # lappend result [string trim $token]
- append result \{$token\}
- set token {}
- }
- }
-
- # If the last token has not been added to the list then there
- # is a problem.
- if { [string length $token] } {
- error "incomplete token \"$token\""
- }
-
- return $result
-}
-
-
-# tcltest::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.
-#
-# If testLevel is 1, then this is a top level test, and we record pass/fail
-# information; otherwise, this information is not logged and is not added to
-# running totals.
-#
-# Attributes:
-# Only description is a required attribute. All others are optional.
-# Default values are indicated.
-#
-# 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 attribute is optional; default is {}
-# body - Script to run to carry out the test. It must
-# return a result that can be checked for
-# correctness. This attribute is optional;
-# default is {}
-# result - Expected result from script. This attribute is
-# optional; default is {}.
-# output - Expected output sent to stdout. This attribute
-# is optional; default is {}.
-# errorOutput - Expected output sent to stderr. This attribute
-# is optional; default is {}.
-# returnCodes - Expected return codes. This attribute is
-# optional; default is {0 2}.
-# setup - Code to run before $script (above). This
-# attribute is optional; default is {}.
-# cleanup - Code to run after $script (above). This
-# attribute is optional; default is {}.
-# match - specifies type of matching to do on result,
-# output, errorOutput; this must be one of: exact,
-# glob, regexp. default is exact.
-#
-# 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.
-#
-# Results:
-# 0 if the command ran successfully; 1 otherwise.
-#
-# Side effects:
-# None.
-#
-
-proc tcltest::test {name description args} {
- DebugPuts 3 "Test $name $args"
-
- incr tcltest::testLevel
-
- # Pre-define everything to null except output and errorOutput. We
- # determine whether or not to trap output based on whether or not these
- # variables (output & errorOutput) are defined.
- foreach item {constraints setup cleanup body result returnCodes match} {
- set $item {}
- }
-
- # Set the default match mode
- set match exact
-
- # Set the default match values for return codes (0 is the standard expected
- # return value if everything went well; 2 represents 'return' being used in
- # the test script).
- set returnCodes [list 0 2]
-
- # The old test format can't have a 3rd argument (constraints or script)
- # that starts with '-'.
- if {[llength $args] == 0} {
- puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?options?\"}"
- incr tcltest::testLevel -1
- return 1
- } elseif {([string index [lindex $args 0] 0] == "-") || ([llength $args] == 1)} {
-
- if {[llength $args] == 1} {
- set list [substArguments [lindex $args 0]]
- foreach {element value} $list {
- set testAttributes($element) $value
- }
- foreach item {constraints match setup body cleanup \
- result returnCodes output errorOutput} {
- if {[info exists testAttributes([subst -$item])]} {
- set testAttributes([subst -$item]) \
- [uplevel concat $testAttributes([subst -$item])]
- }
- }
- } else {
- array set testAttributes $args
- }
-
- set validFlags {-setup -cleanup -body -result -returnCodes -match \
- -output -errorOutput -constraints}
-
- foreach flag [array names testAttributes] {
- if {[lsearch -exact $validFlags $flag] == -1} {
- puts [errorChannel] "test $name: bad flag $flag supplied to tcltest::test"
- incr tcltest::testLevel -1
- return 1
- }
- }
-
- # store whatever the user gave us
- foreach item [array names testAttributes] {
- set [string trimleft $item "-"] $testAttributes($item)
- }
-
- # Check the values supplied for -match
- if {[lsearch {regexp glob exact} $match] == -1} {
- puts [errorChannel] "test $name: {bad value for -match: must be one of exact, glob, regexp}"
- incr tcltest::testLevel -1
- return 1
- }
-
- # Replace symbolic valies supplied for -returnCodes
- regsub -nocase normal $returnCodes 0 returnCodes
- regsub -nocase error $returnCodes 1 returnCodes
- regsub -nocase return $returnCodes 2 returnCodes
- regsub -nocase break $returnCodes 3 returnCodes
- regsub -nocase continue $returnCodes 4 returnCodes
- } else {
- # This is parsing for the old test command format; it is here for
- # backward compatibility.
- set result [lindex $args end]
- if {[llength $args] == 2} {
- set body [lindex $args 0]
- } elseif {[llength $args] == 3} {
- set constraints [lindex $args 0]
- set body [lindex $args 1]
- } else {
- puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?constraints? script expectedResult\"}"
- incr tcltest::testLevel -1
- return 1
- }
- }
-
- set setupFailure 0
- set cleanupFailure 0
-
- # Run the setup script
- if {[catch {uplevel $setup} setupMsg]} {
- set setupFailure 1
- }
-
- # run the test script
- set command [list tcltest::runTest $name $description $body \
- $result $constraints]
- if {!$setupFailure} {
- if {[info exists output] || [info exists errorOutput]} {
- set testResult [uplevel tcltest::testEval [list $command] 0]
- } else {
- set testResult [uplevel tcltest::testEval [list $command] 1]
- }
- } else {
- set testResult setupFailure
- }
-
- # Run the cleanup code
- if {[catch {uplevel $cleanup} cleanupMsg]} {
- set cleanupFailure 1
- }
-
- # If testResult is an empty list, then the test was skipped
- if {$testResult != {}} {
- set coreFailure 0
- set coreMsg ""
- # check for a core file first - if one was created by the test, then
- # the test failed
- if {$tcltest::preserveCore} {
- set currentTclPlatform [array get tcl_platform]
- if {[file exists [file join [tcltest::workingDirectory] core]]} {
- # There's only a test failure 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 coreModTime]} {
- if {$coreModTime != [file mtime \
- [file join [tcltest::workingDirectory] core]]} {
- set coreFailure 1
- }
- } else {
- set coreFailure 1
- }
-
- if {($tcltest::preserveCore > 1) && ($coreFailure)} {
- append coreMsg "\nMoving file to: [file join $tcltest::temporaryDirectory core-$name]"
- catch {file rename -force \
- [file join [tcltest::workingDirectory] core] \
- [file join $tcltest::temporaryDirectory \
- core-$name]} msg
- if {[string length $msg] > 0} {
- append coreMsg "\nError: Problem renaming core file: $msg"
- }
- }
- }
- array set tcl_platform $currentTclPlatform
- }
-
- set actualAnswer [lindex $testResult 0]
- set code [lindex $testResult end]
-
- # If expected output/error strings exist, we have to compare
- # them. If the comparison fails, then so did the test.
- set outputFailure 0
- set errorFailure 0
- if {[info exists output]} {
- set outputFailure [expr ![compareStrings $tcltest::outData \
- $output $match]]
- }
- if {[info exists errorOutput]} {
- set errorFailure [expr ![compareStrings $tcltest::errData \
- $errorOutput $match]]
- }
-
- set testFailed 1
- set codeFailure 0
- set scriptFailure 0
-
- # check if the return code matched the expected return code
- if {[lsearch -exact $returnCodes $code] == -1} {
- set codeFailure 1
- }
-
- # check if the answer matched the expected answer
- if {[compareStrings $actualAnswer $result $match] == 0} {
- set scriptFailure 1
- }
-
- # if we didn't experience any failures, then we passed
- if {!($setupFailure || $cleanupFailure || $coreFailure || \
- $outputFailure || $errorFailure || $codeFailure || \
- $scriptFailure)} {
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Passed)
- if {[tcltest::isVerbose pass]} {
- puts [outputChannel] "++++ $name PASSED"
- }
- }
- set testFailed 0
- }
-
- if {$testFailed} {
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Failed)
- }
- set tcltest::currentFailure true
- if {![tcltest::isVerbose body]} {
- set body ""
- }
- puts [outputChannel] "\n==== $name [string trim $description] FAILED"
- if {$body != ""} {
- puts [outputChannel] "==== Contents of test case:"
- puts [outputChannel] $body
- }
- if {$setupFailure} {
- puts [outputChannel] "---- Test setup failed:\n$setupMsg"
- }
- if {$scriptFailure} {
- puts [outputChannel] "---- Result was:\n$actualAnswer"
- puts [outputChannel] "---- Result should have been ($match matching):\n$result"
- }
- if {$codeFailure} {
- switch -- $code {
- 0 { set msg "Test completed normally" }
- 1 { set msg "Test generated error" }
- 2 { set msg "Test generated return exception" }
- 3 { set msg "Test generated break exception" }
- 4 { set msg "Test generated continue exception" }
- default { set msg "Test generated exception" }
- }
- puts [outputChannel] "---- $msg; Return code was: $code"
- puts [outputChannel] "---- Return code should have been one of: $returnCodes"
- if {[tcltest::isVerbose error]} {
- if {[info exists ::errorInfo]} {
- puts [outputChannel] "---- errorInfo: $::errorInfo"
- puts [outputChannel] "---- errorCode: $::errorCode"
- }
- }
- }
- if {$outputFailure} {
- puts [outputChannel] "---- Output was:\n$tcltest::outData"
- puts [outputChannel] "---- Output should have been ($match matching):\n$output"
- }
- if {$errorFailure} {
- puts [outputChannel] "---- Error output was:\n$tcltest::errData"
- puts [outputChannel] "---- Error output should have been ($match matching):\n$errorOutput"
- }
- if {$cleanupFailure} {
- puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
- }
- if {$coreFailure} {
- puts [outputChannel] "---- Core file produced while running test! $coreMsg"
- }
- puts [outputChannel] "==== $name FAILED\n"
-
- }
- }
-
- incr tcltest::testLevel -1
- return 0
-}
-
-
-# runTest --
-#
-# This is the defnition of the version 1.0 test routine for tcltest. It is
-# provided here for backward compatibility. It is also used as the 'backbone'
-# of the test procedure, as in, this is where all the work really gets done.
-#
-# 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.
-#
-# Behavior depends on the value of testLevel; if testLevel is 1 (top level),
-# then events are logged and we track the number of tests run/skipped and why.
-# Otherwise, we don't track this information.
-#
-# Results:
-# empty list if test is skipped; otherwise returns list containing
-# actual returned value from the test and the return code.
-#
-# Side Effects:
-# none.
-#
-
-proc tcltest::runTest {name description script expectedAnswer constraints} {
-
- if {$tcltest::testLevel == 1} {
- 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]} {
- if {$tcltest::testLevel == 1} {
- 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} {
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Skipped)
- DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedNonMatch}
- }
- return
- }
- }
-
- DebugPuts 3 "Running $name ($description) {$script} {$expectedAnswer} $constraints"
-
- if {$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
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Skipped)
- }
- return
- }
- } else {
- # "constraints" argument exists;
- # make sure that the constraints are satisfied.
-
- 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
- # $tcltest::testConstraints(a) || $tcltest::testConstraints(b).
- regsub -all {[.\w]+} $constraints \
- {$tcltest::testConstraints(&)} c
- catch {set doTest [eval expr $c]}
- } else {
- # just simple constraints such as {unixOnly fonts}.
- set doTest 1
- foreach constraint $constraints {
- if {(![info exists tcltest::testConstraints($constraint)]) \
- || (!$tcltest::testConstraints($constraint))} {
- set doTest 0
-
- # store the constraint that kept the test from running
- set constraints $constraint
- break
- }
- }
- }
-
- if {$doTest == 0} {
- if {[tcltest::isVerbose skip]} {
- puts [outputChannel] "++++ $name SKIPPED: $constraints"
- }
-
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Skipped)
- tcltest::AddToSkippedBecause $constraints
- }
- return
- }
- }
-
- # Save information about the core file. You need to restore the original
- # tcl_platform environment because some of the tests mess with
- # tcl_platform.
-
- if {$tcltest::preserveCore} {
- set currentTclPlatform [array get tcl_platform]
- array set tcl_platform $tcltest::originalTclPlatform
- if {[file exists [file join [tcltest::workingDirectory] core]]} {
- set coreModTime [file mtime [file join \
- [tcltest::workingDirectory] core]]
- }
- array set tcl_platform $currentTclPlatform
- }
-
- # If there is no "memory" command (because memory debugging isn't
- # enabled), then don't attempt to use the command.
-
- if {[info commands memory] != {}} {
- memory tag $name
- }
-
- if {[tcltest::isVerbose start]} {
- puts [outputChannel] "---- $name start"
- flush [outputChannel]
- }
-
- set code [catch {uplevel $script} actualAnswer]
-
- return [list $actualAnswer $code]
-}
-
-#####################################################################
-
-# 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 {} {}
-}
-
-# 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).
-#
-# Arguments:
-# calledFromAllFile - if 0, behave as if we are running a single test file
-# within an entire suite of tests. if we aren't running a single test
-# file, then don't report status. check for new files created during the
-# test run and report on them. if 1, report collated status from all the
-# test file runs.
-#
-# Results:
-# None.
-#
-# Side Effects:
-# None
-#
-
-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 [outputChannel] "$testFileName:"
- foreach index [list "Total" "Passed" "Skipped" "Failed"] {
- puts -nonewline [outputChannel] \
- "\t$index\t$tcltest::numTests($index)"
- }
- puts [outputChannel] ""
-
- # print number test files sourced
- # print names of files that ran tests which failed
-
- if {$calledFromAllFile} {
- puts [outputChannel] \
- "Sourced $tcltest::numTestFiles Test Files."
- set tcltest::numTestFiles 0
- if {[llength $tcltest::failFiles] > 0} {
- puts [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 [outputChannel] \
- "Number of tests skipped for each constraint:"
- foreach constraint [lsort $constraintList] {
- puts [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 [outputChannel] "Warning: files left behind:"
- foreach testFile $testFilesThatTurded {
- puts [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 [outputChannel] \
- "env array elements created:\t$newEnv"
- }
- if {[llength $changedEnv] > 0} {
- puts [outputChannel] \
- "env array elements changed:\t$changedEnv"
- }
- if {[llength $removedEnv] > 0} {
- puts [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 [outputChannel] \
- "tcl_platform array elements changed:\t$changedTclPlatform"
- }
-
- if {[file exists [file join [tcltest::workingDirectory] core]]} {
- if {$tcltest::preserveCore > 1} {
- puts "rename core file (> 1)"
- puts [outputChannel] "produced core file! \
- Moving file to: \
- [file join $tcltest::temporaryDirectory core-$name]"
- 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 [outputChannel] "A core file was created!"
- }
- } else {
- puts [outputChannel] "A core file was created!"
- }
- }
- }
- }
- flush [outputChannel]
- flush [errorChannel]
- return
-}
-
-#####################################################################
-
-# Procs that determine which tests/test files to run
-
-# tcltest::getMatchingFiles
-#
-# Looks at the patterns given to match and skip files
-# and uses them to put together a list of the tests that will be run.
-#
-# Arguments:
-# directory to search
-#
-# Results:
-# The constructed list is returned to the user. This will primarily
-# be used in 'all.tcl' files. It is used in runAllTests.
-#
-# Side Effects:
-# None
-
-proc tcltest::getMatchingFiles { {searchDirectory ""} } {
- if {[llength [info level 0]] == 1} {
- set searchDirectory [tcltest::testsDirectory]
- }
- set matchingFiles {}
-
- # Find the matching files in the list of directories and then remove the
- # ones that match the skip pattern
- foreach directory $searchDirectory {
- set matchFileList {}
- foreach match $tcltest::matchFiles {
- set matchFileList [concat $matchFileList \
- [glob -nocomplain [file join $directory $match]]]
- }
- if {[string compare {} $tcltest::skipFiles]} {
- set skipFileList {}
- foreach skip $tcltest::skipFiles {
- set skipFileList [concat $skipFileList \
- [glob -nocomplain [file join $directory $skip]]]
- }
- foreach file $matchFileList {
- # Only include files that don't match the skip pattern and
- # aren't SCCS lock files.
- if {([lsearch -exact $skipFileList $file] == -1) && \
- (![string match l.*.test [file tail $file]])} {
- lappend matchingFiles $file
- }
- }
- } else {
- set matchingFiles [concat $matchingFiles $matchFileList]
- }
- }
- if {[string equal $matchingFiles {}]} {
- tcltest::PrintError "No test files remain after applying \
- your match and skip patterns!"
- }
- return $matchingFiles
-}
-
-# tcltest::getMatchingDirectories --
-#
-# Looks at the patterns given to match and skip directories and uses them
-# to put together a list of the test directories that we should attempt
-# to run. (Only subdirectories containing an "all.tcl" file are put into
-# the list.)
-#
-# Arguments:
-# root directory from which to search
-#
-# Results:
-# The constructed list is returned to the user. This is used in the
-# primary all.tcl file. Lower-level all.tcl files should use the
-# tcltest::testAllFiles proc instead.
-#
-# Side Effects:
-# None.
-
-proc tcltest::getMatchingDirectories {rootdir} {
- set matchingDirs {}
- set matchDirList {}
- # Find the matching directories in tcltest::testsDirectory and then
- # remove the ones that match the skip pattern
- foreach match $tcltest::matchDirectories {
- foreach file [glob -nocomplain [file join $rootdir $match]] {
- if {([file isdirectory $file]) && ($file != $rootdir)} {
- set matchDirList [concat $matchDirList \
- [tcltest::getMatchingDirectories $file]]
- if {[file exists [file join $file all.tcl]]} {
- set matchDirList [concat $matchDirList $file]
- }
- }
- }
- }
- if {$tcltest::skipDirectories != {}} {
- set skipDirs {}
- foreach skip $tcltest::skipDirectories {
- set skipDirs [concat $skipDirs \
- [glob -nocomplain [file join $tcltest::testsDirectory \
- $skip]]]
- }
- foreach dir $matchDirList {
- # Only include directories that don't match the skip pattern
- if {[lsearch -exact $skipDirs $dir] == -1} {
- lappend matchingDirs $dir
- }
- }
- } else {
- set matchingDirs [concat $matchingDirs $matchDirList]
- }
- if {$matchingDirs == {}} {
- DebugPuts 1 "No test directories remain after applying match and skip patterns!"
- }
- return $matchingDirs
-}
-
-# tcltest::runAllTests --
-#
-# prints output and sources test files according to the match and skip
-# patterns provided. after sourcing test files, it goes on to source
-# all.tcl files in matching test subdirectories.
-#
-# Arguments:
-# shell being tested
-#
-# Results:
-# None.
-#
-# Side effects:
-# None.
-
-proc tcltest::runAllTests { {shell ""} } {
- global argv
-
- if {[llength [info level 0]] == 1} {
- set shell [tcltest::interpreter]
- }
-
- set tcltest::testSingleFile false
-
- puts [outputChannel] "Tests running in interp: $shell"
- puts [outputChannel] "Tests located in: $tcltest::testsDirectory"
- puts [outputChannel] "Tests running in: [tcltest::workingDirectory]"
- puts [outputChannel] "Temporary files stored in $tcltest::temporaryDirectory"
- if {[tcltest::singleProcess]} {
- puts [outputChannel] "Test files sourced into current interpreter"
- } else {
- puts [outputChannel] "Test files run in separate interpreters"
- }
- if {[llength $tcltest::skip] > 0} {
- puts [outputChannel] "Skipping tests that match: $tcltest::skip"
- }
- if {[llength $tcltest::match] > 0} {
- puts [outputChannel] "Only running tests that match: $tcltest::match"
- }
-
- if {[llength $tcltest::skipFiles] > 0} {
- puts [outputChannel] "Skipping test files that match: $tcltest::skipFiles"
- }
- if {[llength $tcltest::matchFiles] > 0} {
- puts [outputChannel] "Only running test files that match: $tcltest::matchFiles"
- }
-
- set timeCmd {clock format [clock seconds]}
- puts [outputChannel] "Tests began at [eval $timeCmd]"
-
- # Run each of the specified tests
- foreach file [lsort [tcltest::getMatchingFiles]] {
- set tail [file tail $file]
- puts [outputChannel] $tail
-
- if {$tcltest::singleProcess} {
- incr tcltest::numTestFiles
- uplevel [list source $file]
- } else {
- # Change to the tests directory so the value of the following
- # variable is set correctly when we spawn the child test processes
- cd $tcltest::testsDirectory
- set cmd [concat [list | $shell $file] [split $argv]]
- if {[catch {
- incr tcltest::numTestFiles
- set pipeFd [open $cmd "r"]
- while {[gets $pipeFd line] >= 0} {
- if {[regexp {^([^:]+):\tTotal\t([0-9]+)\tPassed\t([0-9]+)\tSkipped\t([0-9]+)\tFailed\t([0-9]+)} $line null testFile Total Passed Skipped Failed]} {
- foreach index [list "Total" "Passed" "Skipped" "Failed"] {
- incr tcltest::numTests($index) [set $index]
- }
- if {$Failed > 0} {
- lappend tcltest::failFiles $testFile
- }
- } elseif {[regexp {^Number of tests skipped for each constraint:|^\t(\d+)\t(.+)$} $line match skipped constraint]} {
- if {$match != "Number of tests skipped for each constraint:"} {
- tcltest::AddToSkippedBecause $constraint $skipped
- }
- } else {
- puts [outputChannel] $line
- }
- }
- close $pipeFd
- } msg]} {
- # Print results to tcltest::outputChannel.
- puts [outputChannel] "Test file error: $msg"
- # append the name of the test to a list to be reported later
- lappend testFileFailures $file
- }
- }
- }
-
- # cleanup
- puts [outputChannel] "\nTests ended at [eval $timeCmd]"
- tcltest::cleanupTests 1
- if {[info exists testFileFailures]} {
- puts [outputChannel] "\nTest files exiting with errors: \n"
- foreach file $testFileFailures {
- puts " [file tail $file]\n"
- }
- }
-
- # Checking for subdirectories in which to run tests
- foreach directory [tcltest::getMatchingDirectories $tcltest::testsDirectory] {
- set dir [file tail $directory]
- puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
- puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
-
- uplevel "source [file join $directory all.tcl]"
-
- set endTime [eval $timeCmd]
- puts [outputChannel] "\n$dir test ended at $endTime"
- puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
- }
- return
-}
-
-#####################################################################
-
-# Test utility procs - not used in tcltest, but may be useful for testing.
-
-# 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
-#
-# Side Effects:
-# none.
-
-proc tcltest::loadTestedCommands {} {
- if {$tcltest::loadScript == {}} {
- return
- }
-
- return [uplevel $tcltest::loadScript]
-}
-
-# tcltest::saveState --
-#
-# Save information regarding what procs and variables exist.
-#
-# Arguments:
-# none
-#
-# Results:
-# Modifies the variable tcltest::saveState
-#
-# Side effects:
-# None.
-
-proc tcltest::saveState {} {
- uplevel {set tcltest::saveState [list [info procs] [info vars]]}
- DebugPuts 2 "tcltest::saveState: $tcltest::saveState"
- return
-}
-
-# tcltest::restoreState --
-#
-# Remove procs and variables that didn't exist before the call to
-# tcltest::saveState.
-#
-# Arguments:
-# none
-#
-# Results:
-# Removes procs and variables from your environment if they don't exist
-# in the tcltest::saveState variable.
-#
-# Side effects:
-# None.
-
-proc tcltest::restoreState {} {
- foreach p [info procs] {
- if {([lsearch [lindex $tcltest::saveState 0] $p] < 0) && \
- (![string match "*tcltest::$p" [namespace origin $p]])} {
-
- DebugPuts 2 "tcltest::restoreState: Removing proc $p"
- rename $p {}
- }
- }
- foreach p [uplevel {info vars}] {
- if {[lsearch [lindex $tcltest::saveState 1] $p] < 0} {
- DebugPuts 2 "tcltest::restoreState: Removing variable $p"
- uplevel "catch {unset $p}"
- }
- }
- return
-}
-
-# tcltest::normalizeMsg --
-#
-# Removes "extra" newlines from a string.
-#
-# Arguments:
-# msg String to be modified
-#
-# Results:
-# string with extra newlines removed
-#
-# Side effects:
-# None.
-
-proc tcltest::normalizeMsg {msg} {
- regsub "\n$" [string tolower $msg] "" msg
- regsub -all "\n\n" $msg "\n" msg
- regsub -all "\n\}" $msg "\}" msg
- return $msg
-}
-
-# tcltest::makeFile --
-#
-# Create a new file with the name <name>, and write <contents> to it.
-#
-# If this file hasn't been created via makeFile since the last time
-# cleanupTests was called, add it to the $filesMade list, so it will
-# be removed by the next call to cleanupTests.
-#
-# Arguments:
-# contents content of the new file
-# name name of the new file
-# directory directory name for new file
-#
-# Results:
-# absolute path to the file created
-#
-# Side effects:
-# None.
-
-proc tcltest::makeFile {contents name {directory ""}} {
- global tcl_platform
-
- if {[llength [info level 0]] == 3} {
- set directory [tcltest::temporaryDirectory]
- }
-
- set fullName [file join $directory $name]
-
- DebugPuts 3 "tcltest::makeFile: putting $contents into $fullName"
-
- set fd [open $fullName w]
-
- fconfigure $fd -translation lf
-
- if {[string equal [string index $contents end] "\n"]} {
- puts -nonewline $fd $contents
- } else {
- puts $fd $contents
- }
- close $fd
-
- if {[lsearch -exact $tcltest::filesMade $fullName] == -1} {
- lappend tcltest::filesMade $fullName
- }
- return $fullName
-}
-
-# tcltest::removeFile --
-#
-# Removes the named file from the filesystem
-#
-# Arguments:
-# name file to be removed
-# directory directory from which to remove file
-#
-# Results:
-# return value from [file delete]
-#
-# Side effects:
-# None.
-
-proc tcltest::removeFile {name {directory ""}} {
- if {[llength [info level 0]] == 2} {
- set directory [tcltest::temporaryDirectory]
- }
- set fullName [file join $directory $name]
- DebugPuts 3 "tcltest::removeFile: removing $fullName"
- return [file delete $fullName]
-}
-
-# tcltest::makeDirectory --
-#
-# Create a new dir with the name <name>.
-#
-# If this dir hasn't been created via makeDirectory since the last time
-# cleanupTests was called, add it to the $directoriesMade list, so it will
-# be removed by the next call to cleanupTests.
-#
-# Arguments:
-# name name of the new directory
-# directory directory in which to create new dir
-#
-# Results:
-# absolute path to the directory created
-#
-# Side effects:
-# None.
-
-proc tcltest::makeDirectory {name {directory ""}} {
- if {[llength [info level 0]] == 2} {
- set directory [tcltest::temporaryDirectory]
- }
- set fullName [file join $directory $name]
- DebugPuts 3 "tcltest::makeDirectory: creating $fullName"
- file mkdir $fullName
- if {[lsearch -exact $tcltest::filesMade $fullName] == -1} {
- lappend tcltest::filesMade $fullName
- }
- return $fullName
-}
-
-# tcltest::removeDirectory --
-#
-# Removes a named directory from the file system.
-#
-# Arguments:
-# name Name of the directory to remove
-# directory Directory from which to remove
-#
-# Results:
-# return value from [file delete]
-#
-# Side effects:
-# None
-
-proc tcltest::removeDirectory {name {directory ""}} {
- if {[llength [info level 0]] == 2} {
- set directory [tcltest::temporaryDirectory]
- }
- set fullName [file join $directory $name]
- DebugPuts 3 "tcltest::removeDirectory: deleting $fullName"
- return [file delete -force $fullName]
-}
-
-# tcltest::viewFile --
-#
-# reads the content of a file and returns it
-#
-# Arguments:
-# name of the file to read
-# directory in which file is located
-#
-# Results:
-# content of the named file
-#
-# Side effects:
-# None.
-
-proc tcltest::viewFile {name {directory ""}} {
- global tcl_platform
- if {[llength [info level 0]] == 2} {
- set directory [tcltest::temporaryDirectory]
- }
- set fullName [file join $directory $name]
- if {([string equal $tcl_platform(platform) "macintosh"]) || \
- ([tcltest::testConstraint unixExecs] == 0)} {
- set f [open $fullName]
- set data [read -nonewline $f]
- close $f
- return $data
- } else {
- return [exec cat $fullName]
- }
- return
-}
-
-# tcltest::bytestring --
-#
-# Construct a string that consists of the requested sequence of bytes,
-# as opposed to a string of properly formed UTF-8 characters.
-# This allows the tester to
-# 1. Create denormalized or improperly formed strings to pass to C procedures
-# that are supposed to accept strings with embedded NULL bytes.
-# 2. Confirm that a string result has a certain pattern of bytes, for instance
-# to confirm that "\xe0\0" in a Tcl script is stored internally in
-# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
-#
-# Generally, it's a bad idea to examine the bytes in a Tcl string or to
-# construct improperly formed strings in this manner, because it involves
-# exposing that Tcl uses UTF-8 internally.
-#
-# Arguments:
-# string being converted
-#
-# Results:
-# result fom encoding
-#
-# Side effects:
-# None
-
-proc tcltest::bytestring {string} {
- return [encoding convertfrom identity $string]
-}
-
-# tcltest::openfiles --
-#
-# used in io tests, uses testchannel
-#
-# Arguments:
-# None.
-#
-# Results:
-# ???
-#
-# Side effects:
-# None.
-
-proc tcltest::openfiles {} {
- if {[catch {testchannel open} result]} {
- return {}
- }
- return $result
-}
-
-# tcltest::leakfiles --
-#
-# used in io tests, uses testchannel
-#
-# Arguments:
-# None.
-#
-# Results:
-# ???
-#
-# Side effects:
-# None.
-
-proc tcltest::leakfiles {old} {
- if {[catch {testchannel open} new]} {
- return {}
- }
- set leak {}
- foreach p $new {
- if {[lsearch $old $p] < 0} {
- lappend leak $p
- }
- }
- return $leak
-}
-
-#
-# Internationalization / ISO support procs -- dl
-#
-
-# tcltest::set_iso8859_1_locale --
-#
-# used in cmdIL.test, uses testlocale
-#
-# Arguments:
-# None.
-#
-# Results:
-# None.
-#
-# Side effects:
-# None.
-
-proc tcltest::set_iso8859_1_locale {} {
- if {[info commands testlocale] != ""} {
- set tcltest::previousLocale [testlocale ctype]
- testlocale ctype $tcltest::isoLocale
- }
- return
-}
-
-# tcltest::restore_locale --
-#
-# used in cmdIL.test, uses testlocale
-#
-# Arguments:
-# None.
-#
-# Results:
-# None.
-#
-# Side effects:
-# None.
-
-proc tcltest::restore_locale {} {
- if {[info commands testlocale] != ""} {
- testlocale ctype $tcltest::previousLocale
- }
- return
-}
-
-# tcltest::threadReap --
-#
-# Kill all threads except for the main thread.
-# Do nothing if testthread is not defined.
-#
-# Arguments:
-# none.
-#
-# Results:
-# Returns the number of existing threads.
-#
-# Side Effects:
-# none.
-#
-
-proc tcltest::threadReap {} {
- if {[info commands testthread] != {}} {
-
- # testthread built into tcltest
-
- testthread errorproc ThreadNullError
- while {[llength [testthread names]] > 1} {
- foreach tid [testthread names] {
- if {$tid != $tcltest::mainThread} {
- catch {testthread send -async $tid {testthread exit}}
- }
- }
- ## Enter a bit a sleep to give the threads enough breathing
- ## room to kill themselves off, otherwise the end up with a
- ## massive queue of repeated events
- after 1
- }
- testthread errorproc ThreadError
- return [llength [testthread names]]
- } elseif {[info commands thread::id] != {}} {
-
- # Thread extension
-
- thread::errorproc ThreadNullError
- while {[llength [thread::names]] > 1} {
- foreach tid [thread::names] {
- if {$tid != $tcltest::mainThread} {
- catch {thread::send -async $tid {thread::exit}}
- }
- }
- ## Enter a bit a sleep to give the threads enough breathing
- ## room to kill themselves off, otherwise the end up with a
- ## massive queue of repeated events
- after 1
- }
- thread::errorproc ThreadError
- return [llength [thread::names]]
- } else {
- return 1
- }
- return 0
-}
-
-# Initialize the constraints and set up command line arguments
-namespace eval tcltest {
- # Ensure that we have a minimal auto_path so we don't pick up extra junk.
- set ::auto_path [list [info library]]
-
- tcltest::initConstraints
- if {[namespace children [namespace current]] == {}} {
- tcltest::processCmdLineArgs
- }
-
- # 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]
- }
-}
-
-package provide tcltest 2.0
-