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, 6# etc. used by Tcl tests. See the tcltest man page for more 7# details. 8# 9# This design was based on the Tcl testing approach designed and 10# initially implemented by Mary Ann May-Pumphrey of Sun 11# Microsystems. 12# 13# Copyright (c) 1994-1997 Sun Microsystems, Inc. 14# Copyright (c) 1998-1999 by Scriptics Corporation. 15# Copyright (c) 2000 by Ajuba Solutions 16# Contributions from Don Porter, NIST, 2002. (not subject to US copyright) 17# All rights reserved. 18# 19# RCS: @(#) $Id: tcltest.tcl,v 1.103.2.3 2009/09/01 14:13:02 dgp Exp $ 20 21package require Tcl 8.5 ;# -verbose line uses [info frame] 22namespace eval tcltest { 23 24 # When the version number changes, be sure to update the pkgIndex.tcl file, 25 # and the install directory in the Makefiles. When the minor version 26 # changes (new feature) be sure to update the man page as well. 27 variable Version 2.3.2 28 29 # Compatibility support for dumb variables defined in tcltest 1 30 # Do not use these. Call [package provide Tcl] and [info patchlevel] 31 # yourself. You don't need tcltest to wrap it for you. 32 variable version [package provide Tcl] 33 variable patchLevel [info patchlevel] 34 35##### Export the public tcltest procs; several categories 36 # 37 # Export the main functional commands that do useful things 38 namespace export cleanupTests loadTestedCommands makeDirectory \ 39 makeFile removeDirectory removeFile runAllTests test 40 41 # Export configuration commands that control the functional commands 42 namespace export configure customMatch errorChannel interpreter \ 43 outputChannel testConstraint 44 45 # Export commands that are duplication (candidates for deprecation) 46 namespace export bytestring ;# dups [encoding convertfrom identity] 47 namespace export debug ;# [configure -debug] 48 namespace export errorFile ;# [configure -errfile] 49 namespace export limitConstraints ;# [configure -limitconstraints] 50 namespace export loadFile ;# [configure -loadfile] 51 namespace export loadScript ;# [configure -load] 52 namespace export match ;# [configure -match] 53 namespace export matchFiles ;# [configure -file] 54 namespace export matchDirectories ;# [configure -relateddir] 55 namespace export normalizeMsg ;# application of [customMatch] 56 namespace export normalizePath ;# [file normalize] (8.4) 57 namespace export outputFile ;# [configure -outfile] 58 namespace export preserveCore ;# [configure -preservecore] 59 namespace export singleProcess ;# [configure -singleproc] 60 namespace export skip ;# [configure -skip] 61 namespace export skipFiles ;# [configure -notfile] 62 namespace export skipDirectories ;# [configure -asidefromdir] 63 namespace export temporaryDirectory ;# [configure -tmpdir] 64 namespace export testsDirectory ;# [configure -testdir] 65 namespace export verbose ;# [configure -verbose] 66 namespace export viewFile ;# binary encoding [read] 67 namespace export workingDirectory ;# [cd] [pwd] 68 69 # Export deprecated commands for tcltest 1 compatibility 70 namespace export getMatchingFiles mainThread restoreState saveState \ 71 threadReap 72 73 # tcltest::normalizePath -- 74 # 75 # This procedure resolves any symlinks in the path thus creating 76 # a path without internal redirection. It assumes that the 77 # incoming path is absolute. 78 # 79 # Arguments 80 # pathVar - name of variable containing path to modify. 81 # 82 # Results 83 # The path is modified in place. 84 # 85 # Side Effects: 86 # None. 87 # 88 proc normalizePath {pathVar} { 89 upvar $pathVar path 90 set oldpwd [pwd] 91 catch {cd $path} 92 set path [pwd] 93 cd $oldpwd 94 return $path 95 } 96 97##### Verification commands used to test values of variables and options 98 # 99 # Verification command that accepts everything 100 proc AcceptAll {value} { 101 return $value 102 } 103 104 # Verification command that accepts valid Tcl lists 105 proc AcceptList { list } { 106 return [lrange $list 0 end] 107 } 108 109 # Verification command that accepts a glob pattern 110 proc AcceptPattern { pattern } { 111 return [AcceptAll $pattern] 112 } 113 114 # Verification command that accepts integers 115 proc AcceptInteger { level } { 116 return [incr level 0] 117 } 118 119 # Verification command that accepts boolean values 120 proc AcceptBoolean { boolean } { 121 return [expr {$boolean && $boolean}] 122 } 123 124 # Verification command that accepts (syntactically) valid Tcl scripts 125 proc AcceptScript { script } { 126 if {![info complete $script]} { 127 return -code error "invalid Tcl script: $script" 128 } 129 return $script 130 } 131 132 # Verification command that accepts (converts to) absolute pathnames 133 proc AcceptAbsolutePath { path } { 134 return [file join [pwd] $path] 135 } 136 137 # Verification command that accepts existing readable directories 138 proc AcceptReadable { path } { 139 if {![file readable $path]} { 140 return -code error "\"$path\" is not readable" 141 } 142 return $path 143 } 144 proc AcceptDirectory { directory } { 145 set directory [AcceptAbsolutePath $directory] 146 if {![file exists $directory]} { 147 return -code error "\"$directory\" does not exist" 148 } 149 if {![file isdir $directory]} { 150 return -code error "\"$directory\" is not a directory" 151 } 152 return [AcceptReadable $directory] 153 } 154 155##### Initialize internal arrays of tcltest, but only if the caller 156 # has not already pre-initialized them. This is done to support 157 # compatibility with older tests that directly access internals 158 # rather than go through command interfaces. 159 # 160 proc ArrayDefault {varName value} { 161 variable $varName 162 if {[array exists $varName]} { 163 return 164 } 165 if {[info exists $varName]} { 166 # Pre-initialized value is a scalar: destroy it! 167 unset $varName 168 } 169 array set $varName $value 170 } 171 172 # save the original environment so that it can be restored later 173 ArrayDefault originalEnv [array get ::env] 174 175 # initialize numTests array to keep track of the number of tests 176 # that pass, fail, and are skipped. 177 ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0] 178 179 # createdNewFiles will store test files as indices and the list of 180 # files (that should not have been) left behind by the test files 181 # as values. 182 ArrayDefault createdNewFiles {} 183 184 # initialize skippedBecause array to keep track of constraints that 185 # kept tests from running; a constraint name of "userSpecifiedSkip" 186 # means that the test appeared on the list of tests that matched the 187 # -skip value given to the flag; "userSpecifiedNonMatch" means that 188 # the test didn't match the argument given to the -match flag; both 189 # of these constraints are counted only if tcltest::debug is set to 190 # true. 191 ArrayDefault skippedBecause {} 192 193 # initialize the testConstraints array to keep track of valid 194 # predefined constraints (see the explanation for the 195 # InitConstraints proc for more details). 196 ArrayDefault testConstraints {} 197 198##### Initialize internal variables of tcltest, but only if the caller 199 # has not already pre-initialized them. This is done to support 200 # compatibility with older tests that directly access internals 201 # rather than go through command interfaces. 202 # 203 proc Default {varName value {verify AcceptAll}} { 204 variable $varName 205 if {![info exists $varName]} { 206 variable $varName [$verify $value] 207 } else { 208 variable $varName [$verify [set $varName]] 209 } 210 } 211 212 # Save any arguments that we might want to pass through to other 213 # programs. This is used by the -args flag. 214 # FINDUSER 215 Default parameters {} 216 217 # Count the number of files tested (0 if runAllTests wasn't called). 218 # runAllTests will set testSingleFile to false, so stats will 219 # not be printed until runAllTests calls the cleanupTests proc. 220 # The currentFailure var stores the boolean value of whether the 221 # current test file has had any failures. The failFiles list 222 # stores the names of test files that had failures. 223 Default numTestFiles 0 AcceptInteger 224 Default testSingleFile true AcceptBoolean 225 Default currentFailure false AcceptBoolean 226 Default failFiles {} AcceptList 227 228 # Tests should remove all files they create. The test suite will 229 # check the current working dir for files created by the tests. 230 # filesMade keeps track of such files created using the makeFile and 231 # makeDirectory procedures. filesExisted stores the names of 232 # pre-existing files. 233 # 234 # Note that $filesExisted lists only those files that exist in 235 # the original [temporaryDirectory]. 236 Default filesMade {} AcceptList 237 Default filesExisted {} AcceptList 238 proc FillFilesExisted {} { 239 variable filesExisted 240 241 # Save the names of files that already exist in the scratch directory. 242 foreach file [glob -nocomplain -directory [temporaryDirectory] *] { 243 lappend filesExisted [file tail $file] 244 } 245 246 # After successful filling, turn this into a no-op. 247 proc FillFilesExisted args {} 248 } 249 250 # Kept only for compatibility 251 Default constraintsSpecified {} AcceptList 252 trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \ 253 [array names ::tcltest::testConstraints] ;# } 254 255 # tests that use threads need to know which is the main thread 256 Default mainThread 1 257 variable mainThread 258 if {[info commands thread::id] != {}} { 259 set mainThread [thread::id] 260 } elseif {[info commands testthread] != {}} { 261 set mainThread [testthread id] 262 } 263 264 # Set workingDirectory to [pwd]. The default output directory for 265 # Tcl tests is the working directory. Whenever this value changes 266 # change to that directory. 267 variable workingDirectory 268 trace variable workingDirectory w \ 269 [namespace code {cd $workingDirectory ;#}] 270 271 Default workingDirectory [pwd] AcceptAbsolutePath 272 proc workingDirectory { {dir ""} } { 273 variable workingDirectory 274 if {[llength [info level 0]] == 1} { 275 return $workingDirectory 276 } 277 set workingDirectory [AcceptAbsolutePath $dir] 278 } 279 280 # Set the location of the execuatble 281 Default tcltest [info nameofexecutable] 282 trace variable tcltest w [namespace code {testConstraint stdio \ 283 [eval [ConstraintInitializer stdio]] ;#}] 284 285 # save the platform information so it can be restored later 286 Default originalTclPlatform [array get ::tcl_platform] 287 288 # If a core file exists, save its modification time. 289 if {[file exists [file join [workingDirectory] core]]} { 290 Default coreModTime \ 291 [file mtime [file join [workingDirectory] core]] 292 } 293 294 # stdout and stderr buffers for use when we want to store them 295 Default outData {} 296 Default errData {} 297 298 # keep track of test level for nested test commands 299 variable testLevel 0 300 301 # the variables and procs that existed when saveState was called are 302 # stored in a variable of the same name 303 Default saveState {} 304 305 # Internationalization support -- used in [SetIso8859_1_Locale] and 306 # [RestoreLocale]. Those commands are used in cmdIL.test. 307 308 if {![info exists [namespace current]::isoLocale]} { 309 variable isoLocale fr 310 switch -- $::tcl_platform(platform) { 311 "unix" { 312 313 # Try some 'known' values for some platforms: 314 315 switch -exact -- $::tcl_platform(os) { 316 "FreeBSD" { 317 set isoLocale fr_FR.ISO_8859-1 318 } 319 HP-UX { 320 set isoLocale fr_FR.iso88591 321 } 322 Linux - 323 IRIX { 324 set isoLocale fr 325 } 326 default { 327 328 # Works on SunOS 4 and Solaris, and maybe 329 # others... Define it to something else on your 330 # system if you want to test those. 331 332 set isoLocale iso_8859_1 333 } 334 } 335 } 336 "windows" { 337 set isoLocale French 338 } 339 } 340 } 341 342 variable ChannelsWeOpened; array set ChannelsWeOpened {} 343 # output goes to stdout by default 344 Default outputChannel stdout 345 proc outputChannel { {filename ""} } { 346 variable outputChannel 347 variable ChannelsWeOpened 348 349 # This is very subtle and tricky, so let me try to explain. 350 # (Hopefully this longer comment will be clear when I come 351 # back in a few months, unlike its predecessor :) ) 352 # 353 # The [outputChannel] command (and underlying variable) have to 354 # be kept in sync with the [configure -outfile] configuration 355 # option ( and underlying variable Option(-outfile) ). This is 356 # accomplished with a write trace on Option(-outfile) that will 357 # update [outputChannel] whenver a new value is written. That 358 # much is easy. 359 # 360 # The trick is that in order to maintain compatibility with 361 # version 1 of tcltest, we must allow every configuration option 362 # to get its inital value from command line arguments. This is 363 # accomplished by setting initial read traces on all the 364 # configuration options to parse the command line option the first 365 # time they are read. These traces are cancelled whenever the 366 # program itself calls [configure]. 367 # 368 # OK, then so to support tcltest 1 compatibility, it seems we want 369 # to get the return from [outputFile] to trigger the read traces, 370 # just in case. 371 # 372 # BUT! A little known feature of Tcl variable traces is that 373 # traces are disabled during the handling of other traces. So, 374 # if we trigger read traces on Option(-outfile) and that triggers 375 # command line parsing which turns around and sets an initial 376 # value for Option(-outfile) -- <whew!> -- the write trace that 377 # would keep [outputChannel] in sync with that new initial value 378 # would not fire! 379 # 380 # SO, finally, as a workaround, instead of triggering read traces 381 # by invoking [outputFile], we instead trigger the same set of 382 # read traces by invoking [debug]. Any command that reads a 383 # configuration option would do. [debug] is just a handy one. 384 # The end result is that we support tcltest 1 compatibility and 385 # keep outputChannel and -outfile in sync in all cases. 386 debug 387 388 if {[llength [info level 0]] == 1} { 389 return $outputChannel 390 } 391 if {[info exists ChannelsWeOpened($outputChannel)]} { 392 close $outputChannel 393 unset ChannelsWeOpened($outputChannel) 394 } 395 switch -exact -- $filename { 396 stderr - 397 stdout { 398 set outputChannel $filename 399 } 400 default { 401 set outputChannel [open $filename a] 402 set ChannelsWeOpened($outputChannel) 1 403 404 # If we created the file in [temporaryDirectory], then 405 # [cleanupTests] will delete it, unless we claim it was 406 # already there. 407 set outdir [normalizePath [file dirname \ 408 [file join [pwd] $filename]]] 409 if {[string equal $outdir [temporaryDirectory]]} { 410 variable filesExisted 411 FillFilesExisted 412 set filename [file tail $filename] 413 if {[lsearch -exact $filesExisted $filename] == -1} { 414 lappend filesExisted $filename 415 } 416 } 417 } 418 } 419 return $outputChannel 420 } 421 422 # errors go to stderr by default 423 Default errorChannel stderr 424 proc errorChannel { {filename ""} } { 425 variable errorChannel 426 variable ChannelsWeOpened 427 428 # This is subtle and tricky. See the comment above in 429 # [outputChannel] for a detailed explanation. 430 debug 431 432 if {[llength [info level 0]] == 1} { 433 return $errorChannel 434 } 435 if {[info exists ChannelsWeOpened($errorChannel)]} { 436 close $errorChannel 437 unset ChannelsWeOpened($errorChannel) 438 } 439 switch -exact -- $filename { 440 stderr - 441 stdout { 442 set errorChannel $filename 443 } 444 default { 445 set errorChannel [open $filename a] 446 set ChannelsWeOpened($errorChannel) 1 447 448 # If we created the file in [temporaryDirectory], then 449 # [cleanupTests] will delete it, unless we claim it was 450 # already there. 451 set outdir [normalizePath [file dirname \ 452 [file join [pwd] $filename]]] 453 if {[string equal $outdir [temporaryDirectory]]} { 454 variable filesExisted 455 FillFilesExisted 456 set filename [file tail $filename] 457 if {[lsearch -exact $filesExisted $filename] == -1} { 458 lappend filesExisted $filename 459 } 460 } 461 } 462 } 463 return $errorChannel 464 } 465 466##### Set up the configurable options 467 # 468 # The configurable options of the package 469 variable Option; array set Option {} 470 471 # Usage strings for those options 472 variable Usage; array set Usage {} 473 474 # Verification commands for those options 475 variable Verify; array set Verify {} 476 477 # Initialize the default values of the configurable options that are 478 # historically associated with an exported variable. If that variable 479 # is already set, support compatibility by accepting its pre-set value. 480 # Use [trace] to establish ongoing connection between the deprecated 481 # exported variable and the modern option kept as a true internal var. 482 # Also set up usage string and value testing for the option. 483 proc Option {option value usage {verify AcceptAll} {varName {}}} { 484 variable Option 485 variable Verify 486 variable Usage 487 variable OptionControlledVariables 488 set Usage($option) $usage 489 set Verify($option) $verify 490 if {[catch {$verify $value} msg]} { 491 return -code error $msg 492 } else { 493 set Option($option) $msg 494 } 495 if {[string length $varName]} { 496 variable $varName 497 if {[info exists $varName]} { 498 if {[catch {$verify [set $varName]} msg]} { 499 return -code error $msg 500 } else { 501 set Option($option) $msg 502 } 503 unset $varName 504 } 505 namespace eval [namespace current] \ 506 [list upvar 0 Option($option) $varName] 507 # Workaround for Bug (now Feature Request) 572889. Grrrr.... 508 # Track all the variables tied to options 509 lappend OptionControlledVariables $varName 510 # Later, set auto-configure read traces on all 511 # of them, since a single trace on Option does not work. 512 proc $varName {{value {}}} [subst -nocommands { 513 if {[llength [info level 0]] == 2} { 514 Configure $option [set value] 515 } 516 return [Configure $option] 517 }] 518 } 519 } 520 521 proc MatchingOption {option} { 522 variable Option 523 set match [array names Option $option*] 524 switch -- [llength $match] { 525 0 { 526 set sorted [lsort [array names Option]] 527 set values [join [lrange $sorted 0 end-1] ", "] 528 append values ", or [lindex $sorted end]" 529 return -code error "unknown option $option: should be\ 530 one of $values" 531 } 532 1 { 533 return [lindex $match 0] 534 } 535 default { 536 # Exact match trumps ambiguity 537 if {[lsearch -exact $match $option] >= 0} { 538 return $option 539 } 540 set values [join [lrange $match 0 end-1] ", "] 541 append values ", or [lindex $match end]" 542 return -code error "ambiguous option $option:\ 543 could match $values" 544 } 545 } 546 } 547 548 proc EstablishAutoConfigureTraces {} { 549 variable OptionControlledVariables 550 foreach varName [concat $OptionControlledVariables Option] { 551 variable $varName 552 trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}] 553 } 554 } 555 556 proc RemoveAutoConfigureTraces {} { 557 variable OptionControlledVariables 558 foreach varName [concat $OptionControlledVariables Option] { 559 variable $varName 560 foreach pair [trace vinfo $varName] { 561 foreach {op cmd} $pair break 562 if {[string equal r $op] 563 && [string match *ProcessCmdLineArgs* $cmd]} { 564 trace vdelete $varName $op $cmd 565 } 566 } 567 } 568 # Once the traces are removed, this can become a no-op 569 proc RemoveAutoConfigureTraces {} {} 570 } 571 572 proc Configure args { 573 variable Option 574 variable Verify 575 set n [llength $args] 576 if {$n == 0} { 577 return [lsort [array names Option]] 578 } 579 if {$n == 1} { 580 if {[catch {MatchingOption [lindex $args 0]} option]} { 581 return -code error $option 582 } 583 return $Option($option) 584 } 585 while {[llength $args] > 1} { 586 if {[catch {MatchingOption [lindex $args 0]} option]} { 587 return -code error $option 588 } 589 if {[catch {$Verify($option) [lindex $args 1]} value]} { 590 return -code error "invalid $option\ 591 value \"[lindex $args 1]\": $value" 592 } 593 set Option($option) $value 594 set args [lrange $args 2 end] 595 } 596 if {[llength $args]} { 597 if {[catch {MatchingOption [lindex $args 0]} option]} { 598 return -code error $option 599 } 600 return -code error "missing value for option $option" 601 } 602 } 603 proc configure args { 604 RemoveAutoConfigureTraces 605 set code [catch {Configure {*}$args} msg] 606 return -code $code $msg 607 } 608 609 proc AcceptVerbose { level } { 610 set level [AcceptList $level] 611 if {[llength $level] == 1} { 612 if {![regexp {^(pass|body|skip|start|error|line)$} $level]} { 613 # translate single characters abbreviations to expanded list 614 set level [string map {p pass b body s skip t start e error l line} \ 615 [split $level {}]] 616 } 617 } 618 set valid [list] 619 foreach v $level { 620 if {[regexp {^(pass|body|skip|start|error|line)$} $v]} { 621 lappend valid $v 622 } 623 } 624 return $valid 625 } 626 627 proc IsVerbose {level} { 628 variable Option 629 return [expr {[lsearch -exact $Option(-verbose) $level] != -1}] 630 } 631 632 # Default verbosity is to show bodies of failed tests 633 Option -verbose {body error} { 634 Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'. 635 Test suite will display all passed tests if 'p' is specified, all 636 skipped tests if 's' is specified, the bodies of failed tests if 637 'b' is specified, and when tests start if 't' is specified. 638 ErrorInfo is displayed if 'e' is specified. Source file line 639 information of failed tests is displayed if 'l' is specified. 640 } AcceptVerbose verbose 641 642 # Match and skip patterns default to the empty list, except for 643 # matchFiles, which defaults to all .test files in the 644 # testsDirectory and matchDirectories, which defaults to all 645 # directories. 646 Option -match * { 647 Run all tests within the specified files that match one of the 648 list of glob patterns given. 649 } AcceptList match 650 651 Option -skip {} { 652 Skip all tests within the specified tests (via -match) and files 653 that match one of the list of glob patterns given. 654 } AcceptList skip 655 656 Option -file *.test { 657 Run tests in all test files that match the glob pattern given. 658 } AcceptPattern matchFiles 659 660 # By default, skip files that appear to be SCCS lock files. 661 Option -notfile l.*.test { 662 Skip all test files that match the glob pattern given. 663 } AcceptPattern skipFiles 664 665 Option -relateddir * { 666 Run tests in directories that match the glob pattern given. 667 } AcceptPattern matchDirectories 668 669 Option -asidefromdir {} { 670 Skip tests in directories that match the glob pattern given. 671 } AcceptPattern skipDirectories 672 673 # By default, don't save core files 674 Option -preservecore 0 { 675 If 2, save any core files produced during testing in the directory 676 specified by -tmpdir. If 1, notify the user if core files are 677 created. 678 } AcceptInteger preserveCore 679 680 # debug output doesn't get printed by default; debug level 1 spits 681 # up only the tests that were skipped because they didn't match or 682 # were specifically skipped. A debug level of 2 would spit up the 683 # tcltest variables and flags provided; a debug level of 3 causes 684 # some additional output regarding operations of the test harness. 685 # The tcltest package currently implements only up to debug level 3. 686 Option -debug 0 { 687 Internal debug level 688 } AcceptInteger debug 689 690 proc SetSelectedConstraints args { 691 variable Option 692 foreach c $Option(-constraints) { 693 testConstraint $c 1 694 } 695 } 696 Option -constraints {} { 697 Do not skip the listed constraints listed in -constraints. 698 } AcceptList 699 trace variable Option(-constraints) w \ 700 [namespace code {SetSelectedConstraints ;#}] 701 702 # Don't run only the "-constraint" specified tests by default 703 proc ClearUnselectedConstraints args { 704 variable Option 705 variable testConstraints 706 if {!$Option(-limitconstraints)} {return} 707 foreach c [array names testConstraints] { 708 if {[lsearch -exact $Option(-constraints) $c] == -1} { 709 testConstraint $c 0 710 } 711 } 712 } 713 Option -limitconstraints false { 714 whether to run only tests with the constraints 715 } AcceptBoolean limitConstraints 716 trace variable Option(-limitconstraints) w \ 717 [namespace code {ClearUnselectedConstraints ;#}] 718 719 # A test application has to know how to load the tested commands 720 # into the interpreter. 721 Option -load {} { 722 Specifies the script to load the tested commands. 723 } AcceptScript loadScript 724 725 # Default is to run each test file in a separate process 726 Option -singleproc 0 { 727 whether to run all tests in one process 728 } AcceptBoolean singleProcess 729 730 proc AcceptTemporaryDirectory { directory } { 731 set directory [AcceptAbsolutePath $directory] 732 if {![file exists $directory]} { 733 file mkdir $directory 734 } 735 set directory [AcceptDirectory $directory] 736 if {![file writable $directory]} { 737 if {[string equal [workingDirectory] $directory]} { 738 # Special exception: accept the default value 739 # even if the directory is not writable 740 return $directory 741 } 742 return -code error "\"$directory\" is not writeable" 743 } 744 return $directory 745 } 746 747 # Directory where files should be created 748 Option -tmpdir [workingDirectory] { 749 Save temporary files in the specified directory. 750 } AcceptTemporaryDirectory temporaryDirectory 751 trace variable Option(-tmpdir) w \ 752 [namespace code {normalizePath Option(-tmpdir) ;#}] 753 754 # Tests should not rely on the current working directory. 755 # Files that are part of the test suite should be accessed relative 756 # to [testsDirectory] 757 Option -testdir [workingDirectory] { 758 Search tests in the specified directory. 759 } AcceptDirectory testsDirectory 760 trace variable Option(-testdir) w \ 761 [namespace code {normalizePath Option(-testdir) ;#}] 762 763 proc AcceptLoadFile { file } { 764 if {[string equal "" $file]} {return $file} 765 set file [file join [temporaryDirectory] $file] 766 return [AcceptReadable $file] 767 } 768 proc ReadLoadScript {args} { 769 variable Option 770 if {[string equal "" $Option(-loadfile)]} {return} 771 set tmp [open $Option(-loadfile) r] 772 loadScript [read $tmp] 773 close $tmp 774 } 775 Option -loadfile {} { 776 Read the script to load the tested commands from the specified file. 777 } AcceptLoadFile loadFile 778 trace variable Option(-loadfile) w [namespace code ReadLoadScript] 779 780 proc AcceptOutFile { file } { 781 if {[string equal stderr $file]} {return $file} 782 if {[string equal stdout $file]} {return $file} 783 return [file join [temporaryDirectory] $file] 784 } 785 786 # output goes to stdout by default 787 Option -outfile stdout { 788 Send output from test runs to the specified file. 789 } AcceptOutFile outputFile 790 trace variable Option(-outfile) w \ 791 [namespace code {outputChannel $Option(-outfile) ;#}] 792 793 # errors go to stderr by default 794 Option -errfile stderr { 795 Send errors from test runs to the specified file. 796 } AcceptOutFile errorFile 797 trace variable Option(-errfile) w \ 798 [namespace code {errorChannel $Option(-errfile) ;#}] 799 800} 801 802##################################################################### 803 804# tcltest::Debug* -- 805# 806# Internal helper procedures to write out debug information 807# dependent on the chosen level. A test shell may overide 808# them, f.e. to redirect the output into a different 809# channel, or even into a GUI. 810 811# tcltest::DebugPuts -- 812# 813# Prints the specified string if the current debug level is 814# higher than the provided level argument. 815# 816# Arguments: 817# level The lowest debug level triggering the output 818# string The string to print out. 819# 820# Results: 821# Prints the string. Nothing else is allowed. 822# 823# Side Effects: 824# None. 825# 826 827proc tcltest::DebugPuts {level string} { 828 variable debug 829 if {$debug >= $level} { 830 puts $string 831 } 832 return 833} 834 835# tcltest::DebugPArray -- 836# 837# Prints the contents of the specified array if the current 838# debug level is higher than the provided level argument 839# 840# Arguments: 841# level The lowest debug level triggering the output 842# arrayvar The name of the array to print out. 843# 844# Results: 845# Prints the contents of the array. Nothing else is allowed. 846# 847# Side Effects: 848# None. 849# 850 851proc tcltest::DebugPArray {level arrayvar} { 852 variable debug 853 854 if {$debug >= $level} { 855 catch {upvar $arrayvar $arrayvar} 856 parray $arrayvar 857 } 858 return 859} 860 861# Define our own [parray] in ::tcltest that will inherit use of the [puts] 862# defined in ::tcltest. NOTE: Ought to construct with [info args] and 863# [info default], but can't be bothered now. If [parray] changes, then 864# this will need changing too. 865auto_load ::parray 866proc tcltest::parray {a {pattern *}} [info body ::parray] 867 868# tcltest::DebugDo -- 869# 870# Executes the script if the current debug level is greater than 871# the provided level argument 872# 873# Arguments: 874# level The lowest debug level triggering the execution. 875# script The tcl script executed upon a debug level high enough. 876# 877# Results: 878# Arbitrary side effects, dependent on the executed script. 879# 880# Side Effects: 881# None. 882# 883 884proc tcltest::DebugDo {level script} { 885 variable debug 886 887 if {$debug >= $level} { 888 uplevel 1 $script 889 } 890 return 891} 892 893##################################################################### 894 895proc tcltest::Warn {msg} { 896 puts [outputChannel] "WARNING: $msg" 897} 898 899# tcltest::mainThread 900# 901# Accessor command for tcltest variable mainThread. 902# 903proc tcltest::mainThread { {new ""} } { 904 variable mainThread 905 if {[llength [info level 0]] == 1} { 906 return $mainThread 907 } 908 set mainThread $new 909} 910 911# tcltest::testConstraint -- 912# 913# sets a test constraint to a value; to do multiple constraints, 914# call this proc multiple times. also returns the value of the 915# named constraint if no value was supplied. 916# 917# Arguments: 918# constraint - name of the constraint 919# value - new value for constraint (should be boolean) - if not 920# supplied, this is a query 921# 922# Results: 923# content of tcltest::testConstraints($constraint) 924# 925# Side effects: 926# none 927 928proc tcltest::testConstraint {constraint {value ""}} { 929 variable testConstraints 930 variable Option 931 DebugPuts 3 "entering testConstraint $constraint $value" 932 if {[llength [info level 0]] == 2} { 933 return $testConstraints($constraint) 934 } 935 # Check for boolean values 936 if {[catch {expr {$value && $value}} msg]} { 937 return -code error $msg 938 } 939 if {[limitConstraints] 940 && [lsearch -exact $Option(-constraints) $constraint] == -1} { 941 set value 0 942 } 943 set testConstraints($constraint) $value 944} 945 946# tcltest::interpreter -- 947# 948# the interpreter name stored in tcltest::tcltest 949# 950# Arguments: 951# executable name 952# 953# Results: 954# content of tcltest::tcltest 955# 956# Side effects: 957# None. 958 959proc tcltest::interpreter { {interp ""} } { 960 variable tcltest 961 if {[llength [info level 0]] == 1} { 962 return $tcltest 963 } 964 if {[string equal {} $interp]} { 965 set tcltest {} 966 } else { 967 set tcltest $interp 968 } 969} 970 971##################################################################### 972 973# tcltest::AddToSkippedBecause -- 974# 975# Increments the variable used to track how many tests were 976# skipped because of a particular constraint. 977# 978# Arguments: 979# constraint The name of the constraint to be modified 980# 981# Results: 982# Modifies tcltest::skippedBecause; sets the variable to 1 if 983# didn't previously exist - otherwise, it just increments it. 984# 985# Side effects: 986# None. 987 988proc tcltest::AddToSkippedBecause { constraint {value 1}} { 989 # add the constraint to the list of constraints that kept tests 990 # from running 991 variable skippedBecause 992 993 if {[info exists skippedBecause($constraint)]} { 994 incr skippedBecause($constraint) $value 995 } else { 996 set skippedBecause($constraint) $value 997 } 998 return 999} 1000 1001# tcltest::PrintError -- 1002# 1003# Prints errors to tcltest::errorChannel and then flushes that 1004# channel, making sure that all messages are < 80 characters per 1005# line. 1006# 1007# Arguments: 1008# errorMsg String containing the error to be printed 1009# 1010# Results: 1011# None. 1012# 1013# Side effects: 1014# None. 1015 1016proc tcltest::PrintError {errorMsg} { 1017 set InitialMessage "Error: " 1018 set InitialMsgLen [string length $InitialMessage] 1019 puts -nonewline [errorChannel] $InitialMessage 1020 1021 # Keep track of where the end of the string is. 1022 set endingIndex [string length $errorMsg] 1023 1024 if {$endingIndex < (80 - $InitialMsgLen)} { 1025 puts [errorChannel] $errorMsg 1026 } else { 1027 # Print up to 80 characters on the first line, including the 1028 # InitialMessage. 1029 set beginningIndex [string last " " [string range $errorMsg 0 \ 1030 [expr {80 - $InitialMsgLen}]]] 1031 puts [errorChannel] [string range $errorMsg 0 $beginningIndex] 1032 1033 while {![string equal end $beginningIndex]} { 1034 puts -nonewline [errorChannel] \ 1035 [string repeat " " $InitialMsgLen] 1036 if {($endingIndex - $beginningIndex) 1037 < (80 - $InitialMsgLen)} { 1038 puts [errorChannel] [string trim \ 1039 [string range $errorMsg $beginningIndex end]] 1040 break 1041 } else { 1042 set newEndingIndex [expr {[string last " " \ 1043 [string range $errorMsg $beginningIndex \ 1044 [expr {$beginningIndex 1045 + (80 - $InitialMsgLen)}] 1046 ]] + $beginningIndex}] 1047 if {($newEndingIndex <= 0) 1048 || ($newEndingIndex <= $beginningIndex)} { 1049 set newEndingIndex end 1050 } 1051 puts [errorChannel] [string trim \ 1052 [string range $errorMsg \ 1053 $beginningIndex $newEndingIndex]] 1054 set beginningIndex $newEndingIndex 1055 } 1056 } 1057 } 1058 flush [errorChannel] 1059 return 1060} 1061 1062# tcltest::SafeFetch -- 1063# 1064# The following trace procedure makes it so that we can safely 1065# refer to non-existent members of the testConstraints array 1066# without causing an error. Instead, reading a non-existent 1067# member will return 0. This is necessary because tests are 1068# allowed to use constraint "X" without ensuring that 1069# testConstraints("X") is defined. 1070# 1071# Arguments: 1072# n1 - name of the array (testConstraints) 1073# n2 - array key value (constraint name) 1074# op - operation performed on testConstraints (generally r) 1075# 1076# Results: 1077# none 1078# 1079# Side effects: 1080# sets testConstraints($n2) to 0 if it's referenced but never 1081# before used 1082 1083proc tcltest::SafeFetch {n1 n2 op} { 1084 variable testConstraints 1085 DebugPuts 3 "entering SafeFetch $n1 $n2 $op" 1086 if {[string equal {} $n2]} {return} 1087 if {![info exists testConstraints($n2)]} { 1088 if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} { 1089 testConstraint $n2 0 1090 } 1091 } 1092} 1093 1094# tcltest::ConstraintInitializer -- 1095# 1096# Get or set a script that when evaluated in the tcltest namespace 1097# will return a boolean value with which to initialize the 1098# associated constraint. 1099# 1100# Arguments: 1101# constraint - name of the constraint initialized by the script 1102# script - the initializer script 1103# 1104# Results 1105# boolean value of the constraint - enabled or disabled 1106# 1107# Side effects: 1108# Constraint is initialized for future reference by [test] 1109proc tcltest::ConstraintInitializer {constraint {script ""}} { 1110 variable ConstraintInitializer 1111 DebugPuts 3 "entering ConstraintInitializer $constraint $script" 1112 if {[llength [info level 0]] == 2} { 1113 return $ConstraintInitializer($constraint) 1114 } 1115 # Check for boolean values 1116 if {![info complete $script]} { 1117 return -code error "ConstraintInitializer must be complete script" 1118 } 1119 set ConstraintInitializer($constraint) $script 1120} 1121 1122# tcltest::InitConstraints -- 1123# 1124# Call all registered constraint initializers to force initialization 1125# of all known constraints. 1126# See the tcltest man page for the list of built-in constraints defined 1127# in this procedure. 1128# 1129# Arguments: 1130# none 1131# 1132# Results: 1133# The testConstraints array is reset to have an index for each 1134# built-in test constraint. 1135# 1136# Side Effects: 1137# None. 1138# 1139 1140proc tcltest::InitConstraints {} { 1141 variable ConstraintInitializer 1142 initConstraintsHook 1143 foreach constraint [array names ConstraintInitializer] { 1144 testConstraint $constraint 1145 } 1146} 1147 1148proc tcltest::DefineConstraintInitializers {} { 1149 ConstraintInitializer singleTestInterp {singleProcess} 1150 1151 # All the 'pc' constraints are here for backward compatibility and 1152 # are not documented. They have been replaced with equivalent 'win' 1153 # constraints. 1154 1155 ConstraintInitializer unixOnly \ 1156 {string equal $::tcl_platform(platform) unix} 1157 ConstraintInitializer macOnly \ 1158 {string equal $::tcl_platform(platform) macintosh} 1159 ConstraintInitializer pcOnly \ 1160 {string equal $::tcl_platform(platform) windows} 1161 ConstraintInitializer winOnly \ 1162 {string equal $::tcl_platform(platform) windows} 1163 1164 ConstraintInitializer unix {testConstraint unixOnly} 1165 ConstraintInitializer mac {testConstraint macOnly} 1166 ConstraintInitializer pc {testConstraint pcOnly} 1167 ConstraintInitializer win {testConstraint winOnly} 1168 1169 ConstraintInitializer unixOrPc \ 1170 {expr {[testConstraint unix] || [testConstraint pc]}} 1171 ConstraintInitializer macOrPc \ 1172 {expr {[testConstraint mac] || [testConstraint pc]}} 1173 ConstraintInitializer unixOrWin \ 1174 {expr {[testConstraint unix] || [testConstraint win]}} 1175 ConstraintInitializer macOrWin \ 1176 {expr {[testConstraint mac] || [testConstraint win]}} 1177 ConstraintInitializer macOrUnix \ 1178 {expr {[testConstraint mac] || [testConstraint unix]}} 1179 1180 ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"} 1181 ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"} 1182 ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"} 1183 1184 # The following Constraints switches are used to mark tests that 1185 # should work, but have been temporarily disabled on certain 1186 # platforms because they don't and we haven't gotten around to 1187 # fixing the underlying problem. 1188 1189 ConstraintInitializer tempNotPc {expr {![testConstraint pc]}} 1190 ConstraintInitializer tempNotWin {expr {![testConstraint win]}} 1191 ConstraintInitializer tempNotMac {expr {![testConstraint mac]}} 1192 ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}} 1193 1194 # The following Constraints switches are used to mark tests that 1195 # crash on certain platforms, so that they can be reactivated again 1196 # when the underlying problem is fixed. 1197 1198 ConstraintInitializer pcCrash {expr {![testConstraint pc]}} 1199 ConstraintInitializer winCrash {expr {![testConstraint win]}} 1200 ConstraintInitializer macCrash {expr {![testConstraint mac]}} 1201 ConstraintInitializer unixCrash {expr {![testConstraint unix]}} 1202 1203 # Skip empty tests 1204 1205 ConstraintInitializer emptyTest {format 0} 1206 1207 # By default, tests that expose known bugs are skipped. 1208 1209 ConstraintInitializer knownBug {format 0} 1210 1211 # By default, non-portable tests are skipped. 1212 1213 ConstraintInitializer nonPortable {format 0} 1214 1215 # Some tests require user interaction. 1216 1217 ConstraintInitializer userInteraction {format 0} 1218 1219 # Some tests must be skipped if the interpreter is not in 1220 # interactive mode 1221 1222 ConstraintInitializer interactive \ 1223 {expr {[info exists ::tcl_interactive] && $::tcl_interactive}} 1224 1225 # Some tests can only be run if the installation came from a CD 1226 # image instead of a web image. Some tests must be skipped if you 1227 # are running as root on Unix. Other tests can only be run if you 1228 # are running as root on Unix. 1229 1230 ConstraintInitializer root {expr \ 1231 {[string equal unix $::tcl_platform(platform)] 1232 && ([string equal root $::tcl_platform(user)] 1233 || [string equal "" $::tcl_platform(user)])}} 1234 ConstraintInitializer notRoot {expr {![testConstraint root]}} 1235 1236 # Set nonBlockFiles constraint: 1 means this platform supports 1237 # setting files into nonblocking mode. 1238 1239 ConstraintInitializer nonBlockFiles { 1240 set code [expr {[catch {set f [open defs r]}] 1241 || [catch {fconfigure $f -blocking off}]}] 1242 catch {close $f} 1243 set code 1244 } 1245 1246 # Set asyncPipeClose constraint: 1 means this platform supports 1247 # async flush and async close on a pipe. 1248 # 1249 # Test for SCO Unix - cannot run async flushing tests because a 1250 # potential problem with select is apparently interfering. 1251 # (Mark Diekhans). 1252 1253 ConstraintInitializer asyncPipeClose {expr { 1254 !([string equal unix $::tcl_platform(platform)] 1255 && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}} 1256 1257 # Test to see if we have a broken version of sprintf with respect 1258 # to the "e" format of floating-point numbers. 1259 1260 ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05} 1261 1262 # Test to see if execed commands such as cat, echo, rm and so forth 1263 # are present on this machine. 1264 1265 ConstraintInitializer unixExecs { 1266 set code 1 1267 if {[string equal macintosh $::tcl_platform(platform)]} { 1268 set code 0 1269 } 1270 if {[string equal windows $::tcl_platform(platform)]} { 1271 if {[catch { 1272 set file _tcl_test_remove_me.txt 1273 makeFile {hello} $file 1274 }]} { 1275 set code 0 1276 } elseif { 1277 [catch {exec cat $file}] || 1278 [catch {exec echo hello}] || 1279 [catch {exec sh -c echo hello}] || 1280 [catch {exec wc $file}] || 1281 [catch {exec sleep 1}] || 1282 [catch {exec echo abc > $file}] || 1283 [catch {exec chmod 644 $file}] || 1284 [catch {exec rm $file}] || 1285 [llength [auto_execok mkdir]] == 0 || 1286 [llength [auto_execok fgrep]] == 0 || 1287 [llength [auto_execok grep]] == 0 || 1288 [llength [auto_execok ps]] == 0 1289 } { 1290 set code 0 1291 } 1292 removeFile $file 1293 } 1294 set code 1295 } 1296 1297 ConstraintInitializer stdio { 1298 set code 0 1299 if {![catch {set f [open "|[list [interpreter]]" w]}]} { 1300 if {![catch {puts $f exit}]} { 1301 if {![catch {close $f}]} { 1302 set code 1 1303 } 1304 } 1305 } 1306 set code 1307 } 1308 1309 # Deliberately call socket with the wrong number of arguments. The 1310 # error message you get will indicate whether sockets are available 1311 # on this system. 1312 1313 ConstraintInitializer socket { 1314 catch {socket} msg 1315 string compare $msg "sockets are not available on this system" 1316 } 1317 1318 # Check for internationalization 1319 ConstraintInitializer hasIsoLocale { 1320 if {[llength [info commands testlocale]] == 0} { 1321 set code 0 1322 } else { 1323 set code [string length [SetIso8859_1_Locale]] 1324 RestoreLocale 1325 } 1326 set code 1327 } 1328 1329} 1330##################################################################### 1331 1332# Usage and command line arguments processing. 1333 1334# tcltest::PrintUsageInfo 1335# 1336# Prints out the usage information for package tcltest. This can 1337# be customized with the redefinition of [PrintUsageInfoHook]. 1338# 1339# Arguments: 1340# none 1341# 1342# Results: 1343# none 1344# 1345# Side Effects: 1346# none 1347proc tcltest::PrintUsageInfo {} { 1348 puts [Usage] 1349 PrintUsageInfoHook 1350} 1351 1352proc tcltest::Usage { {option ""} } { 1353 variable Usage 1354 variable Verify 1355 if {[llength [info level 0]] == 1} { 1356 set msg "Usage: [file tail [info nameofexecutable]] script " 1357 append msg "?-help? ?flag value? ... \n" 1358 append msg "Available flags (and valid input values) are:" 1359 1360 set max 0 1361 set allOpts [concat -help [Configure]] 1362 foreach opt $allOpts { 1363 set foo [Usage $opt] 1364 foreach [list x type($opt) usage($opt)] $foo break 1365 set line($opt) " $opt $type($opt) " 1366 set length($opt) [string length $line($opt)] 1367 if {$length($opt) > $max} {set max $length($opt)} 1368 } 1369 set rest [expr {72 - $max}] 1370 foreach opt $allOpts { 1371 append msg \n$line($opt) 1372 append msg [string repeat " " [expr {$max - $length($opt)}]] 1373 set u [string trim $usage($opt)] 1374 catch {append u " (default: \[[Configure $opt]])"} 1375 regsub -all {\s*\n\s*} $u " " u 1376 while {[string length $u] > $rest} { 1377 set break [string wordstart $u $rest] 1378 if {$break == 0} { 1379 set break [string wordend $u 0] 1380 } 1381 append msg [string range $u 0 [expr {$break - 1}]] 1382 set u [string trim [string range $u $break end]] 1383 append msg \n[string repeat " " $max] 1384 } 1385 append msg $u 1386 } 1387 return $msg\n 1388 } elseif {[string equal -help $option]} { 1389 return [list -help "" "Display this usage information."] 1390 } else { 1391 set type [lindex [info args $Verify($option)] 0] 1392 return [list $option $type $Usage($option)] 1393 } 1394} 1395 1396# tcltest::ProcessFlags -- 1397# 1398# process command line arguments supplied in the flagArray - this 1399# is called by processCmdLineArgs. Modifies tcltest variables 1400# according to the content of the flagArray. 1401# 1402# Arguments: 1403# flagArray - array containing name/value pairs of flags 1404# 1405# Results: 1406# sets tcltest variables according to their values as defined by 1407# flagArray 1408# 1409# Side effects: 1410# None. 1411 1412proc tcltest::ProcessFlags {flagArray} { 1413 # Process -help first 1414 if {[lsearch -exact $flagArray {-help}] != -1} { 1415 PrintUsageInfo 1416 exit 1 1417 } 1418 1419 if {[llength $flagArray] == 0} { 1420 RemoveAutoConfigureTraces 1421 } else { 1422 set args $flagArray 1423 while {[llength $args]>1 && [catch {configure {*}$args} msg]} { 1424 1425 # Something went wrong parsing $args for tcltest options 1426 # Check whether the problem is "unknown option" 1427 if {[regexp {^unknown option (\S+):} $msg -> option]} { 1428 # Could be this is an option the Hook knows about 1429 set moreOptions [processCmdLineArgsAddFlagsHook] 1430 if {[lsearch -exact $moreOptions $option] == -1} { 1431 # Nope. Report the error, including additional options, 1432 # but keep going 1433 if {[llength $moreOptions]} { 1434 append msg ", " 1435 append msg [join [lrange $moreOptions 0 end-1] ", "] 1436 append msg "or [lindex $moreOptions end]" 1437 } 1438 Warn $msg 1439 } 1440 } else { 1441 # error is something other than "unknown option" 1442 # notify user of the error; and exit 1443 puts [errorChannel] $msg 1444 exit 1 1445 } 1446 1447 # To recover, find that unknown option and remove up to it. 1448 # then retry 1449 while {![string equal [lindex $args 0] $option]} { 1450 set args [lrange $args 2 end] 1451 } 1452 set args [lrange $args 2 end] 1453 } 1454 if {[llength $args] == 1} { 1455 puts [errorChannel] \ 1456 "missing value for option [lindex $args 0]" 1457 exit 1 1458 } 1459 } 1460 1461 # Call the hook 1462 catch { 1463 array set flag $flagArray 1464 processCmdLineArgsHook [array get flag] 1465 } 1466 return 1467} 1468 1469# tcltest::ProcessCmdLineArgs -- 1470# 1471# This procedure must be run after constraint initialization is 1472# set up (by [DefineConstraintInitializers]) because some constraints 1473# can be overridden. 1474# 1475# Perform configuration according to the command-line options. 1476# 1477# Arguments: 1478# none 1479# 1480# Results: 1481# Sets the above-named variables in the tcltest namespace. 1482# 1483# Side Effects: 1484# None. 1485# 1486 1487proc tcltest::ProcessCmdLineArgs {} { 1488 variable originalEnv 1489 variable testConstraints 1490 1491 # The "argv" var doesn't exist in some cases, so use {}. 1492 if {![info exists ::argv]} { 1493 ProcessFlags {} 1494 } else { 1495 ProcessFlags $::argv 1496 } 1497 1498 # Spit out everything you know if we're at a debug level 2 or 1499 # greater 1500 DebugPuts 2 "Flags passed into tcltest:" 1501 if {[info exists ::env(TCLTEST_OPTIONS)]} { 1502 DebugPuts 2 \ 1503 " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)" 1504 } 1505 if {[info exists ::argv]} { 1506 DebugPuts 2 " argv: $::argv" 1507 } 1508 DebugPuts 2 "tcltest::debug = [debug]" 1509 DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]" 1510 DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]" 1511 DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]" 1512 DebugPuts 2 "tcltest::outputChannel = [outputChannel]" 1513 DebugPuts 2 "tcltest::errorChannel = [errorChannel]" 1514 DebugPuts 2 "Original environment (tcltest::originalEnv):" 1515 DebugPArray 2 originalEnv 1516 DebugPuts 2 "Constraints:" 1517 DebugPArray 2 testConstraints 1518} 1519 1520##################################################################### 1521 1522# Code to run the tests goes here. 1523 1524# tcltest::TestPuts -- 1525# 1526# Used to redefine puts in test environment. Stores whatever goes 1527# out on stdout in tcltest::outData and stderr in errData before 1528# sending it on to the regular puts. 1529# 1530# Arguments: 1531# same as standard puts 1532# 1533# Results: 1534# none 1535# 1536# Side effects: 1537# Intercepts puts; data that would otherwise go to stdout, stderr, 1538# or file channels specified in outputChannel and errorChannel 1539# does not get sent to the normal puts function. 1540namespace eval tcltest::Replace { 1541 namespace export puts 1542} 1543proc tcltest::Replace::puts {args} { 1544 variable [namespace parent]::outData 1545 variable [namespace parent]::errData 1546 switch [llength $args] { 1547 1 { 1548 # Only the string to be printed is specified 1549 append outData [lindex $args 0]\n 1550 return 1551 # return [Puts [lindex $args 0]] 1552 } 1553 2 { 1554 # Either -nonewline or channelId has been specified 1555 if {[string equal -nonewline [lindex $args 0]]} { 1556 append outData [lindex $args end] 1557 return 1558 # return [Puts -nonewline [lindex $args end]] 1559 } else { 1560 set channel [lindex $args 0] 1561 set newline \n 1562 } 1563 } 1564 3 { 1565 if {[string equal -nonewline [lindex $args 0]]} { 1566 # Both -nonewline and channelId are specified, unless 1567 # it's an error. -nonewline is supposed to be argv[0]. 1568 set channel [lindex $args 1] 1569 set newline "" 1570 } 1571 } 1572 } 1573 1574 if {[info exists channel]} { 1575 if {[string equal $channel [[namespace parent]::outputChannel]] 1576 || [string equal $channel stdout]} { 1577 append outData [lindex $args end]$newline 1578 return 1579 } elseif {[string equal $channel [[namespace parent]::errorChannel]] 1580 || [string equal $channel stderr]} { 1581 append errData [lindex $args end]$newline 1582 return 1583 } 1584 } 1585 1586 # If we haven't returned by now, we don't know how to handle the 1587 # input. Let puts handle it. 1588 return [Puts {*}$args] 1589} 1590 1591# tcltest::Eval -- 1592# 1593# Evaluate the script in the test environment. If ignoreOutput is 1594# false, store data sent to stderr and stdout in outData and 1595# errData. Otherwise, ignore this output altogether. 1596# 1597# Arguments: 1598# script Script to evaluate 1599# ?ignoreOutput? Indicates whether or not to ignore output 1600# sent to stdout & stderr 1601# 1602# Results: 1603# result from running the script 1604# 1605# Side effects: 1606# Empties the contents of outData and errData before running a 1607# test if ignoreOutput is set to 0. 1608 1609proc tcltest::Eval {script {ignoreOutput 1}} { 1610 variable outData 1611 variable errData 1612 DebugPuts 3 "[lindex [info level 0] 0] called" 1613 if {!$ignoreOutput} { 1614 set outData {} 1615 set errData {} 1616 rename ::puts [namespace current]::Replace::Puts 1617 namespace eval :: [list namespace import [namespace origin Replace::puts]] 1618 namespace import Replace::puts 1619 } 1620 set result [uplevel 1 $script] 1621 if {!$ignoreOutput} { 1622 namespace forget puts 1623 namespace eval :: namespace forget puts 1624 rename [namespace current]::Replace::Puts ::puts 1625 } 1626 return $result 1627} 1628 1629# tcltest::CompareStrings -- 1630# 1631# compares the expected answer to the actual answer, depending on 1632# the mode provided. Mode determines whether a regexp, exact, 1633# glob or custom comparison is done. 1634# 1635# Arguments: 1636# actual - string containing the actual result 1637# expected - pattern to be matched against 1638# mode - type of comparison to be done 1639# 1640# Results: 1641# result of the match 1642# 1643# Side effects: 1644# None. 1645 1646proc tcltest::CompareStrings {actual expected mode} { 1647 variable CustomMatch 1648 if {![info exists CustomMatch($mode)]} { 1649 return -code error "No matching command registered for `-match $mode'" 1650 } 1651 set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]] 1652 if {[catch {expr {$match && $match}} result]} { 1653 return -code error "Invalid result from `-match $mode' command: $result" 1654 } 1655 return $match 1656} 1657 1658# tcltest::customMatch -- 1659# 1660# registers a command to be called when a particular type of 1661# matching is required. 1662# 1663# Arguments: 1664# nickname - Keyword for the type of matching 1665# cmd - Incomplete command that implements that type of matching 1666# when completed with expected string and actual string 1667# and then evaluated. 1668# 1669# Results: 1670# None. 1671# 1672# Side effects: 1673# Sets the variable tcltest::CustomMatch 1674 1675proc tcltest::customMatch {mode script} { 1676 variable CustomMatch 1677 if {![info complete $script]} { 1678 return -code error \ 1679 "invalid customMatch script; can't evaluate after completion" 1680 } 1681 set CustomMatch($mode) $script 1682} 1683 1684# tcltest::SubstArguments list 1685# 1686# This helper function takes in a list of words, then perform a 1687# substitution on the list as though each word in the list is a separate 1688# argument to the Tcl function. For example, if this function is 1689# invoked as: 1690# 1691# SubstArguments {$a {$a}} 1692# 1693# Then it is as though the function is invoked as: 1694# 1695# SubstArguments $a {$a} 1696# 1697# This code is adapted from Paul Duffin's function "SplitIntoWords". 1698# The original function can be found on: 1699# 1700# http://purl.org/thecliff/tcl/wiki/858.html 1701# 1702# Results: 1703# a list containing the result of the substitution 1704# 1705# Exceptions: 1706# An error may occur if the list containing unbalanced quote or 1707# unknown variable. 1708# 1709# Side Effects: 1710# None. 1711# 1712 1713proc tcltest::SubstArguments {argList} { 1714 1715 # We need to split the argList up into tokens but cannot use list 1716 # operations as they throw away some significant quoting, and 1717 # [split] ignores braces as it should. Therefore what we do is 1718 # gradually build up a string out of whitespace seperated strings. 1719 # We cannot use [split] to split the argList into whitespace 1720 # separated strings as it throws away the whitespace which maybe 1721 # important so we have to do it all by hand. 1722 1723 set result {} 1724 set token "" 1725 1726 while {[string length $argList]} { 1727 # Look for the next word containing a quote: " { } 1728 if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ 1729 $argList all]} { 1730 # Get the text leading up to this word, but not including 1731 # this word, from the argList. 1732 set text [string range $argList 0 \ 1733 [expr {[lindex $all 0] - 1}]] 1734 # Get the word with the quote 1735 set word [string range $argList \ 1736 [lindex $all 0] [lindex $all 1]] 1737 1738 # Remove all text up to and including the word from the 1739 # argList. 1740 set argList [string range $argList \ 1741 [expr {[lindex $all 1] + 1}] end] 1742 } else { 1743 # Take everything up to the end of the argList. 1744 set text $argList 1745 set word {} 1746 set argList {} 1747 } 1748 1749 if {$token != {}} { 1750 # If we saw a word with quote before, then there is a 1751 # multi-word token starting with that word. In this case, 1752 # add the text and the current word to this token. 1753 append token $text $word 1754 } else { 1755 # Add the text to the result. There is no need to parse 1756 # the text because it couldn't be a part of any multi-word 1757 # token. Then start a new multi-word token with the word 1758 # because we need to pass this token to the Tcl parser to 1759 # check for balancing quotes 1760 append result $text 1761 set token $word 1762 } 1763 1764 if { [catch {llength $token} length] == 0 && $length == 1} { 1765 # The token is a valid list so add it to the result. 1766 # lappend result [string trim $token] 1767 append result \{$token\} 1768 set token {} 1769 } 1770 } 1771 1772 # If the last token has not been added to the list then there 1773 # is a problem. 1774 if { [string length $token] } { 1775 error "incomplete token \"$token\"" 1776 } 1777 1778 return $result 1779} 1780 1781 1782# tcltest::test -- 1783# 1784# This procedure runs a test and prints an error message if the test 1785# fails. If verbose has been set, it also prints a message even if the 1786# test succeeds. The test will be skipped if it doesn't match the 1787# match variable, if it matches an element in skip, or if one of the 1788# elements of "constraints" turns out not to be true. 1789# 1790# If testLevel is 1, then this is a top level test, and we record 1791# pass/fail information; otherwise, this information is not logged and 1792# is not added to running totals. 1793# 1794# Attributes: 1795# Only description is a required attribute. All others are optional. 1796# Default values are indicated. 1797# 1798# constraints - A list of one or more keywords, each of which 1799# must be the name of an element in the array 1800# "testConstraints". If any of these elements is 1801# zero, the test is skipped. This attribute is 1802# optional; default is {} 1803# body - Script to run to carry out the test. It must 1804# return a result that can be checked for 1805# correctness. This attribute is optional; 1806# default is {} 1807# result - Expected result from script. This attribute is 1808# optional; default is {}. 1809# output - Expected output sent to stdout. This attribute 1810# is optional; default is {}. 1811# errorOutput - Expected output sent to stderr. This attribute 1812# is optional; default is {}. 1813# returnCodes - Expected return codes. This attribute is 1814# optional; default is {0 2}. 1815# setup - Code to run before $script (above). This 1816# attribute is optional; default is {}. 1817# cleanup - Code to run after $script (above). This 1818# attribute is optional; default is {}. 1819# match - specifies type of matching to do on result, 1820# output, errorOutput; this must be a string 1821# previously registered by a call to [customMatch]. 1822# The strings exact, glob, and regexp are pre-registered 1823# by the tcltest package. Default value is exact. 1824# 1825# Arguments: 1826# name - Name of test, in the form foo-1.2. 1827# description - Short textual description of the test, to 1828# help humans understand what it does. 1829# 1830# Results: 1831# None. 1832# 1833# Side effects: 1834# Just about anything is possible depending on the test. 1835# 1836 1837proc tcltest::test {name description args} { 1838 global tcl_platform 1839 variable testLevel 1840 variable coreModTime 1841 DebugPuts 3 "test $name $args" 1842 DebugDo 1 { 1843 variable TestNames 1844 catch { 1845 puts "test name '$name' re-used; prior use in $TestNames($name)" 1846 } 1847 set TestNames($name) [info script] 1848 } 1849 1850 FillFilesExisted 1851 incr testLevel 1852 1853 # Pre-define everything to null except output and errorOutput. We 1854 # determine whether or not to trap output based on whether or not 1855 # these variables (output & errorOutput) are defined. 1856 foreach item {constraints setup cleanup body result returnCodes 1857 match} { 1858 set $item {} 1859 } 1860 1861 # Set the default match mode 1862 set match exact 1863 1864 # Set the default match values for return codes (0 is the standard 1865 # expected return value if everything went well; 2 represents 1866 # 'return' being used in the test script). 1867 set returnCodes [list 0 2] 1868 1869 # The old test format can't have a 3rd argument (constraints or 1870 # script) that starts with '-'. 1871 if {[string match -* [lindex $args 0]] 1872 || ([llength $args] <= 1)} { 1873 if {[llength $args] == 1} { 1874 set list [SubstArguments [lindex $args 0]] 1875 foreach {element value} $list { 1876 set testAttributes($element) $value 1877 } 1878 foreach item {constraints match setup body cleanup \ 1879 result returnCodes output errorOutput} { 1880 if {[info exists testAttributes(-$item)]} { 1881 set testAttributes(-$item) [uplevel 1 \ 1882 ::concat $testAttributes(-$item)] 1883 } 1884 } 1885 } else { 1886 array set testAttributes $args 1887 } 1888 1889 set validFlags {-setup -cleanup -body -result -returnCodes \ 1890 -match -output -errorOutput -constraints} 1891 1892 foreach flag [array names testAttributes] { 1893 if {[lsearch -exact $validFlags $flag] == -1} { 1894 incr testLevel -1 1895 set sorted [lsort $validFlags] 1896 set options [join [lrange $sorted 0 end-1] ", "] 1897 append options ", or [lindex $sorted end]" 1898 return -code error "bad option \"$flag\": must be $options" 1899 } 1900 } 1901 1902 # store whatever the user gave us 1903 foreach item [array names testAttributes] { 1904 set [string trimleft $item "-"] $testAttributes($item) 1905 } 1906 1907 # Check the values supplied for -match 1908 variable CustomMatch 1909 if {[lsearch [array names CustomMatch] $match] == -1} { 1910 incr testLevel -1 1911 set sorted [lsort [array names CustomMatch]] 1912 set values [join [lrange $sorted 0 end-1] ", "] 1913 append values ", or [lindex $sorted end]" 1914 return -code error "bad -match value \"$match\":\ 1915 must be $values" 1916 } 1917 1918 # Replace symbolic valies supplied for -returnCodes 1919 foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { 1920 set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] 1921 } 1922 } else { 1923 # This is parsing for the old test command format; it is here 1924 # for backward compatibility. 1925 set result [lindex $args end] 1926 if {[llength $args] == 2} { 1927 set body [lindex $args 0] 1928 } elseif {[llength $args] == 3} { 1929 set constraints [lindex $args 0] 1930 set body [lindex $args 1] 1931 } else { 1932 incr testLevel -1 1933 return -code error "wrong # args:\ 1934 should be \"test name desc ?options?\"" 1935 } 1936 } 1937 1938 if {[Skipped $name $constraints]} { 1939 incr testLevel -1 1940 return 1941 } 1942 1943 # Save information about the core file. 1944 if {[preserveCore]} { 1945 if {[file exists [file join [workingDirectory] core]]} { 1946 set coreModTime [file mtime [file join [workingDirectory] core]] 1947 } 1948 } 1949 1950 # First, run the setup script 1951 set code [catch {uplevel 1 $setup} setupMsg] 1952 if {$code == 1} { 1953 set errorInfo(setup) $::errorInfo 1954 set errorCode(setup) $::errorCode 1955 } 1956 set setupFailure [expr {$code != 0}] 1957 1958 # Only run the test body if the setup was successful 1959 if {!$setupFailure} { 1960 1961 # Verbose notification of $body start 1962 if {[IsVerbose start]} { 1963 puts [outputChannel] "---- $name start" 1964 flush [outputChannel] 1965 } 1966 1967 set command [list [namespace origin RunTest] $name $body] 1968 if {[info exists output] || [info exists errorOutput]} { 1969 set testResult [uplevel 1 [list [namespace origin Eval] $command 0]] 1970 } else { 1971 set testResult [uplevel 1 [list [namespace origin Eval] $command 1]] 1972 } 1973 foreach {actualAnswer returnCode} $testResult break 1974 if {$returnCode == 1} { 1975 set errorInfo(body) $::errorInfo 1976 set errorCode(body) $::errorCode 1977 } 1978 } 1979 1980 # Always run the cleanup script 1981 set code [catch {uplevel 1 $cleanup} cleanupMsg] 1982 if {$code == 1} { 1983 set errorInfo(cleanup) $::errorInfo 1984 set errorCode(cleanup) $::errorCode 1985 } 1986 set cleanupFailure [expr {$code != 0}] 1987 1988 set coreFailure 0 1989 set coreMsg "" 1990 # check for a core file first - if one was created by the test, 1991 # then the test failed 1992 if {[preserveCore]} { 1993 if {[file exists [file join [workingDirectory] core]]} { 1994 # There's only a test failure if there is a core file 1995 # and (1) there previously wasn't one or (2) the new 1996 # one is different from the old one. 1997 if {[info exists coreModTime]} { 1998 if {$coreModTime != [file mtime \ 1999 [file join [workingDirectory] core]]} { 2000 set coreFailure 1 2001 } 2002 } else { 2003 set coreFailure 1 2004 } 2005 2006 if {([preserveCore] > 1) && ($coreFailure)} { 2007 append coreMsg "\nMoving file to:\ 2008 [file join [temporaryDirectory] core-$name]" 2009 catch {file rename -force \ 2010 [file join [workingDirectory] core] \ 2011 [file join [temporaryDirectory] core-$name] 2012 } msg 2013 if {[string length $msg] > 0} { 2014 append coreMsg "\nError:\ 2015 Problem renaming core file: $msg" 2016 } 2017 } 2018 } 2019 } 2020 2021 # check if the return code matched the expected return code 2022 set codeFailure 0 2023 if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} { 2024 set codeFailure 1 2025 } 2026 2027 # If expected output/error strings exist, we have to compare 2028 # them. If the comparison fails, then so did the test. 2029 set outputFailure 0 2030 variable outData 2031 if {[info exists output] && !$codeFailure} { 2032 if {[set outputCompare [catch { 2033 CompareStrings $outData $output $match 2034 } outputMatch]] == 0} { 2035 set outputFailure [expr {!$outputMatch}] 2036 } else { 2037 set outputFailure 1 2038 } 2039 } 2040 2041 set errorFailure 0 2042 variable errData 2043 if {[info exists errorOutput] && !$codeFailure} { 2044 if {[set errorCompare [catch { 2045 CompareStrings $errData $errorOutput $match 2046 } errorMatch]] == 0} { 2047 set errorFailure [expr {!$errorMatch}] 2048 } else { 2049 set errorFailure 1 2050 } 2051 } 2052 2053 # check if the answer matched the expected answer 2054 # Only check if we ran the body of the test (no setup failure) 2055 if {$setupFailure || $codeFailure} { 2056 set scriptFailure 0 2057 } elseif {[set scriptCompare [catch { 2058 CompareStrings $actualAnswer $result $match 2059 } scriptMatch]] == 0} { 2060 set scriptFailure [expr {!$scriptMatch}] 2061 } else { 2062 set scriptFailure 1 2063 } 2064 2065 # if we didn't experience any failures, then we passed 2066 variable numTests 2067 if {!($setupFailure || $cleanupFailure || $coreFailure 2068 || $outputFailure || $errorFailure || $codeFailure 2069 || $scriptFailure)} { 2070 if {$testLevel == 1} { 2071 incr numTests(Passed) 2072 if {[IsVerbose pass]} { 2073 puts [outputChannel] "++++ $name PASSED" 2074 } 2075 } 2076 incr testLevel -1 2077 return 2078 } 2079 2080 # We know the test failed, tally it... 2081 if {$testLevel == 1} { 2082 incr numTests(Failed) 2083 } 2084 2085 # ... then report according to the type of failure 2086 variable currentFailure true 2087 if {![IsVerbose body]} { 2088 set body "" 2089 } 2090 puts [outputChannel] "\n" 2091 if {[IsVerbose line]} { 2092 if {![catch {set testFrame [info frame -1]}] && 2093 [dict get $testFrame type] eq "source"} { 2094 set testFile [dict get $testFrame file] 2095 set testLine [dict get $testFrame line] 2096 } else { 2097 set testFile [file normalize [uplevel 1 {info script}]] 2098 if {[file readable $testFile]} { 2099 set testFd [open $testFile r] 2100 set testLine [expr {[lsearch -regexp \ 2101 [split [read $testFd] "\n"] \ 2102 "^\[ \t\]*test [string map {. \\.} $name] "]+1}] 2103 close $testFd 2104 } 2105 } 2106 if {[info exists testLine]} { 2107 puts [outputChannel] "$testFile:$testLine: error: test failed:\ 2108 $name [string trim $description]" 2109 } 2110 } 2111 puts [outputChannel] "==== $name\ 2112 [string trim $description] FAILED" 2113 if {[string length $body]} { 2114 puts [outputChannel] "==== Contents of test case:" 2115 puts [outputChannel] $body 2116 } 2117 if {$setupFailure} { 2118 puts [outputChannel] "---- Test setup\ 2119 failed:\n$setupMsg" 2120 if {[info exists errorInfo(setup)]} { 2121 puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)" 2122 puts [outputChannel] "---- errorCode(setup): $errorCode(setup)" 2123 } 2124 } 2125 if {$scriptFailure} { 2126 if {$scriptCompare} { 2127 puts [outputChannel] "---- Error testing result: $scriptMatch" 2128 } else { 2129 puts [outputChannel] "---- Result was:\n$actualAnswer" 2130 puts [outputChannel] "---- Result should have been\ 2131 ($match matching):\n$result" 2132 } 2133 } 2134 if {$codeFailure} { 2135 switch -- $returnCode { 2136 0 { set msg "Test completed normally" } 2137 1 { set msg "Test generated error" } 2138 2 { set msg "Test generated return exception" } 2139 3 { set msg "Test generated break exception" } 2140 4 { set msg "Test generated continue exception" } 2141 default { set msg "Test generated exception" } 2142 } 2143 puts [outputChannel] "---- $msg; Return code was: $returnCode" 2144 puts [outputChannel] "---- Return code should have been\ 2145 one of: $returnCodes" 2146 if {[IsVerbose error]} { 2147 if {[info exists errorInfo(body)] && ([lsearch $returnCodes 1]<0)} { 2148 puts [outputChannel] "---- errorInfo: $errorInfo(body)" 2149 puts [outputChannel] "---- errorCode: $errorCode(body)" 2150 } 2151 } 2152 } 2153 if {$outputFailure} { 2154 if {$outputCompare} { 2155 puts [outputChannel] "---- Error testing output: $outputMatch" 2156 } else { 2157 puts [outputChannel] "---- Output was:\n$outData" 2158 puts [outputChannel] "---- Output should have been\ 2159 ($match matching):\n$output" 2160 } 2161 } 2162 if {$errorFailure} { 2163 if {$errorCompare} { 2164 puts [outputChannel] "---- Error testing errorOutput: $errorMatch" 2165 } else { 2166 puts [outputChannel] "---- Error output was:\n$errData" 2167 puts [outputChannel] "---- Error output should have\ 2168 been ($match matching):\n$errorOutput" 2169 } 2170 } 2171 if {$cleanupFailure} { 2172 puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" 2173 if {[info exists errorInfo(cleanup)]} { 2174 puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)" 2175 puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)" 2176 } 2177 } 2178 if {$coreFailure} { 2179 puts [outputChannel] "---- Core file produced while running\ 2180 test! $coreMsg" 2181 } 2182 puts [outputChannel] "==== $name FAILED\n" 2183 2184 incr testLevel -1 2185 return 2186} 2187 2188# Skipped -- 2189# 2190# Given a test name and it constraints, returns a boolean indicating 2191# whether the current configuration says the test should be skipped. 2192# 2193# Side Effects: Maintains tally of total tests seen and tests skipped. 2194# 2195proc tcltest::Skipped {name constraints} { 2196 variable testLevel 2197 variable numTests 2198 variable testConstraints 2199 2200 if {$testLevel == 1} { 2201 incr numTests(Total) 2202 } 2203 # skip the test if it's name matches an element of skip 2204 foreach pattern [skip] { 2205 if {[string match $pattern $name]} { 2206 if {$testLevel == 1} { 2207 incr numTests(Skipped) 2208 DebugDo 1 {AddToSkippedBecause userSpecifiedSkip} 2209 } 2210 return 1 2211 } 2212 } 2213 # skip the test if it's name doesn't match any element of match 2214 set ok 0 2215 foreach pattern [match] { 2216 if {[string match $pattern $name]} { 2217 set ok 1 2218 break 2219 } 2220 } 2221 if {!$ok} { 2222 if {$testLevel == 1} { 2223 incr numTests(Skipped) 2224 DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch} 2225 } 2226 return 1 2227 } 2228 if {[string equal {} $constraints]} { 2229 # If we're limited to the listed constraints and there aren't 2230 # any listed, then we shouldn't run the test. 2231 if {[limitConstraints]} { 2232 AddToSkippedBecause userSpecifiedLimitConstraint 2233 if {$testLevel == 1} { 2234 incr numTests(Skipped) 2235 } 2236 return 1 2237 } 2238 } else { 2239 # "constraints" argument exists; 2240 # make sure that the constraints are satisfied. 2241 2242 set doTest 0 2243 if {[string match {*[$\[]*} $constraints] != 0} { 2244 # full expression, e.g. {$foo > [info tclversion]} 2245 catch {set doTest [uplevel #0 [list expr $constraints]]} 2246 } elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} { 2247 # something like {a || b} should be turned into 2248 # $testConstraints(a) || $testConstraints(b). 2249 regsub -all {[.\w]+} $constraints {$testConstraints(&)} c 2250 catch {set doTest [eval [list expr $c]]} 2251 } elseif {![catch {llength $constraints}]} { 2252 # just simple constraints such as {unixOnly fonts}. 2253 set doTest 1 2254 foreach constraint $constraints { 2255 if {(![info exists testConstraints($constraint)]) \ 2256 || (!$testConstraints($constraint))} { 2257 set doTest 0 2258 2259 # store the constraint that kept the test from 2260 # running 2261 set constraints $constraint 2262 break 2263 } 2264 } 2265 } 2266 2267 if {!$doTest} { 2268 if {[IsVerbose skip]} { 2269 puts [outputChannel] "++++ $name SKIPPED: $constraints" 2270 } 2271 2272 if {$testLevel == 1} { 2273 incr numTests(Skipped) 2274 AddToSkippedBecause $constraints 2275 } 2276 return 1 2277 } 2278 } 2279 return 0 2280} 2281 2282# RunTest -- 2283# 2284# This is where the body of a test is evaluated. The combination of 2285# [RunTest] and [Eval] allows the output and error output of the test 2286# body to be captured for comparison against the expected values. 2287 2288proc tcltest::RunTest {name script} { 2289 DebugPuts 3 "Running $name {$script}" 2290 2291 # If there is no "memory" command (because memory debugging isn't 2292 # enabled), then don't attempt to use the command. 2293 2294 if {[llength [info commands memory]] == 1} { 2295 memory tag $name 2296 } 2297 2298 set code [catch {uplevel 1 $script} actualAnswer] 2299 2300 return [list $actualAnswer $code] 2301} 2302 2303##################################################################### 2304 2305# tcltest::cleanupTestsHook -- 2306# 2307# This hook allows a harness that builds upon tcltest to specify 2308# additional things that should be done at cleanup. 2309# 2310 2311if {[llength [info commands tcltest::cleanupTestsHook]] == 0} { 2312 proc tcltest::cleanupTestsHook {} {} 2313} 2314 2315# tcltest::cleanupTests -- 2316# 2317# Remove files and dirs created using the makeFile and makeDirectory 2318# commands since the last time this proc was invoked. 2319# 2320# Print the names of the files created without the makeFile command 2321# since the tests were invoked. 2322# 2323# Print the number tests (total, passed, failed, and skipped) since the 2324# tests were invoked. 2325# 2326# Restore original environment (as reported by special variable env). 2327# 2328# Arguments: 2329# calledFromAllFile - if 0, behave as if we are running a single 2330# test file within an entire suite of tests. if we aren't running 2331# a single test file, then don't report status. check for new 2332# files created during the test run and report on them. if 1, 2333# report collated status from all the test file runs. 2334# 2335# Results: 2336# None. 2337# 2338# Side Effects: 2339# None 2340# 2341 2342proc tcltest::cleanupTests {{calledFromAllFile 0}} { 2343 variable filesMade 2344 variable filesExisted 2345 variable createdNewFiles 2346 variable testSingleFile 2347 variable numTests 2348 variable numTestFiles 2349 variable failFiles 2350 variable skippedBecause 2351 variable currentFailure 2352 variable originalEnv 2353 variable originalTclPlatform 2354 variable coreModTime 2355 2356 FillFilesExisted 2357 set testFileName [file tail [info script]] 2358 2359 # Call the cleanup hook 2360 cleanupTestsHook 2361 2362 # Remove files and directories created by the makeFile and 2363 # makeDirectory procedures. Record the names of files in 2364 # workingDirectory that were not pre-existing, and associate them 2365 # with the test file that created them. 2366 2367 if {!$calledFromAllFile} { 2368 foreach file $filesMade { 2369 if {[file exists $file]} { 2370 DebugDo 1 {Warn "cleanupTests deleting $file..."} 2371 catch {file delete -force $file} 2372 } 2373 } 2374 set currentFiles {} 2375 foreach file [glob -nocomplain \ 2376 -directory [temporaryDirectory] *] { 2377 lappend currentFiles [file tail $file] 2378 } 2379 set newFiles {} 2380 foreach file $currentFiles { 2381 if {[lsearch -exact $filesExisted $file] == -1} { 2382 lappend newFiles $file 2383 } 2384 } 2385 set filesExisted $currentFiles 2386 if {[llength $newFiles] > 0} { 2387 set createdNewFiles($testFileName) $newFiles 2388 } 2389 } 2390 2391 if {$calledFromAllFile || $testSingleFile} { 2392 2393 # print stats 2394 2395 puts -nonewline [outputChannel] "$testFileName:" 2396 foreach index [list "Total" "Passed" "Skipped" "Failed"] { 2397 puts -nonewline [outputChannel] \ 2398 "\t$index\t$numTests($index)" 2399 } 2400 puts [outputChannel] "" 2401 2402 # print number test files sourced 2403 # print names of files that ran tests which failed 2404 2405 if {$calledFromAllFile} { 2406 puts [outputChannel] \ 2407 "Sourced $numTestFiles Test Files." 2408 set numTestFiles 0 2409 if {[llength $failFiles] > 0} { 2410 puts [outputChannel] \ 2411 "Files with failing tests: $failFiles" 2412 set failFiles {} 2413 } 2414 } 2415 2416 # if any tests were skipped, print the constraints that kept 2417 # them from running. 2418 2419 set constraintList [array names skippedBecause] 2420 if {[llength $constraintList] > 0} { 2421 puts [outputChannel] \ 2422 "Number of tests skipped for each constraint:" 2423 foreach constraint [lsort $constraintList] { 2424 puts [outputChannel] \ 2425 "\t$skippedBecause($constraint)\t$constraint" 2426 unset skippedBecause($constraint) 2427 } 2428 } 2429 2430 # report the names of test files in createdNewFiles, and reset 2431 # the array to be empty. 2432 2433 set testFilesThatTurded [lsort [array names createdNewFiles]] 2434 if {[llength $testFilesThatTurded] > 0} { 2435 puts [outputChannel] "Warning: files left behind:" 2436 foreach testFile $testFilesThatTurded { 2437 puts [outputChannel] \ 2438 "\t$testFile:\t$createdNewFiles($testFile)" 2439 unset createdNewFiles($testFile) 2440 } 2441 } 2442 2443 # reset filesMade, filesExisted, and numTests 2444 2445 set filesMade {} 2446 foreach index [list "Total" "Passed" "Skipped" "Failed"] { 2447 set numTests($index) 0 2448 } 2449 2450 # exit only if running Tk in non-interactive mode 2451 # This should be changed to determine if an event 2452 # loop is running, which is the real issue. 2453 # Actually, this doesn't belong here at all. A package 2454 # really has no business [exit]-ing an application. 2455 if {![catch {package present Tk}] && ![testConstraint interactive]} { 2456 exit 2457 } 2458 } else { 2459 2460 # if we're deferring stat-reporting until all files are sourced, 2461 # then add current file to failFile list if any tests in this 2462 # file failed 2463 2464 if {$currentFailure \ 2465 && ([lsearch -exact $failFiles $testFileName] == -1)} { 2466 lappend failFiles $testFileName 2467 } 2468 set currentFailure false 2469 2470 # restore the environment to the state it was in before this package 2471 # was loaded 2472 2473 set newEnv {} 2474 set changedEnv {} 2475 set removedEnv {} 2476 foreach index [array names ::env] { 2477 if {![info exists originalEnv($index)]} { 2478 lappend newEnv $index 2479 unset ::env($index) 2480 } else { 2481 if {$::env($index) != $originalEnv($index)} { 2482 lappend changedEnv $index 2483 set ::env($index) $originalEnv($index) 2484 } 2485 } 2486 } 2487 foreach index [array names originalEnv] { 2488 if {![info exists ::env($index)]} { 2489 lappend removedEnv $index 2490 set ::env($index) $originalEnv($index) 2491 } 2492 } 2493 if {[llength $newEnv] > 0} { 2494 puts [outputChannel] \ 2495 "env array elements created:\t$newEnv" 2496 } 2497 if {[llength $changedEnv] > 0} { 2498 puts [outputChannel] \ 2499 "env array elements changed:\t$changedEnv" 2500 } 2501 if {[llength $removedEnv] > 0} { 2502 puts [outputChannel] \ 2503 "env array elements removed:\t$removedEnv" 2504 } 2505 2506 set changedTclPlatform {} 2507 foreach index [array names originalTclPlatform] { 2508 if {$::tcl_platform($index) \ 2509 != $originalTclPlatform($index)} { 2510 lappend changedTclPlatform $index 2511 set ::tcl_platform($index) $originalTclPlatform($index) 2512 } 2513 } 2514 if {[llength $changedTclPlatform] > 0} { 2515 puts [outputChannel] "tcl_platform array elements\ 2516 changed:\t$changedTclPlatform" 2517 } 2518 2519 if {[file exists [file join [workingDirectory] core]]} { 2520 if {[preserveCore] > 1} { 2521 puts "rename core file (> 1)" 2522 puts [outputChannel] "produced core file! \ 2523 Moving file to: \ 2524 [file join [temporaryDirectory] core-$testFileName]" 2525 catch {file rename -force \ 2526 [file join [workingDirectory] core] \ 2527 [file join [temporaryDirectory] core-$testFileName] 2528 } msg 2529 if {[string length $msg] > 0} { 2530 PrintError "Problem renaming file: $msg" 2531 } 2532 } else { 2533 # Print a message if there is a core file and (1) there 2534 # previously wasn't one or (2) the new one is different 2535 # from the old one. 2536 2537 if {[info exists coreModTime]} { 2538 if {$coreModTime != [file mtime \ 2539 [file join [workingDirectory] core]]} { 2540 puts [outputChannel] "A core file was created!" 2541 } 2542 } else { 2543 puts [outputChannel] "A core file was created!" 2544 } 2545 } 2546 } 2547 } 2548 flush [outputChannel] 2549 flush [errorChannel] 2550 return 2551} 2552 2553##################################################################### 2554 2555# Procs that determine which tests/test files to run 2556 2557# tcltest::GetMatchingFiles 2558# 2559# Looks at the patterns given to match and skip files and uses 2560# them to put together a list of the tests that will be run. 2561# 2562# Arguments: 2563# directory to search 2564# 2565# Results: 2566# The constructed list is returned to the user. This will 2567# primarily be used in 'all.tcl' files. It is used in 2568# runAllTests. 2569# 2570# Side Effects: 2571# None 2572 2573# a lower case version is needed for compatibility with tcltest 1.0 2574proc tcltest::getMatchingFiles args {GetMatchingFiles {*}$args} 2575 2576proc tcltest::GetMatchingFiles { args } { 2577 if {[llength $args]} { 2578 set dirList $args 2579 } else { 2580 # Finding tests only in [testsDirectory] is normal operation. 2581 # This procedure is written to accept multiple directory arguments 2582 # only to satisfy version 1 compatibility. 2583 set dirList [list [testsDirectory]] 2584 } 2585 2586 set matchingFiles [list] 2587 foreach directory $dirList { 2588 2589 # List files in $directory that match patterns to run. 2590 set matchFileList [list] 2591 foreach match [matchFiles] { 2592 set matchFileList [concat $matchFileList \ 2593 [glob -directory $directory -types {b c f p s} \ 2594 -nocomplain -- $match]] 2595 } 2596 2597 # List files in $directory that match patterns to skip. 2598 set skipFileList [list] 2599 foreach skip [skipFiles] { 2600 set skipFileList [concat $skipFileList \ 2601 [glob -directory $directory -types {b c f p s} \ 2602 -nocomplain -- $skip]] 2603 } 2604 2605 # Add to result list all files in match list and not in skip list 2606 foreach file $matchFileList { 2607 if {[lsearch -exact $skipFileList $file] == -1} { 2608 lappend matchingFiles $file 2609 } 2610 } 2611 } 2612 2613 if {[llength $matchingFiles] == 0} { 2614 PrintError "No test files remain after applying your match and\ 2615 skip patterns!" 2616 } 2617 return $matchingFiles 2618} 2619 2620# tcltest::GetMatchingDirectories -- 2621# 2622# Looks at the patterns given to match and skip directories and 2623# uses them to put together a list of the test directories that we 2624# should attempt to run. (Only subdirectories containing an 2625# "all.tcl" file are put into the list.) 2626# 2627# Arguments: 2628# root directory from which to search 2629# 2630# Results: 2631# The constructed list is returned to the user. This is used in 2632# the primary all.tcl file. 2633# 2634# Side Effects: 2635# None. 2636 2637proc tcltest::GetMatchingDirectories {rootdir} { 2638 2639 # Determine the skip list first, to avoid [glob]-ing over subdirectories 2640 # we're going to throw away anyway. Be sure we skip the $rootdir if it 2641 # comes up to avoid infinite loops. 2642 set skipDirs [list $rootdir] 2643 foreach pattern [skipDirectories] { 2644 set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \ 2645 -nocomplain -- $pattern]] 2646 } 2647 2648 # Now step through the matching directories, prune out the skipped ones 2649 # as you go. 2650 set matchDirs [list] 2651 foreach pattern [matchDirectories] { 2652 foreach path [glob -directory $rootdir -types d -nocomplain -- \ 2653 $pattern] { 2654 if {[lsearch -exact $skipDirs $path] == -1} { 2655 set matchDirs [concat $matchDirs [GetMatchingDirectories $path]] 2656 if {[file exists [file join $path all.tcl]]} { 2657 lappend matchDirs $path 2658 } 2659 } 2660 } 2661 } 2662 2663 if {[llength $matchDirs] == 0} { 2664 DebugPuts 1 "No test directories remain after applying match\ 2665 and skip patterns!" 2666 } 2667 return $matchDirs 2668} 2669 2670# tcltest::runAllTests -- 2671# 2672# prints output and sources test files according to the match and 2673# skip patterns provided. after sourcing test files, it goes on 2674# to source all.tcl files in matching test subdirectories. 2675# 2676# Arguments: 2677# shell being tested 2678# 2679# Results: 2680# None. 2681# 2682# Side effects: 2683# None. 2684 2685proc tcltest::runAllTests { {shell ""} } { 2686 variable testSingleFile 2687 variable numTestFiles 2688 variable numTests 2689 variable failFiles 2690 2691 FillFilesExisted 2692 if {[llength [info level 0]] == 1} { 2693 set shell [interpreter] 2694 } 2695 2696 set testSingleFile false 2697 2698 puts [outputChannel] "Tests running in interp: $shell" 2699 puts [outputChannel] "Tests located in: [testsDirectory]" 2700 puts [outputChannel] "Tests running in: [workingDirectory]" 2701 puts [outputChannel] "Temporary files stored in\ 2702 [temporaryDirectory]" 2703 2704 # [file system] first available in Tcl 8.4 2705 if {![catch {file system [testsDirectory]} result] 2706 && ![string equal native [lindex $result 0]]} { 2707 # If we aren't running in the native filesystem, then we must 2708 # run the tests in a single process (via 'source'), because 2709 # trying to run then via a pipe will fail since the files don't 2710 # really exist. 2711 singleProcess 1 2712 } 2713 2714 if {[singleProcess]} { 2715 puts [outputChannel] \ 2716 "Test files sourced into current interpreter" 2717 } else { 2718 puts [outputChannel] \ 2719 "Test files run in separate interpreters" 2720 } 2721 if {[llength [skip]] > 0} { 2722 puts [outputChannel] "Skipping tests that match: [skip]" 2723 } 2724 puts [outputChannel] "Running tests that match: [match]" 2725 2726 if {[llength [skipFiles]] > 0} { 2727 puts [outputChannel] \ 2728 "Skipping test files that match: [skipFiles]" 2729 } 2730 if {[llength [matchFiles]] > 0} { 2731 puts [outputChannel] \ 2732 "Only running test files that match: [matchFiles]" 2733 } 2734 2735 set timeCmd {clock format [clock seconds]} 2736 puts [outputChannel] "Tests began at [eval $timeCmd]" 2737 2738 # Run each of the specified tests 2739 foreach file [lsort [GetMatchingFiles]] { 2740 set tail [file tail $file] 2741 puts [outputChannel] $tail 2742 flush [outputChannel] 2743 2744 if {[singleProcess]} { 2745 incr numTestFiles 2746 uplevel 1 [list ::source $file] 2747 } else { 2748 # Pass along our configuration to the child processes. 2749 # EXCEPT for the -outfile, because the parent process 2750 # needs to read and process output of children. 2751 set childargv [list] 2752 foreach opt [Configure] { 2753 if {[string equal $opt -outfile]} {continue} 2754 lappend childargv $opt [Configure $opt] 2755 } 2756 set cmd [linsert $childargv 0 | $shell $file] 2757 if {[catch { 2758 incr numTestFiles 2759 set pipeFd [open $cmd "r"] 2760 while {[gets $pipeFd line] >= 0} { 2761 if {[regexp [join { 2762 {^([^:]+):\t} 2763 {Total\t([0-9]+)\t} 2764 {Passed\t([0-9]+)\t} 2765 {Skipped\t([0-9]+)\t} 2766 {Failed\t([0-9]+)} 2767 } ""] $line null testFile \ 2768 Total Passed Skipped Failed]} { 2769 foreach index {Total Passed Skipped Failed} { 2770 incr numTests($index) [set $index] 2771 } 2772 if {$Failed > 0} { 2773 lappend failFiles $testFile 2774 } 2775 } elseif {[regexp [join { 2776 {^Number of tests skipped } 2777 {for each constraint:} 2778 {|^\t(\d+)\t(.+)$} 2779 } ""] $line match skipped constraint]} { 2780 if {[string match \t* $match]} { 2781 AddToSkippedBecause $constraint $skipped 2782 } 2783 } else { 2784 puts [outputChannel] $line 2785 } 2786 } 2787 close $pipeFd 2788 } msg]} { 2789 puts [outputChannel] "Test file error: $msg" 2790 # append the name of the test to a list to be reported 2791 # later 2792 lappend testFileFailures $file 2793 } 2794 } 2795 } 2796 2797 # cleanup 2798 puts [outputChannel] "\nTests ended at [eval $timeCmd]" 2799 cleanupTests 1 2800 if {[info exists testFileFailures]} { 2801 puts [outputChannel] "\nTest files exiting with errors: \n" 2802 foreach file $testFileFailures { 2803 puts [outputChannel] " [file tail $file]\n" 2804 } 2805 } 2806 2807 # Checking for subdirectories in which to run tests 2808 foreach directory [GetMatchingDirectories [testsDirectory]] { 2809 set dir [file tail $directory] 2810 puts [outputChannel] [string repeat ~ 44] 2811 puts [outputChannel] "$dir test began at [eval $timeCmd]\n" 2812 2813 uplevel 1 [list ::source [file join $directory all.tcl]] 2814 2815 set endTime [eval $timeCmd] 2816 puts [outputChannel] "\n$dir test ended at $endTime" 2817 puts [outputChannel] "" 2818 puts [outputChannel] [string repeat ~ 44] 2819 } 2820 return 2821} 2822 2823##################################################################### 2824 2825# Test utility procs - not used in tcltest, but may be useful for 2826# testing. 2827 2828# tcltest::loadTestedCommands -- 2829# 2830# Uses the specified script to load the commands to test. Allowed to 2831# be empty, as the tested commands could have been compiled into the 2832# interpreter. 2833# 2834# Arguments 2835# none 2836# 2837# Results 2838# none 2839# 2840# Side Effects: 2841# none. 2842 2843proc tcltest::loadTestedCommands {} { 2844 variable l 2845 if {[string equal {} [loadScript]]} { 2846 return 2847 } 2848 2849 return [uplevel 1 [loadScript]] 2850} 2851 2852# tcltest::saveState -- 2853# 2854# Save information regarding what procs and variables exist. 2855# 2856# Arguments: 2857# none 2858# 2859# Results: 2860# Modifies the variable saveState 2861# 2862# Side effects: 2863# None. 2864 2865proc tcltest::saveState {} { 2866 variable saveState 2867 uplevel 1 [list ::set [namespace which -variable saveState]] \ 2868 {[::list [::info procs] [::info vars]]} 2869 DebugPuts 2 "[lindex [info level 0] 0]: $saveState" 2870 return 2871} 2872 2873# tcltest::restoreState -- 2874# 2875# Remove procs and variables that didn't exist before the call to 2876# [saveState]. 2877# 2878# Arguments: 2879# none 2880# 2881# Results: 2882# Removes procs and variables from your environment if they don't 2883# exist in the saveState variable. 2884# 2885# Side effects: 2886# None. 2887 2888proc tcltest::restoreState {} { 2889 variable saveState 2890 foreach p [uplevel 1 {::info procs}] { 2891 if {([lsearch [lindex $saveState 0] $p] < 0) 2892 && ![string equal [namespace current]::$p \ 2893 [uplevel 1 [list ::namespace origin $p]]]} { 2894 2895 DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p" 2896 uplevel 1 [list ::catch [list ::rename $p {}]] 2897 } 2898 } 2899 foreach p [uplevel 1 {::info vars}] { 2900 if {[lsearch [lindex $saveState 1] $p] < 0} { 2901 DebugPuts 2 "[lindex [info level 0] 0]:\ 2902 Removing variable $p" 2903 uplevel 1 [list ::catch [list ::unset $p]] 2904 } 2905 } 2906 return 2907} 2908 2909# tcltest::normalizeMsg -- 2910# 2911# Removes "extra" newlines from a string. 2912# 2913# Arguments: 2914# msg String to be modified 2915# 2916# Results: 2917# string with extra newlines removed 2918# 2919# Side effects: 2920# None. 2921 2922proc tcltest::normalizeMsg {msg} { 2923 regsub "\n$" [string tolower $msg] "" msg 2924 set msg [string map [list "\n\n" "\n"] $msg] 2925 return [string map [list "\n\}" "\}"] $msg] 2926} 2927 2928# tcltest::makeFile -- 2929# 2930# Create a new file with the name <name>, and write <contents> to it. 2931# 2932# If this file hasn't been created via makeFile since the last time 2933# cleanupTests was called, add it to the $filesMade list, so it will be 2934# removed by the next call to cleanupTests. 2935# 2936# Arguments: 2937# contents content of the new file 2938# name name of the new file 2939# directory directory name for new file 2940# 2941# Results: 2942# absolute path to the file created 2943# 2944# Side effects: 2945# None. 2946 2947proc tcltest::makeFile {contents name {directory ""}} { 2948 variable filesMade 2949 FillFilesExisted 2950 2951 if {[llength [info level 0]] == 3} { 2952 set directory [temporaryDirectory] 2953 } 2954 2955 set fullName [file join $directory $name] 2956 2957 DebugPuts 3 "[lindex [info level 0] 0]:\ 2958 putting ``$contents'' into $fullName" 2959 2960 set fd [open $fullName w] 2961 fconfigure $fd -translation lf 2962 if {[string equal [string index $contents end] \n]} { 2963 puts -nonewline $fd $contents 2964 } else { 2965 puts $fd $contents 2966 } 2967 close $fd 2968 2969 if {[lsearch -exact $filesMade $fullName] == -1} { 2970 lappend filesMade $fullName 2971 } 2972 return $fullName 2973} 2974 2975# tcltest::removeFile -- 2976# 2977# Removes the named file from the filesystem 2978# 2979# Arguments: 2980# name file to be removed 2981# directory directory from which to remove file 2982# 2983# Results: 2984# return value from [file delete] 2985# 2986# Side effects: 2987# None. 2988 2989proc tcltest::removeFile {name {directory ""}} { 2990 variable filesMade 2991 FillFilesExisted 2992 if {[llength [info level 0]] == 2} { 2993 set directory [temporaryDirectory] 2994 } 2995 set fullName [file join $directory $name] 2996 DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName" 2997 set idx [lsearch -exact $filesMade $fullName] 2998 set filesMade [lreplace $filesMade $idx $idx] 2999 if {$idx == -1} { 3000 DebugDo 1 { 3001 Warn "removeFile removing \"$fullName\":\n not created by makeFile" 3002 } 3003 } 3004 if {![file isfile $fullName]} { 3005 DebugDo 1 { 3006 Warn "removeFile removing \"$fullName\":\n not a file" 3007 } 3008 } 3009 return [file delete $fullName] 3010} 3011 3012# tcltest::makeDirectory -- 3013# 3014# Create a new dir with the name <name>. 3015# 3016# If this dir hasn't been created via makeDirectory since the last time 3017# cleanupTests was called, add it to the $directoriesMade list, so it 3018# will be removed by the next call to cleanupTests. 3019# 3020# Arguments: 3021# name name of the new directory 3022# directory directory in which to create new dir 3023# 3024# Results: 3025# absolute path to the directory created 3026# 3027# Side effects: 3028# None. 3029 3030proc tcltest::makeDirectory {name {directory ""}} { 3031 variable filesMade 3032 FillFilesExisted 3033 if {[llength [info level 0]] == 2} { 3034 set directory [temporaryDirectory] 3035 } 3036 set fullName [file join $directory $name] 3037 DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName" 3038 file mkdir $fullName 3039 if {[lsearch -exact $filesMade $fullName] == -1} { 3040 lappend filesMade $fullName 3041 } 3042 return $fullName 3043} 3044 3045# tcltest::removeDirectory -- 3046# 3047# Removes a named directory from the file system. 3048# 3049# Arguments: 3050# name Name of the directory to remove 3051# directory Directory from which to remove 3052# 3053# Results: 3054# return value from [file delete] 3055# 3056# Side effects: 3057# None 3058 3059proc tcltest::removeDirectory {name {directory ""}} { 3060 variable filesMade 3061 FillFilesExisted 3062 if {[llength [info level 0]] == 2} { 3063 set directory [temporaryDirectory] 3064 } 3065 set fullName [file join $directory $name] 3066 DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName" 3067 set idx [lsearch -exact $filesMade $fullName] 3068 set filesMade [lreplace $filesMade $idx $idx] 3069 if {$idx == -1} { 3070 DebugDo 1 { 3071 Warn "removeDirectory removing \"$fullName\":\n not created\ 3072 by makeDirectory" 3073 } 3074 } 3075 if {![file isdirectory $fullName]} { 3076 DebugDo 1 { 3077 Warn "removeDirectory removing \"$fullName\":\n not a directory" 3078 } 3079 } 3080 return [file delete -force $fullName] 3081} 3082 3083# tcltest::viewFile -- 3084# 3085# reads the content of a file and returns it 3086# 3087# Arguments: 3088# name of the file to read 3089# directory in which file is located 3090# 3091# Results: 3092# content of the named file 3093# 3094# Side effects: 3095# None. 3096 3097proc tcltest::viewFile {name {directory ""}} { 3098 FillFilesExisted 3099 if {[llength [info level 0]] == 2} { 3100 set directory [temporaryDirectory] 3101 } 3102 set fullName [file join $directory $name] 3103 set f [open $fullName] 3104 set data [read -nonewline $f] 3105 close $f 3106 return $data 3107} 3108 3109# tcltest::bytestring -- 3110# 3111# Construct a string that consists of the requested sequence of bytes, 3112# as opposed to a string of properly formed UTF-8 characters. 3113# This allows the tester to 3114# 1. Create denormalized or improperly formed strings to pass to C 3115# procedures that are supposed to accept strings with embedded NULL 3116# bytes. 3117# 2. Confirm that a string result has a certain pattern of bytes, for 3118# instance to confirm that "\xe0\0" in a Tcl script is stored 3119# internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". 3120# 3121# Generally, it's a bad idea to examine the bytes in a Tcl string or to 3122# construct improperly formed strings in this manner, because it involves 3123# exposing that Tcl uses UTF-8 internally. 3124# 3125# Arguments: 3126# string being converted 3127# 3128# Results: 3129# result fom encoding 3130# 3131# Side effects: 3132# None 3133 3134proc tcltest::bytestring {string} { 3135 return [encoding convertfrom identity $string] 3136} 3137 3138# tcltest::OpenFiles -- 3139# 3140# used in io tests, uses testchannel 3141# 3142# Arguments: 3143# None. 3144# 3145# Results: 3146# ??? 3147# 3148# Side effects: 3149# None. 3150 3151proc tcltest::OpenFiles {} { 3152 if {[catch {testchannel open} result]} { 3153 return {} 3154 } 3155 return $result 3156} 3157 3158# tcltest::LeakFiles -- 3159# 3160# used in io tests, uses testchannel 3161# 3162# Arguments: 3163# None. 3164# 3165# Results: 3166# ??? 3167# 3168# Side effects: 3169# None. 3170 3171proc tcltest::LeakFiles {old} { 3172 if {[catch {testchannel open} new]} { 3173 return {} 3174 } 3175 set leak {} 3176 foreach p $new { 3177 if {[lsearch $old $p] < 0} { 3178 lappend leak $p 3179 } 3180 } 3181 return $leak 3182} 3183 3184# 3185# Internationalization / ISO support procs -- dl 3186# 3187 3188# tcltest::SetIso8859_1_Locale -- 3189# 3190# used in cmdIL.test, uses testlocale 3191# 3192# Arguments: 3193# None. 3194# 3195# Results: 3196# None. 3197# 3198# Side effects: 3199# None. 3200 3201proc tcltest::SetIso8859_1_Locale {} { 3202 variable previousLocale 3203 variable isoLocale 3204 if {[info commands testlocale] != ""} { 3205 set previousLocale [testlocale ctype] 3206 testlocale ctype $isoLocale 3207 } 3208 return 3209} 3210 3211# tcltest::RestoreLocale -- 3212# 3213# used in cmdIL.test, uses testlocale 3214# 3215# Arguments: 3216# None. 3217# 3218# Results: 3219# None. 3220# 3221# Side effects: 3222# None. 3223 3224proc tcltest::RestoreLocale {} { 3225 variable previousLocale 3226 if {[info commands testlocale] != ""} { 3227 testlocale ctype $previousLocale 3228 } 3229 return 3230} 3231 3232# tcltest::threadReap -- 3233# 3234# Kill all threads except for the main thread. 3235# Do nothing if testthread is not defined. 3236# 3237# Arguments: 3238# none. 3239# 3240# Results: 3241# Returns the number of existing threads. 3242# 3243# Side Effects: 3244# none. 3245# 3246 3247proc tcltest::threadReap {} { 3248 if {[info commands testthread] != {}} { 3249 3250 # testthread built into tcltest 3251 3252 testthread errorproc ThreadNullError 3253 while {[llength [testthread names]] > 1} { 3254 foreach tid [testthread names] { 3255 if {$tid != [mainThread]} { 3256 catch { 3257 testthread send -async $tid {testthread exit} 3258 } 3259 } 3260 } 3261 ## Enter a bit a sleep to give the threads enough breathing 3262 ## room to kill themselves off, otherwise the end up with a 3263 ## massive queue of repeated events 3264 after 1 3265 } 3266 testthread errorproc ThreadError 3267 return [llength [testthread names]] 3268 } elseif {[info commands thread::id] != {}} { 3269 3270 # Thread extension 3271 3272 thread::errorproc ThreadNullError 3273 while {[llength [thread::names]] > 1} { 3274 foreach tid [thread::names] { 3275 if {$tid != [mainThread]} { 3276 catch {thread::send -async $tid {thread::exit}} 3277 } 3278 } 3279 ## Enter a bit a sleep to give the threads enough breathing 3280 ## room to kill themselves off, otherwise the end up with a 3281 ## massive queue of repeated events 3282 after 1 3283 } 3284 thread::errorproc ThreadError 3285 return [llength [thread::names]] 3286 } else { 3287 return 1 3288 } 3289 return 0 3290} 3291 3292# Initialize the constraints and set up command line arguments 3293namespace eval tcltest { 3294 # Define initializers for all the built-in contraint definitions 3295 DefineConstraintInitializers 3296 3297 # Set up the constraints in the testConstraints array to be lazily 3298 # initialized by a registered initializer, or by "false" if no 3299 # initializer is registered. 3300 trace variable testConstraints r [namespace code SafeFetch] 3301 3302 # Only initialize constraints at package load time if an 3303 # [initConstraintsHook] has been pre-defined. This is only 3304 # for compatibility support. The modern way to add a custom 3305 # test constraint is to just call the [testConstraint] command 3306 # straight away, without all this "hook" nonsense. 3307 if {[string equal [namespace current] \ 3308 [namespace qualifiers [namespace which initConstraintsHook]]]} { 3309 InitConstraints 3310 } else { 3311 proc initConstraintsHook {} {} 3312 } 3313 3314 # Define the standard match commands 3315 customMatch exact [list string equal] 3316 customMatch glob [list string match] 3317 customMatch regexp [list regexp --] 3318 3319 # If the TCLTEST_OPTIONS environment variable exists, configure 3320 # tcltest according to the option values it specifies. This has 3321 # the effect of resetting tcltest's default configuration. 3322 proc ConfigureFromEnvironment {} { 3323 upvar #0 env(TCLTEST_OPTIONS) options 3324 if {[catch {llength $options} msg]} { 3325 Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\ 3326 Tcl list: $msg" 3327 return 3328 } 3329 if {[llength $options] % 2} { 3330 Warn "invalid TCLTEST_OPTIONS: \"$options\":\n should be\ 3331 -option value ?-option value ...?" 3332 return 3333 } 3334 if {[catch {Configure {*}$options} msg]} { 3335 Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg" 3336 return 3337 } 3338 } 3339 if {[info exists ::env(TCLTEST_OPTIONS)]} { 3340 ConfigureFromEnvironment 3341 } 3342 3343 proc LoadTimeCmdLineArgParsingRequired {} { 3344 set required false 3345 if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} { 3346 # The command line asks for -help, so give it (and exit) 3347 # right now. ([configure] does not process -help) 3348 set required true 3349 } 3350 foreach hook { PrintUsageInfoHook processCmdLineArgsHook 3351 processCmdLineArgsAddFlagsHook } { 3352 if {[string equal [namespace current] [namespace qualifiers \ 3353 [namespace which $hook]]]} { 3354 set required true 3355 } else { 3356 proc $hook args {} 3357 } 3358 } 3359 return $required 3360 } 3361 3362 # Only initialize configurable options from the command line arguments 3363 # at package load time if necessary for backward compatibility. This 3364 # lets the tcltest user call [configure] for themselves if they wish. 3365 # Traces are established for auto-configuration from the command line 3366 # if any configurable options are accessed before the user calls 3367 # [configure]. 3368 if {[LoadTimeCmdLineArgParsingRequired]} { 3369 ProcessCmdLineArgs 3370 } else { 3371 EstablishAutoConfigureTraces 3372 } 3373 3374 package provide [namespace tail [namespace current]] $Version 3375} 3376