From 17f0c7e5e769d24f08d643c68bf82da3a7cabd04 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 8 Aug 2001 03:38:03 +0000 Subject: BRANCH: core-8-3-1-branch Removed library/tcltest/* . The package tcltest 1.0 is distributed with Tcl 8.3.x and its files are in library/tcltest1.0 . FossilOrigin-Name: d451d9e8bbd5632051c981549fba028542e3b675 --- library/tcltest/pkgIndex.tcl | 18 - library/tcltest/tcltest.tcl | 1905 ------------------------------------------ 2 files changed, 1923 deletions(-) delete mode 100644 library/tcltest/pkgIndex.tcl delete mode 100644 library/tcltest/tcltest.tcl diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl deleted file mode 100644 index 7a58882..0000000 --- a/library/tcltest/pkgIndex.tcl +++ /dev/null @@ -1,18 +0,0 @@ -# Tcl package index file, version 1.1 -# This file is generated by the "pkg_mkIndex" command -# and sourced either when an application starts up or -# by a "package unknown" script. It invokes the -# "package ifneeded" command to set up package-related -# information so that packages will be loaded automatically -# in response to "package require" commands. When this -# script is sourced, the variable $dir must contain the -# full path name of this file's directory. - -package ifneeded tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 \ - {{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests \ - ::tcltest::makeDirectory ::tcltest::makeFile ::tcltest::normalizeMsg \ - ::tcltest::removeDirectory ::tcltest::removeFile \ - ::tcltest::restoreState ::tcltest::saveState ::tcltest::test \ - ::tcltest::threadReap ::tcltest::viewFile ::tcltest::grep \ - ::tcltest::getMatchingFiles ::tcltest::loadTestedCommands \ - ::tcltest::normalizePath }}}] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl deleted file mode 100644 index 5898cf6..0000000 --- a/library/tcltest/tcltest.tcl +++ /dev/null @@ -1,1905 +0,0 @@ -# tcltest.tcl -- -# -# This file contains support code for the Tcl test suite. It -# defines the ::tcltest namespace and finds and defines the output -# directory, constraints available, output and error channels, etc. used -# by Tcl tests. See the tcltest man page for more details. -# -# This design was based on the Tcl testing approach designed and -# initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. -# -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. -# -# RCS: @(#) $Id: tcltest.tcl,v 1.24 2000/04/11 01:04:19 welch Exp $ - -package provide tcltest 1.0 - -# create the "tcltest" namespace for all testing variables and procedures - -namespace eval tcltest { - - # Export the public tcltest procs - set procList [list test cleanupTests saveState restoreState \ - normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile bytestring safeFetch threadReap getMatchingFiles \ - loadTestedCommands normalizePath] - foreach proc $procList { - namespace export $proc - } - - # ::tcltest::verbose defaults to "b" - if {![info exists verbose]} { - variable verbose "b" - } - - # Match and skip patterns default to the empty list, except for - # matchFiles, which defaults to all .test files in the testsDirectory - - if {![info exists match]} { - variable match {} - } - if {![info exists skip]} { - variable skip {} - } - if {![info exists matchFiles]} { - variable matchFiles {*.test} - } - if {![info exists skipFiles]} { - variable skipFiles {} - } - - # By default, don't save core files - if {![info exists preserveCore]} { - variable preserveCore 0 - } - - # output goes to stdout by default - if {![info exists outputChannel]} { - variable outputChannel stdout - } - - # errors go to stderr by default - if {![info exists errorChannel]} { - variable errorChannel stderr - } - - # debug output doesn't get printed by default; debug level 1 spits - # up only the tests that were skipped because they didn't match or were - # specifically skipped. A debug level of 2 would spit up the tcltest - # variables and flags provided; a debug level of 3 causes some additional - # output regarding operations of the test harness. The tcltest package - # currently implements only up to debug level 3. - if {![info exists debug]} { - variable debug 0 - } - - # Save any arguments that we might want to pass through to other programs. - # This is used by the -args flag. - if {![info exists parameters]} { - variable parameters {} - } - - # Count the number of files tested (0 if all.tcl wasn't called). - # The all.tcl file will set testSingleFile to false, so stats will - # not be printed until all.tcl calls the cleanupTests proc. - # The currentFailure var stores the boolean value of whether the - # current test file has had any failures. The failFiles list - # stores the names of test files that had failures. - - if {![info exists numTestFiles]} { - variable numTestFiles 0 - } - if {![info exists testSingleFile]} { - variable testSingleFile true - } - if {![info exists currentFailure]} { - variable currentFailure false - } - if {![info exists failFiles]} { - variable failFiles {} - } - - # Tests should remove all files they create. The test suite will - # check the current working dir for files created by the tests. - # ::tcltest::filesMade keeps track of such files created using the - # ::tcltest::makeFile and ::tcltest::makeDirectory procedures. - # ::tcltest::filesExisted stores the names of pre-existing files. - - if {![info exists filesMade]} { - variable filesMade {} - } - if {![info exists filesExisted]} { - variable filesExisted {} - } - - # ::tcltest::numTests will store test files as indices and the list - # of files (that should not have been) left behind by the test files. - - if {![info exists createdNewFiles]} { - variable createdNewFiles - array set ::tcltest::createdNewFiles {} - } - - # initialize ::tcltest::numTests array to keep track fo the number of - # tests that pass, fail, and are skipped. - - if {![info exists numTests]} { - variable numTests - array set ::tcltest::numTests \ - [list Total 0 Passed 0 Skipped 0 Failed 0] - } - - # initialize ::tcltest::skippedBecause array to keep track of - # constraints that kept tests from running; a constraint name of - # "userSpecifiedSkip" means that the test appeared on the list of tests - # that matched the -skip value given to the flag; "userSpecifiedNonMatch" - # means that the test didn't match the argument given to the -match flag; - # both of these constraints are counted only if ::tcltest::debug is set to - # true. - - if {![info exists skippedBecause]} { - variable skippedBecause - array set ::tcltest::skippedBecause {} - } - - # initialize the ::tcltest::testConstraints array to keep track of valid - # predefined constraints (see the explanation for the - # ::tcltest::initConstraints proc for more details). - - if {![info exists testConstraints]} { - variable testConstraints - array set ::tcltest::testConstraints {} - } - - # Don't run only the constrained tests by default - - if {![info exists limitConstraints]} { - variable limitConstraints false - } - - # A test application has to know how to load the tested commands into - # the interpreter. - - if {![info exists loadScript]} { - variable loadScript {} - } - - # tests that use threads need to know which is the main thread - - if {![info exists mainThread]} { - variable mainThread 1 - if {[info commands thread::id] != {}} { - set mainThread [thread::id] - } elseif {[info commands testthread] != {}} { - set mainThread [testthread id] - } - } - - # save the original environment so that it can be restored later - - if {![info exists originalEnv]} { - variable originalEnv - array set ::tcltest::originalEnv [array get ::env] - } - - # Set ::tcltest::workingDirectory to [pwd]. The default output directory - # for Tcl tests is the working directory. - - if {![info exists workingDirectory]} { - variable workingDirectory [pwd] - } - if {![info exists temporaryDirectory]} { - variable temporaryDirectory $workingDirectory - } - - # Tests should not rely on the current working directory. - # Files that are part of the test suite should be accessed relative to - # ::tcltest::testsDirectory. - - if {![info exists testsDirectory]} { - set oldpwd [pwd] - catch {cd [file join [file dirname [info script]] .. .. tests]} - variable testsDirectory [pwd] - cd $oldpwd - unset oldpwd - } - - # the variables and procs that existed when ::tcltest::saveState was - # called are stored in a variable of the same name - if {![info exists saveState]} { - variable saveState {} - } - - # Internationalization support - if {![info exists isoLocale]} { - variable isoLocale fr - switch $tcl_platform(platform) { - "unix" { - - # Try some 'known' values for some platforms: - - switch -exact -- $tcl_platform(os) { - "FreeBSD" { - set ::tcltest::isoLocale fr_FR.ISO_8859-1 - } - HP-UX { - set ::tcltest::isoLocale fr_FR.iso88591 - } - Linux - - IRIX { - set ::tcltest::isoLocale fr - } - default { - - # Works on SunOS 4 and Solaris, and maybe others... - # define it to something else on your system - #if you want to test those. - - set ::tcltest::isoLocale iso_8859_1 - } - } - } - "windows" { - set ::tcltest::isoLocale French - } - } - } - - # Set the location of the execuatble - if {![info exists tcltest]} { - variable tcltest [info nameofexecutable] - } - - # save the platform information so it can be restored later - if {![info exists originalTclPlatform]} { - variable originalTclPlatform [array get tcl_platform] - } - - # If a core file exists, save its modification time. - if {![info exists coreModificationTime]} { - if {[file exists [file join $::tcltest::workingDirectory core]]} { - variable coreModificationTime [file mtime [file join \ - $::tcltest::workingDirectory core]] - } - } - - # Tcl version numbers - if {![info exists version]} { - variable version 8.3 - } - if {![info exists patchLevel]} { - variable patchLevel 8.3.0 - } -} - -# ::tcltest::Debug* -- -# -# Internal helper procedures to write out debug information -# dependent on the chosen level. A test shell may overide -# them, f.e. to redirect the output into a different -# channel, or even into a GUI. - -# ::tcltest::DebugPuts -- -# -# Prints the specified string if the current debug level is -# higher than the provided level argument. -# -# Arguments: -# level The lowest debug level triggering the output -# string The string to print out. -# -# Results: -# Prints the string. Nothing else is allowed. -# - -proc ::tcltest::DebugPuts {level string} { - variable debug - if {$debug >= $level} { - puts $string - } -} - -# ::tcltest::DebugPArray -- -# -# Prints the contents of the specified array if the current -# debug level is higher than the provided level argument -# -# Arguments: -# level The lowest debug level triggering the output -# arrayvar The name of the array to print out. -# -# Results: -# Prints the contents of the array. Nothing else is allowed. -# - -proc ::tcltest::DebugPArray {level arrayvar} { - variable debug - - if {$debug >= $level} { - catch {upvar $arrayvar $arrayvar} - parray $arrayvar - } -} - -# ::tcltest::DebugDo -- -# -# Executes the script if the current debug level is greater than -# the provided level argument -# -# Arguments: -# level The lowest debug level triggering the execution. -# script The tcl script executed upon a debug level high enough. -# -# Results: -# Arbitrary side effects, dependent on the executed script. -# - -proc ::tcltest::DebugDo {level script} { - variable debug - - if {$debug >= $level} { - uplevel $script - } -} - -# ::tcltest::AddToSkippedBecause -- -# -# Increments the variable used to track how many tests were skipped -# because of a particular constraint. -# -# Arguments: -# constraint The name of the constraint to be modified -# -# Results: -# Modifies ::tcltest::skippedBecause; sets the variable to 1 if didn't -# previously exist - otherwise, it just increments it. - -proc ::tcltest::AddToSkippedBecause { constraint } { - # add the constraint to the list of constraints that kept tests - # from running - - if {[info exists ::tcltest::skippedBecause($constraint)]} { - incr ::tcltest::skippedBecause($constraint) - } else { - set ::tcltest::skippedBecause($constraint) 1 - } - return -} - -# ::tcltest::PrintError -- -# -# Prints errors to ::tcltest::errorChannel and then flushes that -# channel, making sure that all messages are < 80 characters per line. -# -# Arguments: -# errorMsg String containing the error to be printed -# - -proc ::tcltest::PrintError {errorMsg} { - set InitialMessage "Error: " - set InitialMsgLen [string length $InitialMessage] - puts -nonewline $::tcltest::errorChannel $InitialMessage - - # Keep track of where the end of the string is. - set endingIndex [string length $errorMsg] - - if {$endingIndex < 80} { - puts $::tcltest::errorChannel $errorMsg - } else { - # Print up to 80 characters on the first line, including the - # InitialMessage. - set beginningIndex [string last " " [string range $errorMsg 0 \ - [expr {80 - $InitialMsgLen}]]] - puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex] - - while {$beginningIndex != "end"} { - puts -nonewline $::tcltest::errorChannel \ - [string repeat " " $InitialMsgLen] - if {[expr {$endingIndex - $beginningIndex}] < 72} { - puts $::tcltest::errorChannel [string trim \ - [string range $errorMsg $beginningIndex end]] - set beginningIndex end - } else { - set newEndingIndex [expr [string last " " [string range \ - $errorMsg $beginningIndex \ - [expr {$beginningIndex + 72}]]] + $beginningIndex] - if {($newEndingIndex <= 0) \ - || ($newEndingIndex <= $beginningIndex)} { - set newEndingIndex end - } - puts $::tcltest::errorChannel [string trim \ - [string range $errorMsg \ - $beginningIndex $newEndingIndex]] - set beginningIndex $newEndingIndex - } - } - } - flush $::tcltest::errorChannel - return -} - -if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} { - proc ::tcltest::initConstraintsHook {} {} -} - -# ::tcltest::initConstraints -- -# -# Check Constraintsuration information that will determine which tests -# to run. To do this, create an array ::tcltest::testConstraints. Each -# element has a 0 or 1 value. If the element is "true" then tests -# with that constraint will be run, otherwise tests with that constraint -# will be skipped. See the tcltest man page for the list of built-in -# constraints defined in this procedure. -# -# Arguments: -# none -# -# Results: -# The ::tcltest::testConstraints array is reset to have an index for -# each built-in test constraint. - -proc ::tcltest::initConstraints {} { - global tcl_platform tcl_interactive tk_version - - # The following trace procedure makes it so that we can safely refer to - # non-existent members of the ::tcltest::testConstraints array without - # causing an error. Instead, reading a non-existent member will return 0. - # This is necessary because tests are allowed to use constraint "X" without - # ensuring that ::tcltest::testConstraints("X") is defined. - - trace variable ::tcltest::testConstraints r ::tcltest::safeFetch - - proc ::tcltest::safeFetch {n1 n2 op} { - if {($n2 != {}) && ([info exists ::tcltest::testConstraints($n2)] == 0)} { - set ::tcltest::testConstraints($n2) 0 - } - } - - ::tcltest::initConstraintsHook - - set ::tcltest::testConstraints(unixOnly) \ - [string equal $tcl_platform(platform) "unix"] - set ::tcltest::testConstraints(macOnly) \ - [string equal $tcl_platform(platform) "macintosh"] - set ::tcltest::testConstraints(pcOnly) \ - [string equal $tcl_platform(platform) "windows"] - - set ::tcltest::testConstraints(unix) $::tcltest::testConstraints(unixOnly) - set ::tcltest::testConstraints(mac) $::tcltest::testConstraints(macOnly) - set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly) - - set ::tcltest::testConstraints(unixOrPc) \ - [expr {$::tcltest::testConstraints(unix) \ - || $::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macOrPc) \ - [expr {$::tcltest::testConstraints(mac) \ - || $::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macOrUnix) \ - [expr {$::tcltest::testConstraints(mac) \ - || $::tcltest::testConstraints(unix)}] - - set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \ - "Windows NT"] - set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) \ - "Windows 95"] - set ::tcltest::testConstraints(98) [string equal $tcl_platform(os) \ - "Windows 98"] - - # The following Constraints switches are used to mark tests that should - # work, but have been temporarily disabled on certain platforms because - # they don't and we haven't gotten around to fixing the underlying - # problem. - - set ::tcltest::testConstraints(tempNotPc) \ - [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(tempNotMac) \ - [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(tempNotUnix) \ - [expr {!$::tcltest::testConstraints(unix)}] - - # The following Constraints switches are used to mark tests that crash on - # certain platforms, so that they can be reactivated again when the - # underlying problem is fixed. - - set ::tcltest::testConstraints(pcCrash) \ - [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macCrash) \ - [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(unixCrash) \ - [expr {!$::tcltest::testConstraints(unix)}] - - # Skip empty tests - - set ::tcltest::testConstraints(emptyTest) 0 - - # By default, tests that expose known bugs are skipped. - - set ::tcltest::testConstraints(knownBug) 0 - - # By default, non-portable tests are skipped. - - set ::tcltest::testConstraints(nonPortable) 0 - - # Some tests require user interaction. - - set ::tcltest::testConstraints(userInteraction) 0 - - # Some tests must be skipped if the interpreter is not in interactive mode - - if {[info exists tcl_interactive]} { - set ::tcltest::testConstraints(interactive) $::tcl_interactive - } else { - set ::tcltest::testConstraints(interactive) 0 - } - - # Some tests can only be run if the installation came from a CD image - # instead of a web image - # Some tests must be skipped if you are running as root on Unix. - # Other tests can only be run if you are running as root on Unix. - - set ::tcltest::testConstraints(root) 0 - set ::tcltest::testConstraints(notRoot) 1 - set user {} - if {[string equal $tcl_platform(platform) "unix"]} { - catch {set user [exec whoami]} - if {[string equal $user ""]} { - catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} - } - if {([string equal $user "root"]) || ([string equal $user ""])} { - set ::tcltest::testConstraints(root) 1 - set ::tcltest::testConstraints(notRoot) 0 - } - } - - # Set nonBlockFiles constraint: 1 means this platform supports - # setting files into nonblocking mode. - - if {[catch {set f [open defs r]}]} { - set ::tcltest::testConstraints(nonBlockFiles) 1 - } else { - if {[catch {fconfigure $f -blocking off}] == 0} { - set ::tcltest::testConstraints(nonBlockFiles) 1 - } else { - set ::tcltest::testConstraints(nonBlockFiles) 0 - } - close $f - } - - # Set asyncPipeClose constraint: 1 means this platform supports - # async flush and async close on a pipe. - # - # Test for SCO Unix - cannot run async flushing tests because a - # potential problem with select is apparently interfering. - # (Mark Diekhans). - - if {[string equal $tcl_platform(platform) "unix"]} { - if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { - set ::tcltest::testConstraints(asyncPipeClose) 0 - } else { - set ::tcltest::testConstraints(asyncPipeClose) 1 - } - } else { - set ::tcltest::testConstraints(asyncPipeClose) 1 - } - - # Test to see if we have a broken version of sprintf with respect - # to the "e" format of floating-point numbers. - - set ::tcltest::testConstraints(eformat) 1 - if {![string equal "[format %g 5e-5]" "5e-05"]} { - set ::tcltest::testConstraints(eformat) 0 - } - - # Test to see if execed commands such as cat, echo, rm and so forth are - # present on this machine. - - set ::tcltest::testConstraints(unixExecs) 1 - if {[string equal $tcl_platform(platform) "macintosh"]} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([string equal $tcl_platform(platform) "windows"])} { - if {[catch {exec cat defs}] == 1} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec echo hello}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec sh -c echo hello}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec wc defs}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {$::tcltest::testConstraints(unixExecs) == 1} { - exec echo hello > removeMe - if {[catch {exec rm removeMe}] == 1} { - set ::tcltest::testConstraints(unixExecs) 0 - } - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec sleep 1}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec fgrep unixExecs defs}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec ps}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec echo abc > removeMe}] == 0) && \ - ([catch {exec chmod 644 removeMe}] == 1) && \ - ([catch {exec rm removeMe}] == 0)} { - set ::tcltest::testConstraints(unixExecs) 0 - } else { - catch {exec rm -f removeMe} - } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ - ([catch {exec mkdir removeMe}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 - } else { - catch {exec rm -r removeMe} - } - } - - # Locate tcltest executable - - if {![info exists tk_version]} { - set tcltest [info nameofexecutable] - - if {$tcltest == "{}"} { - set tcltest {} - } - } - - set ::tcltest::testConstraints(stdio) 0 - catch { - catch {file delete -force tmp} - set f [open tmp w] - puts $f { - exit - } - close $f - - set f [open "|[list $tcltest tmp]" r] - close $f - - set ::tcltest::testConstraints(stdio) 1 - } - catch {file delete -force tmp} - - # Deliberately call socket with the wrong number of arguments. The error - # message you get will indicate whether sockets are available on this - # system. - - catch {socket} msg - set ::tcltest::testConstraints(socket) \ - [expr {$msg != "sockets are not available on this system"}] - - # Check for internationalization - - if {[info commands testlocale] == ""} { - # No testlocale command, no tests... - set ::tcltest::testConstraints(hasIsoLocale) 0 - } else { - set ::tcltest::testConstraints(hasIsoLocale) \ - [string length [::tcltest::set_iso8859_1_locale]] - ::tcltest::restore_locale - } -} - -# ::tcltest::PrintUsageInfoHook -# -# Hook used for customization of display of usage information. -# - -if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} { - proc ::tcltest::PrintUsageInfoHook {} {} -} - -# ::tcltest::PrintUsageInfo -# -# Prints out the usage information for package tcltest. This can be -# customized with the redefinition of ::tcltest::PrintUsageInfoHook. -# -# Arguments: -# none -# - -proc ::tcltest::PrintUsageInfo {} { - puts [format "Usage: [file tail [info nameofexecutable]] \ - script ?-help? ?flag value? ... \n\ - Available flags (and valid input values) are: \n\ - -help \t Display this usage information. \n\ - -verbose level \t Takes any combination of the values \n\ - \t 'p', 's' and 'b'. Test suite will \n\ - \t display all passed tests if 'p' is \n\ - \t specified, all skipped tests if 's' \n\ - \t is specified, and the bodies of \n\ - \t failed tests if 'b' is specified. \n\ - \t The default value is 'b'. \n\ - -constraints list\t Do not skip the listed constraints\n\ - -limitconstraints bool\t Only run tests with the constraints\n\ - \t listed in -constraints.\n\ - -match pattern \t Run all tests within the specified \n\ - \t files that match the glob pattern \n\ - \t given. \n\ - -skip pattern \t Skip all tests within the set of \n\ - \t specified tests (via -match) and \n\ - \t files that match the glob pattern \n\ - \t given. \n\ - -file pattern \t Run tests in all test files that \n\ - \t match the glob pattern given. \n\ - -notfile pattern\t Skip all test files that match the \n\ - \t glob pattern given. \n\ - -preservecore level \t If 2, save any core files produced \n\ - \t during testing in the directory \n\ - \t specified by -tmpdir. If 1, notify the\n\ - \t user if core files are created. The default \n\ - \t is $::tcltest::preserveCore. \n\ - -tmpdir directory\t Save temporary files in the specified\n\ - \t directory. The default value is \n\ - \t $::tcltest::temporaryDirectory. \n\ - -testdir directories\t Search tests in the specified\n\ - \t directories. The default value is \n\ - \t $::tcltest::testsDirectory. \n\ - -outfile file \t Send output from test runs to the \n\ - \t specified file. The default is \n\ - \t stdout. \n\ - -errfile file \t Send errors from test runs to the \n\ - \t specified file. The default is \n\ - \t stderr. \n\ - -loadfile file \t Read the script to load the tested \n\ - \t commands from the specified file. \n\ - -load script \t Specifies the script to load the tested \n\ - \t commands. \n\ - -debug level \t Internal debug flag."] - ::tcltest::PrintUsageInfoHook - return -} - -# ::tcltest::CheckDirectory -- -# -# This procedure checks whether the specified path is a readable -# and/or writable directory. If one of the conditions is not -# satisfied an error is printed and the application aborted. The -# procedure assumes that the caller already checked the existence -# of the path. -# -# Arguments -# rw Information what attributes to check. Allowed values: -# r, w, rw, wr. If 'r' is part of the value the directory -# must be readable. 'w' associates to 'writable'. -# dir The directory to check. -# errMsg The string to prepend to the actual error message before -# printing it. -# -# Results -# none -# - -proc ::tcltest::CheckDirectory {rw dir errMsg} { - # Allowed values for 'rw': r, w, rw, wr - - if {![file isdir $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not a directory" - exit 1 - } elseif {([string first w $rw] >= 0) && ![file writable $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not writeable" - exit 1 - } elseif {([string first r $rw] >= 0) && ![file readable $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not readable" - exit 1 - } -} - -# ::tcltest::normalizePath -- -# -# This procedure resolves any symlinks in the path thus creating a -# path without internal redirection. It assumes that the incoming -# path is absolute. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# -# Results -# The path is modified in place. -# - -proc ::tcltest::normalizePath {pathVar} { - upvar $pathVar path - - set oldpwd [pwd] - catch {cd $path} - set path [pwd] - cd $oldpwd -} - -# ::tcltest::MakeAbsolutePath -- -# -# This procedure checks whether the incoming path is absolute or not. -# Makes it absolute if it was not. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# prefix is optional, contains the path to use to make the other an -# absolute one. The current working directory is used if it was -# not specified. -# -# Results -# The path is modified in place. -# - -proc ::tcltest::MakeAbsolutePath {pathVar {prefix {}}} { - upvar $pathVar path - - if {![string equal [file pathtype $path] "absolute"]} { - if {$prefix == {}} { - set prefix [pwd] - } - - set path [file join $prefix $path] - } -} - -# ::tcltest::processCmdLineArgsFlagsHook -- -# -# This hook is used to add to the list of command line arguments that are -# processed by ::tcltest::processCmdLineArgs. -# - -if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { - proc ::tcltest::processCmdLineArgsAddFlagsHook {} {} -} - -# ::tcltest::processCmdLineArgsHook -- -# -# This hook is used to actually process the flags added by -# ::tcltest::processCmdLineArgsAddFlagsHook. -# -# Arguments: -# flags The flags that have been pulled out of argv -# - -if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} { - proc ::tcltest::processCmdLineArgsHook {flag} {} -} - -# ::tcltest::processCmdLineArgs -- -# -# Use command line args to set the verbose, skip, and -# match, outputChannel, errorChannel, debug, and temporaryDirectory -# variables. -# -# This procedure must be run after constraints are initialized, because -# some constraints can be overridden. -# -# Arguments: -# none -# -# Results: -# Sets the above-named variables in the tcltest namespace. - -proc ::tcltest::processCmdLineArgs {} { - global argv - - # The "argv" var doesn't exist in some cases, so use {}. - - if {(![info exists argv]) || ([llength $argv] < 1)} { - set flagArray {} - } else { - set flagArray $argv - } - - # Allow for 1-char abbreviations, where applicable (e.g., -match == -m). - # Note that -verbose cannot be abbreviated to -v in wish because it - # conflicts with the wish option -visual. - - # Process -help first - if {([lsearch -exact $flagArray {-help}] != -1) || \ - ([lsearch -exact $flagArray {-h}] != -1)} { - ::tcltest::PrintUsageInfo - exit 1 - } - - if {[catch {array set flag $flagArray}]} { - ::tcltest::PrintError "odd number of arguments specified on command line: \ - $argv" - ::tcltest::PrintUsageInfo - exit 1 - } - - # -help is not listed since it has already been processed - lappend defaultFlags -verbose -match -skip -constraints \ - -outfile -errfile -debug -tmpdir -file -notfile \ - -preservecore -limitconstraints -args -testdir \ - -load -loadfile - set defaultFlags [concat $defaultFlags \ - [ ::tcltest::processCmdLineArgsAddFlagsHook ]] - - foreach arg $defaultFlags { - set abbrev [string range $arg 0 1] - if {([info exists flag($abbrev)]) && \ - ([lsearch -exact $flagArray $arg] < [lsearch -exact \ - $flagArray $abbrev])} { - set flag($arg) $flag($abbrev) - } - } - - # Set ::tcltest::parameters to the arg of the -args flag, if given - if {[info exists flag(-args)]} { - set ::tcltest::parameters $flag(-args) - } - - # Set ::tcltest::verbose to the arg of the -verbose flag, if given - - if {[info exists flag(-verbose)]} { - set ::tcltest::verbose $flag(-verbose) - } - - # Set ::tcltest::match to the arg of the -match flag, if given. - - if {[info exists flag(-match)]} { - set ::tcltest::match $flag(-match) - } - - # Set ::tcltest::skip to the arg of the -skip flag, if given - - if {[info exists flag(-skip)]} { - set ::tcltest::skip $flag(-skip) - } - - # Handle the -file and -notfile flags - if {[info exists flag(-file)]} { - set ::tcltest::matchFiles $flag(-file) - } - if {[info exists flag(-notfile)]} { - set ::tcltest::skipFiles $flag(-notfile) - } - - # Use the -constraints flag, if given, to turn on constraints that are - # turned off by default: userInteractive knownBug nonPortable. This - # code fragment must be run after constraints are initialized. - - if {[info exists flag(-constraints)]} { - foreach elt $flag(-constraints) { - set ::tcltest::testConstraints($elt) 1 - } - } - - # Use the -limitconstraints flag, if given, to tell the harness to limit - # tests run to those that were specified using the -constraints flag. If - # the -constraints flag was not specified, print out an error and exit. - if {[info exists flag(-limitconstraints)]} { - if {![info exists flag(-constraints)]} { - puts "You can only use the -limitconstraints flag with \ - -constraints" - exit 1 - } - set ::tcltest::limitConstraints $flag(-limitconstraints) - foreach elt [array names ::tcltest::testConstraints] { - if {[lsearch -exact $flag(-constraints) $elt] == -1} { - set ::tcltest::testConstraints($elt) 0 - } - } - } - - # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if - # given. - # - # If the path is relative, make it absolute. If the file exists but - # is not a dir, then return an error. - # - # If ::tcltest::temporaryDirectory does not already exist, create it. - # If you cannot create it, then return an error. - - set tmpDirError "" - if {[info exists flag(-tmpdir)]} { - set ::tcltest::temporaryDirectory $flag(-tmpdir) - - MakeAbsolutePath ::tcltest::temporaryDirectory - set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: " - } - if {[file exists $::tcltest::temporaryDirectory]} { - ::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError - } else { - file mkdir $::tcltest::temporaryDirectory - } - - normalizePath ::tcltest::temporaryDirectory - - # Set the ::tcltest::testsDirectory to the arg of -testdir, if - # given. - # - # If the path is relative, make it absolute. If the file exists but - # is not a dir, then return an error. - # - # If ::tcltest::temporaryDirectory does not already exist return an error. - - set testDirError "" - if {[info exists flag(-testdir)]} { - set ::tcltest::testsDirectory $flag(-testdir) - - MakeAbsolutePath ::tcltest::testsDirectory - set testDirError "bad argument \"$flag(-testdir)\" to -testdir: " - } - if {[file exists $::tcltest::testsDirectory]} { - ::tcltest::CheckDirectory r $::tcltest::testsDirectory $testDirError - } else { - ::tcltest::PrintError "$testDirError \"$::tcltest::testsDirectory\" \ - does not exist" - exit 1 - } - - normalizePath ::tcltest::testsDirectory - - # Save the names of files that already exist in - # the output directory. - foreach file [glob -nocomplain \ - [file join $::tcltest::temporaryDirectory *]] { - lappend ::tcltest::filesExisted [file tail $file] - } - - # If an alternate error or output files are specified, change the - # default channels. - - if {[info exists flag(-outfile)]} { - set tmp $flag(-outfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set ::tcltest::outputChannel [open $tmp w] - } - - if {[info exists flag(-errfile)]} { - set tmp $flag(-errfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set ::tcltest::errorChannel [open $tmp w] - } - - # If a load script was specified, either directly or through - # a file, remember it for later usage. - - if {[info exists flag(-load)] && \ - ([lsearch -exact $flagArray -load] > \ - [lsearch -exact $flagArray -loadfile])} { - set ::tcltest::loadScript $flag(-load) - } - - if {[info exists flag(-loadfile)] && \ - ([lsearch -exact $flagArray -loadfile] > \ - [lsearch -exact $flagArray -load]) } { - set tmp $flag(-loadfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set tmp [open $tmp r] - set ::tcltest::loadScript [read $tmp] - close $tmp - } - - # If the user specifies debug testing, print out extra information during - # the run. - if {[info exists flag(-debug)]} { - set ::tcltest::debug $flag(-debug) - } - - # Handle -preservecore - if {[info exists flag(-preservecore)]} { - set ::tcltest::preserveCore $flag(-preservecore) - } - - # Call the hook - ::tcltest::processCmdLineArgsHook [array get flag] - - # Spit out everything you know if we're at a debug level 2 or greater - - DebugPuts 2 "Flags passed into tcltest:" - DebugPArray 2 flag - DebugPuts 2 "::tcltest::debug = $::tcltest::debug" - DebugPuts 2 "::tcltest::testsDirectory = $::tcltest::testsDirectory" - DebugPuts 2 "::tcltest::workingDirectory = $::tcltest::workingDirectory" - DebugPuts 2 "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory" - DebugPuts 2 "::tcltest::outputChannel = $::tcltest::outputChannel" - DebugPuts 2 "::tcltest::errorChannel = $::tcltest::errorChannel" - DebugPuts 2 "Original environment (::tcltest::originalEnv):" - DebugPArray 2 ::tcltest::originalEnv - DebugPuts 2 "Constraints:" - DebugPArray 2 ::tcltest::testConstraints -} - -# ::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 - -proc ::tcltest::loadTestedCommands {} { - if {$::tcltest::loadScript == {}} { - return - } - - uplevel #0 $::tcltest::loadScript -} - -# ::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). - -proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { - - set testFileName [file tail [info script]] - - # Call the cleanup hook - ::tcltest::cleanupTestsHook - - # Remove files and directories created by the :tcltest::makeFile and - # ::tcltest::makeDirectory procedures. - # Record the names of files in ::tcltest::workingDirectory that were not - # pre-existing, and associate them with the test file that created them. - - if {!$calledFromAllFile} { - foreach file $::tcltest::filesMade { - if {[file exists $file]} { - catch {file delete -force $file} - } - } - set currentFiles {} - foreach file [glob -nocomplain \ - [file join $::tcltest::temporaryDirectory *]] { - lappend currentFiles [file tail $file] - } - set newFiles {} - foreach file $currentFiles { - if {[lsearch -exact $::tcltest::filesExisted $file] == -1} { - lappend newFiles $file - } - } - set ::tcltest::filesExisted $currentFiles - if {[llength $newFiles] > 0} { - set ::tcltest::createdNewFiles($testFileName) $newFiles - } - } - - if {$calledFromAllFile || $::tcltest::testSingleFile} { - - # print stats - - puts -nonewline $::tcltest::outputChannel "$testFileName:" - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - puts -nonewline $::tcltest::outputChannel \ - "\t$index\t$::tcltest::numTests($index)" - } - puts $::tcltest::outputChannel "" - - # print number test files sourced - # print names of files that ran tests which failed - - if {$calledFromAllFile} { - puts $::tcltest::outputChannel \ - "Sourced $::tcltest::numTestFiles Test Files." - set ::tcltest::numTestFiles 0 - if {[llength $::tcltest::failFiles] > 0} { - puts $::tcltest::outputChannel \ - "Files with failing tests: $::tcltest::failFiles" - set ::tcltest::failFiles {} - } - } - - # if any tests were skipped, print the constraints that kept them - # from running. - - set constraintList [array names ::tcltest::skippedBecause] - if {[llength $constraintList] > 0} { - puts $::tcltest::outputChannel \ - "Number of tests skipped for each constraint:" - foreach constraint [lsort $constraintList] { - puts $::tcltest::outputChannel \ - "\t$::tcltest::skippedBecause($constraint)\t$constraint" - unset ::tcltest::skippedBecause($constraint) - } - } - - # report the names of test files in ::tcltest::createdNewFiles, and - # reset the array to be empty. - - set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]] - if {[llength $testFilesThatTurded] > 0} { - puts $::tcltest::outputChannel "Warning: files left behind:" - foreach testFile $testFilesThatTurded { - puts $::tcltest::outputChannel \ - "\t$testFile:\t$::tcltest::createdNewFiles($testFile)" - unset ::tcltest::createdNewFiles($testFile) - } - } - - # reset filesMade, filesExisted, and numTests - - set ::tcltest::filesMade {} - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - set ::tcltest::numTests($index) 0 - } - - # exit only if running Tk in non-interactive mode - - global tk_version tcl_interactive - if {[info exists tk_version] && ![info exists tcl_interactive]} { - exit - } - } else { - - # if we're deferring stat-reporting until all files are sourced, - # then add current file to failFile list if any tests in this file - # failed - - incr ::tcltest::numTestFiles - if {($::tcltest::currentFailure) && \ - ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} { - lappend ::tcltest::failFiles $testFileName - } - set ::tcltest::currentFailure false - - # restore the environment to the state it was in before this package - # was loaded - - set newEnv {} - set changedEnv {} - set removedEnv {} - foreach index [array names ::env] { - if {![info exists ::tcltest::originalEnv($index)]} { - lappend newEnv $index - unset ::env($index) - } else { - if {$::env($index) != $::tcltest::originalEnv($index)} { - lappend changedEnv $index - set ::env($index) $::tcltest::originalEnv($index) - } - } - } - foreach index [array names ::tcltest::originalEnv] { - if {![info exists ::env($index)]} { - lappend removedEnv $index - set ::env($index) $::tcltest::originalEnv($index) - } - } - if {[llength $newEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements created:\t$newEnv" - } - if {[llength $changedEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements changed:\t$changedEnv" - } - if {[llength $removedEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements removed:\t$removedEnv" - } - - set changedTclPlatform {} - foreach index [array names ::tcltest::originalTclPlatform] { - if {$::tcl_platform($index) != \ - $::tcltest::originalTclPlatform($index)} { - lappend changedTclPlatform $index - set ::tcl_platform($index) \ - $::tcltest::originalTclPlatform($index) - } - } - if {[llength $changedTclPlatform] > 0} { - puts $::tcltest::outputChannel \ - "tcl_platform array elements changed:\t$changedTclPlatform" - } - - if {[file exists [file join $::tcltest::workingDirectory core]]} { - if {$::tcltest::preserveCore > 1} { - puts $::tcltest::outputChannel "produced core file! \ - Moving file to: \ - [file join $::tcltest::temporaryDirectory core-$name]" - flush $::tcltest::outputChannel - catch {file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - ::tcltest::PrintError "Problem renaming file: $msg" - } - } else { - # Print a message if there is a core file and (1) there - # previously wasn't one or (2) the new one is different from - # the old one. - - if {[info exists ::tcltest::coreModificationTime]} { - if {$::tcltest::coreModificationTime != [file mtime \ - [file join $::tcltest::workingDirectory core]]} { - puts $::tcltest::outputChannel "A core file was created!" - } - } else { - puts $::tcltest::outputChannel "A core file was created!" - } - } - } - } -} - -# ::tcltest::cleanupTestsHook -- -# -# This hook allows a harness that builds upon tcltest to specify -# additional things that should be done at cleanup. -# - -if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} { - proc ::tcltest::cleanupTestsHook {} {} -} - -# test -- -# -# This procedure runs a test and prints an error message if the test fails. -# If ::tcltest::verbose has been set, it also prints a message even if the -# test succeeds. The test will be skipped if it doesn't match the -# ::tcltest::match variable, if it matches an element in -# ::tcltest::skip, or if one of the elements of "constraints" turns -# out not to be true. -# -# Arguments: -# name - Name of test, in the form foo-1.2. -# description - Short textual description of the test, to -# help humans understand what it does. -# constraints - A list of one or more keywords, each of -# which must be the name of an element in -# the array "::tcltest::testConstraints". If any of these -# elements is zero, the test is skipped. -# This argument may be omitted. -# script - Script to run to carry out the test. It must -# return a result that can be checked for -# correctness. -# expectedAnswer - Expected result from script. - -proc ::tcltest::test {name description script expectedAnswer args} { - - DebugPuts 3 "Running $name ($description)" - - incr ::tcltest::numTests(Total) - - # skip the test if it's name matches an element of skip - - foreach pattern $::tcltest::skip { - if {[string match $pattern $name]} { - incr ::tcltest::numTests(Skipped) - DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedSkip} - return - } - } - - # skip the test if it's name doesn't match any element of match - - if {[llength $::tcltest::match] > 0} { - set ok 0 - foreach pattern $::tcltest::match { - if {[string match $pattern $name]} { - set ok 1 - break - } - } - if {!$ok} { - incr ::tcltest::numTests(Skipped) - DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch} - return - } - } - - set i [llength $args] - if {$i == 0} { - set constraints {} - # If we're limited to the listed constraints and there aren't any - # listed, then we shouldn't run the test. - if {$::tcltest::limitConstraints} { - ::tcltest::AddToSkippedBecause userSpecifiedLimitConstraint - incr ::tcltest::numTests(Skipped) - return - } - } elseif {$i == 1} { - - # "constraints" argument exists; shuffle arguments down, then - # make sure that the constraints are satisfied. - - set constraints $script - set script $expectedAnswer - set expectedAnswer [lindex $args 0] - set doTest 0 - if {[string match {*[$\[]*} $constraints] != 0} { - # full expression, e.g. {$foo > [info tclversion]} - catch {set doTest [uplevel #0 expr $constraints]} - } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { - # something like {a || b} should be turned into - # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b). - regsub -all {[.\w]+} $constraints \ - {$::tcltest::testConstraints(&)} c - catch {set doTest [eval expr $c]} - } else { - # just simple constraints such as {unixOnly fonts}. - set doTest 1 - foreach constraint $constraints { - if {(![info exists ::tcltest::testConstraints($constraint)]) \ - || (!$::tcltest::testConstraints($constraint))} { - set doTest 0 - - # store the constraint that kept the test from running - set constraints $constraint - break - } - } - } - if {$doTest == 0} { - if {[string first s $::tcltest::verbose] != -1} { - puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints" - } - - incr ::tcltest::numTests(Skipped) - ::tcltest::AddToSkippedBecause $constraints - return - } - } else { - error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\"" - } - - # Save information about the core file. You need to restore the original - # tcl_platform environment because some of the tests mess with tcl_platform. - - if {$::tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - array set tcl_platform $::tcltest::originalTclPlatform - if {[file exists [file join $::tcltest::workingDirectory core]]} { - set coreModTime [file mtime [file join \ - $::tcltest::workingDirectory core]] - } - array set tcl_platform $currentTclPlatform - } - - # If there is no "memory" command (because memory debugging isn't - # enabled), then don't attempt to use the command. - - if {[info commands memory] != {}} { - memory tag $name - } - - set code [catch {uplevel $script} actualAnswer] - if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} { - incr ::tcltest::numTests(Passed) - if {[string first p $::tcltest::verbose] != -1} { - puts $::tcltest::outputChannel "++++ $name PASSED" - } - } else { - incr ::tcltest::numTests(Failed) - set ::tcltest::currentFailure true - if {[string first b $::tcltest::verbose] == -1} { - set script "" - } - puts $::tcltest::outputChannel "\n==== $name $description FAILED" - if {$script != ""} { - puts $::tcltest::outputChannel "==== Contents of test case:" - puts $::tcltest::outputChannel $script - } - if {$code != 0} { - if {$code == 1} { - puts $::tcltest::outputChannel "==== Test generated error:" - puts $::tcltest::outputChannel $actualAnswer - } elseif {$code == 2} { - puts $::tcltest::outputChannel "==== Test generated return exception; result was:" - puts $::tcltest::outputChannel $actualAnswer - } elseif {$code == 3} { - puts $::tcltest::outputChannel "==== Test generated break exception" - } elseif {$code == 4} { - puts $::tcltest::outputChannel "==== Test generated continue exception" - } else { - puts $::tcltest::outputChannel "==== Test generated exception $code; message was:" - puts $::tcltest::outputChannel $actualAnswer - } - } else { - puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer" - } - puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer" - puts $::tcltest::outputChannel "==== $name FAILED\n" - } - if {$::tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - if {[file exists [file join $::tcltest::workingDirectory core]]} { - if {$::tcltest::preserveCore > 1} { - puts $::tcltest::outputChannel "==== $name produced core file! \ - Moving file to: \ - [file join $::tcltest::temporaryDirectory core-$name]" - catch {file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - ::tcltest::PrintError "Problem renaming file: $msg" - } - } else { - # Print a message if there is a core file and (1) there - # previously wasn't one or (2) the new one is different from - # the old one. - - if {[info exists coreModTime]} { - if {$coreModTime != [file mtime \ - [file join $::tcltest::workingDirectory core]]} { - puts $::tcltest::outputChannel "==== $name produced core file!" - } - } else { - puts $::tcltest::outputChannel "==== $name produced core file!" - } - } - } - array set tcl_platform $currentTclPlatform - } -} - -# ::tcltest::getMatchingFiles -# -# Looks at the patterns given to match and skip files -# and uses them to put together a list of the tests that will be run. -# -# Arguments: -# none -# -# Results: -# The constructed list is returned to the user. This will primarily -# be used in 'all.tcl' files. - -proc ::tcltest::getMatchingFiles {args} { - set matchingFiles {} - if {[llength $args]} { - set searchDirectory $args - } else { - set searchDirectory [list $::tcltest::testsDirectory] - } - # Find the matching files in the list of directories and then remove the - # ones that match the skip pattern - foreach directory $searchDirectory { - set matchFileList {} - foreach match $::tcltest::matchFiles { - set matchFileList [concat $matchFileList \ - [glob -nocomplain [file join $directory $match]]] - } - if {[string compare {} $::tcltest::skipFiles]} { - set skipFileList {} - foreach skip $::tcltest::skipFiles { - set skipFileList [concat $skipFileList \ - [glob -nocomplain [file join $directory $skip]]] - } - foreach file $matchFileList { - # Only include files that don't match the skip pattern and - # aren't SCCS lock files. - if {([lsearch -exact $skipFileList $file] == -1) && \ - (![string match l.*.test [file tail $file]])} { - lappend matchingFiles $file - } - } - } else { - set matchingFiles [concat $matchingFiles $matchFileList] - } - } - if {[string equal $matchingFiles {}]} { - ::tcltest::PrintError "No test files remain after applying \ - your match and skip patterns!" - } - return $matchingFiles -} - -# The following two procs are used in the io tests. - -proc ::tcltest::openfiles {} { - if {[catch {testchannel open} result]} { - return {} - } - return $result -} - -proc ::tcltest::leakfiles {old} { - if {[catch {testchannel open} new]} { - return {} - } - set leak {} - foreach p $new { - if {[lsearch $old $p] < 0} { - lappend leak $p - } - } - return $leak -} - -# ::tcltest::saveState -- -# -# Save information regarding what procs and variables exist. -# -# Arguments: -# none -# -# Results: -# Modifies the variable ::tcltest::saveState - -proc ::tcltest::saveState {} { - uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]} - DebugPuts 2 "::tcltest::saveState: $::tcltest::saveState" -} - -# ::tcltest::restoreState -- -# -# Remove procs and variables that didn't exist before the call to -# ::tcltest::saveState. -# -# Arguments: -# none -# -# Results: -# Removes procs and variables from your environment if they don't exist -# in the ::tcltest::saveState variable. - -proc ::tcltest::restoreState {} { - foreach p [info procs] { - if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \ - (![string equal ::tcltest::$p [namespace origin $p]])} { - - DebugPuts 3 "::tcltest::restoreState: Removing proc $p" - rename $p {} - } - } - foreach p [uplevel #0 {info vars}] { - if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} { - DebugPuts 3 "::tcltest::restoreState: Removing variable $p" - uplevel #0 "catch {unset $p}" - } - } -} - -# ::tcltest::normalizeMsg -- -# -# Removes "extra" newlines from a string. -# -# Arguments: -# msg String to be modified -# - -proc ::tcltest::normalizeMsg {msg} { - regsub "\n$" [string tolower $msg] "" msg - regsub -all "\n\n" $msg "\n" msg - regsub -all "\n\}" $msg "\}" msg - return $msg -} - -# makeFile -- -# -# Create a new file with the name , and write to it. -# -# If this file hasn't been created via makeFile since the last time -# cleanupTests was called, add it to the $filesMade list, so it will -# be removed by the next call to cleanupTests. -# -proc ::tcltest::makeFile {contents name} { - global tcl_platform - - DebugPuts 3 "::tcltest::makeFile: putting $contents into $name" - - set fullName [file join $::tcltest::temporaryDirectory $name] - set fd [open $fullName w] - - fconfigure $fd -translation lf - - if {[string equal [string index $contents end] "\n"]} { - puts -nonewline $fd $contents - } else { - puts $fd $contents - } - close $fd - - if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { - lappend ::tcltest::filesMade $fullName - } - return $fullName -} - -# ::tcltest::removeFile -- -# -# Removes the named file from the filesystem -# -# Arguments: -# name file to be removed -# - -proc ::tcltest::removeFile {name} { - DebugPuts 3 "::tcltest::removeFile: removing $name" - file delete [file join $::tcltest::temporaryDirectory $name] -} - -# makeDirectory -- -# -# Create a new dir with the name . -# -# If this dir hasn't been created via makeDirectory since the last time -# cleanupTests was called, add it to the $directoriesMade list, so it will -# be removed by the next call to cleanupTests. -# -proc ::tcltest::makeDirectory {name} { - file mkdir $name - - set fullName [file join [pwd] $name] - if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { - lappend ::tcltest::filesMade $fullName - } -} - -# ::tcltest::removeDirectory -- -# -# Removes a named directory from the file system. -# -# Arguments: -# name Name of the directory to remove -# - -proc ::tcltest::removeDirectory {name} { - file delete -force $name -} - -proc ::tcltest::viewFile {name} { - global tcl_platform - if {([string equal $tcl_platform(platform) "macintosh"]) || \ - ($::tcltest::testConstraints(unixExecs) == 0)} { - set f [open [file join $::tcltest::temporaryDirectory $name]] - set data [read -nonewline $f] - close $f - return $data - } else { - exec cat [file join $::tcltest::temporaryDirectory $name] - } -} - -# grep -- -# -# Evaluate a given expression against each element of a list and return all -# elements for which the expression evaluates to true. For the purposes of -# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the -# value of the current element within the expression. This is equivalent to -# the perl grep command where CURRENT_ELEMENT would be the name for the special -# variable $_. -# -# Examples of usage would be: -# set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers] -# set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings] -# -# Use of the CURRENT_ELEMENT keyword is optional. If it is left out, it is -# assumed to be the final argument to the expression provided. -# -# Example: -# grep {regexp a} $someList -# -proc ::tcltest::grep { expression searchList } { - foreach element $searchList { - if {[regsub -all CURRENT_ELEMENT $expression $element \ - newExpression] == 0} { - set newExpression "$expression {$element}" - } - if {[eval $newExpression] == 1} { - lappend returnList $element - } - } - if {[info exists returnList]} { - return $returnList - } - return -} - -# -# Construct a string that consists of the requested sequence of bytes, -# as opposed to a string of properly formed UTF-8 characters. -# This allows the tester to -# 1. Create denormalized or improperly formed strings to pass to C procedures -# that are supposed to accept strings with embedded NULL bytes. -# 2. Confirm that a string result has a certain pattern of bytes, for instance -# to confirm that "\xe0\0" in a Tcl script is stored internally in -# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". -# -# Generally, it's a bad idea to examine the bytes in a Tcl string or to -# construct improperly formed strings in this manner, because it involves -# exposing that Tcl uses UTF-8 internally. - -proc ::tcltest::bytestring {string} { - encoding convertfrom identity $string -} - -# -# Internationalization / ISO support procs -- dl -# -proc ::tcltest::set_iso8859_1_locale {} { - if {[info commands testlocale] != ""} { - set ::tcltest::previousLocale [testlocale ctype] - testlocale ctype $::tcltest::isoLocale - } - return -} - -proc ::tcltest::restore_locale {} { - if {[info commands testlocale] != ""} { - testlocale ctype $::tcltest::previousLocale - } - return -} - -# threadReap -- -# -# Kill all threads except for the main thread. -# Do nothing if testthread is not defined. -# -# Arguments: -# none. -# -# Results: -# Returns the number of existing threads. -proc ::tcltest::threadReap {} { - if {[info commands testthread] != {}} { - - # testthread built into tcltest - - testthread errorproc ThreadNullError - while {[llength [testthread names]] > 1} { - foreach tid [testthread names] { - if {$tid != $::tcltest::mainThread} { - catch {testthread send -async $tid {testthread exit}} - } - } - ## Enter a bit a sleep to give the threads enough breathing - ## room to kill themselves off, otherwise the end up with a - ## massive queue of repeated events - after 1 - } - testthread errorproc ThreadError - return [llength [testthread names]] - } elseif {[info commands thread::id] != {}} { - - # Thread extension - - thread::errorproc ThreadNullError - while {[llength [thread::names]] > 1} { - foreach tid [thread::names] { - if {$tid != $::tcltest::mainThread} { - catch {thread::send -async $tid {thread::exit}} - } - } - ## Enter a bit a sleep to give the threads enough breathing - ## room to kill themselves off, otherwise the end up with a - ## massive queue of repeated events - after 1 - } - thread::errorproc ThreadError - return [llength [thread::names]] - } else { - return 1 - } -} - -# Initialize the constraints and set up command line arguments -namespace eval tcltest { - # Ensure that we have a minimal auto_path so we don't pick up extra junk. - set ::auto_path [list [info library]] - - ::tcltest::initConstraints - if {[namespace children ::tcltest] == {}} { - ::tcltest::processCmdLineArgs - } -} -- cgit v0.12