You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
3421 lines
98 KiB
Plaintext
3421 lines
98 KiB
Plaintext
3 weeks ago
|
# 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
|
||
|
|
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
|
||
|
|
# All rights reserved.
|
||
|
|
|
||
|
|
package require Tcl 8.5- ;# -verbose line uses [info frame]
|
||
|
|
namespace eval tcltest {
|
||
|
|
|
||
|
|
# When the version number changes, be sure to update the pkgIndex.tcl file,
|
||
|
|
# and the install directory in the Makefiles. When the minor version
|
||
|
|
# changes (new feature) be sure to update the man page as well.
|
||
|
|
variable Version 2.4.1
|
||
|
|
|
||
|
|
# Compatibility support for dumb variables defined in tcltest 1
|
||
|
|
# Do not use these. Call [package provide Tcl] and [info patchlevel]
|
||
|
|
# yourself. You don't need tcltest to wrap it for you.
|
||
|
|
variable version [package provide Tcl]
|
||
|
|
variable patchLevel [info patchlevel]
|
||
|
|
|
||
|
|
##### Export the public tcltest procs; several categories
|
||
|
|
#
|
||
|
|
# Export the main functional commands that do useful things
|
||
|
|
namespace export cleanupTests loadTestedCommands makeDirectory \
|
||
|
|
makeFile removeDirectory removeFile runAllTests test
|
||
|
|
|
||
|
|
# Export configuration commands that control the functional commands
|
||
|
|
namespace export configure customMatch errorChannel interpreter \
|
||
|
|
outputChannel testConstraint
|
||
|
|
|
||
|
|
# Export commands that are duplication (candidates for deprecation)
|
||
|
|
namespace export bytestring ;# dups [encoding convertfrom identity]
|
||
|
|
namespace export debug ;# [configure -debug]
|
||
|
|
namespace export errorFile ;# [configure -errfile]
|
||
|
|
namespace export limitConstraints ;# [configure -limitconstraints]
|
||
|
|
namespace export loadFile ;# [configure -loadfile]
|
||
|
|
namespace export loadScript ;# [configure -load]
|
||
|
|
namespace export match ;# [configure -match]
|
||
|
|
namespace export matchFiles ;# [configure -file]
|
||
|
|
namespace export matchDirectories ;# [configure -relateddir]
|
||
|
|
namespace export normalizeMsg ;# application of [customMatch]
|
||
|
|
namespace export normalizePath ;# [file normalize] (8.4)
|
||
|
|
namespace export outputFile ;# [configure -outfile]
|
||
|
|
namespace export preserveCore ;# [configure -preservecore]
|
||
|
|
namespace export singleProcess ;# [configure -singleproc]
|
||
|
|
namespace export skip ;# [configure -skip]
|
||
|
|
namespace export skipFiles ;# [configure -notfile]
|
||
|
|
namespace export skipDirectories ;# [configure -asidefromdir]
|
||
|
|
namespace export temporaryDirectory ;# [configure -tmpdir]
|
||
|
|
namespace export testsDirectory ;# [configure -testdir]
|
||
|
|
namespace export verbose ;# [configure -verbose]
|
||
|
|
namespace export viewFile ;# binary encoding [read]
|
||
|
|
namespace export workingDirectory ;# [cd] [pwd]
|
||
|
|
|
||
|
|
# Export deprecated commands for tcltest 1 compatibility
|
||
|
|
namespace export getMatchingFiles mainThread restoreState saveState \
|
||
|
|
threadReap
|
||
|
|
|
||
|
|
# 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 - name of variable containing path to modify.
|
||
|
|
#
|
||
|
|
# Results
|
||
|
|
# The path is modified in place.
|
||
|
|
#
|
||
|
|
# Side Effects:
|
||
|
|
# None.
|
||
|
|
#
|
||
|
|
proc normalizePath {pathVar} {
|
||
|
|
upvar 1 $pathVar path
|
||
|
|
set oldpwd [pwd]
|
||
|
|
catch {cd $path}
|
||
|
|
set path [pwd]
|
||
|
|
cd $oldpwd
|
||
|
|
return $path
|
||
|
|
}
|
||
|
|
|
||
|
|
##### Verification commands used to test values of variables and options
|
||
|
|
#
|
||
|
|
# Verification command that accepts everything
|
||
|
|
proc AcceptAll {value} {
|
||
|
|
return $value
|
||
|
|
}
|
||
|
|
|
||
|
|
# Verification command that accepts valid Tcl lists
|
||
|
|
proc AcceptList { list } {
|
||
|
|
return [lrange $list 0 end]
|
||
|
|
}
|
||
|
|
|
||
|
|
# Verification command that accepts a glob pattern
|
||
|
|
proc AcceptPattern { pattern } {
|
||
|
|
return [AcceptAll $pattern]
|
||
|
|
}
|
||
|
|
|
||
|
|
# Verification command that accepts integers
|
||
|
|
proc AcceptInteger { level } {
|
||
|
|
return [incr level 0]
|
||
|
|
}
|
||
|
|
|
||
|
|
# Verification command that accepts boolean values
|
||
|
|
proc AcceptBoolean { boolean } {
|
||
|
|
return [expr {$boolean && $boolean}]
|
||
|
|
}
|
||
|
|
|
||
|
|
# Verification command that accepts (syntactically) valid Tcl scripts
|
||
|
|
proc AcceptScript { script } {
|
||
|
|
if {![info complete $script]} {
|
||
|
|
return -code error "invalid Tcl script: $script"
|
||
|
|
}
|
||
|
|
return $script
|
||
|
|
}
|
||
|
|
|
||
|
|
# Verification command that accepts (converts to) absolute pathnames
|
||
|
|
proc AcceptAbsolutePath { path } {
|
||
|
|
return [file join [pwd] $path]
|
||
|
|
}
|
||
|
|
|
||
|
|
# Verification command that accepts existing readable directories
|
||
|
|
proc AcceptReadable { path } {
|
||
|
|
if {![file readable $path]} {
|
||
|
|
return -code error "\"$path\" is not readable"
|
||
|
|
}
|
||
|
|
return $path
|
||
|
|
}
|
||
|
|
proc AcceptDirectory { directory } {
|
||
|
|
set directory [AcceptAbsolutePath $directory]
|
||
|
|
if {![file exists $directory]} {
|
||
|
|
return -code error "\"$directory\" does not exist"
|
||
|
|
}
|
||
|
|
if {![file isdir $directory]} {
|
||
|
|
return -code error "\"$directory\" is not a directory"
|
||
|
|
}
|
||
|
|
return [AcceptReadable $directory]
|
||
|
|
}
|
||
|
|
|
||
|
|
##### Initialize internal arrays of tcltest, but only if the caller
|
||
|
|
# has not already pre-initialized them. This is done to support
|
||
|
|
# compatibility with older tests that directly access internals
|
||
|
|
# rather than go through command interfaces.
|
||
|
|
#
|
||
|
|
proc ArrayDefault {varName value} {
|
||
|
|
variable $varName
|
||
|
|
if {[array exists $varName]} {
|
||
|
|
return
|
||
|
|
}
|
||
|
|
if {[info exists $varName]} {
|
||
|
|
# Pre-initialized value is a scalar: destroy it!
|
||
|
|
unset $varName
|
||
|
|
}
|
||
|
|
array set $varName $value
|
||
|
|
}
|
||
|
|
|
||
|
|
# save the original environment so that it can be restored later
|
||
|
|
ArrayDefault originalEnv [array get ::env]
|
||
|
|
|
||
|
|
# initialize numTests array to keep track of the number of tests
|
||
|
|
# that pass, fail, and are skipped.
|
||
|
|
ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
|
||
|
|
|
||
|
|
# createdNewFiles will store test files as indices and the list of
|
||
|
|
# files (that should not have been) left behind by the test files
|
||
|
|
# as values.
|
||
|
|
ArrayDefault createdNewFiles {}
|
||
|
|
|
||
|
|
# initialize 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.
|
||
|
|
ArrayDefault skippedBecause {}
|
||
|
|
|
||
|
|
# initialize the testConstraints array to keep track of valid
|
||
|
|
# predefined constraints (see the explanation for the
|
||
|
|
# InitConstraints proc for more details).
|
||
|
|
ArrayDefault testConstraints {}
|
||
|
|
|
||
|
|
##### Initialize internal variables of tcltest, but only if the caller
|
||
|
|
# has not already pre-initialized them. This is done to support
|
||
|
|
# compatibility with older tests that directly access internals
|
||
|
|
# rather than go through command interfaces.
|
||
|
|
#
|
||
|
|
proc Default {varName value {verify AcceptAll}} {
|
||
|
|
variable $varName
|
||
|
|
if {![info exists $varName]} {
|
||
|
|
variable $varName [$verify $value]
|
||
|
|
} else {
|
||
|
|
variable $varName [$verify [set $varName]]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Save any arguments that we might want to pass through to other
|
||
|
|
# programs. This is used by the -args flag.
|
||
|
|
# FINDUSER
|
||
|
|
Default 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.
|
||
|
|
Default numTestFiles 0 AcceptInteger
|
||
|
|
Default testSingleFile true AcceptBoolean
|
||
|
|
Default currentFailure false AcceptBoolean
|
||
|
|
Default failFiles {} AcceptList
|
||
|
|
|
||
|
|
# Tests should remove all files they create. The test suite will
|
||
|
|
# check the current working dir for files created by the tests.
|
||
|
|
# filesMade keeps track of such files created using the makeFile and
|
||
|
|
# makeDirectory procedures. filesExisted stores the names of
|
||
|
|
# pre-existing files.
|
||
|
|
#
|
||
|
|
# Note that $filesExisted lists only those files that exist in
|
||
|
|
# the original [temporaryDirectory].
|
||
|
|
Default filesMade {} AcceptList
|
||
|
|
Default filesExisted {} AcceptList
|
||
|
|
proc FillFilesExisted {} {
|
||
|
|
variable filesExisted
|
||
|
|
|
||
|
|
# Save the names of files that already exist in the scratch directory.
|
||
|
|
foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
|
||
|
|
lappend filesExisted [file tail $file]
|
||
|
|
}
|
||
|
|
|
||
|
|
# After successful filling, turn this into a no-op.
|
||
|
|
proc FillFilesExisted args {}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Kept only for compatibility
|
||
|
|
Default constraintsSpecified {} AcceptList
|
||
|
|
trace add variable constraintsSpecified read [namespace code {
|
||
|
|
set constraintsSpecified [array names testConstraints] ;#}]
|
||
|
|
|
||
|
|
# tests that use threads need to know which is the main thread
|
||
|
|
Default mainThread 1
|
||
|
|
variable mainThread
|
||
|
|
if {[info commands thread::id] ne {}} {
|
||
|
|
set mainThread [thread::id]
|
||
|
|
} elseif {[info commands testthread] ne {}} {
|
||
|
|
set mainThread [testthread id]
|
||
|
|
}
|
||
|
|
|
||
|
|
# Set workingDirectory to [pwd]. The default output directory for
|
||
|
|
# Tcl tests is the working directory. Whenever this value changes
|
||
|
|
# change to that directory.
|
||
|
|
variable workingDirectory
|
||
|
|
trace add variable workingDirectory write \
|
||
|
|
[namespace code {cd $workingDirectory ;#}]
|
||
|
|
|
||
|
|
Default workingDirectory [pwd] AcceptAbsolutePath
|
||
|
|
proc workingDirectory { {dir ""} } {
|
||
|
|
variable workingDirectory
|
||
|
|
if {[llength [info level 0]] == 1} {
|
||
|
|
return $workingDirectory
|
||
|
|
}
|
||
|
|
set workingDirectory [AcceptAbsolutePath $dir]
|
||
|
|
}
|
||
|
|
|
||
|
|
# Set the location of the execuatble
|
||
|
|
Default tcltest [info nameofexecutable]
|
||
|
|
trace add variable tcltest write [namespace code {testConstraint stdio \
|
||
|
|
[eval [ConstraintInitializer stdio]] ;#}]
|
||
|
|
|
||
|
|
# save the platform information so it can be restored later
|
||
|
|
Default originalTclPlatform [array get ::tcl_platform]
|
||
|
|
|
||
|
|
# If a core file exists, save its modification time.
|
||
|
|
if {[file exists [file join [workingDirectory] core]]} {
|
||
|
|
Default coreModTime \
|
||
|
|
[file mtime [file join [workingDirectory] core]]
|
||
|
|
}
|
||
|
|
|
||
|
|
# stdout and stderr buffers for use when we want to store them
|
||
|
|
Default outData {}
|
||
|
|
Default errData {}
|
||
|
|
|
||
|
|
# keep track of test level for nested test commands
|
||
|
|
variable testLevel 0
|
||
|
|
|
||
|
|
# the variables and procs that existed when saveState was called are
|
||
|
|
# stored in a variable of the same name
|
||
|
|
Default saveState {}
|
||
|
|
|
||
|
|
# Internationalization support -- used in [SetIso8859_1_Locale] and
|
||
|
|
# [RestoreLocale]. Those commands are used in cmdIL.test.
|
||
|
|
|
||
|
|
if {![info exists [namespace current]::isoLocale]} {
|
||
|
|
variable isoLocale fr
|
||
|
|
switch -- $::tcl_platform(platform) {
|
||
|
|
"unix" {
|
||
|
|
|
||
|
|
# Try some 'known' values for some platforms:
|
||
|
|
|
||
|
|
switch -exact -- $::tcl_platform(os) {
|
||
|
|
"FreeBSD" {
|
||
|
|
set isoLocale fr_FR.ISO_8859-1
|
||
|
|
}
|
||
|
|
HP-UX {
|
||
|
|
set isoLocale fr_FR.iso88591
|
||
|
|
}
|
||
|
|
Linux -
|
||
|
|
IRIX {
|
||
|
|
set 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 isoLocale iso_8859_1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
"windows" {
|
||
|
|
set isoLocale French
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
variable ChannelsWeOpened; array set ChannelsWeOpened {}
|
||
|
|
# output goes to stdout by default
|
||
|
|
Default outputChannel stdout
|
||
|
|
proc outputChannel { {filename ""} } {
|
||
|
|
variable outputChannel
|
||
|
|
variable ChannelsWeOpened
|
||
|
|
|
||
|
|
# This is very subtle and tricky, so let me try to explain.
|
||
|
|
# (Hopefully this longer comment will be clear when I come
|
||
|
|
# back in a few months, unlike its predecessor :) )
|
||
|
|
#
|
||
|
|
# The [outputChannel] command (and underlying variable) have to
|
||
|
|
# be kept in sync with the [configure -outfile] configuration
|
||
|
|
# option ( and underlying variable Option(-outfile) ). This is
|
||
|
|
# accomplished with a write trace on Option(-outfile) that will
|
||
|
|
# update [outputChannel] whenver a new value is written. That
|
||
|
|
# much is easy.
|
||
|
|
#
|
||
|
|
# The trick is that in order to maintain compatibility with
|
||
|
|
# version 1 of tcltest, we must allow every configuration option
|
||
|
|
# to get its inital value from command line arguments. This is
|
||
|
|
# accomplished by setting initial read traces on all the
|
||
|
|
# configuration options to parse the command line option the first
|
||
|
|
# time they are read. These traces are cancelled whenever the
|
||
|
|
# program itself calls [configure].
|
||
|
|
#
|
||
|
|
# OK, then so to support tcltest 1 compatibility, it seems we want
|
||
|
|
# to get the return from [outputFile] to trigger the read traces,
|
||
|
|
# just in case.
|
||
|
|
#
|
||
|
|
# BUT! A little known feature of Tcl variable traces is that
|
||
|
|
# traces are disabled during the handling of other traces. So,
|
||
|
|
# if we trigger read traces on Option(-outfile) and that triggers
|
||
|
|
# command line parsing which turns around and sets an initial
|
||
|
|
# value for Option(-outfile) -- <whew!> -- the write trace that
|
||
|
|
# would keep [outputChannel] in sync with that new initial value
|
||
|
|
# would not fire!
|
||
|
|
#
|
||
|
|
# SO, finally, as a workaround, instead of triggering read traces
|
||
|
|
# by invoking [outputFile], we instead trigger the same set of
|
||
|
|
# read traces by invoking [debug]. Any command that reads a
|
||
|
|
# configuration option would do. [debug] is just a handy one.
|
||
|
|
# The end result is that we support tcltest 1 compatibility and
|
||
|
|
# keep outputChannel and -outfile in sync in all cases.
|
||
|
|
debug
|
||
|
|
|
||
|
|
if {[llength [info level 0]] == 1} {
|
||
|
|
return $outputChannel
|
||
|
|
}
|
||
|
|
if {[info exists ChannelsWeOpened($outputChannel)]} {
|
||
|
|
close $outputChannel
|
||
|
|
unset ChannelsWeOpened($outputChannel)
|
||
|
|
}
|
||
|
|
switch -exact -- $filename {
|
||
|
|
stderr -
|
||
|
|
stdout {
|
||
|
|
set outputChannel $filename
|
||
|
|
}
|
||
|
|
default {
|
||
|
|
set outputChannel [open $filename a]
|
||
|
|
set ChannelsWeOpened($outputChannel) 1
|
||
|
|
|
||
|
|
# If we created the file in [temporaryDirectory], then
|
||
|
|
# [cleanupTests] will delete it, unless we claim it was
|
||
|
|
# already there.
|
||
|
|
set outdir [normalizePath [file dirname \
|
||
|
|
[file join [pwd] $filename]]]
|
||
|
|
if {$outdir eq [temporaryDirectory]} {
|
||
|
|
variable filesExisted
|
||
|
|
FillFilesExisted
|
||
|
|
set filename [file tail $filename]
|
||
|
|
if {$filename ni $filesExisted} {
|
||
|
|
lappend filesExisted $filename
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $outputChannel
|
||
|
|
}
|
||
|
|
|
||
|
|
# errors go to stderr by default
|
||
|
|
Default errorChannel stderr
|
||
|
|
proc errorChannel { {filename ""} } {
|
||
|
|
variable errorChannel
|
||
|
|
variable ChannelsWeOpened
|
||
|
|
|
||
|
|
# This is subtle and tricky. See the comment above in
|
||
|
|
# [outputChannel] for a detailed explanation.
|
||
|
|
debug
|
||
|
|
|
||
|
|
if {[llength [info level 0]] == 1} {
|
||
|
|
return $errorChannel
|
||
|
|
}
|
||
|
|
if {[info exists ChannelsWeOpened($errorChannel)]} {
|
||
|
|
close $errorChannel
|
||
|
|
unset ChannelsWeOpened($errorChannel)
|
||
|
|
}
|
||
|
|
switch -exact -- $filename {
|
||
|
|
stderr -
|
||
|
|
stdout {
|
||
|
|
set errorChannel $filename
|
||
|
|
}
|
||
|
|
default {
|
||
|
|
set errorChannel [open $filename a]
|
||
|
|
set ChannelsWeOpened($errorChannel) 1
|
||
|
|
|
||
|
|
# If we created the file in [temporaryDirectory], then
|
||
|
|
# [cleanupTests] will delete it, unless we claim it was
|
||
|
|
# already there.
|
||
|
|
set outdir [normalizePath [file dirname \
|
||
|
|
[file join [pwd] $filename]]]
|
||
|
|
if {$outdir eq [temporaryDirectory]} {
|
||
|
|
variable filesExisted
|
||
|
|
FillFilesExisted
|
||
|
|
set filename [file tail $filename]
|
||
|
|
if {$filename ni $filesExisted} {
|
||
|
|
lappend filesExisted $filename
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $errorChannel
|
||
|
|
}
|
||
|
|
|
||
|
|
##### Set up the configurable options
|
||
|
|
#
|
||
|
|
# The configurable options of the package
|
||
|
|
variable Option; array set Option {}
|
||
|
|
|
||
|
|
# Usage strings for those options
|
||
|
|
variable Usage; array set Usage {}
|
||
|
|
|
||
|
|
# Verification commands for those options
|
||
|
|
variable Verify; array set Verify {}
|
||
|
|
|
||
|
|
# Initialize the default values of the configurable options that are
|
||
|
|
# historically associated with an exported variable. If that variable
|
||
|
|
# is already set, support compatibility by accepting its pre-set value.
|
||
|
|
# Use [trace] to establish ongoing connection between the deprecated
|
||
|
|
# exported variable and the modern option kept as a true internal var.
|
||
|
|
# Also set up usage string and value testing for the option.
|
||
|
|
proc Option {option value usage {verify AcceptAll} {varName {}}} {
|
||
|
|
variable Option
|
||
|
|
variable Verify
|
||
|
|
variable Usage
|
||
|
|
variable OptionControlledVariables
|
||
|
|
variable DefaultValue
|
||
|
|
set Usage($option) $usage
|
||
|
|
set Verify($option) $verify
|
||
|
|
set DefaultValue($option) $value
|
||
|
|
if {[catch {$verify $value} msg]} {
|
||
|
|
return -code error $msg
|
||
|
|
} else {
|
||
|
|
set Option($option) $msg
|
||
|
|
}
|
||
|
|
if {[string length $varName]} {
|
||
|
|
variable $varName
|
||
|
|
if {[info exists $varName]} {
|
||
|
|
if {[catch {$verify [set $varName]} msg]} {
|
||
|
|
return -code error $msg
|
||
|
|
} else {
|
||
|
|
set Option($option) $msg
|
||
|
|
}
|
||
|
|
unset $varName
|
||
|
|
}
|
||
|
|
namespace eval [namespace current] \
|
||
|
|
[list upvar 0 Option($option) $varName]
|
||
|
|
# Workaround for Bug (now Feature Request) 572889. Grrrr....
|
||
|
|
# Track all the variables tied to options
|
||
|
|
lappend OptionControlledVariables $varName
|
||
|
|
# Later, set auto-configure read traces on all
|
||
|
|
# of them, since a single trace on Option does not work.
|
||
|
|
proc $varName {{value {}}} [subst -nocommands {
|
||
|
|
if {[llength [info level 0]] == 2} {
|
||
|
|
Configure $option [set value]
|
||
|
|
}
|
||
|
|
return [Configure $option]
|
||
|
|
}]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc MatchingOption {option} {
|
||
|
|
variable Option
|
||
|
|
set match [array names Option $option*]
|
||
|
|
switch -- [llength $match] {
|
||
|
|
0 {
|
||
|
|
set sorted [lsort [array names Option]]
|
||
|
|
set values [join [lrange $sorted 0 end-1] ", "]
|
||
|
|
append values ", or [lindex $sorted end]"
|
||
|
|
return -code error "unknown option $option: should be\
|
||
|
|
one of $values"
|
||
|
|
}
|
||
|
|
1 {
|
||
|
|
return [lindex $match 0]
|
||
|
|
}
|
||
|
|
default {
|
||
|
|
# Exact match trumps ambiguity
|
||
|
|
if {$option in $match} {
|
||
|
|
return $option
|
||
|
|
}
|
||
|
|
set values [join [lrange $match 0 end-1] ", "]
|
||
|
|
append values ", or [lindex $match end]"
|
||
|
|
return -code error "ambiguous option $option:\
|
||
|
|
could match $values"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc EstablishAutoConfigureTraces {} {
|
||
|
|
variable OptionControlledVariables
|
||
|
|
foreach varName [concat $OptionControlledVariables Option] {
|
||
|
|
variable $varName
|
||
|
|
trace add variable $varName read [namespace code {
|
||
|
|
ProcessCmdLineArgs ;#}]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc RemoveAutoConfigureTraces {} {
|
||
|
|
variable OptionControlledVariables
|
||
|
|
foreach varName [concat $OptionControlledVariables Option] {
|
||
|
|
variable $varName
|
||
|
|
foreach pair [trace info variable $varName] {
|
||
|
|
lassign $pair op cmd
|
||
|
|
if {($op eq "read") &&
|
||
|
|
[string match *ProcessCmdLineArgs* $cmd]} {
|
||
|
|
trace remove variable $varName $op $cmd
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# Once the traces are removed, this can become a no-op
|
||
|
|
proc RemoveAutoConfigureTraces {} {}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc Configure args {
|
||
|
|
variable Option
|
||
|
|
variable Verify
|
||
|
|
set n [llength $args]
|
||
|
|
if {$n == 0} {
|
||
|
|
return [lsort [array names Option]]
|
||
|
|
}
|
||
|
|
if {$n == 1} {
|
||
|
|
if {[catch {MatchingOption [lindex $args 0]} option]} {
|
||
|
|
return -code error $option
|
||
|
|
}
|
||
|
|
return $Option($option)
|
||
|
|
}
|
||
|
|
while {[llength $args] > 1} {
|
||
|
|
if {[catch {MatchingOption [lindex $args 0]} option]} {
|
||
|
|
return -code error $option
|
||
|
|
}
|
||
|
|
if {[catch {$Verify($option) [lindex $args 1]} value]} {
|
||
|
|
return -code error "invalid $option\
|
||
|
|
value \"[lindex $args 1]\": $value"
|
||
|
|
}
|
||
|
|
set Option($option) $value
|
||
|
|
set args [lrange $args 2 end]
|
||
|
|
}
|
||
|
|
if {[llength $args]} {
|
||
|
|
if {[catch {MatchingOption [lindex $args 0]} option]} {
|
||
|
|
return -code error $option
|
||
|
|
}
|
||
|
|
return -code error "missing value for option $option"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
proc configure args {
|
||
|
|
if {[llength $args] > 1} {
|
||
|
|
RemoveAutoConfigureTraces
|
||
|
|
}
|
||
|
|
set code [catch {Configure {*}$args} msg]
|
||
|
|
return -code $code $msg
|
||
|
|
}
|
||
|
|
|
||
|
|
proc AcceptVerbose { level } {
|
||
|
|
set level [AcceptList $level]
|
||
|
|
set levelMap {
|
||
|
|
l list
|
||
|
|
p pass
|
||
|
|
b body
|
||
|
|
s skip
|
||
|
|
t start
|
||
|
|
e error
|
||
|
|
l line
|
||
|
|
m msec
|
||
|
|
u usec
|
||
|
|
}
|
||
|
|
set levelRegexp "^([join [dict values $levelMap] |])\$"
|
||
|
|
if {[llength $level] == 1} {
|
||
|
|
if {![regexp $levelRegexp $level]} {
|
||
|
|
# translate single characters abbreviations to expanded list
|
||
|
|
set level [string map $levelMap [split $level {}]]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
set valid [list]
|
||
|
|
foreach v $level {
|
||
|
|
if {[regexp $levelRegexp $v]} {
|
||
|
|
lappend valid $v
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $valid
|
||
|
|
}
|
||
|
|
|
||
|
|
proc IsVerbose {level} {
|
||
|
|
variable Option
|
||
|
|
return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
|
||
|
|
}
|
||
|
|
|
||
|
|
# Default verbosity is to show bodies of failed tests
|
||
|
|
Option -verbose {body error} {
|
||
|
|
Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'.
|
||
|
|
Test suite will display all passed tests if 'p' is specified, all
|
||
|
|
skipped tests if 's' is specified, the bodies of failed tests if
|
||
|
|
'b' is specified, and when tests start if 't' is specified.
|
||
|
|
ErrorInfo is displayed if 'e' is specified. Source file line
|
||
|
|
information of failed tests is displayed if 'l' is specified.
|
||
|
|
} AcceptVerbose verbose
|
||
|
|
|
||
|
|
# 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.
|
||
|
|
Option -match * {
|
||
|
|
Run all tests within the specified files that match one of the
|
||
|
|
list of glob patterns given.
|
||
|
|
} AcceptList match
|
||
|
|
|
||
|
|
Option -skip {} {
|
||
|
|
Skip all tests within the specified tests (via -match) and files
|
||
|
|
that match one of the list of glob patterns given.
|
||
|
|
} AcceptList skip
|
||
|
|
|
||
|
|
Option -file *.test {
|
||
|
|
Run tests in all test files that match the glob pattern given.
|
||
|
|
} AcceptPattern matchFiles
|
||
|
|
|
||
|
|
# By default, skip files that appear to be SCCS lock files.
|
||
|
|
Option -notfile l.*.test {
|
||
|
|
Skip all test files that match the glob pattern given.
|
||
|
|
} AcceptPattern skipFiles
|
||
|
|
|
||
|
|
Option -relateddir * {
|
||
|
|
Run tests in directories that match the glob pattern given.
|
||
|
|
} AcceptPattern matchDirectories
|
||
|
|
|
||
|
|
Option -asidefromdir {} {
|
||
|
|
Skip tests in directories that match the glob pattern given.
|
||
|
|
} AcceptPattern skipDirectories
|
||
|
|
|
||
|
|
# By default, don't save core files
|
||
|
|
Option -preservecore 0 {
|
||
|
|
If 2, save any core files produced during testing in the directory
|
||
|
|
specified by -tmpdir. If 1, notify the user if core files are
|
||
|
|
created.
|
||
|
|
} AcceptInteger preserveCore
|
||
|
|
|
||
|
|
# 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.
|
||
|
|
Option -debug 0 {
|
||
|
|
Internal debug level
|
||
|
|
} AcceptInteger debug
|
||
|
|
|
||
|
|
proc SetSelectedConstraints args {
|
||
|
|
variable Option
|
||
|
|
foreach c $Option(-constraints) {
|
||
|
|
testConstraint $c 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
Option -constraints {} {
|
||
|
|
Do not skip the listed constraints listed in -constraints.
|
||
|
|
} AcceptList
|
||
|
|
trace add variable Option(-constraints) write \
|
||
|
|
[namespace code {SetSelectedConstraints ;#}]
|
||
|
|
|
||
|
|
# Don't run only the "-constraint" specified tests by default
|
||
|
|
proc ClearUnselectedConstraints args {
|
||
|
|
variable Option
|
||
|
|
variable testConstraints
|
||
|
|
if {!$Option(-limitconstraints)} {return}
|
||
|
|
foreach c [array names testConstraints] {
|
||
|
|
if {$c ni $Option(-constraints)} {
|
||
|
|
testConstraint $c 0
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
Option -limitconstraints 0 {
|
||
|
|
whether to run only tests with the constraints
|
||
|
|
} AcceptBoolean limitConstraints
|
||
|
|
trace add variable Option(-limitconstraints) write \
|
||
|
|
[namespace code {ClearUnselectedConstraints ;#}]
|
||
|
|
|
||
|
|
# A test application has to know how to load the tested commands
|
||
|
|
# into the interpreter.
|
||
|
|
Option -load {} {
|
||
|
|
Specifies the script to load the tested commands.
|
||
|
|
} AcceptScript loadScript
|
||
|
|
|
||
|
|
# Default is to run each test file in a separate process
|
||
|
|
Option -singleproc 0 {
|
||
|
|
whether to run all tests in one process
|
||
|
|
} AcceptBoolean singleProcess
|
||
|
|
|
||
|
|
proc AcceptTemporaryDirectory { directory } {
|
||
|
|
set directory [AcceptAbsolutePath $directory]
|
||
|
|
if {![file exists $directory]} {
|
||
|
|
file mkdir $directory
|
||
|
|
}
|
||
|
|
set directory [AcceptDirectory $directory]
|
||
|
|
if {![file writable $directory]} {
|
||
|
|
if {[workingDirectory] eq $directory} {
|
||
|
|
# Special exception: accept the default value
|
||
|
|
# even if the directory is not writable
|
||
|
|
return $directory
|
||
|
|
}
|
||
|
|
return -code error "\"$directory\" is not writeable"
|
||
|
|
}
|
||
|
|
return $directory
|
||
|
|
}
|
||
|
|
|
||
|
|
# Directory where files should be created
|
||
|
|
Option -tmpdir [workingDirectory] {
|
||
|
|
Save temporary files in the specified directory.
|
||
|
|
} AcceptTemporaryDirectory temporaryDirectory
|
||
|
|
trace add variable Option(-tmpdir) write \
|
||
|
|
[namespace code {normalizePath Option(-tmpdir) ;#}]
|
||
|
|
|
||
|
|
# Tests should not rely on the current working directory.
|
||
|
|
# Files that are part of the test suite should be accessed relative
|
||
|
|
# to [testsDirectory]
|
||
|
|
Option -testdir [workingDirectory] {
|
||
|
|
Search tests in the specified directory.
|
||
|
|
} AcceptDirectory testsDirectory
|
||
|
|
trace add variable Option(-testdir) write \
|
||
|
|
[namespace code {normalizePath Option(-testdir) ;#}]
|
||
|
|
|
||
|
|
proc AcceptLoadFile { file } {
|
||
|
|
if {$file eq {}} {return $file}
|
||
|
|
set file [file join [temporaryDirectory] $file]
|
||
|
|
return [AcceptReadable $file]
|
||
|
|
}
|
||
|
|
proc ReadLoadScript {args} {
|
||
|
|
variable Option
|
||
|
|
if {$Option(-loadfile) eq {}} {return}
|
||
|
|
set tmp [open $Option(-loadfile) r]
|
||
|
|
loadScript [read $tmp]
|
||
|
|
close $tmp
|
||
|
|
}
|
||
|
|
Option -loadfile {} {
|
||
|
|
Read the script to load the tested commands from the specified file.
|
||
|
|
} AcceptLoadFile loadFile
|
||
|
|
trace add variable Option(-loadfile) write [namespace code ReadLoadScript]
|
||
|
|
|
||
|
|
proc AcceptOutFile { file } {
|
||
|
|
if {[string equal stderr $file]} {return $file}
|
||
|
|
if {[string equal stdout $file]} {return $file}
|
||
|
|
return [file join [temporaryDirectory] $file]
|
||
|
|
}
|
||
|
|
|
||
|
|
# output goes to stdout by default
|
||
|
|
Option -outfile stdout {
|
||
|
|
Send output from test runs to the specified file.
|
||
|
|
} AcceptOutFile outputFile
|
||
|
|
trace add variable Option(-outfile) write \
|
||
|
|
[namespace code {outputChannel $Option(-outfile) ;#}]
|
||
|
|
|
||
|
|
# errors go to stderr by default
|
||
|
|
Option -errfile stderr {
|
||
|
|
Send errors from test runs to the specified file.
|
||
|
|
} AcceptOutFile errorFile
|
||
|
|
trace add variable Option(-errfile) write \
|
||
|
|
[namespace code {errorChannel $Option(-errfile) ;#}]
|
||
|
|
|
||
|
|
proc loadIntoSlaveInterpreter {slave args} {
|
||
|
|
variable Version
|
||
|
|
interp eval $slave [package ifneeded tcltest $Version]
|
||
|
|
interp eval $slave "tcltest::configure {*}{$args}"
|
||
|
|
interp alias $slave ::tcltest::ReportToMaster \
|
||
|
|
{} ::tcltest::ReportedFromSlave
|
||
|
|
}
|
||
|
|
proc ReportedFromSlave {total passed skipped failed because newfiles} {
|
||
|
|
variable numTests
|
||
|
|
variable skippedBecause
|
||
|
|
variable createdNewFiles
|
||
|
|
incr numTests(Total) $total
|
||
|
|
incr numTests(Passed) $passed
|
||
|
|
incr numTests(Skipped) $skipped
|
||
|
|
incr numTests(Failed) $failed
|
||
|
|
foreach {constraint count} $because {
|
||
|
|
incr skippedBecause($constraint) $count
|
||
|
|
}
|
||
|
|
foreach {testfile created} $newfiles {
|
||
|
|
lappend createdNewFiles($testfile) {*}$created
|
||
|
|
}
|
||
|
|
return
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
#####################################################################
|
||
|
|
|
||
|
|
# 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 1 $arrayvar $arrayvar}
|
||
|
|
parray $arrayvar
|
||
|
|
}
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
# Define our own [parray] in ::tcltest that will inherit use of the [puts]
|
||
|
|
# defined in ::tcltest. NOTE: Ought to construct with [info args] and
|
||
|
|
# [info default], but can't be bothered now. If [parray] changes, then
|
||
|
|
# this will need changing too.
|
||
|
|
auto_load ::parray
|
||
|
|
proc tcltest::parray {a {pattern *}} [info body ::parray]
|
||
|
|
|
||
|
|
# 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 1 $script
|
||
|
|
}
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
#####################################################################
|
||
|
|
|
||
|
|
proc tcltest::Warn {msg} {
|
||
|
|
puts [outputChannel] "WARNING: $msg"
|
||
|
|
}
|
||
|
|
|
||
|
|
# tcltest::mainThread
|
||
|
|
#
|
||
|
|
# Accessor command for tcltest variable mainThread.
|
||
|
|
#
|
||
|
|
proc tcltest::mainThread { {new ""} } {
|
||
|
|
variable mainThread
|
||
|
|
if {[llength [info level 0]] == 1} {
|
||
|
|
return $mainThread
|
||
|
|
}
|
||
|
|
set mainThread $new
|
||
|
|
}
|
||
|
|
|
||
|
|
# 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:
|
||
|
|
# none
|
||
|
|
|
||
|
|
proc tcltest::testConstraint {constraint {value ""}} {
|
||
|
|
variable testConstraints
|
||
|
|
variable Option
|
||
|
|
DebugPuts 3 "entering testConstraint $constraint $value"
|
||
|
|
if {[llength [info level 0]] == 2} {
|
||
|
|
return $testConstraints($constraint)
|
||
|
|
}
|
||
|
|
# Check for boolean values
|
||
|
|
if {[catch {expr {$value && $value}} msg]} {
|
||
|
|
return -code error $msg
|
||
|
|
}
|
||
|
|
if {[limitConstraints] && ($constraint ni $Option(-constraints))} {
|
||
|
|
set value 0
|
||
|
|
}
|
||
|
|
set testConstraints($constraint) $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 ""} } {
|
||
|
|
variable tcltest
|
||
|
|
if {[llength [info level 0]] == 1} {
|
||
|
|
return $tcltest
|
||
|
|
}
|
||
|
|
set tcltest $interp
|
||
|
|
}
|
||
|
|
|
||
|
|
#####################################################################
|
||
|
|
|
||
|
|
# 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
|
||
|
|
variable skippedBecause
|
||
|
|
|
||
|
|
if {[info exists skippedBecause($constraint)]} {
|
||
|
|
incr skippedBecause($constraint) $value
|
||
|
|
} else {
|
||
|
|
set 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 - $InitialMsgLen)} {
|
||
|
|
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 ne "end"} {
|
||
|
|
puts -nonewline [errorChannel] \
|
||
|
|
[string repeat " " $InitialMsgLen]
|
||
|
|
if {($endingIndex - $beginningIndex)
|
||
|
|
< (80 - $InitialMsgLen)} {
|
||
|
|
puts [errorChannel] [string trim \
|
||
|
|
[string range $errorMsg $beginningIndex end]]
|
||
|
|
break
|
||
|
|
} else {
|
||
|
|
set newEndingIndex [expr {[string last " " \
|
||
|
|
[string range $errorMsg $beginningIndex \
|
||
|
|
[expr {$beginningIndex
|
||
|
|
+ (80 - $InitialMsgLen)}]
|
||
|
|
]] + $beginningIndex}]
|
||
|
|
if {($newEndingIndex <= 0)
|
||
|
|
|| ($newEndingIndex <= $beginningIndex)} {
|
||
|
|
set newEndingIndex end
|
||
|
|
}
|
||
|
|
puts [errorChannel] [string trim \
|
||
|
|
[string range $errorMsg \
|
||
|
|
$beginningIndex $newEndingIndex]]
|
||
|
|
set beginningIndex $newEndingIndex
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
flush [errorChannel]
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
# tcltest::SafeFetch --
|
||
|
|
#
|
||
|
|
# The following trace procedure makes it so that we can safely
|
||
|
|
# refer to non-existent members of the 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
|
||
|
|
# testConstraints("X") is defined.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# n1 - name of the array (testConstraints)
|
||
|
|
# n2 - array key value (constraint name)
|
||
|
|
# op - operation performed on testConstraints (generally r)
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# none
|
||
|
|
#
|
||
|
|
# Side effects:
|
||
|
|
# sets testConstraints($n2) to 0 if it's referenced but never
|
||
|
|
# before used
|
||
|
|
|
||
|
|
proc tcltest::SafeFetch {n1 n2 op} {
|
||
|
|
variable testConstraints
|
||
|
|
DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
|
||
|
|
if {$n2 eq {}} {return}
|
||
|
|
if {![info exists testConstraints($n2)]} {
|
||
|
|
if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
|
||
|
|
testConstraint $n2 0
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# tcltest::ConstraintInitializer --
|
||
|
|
#
|
||
|
|
# Get or set a script that when evaluated in the tcltest namespace
|
||
|
|
# will return a boolean value with which to initialize the
|
||
|
|
# associated constraint.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# constraint - name of the constraint initialized by the script
|
||
|
|
# script - the initializer script
|
||
|
|
#
|
||
|
|
# Results
|
||
|
|
# boolean value of the constraint - enabled or disabled
|
||
|
|
#
|
||
|
|
# Side effects:
|
||
|
|
# Constraint is initialized for future reference by [test]
|
||
|
|
proc tcltest::ConstraintInitializer {constraint {script ""}} {
|
||
|
|
variable ConstraintInitializer
|
||
|
|
DebugPuts 3 "entering ConstraintInitializer $constraint $script"
|
||
|
|
if {[llength [info level 0]] == 2} {
|
||
|
|
return $ConstraintInitializer($constraint)
|
||
|
|
}
|
||
|
|
# Check for boolean values
|
||
|
|
if {![info complete $script]} {
|
||
|
|
return -code error "ConstraintInitializer must be complete script"
|
||
|
|
}
|
||
|
|
set ConstraintInitializer($constraint) $script
|
||
|
|
}
|
||
|
|
|
||
|
|
# tcltest::InitConstraints --
|
||
|
|
#
|
||
|
|
# Call all registered constraint initializers to force initialization
|
||
|
|
# of all known constraints.
|
||
|
|
# See the tcltest man page for the list of built-in constraints defined
|
||
|
|
# in this procedure.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# none
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# The testConstraints array is reset to have an index for each
|
||
|
|
# built-in test constraint.
|
||
|
|
#
|
||
|
|
# Side Effects:
|
||
|
|
# None.
|
||
|
|
#
|
||
|
|
|
||
|
|
proc tcltest::InitConstraints {} {
|
||
|
|
variable ConstraintInitializer
|
||
|
|
initConstraintsHook
|
||
|
|
foreach constraint [array names ConstraintInitializer] {
|
||
|
|
testConstraint $constraint
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tcltest::DefineConstraintInitializers {} {
|
||
|
|
ConstraintInitializer singleTestInterp {singleProcess}
|
||
|
|
|
||
|
|
# All the 'pc' constraints are here for backward compatibility and
|
||
|
|
# are not documented. They have been replaced with equivalent 'win'
|
||
|
|
# constraints.
|
||
|
|
|
||
|
|
ConstraintInitializer unixOnly \
|
||
|
|
{string equal $::tcl_platform(platform) unix}
|
||
|
|
ConstraintInitializer macOnly \
|
||
|
|
{string equal $::tcl_platform(platform) macintosh}
|
||
|
|
ConstraintInitializer pcOnly \
|
||
|
|
{string equal $::tcl_platform(platform) windows}
|
||
|
|
ConstraintInitializer winOnly \
|
||
|
|
{string equal $::tcl_platform(platform) windows}
|
||
|
|
|
||
|
|
ConstraintInitializer unix {testConstraint unixOnly}
|
||
|
|
ConstraintInitializer mac {testConstraint macOnly}
|
||
|
|
ConstraintInitializer pc {testConstraint pcOnly}
|
||
|
|
ConstraintInitializer win {testConstraint winOnly}
|
||
|
|
|
||
|
|
ConstraintInitializer unixOrPc \
|
||
|
|
{expr {[testConstraint unix] || [testConstraint pc]}}
|
||
|
|
ConstraintInitializer macOrPc \
|
||
|
|
{expr {[testConstraint mac] || [testConstraint pc]}}
|
||
|
|
ConstraintInitializer unixOrWin \
|
||
|
|
{expr {[testConstraint unix] || [testConstraint win]}}
|
||
|
|
ConstraintInitializer macOrWin \
|
||
|
|
{expr {[testConstraint mac] || [testConstraint win]}}
|
||
|
|
ConstraintInitializer macOrUnix \
|
||
|
|
{expr {[testConstraint mac] || [testConstraint unix]}}
|
||
|
|
|
||
|
|
ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
|
||
|
|
ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
|
||
|
|
ConstraintInitializer 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.
|
||
|
|
|
||
|
|
ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
|
||
|
|
ConstraintInitializer tempNotWin {expr {![testConstraint win]}}
|
||
|
|
ConstraintInitializer tempNotMac {expr {![testConstraint mac]}}
|
||
|
|
ConstraintInitializer tempNotUnix {expr {![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.
|
||
|
|
|
||
|
|
ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
|
||
|
|
ConstraintInitializer winCrash {expr {![testConstraint win]}}
|
||
|
|
ConstraintInitializer macCrash {expr {![testConstraint mac]}}
|
||
|
|
ConstraintInitializer unixCrash {expr {![testConstraint unix]}}
|
||
|
|
|
||
|
|
# Skip empty tests
|
||
|
|
|
||
|
|
ConstraintInitializer emptyTest {format 0}
|
||
|
|
|
||
|
|
# By default, tests that expose known bugs are skipped.
|
||
|
|
|
||
|
|
ConstraintInitializer knownBug {format 0}
|
||
|
|
|
||
|
|
# By default, non-portable tests are skipped.
|
||
|
|
|
||
|
|
ConstraintInitializer nonPortable {format 0}
|
||
|
|
|
||
|
|
# Some tests require user interaction.
|
||
|
|
|
||
|
|
ConstraintInitializer userInteraction {format 0}
|
||
|
|
|
||
|
|
# Some tests must be skipped if the interpreter is not in
|
||
|
|
# interactive mode
|
||
|
|
|
||
|
|
ConstraintInitializer interactive \
|
||
|
|
{expr {[info exists ::tcl_interactive] && $::tcl_interactive}}
|
||
|
|
|
||
|
|
# 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.
|
||
|
|
|
||
|
|
ConstraintInitializer root {expr \
|
||
|
|
{($::tcl_platform(platform) eq "unix") &&
|
||
|
|
($::tcl_platform(user) in {root {}})}}
|
||
|
|
ConstraintInitializer notRoot {expr {![testConstraint root]}}
|
||
|
|
|
||
|
|
# Set nonBlockFiles constraint: 1 means this platform supports
|
||
|
|
# setting files into nonblocking mode.
|
||
|
|
|
||
|
|
ConstraintInitializer nonBlockFiles {
|
||
|
|
set code [expr {[catch {set f [open defs r]}]
|
||
|
|
|| [catch {chan configure $f -blocking off}]}]
|
||
|
|
catch {close $f}
|
||
|
|
set code
|
||
|
|
}
|
||
|
|
|
||
|
|
# 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).
|
||
|
|
|
||
|
|
ConstraintInitializer asyncPipeClose {expr {
|
||
|
|
!([string equal unix $::tcl_platform(platform)]
|
||
|
|
&& ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}
|
||
|
|
|
||
|
|
# Test to see if we have a broken version of sprintf with respect
|
||
|
|
# to the "e" format of floating-point numbers.
|
||
|
|
|
||
|
|
ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
|
||
|
|
|
||
|
|
# Test to see if execed commands such as cat, echo, rm and so forth
|
||
|
|
# are present on this machine.
|
||
|
|
|
||
|
|
ConstraintInitializer unixExecs {
|
||
|
|
set code 1
|
||
|
|
if {$::tcl_platform(platform) eq "macintosh"} {
|
||
|
|
set code 0
|
||
|
|
}
|
||
|
|
if {$::tcl_platform(platform) eq "windows"} {
|
||
|
|
if {[catch {
|
||
|
|
set file _tcl_test_remove_me.txt
|
||
|
|
makeFile {hello} $file
|
||
|
|
}]} {
|
||
|
|
set code 0
|
||
|
|
} elseif {
|
||
|
|
[catch {exec cat $file}] ||
|
||
|
|
[catch {exec echo hello}] ||
|
||
|
|
[catch {exec sh -c echo hello}] ||
|
||
|
|
[catch {exec wc $file}] ||
|
||
|
|
[catch {exec sleep 1}] ||
|
||
|
|
[catch {exec echo abc > $file}] ||
|
||
|
|
[catch {exec chmod 644 $file}] ||
|
||
|
|
[catch {exec rm $file}] ||
|
||
|
|
[llength [auto_execok mkdir]] == 0 ||
|
||
|
|
[llength [auto_execok fgrep]] == 0 ||
|
||
|
|
[llength [auto_execok grep]] == 0 ||
|
||
|
|
[llength [auto_execok ps]] == 0
|
||
|
|
} {
|
||
|
|
set code 0
|
||
|
|
}
|
||
|
|
removeFile $file
|
||
|
|
}
|
||
|
|
set code
|
||
|
|
}
|
||
|
|
|
||
|
|
ConstraintInitializer stdio {
|
||
|
|
set code 0
|
||
|
|
if {![catch {set f [open "|[list [interpreter]]" w]}]} {
|
||
|
|
if {![catch {puts $f exit}]} {
|
||
|
|
if {![catch {close $f}]} {
|
||
|
|
set code 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
set code
|
||
|
|
}
|
||
|
|
|
||
|
|
# Deliberately call socket with the wrong number of arguments. The
|
||
|
|
# error message you get will indicate whether sockets are available
|
||
|
|
# on this system.
|
||
|
|
|
||
|
|
ConstraintInitializer socket {
|
||
|
|
catch {socket} msg
|
||
|
|
string compare $msg "sockets are not available on this system"
|
||
|
|
}
|
||
|
|
|
||
|
|
# Check for internationalization
|
||
|
|
ConstraintInitializer hasIsoLocale {
|
||
|
|
if {[llength [info commands testlocale]] == 0} {
|
||
|
|
set code 0
|
||
|
|
} else {
|
||
|
|
set code [string length [SetIso8859_1_Locale]]
|
||
|
|
RestoreLocale
|
||
|
|
}
|
||
|
|
set code
|
||
|
|
}
|
||
|
|
|
||
|
|
}
|
||
|
|
#####################################################################
|
||
|
|
|
||
|
|
# Usage and command line arguments processing.
|
||
|
|
|
||
|
|
# tcltest::PrintUsageInfo
|
||
|
|
#
|
||
|
|
# Prints out the usage information for package tcltest. This can
|
||
|
|
# be customized with the redefinition of [PrintUsageInfoHook].
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# none
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# none
|
||
|
|
#
|
||
|
|
# Side Effects:
|
||
|
|
# none
|
||
|
|
proc tcltest::PrintUsageInfo {} {
|
||
|
|
puts [Usage]
|
||
|
|
PrintUsageInfoHook
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tcltest::Usage { {option ""} } {
|
||
|
|
variable Usage
|
||
|
|
variable Verify
|
||
|
|
if {[llength [info level 0]] == 1} {
|
||
|
|
set msg "Usage: [file tail [info nameofexecutable]] script "
|
||
|
|
append msg "?-help? ?flag value? ... \n"
|
||
|
|
append msg "Available flags (and valid input values) are:"
|
||
|
|
|
||
|
|
set max 0
|
||
|
|
set allOpts [concat -help [Configure]]
|
||
|
|
foreach opt $allOpts {
|
||
|
|
set foo [Usage $opt]
|
||
|
|
lassign $foo x type($opt) usage($opt)
|
||
|
|
set line($opt) " $opt $type($opt) "
|
||
|
|
set length($opt) [string length $line($opt)]
|
||
|
|
if {$length($opt) > $max} {set max $length($opt)}
|
||
|
|
}
|
||
|
|
set rest [expr {72 - $max}]
|
||
|
|
foreach opt $allOpts {
|
||
|
|
append msg \n$line($opt)
|
||
|
|
append msg [string repeat " " [expr {$max - $length($opt)}]]
|
||
|
|
set u [string trim $usage($opt)]
|
||
|
|
catch {append u " (default: \[[Configure $opt]])"}
|
||
|
|
regsub -all {\s*\n\s*} $u " " u
|
||
|
|
while {[string length $u] > $rest} {
|
||
|
|
set break [string wordstart $u $rest]
|
||
|
|
if {$break == 0} {
|
||
|
|
set break [string wordend $u 0]
|
||
|
|
}
|
||
|
|
append msg [string range $u 0 [expr {$break - 1}]]
|
||
|
|
set u [string trim [string range $u $break end]]
|
||
|
|
append msg \n[string repeat " " $max]
|
||
|
|
}
|
||
|
|
append msg $u
|
||
|
|
}
|
||
|
|
return $msg\n
|
||
|
|
} elseif {$option eq "-help"} {
|
||
|
|
return [list -help "" "Display this usage information."]
|
||
|
|
} else {
|
||
|
|
set type [lindex [info args $Verify($option)] 0]
|
||
|
|
return [list $option $type $Usage($option)]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# 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 {"-help" in $flagArray} {
|
||
|
|
PrintUsageInfo
|
||
|
|
exit 1
|
||
|
|
}
|
||
|
|
|
||
|
|
if {[llength $flagArray] == 0} {
|
||
|
|
RemoveAutoConfigureTraces
|
||
|
|
} else {
|
||
|
|
set args $flagArray
|
||
|
|
while {[llength $args] > 1 && [catch {configure {*}$args} msg]} {
|
||
|
|
|
||
|
|
# Something went wrong parsing $args for tcltest options
|
||
|
|
# Check whether the problem is "unknown option"
|
||
|
|
if {[regexp {^unknown option (\S+):} $msg -> option]} {
|
||
|
|
# Could be this is an option the Hook knows about
|
||
|
|
set moreOptions [processCmdLineArgsAddFlagsHook]
|
||
|
|
if {$option ni $moreOptions} {
|
||
|
|
# Nope. Report the error, including additional options,
|
||
|
|
# but keep going
|
||
|
|
if {[llength $moreOptions]} {
|
||
|
|
append msg ", "
|
||
|
|
append msg [join [lrange $moreOptions 0 end-1] ", "]
|
||
|
|
append msg "or [lindex $moreOptions end]"
|
||
|
|
}
|
||
|
|
Warn $msg
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
# error is something other than "unknown option"
|
||
|
|
# notify user of the error; and exit
|
||
|
|
puts [errorChannel] $msg
|
||
|
|
exit 1
|
||
|
|
}
|
||
|
|
|
||
|
|
# To recover, find that unknown option and remove up to it.
|
||
|
|
# then retry
|
||
|
|
while {[lindex $args 0] ne $option} {
|
||
|
|
set args [lrange $args 2 end]
|
||
|
|
}
|
||
|
|
set args [lrange $args 2 end]
|
||
|
|
}
|
||
|
|
if {[llength $args] == 1} {
|
||
|
|
puts [errorChannel] \
|
||
|
|
"missing value for option [lindex $args 0]"
|
||
|
|
exit 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Call the hook
|
||
|
|
catch {
|
||
|
|
array set flag $flagArray
|
||
|
|
processCmdLineArgsHook [array get flag]
|
||
|
|
}
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
# tcltest::ProcessCmdLineArgs --
|
||
|
|
#
|
||
|
|
# This procedure must be run after constraint initialization is
|
||
|
|
# set up (by [DefineConstraintInitializers]) because some constraints
|
||
|
|
# can be overridden.
|
||
|
|
#
|
||
|
|
# Perform configuration according to the command-line options.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# none
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# Sets the above-named variables in the tcltest namespace.
|
||
|
|
#
|
||
|
|
# Side Effects:
|
||
|
|
# None.
|
||
|
|
#
|
||
|
|
|
||
|
|
proc tcltest::ProcessCmdLineArgs {} {
|
||
|
|
variable originalEnv
|
||
|
|
variable testConstraints
|
||
|
|
|
||
|
|
# The "argv" var doesn't exist in some cases, so use {}.
|
||
|
|
if {![info exists ::argv]} {
|
||
|
|
ProcessFlags {}
|
||
|
|
} else {
|
||
|
|
ProcessFlags $::argv
|
||
|
|
}
|
||
|
|
|
||
|
|
# 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 = [debug]"
|
||
|
|
DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]"
|
||
|
|
DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]"
|
||
|
|
DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]"
|
||
|
|
DebugPuts 2 "tcltest::outputChannel = [outputChannel]"
|
||
|
|
DebugPuts 2 "tcltest::errorChannel = [errorChannel]"
|
||
|
|
DebugPuts 2 "Original environment (tcltest::originalEnv):"
|
||
|
|
DebugPArray 2 originalEnv
|
||
|
|
DebugPuts 2 "Constraints:"
|
||
|
|
DebugPArray 2 testConstraints
|
||
|
|
}
|
||
|
|
|
||
|
|
#####################################################################
|
||
|
|
|
||
|
|
# 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 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 outputChannel and errorChannel
|
||
|
|
# does not get sent to the normal puts function.
|
||
|
|
namespace eval tcltest::Replace {
|
||
|
|
namespace export puts
|
||
|
|
}
|
||
|
|
proc tcltest::Replace::puts {args} {
|
||
|
|
variable [namespace parent]::outData
|
||
|
|
variable [namespace parent]::errData
|
||
|
|
switch [llength $args] {
|
||
|
|
1 {
|
||
|
|
# Only the string to be printed is specified
|
||
|
|
append outData [lindex $args 0]\n
|
||
|
|
return
|
||
|
|
# return [Puts [lindex $args 0]]
|
||
|
|
}
|
||
|
|
2 {
|
||
|
|
# Either -nonewline or channelId has been specified
|
||
|
|
if {[lindex $args 0] eq "-nonewline"} {
|
||
|
|
append outData [lindex $args end]
|
||
|
|
return
|
||
|
|
# return [Puts -nonewline [lindex $args end]]
|
||
|
|
} else {
|
||
|
|
set channel [lindex $args 0]
|
||
|
|
set newline \n
|
||
|
|
}
|
||
|
|
}
|
||
|
|
3 {
|
||
|
|
if {[lindex $args 0] eq "-nonewline"} {
|
||
|
|
# Both -nonewline and channelId are specified, unless
|
||
|
|
# it's an error. -nonewline is supposed to be argv[0].
|
||
|
|
set channel [lindex $args 1]
|
||
|
|
set newline ""
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if {[info exists channel]} {
|
||
|
|
if {$channel in [list [[namespace parent]::outputChannel] stdout]} {
|
||
|
|
append outData [lindex $args end]$newline
|
||
|
|
return
|
||
|
|
} elseif {$channel in [list [[namespace parent]::errorChannel] stderr]} {
|
||
|
|
append errData [lindex $args end]$newline
|
||
|
|
return
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# If we haven't returned by now, we don't know how to handle the
|
||
|
|
# input. Let puts handle it.
|
||
|
|
return [Puts {*}$args]
|
||
|
|
}
|
||
|
|
|
||
|
|
# tcltest::Eval --
|
||
|
|
#
|
||
|
|
# Evaluate the script in the test environment. If ignoreOutput is
|
||
|
|
# false, store data sent to stderr and stdout in outData and
|
||
|
|
# 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 outData and errData before running a
|
||
|
|
# test if ignoreOutput is set to 0.
|
||
|
|
|
||
|
|
proc tcltest::Eval {script {ignoreOutput 1}} {
|
||
|
|
variable outData
|
||
|
|
variable errData
|
||
|
|
DebugPuts 3 "[lindex [info level 0] 0] called"
|
||
|
|
if {!$ignoreOutput} {
|
||
|
|
set outData {}
|
||
|
|
set errData {}
|
||
|
|
rename ::puts [namespace current]::Replace::Puts
|
||
|
|
namespace eval :: [list namespace import [namespace origin Replace::puts]]
|
||
|
|
namespace import Replace::puts
|
||
|
|
}
|
||
|
|
set result [uplevel 1 $script]
|
||
|
|
if {!$ignoreOutput} {
|
||
|
|
namespace forget puts
|
||
|
|
namespace eval :: namespace forget puts
|
||
|
|
rename [namespace current]::Replace::Puts ::puts
|
||
|
|
}
|
||
|
|
return $result
|
||
|
|
}
|
||
|
|
|
||
|
|
# tcltest::CompareStrings --
|
||
|
|
#
|
||
|
|
# compares the expected answer to the actual answer, depending on
|
||
|
|
# the mode provided. Mode determines whether a regexp, exact,
|
||
|
|
# glob or custom 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} {
|
||
|
|
variable CustomMatch
|
||
|
|
if {![info exists CustomMatch($mode)]} {
|
||
|
|
return -code error "No matching command registered for `-match $mode'"
|
||
|
|
}
|
||
|
|
set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
|
||
|
|
if {[catch {expr {$match && $match}} result]} {
|
||
|
|
return -code error "Invalid result from `-match $mode' command: $result"
|
||
|
|
}
|
||
|
|
return $match
|
||
|
|
}
|
||
|
|
|
||
|
|
# tcltest::customMatch --
|
||
|
|
#
|
||
|
|
# registers a command to be called when a particular type of
|
||
|
|
# matching is required.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# nickname - Keyword for the type of matching
|
||
|
|
# cmd - Incomplete command that implements that type of matching
|
||
|
|
# when completed with expected string and actual string
|
||
|
|
# and then evaluated.
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# None.
|
||
|
|
#
|
||
|
|
# Side effects:
|
||
|
|
# Sets the variable tcltest::CustomMatch
|
||
|
|
|
||
|
|
proc tcltest::customMatch {mode script} {
|
||
|
|
variable CustomMatch
|
||
|
|
if {![info complete $script]} {
|
||
|
|
return -code error \
|
||
|
|
"invalid customMatch script; can't evaluate after completion"
|
||
|
|
}
|
||
|
|
set CustomMatch($mode) $script
|
||
|
|
}
|
||
|
|
|
||
|
|
# 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
|
||
|
|
# separated 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 ne {}} {
|
||
|
|
# 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 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
|
||
|
|
# match variable, if it matches an element in 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
|
||
|
|
# "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 a string
|
||
|
|
# previously registered by a call to [customMatch].
|
||
|
|
# The strings exact, glob, and regexp are pre-registered
|
||
|
|
# by the tcltest package. Default value 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:
|
||
|
|
# None.
|
||
|
|
#
|
||
|
|
# Side effects:
|
||
|
|
# Just about anything is possible depending on the test.
|
||
|
|
#
|
||
|
|
|
||
|
|
proc tcltest::test {name description args} {
|
||
|
|
global tcl_platform
|
||
|
|
variable testLevel
|
||
|
|
variable coreModTime
|
||
|
|
DebugPuts 3 "test $name $args"
|
||
|
|
DebugDo 1 {
|
||
|
|
variable TestNames
|
||
|
|
catch {
|
||
|
|
puts "test name '$name' re-used; prior use in $TestNames($name)"
|
||
|
|
}
|
||
|
|
set TestNames($name) [info script]
|
||
|
|
}
|
||
|
|
|
||
|
|
FillFilesExisted
|
||
|
|
incr 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.
|
||
|
|
lassign {} constraints setup cleanup body result returnCodes match
|
||
|
|
|
||
|
|
# 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 {[string match -* [lindex $args 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(-$item)]} {
|
||
|
|
set testAttributes(-$item) [uplevel 1 \
|
||
|
|
::concat $testAttributes(-$item)]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
array set testAttributes $args
|
||
|
|
}
|
||
|
|
|
||
|
|
set validFlags {-setup -cleanup -body -result -returnCodes \
|
||
|
|
-match -output -errorOutput -constraints}
|
||
|
|
|
||
|
|
foreach flag [array names testAttributes] {
|
||
|
|
if {$flag ni $validFlags} {
|
||
|
|
incr testLevel -1
|
||
|
|
set sorted [lsort $validFlags]
|
||
|
|
set options [join [lrange $sorted 0 end-1] ", "]
|
||
|
|
append options ", or [lindex $sorted end]"
|
||
|
|
return -code error "bad option \"$flag\": must be $options"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# store whatever the user gave us
|
||
|
|
foreach item [array names testAttributes] {
|
||
|
|
set [string trimleft $item "-"] $testAttributes($item)
|
||
|
|
}
|
||
|
|
|
||
|
|
# Check the values supplied for -match
|
||
|
|
variable CustomMatch
|
||
|
|
if {$match ni [array names CustomMatch]} {
|
||
|
|
incr testLevel -1
|
||
|
|
set sorted [lsort [array names CustomMatch]]
|
||
|
|
set values [join [lrange $sorted 0 end-1] ", "]
|
||
|
|
append values ", or [lindex $sorted end]"
|
||
|
|
return -code error "bad -match value \"$match\":\
|
||
|
|
must be $values"
|
||
|
|
}
|
||
|
|
|
||
|
|
# Replace symbolic valies supplied for -returnCodes
|
||
|
|
foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
|
||
|
|
set returnCodes [string map -nocase [list $strcode $numcode] $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 {
|
||
|
|
incr testLevel -1
|
||
|
|
return -code error "wrong # args:\
|
||
|
|
should be \"test name desc ?options?\""
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if {[Skipped $name $constraints]} {
|
||
|
|
incr testLevel -1
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
# Save information about the core file.
|
||
|
|
if {[preserveCore]} {
|
||
|
|
if {[file exists [file join [workingDirectory] core]]} {
|
||
|
|
set coreModTime [file mtime [file join [workingDirectory] core]]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# First, run the setup script
|
||
|
|
set code [catch {uplevel 1 $setup} setupMsg]
|
||
|
|
if {$code == 1} {
|
||
|
|
set errorInfo(setup) $::errorInfo
|
||
|
|
set errorCode(setup) $::errorCode
|
||
|
|
}
|
||
|
|
set setupFailure [expr {$code != 0}]
|
||
|
|
|
||
|
|
# Only run the test body if the setup was successful
|
||
|
|
if {!$setupFailure} {
|
||
|
|
|
||
|
|
# Register startup time
|
||
|
|
if {[IsVerbose msec] || [IsVerbose usec]} {
|
||
|
|
set timeStart [clock microseconds]
|
||
|
|
}
|
||
|
|
|
||
|
|
# Verbose notification of $body start
|
||
|
|
if {[IsVerbose start]} {
|
||
|
|
puts [outputChannel] "---- $name start"
|
||
|
|
flush [outputChannel]
|
||
|
|
}
|
||
|
|
|
||
|
|
set command [list [namespace origin RunTest] $name $body]
|
||
|
|
if {[info exists output] || [info exists errorOutput]} {
|
||
|
|
set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
|
||
|
|
} else {
|
||
|
|
set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
|
||
|
|
}
|
||
|
|
lassign $testResult actualAnswer returnCode
|
||
|
|
if {$returnCode == 1} {
|
||
|
|
set errorInfo(body) $::errorInfo
|
||
|
|
set errorCode(body) $::errorCode
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# check if the return code matched the expected return code
|
||
|
|
set codeFailure 0
|
||
|
|
if {!$setupFailure && ($returnCode ni $returnCodes)} {
|
||
|
|
set codeFailure 1
|
||
|
|
}
|
||
|
|
|
||
|
|
# If expected output/error strings exist, we have to compare
|
||
|
|
# them. If the comparison fails, then so did the test.
|
||
|
|
set outputFailure 0
|
||
|
|
variable outData
|
||
|
|
if {[info exists output] && !$codeFailure} {
|
||
|
|
if {[set outputCompare [catch {
|
||
|
|
CompareStrings $outData $output $match
|
||
|
|
} outputMatch]] == 0} {
|
||
|
|
set outputFailure [expr {!$outputMatch}]
|
||
|
|
} else {
|
||
|
|
set outputFailure 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
set errorFailure 0
|
||
|
|
variable errData
|
||
|
|
if {[info exists errorOutput] && !$codeFailure} {
|
||
|
|
if {[set errorCompare [catch {
|
||
|
|
CompareStrings $errData $errorOutput $match
|
||
|
|
} errorMatch]] == 0} {
|
||
|
|
set errorFailure [expr {!$errorMatch}]
|
||
|
|
} else {
|
||
|
|
set errorFailure 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# check if the answer matched the expected answer
|
||
|
|
# Only check if we ran the body of the test (no setup failure)
|
||
|
|
if {$setupFailure || $codeFailure} {
|
||
|
|
set scriptFailure 0
|
||
|
|
} elseif {[set scriptCompare [catch {
|
||
|
|
CompareStrings $actualAnswer $result $match
|
||
|
|
} scriptMatch]] == 0} {
|
||
|
|
set scriptFailure [expr {!$scriptMatch}]
|
||
|
|
} else {
|
||
|
|
set scriptFailure 1
|
||
|
|
}
|
||
|
|
|
||
|
|
# Always run the cleanup script
|
||
|
|
set code [catch {uplevel 1 $cleanup} cleanupMsg]
|
||
|
|
if {$code == 1} {
|
||
|
|
set errorInfo(cleanup) $::errorInfo
|
||
|
|
set errorCode(cleanup) $::errorCode
|
||
|
|
}
|
||
|
|
set cleanupFailure [expr {$code != 0}]
|
||
|
|
|
||
|
|
set coreFailure 0
|
||
|
|
set coreMsg ""
|
||
|
|
# check for a core file first - if one was created by the test,
|
||
|
|
# then the test failed
|
||
|
|
if {[preserveCore]} {
|
||
|
|
if {[file exists [file join [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 [workingDirectory] core]]} {
|
||
|
|
set coreFailure 1
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
set coreFailure 1
|
||
|
|
}
|
||
|
|
|
||
|
|
if {([preserveCore] > 1) && ($coreFailure)} {
|
||
|
|
append coreMsg "\nMoving file to:\
|
||
|
|
[file join [temporaryDirectory] core-$name]"
|
||
|
|
catch {file rename -force -- \
|
||
|
|
[file join [workingDirectory] core] \
|
||
|
|
[file join [temporaryDirectory] core-$name]
|
||
|
|
} msg
|
||
|
|
if {$msg ne {}} {
|
||
|
|
append coreMsg "\nError:\
|
||
|
|
Problem renaming core file: $msg"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if {[IsVerbose msec] || [IsVerbose usec]} {
|
||
|
|
set t [expr {[clock microseconds] - $timeStart}]
|
||
|
|
if {[IsVerbose usec]} {
|
||
|
|
puts [outputChannel] "++++ $name took $t μs"
|
||
|
|
}
|
||
|
|
if {[IsVerbose msec]} {
|
||
|
|
puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# if we didn't experience any failures, then we passed
|
||
|
|
variable numTests
|
||
|
|
if {!($setupFailure || $cleanupFailure || $coreFailure
|
||
|
|
|| $outputFailure || $errorFailure || $codeFailure
|
||
|
|
|| $scriptFailure)} {
|
||
|
|
if {$testLevel == 1} {
|
||
|
|
incr numTests(Passed)
|
||
|
|
if {[IsVerbose pass]} {
|
||
|
|
puts [outputChannel] "++++ $name PASSED"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
incr testLevel -1
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
# We know the test failed, tally it...
|
||
|
|
if {$testLevel == 1} {
|
||
|
|
incr numTests(Failed)
|
||
|
|
}
|
||
|
|
|
||
|
|
# ... then report according to the type of failure
|
||
|
|
variable currentFailure true
|
||
|
|
if {![IsVerbose body]} {
|
||
|
|
set body ""
|
||
|
|
}
|
||
|
|
puts [outputChannel] "\n"
|
||
|
|
if {[IsVerbose line]} {
|
||
|
|
if {![catch {set testFrame [info frame -1]}] &&
|
||
|
|
[dict get $testFrame type] eq "source"} {
|
||
|
|
set testFile [dict get $testFrame file]
|
||
|
|
set testLine [dict get $testFrame line]
|
||
|
|
} else {
|
||
|
|
set testFile [file normalize [uplevel 1 {info script}]]
|
||
|
|
if {[file readable $testFile]} {
|
||
|
|
set testFd [open $testFile r]
|
||
|
|
set testLine [expr {[lsearch -regexp \
|
||
|
|
[split [read $testFd] "\n"] \
|
||
|
|
"^\[ \t\]*test [string map {. \\.} $name] "] + 1}]
|
||
|
|
close $testFd
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if {[info exists testLine]} {
|
||
|
|
puts [outputChannel] "$testFile:$testLine: error: test failed:\
|
||
|
|
$name [string trim $description]"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
puts [outputChannel] "==== $name\
|
||
|
|
[string trim $description] FAILED"
|
||
|
|
if {[string length $body]} {
|
||
|
|
puts [outputChannel] "==== Contents of test case:"
|
||
|
|
puts [outputChannel] $body
|
||
|
|
}
|
||
|
|
if {$setupFailure} {
|
||
|
|
puts [outputChannel] "---- Test setup\
|
||
|
|
failed:\n$setupMsg"
|
||
|
|
if {[info exists errorInfo(setup)]} {
|
||
|
|
puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
|
||
|
|
puts [outputChannel] "---- errorCode(setup): $errorCode(setup)"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if {$scriptFailure} {
|
||
|
|
if {$scriptCompare} {
|
||
|
|
puts [outputChannel] "---- Error testing result: $scriptMatch"
|
||
|
|
} else {
|
||
|
|
puts [outputChannel] "---- Result was:\n$actualAnswer"
|
||
|
|
puts [outputChannel] "---- Result should have been\
|
||
|
|
($match matching):\n$result"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if {$codeFailure} {
|
||
|
|
switch -- $returnCode {
|
||
|
|
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: $returnCode"
|
||
|
|
puts [outputChannel] "---- Return code should have been\
|
||
|
|
one of: $returnCodes"
|
||
|
|
if {[IsVerbose error]} {
|
||
|
|
if {[info exists errorInfo(body)] && (1 ni $returnCodes)} {
|
||
|
|
puts [outputChannel] "---- errorInfo: $errorInfo(body)"
|
||
|
|
puts [outputChannel] "---- errorCode: $errorCode(body)"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if {$outputFailure} {
|
||
|
|
if {$outputCompare} {
|
||
|
|
puts [outputChannel] "---- Error testing output: $outputMatch"
|
||
|
|
} else {
|
||
|
|
puts [outputChannel] "---- Output was:\n$outData"
|
||
|
|
puts [outputChannel] "---- Output should have been\
|
||
|
|
($match matching):\n$output"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if {$errorFailure} {
|
||
|
|
if {$errorCompare} {
|
||
|
|
puts [outputChannel] "---- Error testing errorOutput: $errorMatch"
|
||
|
|
} else {
|
||
|
|
puts [outputChannel] "---- Error output was:\n$errData"
|
||
|
|
puts [outputChannel] "---- Error output should have\
|
||
|
|
been ($match matching):\n$errorOutput"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if {$cleanupFailure} {
|
||
|
|
puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
|
||
|
|
if {[info exists errorInfo(cleanup)]} {
|
||
|
|
puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)"
|
||
|
|
puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if {$coreFailure} {
|
||
|
|
puts [outputChannel] "---- Core file produced while running\
|
||
|
|
test! $coreMsg"
|
||
|
|
}
|
||
|
|
puts [outputChannel] "==== $name FAILED\n"
|
||
|
|
|
||
|
|
incr testLevel -1
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
# Skipped --
|
||
|
|
#
|
||
|
|
# Given a test name and it constraints, returns a boolean indicating
|
||
|
|
# whether the current configuration says the test should be skipped.
|
||
|
|
#
|
||
|
|
# Side Effects: Maintains tally of total tests seen and tests skipped.
|
||
|
|
#
|
||
|
|
proc tcltest::Skipped {name constraints} {
|
||
|
|
variable testLevel
|
||
|
|
variable numTests
|
||
|
|
variable testConstraints
|
||
|
|
|
||
|
|
if {$testLevel == 1} {
|
||
|
|
incr numTests(Total)
|
||
|
|
}
|
||
|
|
# skip the test if it's name matches an element of skip
|
||
|
|
foreach pattern [skip] {
|
||
|
|
if {[string match $pattern $name]} {
|
||
|
|
if {$testLevel == 1} {
|
||
|
|
incr numTests(Skipped)
|
||
|
|
DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
|
||
|
|
}
|
||
|
|
return 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# skip the test if it's name doesn't match any element of match
|
||
|
|
set ok 0
|
||
|
|
foreach pattern [match] {
|
||
|
|
if {[string match $pattern $name]} {
|
||
|
|
set ok 1
|
||
|
|
break
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if {!$ok} {
|
||
|
|
if {$testLevel == 1} {
|
||
|
|
incr numTests(Skipped)
|
||
|
|
DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
|
||
|
|
}
|
||
|
|
return 1
|
||
|
|
}
|
||
|
|
if {$constraints eq {}} {
|
||
|
|
# If we're limited to the listed constraints and there aren't
|
||
|
|
# any listed, then we shouldn't run the test.
|
||
|
|
if {[limitConstraints]} {
|
||
|
|
AddToSkippedBecause userSpecifiedLimitConstraint
|
||
|
|
if {$testLevel == 1} {
|
||
|
|
incr numTests(Skipped)
|
||
|
|
}
|
||
|
|
return 1
|
||
|
|
}
|
||
|
|
} 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 [list expr $constraints]]}
|
||
|
|
} elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
|
||
|
|
# something like {a || b} should be turned into
|
||
|
|
# $testConstraints(a) || $testConstraints(b).
|
||
|
|
regsub -all {[.\w]+} $constraints {$testConstraints(&)} c
|
||
|
|
catch {set doTest [eval [list expr $c]]}
|
||
|
|
} elseif {![catch {llength $constraints}]} {
|
||
|
|
# just simple constraints such as {unixOnly fonts}.
|
||
|
|
set doTest 1
|
||
|
|
foreach constraint $constraints {
|
||
|
|
if {(![info exists testConstraints($constraint)]) \
|
||
|
|
|| (!$testConstraints($constraint))} {
|
||
|
|
set doTest 0
|
||
|
|
|
||
|
|
# store the constraint that kept the test from
|
||
|
|
# running
|
||
|
|
set constraints $constraint
|
||
|
|
break
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if {!$doTest} {
|
||
|
|
if {[IsVerbose skip]} {
|
||
|
|
puts [outputChannel] "++++ $name SKIPPED: $constraints"
|
||
|
|
}
|
||
|
|
|
||
|
|
if {$testLevel == 1} {
|
||
|
|
incr numTests(Skipped)
|
||
|
|
AddToSkippedBecause $constraints
|
||
|
|
}
|
||
|
|
return 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return 0
|
||
|
|
}
|
||
|
|
|
||
|
|
# RunTest --
|
||
|
|
#
|
||
|
|
# This is where the body of a test is evaluated. The combination of
|
||
|
|
# [RunTest] and [Eval] allows the output and error output of the test
|
||
|
|
# body to be captured for comparison against the expected values.
|
||
|
|
|
||
|
|
proc tcltest::RunTest {name script} {
|
||
|
|
DebugPuts 3 "Running $name {$script}"
|
||
|
|
|
||
|
|
# If there is no "memory" command (because memory debugging isn't
|
||
|
|
# enabled), then don't attempt to use the command.
|
||
|
|
|
||
|
|
if {[llength [info commands memory]] == 1} {
|
||
|
|
memory tag $name
|
||
|
|
}
|
||
|
|
|
||
|
|
set code [catch {uplevel 1 $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 {[llength [info commands tcltest::cleanupTestsHook]] == 0} {
|
||
|
|
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}} {
|
||
|
|
variable filesMade
|
||
|
|
variable filesExisted
|
||
|
|
variable createdNewFiles
|
||
|
|
variable testSingleFile
|
||
|
|
variable numTests
|
||
|
|
variable numTestFiles
|
||
|
|
variable failFiles
|
||
|
|
variable skippedBecause
|
||
|
|
variable currentFailure
|
||
|
|
variable originalEnv
|
||
|
|
variable originalTclPlatform
|
||
|
|
variable coreModTime
|
||
|
|
|
||
|
|
FillFilesExisted
|
||
|
|
set testFileName [file tail [info script]]
|
||
|
|
|
||
|
|
# Hook to handle reporting to a parent interpreter
|
||
|
|
if {[llength [info commands [namespace current]::ReportToMaster]]} {
|
||
|
|
ReportToMaster $numTests(Total) $numTests(Passed) $numTests(Skipped) \
|
||
|
|
$numTests(Failed) [array get skippedBecause] \
|
||
|
|
[array get createdNewFiles]
|
||
|
|
set testSingleFile false
|
||
|
|
}
|
||
|
|
|
||
|
|
# Call the cleanup hook
|
||
|
|
cleanupTestsHook
|
||
|
|
|
||
|
|
# Remove files and directories created by the makeFile and
|
||
|
|
# makeDirectory procedures. Record the names of files in
|
||
|
|
# workingDirectory that were not pre-existing, and associate them
|
||
|
|
# with the test file that created them.
|
||
|
|
|
||
|
|
if {!$calledFromAllFile} {
|
||
|
|
foreach file $filesMade {
|
||
|
|
if {[file exists $file]} {
|
||
|
|
DebugDo 1 {Warn "cleanupTests deleting $file..."}
|
||
|
|
catch {file delete -force -- $file}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
set currentFiles {}
|
||
|
|
foreach file [glob -nocomplain \
|
||
|
|
-directory [temporaryDirectory] *] {
|
||
|
|
lappend currentFiles [file tail $file]
|
||
|
|
}
|
||
|
|
set newFiles {}
|
||
|
|
foreach file $currentFiles {
|
||
|
|
if {$file ni $filesExisted} {
|
||
|
|
lappend newFiles $file
|
||
|
|
}
|
||
|
|
}
|
||
|
|
set filesExisted $currentFiles
|
||
|
|
if {[llength $newFiles] > 0} {
|
||
|
|
set createdNewFiles($testFileName) $newFiles
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if {$calledFromAllFile || $testSingleFile} {
|
||
|
|
|
||
|
|
# print stats
|
||
|
|
|
||
|
|
puts -nonewline [outputChannel] "$testFileName:"
|
||
|
|
foreach index [list "Total" "Passed" "Skipped" "Failed"] {
|
||
|
|
puts -nonewline [outputChannel] \
|
||
|
|
"\t$index\t$numTests($index)"
|
||
|
|
}
|
||
|
|
puts [outputChannel] ""
|
||
|
|
|
||
|
|
# print number test files sourced
|
||
|
|
# print names of files that ran tests which failed
|
||
|
|
|
||
|
|
if {$calledFromAllFile} {
|
||
|
|
puts [outputChannel] \
|
||
|
|
"Sourced $numTestFiles Test Files."
|
||
|
|
set numTestFiles 0
|
||
|
|
if {[llength $failFiles] > 0} {
|
||
|
|
puts [outputChannel] \
|
||
|
|
"Files with failing tests: $failFiles"
|
||
|
|
set failFiles {}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# if any tests were skipped, print the constraints that kept
|
||
|
|
# them from running.
|
||
|
|
|
||
|
|
set constraintList [array names skippedBecause]
|
||
|
|
if {[llength $constraintList] > 0} {
|
||
|
|
puts [outputChannel] \
|
||
|
|
"Number of tests skipped for each constraint:"
|
||
|
|
foreach constraint [lsort $constraintList] {
|
||
|
|
puts [outputChannel] \
|
||
|
|
"\t$skippedBecause($constraint)\t$constraint"
|
||
|
|
unset skippedBecause($constraint)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# report the names of test files in createdNewFiles, and reset
|
||
|
|
# the array to be empty.
|
||
|
|
|
||
|
|
set testFilesThatTurded [lsort [array names createdNewFiles]]
|
||
|
|
if {[llength $testFilesThatTurded] > 0} {
|
||
|
|
puts [outputChannel] "Warning: files left behind:"
|
||
|
|
foreach testFile $testFilesThatTurded {
|
||
|
|
puts [outputChannel] \
|
||
|
|
"\t$testFile:\t$createdNewFiles($testFile)"
|
||
|
|
unset createdNewFiles($testFile)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# reset filesMade, filesExisted, and numTests
|
||
|
|
|
||
|
|
set filesMade {}
|
||
|
|
foreach index [list "Total" "Passed" "Skipped" "Failed"] {
|
||
|
|
set numTests($index) 0
|
||
|
|
}
|
||
|
|
|
||
|
|
# exit only if running Tk in non-interactive mode
|
||
|
|
# This should be changed to determine if an event
|
||
|
|
# loop is running, which is the real issue.
|
||
|
|
# Actually, this doesn't belong here at all. A package
|
||
|
|
# really has no business [exit]-ing an application.
|
||
|
|
if {![catch {package present Tk}] && ![testConstraint 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
|
||
|
|
|
||
|
|
if {$currentFailure && ($testFileName ni $failFiles)} {
|
||
|
|
lappend failFiles $testFileName
|
||
|
|
}
|
||
|
|
set 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 originalEnv($index)]} {
|
||
|
|
lappend newEnv $index
|
||
|
|
unset ::env($index)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
foreach index [array names originalEnv] {
|
||
|
|
if {![info exists ::env($index)]} {
|
||
|
|
lappend removedEnv $index
|
||
|
|
set ::env($index) $originalEnv($index)
|
||
|
|
} elseif {$::env($index) ne $originalEnv($index)} {
|
||
|
|
lappend changedEnv $index
|
||
|
|
set ::env($index) $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 originalTclPlatform] {
|
||
|
|
if {$::tcl_platform($index) \
|
||
|
|
!= $originalTclPlatform($index)} {
|
||
|
|
lappend changedTclPlatform $index
|
||
|
|
set ::tcl_platform($index) $originalTclPlatform($index)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if {[llength $changedTclPlatform] > 0} {
|
||
|
|
puts [outputChannel] "tcl_platform array elements\
|
||
|
|
changed:\t$changedTclPlatform"
|
||
|
|
}
|
||
|
|
|
||
|
|
if {[file exists [file join [workingDirectory] core]]} {
|
||
|
|
if {[preserveCore] > 1} {
|
||
|
|
puts "rename core file (> 1)"
|
||
|
|
puts [outputChannel] "produced core file! \
|
||
|
|
Moving file to: \
|
||
|
|
[file join [temporaryDirectory] core-$testFileName]"
|
||
|
|
catch {file rename -force -- \
|
||
|
|
[file join [workingDirectory] core] \
|
||
|
|
[file join [temporaryDirectory] core-$testFileName]
|
||
|
|
} msg
|
||
|
|
if {$msg ne {}} {
|
||
|
|
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 [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
|
||
|
|
|
||
|
|
# a lower case version is needed for compatibility with tcltest 1.0
|
||
|
|
proc tcltest::getMatchingFiles args {GetMatchingFiles {*}$args}
|
||
|
|
|
||
|
|
proc tcltest::GetMatchingFiles { args } {
|
||
|
|
if {[llength $args]} {
|
||
|
|
set dirList $args
|
||
|
|
} else {
|
||
|
|
# Finding tests only in [testsDirectory] is normal operation.
|
||
|
|
# This procedure is written to accept multiple directory arguments
|
||
|
|
# only to satisfy version 1 compatibility.
|
||
|
|
set dirList [list [testsDirectory]]
|
||
|
|
}
|
||
|
|
|
||
|
|
set matchingFiles [list]
|
||
|
|
foreach directory $dirList {
|
||
|
|
|
||
|
|
# List files in $directory that match patterns to run.
|
||
|
|
set matchFileList [list]
|
||
|
|
foreach match [matchFiles] {
|
||
|
|
set matchFileList [concat $matchFileList \
|
||
|
|
[glob -directory $directory -types {b c f p s} \
|
||
|
|
-nocomplain -- $match]]
|
||
|
|
}
|
||
|
|
|
||
|
|
# List files in $directory that match patterns to skip.
|
||
|
|
set skipFileList [list]
|
||
|
|
foreach skip [skipFiles] {
|
||
|
|
set skipFileList [concat $skipFileList \
|
||
|
|
[glob -directory $directory -types {b c f p s} \
|
||
|
|
-nocomplain -- $skip]]
|
||
|
|
}
|
||
|
|
|
||
|
|
# Add to result list all files in match list and not in skip list
|
||
|
|
foreach file $matchFileList {
|
||
|
|
if {$file ni $skipFileList} {
|
||
|
|
lappend matchingFiles $file
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if {[llength $matchingFiles] == 0} {
|
||
|
|
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.
|
||
|
|
#
|
||
|
|
# Side Effects:
|
||
|
|
# None.
|
||
|
|
|
||
|
|
proc tcltest::GetMatchingDirectories {rootdir} {
|
||
|
|
|
||
|
|
# Determine the skip list first, to avoid [glob]-ing over subdirectories
|
||
|
|
# we're going to throw away anyway. Be sure we skip the $rootdir if it
|
||
|
|
# comes up to avoid infinite loops.
|
||
|
|
set skipDirs [list $rootdir]
|
||
|
|
foreach pattern [skipDirectories] {
|
||
|
|
set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \
|
||
|
|
-nocomplain -- $pattern]]
|
||
|
|
}
|
||
|
|
|
||
|
|
# Now step through the matching directories, prune out the skipped ones
|
||
|
|
# as you go.
|
||
|
|
set matchDirs [list]
|
||
|
|
foreach pattern [matchDirectories] {
|
||
|
|
foreach path [glob -directory $rootdir -types d -nocomplain -- \
|
||
|
|
$pattern] {
|
||
|
|
if {$path ni $skipDirs} {
|
||
|
|
set matchDirs [concat $matchDirs [GetMatchingDirectories $path]]
|
||
|
|
if {[file exists [file join $path all.tcl]]} {
|
||
|
|
lappend matchDirs $path
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if {[llength $matchDirs] == 0} {
|
||
|
|
DebugPuts 1 "No test directories remain after applying match\
|
||
|
|
and skip patterns!"
|
||
|
|
}
|
||
|
|
return [lsort $matchDirs]
|
||
|
|
}
|
||
|
|
|
||
|
|
# 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 ""} } {
|
||
|
|
variable testSingleFile
|
||
|
|
variable numTestFiles
|
||
|
|
variable numTests
|
||
|
|
variable failFiles
|
||
|
|
variable DefaultValue
|
||
|
|
|
||
|
|
FillFilesExisted
|
||
|
|
if {[llength [info level 0]] == 1} {
|
||
|
|
set shell [interpreter]
|
||
|
|
}
|
||
|
|
|
||
|
|
set testSingleFile false
|
||
|
|
|
||
|
|
puts [outputChannel] "Tests running in interp: $shell"
|
||
|
|
puts [outputChannel] "Tests located in: [testsDirectory]"
|
||
|
|
puts [outputChannel] "Tests running in: [workingDirectory]"
|
||
|
|
puts [outputChannel] "Temporary files stored in\
|
||
|
|
[temporaryDirectory]"
|
||
|
|
|
||
|
|
# [file system] first available in Tcl 8.4
|
||
|
|
if {![catch {file system [testsDirectory]} result]
|
||
|
|
&& ([lindex $result 0] ne "native")} {
|
||
|
|
# If we aren't running in the native filesystem, then we must
|
||
|
|
# run the tests in a single process (via 'source'), because
|
||
|
|
# trying to run then via a pipe will fail since the files don't
|
||
|
|
# really exist.
|
||
|
|
singleProcess 1
|
||
|
|
}
|
||
|
|
|
||
|
|
if {[singleProcess]} {
|
||
|
|
puts [outputChannel] \
|
||
|
|
"Test files sourced into current interpreter"
|
||
|
|
} else {
|
||
|
|
puts [outputChannel] \
|
||
|
|
"Test files run in separate interpreters"
|
||
|
|
}
|
||
|
|
if {[llength [skip]] > 0} {
|
||
|
|
puts [outputChannel] "Skipping tests that match: [skip]"
|
||
|
|
}
|
||
|
|
puts [outputChannel] "Running tests that match: [match]"
|
||
|
|
|
||
|
|
if {[llength [skipFiles]] > 0} {
|
||
|
|
puts [outputChannel] \
|
||
|
|
"Skipping test files that match: [skipFiles]"
|
||
|
|
}
|
||
|
|
if {[llength [matchFiles]] > 0} {
|
||
|
|
puts [outputChannel] \
|
||
|
|
"Only running test files that match: [matchFiles]"
|
||
|
|
}
|
||
|
|
|
||
|
|
set timeCmd {clock format [clock seconds]}
|
||
|
|
puts [outputChannel] "Tests began at [eval $timeCmd]"
|
||
|
|
|
||
|
|
# Run each of the specified tests
|
||
|
|
foreach file [lsort [GetMatchingFiles]] {
|
||
|
|
set tail [file tail $file]
|
||
|
|
puts [outputChannel] $tail
|
||
|
|
flush [outputChannel]
|
||
|
|
|
||
|
|
if {[singleProcess]} {
|
||
|
|
incr numTestFiles
|
||
|
|
uplevel 1 [list ::source $file]
|
||
|
|
} else {
|
||
|
|
# Pass along our configuration to the child processes.
|
||
|
|
# EXCEPT for the -outfile, because the parent process
|
||
|
|
# needs to read and process output of children.
|
||
|
|
set childargv [list]
|
||
|
|
foreach opt [Configure] {
|
||
|
|
if {$opt eq "-outfile"} {continue}
|
||
|
|
set value [Configure $opt]
|
||
|
|
# Don't bother passing default configuration options
|
||
|
|
if {$value eq $DefaultValue($opt)} {
|
||
|
|
continue
|
||
|
|
}
|
||
|
|
lappend childargv $opt $value
|
||
|
|
}
|
||
|
|
set cmd [linsert $childargv 0 | $shell $file]
|
||
|
|
if {[catch {
|
||
|
|
incr numTestFiles
|
||
|
|
set pipeFd [open $cmd "r"]
|
||
|
|
while {[gets $pipeFd line] >= 0} {
|
||
|
|
if {[regexp [join {
|
||
|
|
{^([^:]+):\t}
|
||
|
|
{Total\t([0-9]+)\t}
|
||
|
|
{Passed\t([0-9]+)\t}
|
||
|
|
{Skipped\t([0-9]+)\t}
|
||
|
|
{Failed\t([0-9]+)}
|
||
|
|
} ""] $line null testFile \
|
||
|
|
Total Passed Skipped Failed]} {
|
||
|
|
foreach index {Total Passed Skipped Failed} {
|
||
|
|
incr numTests($index) [set $index]
|
||
|
|
}
|
||
|
|
if {$Failed > 0} {
|
||
|
|
lappend failFiles $testFile
|
||
|
|
}
|
||
|
|
} elseif {[regexp [join {
|
||
|
|
{^Number of tests skipped }
|
||
|
|
{for each constraint:}
|
||
|
|
{|^\t(\d+)\t(.+)$}
|
||
|
|
} ""] $line match skipped constraint]} {
|
||
|
|
if {[string match \t* $match]} {
|
||
|
|
AddToSkippedBecause $constraint $skipped
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
puts [outputChannel] $line
|
||
|
|
}
|
||
|
|
}
|
||
|
|
close $pipeFd
|
||
|
|
} msg]} {
|
||
|
|
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]"
|
||
|
|
cleanupTests 1
|
||
|
|
if {[info exists testFileFailures]} {
|
||
|
|
puts [outputChannel] "\nTest files exiting with errors: \n"
|
||
|
|
foreach file $testFileFailures {
|
||
|
|
puts [outputChannel] " [file tail $file]\n"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Checking for subdirectories in which to run tests
|
||
|
|
foreach directory [GetMatchingDirectories [testsDirectory]] {
|
||
|
|
set dir [file tail $directory]
|
||
|
|
puts [outputChannel] [string repeat ~ 44]
|
||
|
|
puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
|
||
|
|
|
||
|
|
uplevel 1 [list ::source [file join $directory all.tcl]]
|
||
|
|
|
||
|
|
set endTime [eval $timeCmd]
|
||
|
|
puts [outputChannel] "\n$dir test ended at $endTime"
|
||
|
|
puts [outputChannel] ""
|
||
|
|
puts [outputChannel] [string repeat ~ 44]
|
||
|
|
}
|
||
|
|
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 {} {
|
||
|
|
return [uplevel 1 [loadScript]]
|
||
|
|
}
|
||
|
|
|
||
|
|
# tcltest::saveState --
|
||
|
|
#
|
||
|
|
# Save information regarding what procs and variables exist.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# none
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# Modifies the variable saveState
|
||
|
|
#
|
||
|
|
# Side effects:
|
||
|
|
# None.
|
||
|
|
|
||
|
|
proc tcltest::saveState {} {
|
||
|
|
variable saveState
|
||
|
|
uplevel 1 [list ::set [namespace which -variable saveState]] \
|
||
|
|
{[::list [::info procs] [::info vars]]}
|
||
|
|
DebugPuts 2 "[lindex [info level 0] 0]: $saveState"
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
# tcltest::restoreState --
|
||
|
|
#
|
||
|
|
# Remove procs and variables that didn't exist before the call to
|
||
|
|
# [saveState].
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# none
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# Removes procs and variables from your environment if they don't
|
||
|
|
# exist in the saveState variable.
|
||
|
|
#
|
||
|
|
# Side effects:
|
||
|
|
# None.
|
||
|
|
|
||
|
|
proc tcltest::restoreState {} {
|
||
|
|
variable saveState
|
||
|
|
foreach p [uplevel 1 {::info procs}] {
|
||
|
|
if {($p ni [lindex $saveState 0]) && ("[namespace current]::$p" ne
|
||
|
|
[uplevel 1 [list ::namespace origin $p]])} {
|
||
|
|
|
||
|
|
DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p"
|
||
|
|
uplevel 1 [list ::catch [list ::rename $p {}]]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
foreach p [uplevel 1 {::info vars}] {
|
||
|
|
if {$p ni [lindex $saveState 1]} {
|
||
|
|
DebugPuts 2 "[lindex [info level 0] 0]:\
|
||
|
|
Removing variable $p"
|
||
|
|
uplevel 1 [list ::catch [list ::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
|
||
|
|
set msg [string map [list "\n\n" "\n"] $msg]
|
||
|
|
return [string map [list "\n\}" "\}"] $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 ""}} {
|
||
|
|
variable filesMade
|
||
|
|
FillFilesExisted
|
||
|
|
|
||
|
|
if {[llength [info level 0]] == 3} {
|
||
|
|
set directory [temporaryDirectory]
|
||
|
|
}
|
||
|
|
|
||
|
|
set fullName [file join $directory $name]
|
||
|
|
|
||
|
|
DebugPuts 3 "[lindex [info level 0] 0]:\
|
||
|
|
putting ``$contents'' into $fullName"
|
||
|
|
|
||
|
|
set fd [open $fullName w]
|
||
|
|
chan configure $fd -translation lf
|
||
|
|
if {[string index $contents end] eq "\n"} {
|
||
|
|
puts -nonewline $fd $contents
|
||
|
|
} else {
|
||
|
|
puts $fd $contents
|
||
|
|
}
|
||
|
|
close $fd
|
||
|
|
|
||
|
|
if {$fullName ni $filesMade} {
|
||
|
|
lappend 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 ""}} {
|
||
|
|
variable filesMade
|
||
|
|
FillFilesExisted
|
||
|
|
if {[llength [info level 0]] == 2} {
|
||
|
|
set directory [temporaryDirectory]
|
||
|
|
}
|
||
|
|
set fullName [file join $directory $name]
|
||
|
|
DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
|
||
|
|
set idx [lsearch -exact $filesMade $fullName]
|
||
|
|
set filesMade [lreplace $filesMade $idx $idx]
|
||
|
|
if {$idx == -1} {
|
||
|
|
DebugDo 1 {
|
||
|
|
Warn "removeFile removing \"$fullName\":\n not created by makeFile"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if {![file isfile $fullName]} {
|
||
|
|
DebugDo 1 {
|
||
|
|
Warn "removeFile removing \"$fullName\":\n not a file"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
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 ""}} {
|
||
|
|
variable filesMade
|
||
|
|
FillFilesExisted
|
||
|
|
if {[llength [info level 0]] == 2} {
|
||
|
|
set directory [temporaryDirectory]
|
||
|
|
}
|
||
|
|
set fullName [file join $directory $name]
|
||
|
|
DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
|
||
|
|
file mkdir $fullName
|
||
|
|
if {$fullName ni $filesMade} {
|
||
|
|
lappend 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 ""}} {
|
||
|
|
variable filesMade
|
||
|
|
FillFilesExisted
|
||
|
|
if {[llength [info level 0]] == 2} {
|
||
|
|
set directory [temporaryDirectory]
|
||
|
|
}
|
||
|
|
set fullName [file join $directory $name]
|
||
|
|
DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
|
||
|
|
set idx [lsearch -exact $filesMade $fullName]
|
||
|
|
set filesMade [lreplace $filesMade $idx $idx]
|
||
|
|
if {$idx == -1} {
|
||
|
|
DebugDo 1 {
|
||
|
|
Warn "removeDirectory removing \"$fullName\":\n not created\
|
||
|
|
by makeDirectory"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if {![file isdirectory $fullName]} {
|
||
|
|
DebugDo 1 {
|
||
|
|
Warn "removeDirectory removing \"$fullName\":\n not a directory"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
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 ""}} {
|
||
|
|
FillFilesExisted
|
||
|
|
if {[llength [info level 0]] == 2} {
|
||
|
|
set directory [temporaryDirectory]
|
||
|
|
}
|
||
|
|
set fullName [file join $directory $name]
|
||
|
|
set f [open $fullName]
|
||
|
|
set data [read -nonewline $f]
|
||
|
|
close $f
|
||
|
|
return $data
|
||
|
|
}
|
||
|
|
|
||
|
|
# 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 {$p ni $old} {
|
||
|
|
lappend leak $p
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $leak
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Internationalization / ISO support procs -- dl
|
||
|
|
#
|
||
|
|
|
||
|
|
# tcltest::SetIso8859_1_Locale --
|
||
|
|
#
|
||
|
|
# used in cmdIL.test, uses testlocale
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# None.
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# None.
|
||
|
|
#
|
||
|
|
# Side effects:
|
||
|
|
# None.
|
||
|
|
|
||
|
|
proc tcltest::SetIso8859_1_Locale {} {
|
||
|
|
variable previousLocale
|
||
|
|
variable isoLocale
|
||
|
|
if {[info commands testlocale] != ""} {
|
||
|
|
set previousLocale [testlocale ctype]
|
||
|
|
testlocale ctype $isoLocale
|
||
|
|
}
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
# tcltest::RestoreLocale --
|
||
|
|
#
|
||
|
|
# used in cmdIL.test, uses testlocale
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# None.
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# None.
|
||
|
|
#
|
||
|
|
# Side effects:
|
||
|
|
# None.
|
||
|
|
|
||
|
|
proc tcltest::RestoreLocale {} {
|
||
|
|
variable previousLocale
|
||
|
|
if {[info commands testlocale] != ""} {
|
||
|
|
testlocale ctype $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] ne {}} {
|
||
|
|
|
||
|
|
# testthread built into tcltest
|
||
|
|
|
||
|
|
testthread errorproc ThreadNullError
|
||
|
|
while {[llength [testthread names]] > 1} {
|
||
|
|
foreach tid [testthread names] {
|
||
|
|
if {$tid != [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] ne {}} {
|
||
|
|
|
||
|
|
# Thread extension
|
||
|
|
|
||
|
|
thread::errorproc ThreadNullError
|
||
|
|
while {[llength [thread::names]] > 1} {
|
||
|
|
foreach tid [thread::names] {
|
||
|
|
if {$tid != [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 {
|
||
|
|
# Define initializers for all the built-in contraint definitions
|
||
|
|
DefineConstraintInitializers
|
||
|
|
|
||
|
|
# Set up the constraints in the testConstraints array to be lazily
|
||
|
|
# initialized by a registered initializer, or by "false" if no
|
||
|
|
# initializer is registered.
|
||
|
|
trace add variable testConstraints read [namespace code SafeFetch]
|
||
|
|
|
||
|
|
# Only initialize constraints at package load time if an
|
||
|
|
# [initConstraintsHook] has been pre-defined. This is only
|
||
|
|
# for compatibility support. The modern way to add a custom
|
||
|
|
# test constraint is to just call the [testConstraint] command
|
||
|
|
# straight away, without all this "hook" nonsense.
|
||
|
|
if {[namespace current] eq
|
||
|
|
[namespace qualifiers [namespace which initConstraintsHook]]} {
|
||
|
|
InitConstraints
|
||
|
|
} else {
|
||
|
|
proc initConstraintsHook {} {}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Define the standard match commands
|
||
|
|
customMatch exact [list string equal]
|
||
|
|
customMatch glob [list string match]
|
||
|
|
customMatch regexp [list regexp --]
|
||
|
|
|
||
|
|
# If the TCLTEST_OPTIONS environment variable exists, configure
|
||
|
|
# tcltest according to the option values it specifies. This has
|
||
|
|
# the effect of resetting tcltest's default configuration.
|
||
|
|
proc ConfigureFromEnvironment {} {
|
||
|
|
upvar #0 env(TCLTEST_OPTIONS) options
|
||
|
|
if {[catch {llength $options} msg]} {
|
||
|
|
Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\
|
||
|
|
Tcl list: $msg"
|
||
|
|
return
|
||
|
|
}
|
||
|
|
if {[llength $options] % 2} {
|
||
|
|
Warn "invalid TCLTEST_OPTIONS: \"$options\":\n should be\
|
||
|
|
-option value ?-option value ...?"
|
||
|
|
return
|
||
|
|
}
|
||
|
|
if {[catch {Configure {*}$options} msg]} {
|
||
|
|
Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg"
|
||
|
|
return
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if {[info exists ::env(TCLTEST_OPTIONS)]} {
|
||
|
|
ConfigureFromEnvironment
|
||
|
|
}
|
||
|
|
|
||
|
|
proc LoadTimeCmdLineArgParsingRequired {} {
|
||
|
|
set required false
|
||
|
|
if {[info exists ::argv] && ("-help" in $::argv)} {
|
||
|
|
# The command line asks for -help, so give it (and exit)
|
||
|
|
# right now. ([configure] does not process -help)
|
||
|
|
set required true
|
||
|
|
}
|
||
|
|
foreach hook { PrintUsageInfoHook processCmdLineArgsHook
|
||
|
|
processCmdLineArgsAddFlagsHook } {
|
||
|
|
if {[namespace current] eq
|
||
|
|
[namespace qualifiers [namespace which $hook]]} {
|
||
|
|
set required true
|
||
|
|
} else {
|
||
|
|
proc $hook args {}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $required
|
||
|
|
}
|
||
|
|
|
||
|
|
# Only initialize configurable options from the command line arguments
|
||
|
|
# at package load time if necessary for backward compatibility. This
|
||
|
|
# lets the tcltest user call [configure] for themselves if they wish.
|
||
|
|
# Traces are established for auto-configuration from the command line
|
||
|
|
# if any configurable options are accessed before the user calls
|
||
|
|
# [configure].
|
||
|
|
if {[LoadTimeCmdLineArgParsingRequired]} {
|
||
|
|
ProcessCmdLineArgs
|
||
|
|
} else {
|
||
|
|
EstablishAutoConfigureTraces
|
||
|
|
}
|
||
|
|
|
||
|
|
package provide [namespace tail [namespace current]] $Version
|
||
|
|
}
|