diff options
Diffstat (limited to 'tests/defs.tcl')
| -rw-r--r-- | tests/defs.tcl | 1087 |
1 files changed, 0 insertions, 1087 deletions
diff --git a/tests/defs.tcl b/tests/defs.tcl deleted file mode 100644 index 839d358..0000000 --- a/tests/defs.tcl +++ /dev/null @@ -1,1087 +0,0 @@ -# defs.tcl -- -# -# This file contains support code for the Tcl/Tk test suite.It is -# It is normally sourced by the individual files in the test suite -# before they run their tests. This improved approach to testing -# was designed and initially implemented by Mary Ann May-Pumphrey -# of Sun Microsystems. -# -# Copyright (c) 1990-1994 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. -# -# RCS: @(#) $Id: defs.tcl,v 1.6 1999/06/19 00:57:57 jenn Exp $ - -# Initialize wish shell - -if {[info exists tk_version]} { - tk appname tktest - wm title . tktest -} else { - # Ensure that we have a minimal auto_path so we don't pick up extra junk. - set auto_path [list [info library]] -} - -# create the "tcltest" namespace for all testing variables and procedures - -namespace eval tcltest { - set procList [list test cleanupTests dotests saveState restoreState \ - normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile bytestring set_iso8859_1_locale restore_locale \ - safeFetch threadReap] - if {[info exists tk_version]} { - lappend procList setupbg dobg bgReady cleanupbg fixfocus - } - foreach proc $procList { - namespace export $proc - } - - # ::tcltest::verbose defaults to "b" - - variable verbose "b" - - # match defaults to the empty list - - variable match {} - - # skip defaults to the empty list - - variable skip {} - - # Tests should not rely on the current working directory. - # Files that are part of the test suite should be accessed relative to - # ::tcltest::testsDir. - - set originalDir [pwd] - set tDir [file join $originalDir [file dirname [info script]]] - cd $tDir - variable testsDir [pwd] - cd $originalDir - - # 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. - - variable numTestFiles 0 - variable testSingleFile true - variable currentFailure false - 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. - - variable filesMade {} - 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. - - array set ::tcltest::createdNewFiles {} - - # initialize ::tcltest::numTests array to keep track fo the number of - # tests that pass, fial, and are skipped. - - array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0] - - # initialize ::tcltest::skippedBecause array to keep track of - # constraints that kept tests from running - - array set ::tcltest::skippedBecause {} - - # tests that use thread need to know which is the main thread - - variable ::tcltest::mainThread 1 - if {[info commands testthread] != {}} { - set ::tcltest::mainThread [testthread names] - } -} - -# If there is no "memory" command (because memory debugging isn't -# enabled), generate a dummy command that does nothing. - -if {[info commands memory] == ""} { - proc memory args {} -} - -# ::tcltest::initConfig -- -# -# Check configuration information that will determine which tests -# to run. To do this, create an array ::tcltest::testConfig. 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 README file for the list of built-in -# constraints defined in this procedure. -# -# Arguments: -# none -# -# Results: -# The ::tcltest::testConfig array is reset to have an index for -# each built-in test constraint. - -proc ::tcltest::initConfig {} { - - global tcl_platform tcl_interactive tk_version - - catch {unset ::tcltest::testConfig} - - # The following trace procedure makes it so that we can safely refer to - # non-existent members of the ::tcltest::testConfig 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::testConfig("X") is defined. - - trace variable ::tcltest::testConfig r ::tcltest::safeFetch - - proc ::tcltest::safeFetch {n1 n2 op} { - if {($n2 != {}) && ([info exists ::tcltest::testConfig($n2)] == 0)} { - set ::tcltest::testConfig($n2) 0 - } - } - - set ::tcltest::testConfig(unixOnly) \ - [expr {$tcl_platform(platform) == "unix"}] - set ::tcltest::testConfig(macOnly) \ - [expr {$tcl_platform(platform) == "macintosh"}] - set ::tcltest::testConfig(pcOnly) \ - [expr {$tcl_platform(platform) == "windows"}] - - set ::tcltest::testConfig(unix) $::tcltest::testConfig(unixOnly) - set ::tcltest::testConfig(mac) $::tcltest::testConfig(macOnly) - set ::tcltest::testConfig(pc) $::tcltest::testConfig(pcOnly) - - set ::tcltest::testConfig(unixOrPc) \ - [expr {$::tcltest::testConfig(unix) || $::tcltest::testConfig(pc)}] - set ::tcltest::testConfig(macOrPc) \ - [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(pc)}] - set ::tcltest::testConfig(macOrUnix) \ - [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(unix)}] - - set ::tcltest::testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}] - set ::tcltest::testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}] - - # The following config 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::testConfig(tempNotPc) [expr {!$::tcltest::testConfig(pc)}] - set ::tcltest::testConfig(tempNotMac) [expr {!$::tcltest::testConfig(mac)}] - set ::tcltest::testConfig(tempNotUnix) [expr {!$::tcltest::testConfig(unix)}] - - # The following config 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::testConfig(pcCrash) [expr {!$::tcltest::testConfig(pc)}] - set ::tcltest::testConfig(macCrash) [expr {!$::tcltest::testConfig(mac)}] - set ::tcltest::testConfig(unixCrash) [expr {!$::tcltest::testConfig(unix)}] - - # Set the "fonts" constraint for wish apps - - if {[info exists tk_version]} { - set ::tcltest::testConfig(fonts) 1 - catch {destroy .e} - entry .e -width 0 -font {Helvetica -12} -bd 1 - .e insert end "a.bcd" - if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} { - set ::tcltest::testConfig(fonts) 0 - } - destroy .e - catch {destroy .t} - text .t -width 80 -height 20 -font {Times -14} -bd 1 - pack .t - .t insert end "This is\na dot." - update - set x [list [.t bbox 1.3] [.t bbox 2.5]] - destroy .t - if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} { - set ::tcltest::testConfig(fonts) 0 - } - } - - # Skip empty tests - - set ::tcltest::testConfig(emptyTest) 0 - - # By default, tests that expost known bugs are skipped. - - set ::tcltest::testConfig(knownBug) 0 - - # By default, non-portable tests are skipped. - - set ::tcltest::testConfig(nonPortable) 0 - - # Some tests require user interaction. - - set ::tcltest::testConfig(userInteraction) 0 - - # Some tests must be skipped if the interpreter is not in interactive mode - - set ::tcltest::testConfig(interactive) $tcl_interactive - - # 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::testConfig(root) 0 - set ::tcltest::testConfig(notRoot) 1 - set user {} - if {$tcl_platform(platform) == "unix"} { - catch {set user [exec whoami]} - if {$user == ""} { - catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} - } - if {($user == "root") || ($user == "")} { - set ::tcltest::testConfig(root) 1 - set ::tcltest::testConfig(notRoot) 0 - } - } - - # Set nonBlockFiles constraint: 1 means this platform supports - # setting files into nonblocking mode. - - if {[catch {set f [open defs r]}]} { - set ::tcltest::testConfig(nonBlockFiles) 1 - } else { - if {[catch {fconfigure $f -blocking off}] == 0} { - set ::tcltest::testConfig(nonBlockFiles) 1 - } else { - set ::tcltest::testConfig(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 {$tcl_platform(platform) == "unix"} { - if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { - set ::tcltest::testConfig(asyncPipeClose) 0 - } else { - set ::tcltest::testConfig(asyncPipeClose) 1 - } - } else { - set ::tcltest::testConfig(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::testConfig(eformat) 1 - if {[string compare "[format %g 5e-5]" "5e-05"] != 0} { - set ::tcltest::testConfig(eformat) 0 - } - - # Test to see if execed commands such as cat, echo, rm and so forth are - # present on this machine. - - set ::tcltest::testConfig(unixExecs) 1 - if {$tcl_platform(platform) == "macintosh"} { - set ::tcltest::testConfig(unixExecs) 0 - } - if {($::tcltest::testConfig(unixExecs) == 1) && \ - ($tcl_platform(platform) == "windows")} { - if {[catch {exec cat defs}] == 1} { - set ::tcltest::testConfig(unixExecs) 0 - } - if {($::tcltest::testConfig(unixExecs) == 1) && \ - ([catch {exec echo hello}] == 1)} { - set ::tcltest::testConfig(unixExecs) 0 - } - if {($::tcltest::testConfig(unixExecs) == 1) && \ - ([catch {exec sh -c echo hello}] == 1)} { - set ::tcltest::testConfig(unixExecs) 0 - } - if {($::tcltest::testConfig(unixExecs) == 1) && \ - ([catch {exec wc defs}] == 1)} { - set ::tcltest::testConfig(unixExecs) 0 - } - if {$::tcltest::testConfig(unixExecs) == 1} { - exec echo hello > removeMe - if {[catch {exec rm removeMe}] == 1} { - set ::tcltest::testConfig(unixExecs) 0 - } - } - if {($::tcltest::testConfig(unixExecs) == 1) && \ - ([catch {exec sleep 1}] == 1)} { - set ::tcltest::testConfig(unixExecs) 0 - } - if {($::tcltest::testConfig(unixExecs) == 1) && \ - ([catch {exec fgrep unixExecs defs}] == 1)} { - set ::tcltest::testConfig(unixExecs) 0 - } - if {($::tcltest::testConfig(unixExecs) == 1) && \ - ([catch {exec ps}] == 1)} { - set ::tcltest::testConfig(unixExecs) 0 - } - if {($::tcltest::testConfig(unixExecs) == 1) && \ - ([catch {exec echo abc > removeMe}] == 0) && \ - ([catch {exec chmod 644 removeMe}] == 1) && \ - ([catch {exec rm removeMe}] == 0)} { - set ::tcltest::testConfig(unixExecs) 0 - } else { - catch {exec rm -f removeMe} - } - if {($::tcltest::testConfig(unixExecs) == 1) && \ - ([catch {exec mkdir removeMe}] == 1)} { - set ::tcltest::testConfig(unixExecs) 0 - } else { - catch {exec rm -r removeMe} - } - } -} - -::tcltest::initConfig - - -# ::tcltest::processCmdLineArgs -- -# -# Use command line args to set the verbose, skip, and -# match variables. This procedure must be run after -# constraints are initialized, because some constraints can be -# overridden. -# -# Arguments: -# none -# -# Results: -# ::tcltest::verbose is set to <value> - -proc ::tcltest::processCmdLineArgs {} { - global argv - - # The "argv" var doesn't exist in some cases, so use {} - # The "argv" var doesn't exist in some cases. - - if {(![info exists argv]) || ([llength $argv] < 2)} { - set flagArray {} - } else { - set flagArray $argv - } - - if {[catch {array set flag $flagArray}]} { - puts stderr "Error: odd number of command line args specified:" - puts stderr " $argv" - exit - } - - # 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. - - foreach arg {-verbose -match -skip -constraints} { - 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::workingDir to [pwd]. - # Save the names of files that already exist in ::tcltest::workingDir. - - set ::tcltest::workingDir [pwd] - foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] { - lappend ::tcltest::filesExisted [file tail $file] - } - - # 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) - } - - # 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::testConfig($elt) 1 - } - } -} - -::tcltest::processCmdLineArgs - - -# ::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. -# - -proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { - set tail [file tail [info script]] - - # Remove files and directories created by the :tcltest::makeFile and - # ::tcltest::makeDirectory procedures. - # Record the names of files in ::tcltest::workingDir 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::workingDir *]] { - 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($tail) $newFiles - } - } - - if {$calledFromAllFile || $::tcltest::testSingleFile} { - - # print stats - - puts -nonewline stdout "$tail:" - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - puts -nonewline stdout "\t$index\t$::tcltest::numTests($index)" - } - puts stdout "" - - # print number test files sourced - # print names of files that ran tests which failed - - if {$calledFromAllFile} { - puts stdout "Sourced $::tcltest::numTestFiles Test Files." - set ::tcltest::numTestFiles 0 - if {[llength $::tcltest::failFiles] > 0} { - puts stdout "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 stdout "Number of tests skipped for each constraint:" - foreach constraint [lsort $constraintList] { - puts stdout \ - "\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 stdout "Warning: test files left files behind:" - foreach testFile $testFilesThatTurded { - puts "\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] && !$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 $tail] == -1)} { - lappend ::tcltest::failFiles $tail - } - set ::tcltest::currentFailure false - } -} - - -# 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::testConfig". 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} { - 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) - 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) - return - } - } - set i [llength $args] - if {$i == 0} { - set constraints {} - } 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::testConfig(a) || $::tcltest::testConfig(b). - - regsub -all {[.a-zA-Z0-9]+} $constraints \ - {$::tcltest::testConfig(&)} 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::testConfig($constraint)] - || !$::tcltest::testConfig($constraint)} { - set doTest 0 - - # store the constraint that kept the test from running - - set constraints $constraint - break - } - } - } - if {$doTest == 0} { - incr ::tcltest::numTests(Skipped) - if {[string first s $::tcltest::verbose] != -1} { - puts stdout "++++ $name SKIPPED: $constraints" - } - - # add the constraint to the list of constraints the kept tests - # from running - - if {[info exists ::tcltest::skippedBecause($constraints)]} { - incr ::tcltest::skippedBecause($constraints) - } else { - set ::tcltest::skippedBecause($constraints) 1 - } - return - } - } else { - error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\"" - } - memory tag $name - set code [catch {uplevel $script} actualAnswer] - if {$code != 0 || [string compare $actualAnswer $expectedAnswer] != 0} { - incr ::tcltest::numTests(Failed) - set ::tcltest::currentFailure true - if {[string first b $::tcltest::verbose] == -1} { - set script "" - } - puts stdout "\n==== $name $description FAILED" - if {$script != ""} { - puts stdout "==== Contents of test case:" - puts stdout $script - } - if {$code != 0} { - if {$code == 1} { - puts stdout "==== Test generated error:" - puts stdout $actualAnswer - } elseif {$code == 2} { - puts stdout "==== Test generated return exception; result was:" - puts stdout $actualAnswer - } elseif {$code == 3} { - puts stdout "==== Test generated break exception" - } elseif {$code == 4} { - puts stdout "==== Test generated continue exception" - } else { - puts stdout "==== Test generated exception $code; message was:" - puts stdout $actualAnswer - } - } else { - puts stdout "---- Result was:\n$actualAnswer" - } - puts stdout "---- Result should have been:\n$expectedAnswer" - puts stdout "==== $name FAILED\n" - } else { - incr ::tcltest::numTests(Passed) - if {[string first p $::tcltest::verbose] != -1} { - puts stdout "++++ $name PASSED" - } - } -} - -# ::tcltest::dotests -- -# -# takes two arguments--the name of the test file (such -# as "parse.test"), and a pattern selecting the tests you want to -# execute. It sets ::tcltest::matching to the second argument, calls -# "source" on the file specified in the first argument, and restores -# ::tcltest::matching to its pre-call value at the end. -# -# Arguments: -# file name of tests file to source -# args pattern selecting the tests you want to execute -# -# Results: -# none - -proc ::tcltest::dotests {file args} { - set savedTests $::tcltest::match - set ::tcltest::match $args - source $file - set ::tcltest::match $savedTests -} - -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 -} - -set ::tcltest::saveState {} - -proc ::tcltest::saveState {} { - uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]} -} - -proc ::tcltest::restoreState {} { - foreach p [info procs] { - if {[lsearch [lindex $::tcltest::saveState 0] $p] < 0} { - rename $p {} - } - } - foreach p [uplevel #0 {info vars}] { - if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} { - uplevel #0 "unset $p" - } - } -} - -proc ::tcltest::normalizeMsg {msg} { - regsub "\n$" [string tolower $msg] "" msg - regsub -all "\n\n" $msg "\n" msg - regsub -all "\n\}" $msg "\}" msg - return $msg -} - -# makeFile -- -# -# Create a new file with the name <name>, and write <contents> to it. -# -# If this file hasn't been created via makeFile since the last time -# cleanupTests was called, add it to the $filesMade list, so it will -# be removed by the next call to cleanupTests. -# -proc ::tcltest::makeFile {contents name} { - set fd [open $name w] - fconfigure $fd -translation lf - if {[string index $contents [expr {[string length $contents] - 1}]] == "\n"} { - puts -nonewline $fd $contents - } else { - puts $fd $contents - } - close $fd - - set fullName [file join [pwd] $name] - if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { - lappend ::tcltest::filesMade $fullName - } -} - -proc ::tcltest::removeFile {name} { - file delete $name -} - -# makeDirectory -- -# -# Create a new dir with the name <name>. -# -# If this dir hasn't been created via makeDirectory since the last time -# cleanupTests was called, add it to the $directoriesMade list, so it will -# be removed by the next call to cleanupTests. -# -proc ::tcltest::makeDirectory {name} { - file mkdir $name - - set fullName [file join [pwd] $name] - if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { - lappend ::tcltest::filesMade $fullName - } -} - -proc ::tcltest::removeDirectory {name} { - file delete -force $name -} - -proc ::tcltest::viewFile {name} { - global tcl_platform - if {($tcl_platform(platform) == "macintosh") || \ - ($::tcltest::testConfig(unixExecs) == 0)} { - set f [open $name] - set data [read -nonewline $f] - close $f - return $data - } else { - exec cat $name - } -} - -# -# 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 -} - -# Locate tcltest executable - -if {![info exists tk_version]} { - set tcltest [info nameofexecutable] - - if {$tcltest == "{}"} { - set tcltest {} - } -} - -set ::tcltest::testConfig(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::testConfig(stdio) 1 -} -catch {file delete -force tmp} - -# Deliberately call the 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::testConfig(socket) \ - [expr {$msg != "sockets are not available on this system"}] - -# -# Internationalization / ISO support procs -- dl -# - -if {[info commands testlocale]==""} { - - # No testlocale command, no tests... - # (it could be that we are a sub interp and we could just load - # the Tcltest package but that would interfere with tests - # that tests packages/loading in slaves...) - - set ::tcltest::testConfig(hasIsoLocale) 0 -} else { - proc ::tcltest::set_iso8859_1_locale {} { - set ::tcltest::previousLocale [testlocale ctype] - testlocale ctype $::tcltest::isoLocale - } - - proc ::tcltest::restore_locale {} { - testlocale ctype $::tcltest::previousLocale - } - - if {![info exists ::tcltest::isoLocale]} { - set ::tcltest::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 ::tcltest::testConfig(hasIsoLocale) \ - [string length [::tcltest::set_iso8859_1_locale]] - ::tcltest::restore_locale -} - -# -# procedures that are Tk specific -# - -if {[info exists tk_version]} { - - # If the main window isn't already mapped (e.g. because the tests are - # being run automatically) , specify a precise size for it so that the - # user won't have to position it manually. - - if {![winfo ismapped .]} { - wm geometry . +0+0 - update - } - - # The following code can be used to perform tests involving a second - # process running in the background. - - # Locate the tktest executable - - set ::tcltest::tktest [info nameofexecutable] - if {$::tcltest::tktest == "{}"} { - set ::tcltest::tktest {} - puts stdout \ - "Unable to find tktest executable, skipping multiple process tests." - } - - # Create background process - - proc ::tcltest::setupbg args { - if {$::tcltest::tktest == ""} { - error "you're not running tktest so setupbg should not have been called" - } - if {[info exists ::tcltest::fd] && ($::tcltest::fd != "")} { - cleanupbg - } - - # The following code segment cannot be run on Windows prior - # to Tk 8.1b3 due to a channel I/O bug (bugID 1495). - - global tcl_platform - set ::tcltest::fd [open "|[list $::tcltest::tktest -geometry +0+0 -name tktest] $args" r+] - puts $::tcltest::fd "puts foo; flush stdout" - flush $::tcltest::fd - if {[gets $::tcltest::fd data] < 0} { - error "unexpected EOF from \"$::tcltest::tktest\"" - } - if {[string compare $data foo]} { - error "unexpected output from background process \"$data\"" - } - fileevent $::tcltest::fd readable bgReady - } - - # Send a command to the background process, catching errors and - # flushing I/O channels - - proc ::tcltest::dobg {command} { - puts $::tcltest::fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout" - flush $::tcltest::fd - set ::tcltest::bgDone 0 - set ::tcltest::bgData {} - tkwait variable ::tcltest::bgDone - set ::tcltest::bgData - } - - # Data arrived from background process. Check for special marker - # indicating end of data for this command, and make data available - # to dobg procedure. - - proc ::tcltest::bgReady {} { - set x [gets $::tcltest::fd] - if {[eof $::tcltest::fd]} { - fileevent $::tcltest::fd readable {} - set ::tcltest::bgDone 1 - } elseif {$x == "**DONE**"} { - set ::tcltest::bgDone 1 - } else { - append ::tcltest::bgData $x - } - } - - # Exit the background process, and close the pipes - - proc ::tcltest::cleanupbg {} { - catch { - puts $::tcltest::fd "exit" - close $::tcltest::fd - } - set ::tcltest::fd "" - } - - # Clean up focus after using generate event, which - # can leave the window manager with the wrong impression - # about who thinks they have the focus. (BW) - - proc ::tcltest::fixfocus {} { - catch {destroy .focus} - toplevel .focus - wm geometry .focus +0+0 - entry .focus.e - .focus.e insert 0 "fixfocus" - pack .focus.e - update - focus -force .focus.e - destroy .focus - } -} - -# 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. - -if {[info commands testthread] != {}} { - proc ::tcltest::threadReap {} { - testthread errorproc ThreadNullError - while {[llength [testthread names]] > 1} { - foreach tid [testthread names] { - if {$tid != $::tcltest::mainThread} { - catch {testthread send -async $tid {testthread exit}} - update - } - } - } - testthread errorproc ThreadError - return [llength [testthread names]] - } -} else { - proc ::tcltest::threadReap {} { - return 1 - } -} - -# Need to catch the import because it fails if defs.tcl is sourced -# more than once. - -catch {namespace import ::tcltest::*} -return |