tcltest.tcl

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

	    # $::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 {[string first s $::tcltest::verbose] != -1} {
		puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints"
	    }

	    incr ::tcltest::numTests(Skipped)
	    ::tcltest::AddToSkippedBecause $constraints
	    return	
	}
    } else {
	error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
    }   

    # 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
    }

    set code [catch {uplevel $script} actualAnswer]
    if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} {
	incr ::tcltest::numTests(Passed)
	if {[string first p $::tcltest::verbose] != -1} {
	    puts $::tcltest::outputChannel "++++ $name PASSED"
	}
    } else {
	incr ::tcltest::numTests(Failed)
	set ::tcltest::currentFailure true
	if {[string first b $::tcltest::verbose] == -1} {
	    set script ""
	}
	puts $::tcltest::outputChannel "\n==== $name $description FAILED"
	if {$script != ""} {
	    puts $::tcltest::outputChannel "==== Contents of test case:"
	    puts $::tcltest::outputChannel $script
	}
	if {$code != 0} {
	    if {$code == 1} {
		puts $::tcltest::outputChannel "==== Test generated error:"
		puts $::tcltest::outputChannel $actualAnswer
	    } elseif {$code == 2} {
		puts $::tcltest::outputChannel "==== Test generated return exception;  result was:"
		puts $::tcltest::outputChannel $actualAnswer
	    } elseif {$code == 3} {
		puts $::tcltest::outputChannel "==== Test generated break exception"
	    } elseif {$code == 4} {
		puts $::tcltest::outputChannel "==== Test generated continue exception"
	    } else {
		puts $::tcltest::outputChannel "==== Test generated exception $code;  message was:"
		puts $::tcltest::outputChannel $actualAnswer
	    }
	} else {
	    puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer"
	}
	puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer"
	puts $::tcltest::outputChannel "==== $name FAILED\n"
    }
    if {$::tcltest::preserveCore} {
	set currentTclPlatform [array get tcl_platform]
	if {[file exists [file join $::tcltest::workingDirectory core]]} {
	    if {$::tcltest::preserveCore > 1} {
		puts $::tcltest::outputChannel "==== $name 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 coreModTime]} {
		    if {$coreModTime != [file mtime \
			    [file join $::tcltest::workingDirectory core]]} {
			puts $::tcltest::outputChannel "==== $name produced core file!"
		    }
		} else {
		    puts $::tcltest::outputChannel "==== $name produced core file!"
		} 
	    }
	}
	array set tcl_platform $currentTclPlatform
    }
}

# ::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:
#       none
#
# Results:
#       The constructed list is returned to the user.  This will primarily
#       be used in 'all.tcl' files.

proc ::tcltest::getMatchingFiles {args} {
    set matchingFiles {}
    if {[llength $args]} {
	set searchDirectory $args
    } else {
	set searchDirectory [list $::tcltest::testsDirectory]
    }
    # 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
}

# The following two procs are used in the io tests.

proc ::tcltest::openfiles {} {
    if {[catch {testchannel open} result]} {
	return {}
    }
    return $result
}

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
}

# ::tcltest::saveState --
#
#	Save information regarding what procs and variables exist.
#
# Arguments:
#	none
#
# Results:
#	Modifies the variable ::tcltest::saveState

proc ::tcltest::saveState {} {
    uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
    DebugPuts  2 "::tcltest::saveState: $::tcltest::saveState"
}

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

proc ::tcltest::restoreState {} {
    foreach p [info procs] {
	if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
		(![string equal ::tcltest::$p [namespace origin $p]])} {
	    
	    DebugPuts 3 "::tcltest::restoreState: Removing proc $p"
	    rename $p {}
	}
    }
    foreach p [uplevel #0 {info vars}] {
	if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
	    DebugPuts 3 "::tcltest::restoreState: Removing variable $p"
	    uplevel #0 "catch {unset $p}"
	}
    }
}

# ::tcltest::normalizeMsg --
#
#	Removes "extra" newlines from a string.
#
# Arguments:
#	msg        String to be modified
#

proc ::tcltest::normalizeMsg {msg} {
    regsub "\n$" [string tolower $msg] "" msg
    regsub -all "\n\n" $msg "\n" msg
    regsub -all "\n\}" $msg "\}" msg
    return $msg
}

# 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.
#
proc ::tcltest::makeFile {contents name} {
    global tcl_platform
    
    DebugPuts 3 "::tcltest::makeFile: putting $contents into $name"

    set fullName [file join $::tcltest::temporaryDirectory $name]
    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
#

proc ::tcltest::removeFile {name} {
    DebugPuts 3 "::tcltest::removeFile: removing $name"
    file delete [file join $::tcltest::temporaryDirectory $name]
}

# 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.
#
proc ::tcltest::makeDirectory {name} {
    file mkdir $name

    set fullName [file join [pwd] $name]
    if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
	lappend ::tcltest::filesMade $fullName
    }
}

# ::tcltest::removeDirectory --
#
#	Removes a named directory from the file system.
#
# Arguments:
#	name    Name of the directory to remove
#

proc ::tcltest::removeDirectory {name} {
    file delete -force $name
}

proc ::tcltest::viewFile {name} {
    global tcl_platform
    if {([string equal $tcl_platform(platform) "macintosh"]) || \
	    ($::tcltest::testConstraints(unixExecs) == 0)} {
	set f [open [file join $::tcltest::temporaryDirectory $name]]
	set data [read -nonewline $f]
	close $f
	return $data
    } else {
	exec cat [file join $::tcltest::temporaryDirectory $name]
    }
}

# grep --
#
# Evaluate a given expression against each element of a list and return all
# elements for which the expression evaluates to true.  For the purposes of
# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the
# value of the current element within the expression.  This is equivalent to
# the perl grep command where CURRENT_ELEMENT would be the name for the special
# variable $_.
#
# Examples of usage would be:
#   set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers]
#   set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings]
#
# Use of the CURRENT_ELEMENT keyword is optional.  If it is left out, it is
# assumed to be the final argument to the expression provided.
# 
# Example:
#   grep {regexp a} $someList   
#
proc ::tcltest::grep { expression searchList } {
    foreach element $searchList {
	if {[regsub -all CURRENT_ELEMENT $expression $element \
		newExpression] == 0} { 
	    set newExpression "$expression {$element}"
	}
	if {[eval $newExpression] == 1} {
	    lappend returnList $element
	}
    }
    if {[info exists returnList]} {
	return $returnList
    }
    return
}

#
# 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.

proc ::tcltest::bytestring {string} {
    encoding convertfrom identity $string
}

#
# Internationalization / ISO support procs     -- dl
#
proc ::tcltest::set_iso8859_1_locale {} {
    if {[info commands testlocale] != ""} {
	set ::tcltest::previousLocale [testlocale ctype]
	testlocale ctype $::tcltest::isoLocale
    }
    return
}

proc ::tcltest::restore_locale {} {
    if {[info commands testlocale] != ""} {
	testlocale ctype $::tcltest::previousLocale
    }
    return
}

# 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.
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
    }
}

# 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 ::tcltest] == {}} {
	::tcltest::processCmdLineArgs
    }
}