home *** CD-ROM | disk | FTP | other *** search
/ PC World 2001 April / PCWorld_2001-04_cd.bin / Software / TemaCD / webclean / !!!python!!! / BeOpen-Python-2.0.exe / TCLTEST.TCL < prev    next >
Encoding:
Text File  |  2000-04-10  |  57.8 KB  |  1,906 lines
  1. # tcltest.tcl --
  2. #
  3. #    This file contains support code for the Tcl test suite.  It 
  4. #       defines the ::tcltest namespace and finds and defines the output
  5. #       directory, constraints available, output and error channels, etc. used
  6. #       by Tcl tests.  See the tcltest man page for more details.
  7. #       
  8. #       This design was based on the Tcl testing approach designed and
  9. #       initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. 
  10. #
  11. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  12. # Copyright (c) 1998-1999 by Scriptics Corporation.
  13. # All rights reserved.
  14. # 
  15. # RCS: @(#) $Id: tcltest.tcl,v 1.24 2000/04/11 01:04:19 welch Exp $
  16.  
  17. package provide tcltest 1.0
  18.  
  19. # create the "tcltest" namespace for all testing variables and procedures
  20.  
  21. namespace eval tcltest { 
  22.  
  23.     # Export the public tcltest procs
  24.     set procList [list test cleanupTests saveState restoreState \
  25.         normalizeMsg makeFile removeFile makeDirectory removeDirectory \
  26.         viewFile bytestring safeFetch threadReap getMatchingFiles \
  27.         loadTestedCommands normalizePath]
  28.     foreach proc $procList {
  29.     namespace export $proc
  30.     }
  31.  
  32.     # ::tcltest::verbose defaults to "b"
  33.     if {![info exists verbose]} {
  34.     variable verbose "b"
  35.     }
  36.  
  37.     # Match and skip patterns default to the empty list, except for
  38.     # matchFiles, which defaults to all .test files in the testsDirectory
  39.  
  40.     if {![info exists match]} {
  41.     variable match {}
  42.     }
  43.     if {![info exists skip]} {
  44.     variable skip {}
  45.     }
  46.     if {![info exists matchFiles]} {
  47.     variable matchFiles {*.test}
  48.     }
  49.     if {![info exists skipFiles]} {
  50.     variable skipFiles {}
  51.     }
  52.  
  53.     # By default, don't save core files
  54.     if {![info exists preserveCore]} {
  55.     variable preserveCore 0
  56.     }
  57.  
  58.     # output goes to stdout by default
  59.     if {![info exists outputChannel]} {
  60.     variable outputChannel stdout
  61.     }
  62.  
  63.     # errors go to stderr by default
  64.     if {![info exists errorChannel]} {
  65.     variable errorChannel stderr
  66.     }
  67.  
  68.     # debug output doesn't get printed by default; debug level 1 spits
  69.     # up only the tests that were skipped because they didn't match or were 
  70.     # specifically skipped.  A debug level of 2 would spit up the tcltest
  71.     # variables and flags provided; a debug level of 3 causes some additional
  72.     # output regarding operations of the test harness.  The tcltest package
  73.     # currently implements only up to debug level 3.
  74.     if {![info exists debug]} {
  75.     variable debug 0
  76.     }
  77.  
  78.     # Save any arguments that we might want to pass through to other programs. 
  79.     # This is used by the -args flag.
  80.     if {![info exists parameters]} {
  81.     variable parameters {}
  82.     }
  83.  
  84.     # Count the number of files tested (0 if all.tcl wasn't called).
  85.     # The all.tcl file will set testSingleFile to false, so stats will
  86.     # not be printed until all.tcl calls the cleanupTests proc.
  87.     # The currentFailure var stores the boolean value of whether the
  88.     # current test file has had any failures.  The failFiles list
  89.     # stores the names of test files that had failures.
  90.  
  91.     if {![info exists numTestFiles]} {
  92.     variable numTestFiles 0
  93.     }
  94.     if {![info exists testSingleFile]} {
  95.     variable testSingleFile true
  96.     }
  97.     if {![info exists currentFailure]} {
  98.     variable currentFailure false
  99.     }
  100.     if {![info exists failFiles]} {
  101.     variable failFiles {}
  102.     }
  103.  
  104.     # Tests should remove all files they create.  The test suite will
  105.     # check the current working dir for files created by the tests.
  106.     # ::tcltest::filesMade keeps track of such files created using the
  107.     # ::tcltest::makeFile and ::tcltest::makeDirectory procedures.
  108.     # ::tcltest::filesExisted stores the names of pre-existing files.
  109.  
  110.     if {![info exists filesMade]} {
  111.     variable filesMade {}
  112.     }
  113.     if {![info exists filesExisted]} {
  114.     variable filesExisted {}
  115.     }
  116.  
  117.     # ::tcltest::numTests will store test files as indices and the list
  118.     # of files (that should not have been) left behind by the test files.
  119.  
  120.     if {![info exists createdNewFiles]} {
  121.     variable createdNewFiles
  122.     array set ::tcltest::createdNewFiles {}
  123.     }
  124.  
  125.     # initialize ::tcltest::numTests array to keep track fo the number of
  126.     # tests that pass, fail, and are skipped.
  127.  
  128.     if {![info exists numTests]} {
  129.     variable numTests
  130.     array set ::tcltest::numTests \
  131.         [list Total 0 Passed 0 Skipped 0 Failed    0] 
  132.     }
  133.  
  134.     # initialize ::tcltest::skippedBecause array to keep track of
  135.     # constraints that kept tests from running; a constraint name of
  136.     # "userSpecifiedSkip" means that the test appeared on the list of tests
  137.     # that matched the -skip value given to the flag; "userSpecifiedNonMatch"
  138.     # means that the test didn't match the argument given to the -match flag;
  139.     # both of these constraints are counted only if ::tcltest::debug is set to
  140.     # true. 
  141.  
  142.     if {![info exists skippedBecause]} {
  143.     variable skippedBecause
  144.     array set ::tcltest::skippedBecause {}
  145.     }
  146.  
  147.     # initialize the ::tcltest::testConstraints array to keep track of valid
  148.     # predefined constraints (see the explanation for the
  149.     # ::tcltest::initConstraints proc for more details).
  150.  
  151.     if {![info exists testConstraints]} {
  152.     variable testConstraints
  153.     array set ::tcltest::testConstraints {}
  154.     }
  155.  
  156.     # Don't run only the constrained tests by default
  157.  
  158.     if {![info exists limitConstraints]} {
  159.     variable limitConstraints false
  160.     }
  161.  
  162.     # A test application has to know how to load the tested commands into
  163.     # the interpreter.
  164.  
  165.     if {![info exists loadScript]} {
  166.     variable loadScript {}
  167.     }
  168.  
  169.     # tests that use threads need to know which is the main thread
  170.  
  171.     if {![info exists mainThread]} {
  172.     variable mainThread 1
  173.     if {[info commands thread::id] != {}} {
  174.         set mainThread [thread::id]
  175.     } elseif {[info commands testthread] != {}} {
  176.         set mainThread [testthread id]
  177.     }
  178.     }
  179.  
  180.     # save the original environment so that it can be restored later
  181.     
  182.     if {![info exists originalEnv]} {
  183.     variable originalEnv
  184.     array set ::tcltest::originalEnv [array get ::env]
  185.     }
  186.  
  187.     # Set ::tcltest::workingDirectory to [pwd]. The default output directory
  188.     # for Tcl tests is the working directory.
  189.  
  190.     if {![info exists workingDirectory]} {
  191.     variable workingDirectory [pwd]
  192.     }
  193.     if {![info exists temporaryDirectory]} {
  194.     variable temporaryDirectory $workingDirectory
  195.     }
  196.  
  197.     # Tests should not rely on the current working directory.
  198.     # Files that are part of the test suite should be accessed relative to 
  199.     # ::tcltest::testsDirectory.
  200.  
  201.     if {![info exists testsDirectory]} {
  202.     set oldpwd [pwd]
  203.     catch {cd [file join [file dirname [info script]] .. .. tests]}
  204.     variable testsDirectory [pwd]
  205.     cd $oldpwd
  206.     unset oldpwd
  207.     }
  208.  
  209.     # the variables and procs that existed when ::tcltest::saveState was
  210.     # called are stored in a variable of the same name
  211.     if {![info exists saveState]} {
  212.     variable saveState {}
  213.     }
  214.  
  215.     # Internationalization support
  216.     if {![info exists isoLocale]} {
  217.     variable isoLocale fr
  218.         switch $tcl_platform(platform) {
  219.         "unix" {
  220.  
  221.         # Try some 'known' values for some platforms:
  222.  
  223.         switch -exact -- $tcl_platform(os) {
  224.             "FreeBSD" {
  225.             set ::tcltest::isoLocale fr_FR.ISO_8859-1
  226.             }
  227.             HP-UX {
  228.             set ::tcltest::isoLocale fr_FR.iso88591
  229.             }
  230.             Linux -
  231.             IRIX {
  232.             set ::tcltest::isoLocale fr
  233.             }
  234.             default {
  235.  
  236.             # Works on SunOS 4 and Solaris, and maybe others...
  237.             # define it to something else on your system
  238.             #if you want to test those.
  239.  
  240.             set ::tcltest::isoLocale iso_8859_1
  241.             }
  242.         }
  243.         }
  244.         "windows" {
  245.         set ::tcltest::isoLocale French
  246.         }
  247.     }
  248.     }
  249.  
  250.     # Set the location of the execuatble
  251.     if {![info exists tcltest]} {
  252.     variable tcltest [info nameofexecutable]
  253.     }
  254.  
  255.     # save the platform information so it can be restored later
  256.     if {![info exists originalTclPlatform]} {
  257.     variable originalTclPlatform [array get tcl_platform]
  258.     }
  259.  
  260.     # If a core file exists, save its modification time.
  261.     if {![info exists coreModificationTime]} {
  262.     if {[file exists [file join $::tcltest::workingDirectory core]]} {
  263.         variable coreModificationTime [file mtime [file join \
  264.             $::tcltest::workingDirectory core]]
  265.     }
  266.     }
  267.  
  268.     # Tcl version numbers
  269.     if {![info exists version]} {
  270.     variable version 8.3
  271.     }
  272.     if {![info exists patchLevel]} {
  273.     variable patchLevel 8.3.0
  274.     }
  275. }   
  276.  
  277. # ::tcltest::Debug* --
  278. #
  279. #     Internal helper procedures to write out debug information
  280. #     dependent on the chosen level. A test shell may overide
  281. #     them, f.e. to redirect the output into a different
  282. #     channel, or even into a GUI.
  283.  
  284. # ::tcltest::DebugPuts --
  285. #
  286. #     Prints the specified string if the current debug level is
  287. #     higher than the provided level argument.
  288. #
  289. # Arguments:
  290. #     level   The lowest debug level triggering the output
  291. #     string  The string to print out.
  292. #
  293. # Results:
  294. #     Prints the string. Nothing else is allowed.
  295. #
  296.  
  297. proc ::tcltest::DebugPuts {level string} {
  298.     variable debug
  299.     if {$debug >= $level} {
  300.     puts $string
  301.     }
  302. }
  303.  
  304. # ::tcltest::DebugPArray --
  305. #
  306. #     Prints the contents of the specified array if the current
  307. #       debug level is higher than the provided level argument
  308. #
  309. # Arguments:
  310. #     level           The lowest debug level triggering the output
  311. #     arrayvar        The name of the array to print out.
  312. #
  313. # Results:
  314. #     Prints the contents of the array. Nothing else is allowed.
  315. #
  316.  
  317. proc ::tcltest::DebugPArray {level arrayvar} {
  318.     variable debug
  319.  
  320.     if {$debug >= $level} {
  321.     catch {upvar  $arrayvar $arrayvar}
  322.     parray $arrayvar
  323.     }
  324. }
  325.  
  326. # ::tcltest::DebugDo --
  327. #
  328. #     Executes the script if the current debug level is greater than
  329. #       the provided level argument
  330. #
  331. # Arguments:
  332. #     level   The lowest debug level triggering the execution.
  333. #     script  The tcl script executed upon a debug level high enough.
  334. #
  335. # Results:
  336. #     Arbitrary side effects, dependent on the executed script.
  337. #
  338.  
  339. proc ::tcltest::DebugDo {level script} {
  340.     variable debug
  341.  
  342.     if {$debug >= $level} {
  343.     uplevel $script
  344.     }
  345. }
  346.  
  347. # ::tcltest::AddToSkippedBecause --
  348. #
  349. #    Increments the variable used to track how many tests were skipped
  350. #       because of a particular constraint.
  351. #
  352. # Arguments:
  353. #    constraint     The name of the constraint to be modified
  354. #
  355. # Results:
  356. #    Modifies ::tcltest::skippedBecause; sets the variable to 1 if didn't
  357. #       previously exist - otherwise, it just increments it.
  358.  
  359. proc ::tcltest::AddToSkippedBecause { constraint } {
  360.     # add the constraint to the list of constraints that kept tests
  361.     # from running
  362.  
  363.     if {[info exists ::tcltest::skippedBecause($constraint)]} {
  364.     incr ::tcltest::skippedBecause($constraint)
  365.     } else {
  366.     set ::tcltest::skippedBecause($constraint) 1
  367.     }
  368.     return
  369. }
  370.  
  371. # ::tcltest::PrintError --
  372. #
  373. #    Prints errors to ::tcltest::errorChannel and then flushes that
  374. #       channel, making sure that all messages are < 80 characters per line.
  375. #
  376. # Arguments:
  377. #    errorMsg     String containing the error to be printed
  378. #
  379.  
  380. proc ::tcltest::PrintError {errorMsg} {
  381.     set InitialMessage "Error:  "
  382.     set InitialMsgLen  [string length $InitialMessage]
  383.     puts -nonewline $::tcltest::errorChannel $InitialMessage
  384.  
  385.     # Keep track of where the end of the string is.
  386.     set endingIndex [string length $errorMsg]
  387.  
  388.     if {$endingIndex < 80} {
  389.     puts $::tcltest::errorChannel $errorMsg
  390.     } else {
  391.     # Print up to 80 characters on the first line, including the
  392.     # InitialMessage. 
  393.     set beginningIndex [string last " " [string range $errorMsg 0 \
  394.         [expr {80 - $InitialMsgLen}]]]
  395.     puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex]
  396.  
  397.     while {$beginningIndex != "end"} {
  398.         puts -nonewline $::tcltest::errorChannel \
  399.             [string repeat " " $InitialMsgLen]  
  400.         if {[expr {$endingIndex - $beginningIndex}] < 72} {
  401.         puts $::tcltest::errorChannel [string trim \
  402.             [string range $errorMsg $beginningIndex end]]
  403.         set beginningIndex end
  404.         } else {
  405.         set newEndingIndex [expr [string last " " [string range \
  406.             $errorMsg $beginningIndex \
  407.             [expr {$beginningIndex + 72}]]] + $beginningIndex]
  408.         if {($newEndingIndex <= 0) \
  409.             || ($newEndingIndex <= $beginningIndex)} {
  410.             set newEndingIndex end
  411.         }
  412.         puts $::tcltest::errorChannel [string trim \
  413.             [string range $errorMsg \
  414.             $beginningIndex $newEndingIndex]]
  415.         set beginningIndex $newEndingIndex
  416.         }
  417.     }
  418.     }
  419.     flush $::tcltest::errorChannel
  420.     return
  421. }
  422.  
  423. if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} {
  424.     proc ::tcltest::initConstraintsHook {} {}
  425. }
  426.  
  427. # ::tcltest::initConstraints --
  428. #
  429. # Check Constraintsuration information that will determine which tests
  430. # to run.  To do this, create an array ::tcltest::testConstraints.  Each
  431. # element has a 0 or 1 value.  If the element is "true" then tests
  432. # with that constraint will be run, otherwise tests with that constraint
  433. # will be skipped.  See the tcltest man page for the list of built-in
  434. # constraints defined in this procedure.
  435. #
  436. # Arguments:
  437. #    none
  438. #
  439. # Results:
  440. #    The ::tcltest::testConstraints array is reset to have an index for
  441. #    each built-in test constraint.
  442.  
  443. proc ::tcltest::initConstraints {} {
  444.     global tcl_platform tcl_interactive tk_version
  445.  
  446.     # The following trace procedure makes it so that we can safely refer to
  447.     # non-existent members of the ::tcltest::testConstraints array without
  448.     # causing an error.  Instead, reading a non-existent member will return 0.
  449.     # This is necessary because tests are allowed to use constraint "X" without
  450.     # ensuring that ::tcltest::testConstraints("X") is defined.
  451.  
  452.     trace variable ::tcltest::testConstraints r ::tcltest::safeFetch
  453.  
  454.     proc ::tcltest::safeFetch {n1 n2 op} {
  455.     if {($n2 != {}) && ([info exists ::tcltest::testConstraints($n2)] == 0)} {
  456.         set ::tcltest::testConstraints($n2) 0
  457.     }
  458.     }
  459.  
  460.     ::tcltest::initConstraintsHook
  461.  
  462.     set ::tcltest::testConstraints(unixOnly) \
  463.         [string equal $tcl_platform(platform) "unix"]
  464.     set ::tcltest::testConstraints(macOnly) \
  465.         [string equal $tcl_platform(platform) "macintosh"]
  466.     set ::tcltest::testConstraints(pcOnly) \
  467.         [string equal $tcl_platform(platform) "windows"]
  468.  
  469.     set ::tcltest::testConstraints(unix) $::tcltest::testConstraints(unixOnly)
  470.     set ::tcltest::testConstraints(mac) $::tcltest::testConstraints(macOnly)
  471.     set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly)
  472.  
  473.     set ::tcltest::testConstraints(unixOrPc) \
  474.         [expr {$::tcltest::testConstraints(unix) \
  475.         || $::tcltest::testConstraints(pc)}]
  476.     set ::tcltest::testConstraints(macOrPc) \
  477.         [expr {$::tcltest::testConstraints(mac) \
  478.         || $::tcltest::testConstraints(pc)}]
  479.     set ::tcltest::testConstraints(macOrUnix) \
  480.         [expr {$::tcltest::testConstraints(mac) \
  481.         || $::tcltest::testConstraints(unix)}]
  482.  
  483.     set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \
  484.         "Windows NT"]
  485.     set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) \
  486.         "Windows 95"]
  487.     set ::tcltest::testConstraints(98) [string equal $tcl_platform(os) \
  488.         "Windows 98"]
  489.  
  490.     # The following Constraints switches are used to mark tests that should
  491.     # work, but have been temporarily disabled on certain platforms because
  492.     # they don't and we haven't gotten around to fixing the underlying
  493.     # problem. 
  494.  
  495.     set ::tcltest::testConstraints(tempNotPc) \
  496.         [expr {!$::tcltest::testConstraints(pc)}]
  497.     set ::tcltest::testConstraints(tempNotMac) \
  498.         [expr {!$::tcltest::testConstraints(mac)}]
  499.     set ::tcltest::testConstraints(tempNotUnix) \
  500.         [expr {!$::tcltest::testConstraints(unix)}]
  501.  
  502.     # The following Constraints switches are used to mark tests that crash on
  503.     # certain platforms, so that they can be reactivated again when the
  504.     # underlying problem is fixed.
  505.  
  506.     set ::tcltest::testConstraints(pcCrash) \
  507.         [expr {!$::tcltest::testConstraints(pc)}]
  508.     set ::tcltest::testConstraints(macCrash) \
  509.         [expr {!$::tcltest::testConstraints(mac)}]
  510.     set ::tcltest::testConstraints(unixCrash) \
  511.         [expr {!$::tcltest::testConstraints(unix)}]
  512.  
  513.     # Skip empty tests
  514.  
  515.     set ::tcltest::testConstraints(emptyTest) 0
  516.  
  517.     # By default, tests that expose known bugs are skipped.
  518.  
  519.     set ::tcltest::testConstraints(knownBug) 0
  520.  
  521.     # By default, non-portable tests are skipped.
  522.  
  523.     set ::tcltest::testConstraints(nonPortable) 0
  524.  
  525.     # Some tests require user interaction.
  526.  
  527.     set ::tcltest::testConstraints(userInteraction) 0
  528.  
  529.     # Some tests must be skipped if the interpreter is not in interactive mode
  530.     
  531.     if {[info exists tcl_interactive]} {
  532.     set ::tcltest::testConstraints(interactive) $::tcl_interactive
  533.     } else {
  534.     set ::tcltest::testConstraints(interactive) 0
  535.     }
  536.  
  537.     # Some tests can only be run if the installation came from a CD image
  538.     # instead of a web image
  539.     # Some tests must be skipped if you are running as root on Unix.
  540.     # Other tests can only be run if you are running as root on Unix.
  541.  
  542.     set ::tcltest::testConstraints(root) 0
  543.     set ::tcltest::testConstraints(notRoot) 1
  544.     set user {}
  545.     if {[string equal $tcl_platform(platform) "unix"]} {
  546.     catch {set user [exec whoami]}
  547.     if {[string equal $user ""]} {
  548.         catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
  549.     }
  550.     if {([string equal $user "root"]) || ([string equal $user ""])} {
  551.         set ::tcltest::testConstraints(root) 1
  552.         set ::tcltest::testConstraints(notRoot) 0
  553.     }
  554.     }
  555.  
  556.     # Set nonBlockFiles constraint: 1 means this platform supports
  557.     # setting files into nonblocking mode.
  558.  
  559.     if {[catch {set f [open defs r]}]} {
  560.     set ::tcltest::testConstraints(nonBlockFiles) 1
  561.     } else {
  562.     if {[catch {fconfigure $f -blocking off}] == 0} {
  563.         set ::tcltest::testConstraints(nonBlockFiles) 1
  564.     } else {
  565.         set ::tcltest::testConstraints(nonBlockFiles) 0
  566.     }
  567.     close $f
  568.     }
  569.  
  570.     # Set asyncPipeClose constraint: 1 means this platform supports
  571.     # async flush and async close on a pipe.
  572.     #
  573.     # Test for SCO Unix - cannot run async flushing tests because a
  574.     # potential problem with select is apparently interfering.
  575.     # (Mark Diekhans).
  576.  
  577.     if {[string equal $tcl_platform(platform) "unix"]} {
  578.     if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
  579.         set ::tcltest::testConstraints(asyncPipeClose) 0
  580.     } else {
  581.         set ::tcltest::testConstraints(asyncPipeClose) 1
  582.     }
  583.     } else {
  584.     set ::tcltest::testConstraints(asyncPipeClose) 1
  585.     }
  586.  
  587.     # Test to see if we have a broken version of sprintf with respect
  588.     # to the "e" format of floating-point numbers.
  589.  
  590.     set ::tcltest::testConstraints(eformat) 1
  591.     if {![string equal "[format %g 5e-5]" "5e-05"]} {
  592.     set ::tcltest::testConstraints(eformat) 0
  593.     }
  594.  
  595.     # Test to see if execed commands such as cat, echo, rm and so forth are
  596.     # present on this machine.
  597.  
  598.     set ::tcltest::testConstraints(unixExecs) 1
  599.     if {[string equal $tcl_platform(platform) "macintosh"]} {
  600.     set ::tcltest::testConstraints(unixExecs) 0
  601.     }
  602.     if {($::tcltest::testConstraints(unixExecs) == 1) && \
  603.         ([string equal $tcl_platform(platform) "windows"])} {
  604.     if {[catch {exec cat defs}] == 1} {
  605.         set ::tcltest::testConstraints(unixExecs) 0
  606.     }
  607.     if {($::tcltest::testConstraints(unixExecs) == 1) && \
  608.         ([catch {exec echo hello}] == 1)} {
  609.         set ::tcltest::testConstraints(unixExecs) 0
  610.     }
  611.     if {($::tcltest::testConstraints(unixExecs) == 1) && \
  612.         ([catch {exec sh -c echo hello}] == 1)} {
  613.         set ::tcltest::testConstraints(unixExecs) 0
  614.     }
  615.     if {($::tcltest::testConstraints(unixExecs) == 1) && \
  616.         ([catch {exec wc defs}] == 1)} {
  617.         set ::tcltest::testConstraints(unixExecs) 0
  618.     }
  619.     if {$::tcltest::testConstraints(unixExecs) == 1} {
  620.         exec echo hello > removeMe
  621.         if {[catch {exec rm removeMe}] == 1} {
  622.         set ::tcltest::testConstraints(unixExecs) 0
  623.         }
  624.     }
  625.     if {($::tcltest::testConstraints(unixExecs) == 1) && \
  626.         ([catch {exec sleep 1}] == 1)} {
  627.         set ::tcltest::testConstraints(unixExecs) 0
  628.     }
  629.     if {($::tcltest::testConstraints(unixExecs) == 1) && \
  630.         ([catch {exec fgrep unixExecs defs}] == 1)} {
  631.         set ::tcltest::testConstraints(unixExecs) 0
  632.     }
  633.     if {($::tcltest::testConstraints(unixExecs) == 1) && \
  634.         ([catch {exec ps}] == 1)} {
  635.         set ::tcltest::testConstraints(unixExecs) 0
  636.     }
  637.     if {($::tcltest::testConstraints(unixExecs) == 1) && \
  638.         ([catch {exec echo abc > removeMe}] == 0) && \
  639.         ([catch {exec chmod 644 removeMe}] == 1) && \
  640.         ([catch {exec rm removeMe}] == 0)} {
  641.         set ::tcltest::testConstraints(unixExecs) 0
  642.     } else {
  643.         catch {exec rm -f removeMe}
  644.     }
  645.     if {($::tcltest::testConstraints(unixExecs) == 1) && \
  646.         ([catch {exec mkdir removeMe}] == 1)} {
  647.         set ::tcltest::testConstraints(unixExecs) 0
  648.     } else {
  649.         catch {exec rm -r removeMe}
  650.     }
  651.     }
  652.  
  653.     # Locate tcltest executable
  654.  
  655.     if {![info exists tk_version]} {
  656.     set tcltest [info nameofexecutable]
  657.  
  658.     if {$tcltest == "{}"} {
  659.         set tcltest {}
  660.     }
  661.     }
  662.  
  663.     set ::tcltest::testConstraints(stdio) 0
  664.     catch {
  665.     catch {file delete -force tmp}
  666.     set f [open tmp w]
  667.     puts $f {
  668.         exit
  669.     }
  670.     close $f
  671.  
  672.     set f [open "|[list $tcltest tmp]" r]
  673.     close $f
  674.     
  675.     set ::tcltest::testConstraints(stdio) 1
  676.     }
  677.     catch {file delete -force tmp}
  678.  
  679.     # Deliberately call socket with the wrong number of arguments.  The error
  680.     # message you get will indicate whether sockets are available on this
  681.     # system. 
  682.  
  683.     catch {socket} msg
  684.     set ::tcltest::testConstraints(socket) \
  685.         [expr {$msg != "sockets are not available on this system"}]
  686.     
  687.     # Check for internationalization
  688.  
  689.     if {[info commands testlocale] == ""} {
  690.     # No testlocale command, no tests...
  691.     set ::tcltest::testConstraints(hasIsoLocale) 0
  692.     } else {
  693.     set ::tcltest::testConstraints(hasIsoLocale) \
  694.         [string length [::tcltest::set_iso8859_1_locale]]
  695.     ::tcltest::restore_locale
  696.     }
  697. }   
  698.  
  699. # ::tcltest::PrintUsageInfoHook
  700. #
  701. #       Hook used for customization of display of usage information.
  702. #
  703.  
  704. if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} {
  705.     proc ::tcltest::PrintUsageInfoHook {} {}
  706. }
  707.  
  708. # ::tcltest::PrintUsageInfo
  709. #
  710. #    Prints out the usage information for package tcltest.  This can be
  711. #       customized with the redefinition of ::tcltest::PrintUsageInfoHook.
  712. #
  713. # Arguments:
  714. #    none
  715. #
  716.  
  717. proc ::tcltest::PrintUsageInfo {} {
  718.     puts [format "Usage: [file tail [info nameofexecutable]] \
  719.         script ?-help? ?flag value? ... \n\
  720.         Available flags (and valid input values) are: \n\
  721.         -help          \t Display this usage information. \n\
  722.         -verbose level \t Takes any combination of the values \n\
  723.         \t                 'p', 's' and 'b'.  Test suite will \n\
  724.         \t                 display all passed tests if 'p' is \n\
  725.         \t                 specified, all skipped tests if 's' \n\
  726.         \t                 is specified, and the bodies of \n\
  727.         \t                 failed tests if 'b' is specified. \n\
  728.         \t                 The default value is 'b'. \n\
  729.         -constraints list\t Do not skip the listed constraints\n\
  730.         -limitconstraints bool\t Only run tests with the constraints\n\
  731.         \t                 listed in -constraints.\n\
  732.         -match pattern \t Run all tests within the specified \n\
  733.         \t                 files that match the glob pattern \n\
  734.         \t                 given. \n\
  735.         -skip pattern  \t Skip all tests within the set of \n\
  736.         \t                 specified tests (via -match) and \n\
  737.         \t                 files that match the glob pattern \n\
  738.         \t                 given. \n\
  739.         -file pattern  \t Run tests in all test files that \n\
  740.         \t                 match the glob pattern given. \n\
  741.         -notfile pattern\t Skip all test files that match the \n\
  742.         \t                 glob pattern given. \n\
  743.         -preservecore level \t If 2, save any core files produced \n\
  744.         \t                 during testing in the directory \n\
  745.         \t                 specified by -tmpdir. If 1, notify the\n\
  746.         \t                 user if core files are created. The default \n\
  747.         \t                 is $::tcltest::preserveCore. \n\
  748.         -tmpdir directory\t Save temporary files in the specified\n\
  749.         \t                 directory.  The default value is \n\
  750.         \t                 $::tcltest::temporaryDirectory. \n\
  751.         -testdir directories\t Search tests in the specified\n\
  752.         \t                 directories.  The default value is \n\
  753.         \t                 $::tcltest::testsDirectory. \n\
  754.         -outfile file    \t Send output from test runs to the \n\
  755.         \t                 specified file.  The default is \n\
  756.         \t                 stdout. \n\
  757.         -errfile file    \t Send errors from test runs to the \n\
  758.         \t                 specified file.  The default is \n\
  759.         \t                 stderr. \n\
  760.         -loadfile file   \t Read the script to load the tested \n\
  761.         \t                 commands from the specified file. \n\
  762.         -load script     \t Specifies the script to load the tested \n\
  763.         \t                 commands. \n\
  764.         -debug level     \t Internal debug flag."]
  765.     ::tcltest::PrintUsageInfoHook
  766.     return
  767. }
  768.  
  769. # ::tcltest::CheckDirectory --
  770. #
  771. #     This procedure checks whether the specified path is a readable
  772. #     and/or writable directory. If one of the conditions is not
  773. #     satisfied an error is printed and the application aborted. The
  774. #     procedure assumes that the caller already checked the existence
  775. #     of the path.
  776. #
  777. # Arguments
  778. #     rw      Information what attributes to check. Allowed values:
  779. #             r, w, rw, wr. If 'r' is part of the value the directory
  780. #             must be readable. 'w' associates to 'writable'.
  781. #     dir     The directory to check.
  782. #     errMsg  The string to prepend to the actual error message before
  783. #             printing it.
  784. #
  785. # Results
  786. #     none
  787. #
  788.  
  789. proc ::tcltest::CheckDirectory {rw dir errMsg} {
  790.     # Allowed values for 'rw': r, w, rw, wr
  791.  
  792.     if {![file isdir $dir]} { 
  793.     ::tcltest::PrintError "$errMsg \"$dir\" is not a directory"
  794.     exit 1
  795.     } elseif {([string first w $rw] >= 0) && ![file writable $dir]} {
  796.     ::tcltest::PrintError "$errMsg \"$dir\" is not writeable"
  797.     exit 1
  798.     } elseif {([string first r $rw] >= 0) && ![file readable $dir]} {
  799.     ::tcltest::PrintError "$errMsg \"$dir\" is not readable"
  800.     exit 1
  801.     }
  802. }
  803.  
  804. # ::tcltest::normalizePath --
  805. #
  806. #     This procedure resolves any symlinks in the path thus creating a
  807. #     path without internal redirection. It assumes that the incoming
  808. #     path is absolute.
  809. #
  810. # Arguments
  811. #     pathVar contains the name of the variable containing the path to modify.
  812. #
  813. # Results
  814. #     The path is modified in place.
  815. #
  816.  
  817. proc ::tcltest::normalizePath {pathVar} {
  818.     upvar $pathVar path
  819.  
  820.     set oldpwd [pwd]
  821.     catch {cd $path}
  822.     set path [pwd]
  823.     cd $oldpwd
  824. }
  825.  
  826. # ::tcltest::MakeAbsolutePath --
  827. #
  828. #     This procedure checks whether the incoming path is absolute or not.
  829. #     Makes it absolute if it was not.
  830. #
  831. # Arguments
  832. #     pathVar contains the name of the variable containing the path to modify.
  833. #     prefix  is optional, contains the path to use to make the other an
  834. #             absolute one. The current working directory is used if it was
  835. #             not specified.
  836. #
  837. # Results
  838. #     The path is modified in place.
  839. #
  840.  
  841. proc ::tcltest::MakeAbsolutePath {pathVar {prefix {}}} {
  842.     upvar $pathVar path
  843.  
  844.     if {![string equal [file pathtype $path] "absolute"]} { 
  845.     if {$prefix == {}} {
  846.         set prefix [pwd]
  847.     }
  848.  
  849.     set path [file join $prefix $path] 
  850.     }
  851. }
  852.  
  853. # ::tcltest::processCmdLineArgsFlagsHook --
  854. #
  855. #    This hook is used to add to the list of command line arguments that are
  856. #       processed by ::tcltest::processCmdLineArgs. 
  857. #
  858.  
  859. if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} {
  860.     proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
  861. }
  862.  
  863. # ::tcltest::processCmdLineArgsHook --
  864. #
  865. #    This hook is used to actually process the flags added by
  866. #       ::tcltest::processCmdLineArgsAddFlagsHook.
  867. #
  868. # Arguments:
  869. #    flags      The flags that have been pulled out of argv
  870. #
  871.  
  872. if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} {
  873.     proc ::tcltest::processCmdLineArgsHook {flag} {}
  874. }
  875.  
  876. # ::tcltest::processCmdLineArgs --
  877. #
  878. #    Use command line args to set the verbose, skip, and
  879. #    match, outputChannel, errorChannel, debug, and temporaryDirectory
  880. #       variables.   
  881. #
  882. #       This procedure must be run after constraints are initialized, because
  883. #       some constraints can be overridden.
  884. #
  885. # Arguments:
  886. #    none
  887. #
  888. # Results:
  889. #    Sets the above-named variables in the tcltest namespace.
  890.  
  891. proc ::tcltest::processCmdLineArgs {} {
  892.     global argv
  893.  
  894.     # The "argv" var doesn't exist in some cases, so use {}.
  895.  
  896.     if {(![info exists argv]) || ([llength $argv] < 1)} {
  897.     set flagArray {}
  898.     } else {
  899.     set flagArray $argv
  900.     }
  901.     
  902.     # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
  903.     # Note that -verbose cannot be abbreviated to -v in wish because it
  904.     # conflicts with the wish option -visual.
  905.  
  906.     # Process -help first
  907.     if {([lsearch -exact $flagArray {-help}] != -1) || \
  908.         ([lsearch -exact $flagArray {-h}] != -1)} {
  909.     ::tcltest::PrintUsageInfo
  910.     exit 1
  911.     }
  912.  
  913.     if {[catch {array set flag $flagArray}]} {
  914.     ::tcltest::PrintError "odd number of arguments specified on command line: \ 
  915.     $argv"
  916.     ::tcltest::PrintUsageInfo
  917.     exit 1
  918.     }
  919.  
  920.     # -help is not listed since it has already been processed
  921.     lappend defaultFlags -verbose -match -skip -constraints \
  922.         -outfile -errfile -debug -tmpdir -file -notfile \
  923.         -preservecore -limitconstraints -args -testdir \
  924.         -load -loadfile
  925.     set defaultFlags [concat $defaultFlags \
  926.         [ ::tcltest::processCmdLineArgsAddFlagsHook ]]
  927.  
  928.     foreach arg $defaultFlags {
  929.     set abbrev [string range $arg 0 1]
  930.     if {([info exists flag($abbrev)]) && \
  931.         ([lsearch -exact $flagArray $arg] < [lsearch -exact \
  932.         $flagArray $abbrev])} { 
  933.         set flag($arg) $flag($abbrev)
  934.     }
  935.     }
  936.  
  937.     # Set ::tcltest::parameters to the arg of the -args flag, if given
  938.     if {[info exists flag(-args)]} {
  939.     set ::tcltest::parameters $flag(-args)
  940.     }
  941.  
  942.     # Set ::tcltest::verbose to the arg of the -verbose flag, if given
  943.  
  944.     if {[info exists flag(-verbose)]} {
  945.     set ::tcltest::verbose $flag(-verbose)
  946.     }
  947.  
  948.     # Set ::tcltest::match to the arg of the -match flag, if given.  
  949.  
  950.     if {[info exists flag(-match)]} {
  951.     set ::tcltest::match $flag(-match)
  952.     } 
  953.  
  954.     # Set ::tcltest::skip to the arg of the -skip flag, if given
  955.  
  956.     if {[info exists flag(-skip)]} {
  957.     set ::tcltest::skip $flag(-skip)
  958.     }
  959.  
  960.     # Handle the -file and -notfile flags
  961.     if {[info exists flag(-file)]} {
  962.     set ::tcltest::matchFiles $flag(-file)
  963.     }
  964.     if {[info exists flag(-notfile)]} {
  965.     set ::tcltest::skipFiles $flag(-notfile)
  966.     }
  967.  
  968.     # Use the -constraints flag, if given, to turn on constraints that are
  969.     # turned off by default: userInteractive knownBug nonPortable.  This
  970.     # code fragment must be run after constraints are initialized.
  971.  
  972.     if {[info exists flag(-constraints)]} {
  973.     foreach elt $flag(-constraints) {
  974.         set ::tcltest::testConstraints($elt) 1
  975.     }
  976.     }
  977.  
  978.     # Use the -limitconstraints flag, if given, to tell the harness to limit
  979.     # tests run to those that were specified using the -constraints flag.  If
  980.     # the -constraints flag was not specified, print out an error and exit.
  981.     if {[info exists flag(-limitconstraints)]} {
  982.     if {![info exists flag(-constraints)]} {
  983.         puts "You can only use the -limitconstraints flag with \
  984.             -constraints"
  985.         exit 1
  986.     }
  987.     set ::tcltest::limitConstraints $flag(-limitconstraints)
  988.     foreach elt [array names ::tcltest::testConstraints] {
  989.         if {[lsearch -exact $flag(-constraints) $elt] == -1} {
  990.         set ::tcltest::testConstraints($elt) 0
  991.         }
  992.     }
  993.     }
  994.  
  995.     # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if
  996.     # given.
  997.     # 
  998.     # If the path is relative, make it absolute.  If the file exists but
  999.     # is not a dir, then return an error.
  1000.     #
  1001.     # If ::tcltest::temporaryDirectory does not already exist, create it.
  1002.     # If you cannot create it, then return an error.
  1003.  
  1004.     set tmpDirError ""
  1005.     if {[info exists flag(-tmpdir)]} {
  1006.     set ::tcltest::temporaryDirectory $flag(-tmpdir)
  1007.     
  1008.     MakeAbsolutePath ::tcltest::temporaryDirectory
  1009.     set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: "
  1010.     }
  1011.     if {[file exists $::tcltest::temporaryDirectory]} {
  1012.     ::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError
  1013.     } else {
  1014.     file mkdir $::tcltest::temporaryDirectory
  1015.     }
  1016.  
  1017.     normalizePath ::tcltest::temporaryDirectory
  1018.  
  1019.     # Set the ::tcltest::testsDirectory to the arg of -testdir, if
  1020.     # given.
  1021.     # 
  1022.     # If the path is relative, make it absolute.  If the file exists but
  1023.     # is not a dir, then return an error.
  1024.     #
  1025.     # If ::tcltest::temporaryDirectory does not already exist return an error.
  1026.     
  1027.     set testDirError ""
  1028.     if {[info exists flag(-testdir)]} {
  1029.     set ::tcltest::testsDirectory $flag(-testdir)
  1030.     
  1031.     MakeAbsolutePath ::tcltest::testsDirectory
  1032.     set testDirError "bad argument \"$flag(-testdir)\" to -testdir: "
  1033.     }
  1034.     if {[file exists $::tcltest::testsDirectory]} {
  1035.     ::tcltest::CheckDirectory r $::tcltest::testsDirectory $testDirError
  1036.     } else {
  1037.     ::tcltest::PrintError "$testDirError \"$::tcltest::testsDirectory\" \
  1038.         does not exist"
  1039.     exit 1
  1040.     }
  1041.     
  1042.     normalizePath ::tcltest::testsDirectory
  1043.     
  1044.     # Save the names of files that already exist in
  1045.     # the output directory.
  1046.     foreach file [glob -nocomplain \
  1047.         [file join $::tcltest::temporaryDirectory *]] {
  1048.     lappend ::tcltest::filesExisted [file tail $file]
  1049.     }
  1050.  
  1051.     # If an alternate error or output files are specified, change the
  1052.     # default channels.
  1053.  
  1054.     if {[info exists flag(-outfile)]} {
  1055.     set tmp $flag(-outfile)
  1056.     MakeAbsolutePath tmp $::tcltest::temporaryDirectory
  1057.     set ::tcltest::outputChannel [open $tmp w]
  1058.     } 
  1059.  
  1060.     if {[info exists flag(-errfile)]} {
  1061.     set tmp $flag(-errfile)
  1062.     MakeAbsolutePath tmp $::tcltest::temporaryDirectory
  1063.     set ::tcltest::errorChannel [open $tmp w]
  1064.     }
  1065.  
  1066.     # If a load script was specified, either directly or through
  1067.     # a file, remember it for later usage.
  1068.     
  1069.     if {[info exists flag(-load)] &&  \
  1070.         ([lsearch -exact $flagArray -load] > \
  1071.         [lsearch -exact $flagArray -loadfile])} {
  1072.         set ::tcltest::loadScript $flag(-load)
  1073.     }
  1074.     
  1075.     if {[info exists flag(-loadfile)] && \
  1076.         ([lsearch -exact $flagArray -loadfile] > \
  1077.         [lsearch -exact $flagArray -load]) } {
  1078.     set tmp $flag(-loadfile)
  1079.     MakeAbsolutePath tmp $::tcltest::temporaryDirectory
  1080.     set tmp [open $tmp r]
  1081.     set ::tcltest::loadScript [read $tmp]
  1082.     close $tmp
  1083.     }
  1084.  
  1085.     # If the user specifies debug testing, print out extra information during
  1086.     # the run.
  1087.     if {[info exists flag(-debug)]} {
  1088.     set ::tcltest::debug $flag(-debug)
  1089.     }
  1090.  
  1091.     # Handle -preservecore
  1092.     if {[info exists flag(-preservecore)]} {
  1093.     set ::tcltest::preserveCore $flag(-preservecore)
  1094.     }
  1095.  
  1096.     # Call the hook
  1097.     ::tcltest::processCmdLineArgsHook [array get flag]
  1098.  
  1099.     # Spit out everything you know if we're at a debug level 2 or greater
  1100.  
  1101.     DebugPuts    2 "Flags passed into tcltest:"
  1102.     DebugPArray  2 flag
  1103.     DebugPuts    2 "::tcltest::debug              = $::tcltest::debug"
  1104.     DebugPuts    2 "::tcltest::testsDirectory     = $::tcltest::testsDirectory"
  1105.     DebugPuts    2 "::tcltest::workingDirectory   = $::tcltest::workingDirectory"
  1106.     DebugPuts    2 "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory"
  1107.     DebugPuts    2 "::tcltest::outputChannel      = $::tcltest::outputChannel"
  1108.     DebugPuts    2 "::tcltest::errorChannel       = $::tcltest::errorChannel"
  1109.     DebugPuts    2 "Original environment (::tcltest::originalEnv):"
  1110.     DebugPArray  2 ::tcltest::originalEnv
  1111.     DebugPuts    2 "Constraints:"
  1112.     DebugPArray  2 ::tcltest::testConstraints
  1113. }
  1114.  
  1115. # ::tcltest::loadTestedCommands --
  1116. #
  1117. #     Uses the specified script to load the commands to test. Allowed to
  1118. #     be empty, as the tested commands could have been compiled into the
  1119. #     interpreter.
  1120. #
  1121. # Arguments
  1122. #     none
  1123. #
  1124. # Results
  1125. #     none
  1126.  
  1127. proc ::tcltest::loadTestedCommands {} {
  1128.     if {$::tcltest::loadScript == {}} {
  1129.     return
  1130.     }
  1131.     
  1132.     uplevel #0 $::tcltest::loadScript
  1133. }
  1134.  
  1135. # ::tcltest::cleanupTests --
  1136. #
  1137. # Remove files and dirs created using the makeFile and makeDirectory
  1138. # commands since the last time this proc was invoked.
  1139. #
  1140. # Print the names of the files created without the makeFile command
  1141. # since the tests were invoked.
  1142. #
  1143. # Print the number tests (total, passed, failed, and skipped) since the
  1144. # tests were invoked.
  1145. # 
  1146. # Restore original environment (as reported by special variable env).
  1147.  
  1148. proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
  1149.  
  1150.     set testFileName [file tail [info script]]
  1151.  
  1152.     # Call the cleanup hook
  1153.     ::tcltest::cleanupTestsHook 
  1154.  
  1155.     # Remove files and directories created by the :tcltest::makeFile and
  1156.     # ::tcltest::makeDirectory procedures.
  1157.     # Record the names of files in ::tcltest::workingDirectory that were not
  1158.     # pre-existing, and associate them with the test file that created them.
  1159.  
  1160.     if {!$calledFromAllFile} {
  1161.     foreach file $::tcltest::filesMade {
  1162.         if {[file exists $file]} {
  1163.         catch {file delete -force $file}
  1164.         }
  1165.     }
  1166.     set currentFiles {}
  1167.     foreach file [glob -nocomplain \
  1168.         [file join $::tcltest::temporaryDirectory *]] {
  1169.         lappend currentFiles [file tail $file]
  1170.     }
  1171.     set newFiles {}
  1172.     foreach file $currentFiles {
  1173.         if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
  1174.         lappend newFiles $file
  1175.         }
  1176.     }
  1177.     set ::tcltest::filesExisted $currentFiles
  1178.     if {[llength $newFiles] > 0} {
  1179.         set ::tcltest::createdNewFiles($testFileName) $newFiles
  1180.     }
  1181.     }
  1182.  
  1183.     if {$calledFromAllFile || $::tcltest::testSingleFile} {
  1184.  
  1185.     # print stats
  1186.  
  1187.     puts -nonewline $::tcltest::outputChannel "$testFileName:"
  1188.     foreach index [list "Total" "Passed" "Skipped" "Failed"] {
  1189.         puts -nonewline $::tcltest::outputChannel \
  1190.             "\t$index\t$::tcltest::numTests($index)"
  1191.     }
  1192.     puts $::tcltest::outputChannel ""
  1193.  
  1194.     # print number test files sourced
  1195.     # print names of files that ran tests which failed
  1196.  
  1197.     if {$calledFromAllFile} {
  1198.         puts $::tcltest::outputChannel \
  1199.             "Sourced $::tcltest::numTestFiles Test Files."
  1200.         set ::tcltest::numTestFiles 0
  1201.         if {[llength $::tcltest::failFiles] > 0} {
  1202.         puts $::tcltest::outputChannel \
  1203.             "Files with failing tests: $::tcltest::failFiles"
  1204.         set ::tcltest::failFiles {}
  1205.         }
  1206.     }
  1207.  
  1208.     # if any tests were skipped, print the constraints that kept them
  1209.     # from running.
  1210.  
  1211.     set constraintList [array names ::tcltest::skippedBecause]
  1212.     if {[llength $constraintList] > 0} {
  1213.         puts $::tcltest::outputChannel \
  1214.             "Number of tests skipped for each constraint:"
  1215.         foreach constraint [lsort $constraintList] {
  1216.         puts $::tcltest::outputChannel \
  1217.             "\t$::tcltest::skippedBecause($constraint)\t$constraint"
  1218.         unset ::tcltest::skippedBecause($constraint)
  1219.         }
  1220.     }
  1221.  
  1222.     # report the names of test files in ::tcltest::createdNewFiles, and
  1223.     # reset the array to be empty.
  1224.  
  1225.     set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
  1226.     if {[llength $testFilesThatTurded] > 0} {
  1227.         puts $::tcltest::outputChannel "Warning: files left behind:"
  1228.         foreach testFile $testFilesThatTurded {
  1229.         puts $::tcltest::outputChannel \
  1230.             "\t$testFile:\t$::tcltest::createdNewFiles($testFile)"
  1231.         unset ::tcltest::createdNewFiles($testFile)
  1232.         }
  1233.     }
  1234.  
  1235.     # reset filesMade, filesExisted, and numTests
  1236.  
  1237.     set ::tcltest::filesMade {}
  1238.     foreach index [list "Total" "Passed" "Skipped" "Failed"] {
  1239.         set ::tcltest::numTests($index) 0
  1240.     }
  1241.  
  1242.     # exit only if running Tk in non-interactive mode
  1243.  
  1244.     global tk_version tcl_interactive
  1245.     if {[info exists tk_version] && ![info exists tcl_interactive]} {
  1246.         exit
  1247.     }
  1248.     } else {
  1249.  
  1250.     # if we're deferring stat-reporting until all files are sourced,
  1251.     # then add current file to failFile list if any tests in this file
  1252.     # failed
  1253.  
  1254.     incr ::tcltest::numTestFiles
  1255.     if {($::tcltest::currentFailure) && \
  1256.         ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} {
  1257.         lappend ::tcltest::failFiles $testFileName
  1258.     }
  1259.     set ::tcltest::currentFailure false
  1260.  
  1261.     # restore the environment to the state it was in before this package
  1262.     # was loaded
  1263.  
  1264.     set newEnv {}
  1265.     set changedEnv {}
  1266.     set removedEnv {}
  1267.     foreach index [array names ::env] {
  1268.         if {![info exists ::tcltest::originalEnv($index)]} {
  1269.         lappend newEnv $index
  1270.         unset ::env($index)
  1271.         } else {
  1272.         if {$::env($index) != $::tcltest::originalEnv($index)} {
  1273.             lappend changedEnv $index
  1274.             set ::env($index) $::tcltest::originalEnv($index)
  1275.         }
  1276.         }
  1277.     }
  1278.     foreach index [array names ::tcltest::originalEnv] {
  1279.         if {![info exists ::env($index)]} {
  1280.         lappend removedEnv $index
  1281.         set ::env($index) $::tcltest::originalEnv($index)
  1282.         }
  1283.     }
  1284.     if {[llength $newEnv] > 0} {
  1285.         puts $::tcltest::outputChannel \
  1286.             "env array elements created:\t$newEnv"
  1287.     }
  1288.     if {[llength $changedEnv] > 0} {
  1289.         puts $::tcltest::outputChannel \
  1290.             "env array elements changed:\t$changedEnv"
  1291.     }
  1292.     if {[llength $removedEnv] > 0} {
  1293.         puts $::tcltest::outputChannel \
  1294.             "env array elements removed:\t$removedEnv"
  1295.     }
  1296.  
  1297.     set changedTclPlatform {}
  1298.     foreach index [array names ::tcltest::originalTclPlatform] {
  1299.         if {$::tcl_platform($index) != \
  1300.             $::tcltest::originalTclPlatform($index)} { 
  1301.         lappend changedTclPlatform $index
  1302.         set ::tcl_platform($index) \
  1303.             $::tcltest::originalTclPlatform($index) 
  1304.         }
  1305.     }
  1306.     if {[llength $changedTclPlatform] > 0} {
  1307.         puts $::tcltest::outputChannel \
  1308.             "tcl_platform array elements changed:\t$changedTclPlatform"
  1309.     } 
  1310.  
  1311.     if {[file exists [file join $::tcltest::workingDirectory core]]} {
  1312.         if {$::tcltest::preserveCore > 1} {
  1313.         puts $::tcltest::outputChannel "produced core file! \
  1314.             Moving file to: \
  1315.             [file join $::tcltest::temporaryDirectory core-$name]"
  1316.         flush $::tcltest::outputChannel
  1317.         catch {file rename -force \
  1318.             [file join $::tcltest::workingDirectory core] \
  1319.             [file join $::tcltest::temporaryDirectory \
  1320.             core-$name]} msg
  1321.         if {[string length $msg] > 0} {
  1322.             ::tcltest::PrintError "Problem renaming file: $msg"
  1323.         }
  1324.         } else {
  1325.         # Print a message if there is a core file and (1) there
  1326.         # previously wasn't one or (2) the new one is different from
  1327.         # the old one. 
  1328.  
  1329.         if {[info exists ::tcltest::coreModificationTime]} {
  1330.             if {$::tcltest::coreModificationTime != [file mtime \
  1331.                 [file join $::tcltest::workingDirectory core]]} {
  1332.             puts $::tcltest::outputChannel "A core file was created!"
  1333.             }
  1334.         } else {
  1335.             puts $::tcltest::outputChannel "A core file was created!"
  1336.         } 
  1337.         }
  1338.     }
  1339.     }
  1340. }
  1341.  
  1342. # ::tcltest::cleanupTestsHook --
  1343. #
  1344. #    This hook allows a harness that builds upon tcltest to specify
  1345. #       additional things that should be done at cleanup.
  1346. #
  1347.  
  1348. if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} {
  1349.     proc ::tcltest::cleanupTestsHook {} {}
  1350. }
  1351.  
  1352. # test --
  1353. #
  1354. # This procedure runs a test and prints an error message if the test fails.
  1355. # If ::tcltest::verbose has been set, it also prints a message even if the
  1356. # test succeeds.  The test will be skipped if it doesn't match the
  1357. # ::tcltest::match variable, if it matches an element in
  1358. # ::tcltest::skip, or if one of the elements of "constraints" turns
  1359. # out not to be true.
  1360. #
  1361. # Arguments:
  1362. # name -        Name of test, in the form foo-1.2.
  1363. # description -        Short textual description of the test, to
  1364. #            help humans understand what it does.
  1365. # constraints -        A list of one or more keywords, each of
  1366. #            which must be the name of an element in
  1367. #            the array "::tcltest::testConstraints".  If any of these
  1368. #            elements is zero, the test is skipped.
  1369. #            This argument may be omitted.
  1370. # script -        Script to run to carry out the test.  It must
  1371. #            return a result that can be checked for
  1372. #            correctness.
  1373. # expectedAnswer -    Expected result from script.
  1374.  
  1375. proc ::tcltest::test {name description script expectedAnswer args} {
  1376.  
  1377.     DebugPuts 3 "Running $name ($description)"
  1378.  
  1379.     incr ::tcltest::numTests(Total)
  1380.  
  1381.     # skip the test if it's name matches an element of skip
  1382.  
  1383.     foreach pattern $::tcltest::skip {
  1384.     if {[string match $pattern $name]} {
  1385.         incr ::tcltest::numTests(Skipped)
  1386.         DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedSkip}
  1387.         return
  1388.     }
  1389.     }
  1390.  
  1391.     # skip the test if it's name doesn't match any element of match
  1392.  
  1393.     if {[llength $::tcltest::match] > 0} {
  1394.     set ok 0
  1395.     foreach pattern $::tcltest::match {
  1396.         if {[string match $pattern $name]} {
  1397.         set ok 1
  1398.         break
  1399.         }
  1400.         }
  1401.     if {!$ok} {
  1402.         incr ::tcltest::numTests(Skipped)
  1403.         DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch}
  1404.         return
  1405.     }
  1406.     }
  1407.  
  1408.     set i [llength $args]
  1409.     if {$i == 0} {
  1410.     set constraints {}
  1411.     # If we're limited to the listed constraints and there aren't any
  1412.     # listed, then we shouldn't run the test.
  1413.     if {$::tcltest::limitConstraints} {
  1414.         ::tcltest::AddToSkippedBecause userSpecifiedLimitConstraint
  1415.         incr ::tcltest::numTests(Skipped)
  1416.         return
  1417.     }
  1418.     } elseif {$i == 1} {
  1419.  
  1420.     # "constraints" argument exists;  shuffle arguments down, then
  1421.     # make sure that the constraints are satisfied.
  1422.  
  1423.     set constraints $script
  1424.     set script $expectedAnswer
  1425.     set expectedAnswer [lindex $args 0]
  1426.     set doTest 0
  1427.     if {[string match {*[$\[]*} $constraints] != 0} {
  1428.         # full expression, e.g. {$foo > [info tclversion]}
  1429.         catch {set doTest [uplevel #0 expr $constraints]}
  1430.     } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
  1431.         # something like {a || b} should be turned into 
  1432.         # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b).
  1433.          regsub -all {[.\w]+} $constraints \
  1434.             {$::tcltest::testConstraints(&)} c
  1435.         catch {set doTest [eval expr $c]}
  1436.     } else {
  1437.         # just simple constraints such as {unixOnly fonts}.
  1438.         set doTest 1
  1439.         foreach constraint $constraints {
  1440.         if {(![info exists ::tcltest::testConstraints($constraint)]) \
  1441.             || (!$::tcltest::testConstraints($constraint))} {
  1442.             set doTest 0
  1443.  
  1444.             # store the constraint that kept the test from running
  1445.             set constraints $constraint
  1446.             break
  1447.         }
  1448.         }
  1449.     }
  1450.     if {$doTest == 0} {
  1451.         if {[string first s $::tcltest::verbose] != -1} {
  1452.         puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints"
  1453.         }
  1454.  
  1455.         incr ::tcltest::numTests(Skipped)
  1456.         ::tcltest::AddToSkippedBecause $constraints
  1457.         return    
  1458.     }
  1459.     } else {
  1460.     error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
  1461.     }   
  1462.  
  1463.     # Save information about the core file.  You need to restore the original
  1464.     # tcl_platform environment because some of the tests mess with tcl_platform.
  1465.  
  1466.     if {$::tcltest::preserveCore} {
  1467.     set currentTclPlatform [array get tcl_platform]
  1468.     array set tcl_platform $::tcltest::originalTclPlatform
  1469.     if {[file exists [file join $::tcltest::workingDirectory core]]} {
  1470.         set coreModTime [file mtime [file join \
  1471.             $::tcltest::workingDirectory core]]
  1472.     }
  1473.     array set tcl_platform $currentTclPlatform
  1474.     }
  1475.  
  1476.     # If there is no "memory" command (because memory debugging isn't
  1477.     # enabled), then don't attempt to use the command.
  1478.     
  1479.     if {[info commands memory] != {}} {
  1480.     memory tag $name
  1481.     }
  1482.  
  1483.     set code [catch {uplevel $script} actualAnswer]
  1484.     if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} {
  1485.     incr ::tcltest::numTests(Passed)
  1486.     if {[string first p $::tcltest::verbose] != -1} {
  1487.         puts $::tcltest::outputChannel "++++ $name PASSED"
  1488.     }
  1489.     } else {
  1490.     incr ::tcltest::numTests(Failed)
  1491.     set ::tcltest::currentFailure true
  1492.     if {[string first b $::tcltest::verbose] == -1} {
  1493.         set script ""
  1494.     }
  1495.     puts $::tcltest::outputChannel "\n==== $name $description FAILED"
  1496.     if {$script != ""} {
  1497.         puts $::tcltest::outputChannel "==== Contents of test case:"
  1498.         puts $::tcltest::outputChannel $script
  1499.     }
  1500.     if {$code != 0} {
  1501.         if {$code == 1} {
  1502.         puts $::tcltest::outputChannel "==== Test generated error:"
  1503.         puts $::tcltest::outputChannel $actualAnswer
  1504.         } elseif {$code == 2} {
  1505.         puts $::tcltest::outputChannel "==== Test generated return exception;  result was:"
  1506.         puts $::tcltest::outputChannel $actualAnswer
  1507.         } elseif {$code == 3} {
  1508.         puts $::tcltest::outputChannel "==== Test generated break exception"
  1509.         } elseif {$code == 4} {
  1510.         puts $::tcltest::outputChannel "==== Test generated continue exception"
  1511.         } else {
  1512.         puts $::tcltest::outputChannel "==== Test generated exception $code;  message was:"
  1513.         puts $::tcltest::outputChannel $actualAnswer
  1514.         }
  1515.     } else {
  1516.         puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer"
  1517.     }
  1518.     puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer"
  1519.     puts $::tcltest::outputChannel "==== $name FAILED\n"
  1520.     }
  1521.     if {$::tcltest::preserveCore} {
  1522.     set currentTclPlatform [array get tcl_platform]
  1523.     if {[file exists [file join $::tcltest::workingDirectory core]]} {
  1524.         if {$::tcltest::preserveCore > 1} {
  1525.         puts $::tcltest::outputChannel "==== $name produced core file! \
  1526.             Moving file to: \
  1527.             [file join $::tcltest::temporaryDirectory core-$name]"
  1528.         catch {file rename -force \
  1529.             [file join $::tcltest::workingDirectory core] \
  1530.             [file join $::tcltest::temporaryDirectory \
  1531.             core-$name]} msg
  1532.         if {[string length $msg] > 0} {
  1533.             ::tcltest::PrintError "Problem renaming file: $msg"
  1534.         }
  1535.         } else {
  1536.         # Print a message if there is a core file and (1) there
  1537.         # previously wasn't one or (2) the new one is different from
  1538.         # the old one. 
  1539.  
  1540.         if {[info exists coreModTime]} {
  1541.             if {$coreModTime != [file mtime \
  1542.                 [file join $::tcltest::workingDirectory core]]} {
  1543.             puts $::tcltest::outputChannel "==== $name produced core file!"
  1544.             }
  1545.         } else {
  1546.             puts $::tcltest::outputChannel "==== $name produced core file!"
  1547.         } 
  1548.         }
  1549.     }
  1550.     array set tcl_platform $currentTclPlatform
  1551.     }
  1552. }
  1553.  
  1554. # ::tcltest::getMatchingFiles
  1555. #
  1556. #       Looks at the patterns given to match and skip files
  1557. #       and uses them to put together a list of the tests that will be run.
  1558. #
  1559. # Arguments:
  1560. #       none
  1561. #
  1562. # Results:
  1563. #       The constructed list is returned to the user.  This will primarily
  1564. #       be used in 'all.tcl' files.
  1565.  
  1566. proc ::tcltest::getMatchingFiles {args} {
  1567.     set matchingFiles {}
  1568.     if {[llength $args]} {
  1569.     set searchDirectory $args
  1570.     } else {
  1571.     set searchDirectory [list $::tcltest::testsDirectory]
  1572.     }
  1573.     # Find the matching files in the list of directories and then remove the
  1574.     # ones that match the skip pattern
  1575.     foreach directory $searchDirectory {
  1576.     set matchFileList {}
  1577.     foreach match $::tcltest::matchFiles {
  1578.         set matchFileList [concat $matchFileList \
  1579.             [glob -nocomplain [file join $directory $match]]]
  1580.     }
  1581.     if {[string compare {} $::tcltest::skipFiles]} {
  1582.         set skipFileList {}
  1583.         foreach skip $::tcltest::skipFiles {
  1584.         set skipFileList [concat $skipFileList \
  1585.             [glob -nocomplain [file join $directory $skip]]]
  1586.         }
  1587.         foreach file $matchFileList {
  1588.         # Only include files that don't match the skip pattern and
  1589.         # aren't SCCS lock files.
  1590.         if {([lsearch -exact $skipFileList $file] == -1) && \
  1591.             (![string match l.*.test [file tail $file]])} {
  1592.             lappend matchingFiles $file
  1593.         }
  1594.         }
  1595.     } else {
  1596.         set matchingFiles [concat $matchingFiles $matchFileList]
  1597.     }
  1598.     }
  1599.     if {[string equal $matchingFiles {}]} {
  1600.     ::tcltest::PrintError "No test files remain after applying \
  1601.         your match and skip patterns!"
  1602.     }
  1603.     return $matchingFiles
  1604. }
  1605.  
  1606. # The following two procs are used in the io tests.
  1607.  
  1608. proc ::tcltest::openfiles {} {
  1609.     if {[catch {testchannel open} result]} {
  1610.     return {}
  1611.     }
  1612.     return $result
  1613. }
  1614.  
  1615. proc ::tcltest::leakfiles {old} {
  1616.     if {[catch {testchannel open} new]} {
  1617.         return {}
  1618.     }
  1619.     set leak {}
  1620.     foreach p $new {
  1621.         if {[lsearch $old $p] < 0} {
  1622.         lappend leak $p
  1623.     }
  1624.     }
  1625.     return $leak
  1626. }
  1627.  
  1628. # ::tcltest::saveState --
  1629. #
  1630. #    Save information regarding what procs and variables exist.
  1631. #
  1632. # Arguments:
  1633. #    none
  1634. #
  1635. # Results:
  1636. #    Modifies the variable ::tcltest::saveState
  1637.  
  1638. proc ::tcltest::saveState {} {
  1639.     uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
  1640.     DebugPuts  2 "::tcltest::saveState: $::tcltest::saveState"
  1641. }
  1642.  
  1643. # ::tcltest::restoreState --
  1644. #
  1645. #    Remove procs and variables that didn't exist before the call to
  1646. #       ::tcltest::saveState.
  1647. #
  1648. # Arguments:
  1649. #    none
  1650. #
  1651. # Results:
  1652. #    Removes procs and variables from your environment if they don't exist
  1653. #       in the ::tcltest::saveState variable.
  1654.  
  1655. proc ::tcltest::restoreState {} {
  1656.     foreach p [info procs] {
  1657.     if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
  1658.         (![string equal ::tcltest::$p [namespace origin $p]])} {
  1659.         
  1660.         DebugPuts 3 "::tcltest::restoreState: Removing proc $p"
  1661.         rename $p {}
  1662.     }
  1663.     }
  1664.     foreach p [uplevel #0 {info vars}] {
  1665.     if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
  1666.         DebugPuts 3 "::tcltest::restoreState: Removing variable $p"
  1667.         uplevel #0 "catch {unset $p}"
  1668.     }
  1669.     }
  1670. }
  1671.  
  1672. # ::tcltest::normalizeMsg --
  1673. #
  1674. #    Removes "extra" newlines from a string.
  1675. #
  1676. # Arguments:
  1677. #    msg        String to be modified
  1678. #
  1679.  
  1680. proc ::tcltest::normalizeMsg {msg} {
  1681.     regsub "\n$" [string tolower $msg] "" msg
  1682.     regsub -all "\n\n" $msg "\n" msg
  1683.     regsub -all "\n\}" $msg "\}" msg
  1684.     return $msg
  1685. }
  1686.  
  1687. # makeFile --
  1688. #
  1689. # Create a new file with the name <name>, and write <contents> to it.
  1690. #
  1691. # If this file hasn't been created via makeFile since the last time
  1692. # cleanupTests was called, add it to the $filesMade list, so it will
  1693. # be removed by the next call to cleanupTests.
  1694. #
  1695. proc ::tcltest::makeFile {contents name} {
  1696.     global tcl_platform
  1697.     
  1698.     DebugPuts 3 "::tcltest::makeFile: putting $contents into $name"
  1699.  
  1700.     set fullName [file join $::tcltest::temporaryDirectory $name]
  1701.     set fd [open $fullName w]
  1702.  
  1703.     fconfigure $fd -translation lf
  1704.  
  1705.     if {[string equal [string index $contents end] "\n"]} {
  1706.     puts -nonewline $fd $contents
  1707.     } else {
  1708.     puts $fd $contents
  1709.     }
  1710.     close $fd
  1711.  
  1712.     if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
  1713.     lappend ::tcltest::filesMade $fullName
  1714.     }
  1715.     return $fullName
  1716. }
  1717.  
  1718. # ::tcltest::removeFile --
  1719. #
  1720. #    Removes the named file from the filesystem
  1721. #
  1722. # Arguments:
  1723. #    name     file to be removed
  1724. #
  1725.  
  1726. proc ::tcltest::removeFile {name} {
  1727.     DebugPuts 3 "::tcltest::removeFile: removing $name"
  1728.     file delete [file join $::tcltest::temporaryDirectory $name]
  1729. }
  1730.  
  1731. # makeDirectory --
  1732. #
  1733. # Create a new dir with the name <name>.
  1734. #
  1735. # If this dir hasn't been created via makeDirectory since the last time
  1736. # cleanupTests was called, add it to the $directoriesMade list, so it will
  1737. # be removed by the next call to cleanupTests.
  1738. #
  1739. proc ::tcltest::makeDirectory {name} {
  1740.     file mkdir $name
  1741.  
  1742.     set fullName [file join [pwd] $name]
  1743.     if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
  1744.     lappend ::tcltest::filesMade $fullName
  1745.     }
  1746. }
  1747.  
  1748. # ::tcltest::removeDirectory --
  1749. #
  1750. #    Removes a named directory from the file system.
  1751. #
  1752. # Arguments:
  1753. #    name    Name of the directory to remove
  1754. #
  1755.  
  1756. proc ::tcltest::removeDirectory {name} {
  1757.     file delete -force $name
  1758. }
  1759.  
  1760. proc ::tcltest::viewFile {name} {
  1761.     global tcl_platform
  1762.     if {([string equal $tcl_platform(platform) "macintosh"]) || \
  1763.         ($::tcltest::testConstraints(unixExecs) == 0)} {
  1764.     set f [open [file join $::tcltest::temporaryDirectory $name]]
  1765.     set data [read -nonewline $f]
  1766.     close $f
  1767.     return $data
  1768.     } else {
  1769.     exec cat [file join $::tcltest::temporaryDirectory $name]
  1770.     }
  1771. }
  1772.  
  1773. # grep --
  1774. #
  1775. # Evaluate a given expression against each element of a list and return all
  1776. # elements for which the expression evaluates to true.  For the purposes of
  1777. # this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the
  1778. # value of the current element within the expression.  This is equivalent to
  1779. # the perl grep command where CURRENT_ELEMENT would be the name for the special
  1780. # variable $_.
  1781. #
  1782. # Examples of usage would be:
  1783. #   set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers]
  1784. #   set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings]
  1785. #
  1786. # Use of the CURRENT_ELEMENT keyword is optional.  If it is left out, it is
  1787. # assumed to be the final argument to the expression provided.
  1788. # 
  1789. # Example:
  1790. #   grep {regexp a} $someList   
  1791. #
  1792. proc ::tcltest::grep { expression searchList } {
  1793.     foreach element $searchList {
  1794.     if {[regsub -all CURRENT_ELEMENT $expression $element \
  1795.         newExpression] == 0} { 
  1796.         set newExpression "$expression {$element}"
  1797.     }
  1798.     if {[eval $newExpression] == 1} {
  1799.         lappend returnList $element
  1800.     }
  1801.     }
  1802.     if {[info exists returnList]} {
  1803.     return $returnList
  1804.     }
  1805.     return
  1806. }
  1807.  
  1808. #
  1809. # Construct a string that consists of the requested sequence of bytes,
  1810. # as opposed to a string of properly formed UTF-8 characters.  
  1811. # This allows the tester to 
  1812. # 1. Create denormalized or improperly formed strings to pass to C procedures 
  1813. #    that are supposed to accept strings with embedded NULL bytes.
  1814. # 2. Confirm that a string result has a certain pattern of bytes, for instance
  1815. #    to confirm that "\xe0\0" in a Tcl script is stored internally in 
  1816. #    UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
  1817. #
  1818. # Generally, it's a bad idea to examine the bytes in a Tcl string or to
  1819. # construct improperly formed strings in this manner, because it involves
  1820. # exposing that Tcl uses UTF-8 internally.
  1821.  
  1822. proc ::tcltest::bytestring {string} {
  1823.     encoding convertfrom identity $string
  1824. }
  1825.  
  1826. #
  1827. # Internationalization / ISO support procs     -- dl
  1828. #
  1829. proc ::tcltest::set_iso8859_1_locale {} {
  1830.     if {[info commands testlocale] != ""} {
  1831.     set ::tcltest::previousLocale [testlocale ctype]
  1832.     testlocale ctype $::tcltest::isoLocale
  1833.     }
  1834.     return
  1835. }
  1836.  
  1837. proc ::tcltest::restore_locale {} {
  1838.     if {[info commands testlocale] != ""} {
  1839.     testlocale ctype $::tcltest::previousLocale
  1840.     }
  1841.     return
  1842. }
  1843.  
  1844. # threadReap --
  1845. #
  1846. #    Kill all threads except for the main thread.
  1847. #    Do nothing if testthread is not defined.
  1848. #
  1849. # Arguments:
  1850. #    none.
  1851. #
  1852. # Results:
  1853. #    Returns the number of existing threads.
  1854. proc ::tcltest::threadReap {} {
  1855.     if {[info commands testthread] != {}} {
  1856.  
  1857.     # testthread built into tcltest
  1858.  
  1859.     testthread errorproc ThreadNullError
  1860.     while {[llength [testthread names]] > 1} {
  1861.         foreach tid [testthread names] {
  1862.         if {$tid != $::tcltest::mainThread} {
  1863.             catch {testthread send -async $tid {testthread exit}}
  1864.         }
  1865.         }
  1866.         ## Enter a bit a sleep to give the threads enough breathing
  1867.         ## room to kill themselves off, otherwise the end up with a
  1868.         ## massive queue of repeated events
  1869.         after 1
  1870.     }
  1871.     testthread errorproc ThreadError
  1872.     return [llength [testthread names]]
  1873.     } elseif {[info commands thread::id] != {}} {
  1874.     
  1875.     # Thread extension
  1876.  
  1877.     thread::errorproc ThreadNullError
  1878.     while {[llength [thread::names]] > 1} {
  1879.         foreach tid [thread::names] {
  1880.         if {$tid != $::tcltest::mainThread} {
  1881.             catch {thread::send -async $tid {thread::exit}}
  1882.         }
  1883.         }
  1884.         ## Enter a bit a sleep to give the threads enough breathing
  1885.         ## room to kill themselves off, otherwise the end up with a
  1886.         ## massive queue of repeated events
  1887.         after 1
  1888.     }
  1889.     thread::errorproc ThreadError
  1890.     return [llength [thread::names]]
  1891.     } else {
  1892.     return 1
  1893.     }
  1894. }
  1895.  
  1896. # Initialize the constraints and set up command line arguments 
  1897. namespace eval tcltest {
  1898.     # Ensure that we have a minimal auto_path so we don't pick up extra junk.
  1899.     set ::auto_path [list [info library]]
  1900.  
  1901.     ::tcltest::initConstraints
  1902.     if {[namespace children ::tcltest] == {}} {
  1903.     ::tcltest::processCmdLineArgs
  1904.     }
  1905. }
  1906.