开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
tcltest.test
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：49k
源码类别：

通讯编程

开发平台：

Visual C++

tcltest.test：源码内容
  1. # This file contains a collection of tests for one or more of the Tcl
  2. # built-in commands.  Sourcing this file into Tcl runs the tests and
  3. # generates output for errors.  No output means no errors were found.
  4. #
  5. # Copyright (c) 1998-1999 by Scriptics Corporation. 
  6. # Copyright (c) 2000 by Ajuba Solutions
  7. # All rights reserved.
  8. #
  9. # RCS: @(#) $Id: tcltest.test,v 1.37.2.11 2006/03/19 22:47:30 vincentdarley Exp $
  11. # Note that there are several places where the value of 
  12. # tcltest::currentFailure is stored/reset in the -setup/-cleanup
  13. # of a test that has a body that runs [test] that will fail.
  14. # This is a workaround of using the same tcltest code that we are
  15. # testing to run the test itself.  Ditto on things like [verbose].
  16. #
  17. # It would be better to have the -body of the tests run the tcltest
  18. # commands in a slave interp so the [test] being tested would not
  19. # interfere with the [test] doing the testing.  
  20. #
  22. if {[catch {package require tcltest 2.1}]} {
  23.     puts stderr "Skipping tests in [info script].  tcltest 2.1 required."
  24.     return
  25. }
  27. namespace eval ::tcltest::test {
  29. namespace import ::tcltest::*
  31. makeFile {
  32.     package require tcltest
  33.     namespace import ::tcltest::test
  34.     test a-1.0 {test a} {
  35. list 0
  36.     } {0}
  37.     test b-1.0 {test b} {
  38. list 1
  39.     } {0}
  40.     test c-1.0 {test c} {knownBug} {
  41.     } {}
  42.     test d-1.0 {test d} {
  43. error "foo" foo 9
  44.     } {}
  45.     tcltest::cleanupTests
  46.     exit
  47. } test.tcl
  49. cd [temporaryDirectory]
  50. testConstraint exec [llength [info commands exec]]
  51. # test -help
  52. # Child processes because -help [exit]s.
  53. test tcltest-1.1 {tcltest -help} {exec} {
  54.     set result [catch {exec [interpreter] test.tcl -help} msg]
  55.     list $result [regexp Usage $msg]
  56. } {1 1} 
  57. test tcltest-1.2 {tcltest -help -something} {exec} {
  58.     set result [catch {exec [interpreter] test.tcl -help -something} msg]
  59.     list $result [regexp Usage $msg]
  60. } {1 1}
  61. test tcltest-1.3 {tcltest -h} {exec} {
  62.     set result [catch {exec [interpreter] test.tcl -h} msg]
  63.     list $result [regexp Usage $msg]
  64. } {1 0} 
  66. # -verbose, implicit & explicit testing of [verbose]
  67. proc slave {msgVar args} {
  68.     upvar 1 $msgVar msg
  70.     interp create [namespace current]::i
  71.     # Fake the slave interp into dumping output to a file
  72.     i eval {namespace eval ::tcltest {}}
  73.     i eval "set tcltest::outputChannel
  74.     [[list open [set of [makeFile {} output]] w]]"
  75.     i eval "set tcltest::errorChannel
  76.     [[list open [set ef [makeFile {} error]] w]]"
  77.     i eval [list set argv0 [lindex $args 0]]
  78.     i eval [list set argv [lrange $args 1 end]]
  79.     i eval [list package ifneeded tcltest [package provide tcltest] 
  80.     [package ifneeded tcltest [package provide tcltest]]]
  81.     i eval {proc exit args {}}
  83.     # Need to capture output in msg
  85.     set code [catch {i eval {source $argv0}} foo]
  86. if $code {
  87. #puts "$code: $foon$::errorInfo"
  88. }
  89.     i eval {close $tcltest::outputChannel}
  90.     interp delete [namespace current]::i
  91.     set f [open $of]
  92.     set msg [read -nonewline $f]
  93.     close $f
  94.     set f [open $ef]
  95.     set err [read -nonewline $f]
  96.     close $f
  97.     removeFile output
  98.     removeFile error
  99.     if {[string length $err]} {
  100. set code 1
  101. append msg n$err
  102.     }
  103.     return $code
  105. #    return [catch {uplevel 1 [linsert $args 0  exec [interpreter]]} msg]
  106. }
  107. test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} {
  108.     set result [slave msg test.tcl]
  109.     list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] 
  110.     [regexp c-1.0 $msg] 
  111.     [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
  112. } {0 1 0 0 1}
  113. test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} {
  114.     set result [slave msg test.tcl -verbose 'b']
  115.     list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] 
  116.     [regexp c-1.0 $msg] 
  117.     [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
  118. } {0 1 0 0 1}
  119. test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} {
  120.     set result [slave msg test.tcl -verbose 'p']
  121.     list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] 
  122.     [regexp c-1.0 $msg] 
  123.     [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
  124. } {0 0 1 0 1}
  125. test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} {
  126.     set result [slave msg test.tcl -verbose 's']
  127.     list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] 
  128.     [regexp c-1.0 $msg] 
  129.     [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
  130. } {0 0 0 1 1}
  131. test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} {
  132.     set result [slave msg test.tcl -verbose 'ps']
  133.     list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] 
  134.     [regexp c-1.0 $msg] 
  135.     [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
  136. } {0 0 1 1 1}
  137. test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} {
  138.     set result [slave msg test.tcl -verbose 'psb']
  139.     list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] 
  140.     [regexp c-1.0 $msg] 
  141.     [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
  142. } {0 1 1 1 1}
  144. test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} {
  145.     set result [slave msg test.tcl -verbose "pass skip body"]
  146.     list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] 
  147.     [regexp c-1.0 $msg] 
  148.     [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
  149. } {0 1 1 1 1}
  151. test tcltest-2.6 {tcltest -verbose 't'}  {
  152.     -constraints {unixOrPc} 
  153.     -body {
  154. set result [slave msg test.tcl -verbose 't']
  155. list $result $msg
  156.     }
  157.     -result {^0 .*a-1.0 start.*b-1.0 start}
  158.     -match regexp
  159. }
  161. test tcltest-2.6a {tcltest -verbose 'start'}  {
  162.     -constraints {unixOrPc} 
  163.     -body {
  164. set result [slave msg test.tcl -verbose start]
  165. list $result $msg
  166.     }
  167.     -result {^0 .*a-1.0 start.*b-1.0 start}
  168.     -match regexp
  169. }
  171. test tcltest-2.7 {tcltest::verbose}  {
  172.     -body {
  173. set oldVerbosity [verbose]
  174. verbose bar
  175. set currentVerbosity [verbose]
  176. verbose foo
  177. set newVerbosity [verbose]
  178. verbose $oldVerbosity
  179. list $currentVerbosity $newVerbosity 
  180.     }
  181.     -result {body {}}
  182. }
  184. test tcltest-2.8 {tcltest -verbose 'error'} {
  185.     -constraints {unixOrPc}
  186.     -body {
  187. set result [slave msg test.tcl -verbose error]
  188. list $result $msg
  189.     }
  190.     -result {errorInfo: foo.*errorCode: 9}
  191.     -match regexp
  192. }
  193. # -match, [match]
  194. test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} {
  195.     set result [slave msg test.tcl -match a* -verbose 'ps']
  196.     list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] 
  197.     [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
  198. } {0 1 0 0 1}
  199. test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} {
  200.     set result [slave msg test.tcl -match b* -verbose 'ps']
  201.     list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] 
  202.     [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
  203. } {0 0 1 0 1}
  204. test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} {
  205.     set result [slave msg test.tcl -match c* -verbose 'ps']
  206.     list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] 
  207.     [regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg]
  208. } {0 0 0 1 1}
  209. test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} {
  210.     set result [slave msg test.tcl -match {a* b*} -verbose 'ps']
  211.     list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] 
  212.     [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
  213. } {0 1 1 0 1}
  215. test tcltest-3.5 {tcltest::match}  {
  216.     -body {
  217. set oldMatch [match]
  218. match foo
  219. set currentMatch [match]
  220. match bar
  221. set newMatch [match]
  222. match $oldMatch
  223. list $currentMatch $newMatch
  224.     }
  225.     -result {foo bar}
  226. }
  228. # -skip, [skip]
  229. test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} {
  230.     set result [slave msg test.tcl -skip a* -verbose 'ps']
  231.     list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] 
  232.     [regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
  233. } {0 0 1 1 1}
  234. test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} {
  235.     set result [slave msg test.tcl -skip b* -verbose 'ps']
  236.     list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] 
  237.     [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
  238. } {0 1 0 1 1}
  239. test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} {
  240.     set result [slave msg test.tcl -skip c* -verbose 'ps']
  241.     list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] 
  242.     [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
  243. } {0 1 1 0 1}
  244. test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} {
  245.     set result [slave msg test.tcl -skip {a* b*} -verbose 'ps']
  246.     list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] 
  247.     [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
  248. } {0 0 0 1 1}
  249. test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} {
  250.     set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps']
  251.     list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] 
  252.     [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
  253. } {0 1 0 0 1}
  255. test tcltest-4.6 {tcltest::skip} {
  256.     -body {
  257. set oldSkip [skip]
  258. skip foo
  259. set currentSkip [skip]
  260. skip bar
  261. set newSkip [skip]
  262. skip $oldSkip
  263. list $currentSkip $newSkip
  264.     }
  265.     -result {foo bar}
  266. }
  268. # -constraints, -limitconstraints, [testConstraint],
  269. # $constraintsSpecified, [limitConstraints]
  270. test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} {
  271.     set result [slave msg test.tcl -constraints knownBug -verbose 'ps']
  272.     list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] 
  273.     [regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg]
  274. } {0 1 1 1 1}
  275. test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} {
  276.     set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1]
  277.     list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] 
  278.     [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
  279. } {0 0 0 1 1}
  281. test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)}  {
  282.     -body {
  283. set r1 [testConstraint tcltestFakeConstraint]
  284. set r2 [testConstraint tcltestFakeConstraint 4]
  285. set r3 [testConstraint tcltestFakeConstraint]
  286. list $r1 $r2 $r3
  287.     }
  288.     -result {0 4 4}
  289.     -cleanup {unset ::tcltest::testConstraints(tcltestFakeConstraint)}
  290. }
  292. # Removed this test of internals of tcltest.  Those internals have changed.
  293. #test tcltest-5.4 {tcltest::constraintsSpecified} {
  294. #    -setup {
  295. # set constraintlist $::tcltest::constraintsSpecified
  296. # set ::tcltest::constraintsSpecified {}
  297. #    }
  298. #    -body {
  299. # set r1 $::tcltest::constraintsSpecified
  300. # testConstraint tcltestFakeConstraint1 1
  301. # set r2 $::tcltest::constraintsSpecified
  302. # testConstraint tcltestFakeConstraint2 1
  303. # set r3 $::tcltest::constraintsSpecified
  304. # list $r1 $r2 $r3
  305. #    }
  306. #    -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}}
  307. #    -cleanup {
  308. # set ::tcltest::constraintsSpecified $constraintlist
  309. # unset ::tcltest::testConstraints(tcltestFakeConstraint1) 
  310. # unset ::tcltest::testConstraints(tcltestFakeConstraint2) 
  311. #    }
  312. #}
  314. test tcltest-5.5 {InitConstraints: list of built-in constraints} 
  315. -constraints {!singleTestInterp} 
  316. -setup {tcltest::InitConstraints} 
  317. -body { lsort [array names ::tcltest::testConstraints] } 
  318. -result [lsort {
  319.     95 98 asyncPipeClose eformat emptyTest exec hasIsoLocale interactive
  320.     knownBug mac macCrash macOnly macOrPc macOrUnix macOrWin nonBlockFiles
  321.     nonPortable notRoot nt pc pcCrash pcOnly root singleTestInterp socket
  322.     stdio tempNotMac tempNotPc tempNotUnix tempNotWin unix unixCrash unixExecs
  323.     unixOnly unixOrPc unixOrWin userInteraction win winCrash winOnly
  324. }]
  326. # Removed this broken test.  Its usage of [limitConstraints] was not
  327. # in agreement with the documentation.  [limitConstraints] is supposed
  328. # to take an optional boolean argument, and "knownBug" ain't no boolean!
  329. #test tcltest-5.6 {tcltest::limitConstraints} {
  330. #    -setup {
  331. #        set keeplc $::tcltest::limitConstraints
  332. #        set keepkb [testConstraint knownBug]
  333. #    }
  334. #    -body {
  335. #        set r1 [limitConstraints]
  336. #        set r2 [limitConstraints knownBug]
  337. #        set r3 [limitConstraints]
  338. #        list $r1 $r2 $r3
  339. #    }
  340. #    -cleanup {
  341. #        limitConstraints $keeplc
  342. #        testConstraint knownBug $keepkb
  343. #    }
  344. #    -result {false knownBug knownBug}
  345. #}
  347. # -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile]
  348. set printerror [makeFile {
  349.     package require tcltest
  350.     namespace import ::tcltest::*
  351.     puts [outputChannel] "a test"
  352.     ::tcltest::PrintError "a really short string"
  353.     ::tcltest::PrintError "a really really really really really really long 
  354.     string containing "quotes" and other bad bad stuff"
  355.     ::tcltest::PrintError "a really really long string containing a 
  356.     "Path/that/is/really/long/and/contains/no/spaces""
  357.     ::tcltest::PrintError "a really really long string containing a 
  358.     "Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens"" 
  359.     ::tcltest::PrintError "Problem renaming file: error renaming "Z:/ws/tcl8.2/win32-ix86/tests/core" to "Z:/ws/tcl8.2/win32-ix86/tests/movecore-core""
  360.     exit
  361. } printerror.tcl]
  363. test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
  364.     -constraints unixOrPc
  365.     -body {
  366. slave msg $printerror
  367. return $msg
  368.     }
  369.     -result {a test.*a really}
  370.     -match regexp
  371. }
  372. test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} {
  373.     slave msg $printerror -outfile a.tmp
  374.     set result1 [catch {exec grep "a test" a.tmp}]
  375.     set result2 [catch {exec grep "a really" a.tmp}]
  376.     list [regexp "a test" $msg] [regexp "a really" $msg] 
  377.     $result1 $result2 [file exists a.tmp] [file delete a.tmp] 
  378. } {0 1 0 1 1 {}}
  379. test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} {
  380.     slave msg $printerror -errfile a.tmp
  381.     set result1 [catch {exec grep "a test" a.tmp}]
  382.     set result2 [catch {exec grep "a really" a.tmp}]
  383.     list [regexp "a test" $msg] [regexp "a really" $msg] 
  384.     $result1 $result2 [file exists a.tmp] [file delete a.tmp]
  385. } {1 0 1 0 1 {}}
  386. test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc unixExecs} {
  387.     slave msg $printerror -outfile a.tmp -errfile b.tmp
  388.     set result1 [catch {exec grep "a test" a.tmp}]
  389.     set result2 [catch {exec grep "a really" b.tmp}]
  390.     list [regexp "a test" $msg] [regexp "a really" $msg] 
  391.     $result1 $result2 
  392.     [file exists a.tmp] [file delete a.tmp] 
  393.     [file exists b.tmp] [file delete b.tmp]
  394. } {0 0 0 0 1 {} 1 {}}
  396. test tcltest-6.5 {tcltest::errorChannel - retrieval} {
  397.     -setup {
  398. set of [errorChannel]
  399. set ::tcltest::errorChannel stderr
  400.     }
  401.     -body {
  402. errorChannel
  403.     }
  404.     -result {stderr}
  405.     -cleanup {
  406. set ::tcltest::errorChannel $of
  407.     }
  408. }
  410. test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} {
  411.     -setup {
  412. set ef [makeFile {} efile]
  413. set of [errorFile]
  414. set ::tcltest::errorChannel stderr
  415. set ::tcltest::errorFile stderr
  416.     }
  417.     -body {
  418. set f0 [errorChannel]
  419. set f1 [errorFile]
  420. set f2 [errorFile $ef]
  421. set f3 [errorChannel]
  422. set f4 [errorFile]
  423. subst {$f0;$f1;$f2;$f3;$f4} 
  424.     }
  425.     -result {stderr;stderr;.*efile;file[0-9a-f]+;.*efile}
  426.     -match regexp
  427.     -cleanup {
  428. errorFile $of
  429. removeFile efile
  430.     }
  431. }
  432. test tcltest-6.7 {tcltest::outputChannel - retrieval} {
  433.     -setup {
  434. set of [outputChannel]
  435. set ::tcltest::outputChannel stdout
  436.     }
  437.     -body {
  438. outputChannel
  439.     }
  440.     -result {stdout}
  441.     -cleanup {
  442. set tcltest::outputChannel $of
  443.     }
  444. }
  446. test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} {
  447.     -setup {
  448. set ef [makeFile {} efile]
  449. set of [outputFile]
  450. set ::tcltest::outputChannel stdout
  451. set ::tcltest::outputFile stdout
  452.     }
  453.     -body {
  454. set f0 [outputChannel]
  455. set f1 [outputFile]
  456. set f2 [outputFile $ef]
  457. set f3 [outputChannel]
  458. set f4 [outputFile]
  459. subst {$f0;$f1;$f2;$f3;$f4} 
  460.     }
  461.     -result {stdout;stdout;.*efile;file[0-9a-f]+;.*efile}
  462.     -match regexp
  463.     -cleanup {
  464. outputFile $of
  465. removeFile efile
  466.     }
  467. }
  469. # -debug, [debug]
  470. # Must use child processes to test -debug because it always writes
  471. # messages to stdout, and we have no way to capture stdout of a
  472. # slave interp
  473. test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} {
  474.     catch {exec [interpreter] test.tcl -debug 0} msg
  475.     regexp "Flags passed into tcltest" $msg
  476. } {0}
  477. test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} {
  478.     catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg
  479.     list [regexp userSpecifiedSkip $msg] 
  480.     [regexp "Flags passed into tcltest" $msg]
  481. } {1 0}
  482. test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrPc} {
  483.     catch {exec [interpreter] test.tcl -debug 1 -match b*} msg
  484.     list [regexp userSpecifiedNonMatch $msg] 
  485.     [regexp "Flags passed into tcltest" $msg]
  486. } {1 0}
  487. test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrPc} {
  488.     catch {exec [interpreter] test.tcl -debug 2} msg
  489.     list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
  490. } {1 0}
  491. test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrPc} {
  492.     catch {exec [interpreter] test.tcl -debug 3} msg
  493.     list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
  494. } {1 1}
  496. test tcltest-7.6 {tcltest::debug} {
  497.     -setup {
  498. set old $::tcltest::debug
  499. set ::tcltest::debug 0
  500.     }
  501.     -body {
  502. set f1 [debug]
  503. set f2 [debug 1]
  504. set f3 [debug]
  505. set f4 [debug 2]
  506. set f5 [debug]
  507. list $f1 $f2 $f3 $f4 $f5
  508.     }
  509.     -result {0 1 1 2 2}
  510.     -cleanup {
  511. set ::tcltest::debug $old
  512.     }
  513. }
  514. removeFile test.tcl
  516. # directory tests
  518. set a [makeFile {
  519.     package require tcltest
  520.     tcltest::makeFile {} a.tmp
  521.     puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]"
  522.     exit
  523. } a.tcl]
  525. set tdiaf [makeFile {} thisdirectoryisafile]
  527. set normaldirectory [makeDirectory normaldirectory]
  528. normalizePath normaldirectory
  530. # -tmpdir, [temporaryDirectory]
  531. test tcltest-8.1 {tcltest a.tcl -tmpdir a} {unixOrPc} {
  532.     file delete -force thisdirectorydoesnotexist
  533.     slave msg $a -tmpdir thisdirectorydoesnotexist
  534.     list [file exists [file join thisdirectorydoesnotexist a.tmp]] 
  535.     [file delete -force thisdirectorydoesnotexist] 
  536. } {1 {}}
  537. test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
  538.     -constraints unixOrPc
  539.     -body {
  540. slave msg $a -tmpdir $tdiaf
  541. set msg
  542.     }
  543.     -result {*not a directory*}
  544.     -match glob
  545. }
  547. # Test non-writeable directories, non-readable directories with directory flags
  548. set notReadableDir [file join [temporaryDirectory] notreadable]
  549. set notWriteableDir [file join [temporaryDirectory] notwriteable]
  551. makeDirectory notreadable
  552. makeDirectory notwriteable
  554. switch $tcl_platform(platform) {
  555.     "unix" {
  556. file attributes $notReadableDir -permissions 00333
  557. file attributes $notWriteableDir -permissions 00555
  558.     }
  559.     default {
  560. catch {file attributes $notWriteableDir -readonly 1}
  561. catch {testchmod 000 $notWriteableDir}
  562.     }
  563. }
  565. test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unix notRoot} {
  566.     slave msg $a -tmpdir $notReadableDir 
  567.     string match {*not readable*} $msg
  568. } {1}
  570. test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc notRoot} {
  571.     slave msg $a -tmpdir $notWriteableDir
  572.     string match {*not writeable*} $msg
  573. } {1}
  575. test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {unixOrPc} {
  576.     slave msg $a -tmpdir $normaldirectory
  577.     # The join is necessary because the message can be split on multiple lines
  578.     list [file exists [file join $normaldirectory a.tmp]] 
  579.     [file delete [file join $normaldirectory a.tmp]] 
  580. } {1 {}}   
  581. cd [workingDirectory]
  583. test tcltest-8.6 {temporaryDirectory}  {
  584.     -setup {
  585. set old $::tcltest::temporaryDirectory
  586. set ::tcltest::temporaryDirectory $normaldirectory
  587.     }
  588.     -body {
  589. set f1 [temporaryDirectory]
  590. set f2 [temporaryDirectory [workingDirectory]]
  591. set f3 [temporaryDirectory]
  592. list $f1 $f2 $f3
  593.     }
  594.     -result "[list $normaldirectory [workingDirectory] [workingDirectory]]"
  595.     -cleanup {
  596. set ::tcltest::temporaryDirectory $old
  597.     }
  598. }
  600. test tcltest-8.6a {temporaryDirectory - test format 2} -setup {
  601.     set old $::tcltest::temporaryDirectory
  602.     set ::tcltest::temporaryDirectory $normaldirectory
  603. } -body {
  604.     set f1 [temporaryDirectory]
  605.     set f2 [temporaryDirectory [workingDirectory]]
  606.     set f3 [temporaryDirectory]
  607.     list $f1 $f2 $f3
  608. } -cleanup {
  609.     set ::tcltest::temporaryDirectory $old
  610. } -result [list $normaldirectory [workingDirectory] [workingDirectory]]
  612. cd [temporaryDirectory]
  613. # -testdir, [testsDirectory]
  614. test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {unixOrPc} {
  615.     file delete -force thisdirectorydoesnotexist
  616.     slave msg $a -testdir thisdirectorydoesnotexist
  617.     string match "*does not exist*" $msg
  618. } {1}
  620. test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {unixOrPc} {
  621.     slave msg $a -testdir $tdiaf
  622.     string match "*not a directory*" $msg 
  623. } {1}
  625. test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {unix notRoot} {
  626.     slave msg $a -testdir $notReadableDir 
  627.     string match {*not readable*} $msg
  628. } {1}
  631. test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {unixOrPc} {
  632.     slave msg $a -testdir $normaldirectory
  633.     # The join is necessary because the message can be split on multiple lines
  634.     list [string first "testdir: $normaldirectory" [join $msg]] 
  635.     [file exists [file join [temporaryDirectory] a.tmp]] 
  636.     [file delete [file join [temporaryDirectory] a.tmp]] 
  637. } {0 1 {}} 
  638. cd [workingDirectory]
  640. set current [pwd]
  641. test tcltest-8.14 {testsDirectory} {
  642.     -setup {
  643. set old $::tcltest::testsDirectory
  644. set ::tcltest::testsDirectory $normaldirectory
  645.     }
  646.     -body {
  647. set f1 [testsDirectory]
  648. set f2 [testsDirectory $current]
  649. set f3 [testsDirectory]
  650. list $f1 $f2 $f3
  651.     }
  652.     -result "[list $normaldirectory $current $current]"
  653.     -cleanup {
  654. set ::tcltest::testsDirectory $old
  655.     }
  656. }
  658. # [workingDirectory]
  659. test tcltest-8.60 {::workingDirectory}  {
  660.     -setup {
  661. set old $::tcltest::workingDirectory
  662. set current [pwd]
  663. set ::tcltest::workingDirectory $normaldirectory
  664. cd $normaldirectory
  665.     }
  666.     -body {
  667. set f1 [workingDirectory]
  668. set f2 [pwd]
  669. set f3 [workingDirectory $current]
  670. set f4 [pwd] 
  671. set f5 [workingDirectory]
  672. list $f1 $f2 $f3 $f4 $f5
  673.     }
  674.     -result "[list $normaldirectory 
  675.                    $normaldirectory 
  676.                    $current 
  677.                    $current 
  678.                    $current]"
  679.     -cleanup {
  680. set ::tcltest::workingDirectory $old
  681. cd $current
  682.     }
  683. }
  685. # clean up from directory testing
  687. switch $tcl_platform(platform) {
  688.     "unix" {
  689. file attributes $notReadableDir -permissions 777
  690. file attributes $notWriteableDir -permissions 777
  691.     }
  692.     default {
  693. catch {file attributes $notWriteableDir -readonly 0}
  694.     }
  695. }
  697. file delete -force $notReadableDir $notWriteableDir
  698. removeFile a.tcl
  699. removeFile thisdirectoryisafile
  700. removeDirectory normaldirectory
  702. # -file, -notfile, [matchFiles], [skipFiles]
  703. test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup {
  704.     set old [testsDirectory]
  705.     testsDirectory [file dirname [info script]]
  706. } -body {
  707.     slave msg [file join [testsDirectory] all.tcl] -file d*.test
  708.     set msg
  709. } -cleanup {
  710.     testsDirectory $old
  711. } -match regexp -result {dstring.test}
  713. test tcltest-9.2 {-file d*.tcl} -constraints {unixOrPc} -setup {
  714.     set old [testsDirectory]
  715.     testsDirectory [file dirname [info script]]
  716. } -body {
  717.     slave msg [file join [testsDirectory] all.tcl] 
  718.     -file d*.test -notfile dstring*
  719.     regexp {dstring.test} $msg
  720. } -cleanup {
  721.     testsDirectory $old
  722. } -result 0
  724. test tcltest-9.3 {matchFiles}  {
  725.     -body {
  726. set old [matchFiles]
  727. matchFiles foo
  728. set current [matchFiles]
  729. matchFiles bar
  730. set new [matchFiles]
  731. matchFiles $old
  732. list $current $new
  733.     } 
  734.     -result {foo bar}
  735. }
  737. test tcltest-9.4 {skipFiles} {
  738.     -body {
  739. set old [skipFiles]
  740. skipFiles foo
  741. set current [skipFiles]
  742. skipFiles bar
  743. set new [skipFiles]
  744. skipFiles $old
  745. list $current $new
  746.     } 
  747.     -result {foo bar}
  748. }
  750. test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup {
  751.     set d [makeDirectory tmp]
  752.     makeDirectory foo $d
  753.     makeFile {} fee $d
  754.     file copy [file join [file dirname [info script]] all.tcl] $d
  755. } -body {
  756.     slave msg [file join [temporaryDirectory] all.tcl] -file f*
  757.     regexp {exiting with errors:} $msg
  758. } -cleanup {
  759.     file delete [file join $d all.tcl]
  760.     removeFile fee $d
  761.     removeDirectory foo $d
  762.     removeDirectory tmp
  763. } -result 0
  765. # -preservecore, [preserveCore]
  766. set mc [makeFile {
  767.     package require tcltest
  768.     namespace import ::tcltest::test
  769.     test makecore {make a core file} {
  770. set f [open core w]
  771. close $f
  772.     } {}
  773.     ::tcltest::cleanupTests
  774.     return
  775. } makecore.tcl]
  777. cd [temporaryDirectory]
  778. test tcltest-10.1 {-preservecore 0} {unixOrPc} {
  779.     slave msg $mc -preservecore 0
  780.     file delete core
  781.     regexp "Core file produced" $msg
  782. } {0}
  783. test tcltest-10.2 {-preservecore 1} {unixOrPc} {
  784.     slave msg $mc -preservecore 1
  785.     file delete core
  786.     regexp "Core file produced" $msg
  787. } {1}
  788. test tcltest-10.3 {-preservecore 2} {unixOrPc} {
  789.     slave msg $mc -preservecore 2
  790.     file delete core
  791.     list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] 
  792.     [regexp "core-" $msg] [file delete core-makecore]
  793. } {1 1 1 {}}
  794. test tcltest-10.4 {-preservecore 3} {unixOrPc} {
  795.     slave msg $mc -preservecore 3
  796.     file delete core
  797.     list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] 
  798.     [regexp "core-" $msg] [file delete core-makecore]
  799. } {1 1 1 {}}
  801. # Removing this test.  It makes no sense to test the ability of
  802. # [preserveCore] to accept an invalid value that will cause errors
  803. # in other parts of tcltest's operation.
  804. #test tcltest-10.5 {preserveCore} {
  805. #    -body {
  806. # set old [preserveCore]
  807. # set result [preserveCore foo]
  808. # set result2 [preserveCore]
  809. # preserveCore $old
  810. # list $result $result2
  811. #    }
  812. #    -result {foo foo}
  813. #}
  814. removeFile makecore.tcl
  816. # -load, -loadfile, [loadScript], [loadFile]
  817. set contents { 
  818.     package require tcltest
  819.     namespace import tcltest::*
  820.     puts [outputChannel] $::tcltest::loadScript
  821.     exit
  822. } 
  823. set loadfile [makeFile $contents load.tcl]
  825. test tcltest-12.1 {-load xxx} {unixOrPc} {
  826.     slave msg $loadfile -load xxx
  827.     set msg
  828. } {xxx}
  830. # Using child process because of -debug usage.
  831. test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} {
  832.     catch {exec [interpreter] $loadfile -debug 2 -loadfile $loadfile} msg
  833.     list 
  834.     [regexp {tcltest} [join [list $msg] [split $msg n]]] 
  835.     [regexp {loadScript} [join [list $msg] [split $msg n]]]
  836. } {1 1}
  838. test tcltest-12.3 {loadScript} {
  839.     -setup {
  840. set old $::tcltest::loadScript
  841. set ::tcltest::loadScript {}
  842.     }
  843.     -body {
  844. set f1 [loadScript]
  845. set f2 [loadScript xxx]
  846. set f3 [loadScript]
  847. list $f1 $f2 $f3
  848.     }
  849.     -result {{} xxx xxx}
  850.     -cleanup {
  851. set ::tcltest::loadScript $old
  852.     }
  853. }
  855. test tcltest-12.4 {loadFile} {
  856.     -setup {
  857. set olds $::tcltest::loadScript
  858. set ::tcltest::loadScript {}
  859. set oldf $::tcltest::loadFile
  860. set ::tcltest::loadFile {}
  861.     }
  862.     -body {
  863. set f1 [loadScript]
  864. set f2 [loadFile]
  865. set f3 [loadFile $loadfile]
  866. set f4 [loadScript]
  867. set f5 [loadFile]
  868. list $f1 $f2 $f3 $f4 $f5
  869.     }
  870.     -result "[list {} {} $loadfile $contents $loadfile]n"
  871.     -cleanup {
  872. set ::tcltest::loadScript $olds
  873. set ::tcltest::loadFile $oldf
  874.     }
  875. }
  876. removeFile load.tcl
  878. # [interpreter]
  879. test tcltest-13.1 {interpreter} {
  880.     -setup {
  881. set old $::tcltest::tcltest
  882. set ::tcltest::tcltest tcltest
  883.     }
  884.     -body {
  885. set f1 [interpreter]
  886. set f2 [interpreter tclsh]
  887. set f3 [interpreter]
  888. list $f1 $f2 $f3
  889.     }
  890.     -result {tcltest tclsh tclsh}
  891.     -cleanup {
  892. set ::tcltest::tcltest $old
  893.     }
  894. }
  896. # -singleproc, [singleProcess]
  897. set spd [makeDirectory singleprocdir]
  898. makeFile {
  899.     set foo 1
  900. } single1.test $spd
  902. makeFile {
  903.     unset foo
  904. } single2.test $spd
  906. set allfile [makeFile {
  907.     package require tcltest
  908.     namespace import tcltest::*
  909.     testsDirectory [file join [temporaryDirectory] singleprocdir]
  910.     runAllTests
  911. } all-single.tcl $spd]
  912. cd [workingDirectory]
  914. test tcltest-14.1 {-singleproc - single process} {
  915.     -constraints {unixOrPc}
  916.     -body {
  917. slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
  918. set msg
  919.     }
  920.     -result {Test file error: can't unset .foo.: no such variable}
  921.     -match regexp
  922. }
  924. test tcltest-14.2 {-singleproc - multiple process} {
  925.     -constraints {unixOrPc}
  926.     -body {
  927. slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory]
  928. set msg
  929.     }
  930.     -result {single1.test.*single2.test.*all-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0}
  931.     -match regexp
  932. }
  934. test tcltest-14.3 {singleProcess} {
  935.     -setup {
  936. set old $::tcltest::singleProcess
  937. set ::tcltest::singleProcess 0
  938.     }
  939.     -body {
  940. set f1 [singleProcess]
  941. set f2 [singleProcess 1]
  942. set f3 [singleProcess]
  943. list $f1 $f2 $f3
  944.     }
  945.     -result {0 1 1}
  946.     -cleanup {
  947. set ::tcltest::singleProcess $old
  948.     }
  949. }
  950. removeFile single1.test $spd
  951. removeFile single2.test $spd
  952. removeDirectory singleprocdir
  954. # -asidefromdir, -relateddir, [matchDirectories], [skipDirectories]
  956. # Before running these tests, need to set up test subdirectories with their own
  957. # all.tcl files.
  959. set dtd [makeDirectory dirtestdir]
  960. set dtd1 [makeDirectory dirtestdir2.1 $dtd]
  961. set dtd2 [makeDirectory dirtestdir2.2 $dtd]
  962. set dtd3 [makeDirectory dirtestdir2.3 $dtd]
  963. makeFile {
  964.     package require tcltest
  965.     namespace import -force tcltest::*
  966.     testsDirectory [file join [temporaryDirectory] dirtestdir]
  967.     runAllTests
  968. } all.tcl $dtd
  969. makeFile {
  970.     package require tcltest
  971.     namespace import -force tcltest::*
  972.     testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1]
  973.     runAllTests
  974. } all.tcl $dtd1
  975. makeFile {
  976.     package require tcltest
  977.     namespace import -force tcltest::*
  978.     testsDirectory [file join [temporaryDirectory]  dirtestdir dirtestdir2.2]
  979.     runAllTests
  980. } all.tcl $dtd2
  981. makeFile {
  982.     package require tcltest
  983.     namespace import -force tcltest::*
  984.     testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3]
  985.     runAllTests
  986. } all.tcl $dtd3
  988. test tcltest-15.1 {basic directory walking} {
  989.     -constraints {unixOrPc}
  990.     -body {
  991. if {[slave msg 
  992. [file join $dtd all.tcl] 
  993. -tmpdir [temporaryDirectory]] == 1} {
  994.     error $msg
  995. }
  996.     }
  997.     -match regexp
  998.     -returnCodes 1
  999.     -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123]}
  1000. }
  1002. test tcltest-15.2 {-asidefromdir} {
  1003.     -constraints {unixOrPc}
  1004.     -body {
  1005. if {[slave msg 
  1006. [file join $dtd all.tcl] 
  1007. -asidefromdir dirtestdir2.3 
  1008. -tmpdir [temporaryDirectory]] == 1} {
  1009.     error $msg
  1010. }
  1011.     }
  1012.     -match regexp
  1013.     -returnCodes 1
  1014.     -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[12].*Tests located in:.*dirtestdir2.[12].*dirtestdir2.[12] test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  1015. Error:  No test files remain after applying your match and skip patterns!
  1016. Error:  No test files remain after applying your match and skip patterns!
  1017. Error:  No test files remain after applying your match and skip patterns!$}
  1018. }
  1020. test tcltest-15.3 {-relateddir, non-existent dir} {
  1021.     -constraints {unixOrPc}
  1022.     -body {
  1023. if {[slave msg 
  1024. [file join $dtd all.tcl] 
  1025. -relateddir [file join [temporaryDirectory] dirtestdir0] 
  1026. -tmpdir [temporaryDirectory]] == 1} {
  1027.     error $msg
  1028. }
  1029.     }
  1030.     -returnCodes 1
  1031.     -match regexp
  1032.     -result {[^~]|dirtestdir[^2]}
  1033. }
  1035. test tcltest-15.4 {-relateddir, subdir} {
  1036.     -constraints {unixOrPc}
  1037.     -body {
  1038. if {[slave msg 
  1039. [file join $dtd all.tcl] 
  1040. -relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} {
  1041.     error $msg
  1042. }
  1043.     }
  1044.     -returnCodes 1
  1045.     -match regexp
  1046.     -result {Tests located in:.*dirtestdir2.[^23]}
  1047. }
  1048. test tcltest-15.5 {-relateddir, -asidefromdir} {
  1049.     -constraints {unixOrPc}
  1050.     -body {
  1051. if {[slave msg 
  1052. [file join $dtd all.tcl] 
  1053. -relateddir "dirtestdir2.1 dirtestdir2.2" 
  1054. -asidefromdir dirtestdir2.2 
  1055. -tmpdir [temporaryDirectory]] == 1} {
  1056.     error $msg
  1057. }
  1058.     }
  1059.     -match regexp
  1060.     -returnCodes 1
  1061.     -result {Tests located in:.*dirtestdir2.[^23]}
  1062. }
  1064. test tcltest-15.6 {matchDirectories} {
  1065.     -setup {
  1066. set old [matchDirectories]
  1067. set ::tcltest::matchDirectories {}
  1068.     }
  1069.     -body {
  1070. set r1 [matchDirectories]
  1071. set r2 [matchDirectories foo]
  1072. set r3 [matchDirectories]
  1073. list $r1 $r2 $r3
  1074.     }
  1075.     -cleanup {
  1076. set ::tcltest::matchDirectories $old
  1077.     }
  1078.     -result {{} foo foo}
  1079. }
  1081. test tcltest-15.7 {skipDirectories} {
  1082.     -setup {
  1083. set old [skipDirectories]
  1084. set ::tcltest::skipDirectories {}
  1085.     }
  1086.     -body {
  1087. set r1 [skipDirectories]
  1088. set r2 [skipDirectories foo]
  1089. set r3 [skipDirectories]
  1090. list $r1 $r2 $r3
  1091.     }
  1092.     -cleanup {
  1093. set ::tcltest::skipDirectories $old
  1094.     }
  1095.     -result {{} foo foo}
  1096. }
  1097. removeDirectory dirtestdir2.3 $dtd
  1098. removeDirectory dirtestdir2.2 $dtd
  1099. removeDirectory dirtestdir2.1 $dtd
  1100. removeDirectory dirtestdir
  1102. # TCLTEST_OPTIONS
  1103. test tcltest-19.1 {TCLTEST_OPTIONS default} -setup {
  1104. if {[info exists ::env(TCLTEST_OPTIONS)]} {
  1105.     set oldoptions $::env(TCLTEST_OPTIONS)
  1106. } else {
  1107.     set oldoptions none
  1108. }
  1109. # set this to { } instead of just {} to get around quirk in
  1110. # Windows env handling that removes empty elements from env array.
  1111. set ::env(TCLTEST_OPTIONS) { }
  1112. interp create slave1
  1113. slave1 eval [list set argv {-debug 2}]
  1114. slave1 alias puts puts
  1115. interp create slave2
  1116. slave2 alias puts puts
  1117.     } -cleanup {
  1118. interp delete slave2
  1119. interp delete slave1
  1120. if {$oldoptions == "none"} {
  1121.     unset ::env(TCLTEST_OPTIONS) 
  1122. } else {
  1123.     set ::env(TCLTEST_OPTIONS) $oldoptions
  1124. }
  1125.     } -body {
  1126. slave1 eval [package ifneeded tcltest [package provide tcltest]]
  1127. slave1 eval tcltest::debug
  1128. set ::env(TCLTEST_OPTIONS) "-debug 3"
  1129. slave2 eval [package ifneeded tcltest [package provide tcltest]]
  1130. slave2 eval tcltest::debug
  1131.     } -result {^3$} -match regexp -output
  1132. {tcltest::debugs+= 2.*tcltest::debugs+= 3}
  1134. # Begin testing of tcltest procs ...
  1136. cd [temporaryDirectory]
  1137. # PrintError
  1138. test tcltest-20.1 {PrintError} {unixOrPc} {
  1139.     set result [slave msg $printerror]
  1140.     list $result [regexp "Error:  a really short string" $msg] 
  1141.     [regexp "     "quotes"" $msg] [regexp "    "Path" $msg] 
  1142.     [regexp "    "Really" $msg] [regexp Problem $msg]
  1143. } {1 1 1 1 1 1}
  1144. cd [workingDirectory]
  1145. removeFile printerror.tcl
  1147. # test::test
  1148. test tcltest-21.0 {name and desc but no args specified} -setup {
  1149.     set v [verbose]
  1150. } -cleanup {
  1151.     verbose $v
  1152. } -body {
  1153.    verbose {}
  1154.    test tcltest-21.0.0 bar
  1155. } -result {}
  1157. test tcltest-21.1 {expect with glob} {
  1158.     -body {
  1159. list a b c d e
  1160.     }
  1161.     -match glob
  1162.     -result {[ab] b c d e}
  1163. }
  1165. test tcltest-21.2 {force a test command failure} {
  1166.     -body {
  1167. test tcltest-21.2.0 {
  1168.     return 2
  1169. } {1}
  1170.     }
  1171.     -returnCodes 1
  1172.     -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
  1173. }
  1175. test tcltest-21.3 {test command with setup} {
  1176.     -setup {
  1177. set foo 1
  1178.     }
  1179.     -body {
  1180. set foo
  1181.     }
  1182.     -cleanup {unset foo}
  1183.     -result {1}
  1184. }
  1186. test tcltest-21.4 {test command with cleanup failure} {
  1187.     -setup {
  1188. if {[info exists foo]} {
  1189.     unset foo
  1190. }
  1191. set fail $::tcltest::currentFailure
  1192. set v [verbose]
  1193.     }
  1194.     -body {
  1195. verbose {}
  1196. test tcltest-21.4.0 {foo-1} {
  1197.     -cleanup {unset foo}
  1198. }
  1199.     }
  1200.     -result {^$}
  1201.     -match regexp
  1202.     -cleanup {verbose $v; set ::tcltest::currentFailure $fail}
  1203.     -output "Test cleanup failed:.*can't unset "foo": no such variable"
  1204. }
  1206. test tcltest-21.5 {test command with setup failure} {
  1207.     -setup {
  1208. if {[info exists foo]} {
  1209.     unset foo
  1210. }
  1211. set fail $::tcltest::currentFailure
  1212.     }
  1213.     -body {
  1214. test tcltest-21.5.0 {foo-2} {
  1215.     -setup {unset foo}
  1216. }
  1217.     }
  1218.     -result {^$}
  1219.     -match regexp
  1220.     -cleanup {set ::tcltest::currentFailure $fail}
  1221.     -output "Test setup failed:.*can't unset "foo": no such variable"
  1222. }
  1224. test tcltest-21.6 {test command - setup occurs before cleanup & before script} {
  1225.     -setup {set v [verbose]; set fail $::tcltest::currentFailure}
  1226.     -body {
  1227. verbose {}
  1228. test tcltest-21.6.0 {foo-3} {
  1229.     -setup {
  1230. if {[info exists foo]} {
  1231.     unset foo
  1232. }
  1233. set foo 1
  1234. set expected 2
  1235.     } 
  1236.     -body {
  1237. incr foo
  1238. set foo
  1239.     }
  1240.     -cleanup {
  1241. if {$foo != 2} {
  1242.     puts [outputChannel] "foo is wrong"
  1243. } else {
  1244.     puts [outputChannel] "foo is 2"
  1245. }
  1246.     }
  1247.     -result {$expected}
  1248. }
  1249.     }
  1250.     -cleanup {verbose $v; set ::tcltest::currentFailure $fail}
  1251.     -result {^$}
  1252.     -match regexp
  1253.     -output "foo is 2"
  1254. }
  1256. test tcltest-21.7 {test command - bad flag} {
  1257.     -setup {set fail $::tcltest::currentFailure}
  1258.     -cleanup {set ::tcltest::currentFailure $fail}
  1259.     -body {
  1260. test tcltest-21.7.0 {foo-4} {
  1261.     -foobar {}
  1262. }
  1263.     }
  1264.     -returnCodes 1
  1265.     -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
  1266. }
  1268. # alternate test command format (these are the same as 21.1-21.6, with the
  1269. # exception of being in the all-inline format)
  1271. test tcltest-21.7a {expect with glob} 
  1272. -body {list a b c d e} 
  1273. -result {[ab] b c d e} 
  1274. -match glob
  1276. test tcltest-21.8 {force a test command failure} 
  1277.     -setup {set fail $::tcltest::currentFailure} 
  1278.     -body {
  1279.         test tcltest-21.8.0 {
  1280.             return 2
  1281.         } {1}
  1282.     } 
  1283.     -returnCodes 1 
  1284.     -cleanup {set ::tcltest::currentFailure $fail} 
  1285.     -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
  1287. test tcltest-21.9 {test command with setup} 
  1288. -setup {set foo 1} 
  1289. -body {set foo} 
  1290. -cleanup {unset foo} 
  1291. -result {1}
  1293. test tcltest-21.10 {test command with cleanup failure} -setup {
  1294.     if {[info exists foo]} {
  1295. unset foo
  1296.     }
  1297.     set fail $::tcltest::currentFailure
  1298.     set v [verbose]
  1299. } -cleanup {
  1300.     verbose $v
  1301.     set ::tcltest::currentFailure $fail
  1302. } -body {
  1303.     verbose {}
  1304.     test tcltest-21.10.0 {foo-1} -cleanup {unset foo}
  1305. } -result {^$} -match regexp 
  1306. -output {Test cleanup failed:.*can't unset "foo": no such variable}
  1308. test tcltest-21.11 {test command with setup failure} -setup {
  1309.     if {[info exists foo]} {
  1310. unset foo
  1311.     }
  1312.     set fail $::tcltest::currentFailure
  1313. } -cleanup {set ::tcltest::currentFailure $fail} -body {
  1314.     test tcltest-21.11.0 {foo-2} -setup {unset foo}
  1315. } -result {^$} -output {Test setup failed:.*can't unset "foo": no such variable} -match regexp
  1317. test tcltest-21.12 {
  1318. test command - setup occurs before cleanup & before script
  1319. } -setup {
  1320. set fail $::tcltest::currentFailure
  1321. set v [verbose]
  1322. } -cleanup {
  1323. verbose $v
  1324. set ::tcltest::currentFailure $fail
  1325. } -body {
  1326.     verbose {}
  1327.     test tcltest-21.12.0 {foo-3} -setup {
  1328. if {[info exists foo]} {
  1329.     unset foo
  1330. }
  1331. set foo 1
  1332. set expected 2
  1333.     }  -body {
  1334. incr foo
  1335. set foo
  1336.     }  -cleanup {
  1337. if {$foo != 2} {
  1338.     puts [outputChannel] "foo is wrong"
  1339. } else {
  1340.     puts [outputChannel] "foo is 2"
  1341. }
  1342.     }  -result {$expected}
  1343. } -result {^$} -output {foo is 2} -match regexp
  1345. # test all.tcl usage (runAllTests); simulate .test file failure, as well as
  1346. # crashes to determine whether or not these errors are logged.
  1348. set atd [makeDirectory alltestdir]
  1349. makeFile {
  1350.     package require tcltest
  1351.     namespace import -force tcltest::*
  1352.     testsDirectory [file join [temporaryDirectory] alltestdir]
  1353.     runAllTests
  1354. } all.tcl $atd
  1355. makeFile {
  1356.     exit 1
  1357. } exit.test $atd
  1358. makeFile {
  1359.     error "throw an error"
  1360. } error.test $atd
  1361. makeFile {
  1362.     package require tcltest
  1363.     namespace import -force tcltest::*
  1364.     test foo-1.1 {foo} {
  1365. -body { return 1 }
  1366. -result {1}
  1367.     }
  1368.     cleanupTests
  1369. } test.test $atd
  1371. # Must use a child process because stdout/stderr parsing can't be
  1372. # duplicated in slave interp.
  1373. test tcltest-22.1 {runAllTests} {
  1374.     -constraints {unixOrPc}
  1375.     -body {
  1376. exec [interpreter] 
  1377. [file join $atd all.tcl] 
  1378. -verbose t -tmpdir [temporaryDirectory]
  1379.     }
  1380.     -match regexp
  1381.     -result "Test files exiting with errors:.*error.test.*exit.test"
  1382. }
  1383. removeDirectory alltestdir
  1385. # makeFile, removeFile, makeDirectory, removeDirectory, viewFile
  1386. test tcltest-23.1 {makeFile} {
  1387.     -setup {
  1388. set mfdir [file join [temporaryDirectory] mfdir]
  1389. file mkdir $mfdir
  1390.     }
  1391.     -body {
  1392. makeFile {} t1.tmp
  1393. makeFile {} et1.tmp $mfdir
  1394. list [file exists [file join [temporaryDirectory] t1.tmp]] 
  1395. [file exists [file join $mfdir et1.tmp]]
  1396.     }
  1397.     -cleanup {
  1398. file delete -force $mfdir 
  1399. [file join [temporaryDirectory] t1.tmp] 
  1400.     }
  1401.     -result {1 1}
  1402. }
  1403. test tcltest-23.2 {removeFile} {
  1404.     -setup {
  1405. set mfdir [file join [temporaryDirectory] mfdir]
  1406. file mkdir $mfdir
  1407. makeFile {} t1.tmp
  1408. makeFile {} et1.tmp $mfdir
  1409. if  {![file exists [file join [temporaryDirectory] t1.tmp]] || 
  1410. ![file exists [file join $mfdir et1.tmp]]} {
  1411.     error "file creation didn't work"
  1412. }
  1413.     }
  1414.     -body {
  1415. removeFile t1.tmp
  1416. removeFile et1.tmp $mfdir
  1417. list [file exists [file join [temporaryDirectory] t1.tmp]] 
  1418. [file exists [file join $mfdir et1.tmp]]
  1419.     }
  1420.     -cleanup {
  1421. file delete -force $mfdir 
  1422. [file join [temporaryDirectory] t1.tmp] 
  1423.     }
  1424.     -result {0 0}
  1425. }
  1426. test tcltest-23.3 {makeDirectory} {
  1427.     -body {
  1428. set mfdir [file join [temporaryDirectory] mfdir]
  1429. file mkdir $mfdir
  1430. makeDirectory d1
  1431. makeDirectory d2 $mfdir
  1432. list [file exists [file join [temporaryDirectory] d1]] 
  1433. [file exists [file join $mfdir d2]]
  1434.     }
  1435.     -cleanup {
  1436. file delete -force [file join [temporaryDirectory] d1] $mfdir
  1437.     }
  1438.     -result {1 1}
  1439. }
  1440. test tcltest-23.4 {removeDirectory} {
  1441.     -setup {
  1442. set mfdir [makeDirectory mfdir]
  1443. makeDirectory t1
  1444. makeDirectory t2 $mfdir
  1445. if {![file exists $mfdir] || 
  1446. ![file exists [file join [temporaryDirectory] $mfdir t2]]} {
  1447.     error "setup failed - directory not created"
  1448. }
  1449.     }
  1450.     -body {
  1451. removeDirectory t1
  1452. removeDirectory t2 $mfdir
  1453. list [file exists [file join [temporaryDirectory] t1]] 
  1454. [file exists [file join $mfdir t2]]
  1455.     }
  1456.     -result {0 0}
  1457. }
  1458. test tcltest-23.5 {viewFile} {
  1459.     -body {
  1460. set mfdir [file join [temporaryDirectory] mfdir]
  1461. file mkdir $mfdir
  1462. makeFile {foobar} t1.tmp
  1463. makeFile {foobarbaz} t2.tmp $mfdir
  1464. list [viewFile t1.tmp] [viewFile t2.tmp $mfdir]
  1465.     }
  1466.     -result {foobar foobarbaz}
  1467.     -cleanup {
  1468. file delete -force $mfdir
  1469. removeFile t1.tmp
  1470.     }
  1471. }
  1473. # customMatch
  1474. proc matchNegative { expected actual } {
  1475.    set match 0
  1476.    foreach a $actual e $expected {
  1477.       if { $a != $e } {
  1478.          set match 1
  1479.         break
  1480.       }
  1481.    }
  1482.    return $match
  1483. }
  1485. test tcltest-24.0 {
  1486. customMatch: syntax
  1487. } -body {
  1488. list [catch {customMatch} result] $result
  1489. } -result [list 1 "wrong # args: should be "customMatch mode script""]
  1491. test tcltest-24.1 {
  1492. customMatch: syntax
  1493. } -body {
  1494. list [catch {customMatch foo} result] $result
  1495. } -result [list 1 "wrong # args: should be "customMatch mode script""]
  1497. test tcltest-24.2 {
  1498. customMatch: syntax
  1499. } -body {
  1500. list [catch {customMatch foo bar baz} result] $result
  1501. } -result [list 1 "wrong # args: should be "customMatch mode script""]
  1503. test tcltest-24.3 {
  1504. customMatch: argument checking
  1505. } -body {
  1506. list [catch {customMatch bad "a { b"} result] $result
  1507. } -result [list 1 "invalid customMatch script; can't evaluate after completion"]
  1509. test tcltest-24.4 {
  1510. test: valid -match values
  1511. } -body {
  1512. list [catch {
  1513. test tcltest-24.4.0 {} 
  1514. -match [namespace current]::noSuchMode
  1515. } result] $result
  1516. } -match glob -result {1 *bad -match value*}
  1518. test tcltest-24.5 {
  1519. test: valid -match values
  1520. } -setup {
  1521. customMatch [namespace current]::alwaysMatch "format 1 ;#"
  1522. } -body {
  1523. list [catch {
  1524. test tcltest-24.5.0 {} 
  1525. -match [namespace current]::noSuchMode
  1526. } result] $result
  1527. } -match glob -result {1 *bad -match value*: must be *alwaysMatch,*}
  1529. test tcltest-24.6 {
  1530. customMatch: -match script that always matches
  1531. } -setup {
  1532. customMatch [namespace current]::alwaysMatch "format 1 ;#"
  1533. set v [verbose]
  1534. } -body {
  1535. verbose {}
  1536. test tcltest-24.6.0 {} -match [namespace current]::alwaysMatch 
  1537. -body {format 1} -result 0
  1538. } -cleanup {
  1539. verbose $v
  1540. } -result {} -output {} -errorOutput {}
  1542. test tcltest-24.7 {
  1543. customMatch: replace default -exact matching
  1544. } -setup {
  1545. set saveExactMatchScript $::tcltest::CustomMatch(exact)
  1546. customMatch exact "format 1 ;#"
  1547. set v [verbose]
  1548. } -body {
  1549. verbose {}
  1550. test tcltest-24.7.0 {} -body {format 1} -result 0
  1551. } -cleanup {
  1552. verbose $v
  1553. customMatch exact $saveExactMatchScript
  1554. unset saveExactMatchScript
  1555. } -result {} -output {}
  1557. test tcltest-24.9 {
  1558. customMatch: error during match
  1559. } -setup {
  1560. proc errorDuringMatch args {return -code error "match returned error"}
  1561. customMatch [namespace current]::errorDuringMatch 
  1562. [namespace code errorDuringMatch]
  1563. set v [verbose]
  1564. set fail $::tcltest::currentFailure
  1565. } -body {
  1566. verbose {}
  1567. test tcltest-24.9.0 {} -match [namespace current]::errorDuringMatch
  1568. } -cleanup {
  1569. verbose $v
  1570. set ::tcltest::currentFailure $fail
  1571. } -match glob -result {} -output {*FAILED*match returned error*}
  1573. test tcltest-24.10 {
  1574. customMatch: bad return from match command
  1575. } -setup {
  1576. proc nonBooleanReturn args {return foo}
  1577. customMatch nonBooleanReturn [namespace code nonBooleanReturn]
  1578. set v [verbose]
  1579. set fail $::tcltest::currentFailure
  1580. } -body {
  1581. verbose {}
  1582. test tcltest-24.10.0 {} -match nonBooleanReturn
  1583. } -cleanup {
  1584. verbose $v
  1585. set ::tcltest::currentFailure $fail
  1586. } -match glob -result {} -output {*FAILED*expected boolean value*}
  1588. test tcltest-24.11 {
  1589. test: -match exact
  1590. } -body {
  1591. set result {A B C}
  1592. } -match exact -result {A B C}
  1594. test tcltest-24.12 {
  1595. test: -match exact match command eval in ::, not caller namespace
  1596. } -setup {
  1597. set saveExactMatchScript $::tcltest::CustomMatch(exact)
  1598. customMatch exact [list string equal]
  1599. set v [verbose]
  1600. proc string args {error {called [string] in caller namespace}}
  1601. } -body {
  1602. verbose {}
  1603. test tcltest-24.12.0 {} -body {format 1} -result 1
  1604. } -cleanup {
  1605. rename string {}
  1606. verbose $v
  1607. customMatch exact $saveExactMatchScript
  1608. unset saveExactMatchScript
  1609. } -match exact -result {} -output {}
  1611. test tcltest-24.13 {
  1612. test: -match exact failure
  1613. } -setup {
  1614. set saveExactMatchScript $::tcltest::CustomMatch(exact)
  1615. customMatch exact [list string equal]
  1616. set v [verbose]
  1617. set fail $::tcltest::currentFailure
  1618. } -body {
  1619. verbose {}
  1620. test tcltest-24.13.0 {} -body {format 1} -result 0
  1621. } -cleanup {
  1622. set ::tcltest::currentFailure $fail
  1623. verbose $v
  1624. customMatch exact $saveExactMatchScript
  1625. unset saveExactMatchScript
  1626. } -match glob -result {} -output {*FAILED*Result was:
  1627. 1*(exact matching):
  1628. 0*}
  1630. test tcltest-24.14 {
  1631. test: -match glob
  1632. } -body {
  1633. set result {A B C}
  1634. } -match glob -result {A B*}
  1636. test tcltest-24.15 {
  1637. test: -match glob failure
  1638. } -setup {
  1639. set v [verbose]
  1640. set fail $::tcltest::currentFailure
  1641. } -body {
  1642. verbose {}
  1643. test tcltest-24.15.0 {} -match glob -body {format {A B C}} 
  1644. -result {A B* }
  1645. } -cleanup {
  1646. set ::tcltest::currentFailure $fail
  1647. verbose $v
  1648. } -match glob -result {} -output {*FAILED*Result was:
  1649. *(glob matching):
  1650. *}
  1652. test tcltest-24.16 {
  1653. test: -match regexp
  1654. } -body {
  1655. set result {A B C}
  1656. } -match regexp -result {A B.*}
  1658. test tcltest-24.17 {
  1659. test: -match regexp failure
  1660. } -setup {
  1661. set fail $::tcltest::currentFailure
  1662. set v [verbose]
  1663. } -body {
  1664. verbose {}
  1665. test tcltest-24.17.0 {} -match regexp -body {format {A B C}} 
  1666. -result {A B.* X}
  1667. } -cleanup {
  1668. set ::tcltest::currentFailure $fail
  1669. verbose $v
  1670. } -match glob -result {} -output {*FAILED*Result was:
  1671. *(regexp matching):
  1672. *}
  1674. test tcltest-24.18 {
  1675. test: -match custom forget namespace qualification
  1676. } -setup {
  1677. set fail $::tcltest::currentFailure
  1678. set v [verbose]
  1679. customMatch negative matchNegative
  1680. } -body {
  1681. verbose {}
  1682. test tcltest-24.18.0 {} -match negative -body {format {A B C}} 
  1683. -result {A B X}
  1684. } -cleanup {
  1685. set ::tcltest::currentFailure $fail
  1686. verbose $v
  1687. } -match glob -result {} -output {*FAILED*Error testing result:*}
  1689. test tcltest-24.19 {
  1690. test: -match custom
  1691. } -setup {
  1692. set v [verbose]
  1693. customMatch negative [namespace code matchNegative]
  1694. } -body {
  1695. verbose {}
  1696. test tcltest-24.19.0 {} -match negative -body {format {A B C}} 
  1697. -result {A B X}
  1698. } -cleanup {
  1699. verbose $v
  1700. } -match exact -result {} -output {}
  1702. test tcltest-24.20 {
  1703. test: -match custom failure
  1704. } -setup {
  1705. set fail $::tcltest::currentFailure
  1706. set v [verbose]
  1707. customMatch negative [namespace code matchNegative]
  1708. } -body {
  1709. verbose {}
  1710. test tcltest-24.20.0 {} -match negative -body {format {A B C}} 
  1711. -result {A B C}
  1712. } -cleanup {
  1713. set ::tcltest::currentFailure $fail
  1714. verbose $v
  1715. } -match glob -result {} -output {*FAILED*Result was:
  1716. *(negative matching):
  1717. *}
  1719. test tcltest-25.1 {
  1720. constraint of setup/cleanup (Bug 589859)
  1721. } -setup {
  1722. set foo 0
  1723. } -body {
  1724. # Buggy tcltest will generate result of 2
  1725. test tcltest-25.1.0 {} -constraints knownBug -setup {
  1726.     incr foo
  1727. } -body {
  1728.     incr foo
  1729. } -cleanup {
  1730.     incr foo
  1731. } -match glob -result *
  1732. set foo
  1733. } -cleanup {
  1734. unset foo
  1735. } -result 0
  1737. test tcltest-25.2 {
  1738. puts -nonewline (Bug 612786)
  1739. } -body {
  1740. puts -nonewline stdout bla
  1741. puts -nonewline stdout bla
  1742. } -output {blabla}
  1744. test tcltest-25.3 {
  1745. reported return code (Bug 611922)
  1746. } -setup {
  1747. set fail $::tcltest::currentFailure
  1748. set v [verbose]
  1749. } -body {
  1750. verbose {}
  1751. test tcltest-25.3.0 {} -body {
  1752.     error foo
  1753. }
  1754. } -cleanup {
  1755. set ::tcltest::currentFailure $fail
  1756. verbose $v
  1757. } -match glob -output {*generated error; Return code was: 1*}
  1759. test tcltest-26.1 {Bug/RFE 1017151} -setup {
  1760.     makeFile {
  1761. package require tcltest
  1762. set errorInfo "Should never see this"
  1763. tcltest::test tcltest-26.1.0 {
  1764.     no errorInfo when only return code mismatch
  1765. } -body {
  1766.     set x 1
  1767. } -returnCodes error -result 1
  1768. tcltest::cleanupTests
  1769.     } test.tcl
  1770. } -body {
  1771.     slave msg [file join [temporaryDirectory] test.tcl]
  1772.     set msg
  1773. } -cleanup {
  1774.     removeFile test.tcl
  1775. } -match glob -result {*
  1776. ---- Return code should have been one of: 1
  1777. ==== tcltest-26.1.0 FAILED*}
  1779. test tcltest-26.2 {Bug/RFE 1017151} -setup {
  1780.     makeFile {
  1781. package require tcltest
  1782. set errorInfo "Should never see this"
  1783. tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body {
  1784.     error "body error"
  1785. } -cleanup {
  1786.     error "cleanup error"
  1787. } -result 1
  1788. tcltest::cleanupTests
  1789.     } test.tcl
  1790. } -body {
  1791.     slave msg [file join [temporaryDirectory] test.tcl]
  1792.     set msg
  1793. } -cleanup {
  1794.     removeFile test.tcl
  1795. } -match glob -result {*
  1796. ---- errorInfo: body error
  1797. *
  1798. ---- errorInfo(cleanup): cleanup error*}
  1800. cleanupTests
  1801. }
  1803. namespace delete ::tcltest::test
  1804. return