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.78.2.14 2007/09/11 21:18:42 dgp Exp $ 20 21package require Tcl 8.3 ;# uses [glob -directory] 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.2.10 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 {eval 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)$} $level]} { 613 # translate single characters abbreviations to expanded list 614 set level [string map {p pass b body s skip t start e error} \ 615 [split $level {}]] 616 } 617 } 618 set valid [list] 619 foreach v $level { 620 if {[regexp {^(pass|body|skip|start|error)$} $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' and 'e'. 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. 639 } AcceptVerbose verbose 640 641 # Match and skip patterns default to the empty list, except for 642 # matchFiles, which defaults to all .test files in the 643 # testsDirectory and matchDirectories, which defaults to all 644 # directories. 645 Option -match * { 646 Run all tests within the specified files that match one of the 647 list of glob patterns given. 648 } AcceptList match 649 650 Option -skip {} { 651 Skip all tests within the specified tests (via -match) and files 652 that match one of the list of glob patterns given. 653 } AcceptList skip 654 655 Option -file *.test { 656 Run tests in all test files that match the glob pattern given. 657 } AcceptPattern matchFiles 658 659 # By default, skip files that appear to be SCCS lock files. 660 Option -notfile l.*.test { 661 Skip all test files that match the glob pattern given. 662 } AcceptPattern skipFiles 663 664 Option -relateddir * { 665 Run tests in directories that match the glob pattern given. 666 } AcceptPattern matchDirectories 667 668 Option -asidefromdir {} { 669 Skip tests in directories that match the glob pattern given. 670 } AcceptPattern skipDirectories 671 672 # By default, don't save core files 673 Option -preservecore 0 { 674 If 2, save any core files produced during testing in the directory 675 specified by -tmpdir. If 1, notify the user if core files are 676 created. 677 } AcceptInteger preserveCore 678 679 # debug output doesn't get printed by default; debug level 1 spits 680 # up only the tests that were skipped because they didn't match or 681 # were specifically skipped. A debug level of 2 would spit up the 682 # tcltest variables and flags provided; a debug level of 3 causes 683 # some additional output regarding operations of the test harness. 684 # The tcltest package currently implements only up to debug level 3. 685 Option -debug 0 { 686 Internal debug level 687 } AcceptInteger debug 688 689 proc SetSelectedConstraints args { 690 variable Option 691 foreach c $Option(-constraints) { 692 testConstraint $c 1 693 } 694 } 695 Option -constraints {} { 696 Do not skip the listed constraints listed in -constraints. 697 } AcceptList 698 trace variable Option(-constraints) w \ 699 [namespace code {SetSelectedConstraints ;#}] 700 701 # Don't run only the "-constraint" specified tests by default 702 proc ClearUnselectedConstraints args { 703 variable Option 704 variable testConstraints 705 if {!$Option(-limitconstraints)} {return} 706 foreach c [array names testConstraints] { 707 if {[lsearch -exact $Option(-constraints) $c] == -1} { 708 testConstraint $c 0 709 } 710 } 711 } 712 Option -limitconstraints false { 713 whether to run only tests with the constraints 714 } AcceptBoolean limitConstraints 715 trace variable Option(-limitconstraints) w \ 716 [namespace code {ClearUnselectedConstraints ;#}] 717 718 # A test application has to know how to load the tested commands 719 # into the interpreter. 720 Option -load {} { 721 Specifies the script to load the tested commands. 722 } AcceptScript loadScript 723 724 # Default is to run each test file in a separate process 725 Option -singleproc 0 { 726 whether to run all tests in one process 727 } AcceptBoolean singleProcess 728 729 proc AcceptTemporaryDirectory { directory } { 730 set directory [AcceptAbsolutePath $directory] 731 if {![file exists $directory]} { 732 file mkdir $directory 733 } 734 set directory [AcceptDirectory $directory] 735 if {![file writable $directory]} { 736 if {[string equal [workingDirectory] $directory]} { 737 # Special exception: accept the default value 738 # even if the directory is not writable 739 return $directory 740 } 741 return -code error "\"$directory\" is not writeable" 742 } 743 return $directory 744 } 745 746 # Directory where files should be created 747 Option -tmpdir [workingDirectory] { 748 Save temporary files in the specified directory. 749 } AcceptTemporaryDirectory temporaryDirectory 750 trace variable Option(-tmpdir) w \ 751 [namespace code {normalizePath Option(-tmpdir) ;#}] 752 753 # Tests should not rely on the current working directory. 754 # Files that are part of the test suite should be accessed relative 755 # to [testsDirectory] 756 Option -testdir [workingDirectory] { 757 Search tests in the specified directory. 758 } AcceptDirectory testsDirectory 759 trace variable Option(-testdir) w \ 760 [namespace code {normalizePath Option(-testdir) ;#}] 761 762 proc AcceptLoadFile { file } { 763 if {[string equal "" $file]} {return $file} 764 set file [file join [temporaryDirectory] $file] 765 return [AcceptReadable $file] 766 } 767 proc ReadLoadScript {args} { 768 variable Option 769 if {[string equal "" $Option(-loadfile)]} {return} 770 set tmp [open $Option(-loadfile) r] 771 loadScript [read $tmp] 772 close $tmp 773 } 774 Option -loadfile {} { 775 Read the script to load the tested commands from the specified file. 776 } AcceptLoadFile loadFile 777 trace variable Option(-loadfile) w [namespace code ReadLoadScript] 778 779 proc AcceptOutFile { file } { 780 if {[string equal stderr $file]} {return $file} 781 if {[string equal stdout $file]} {return $file} 782 return [file join [temporaryDirectory] $file] 783 } 784 785 # output goes to stdout by default 786 Option -outfile stdout { 787 Send output from test runs to the specified file. 788 } AcceptOutFile outputFile 789 trace variable Option(-outfile) w \ 790 [namespace code {outputChannel $Option(-outfile) ;#}] 791 792 # errors go to stderr by default 793 Option -errfile stderr { 794 Send errors from test runs to the specified file. 795 } AcceptOutFile errorFile 796 trace variable Option(-errfile) w \ 797 [namespace code {errorChannel $Option(-errfile) ;#}] 798 799} 800 801##################################################################### 802 803# tcltest::Debug* -- 804# 805# Internal helper procedures to write out debug information 806# dependent on the chosen level. A test shell may overide 807# them, f.e. to redirect the output into a different 808# channel, or even into a GUI. 809 810# tcltest::DebugPuts -- 811# 812# Prints the specified string if the current debug level is 813# higher than the provided level argument. 814# 815# Arguments: 816# level The lowest debug level triggering the output 817# string The string to print out. 818# 819# Results: 820# Prints the string. Nothing else is allowed. 821# 822# Side Effects: 823# None. 824# 825 826proc tcltest::DebugPuts {level string} { 827 variable debug 828 if {$debug >= $level} { 829 puts $string 830 } 831 return 832} 833 834# tcltest::DebugPArray -- 835# 836# Prints the contents of the specified array if the current 837# debug level is higher than the provided level argument 838# 839# Arguments: 840# level The lowest debug level triggering the output 841# arrayvar The name of the array to print out. 842# 843# Results: 844# Prints the contents of the array. Nothing else is allowed. 845# 846# Side Effects: 847# None. 848# 849 850proc tcltest::DebugPArray {level arrayvar} { 851 variable debug 852 853 if {$debug >= $level} { 854 catch {upvar $arrayvar $arrayvar} 855 parray $arrayvar 856 } 857 return 858} 859 860# Define our own [parray] in ::tcltest that will inherit use of the [puts] 861# defined in ::tcltest. NOTE: Ought to construct with [info args] and 862# [info default], but can't be bothered now. If [parray] changes, then 863# this will need changing too. 864auto_load ::parray 865proc tcltest::parray {a {pattern *}} [info body ::parray] 866 867# tcltest::DebugDo -- 868# 869# Executes the script if the current debug level is greater than 870# the provided level argument 871# 872# Arguments: 873# level The lowest debug level triggering the execution. 874# script The tcl script executed upon a debug level high enough. 875# 876# Results: 877# Arbitrary side effects, dependent on the executed script. 878# 879# Side Effects: 880# None. 881# 882 883proc tcltest::DebugDo {level script} { 884 variable debug 885 886 if {$debug >= $level} { 887 uplevel 1 $script 888 } 889 return 890} 891 892##################################################################### 893 894proc tcltest::Warn {msg} { 895 puts [outputChannel] "WARNING: $msg" 896} 897 898# tcltest::mainThread 899# 900# Accessor command for tcltest variable mainThread. 901# 902proc tcltest::mainThread { {new ""} } { 903 variable mainThread 904 if {[llength [info level 0]] == 1} { 905 return $mainThread 906 } 907 set mainThread $new 908} 909 910# tcltest::testConstraint -- 911# 912# sets a test constraint to a value; to do multiple constraints, 913# call this proc multiple times. also returns the value of the 914# named constraint if no value was supplied. 915# 916# Arguments: 917# constraint - name of the constraint 918# value - new value for constraint (should be boolean) - if not 919# supplied, this is a query 920# 921# Results: 922# content of tcltest::testConstraints($constraint) 923# 924# Side effects: 925# none 926 927proc tcltest::testConstraint {constraint {value ""}} { 928 variable testConstraints 929 variable Option 930 DebugPuts 3 "entering testConstraint $constraint $value" 931 if {[llength [info level 0]] == 2} { 932 return $testConstraints($constraint) 933 } 934 # Check for boolean values 935 if {[catch {expr {$value && $value}} msg]} { 936 return -code error $msg 937 } 938 if {[limitConstraints] 939 && [lsearch -exact $Option(-constraints) $constraint] == -1} { 940 set value 0 941 } 942 set testConstraints($constraint) $value 943} 944 945# tcltest::interpreter -- 946# 947# the interpreter name stored in tcltest::tcltest 948# 949# Arguments: 950# executable name 951# 952# Results: 953# content of tcltest::tcltest 954# 955# Side effects: 956# None. 957 958proc tcltest::interpreter { {interp ""} } { 959 variable tcltest 960 if {[llength [info level 0]] == 1} { 961 return $tcltest 962 } 963 if {[string equal {} $interp]} { 964 set tcltest {} 965 } else { 966 set tcltest $interp 967 } 968} 969 970##################################################################### 971 972# tcltest::AddToSkippedBecause -- 973# 974# Increments the variable used to track how many tests were 975# skipped because of a particular constraint. 976# 977# Arguments: 978# constraint The name of the constraint to be modified 979# 980# Results: 981# Modifies tcltest::skippedBecause; sets the variable to 1 if 982# didn't previously exist - otherwise, it just increments it. 983# 984# Side effects: 985# None. 986 987proc tcltest::AddToSkippedBecause { constraint {value 1}} { 988 # add the constraint to the list of constraints that kept tests 989 # from running 990 variable skippedBecause 991 992 if {[info exists skippedBecause($constraint)]} { 993 incr skippedBecause($constraint) $value 994 } else { 995 set skippedBecause($constraint) $value 996 } 997 return 998} 999 1000# tcltest::PrintError -- 1001# 1002# Prints errors to tcltest::errorChannel and then flushes that 1003# channel, making sure that all messages are < 80 characters per 1004# line. 1005# 1006# Arguments: 1007# errorMsg String containing the error to be printed 1008# 1009# Results: 1010# None. 1011# 1012# Side effects: 1013# None. 1014 1015proc tcltest::PrintError {errorMsg} { 1016 set InitialMessage "Error: " 1017 set InitialMsgLen [string length $InitialMessage] 1018 puts -nonewline [errorChannel] $InitialMessage 1019 1020 # Keep track of where the end of the string is. 1021 set endingIndex [string length $errorMsg] 1022 1023 if {$endingIndex < (80 - $InitialMsgLen)} { 1024 puts [errorChannel] $errorMsg 1025 } else { 1026 # Print up to 80 characters on the first line, including the 1027 # InitialMessage. 1028 set beginningIndex [string last " " [string range $errorMsg 0 \ 1029 [expr {80 - $InitialMsgLen}]]] 1030 puts [errorChannel] [string range $errorMsg 0 $beginningIndex] 1031 1032 while {![string equal end $beginningIndex]} { 1033 puts -nonewline [errorChannel] \ 1034 [string repeat " " $InitialMsgLen] 1035 if {($endingIndex - $beginningIndex) 1036 < (80 - $InitialMsgLen)} { 1037 puts [errorChannel] [string trim \ 1038 [string range $errorMsg $beginningIndex end]] 1039 break 1040 } else { 1041 set newEndingIndex [expr {[string last " " \ 1042 [string range $errorMsg $beginningIndex \ 1043 [expr {$beginningIndex 1044 + (80 - $InitialMsgLen)}] 1045 ]] + $beginningIndex}] 1046 if {($newEndingIndex <= 0) 1047 || ($newEndingIndex <= $beginningIndex)} { 1048 set newEndingIndex end 1049 } 1050 puts [errorChannel] [string trim \ 1051 [string range $errorMsg \ 1052 $beginningIndex $newEndingIndex]] 1053 set beginningIndex $newEndingIndex 1054 } 1055 } 1056 } 1057 flush [errorChannel] 1058 return 1059} 1060 1061# tcltest::SafeFetch -- 1062# 1063# The following trace procedure makes it so that we can safely 1064# refer to non-existent members of the testConstraints array 1065# without causing an error. Instead, reading a non-existent 1066# member will return 0. This is necessary because tests are 1067# allowed to use constraint "X" without ensuring that 1068# testConstraints("X") is defined. 1069# 1070# Arguments: 1071# n1 - name of the array (testConstraints) 1072# n2 - array key value (constraint name) 1073# op - operation performed on testConstraints (generally r) 1074# 1075# Results: 1076# none 1077# 1078# Side effects: 1079# sets testConstraints($n2) to 0 if it's referenced but never 1080# before used 1081 1082proc tcltest::SafeFetch {n1 n2 op} { 1083 variable testConstraints 1084 DebugPuts 3 "entering SafeFetch $n1 $n2 $op" 1085 if {[string equal {} $n2]} {return} 1086 if {![info exists testConstraints($n2)]} { 1087 if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} { 1088 testConstraint $n2 0 1089 } 1090 } 1091} 1092 1093# tcltest::ConstraintInitializer -- 1094# 1095# Get or set a script that when evaluated in the tcltest namespace 1096# will return a boolean value with which to initialize the 1097# associated constraint. 1098# 1099# Arguments: 1100# constraint - name of the constraint initialized by the script 1101# script - the initializer script 1102# 1103# Results 1104# boolean value of the constraint - enabled or disabled 1105# 1106# Side effects: 1107# Constraint is initialized for future reference by [test] 1108proc tcltest::ConstraintInitializer {constraint {script ""}} { 1109 variable ConstraintInitializer 1110 DebugPuts 3 "entering ConstraintInitializer $constraint $script" 1111 if {[llength [info level 0]] == 2} { 1112 return $ConstraintInitializer($constraint) 1113 } 1114 # Check for boolean values 1115 if {![info complete $script]} { 1116 return -code error "ConstraintInitializer must be complete script" 1117 } 1118 set ConstraintInitializer($constraint) $script 1119} 1120 1121# tcltest::InitConstraints -- 1122# 1123# Call all registered constraint initializers to force initialization 1124# of all known constraints. 1125# See the tcltest man page for the list of built-in constraints defined 1126# in this procedure. 1127# 1128# Arguments: 1129# none 1130# 1131# Results: 1132# The testConstraints array is reset to have an index for each 1133# built-in test constraint. 1134# 1135# Side Effects: 1136# None. 1137# 1138 1139proc tcltest::InitConstraints {} { 1140 variable ConstraintInitializer 1141 initConstraintsHook 1142 foreach constraint [array names ConstraintInitializer] { 1143 testConstraint $constraint 1144 } 1145} 1146 1147proc tcltest::DefineConstraintInitializers {} { 1148 ConstraintInitializer singleTestInterp {singleProcess} 1149 1150 # All the 'pc' constraints are here for backward compatibility and 1151 # are not documented. They have been replaced with equivalent 'win' 1152 # constraints. 1153 1154 ConstraintInitializer unixOnly \ 1155 {string equal $::tcl_platform(platform) unix} 1156 ConstraintInitializer macOnly \ 1157 {string equal $::tcl_platform(platform) macintosh} 1158 ConstraintInitializer pcOnly \ 1159 {string equal $::tcl_platform(platform) windows} 1160 ConstraintInitializer winOnly \ 1161 {string equal $::tcl_platform(platform) windows} 1162 1163 ConstraintInitializer unix {testConstraint unixOnly} 1164 ConstraintInitializer mac {testConstraint macOnly} 1165 ConstraintInitializer pc {testConstraint pcOnly} 1166 ConstraintInitializer win {testConstraint winOnly} 1167 1168 ConstraintInitializer unixOrPc \ 1169 {expr {[testConstraint unix] || [testConstraint pc]}} 1170 ConstraintInitializer macOrPc \ 1171 {expr {[testConstraint mac] || [testConstraint pc]}} 1172 ConstraintInitializer unixOrWin \ 1173 {expr {[testConstraint unix] || [testConstraint win]}} 1174 ConstraintInitializer macOrWin \ 1175 {expr {[testConstraint mac] || [testConstraint win]}} 1176 ConstraintInitializer macOrUnix \ 1177 {expr {[testConstraint mac] || [testConstraint unix]}} 1178 1179 ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"} 1180 ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"} 1181 ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"} 1182 1183 # The following Constraints switches are used to mark tests that 1184 # should work, but have been temporarily disabled on certain 1185 # platforms because they don't and we haven't gotten around to 1186 # fixing the underlying problem. 1187 1188 ConstraintInitializer tempNotPc {expr {![testConstraint pc]}} 1189 ConstraintInitializer tempNotWin {expr {![testConstraint win]}} 1190 ConstraintInitializer tempNotMac {expr {![testConstraint mac]}} 1191 ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}} 1192 1193 # The following Constraints switches are used to mark tests that 1194 # crash on certain platforms, so that they can be reactivated again 1195 # when the underlying problem is fixed. 1196 1197 ConstraintInitializer pcCrash {expr {![testConstraint pc]}} 1198 ConstraintInitializer winCrash {expr {![testConstraint win]}} 1199 ConstraintInitializer macCrash {expr {![testConstraint mac]}} 1200 ConstraintInitializer unixCrash {expr {![testConstraint unix]}} 1201 1202 # Skip empty tests 1203 1204 ConstraintInitializer emptyTest {format 0} 1205 1206 # By default, tests that expose known bugs are skipped. 1207 1208 ConstraintInitializer knownBug {format 0} 1209 1210 # By default, non-portable tests are skipped. 1211 1212 ConstraintInitializer nonPortable {format 0} 1213 1214 # Some tests require user interaction. 1215 1216 ConstraintInitializer userInteraction {format 0} 1217 1218 # Some tests must be skipped if the interpreter is not in 1219 # interactive mode 1220 1221 ConstraintInitializer interactive \ 1222 {expr {[info exists ::tcl_interactive] && $::tcl_interactive}} 1223 1224 # Some tests can only be run if the installation came from a CD 1225 # image instead of a web image. Some tests must be skipped if you 1226 # are running as root on Unix. Other tests can only be run if you 1227 # are running as root on Unix. 1228 1229 ConstraintInitializer root {expr \ 1230 {[string equal unix $::tcl_platform(platform)] 1231 && ([string equal root $::tcl_platform(user)] 1232 || [string equal "" $::tcl_platform(user)])}} 1233 ConstraintInitializer notRoot {expr {![testConstraint root]}} 1234 1235 # Set nonBlockFiles constraint: 1 means this platform supports 1236 # setting files into nonblocking mode. 1237 1238 ConstraintInitializer nonBlockFiles { 1239 set code [expr {[catch {set f [open defs r]}] 1240 || [catch {fconfigure $f -blocking off}]}] 1241 catch {close $f} 1242 set code 1243 } 1244 1245 # Set asyncPipeClose constraint: 1 means this platform supports 1246 # async flush and async close on a pipe. 1247 # 1248 # Test for SCO Unix - cannot run async flushing tests because a 1249 # potential problem with select is apparently interfering. 1250 # (Mark Diekhans). 1251 1252 ConstraintInitializer asyncPipeClose {expr { 1253 !([string equal unix $::tcl_platform(platform)] 1254 && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}} 1255 1256 # Test to see if we have a broken version of sprintf with respect 1257 # to the "e" format of floating-point numbers. 1258 1259 ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05} 1260 1261 # Test to see if execed commands such as cat, echo, rm and so forth 1262 # are present on this machine. 1263 1264 ConstraintInitializer unixExecs { 1265 set code 1 1266 if {[string equal macintosh $::tcl_platform(platform)]} { 1267 set code 0 1268 } 1269 if {[string equal windows $::tcl_platform(platform)]} { 1270 if {[catch { 1271 set file _tcl_test_remove_me.txt 1272 makeFile {hello} $file 1273 }]} { 1274 set code 0 1275 } elseif { 1276 [catch {exec cat $file}] || 1277 [catch {exec echo hello}] || 1278 [catch {exec sh -c echo hello}] || 1279 [catch {exec wc $file}] || 1280 [catch {exec sleep 1}] || 1281 [catch {exec echo abc > $file}] || 1282 [catch {exec chmod 644 $file}] || 1283 [catch {exec rm $file}] || 1284 [llength [auto_execok mkdir]] == 0 || 1285 [llength [auto_execok fgrep]] == 0 || 1286 [llength [auto_execok grep]] == 0 || 1287 [llength [auto_execok ps]] == 0 1288 } { 1289 set code 0 1290 } 1291 removeFile $file 1292 } 1293 set code 1294 } 1295 1296 ConstraintInitializer stdio { 1297 set code 0 1298 if {![catch {set f [open "|[list [interpreter]]" w]}]} { 1299 if {![catch {puts $f exit}]} { 1300 if {![catch {close $f}]} { 1301 set code 1 1302 } 1303 } 1304 } 1305 set code 1306 } 1307 1308 # Deliberately call socket with the wrong number of arguments. The 1309 # error message you get will indicate whether sockets are available 1310 # on this system. 1311 1312 ConstraintInitializer socket { 1313 catch {socket} msg 1314 string compare $msg "sockets are not available on this system" 1315 } 1316 1317 # Check for internationalization 1318 ConstraintInitializer hasIsoLocale { 1319 if {[llength [info commands testlocale]] == 0} { 1320 set code 0 1321 } else { 1322 set code [string length [SetIso8859_1_Locale]] 1323 RestoreLocale 1324 } 1325 set code 1326 } 1327 1328} 1329##################################################################### 1330 1331# Usage and command line arguments processing. 1332 1333# tcltest::PrintUsageInfo 1334# 1335# Prints out the usage information for package tcltest. This can 1336# be customized with the redefinition of [PrintUsageInfoHook]. 1337# 1338# Arguments: 1339# none 1340# 1341# Results: 1342# none 1343# 1344# Side Effects: 1345# none 1346proc tcltest::PrintUsageInfo {} { 1347 puts [Usage] 1348 PrintUsageInfoHook 1349} 1350 1351proc tcltest::Usage { {option ""} } { 1352 variable Usage 1353 variable Verify 1354 if {[llength [info level 0]] == 1} { 1355 set msg "Usage: [file tail [info nameofexecutable]] script " 1356 append msg "?-help? ?flag value? ... \n" 1357 append msg "Available flags (and valid input values) are:" 1358 1359 set max 0 1360 set allOpts [concat -help [Configure]] 1361 foreach opt $allOpts { 1362 set foo [Usage $opt] 1363 foreach [list x type($opt) usage($opt)] $foo break 1364 set line($opt) " $opt $type($opt) " 1365 set length($opt) [string length $line($opt)] 1366 if {$length($opt) > $max} {set max $length($opt)} 1367 } 1368 set rest [expr {72 - $max}] 1369 foreach opt $allOpts { 1370 append msg \n$line($opt) 1371 append msg [string repeat " " [expr {$max - $length($opt)}]] 1372 set u [string trim $usage($opt)] 1373 catch {append u " (default: \[[Configure $opt]])"} 1374 regsub -all {\s*\n\s*} $u " " u 1375 while {[string length $u] > $rest} { 1376 set break [string wordstart $u $rest] 1377 if {$break == 0} { 1378 set break [string wordend $u 0] 1379 } 1380 append msg [string range $u 0 [expr {$break - 1}]] 1381 set u [string trim [string range $u $break end]] 1382 append msg \n[string repeat " " $max] 1383 } 1384 append msg $u 1385 } 1386 return $msg\n 1387 } elseif {[string equal -help $option]} { 1388 return [list -help "" "Display this usage information."] 1389 } else { 1390 set type [lindex [info args $Verify($option)] 0] 1391 return [list $option $type $Usage($option)] 1392 } 1393} 1394 1395# tcltest::ProcessFlags -- 1396# 1397# process command line arguments supplied in the flagArray - this 1398# is called by processCmdLineArgs. Modifies tcltest variables 1399# according to the content of the flagArray. 1400# 1401# Arguments: 1402# flagArray - array containing name/value pairs of flags 1403# 1404# Results: 1405# sets tcltest variables according to their values as defined by 1406# flagArray 1407# 1408# Side effects: 1409# None. 1410 1411proc tcltest::ProcessFlags {flagArray} { 1412 # Process -help first 1413 if {[lsearch -exact $flagArray {-help}] != -1} { 1414 PrintUsageInfo 1415 exit 1 1416 } 1417 1418 if {[llength $flagArray] == 0} { 1419 RemoveAutoConfigureTraces 1420 } else { 1421 set args $flagArray 1422 while {[llength $args]>1 && [catch {eval [linsert $args 0 configure]} msg]} { 1423 1424 # Something went wrong parsing $args for tcltest options 1425 # Check whether the problem is "unknown option" 1426 if {[regexp {^unknown option (\S+):} $msg -> option]} { 1427 # Could be this is an option the Hook knows about 1428 set moreOptions [processCmdLineArgsAddFlagsHook] 1429 if {[lsearch -exact $moreOptions $option] == -1} { 1430 # Nope. Report the error, including additional options, 1431 # but keep going 1432 if {[llength $moreOptions]} { 1433 append msg ", " 1434 append msg [join [lrange $moreOptions 0 end-1] ", "] 1435 append msg "or [lindex $moreOptions end]" 1436 } 1437 Warn $msg 1438 } 1439 } else { 1440 # error is something other than "unknown option" 1441 # notify user of the error; and exit 1442 puts [errorChannel] $msg 1443 exit 1 1444 } 1445 1446 # To recover, find that unknown option and remove up to it. 1447 # then retry 1448 while {![string equal [lindex $args 0] $option]} { 1449 set args [lrange $args 2 end] 1450 } 1451 set args [lrange $args 2 end] 1452 } 1453 if {[llength $args] == 1} { 1454 puts [errorChannel] \ 1455 "missing value for option [lindex $args 0]" 1456 exit 1 1457 } 1458 } 1459 1460 # Call the hook 1461 catch { 1462 array set flag $flagArray 1463 processCmdLineArgsHook [array get flag] 1464 } 1465 return 1466} 1467 1468# tcltest::ProcessCmdLineArgs -- 1469# 1470# This procedure must be run after constraint initialization is 1471# set up (by [DefineConstraintInitializers]) because some constraints 1472# can be overridden. 1473# 1474# Perform configuration according to the command-line options. 1475# 1476# Arguments: 1477# none 1478# 1479# Results: 1480# Sets the above-named variables in the tcltest namespace. 1481# 1482# Side Effects: 1483# None. 1484# 1485 1486proc tcltest::ProcessCmdLineArgs {} { 1487 variable originalEnv 1488 variable testConstraints 1489 1490 # The "argv" var doesn't exist in some cases, so use {}. 1491 if {![info exists ::argv]} { 1492 ProcessFlags {} 1493 } else { 1494 ProcessFlags $::argv 1495 } 1496 1497 # Spit out everything you know if we're at a debug level 2 or 1498 # greater 1499 DebugPuts 2 "Flags passed into tcltest:" 1500 if {[info exists ::env(TCLTEST_OPTIONS)]} { 1501 DebugPuts 2 \ 1502 " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)" 1503 } 1504 if {[info exists ::argv]} { 1505 DebugPuts 2 " argv: $::argv" 1506 } 1507 DebugPuts 2 "tcltest::debug = [debug]" 1508 DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]" 1509 DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]" 1510 DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]" 1511 DebugPuts 2 "tcltest::outputChannel = [outputChannel]" 1512 DebugPuts 2 "tcltest::errorChannel = [errorChannel]" 1513 DebugPuts 2 "Original environment (tcltest::originalEnv):" 1514 DebugPArray 2 originalEnv 1515 DebugPuts 2 "Constraints:" 1516 DebugPArray 2 testConstraints 1517} 1518 1519##################################################################### 1520 1521# Code to run the tests goes here. 1522 1523# tcltest::TestPuts -- 1524# 1525# Used to redefine puts in test environment. Stores whatever goes 1526# out on stdout in tcltest::outData and stderr in errData before 1527# sending it on to the regular puts. 1528# 1529# Arguments: 1530# same as standard puts 1531# 1532# Results: 1533# none 1534# 1535# Side effects: 1536# Intercepts puts; data that would otherwise go to stdout, stderr, 1537# or file channels specified in outputChannel and errorChannel 1538# does not get sent to the normal puts function. 1539namespace eval tcltest::Replace { 1540 namespace export puts 1541} 1542proc tcltest::Replace::puts {args} { 1543 variable [namespace parent]::outData 1544 variable [namespace parent]::errData 1545 switch [llength $args] { 1546 1 { 1547 # Only the string to be printed is specified 1548 append outData [lindex $args 0]\n 1549 return 1550 # return [Puts [lindex $args 0]] 1551 } 1552 2 { 1553 # Either -nonewline or channelId has been specified 1554 if {[string equal -nonewline [lindex $args 0]]} { 1555 append outData [lindex $args end] 1556 return 1557 # return [Puts -nonewline [lindex $args end]] 1558 } else { 1559 set channel [lindex $args 0] 1560 set newline \n 1561 } 1562 } 1563 3 { 1564 if {[string equal -nonewline [lindex $args 0]]} { 1565 # Both -nonewline and channelId are specified, unless 1566 # it's an error. -nonewline is supposed to be argv[0]. 1567 set channel [lindex $args 1] 1568 set newline "" 1569 } 1570 } 1571 } 1572 1573 if {[info exists channel]} { 1574 if {[string equal $channel [[namespace parent]::outputChannel]] 1575 || [string equal $channel stdout]} { 1576 append outData [lindex $args end]$newline 1577 return 1578 } elseif {[string equal $channel [[namespace parent]::errorChannel]] 1579 || [string equal $channel stderr]} { 1580 append errData [lindex $args end]$newline 1581 return 1582 } 1583 } 1584 1585 # If we haven't returned by now, we don't know how to handle the 1586 # input. Let puts handle it. 1587 return [eval Puts $args] 1588} 1589 1590# tcltest::Eval -- 1591# 1592# Evaluate the script in the test environment. If ignoreOutput is 1593# false, store data sent to stderr and stdout in outData and 1594# errData. Otherwise, ignore this output altogether. 1595# 1596# Arguments: 1597# script Script to evaluate 1598# ?ignoreOutput? Indicates whether or not to ignore output 1599# sent to stdout & stderr 1600# 1601# Results: 1602# result from running the script 1603# 1604# Side effects: 1605# Empties the contents of outData and errData before running a 1606# test if ignoreOutput is set to 0. 1607 1608proc tcltest::Eval {script {ignoreOutput 1}} { 1609 variable outData 1610 variable errData 1611 DebugPuts 3 "[lindex [info level 0] 0] called" 1612 if {!$ignoreOutput} { 1613 set outData {} 1614 set errData {} 1615 rename ::puts [namespace current]::Replace::Puts 1616 namespace eval :: \ 1617 [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==== $name\ 2091 [string trim $description] FAILED" 2092 if {[string length $body]} { 2093 puts [outputChannel] "==== Contents of test case:" 2094 puts [outputChannel] $body 2095 } 2096 if {$setupFailure} { 2097 puts [outputChannel] "---- Test setup\ 2098 failed:\n$setupMsg" 2099 if {[info exists errorInfo(setup)]} { 2100 puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)" 2101 puts [outputChannel] "---- errorCode(setup): $errorCode(setup)" 2102 } 2103 } 2104 if {$scriptFailure} { 2105 if {$scriptCompare} { 2106 puts [outputChannel] "---- Error testing result: $scriptMatch" 2107 } else { 2108 puts [outputChannel] "---- Result was:\n$actualAnswer" 2109 puts [outputChannel] "---- Result should have been\ 2110 ($match matching):\n$result" 2111 } 2112 } 2113 if {$codeFailure} { 2114 switch -- $returnCode { 2115 0 { set msg "Test completed normally" } 2116 1 { set msg "Test generated error" } 2117 2 { set msg "Test generated return exception" } 2118 3 { set msg "Test generated break exception" } 2119 4 { set msg "Test generated continue exception" } 2120 default { set msg "Test generated exception" } 2121 } 2122 puts [outputChannel] "---- $msg; Return code was: $returnCode" 2123 puts [outputChannel] "---- Return code should have been\ 2124 one of: $returnCodes" 2125 if {[IsVerbose error]} { 2126 if {[info exists errorInfo(body)] && ([lsearch $returnCodes 1]<0)} { 2127 puts [outputChannel] "---- errorInfo: $errorInfo(body)" 2128 puts [outputChannel] "---- errorCode: $errorCode(body)" 2129 } 2130 } 2131 } 2132 if {$outputFailure} { 2133 if {$outputCompare} { 2134 puts [outputChannel] "---- Error testing output: $outputMatch" 2135 } else { 2136 puts [outputChannel] "---- Output was:\n$outData" 2137 puts [outputChannel] "---- Output should have been\ 2138 ($match matching):\n$output" 2139 } 2140 } 2141 if {$errorFailure} { 2142 if {$errorCompare} { 2143 puts [outputChannel] "---- Error testing errorOutput: $errorMatch" 2144 } else { 2145 puts [outputChannel] "---- Error output was:\n$errData" 2146 puts [outputChannel] "---- Error output should have\ 2147 been ($match matching):\n$errorOutput" 2148 } 2149 } 2150 if {$cleanupFailure} { 2151 puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" 2152 if {[info exists errorInfo(cleanup)]} { 2153 puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)" 2154 puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)" 2155 } 2156 } 2157 if {$coreFailure} { 2158 puts [outputChannel] "---- Core file produced while running\ 2159 test! $coreMsg" 2160 } 2161 puts [outputChannel] "==== $name FAILED\n" 2162 2163 incr testLevel -1 2164 return 2165} 2166 2167# Skipped -- 2168# 2169# Given a test name and it constraints, returns a boolean indicating 2170# whether the current configuration says the test should be skipped. 2171# 2172# Side Effects: Maintains tally of total tests seen and tests skipped. 2173# 2174proc tcltest::Skipped {name constraints} { 2175 variable testLevel 2176 variable numTests 2177 variable testConstraints 2178 2179 if {$testLevel == 1} { 2180 incr numTests(Total) 2181 } 2182 # skip the test if it's name matches an element of skip 2183 foreach pattern [skip] { 2184 if {[string match $pattern $name]} { 2185 if {$testLevel == 1} { 2186 incr numTests(Skipped) 2187 DebugDo 1 {AddToSkippedBecause userSpecifiedSkip} 2188 } 2189 return 1 2190 } 2191 } 2192 # skip the test if it's name doesn't match any element of match 2193 set ok 0 2194 foreach pattern [match] { 2195 if {[string match $pattern $name]} { 2196 set ok 1 2197 break 2198 } 2199 } 2200 if {!$ok} { 2201 if {$testLevel == 1} { 2202 incr numTests(Skipped) 2203 DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch} 2204 } 2205 return 1 2206 } 2207 if {[string equal {} $constraints]} { 2208 # If we're limited to the listed constraints and there aren't 2209 # any listed, then we shouldn't run the test. 2210 if {[limitConstraints]} { 2211 AddToSkippedBecause userSpecifiedLimitConstraint 2212 if {$testLevel == 1} { 2213 incr numTests(Skipped) 2214 } 2215 return 1 2216 } 2217 } else { 2218 # "constraints" argument exists; 2219 # make sure that the constraints are satisfied. 2220 2221 set doTest 0 2222 if {[string match {*[$\[]*} $constraints] != 0} { 2223 # full expression, e.g. {$foo > [info tclversion]} 2224 catch {set doTest [uplevel #0 [list expr $constraints]]} 2225 } elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} { 2226 # something like {a || b} should be turned into 2227 # $testConstraints(a) || $testConstraints(b). 2228 regsub -all {[.\w]+} $constraints {$testConstraints(&)} c 2229 catch {set doTest [eval [list expr $c]]} 2230 } elseif {![catch {llength $constraints}]} { 2231 # just simple constraints such as {unixOnly fonts}. 2232 set doTest 1 2233 foreach constraint $constraints { 2234 if {(![info exists testConstraints($constraint)]) \ 2235 || (!$testConstraints($constraint))} { 2236 set doTest 0 2237 2238 # store the constraint that kept the test from 2239 # running 2240 set constraints $constraint 2241 break 2242 } 2243 } 2244 } 2245 2246 if {!$doTest} { 2247 if {[IsVerbose skip]} { 2248 puts [outputChannel] "++++ $name SKIPPED: $constraints" 2249 } 2250 2251 if {$testLevel == 1} { 2252 incr numTests(Skipped) 2253 AddToSkippedBecause $constraints 2254 } 2255 return 1 2256 } 2257 } 2258 return 0 2259} 2260 2261# RunTest -- 2262# 2263# This is where the body of a test is evaluated. The combination of 2264# [RunTest] and [Eval] allows the output and error output of the test 2265# body to be captured for comparison against the expected values. 2266 2267proc tcltest::RunTest {name script} { 2268 DebugPuts 3 "Running $name {$script}" 2269 2270 # If there is no "memory" command (because memory debugging isn't 2271 # enabled), then don't attempt to use the command. 2272 2273 if {[llength [info commands memory]] == 1} { 2274 memory tag $name 2275 } 2276 2277 set code [catch {uplevel 1 $script} actualAnswer] 2278 2279 return [list $actualAnswer $code] 2280} 2281 2282##################################################################### 2283 2284# tcltest::cleanupTestsHook -- 2285# 2286# This hook allows a harness that builds upon tcltest to specify 2287# additional things that should be done at cleanup. 2288# 2289 2290if {[llength [info commands tcltest::cleanupTestsHook]] == 0} { 2291 proc tcltest::cleanupTestsHook {} {} 2292} 2293 2294# tcltest::cleanupTests -- 2295# 2296# Remove files and dirs created using the makeFile and makeDirectory 2297# commands since the last time this proc was invoked. 2298# 2299# Print the names of the files created without the makeFile command 2300# since the tests were invoked. 2301# 2302# Print the number tests (total, passed, failed, and skipped) since the 2303# tests were invoked. 2304# 2305# Restore original environment (as reported by special variable env). 2306# 2307# Arguments: 2308# calledFromAllFile - if 0, behave as if we are running a single 2309# test file within an entire suite of tests. if we aren't running 2310# a single test file, then don't report status. check for new 2311# files created during the test run and report on them. if 1, 2312# report collated status from all the test file runs. 2313# 2314# Results: 2315# None. 2316# 2317# Side Effects: 2318# None 2319# 2320 2321proc tcltest::cleanupTests {{calledFromAllFile 0}} { 2322 variable filesMade 2323 variable filesExisted 2324 variable createdNewFiles 2325 variable testSingleFile 2326 variable numTests 2327 variable numTestFiles 2328 variable failFiles 2329 variable skippedBecause 2330 variable currentFailure 2331 variable originalEnv 2332 variable originalTclPlatform 2333 variable coreModTime 2334 2335 FillFilesExisted 2336 set testFileName [file tail [info script]] 2337 2338 # Call the cleanup hook 2339 cleanupTestsHook 2340 2341 # Remove files and directories created by the makeFile and 2342 # makeDirectory procedures. Record the names of files in 2343 # workingDirectory that were not pre-existing, and associate them 2344 # with the test file that created them. 2345 2346 if {!$calledFromAllFile} { 2347 foreach file $filesMade { 2348 if {[file exists $file]} { 2349 DebugDo 1 {Warn "cleanupTests deleting $file..."} 2350 catch {file delete -force $file} 2351 } 2352 } 2353 set currentFiles {} 2354 foreach file [glob -nocomplain \ 2355 -directory [temporaryDirectory] *] { 2356 lappend currentFiles [file tail $file] 2357 } 2358 set newFiles {} 2359 foreach file $currentFiles { 2360 if {[lsearch -exact $filesExisted $file] == -1} { 2361 lappend newFiles $file 2362 } 2363 } 2364 set filesExisted $currentFiles 2365 if {[llength $newFiles] > 0} { 2366 set createdNewFiles($testFileName) $newFiles 2367 } 2368 } 2369 2370 if {$calledFromAllFile || $testSingleFile} { 2371 2372 # print stats 2373 2374 puts -nonewline [outputChannel] "$testFileName:" 2375 foreach index [list "Total" "Passed" "Skipped" "Failed"] { 2376 puts -nonewline [outputChannel] \ 2377 "\t$index\t$numTests($index)" 2378 } 2379 puts [outputChannel] "" 2380 2381 # print number test files sourced 2382 # print names of files that ran tests which failed 2383 2384 if {$calledFromAllFile} { 2385 puts [outputChannel] \ 2386 "Sourced $numTestFiles Test Files." 2387 set numTestFiles 0 2388 if {[llength $failFiles] > 0} { 2389 puts [outputChannel] \ 2390 "Files with failing tests: $failFiles" 2391 set failFiles {} 2392 } 2393 } 2394 2395 # if any tests were skipped, print the constraints that kept 2396 # them from running. 2397 2398 set constraintList [array names skippedBecause] 2399 if {[llength $constraintList] > 0} { 2400 puts [outputChannel] \ 2401 "Number of tests skipped for each constraint:" 2402 foreach constraint [lsort $constraintList] { 2403 puts [outputChannel] \ 2404 "\t$skippedBecause($constraint)\t$constraint" 2405 unset skippedBecause($constraint) 2406 } 2407 } 2408 2409 # report the names of test files in createdNewFiles, and reset 2410 # the array to be empty. 2411 2412 set testFilesThatTurded [lsort [array names createdNewFiles]] 2413 if {[llength $testFilesThatTurded] > 0} { 2414 puts [outputChannel] "Warning: files left behind:" 2415 foreach testFile $testFilesThatTurded { 2416 puts [outputChannel] \ 2417 "\t$testFile:\t$createdNewFiles($testFile)" 2418 unset createdNewFiles($testFile) 2419 } 2420 } 2421 2422 # reset filesMade, filesExisted, and numTests 2423 2424 set filesMade {} 2425 foreach index [list "Total" "Passed" "Skipped" "Failed"] { 2426 set numTests($index) 0 2427 } 2428 2429 # exit only if running Tk in non-interactive mode 2430 # This should be changed to determine if an event 2431 # loop is running, which is the real issue. 2432 # Actually, this doesn't belong here at all. A package 2433 # really has no business [exit]-ing an application. 2434 if {![catch {package present Tk}] && ![testConstraint interactive]} { 2435 exit 2436 } 2437 } else { 2438 2439 # if we're deferring stat-reporting until all files are sourced, 2440 # then add current file to failFile list if any tests in this 2441 # file failed 2442 2443 if {$currentFailure \ 2444 && ([lsearch -exact $failFiles $testFileName] == -1)} { 2445 lappend failFiles $testFileName 2446 } 2447 set currentFailure false 2448 2449 # restore the environment to the state it was in before this package 2450 # was loaded 2451 2452 set newEnv {} 2453 set changedEnv {} 2454 set removedEnv {} 2455 foreach index [array names ::env] { 2456 if {![info exists originalEnv($index)]} { 2457 lappend newEnv $index 2458 unset ::env($index) 2459 } else { 2460 if {$::env($index) != $originalEnv($index)} { 2461 lappend changedEnv $index 2462 set ::env($index) $originalEnv($index) 2463 } 2464 } 2465 } 2466 foreach index [array names originalEnv] { 2467 if {![info exists ::env($index)]} { 2468 lappend removedEnv $index 2469 set ::env($index) $originalEnv($index) 2470 } 2471 } 2472 if {[llength $newEnv] > 0} { 2473 puts [outputChannel] \ 2474 "env array elements created:\t$newEnv" 2475 } 2476 if {[llength $changedEnv] > 0} { 2477 puts [outputChannel] \ 2478 "env array elements changed:\t$changedEnv" 2479 } 2480 if {[llength $removedEnv] > 0} { 2481 puts [outputChannel] \ 2482 "env array elements removed:\t$removedEnv" 2483 } 2484 2485 set changedTclPlatform {} 2486 foreach index [array names originalTclPlatform] { 2487 if {$::tcl_platform($index) \ 2488 != $originalTclPlatform($index)} { 2489 lappend changedTclPlatform $index 2490 set ::tcl_platform($index) $originalTclPlatform($index) 2491 } 2492 } 2493 if {[llength $changedTclPlatform] > 0} { 2494 puts [outputChannel] "tcl_platform array elements\ 2495 changed:\t$changedTclPlatform" 2496 } 2497 2498 if {[file exists [file join [workingDirectory] core]]} { 2499 if {[preserveCore] > 1} { 2500 puts "rename core file (> 1)" 2501 puts [outputChannel] "produced core file! \ 2502 Moving file to: \ 2503 [file join [temporaryDirectory] core-$testFileName]" 2504 catch {file rename -force \ 2505 [file join [workingDirectory] core] \ 2506 [file join [temporaryDirectory] core-$testFileName] 2507 } msg 2508 if {[string length $msg] > 0} { 2509 PrintError "Problem renaming file: $msg" 2510 } 2511 } else { 2512 # Print a message if there is a core file and (1) there 2513 # previously wasn't one or (2) the new one is different 2514 # from the old one. 2515 2516 if {[info exists coreModTime]} { 2517 if {$coreModTime != [file mtime \ 2518 [file join [workingDirectory] core]]} { 2519 puts [outputChannel] "A core file was created!" 2520 } 2521 } else { 2522 puts [outputChannel] "A core file was created!" 2523 } 2524 } 2525 } 2526 } 2527 flush [outputChannel] 2528 flush [errorChannel] 2529 return 2530} 2531 2532##################################################################### 2533 2534# Procs that determine which tests/test files to run 2535 2536# tcltest::GetMatchingFiles 2537# 2538# Looks at the patterns given to match and skip files and uses 2539# them to put together a list of the tests that will be run. 2540# 2541# Arguments: 2542# directory to search 2543# 2544# Results: 2545# The constructed list is returned to the user. This will 2546# primarily be used in 'all.tcl' files. It is used in 2547# runAllTests. 2548# 2549# Side Effects: 2550# None 2551 2552# a lower case version is needed for compatibility with tcltest 1.0 2553proc tcltest::getMatchingFiles args {eval GetMatchingFiles $args} 2554 2555proc tcltest::GetMatchingFiles { args } { 2556 if {[llength $args]} { 2557 set dirList $args 2558 } else { 2559 # Finding tests only in [testsDirectory] is normal operation. 2560 # This procedure is written to accept multiple directory arguments 2561 # only to satisfy version 1 compatibility. 2562 set dirList [list [testsDirectory]] 2563 } 2564 2565 set matchingFiles [list] 2566 foreach directory $dirList { 2567 2568 # List files in $directory that match patterns to run. 2569 set matchFileList [list] 2570 foreach match [matchFiles] { 2571 set matchFileList [concat $matchFileList \ 2572 [glob -directory $directory -types {b c f p s} \ 2573 -nocomplain -- $match]] 2574 } 2575 2576 # List files in $directory that match patterns to skip. 2577 set skipFileList [list] 2578 foreach skip [skipFiles] { 2579 set skipFileList [concat $skipFileList \ 2580 [glob -directory $directory -types {b c f p s} \ 2581 -nocomplain -- $skip]] 2582 } 2583 2584 # Add to result list all files in match list and not in skip list 2585 foreach file $matchFileList { 2586 if {[lsearch -exact $skipFileList $file] == -1} { 2587 lappend matchingFiles $file 2588 } 2589 } 2590 } 2591 2592 if {[llength $matchingFiles] == 0} { 2593 PrintError "No test files remain after applying your match and\ 2594 skip patterns!" 2595 } 2596 return $matchingFiles 2597} 2598 2599# tcltest::GetMatchingDirectories -- 2600# 2601# Looks at the patterns given to match and skip directories and 2602# uses them to put together a list of the test directories that we 2603# should attempt to run. (Only subdirectories containing an 2604# "all.tcl" file are put into the list.) 2605# 2606# Arguments: 2607# root directory from which to search 2608# 2609# Results: 2610# The constructed list is returned to the user. This is used in 2611# the primary all.tcl file. 2612# 2613# Side Effects: 2614# None. 2615 2616proc tcltest::GetMatchingDirectories {rootdir} { 2617 2618 # Determine the skip list first, to avoid [glob]-ing over subdirectories 2619 # we're going to throw away anyway. Be sure we skip the $rootdir if it 2620 # comes up to avoid infinite loops. 2621 set skipDirs [list $rootdir] 2622 foreach pattern [skipDirectories] { 2623 set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \ 2624 -nocomplain -- $pattern]] 2625 } 2626 2627 # Now step through the matching directories, prune out the skipped ones 2628 # as you go. 2629 set matchDirs [list] 2630 foreach pattern [matchDirectories] { 2631 foreach path [glob -directory $rootdir -types d -nocomplain -- \ 2632 $pattern] { 2633 if {[lsearch -exact $skipDirs $path] == -1} { 2634 set matchDirs [concat $matchDirs [GetMatchingDirectories $path]] 2635 if {[file exists [file join $path all.tcl]]} { 2636 lappend matchDirs $path 2637 } 2638 } 2639 } 2640 } 2641 2642 if {[llength $matchDirs] == 0} { 2643 DebugPuts 1 "No test directories remain after applying match\ 2644 and skip patterns!" 2645 } 2646 return $matchDirs 2647} 2648 2649# tcltest::runAllTests -- 2650# 2651# prints output and sources test files according to the match and 2652# skip patterns provided. after sourcing test files, it goes on 2653# to source all.tcl files in matching test subdirectories. 2654# 2655# Arguments: 2656# shell being tested 2657# 2658# Results: 2659# None. 2660# 2661# Side effects: 2662# None. 2663 2664proc tcltest::runAllTests { {shell ""} } { 2665 variable testSingleFile 2666 variable numTestFiles 2667 variable numTests 2668 variable failFiles 2669 2670 FillFilesExisted 2671 if {[llength [info level 0]] == 1} { 2672 set shell [interpreter] 2673 } 2674 2675 set testSingleFile false 2676 2677 puts [outputChannel] "Tests running in interp: $shell" 2678 puts [outputChannel] "Tests located in: [testsDirectory]" 2679 puts [outputChannel] "Tests running in: [workingDirectory]" 2680 puts [outputChannel] "Temporary files stored in\ 2681 [temporaryDirectory]" 2682 2683 # [file system] first available in Tcl 8.4 2684 if {![catch {file system [testsDirectory]} result] 2685 && ![string equal native [lindex $result 0]]} { 2686 # If we aren't running in the native filesystem, then we must 2687 # run the tests in a single process (via 'source'), because 2688 # trying to run then via a pipe will fail since the files don't 2689 # really exist. 2690 singleProcess 1 2691 } 2692 2693 if {[singleProcess]} { 2694 puts [outputChannel] \ 2695 "Test files sourced into current interpreter" 2696 } else { 2697 puts [outputChannel] \ 2698 "Test files run in separate interpreters" 2699 } 2700 if {[llength [skip]] > 0} { 2701 puts [outputChannel] "Skipping tests that match: [skip]" 2702 } 2703 puts [outputChannel] "Running tests that match: [match]" 2704 2705 if {[llength [skipFiles]] > 0} { 2706 puts [outputChannel] \ 2707 "Skipping test files that match: [skipFiles]" 2708 } 2709 if {[llength [matchFiles]] > 0} { 2710 puts [outputChannel] \ 2711 "Only running test files that match: [matchFiles]" 2712 } 2713 2714 set timeCmd {clock format [clock seconds]} 2715 puts [outputChannel] "Tests began at [eval $timeCmd]" 2716 2717 # Run each of the specified tests 2718 foreach file [lsort [GetMatchingFiles]] { 2719 set tail [file tail $file] 2720 puts [outputChannel] $tail 2721 flush [outputChannel] 2722 2723 if {[singleProcess]} { 2724 incr numTestFiles 2725 uplevel 1 [list ::source $file] 2726 } else { 2727 # Pass along our configuration to the child processes. 2728 # EXCEPT for the -outfile, because the parent process 2729 # needs to read and process output of children. 2730 set childargv [list] 2731 foreach opt [Configure] { 2732 if {[string equal $opt -outfile]} {continue} 2733 lappend childargv $opt [Configure $opt] 2734 } 2735 set cmd [linsert $childargv 0 | $shell $file] 2736 if {[catch { 2737 incr numTestFiles 2738 set pipeFd [open $cmd "r"] 2739 while {[gets $pipeFd line] >= 0} { 2740 if {[regexp [join { 2741 {^([^:]+):\t} 2742 {Total\t([0-9]+)\t} 2743 {Passed\t([0-9]+)\t} 2744 {Skipped\t([0-9]+)\t} 2745 {Failed\t([0-9]+)} 2746 } ""] $line null testFile \ 2747 Total Passed Skipped Failed]} { 2748 foreach index {Total Passed Skipped Failed} { 2749 incr numTests($index) [set $index] 2750 } 2751 if {$Failed > 0} { 2752 lappend failFiles $testFile 2753 } 2754 } elseif {[regexp [join { 2755 {^Number of tests skipped } 2756 {for each constraint:} 2757 {|^\t(\d+)\t(.+)$} 2758 } ""] $line match skipped constraint]} { 2759 if {[string match \t* $match]} { 2760 AddToSkippedBecause $constraint $skipped 2761 } 2762 } else { 2763 puts [outputChannel] $line 2764 } 2765 } 2766 close $pipeFd 2767 } msg]} { 2768 puts [outputChannel] "Test file error: $msg" 2769 # append the name of the test to a list to be reported 2770 # later 2771 lappend testFileFailures $file 2772 } 2773 } 2774 } 2775 2776 # cleanup 2777 puts [outputChannel] "\nTests ended at [eval $timeCmd]" 2778 cleanupTests 1 2779 if {[info exists testFileFailures]} { 2780 puts [outputChannel] "\nTest files exiting with errors: \n" 2781 foreach file $testFileFailures { 2782 puts [outputChannel] " [file tail $file]\n" 2783 } 2784 } 2785 2786 # Checking for subdirectories in which to run tests 2787 foreach directory [GetMatchingDirectories [testsDirectory]] { 2788 set dir [file tail $directory] 2789 puts [outputChannel] [string repeat ~ 44] 2790 puts [outputChannel] "$dir test began at [eval $timeCmd]\n" 2791 2792 uplevel 1 [list ::source [file join $directory all.tcl]] 2793 2794 set endTime [eval $timeCmd] 2795 puts [outputChannel] "\n$dir test ended at $endTime" 2796 puts [outputChannel] "" 2797 puts [outputChannel] [string repeat ~ 44] 2798 } 2799 return 2800} 2801 2802##################################################################### 2803 2804# Test utility procs - not used in tcltest, but may be useful for 2805# testing. 2806 2807# tcltest::loadTestedCommands -- 2808# 2809# Uses the specified script to load the commands to test. Allowed to 2810# be empty, as the tested commands could have been compiled into the 2811# interpreter. 2812# 2813# Arguments 2814# none 2815# 2816# Results 2817# none 2818# 2819# Side Effects: 2820# none. 2821 2822proc tcltest::loadTestedCommands {} { 2823 variable l 2824 if {[string equal {} [loadScript]]} { 2825 return 2826 } 2827 2828 return [uplevel 1 [loadScript]] 2829} 2830 2831# tcltest::saveState -- 2832# 2833# Save information regarding what procs and variables exist. 2834# 2835# Arguments: 2836# none 2837# 2838# Results: 2839# Modifies the variable saveState 2840# 2841# Side effects: 2842# None. 2843 2844proc tcltest::saveState {} { 2845 variable saveState 2846 uplevel 1 [list ::set [namespace which -variable saveState]] \ 2847 {[::list [::info procs] [::info vars]]} 2848 DebugPuts 2 "[lindex [info level 0] 0]: $saveState" 2849 return 2850} 2851 2852# tcltest::restoreState -- 2853# 2854# Remove procs and variables that didn't exist before the call to 2855# [saveState]. 2856# 2857# Arguments: 2858# none 2859# 2860# Results: 2861# Removes procs and variables from your environment if they don't 2862# exist in the saveState variable. 2863# 2864# Side effects: 2865# None. 2866 2867proc tcltest::restoreState {} { 2868 variable saveState 2869 foreach p [uplevel 1 {::info procs}] { 2870 if {([lsearch [lindex $saveState 0] $p] < 0) 2871 && ![string equal [namespace current]::$p \ 2872 [uplevel 1 [list ::namespace origin $p]]]} { 2873 2874 DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p" 2875 uplevel 1 [list ::catch [list ::rename $p {}]] 2876 } 2877 } 2878 foreach p [uplevel 1 {::info vars}] { 2879 if {[lsearch [lindex $saveState 1] $p] < 0} { 2880 DebugPuts 2 "[lindex [info level 0] 0]:\ 2881 Removing variable $p" 2882 uplevel 1 [list ::catch [list ::unset $p]] 2883 } 2884 } 2885 return 2886} 2887 2888# tcltest::normalizeMsg -- 2889# 2890# Removes "extra" newlines from a string. 2891# 2892# Arguments: 2893# msg String to be modified 2894# 2895# Results: 2896# string with extra newlines removed 2897# 2898# Side effects: 2899# None. 2900 2901proc tcltest::normalizeMsg {msg} { 2902 regsub "\n$" [string tolower $msg] "" msg 2903 set msg [string map [list "\n\n" "\n"] $msg] 2904 return [string map [list "\n\}" "\}"] $msg] 2905} 2906 2907# tcltest::makeFile -- 2908# 2909# Create a new file with the name <name>, and write <contents> to it. 2910# 2911# If this file hasn't been created via makeFile since the last time 2912# cleanupTests was called, add it to the $filesMade list, so it will be 2913# removed by the next call to cleanupTests. 2914# 2915# Arguments: 2916# contents content of the new file 2917# name name of the new file 2918# directory directory name for new file 2919# 2920# Results: 2921# absolute path to the file created 2922# 2923# Side effects: 2924# None. 2925 2926proc tcltest::makeFile {contents name {directory ""}} { 2927 variable filesMade 2928 FillFilesExisted 2929 2930 if {[llength [info level 0]] == 3} { 2931 set directory [temporaryDirectory] 2932 } 2933 2934 set fullName [file join $directory $name] 2935 2936 DebugPuts 3 "[lindex [info level 0] 0]:\ 2937 putting ``$contents'' into $fullName" 2938 2939 set fd [open $fullName w] 2940 fconfigure $fd -translation lf 2941 if {[string equal [string index $contents end] \n]} { 2942 puts -nonewline $fd $contents 2943 } else { 2944 puts $fd $contents 2945 } 2946 close $fd 2947 2948 if {[lsearch -exact $filesMade $fullName] == -1} { 2949 lappend filesMade $fullName 2950 } 2951 return $fullName 2952} 2953 2954# tcltest::removeFile -- 2955# 2956# Removes the named file from the filesystem 2957# 2958# Arguments: 2959# name file to be removed 2960# directory directory from which to remove file 2961# 2962# Results: 2963# return value from [file delete] 2964# 2965# Side effects: 2966# None. 2967 2968proc tcltest::removeFile {name {directory ""}} { 2969 variable filesMade 2970 FillFilesExisted 2971 if {[llength [info level 0]] == 2} { 2972 set directory [temporaryDirectory] 2973 } 2974 set fullName [file join $directory $name] 2975 DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName" 2976 set idx [lsearch -exact $filesMade $fullName] 2977 set filesMade [lreplace $filesMade $idx $idx] 2978 if {$idx == -1} { 2979 DebugDo 1 { 2980 Warn "removeFile removing \"$fullName\":\n not created by makeFile" 2981 } 2982 } 2983 if {![file isfile $fullName]} { 2984 DebugDo 1 { 2985 Warn "removeFile removing \"$fullName\":\n not a file" 2986 } 2987 } 2988 return [file delete $fullName] 2989} 2990 2991# tcltest::makeDirectory -- 2992# 2993# Create a new dir with the name <name>. 2994# 2995# If this dir hasn't been created via makeDirectory since the last time 2996# cleanupTests was called, add it to the $directoriesMade list, so it 2997# will be removed by the next call to cleanupTests. 2998# 2999# Arguments: 3000# name name of the new directory 3001# directory directory in which to create new dir 3002# 3003# Results: 3004# absolute path to the directory created 3005# 3006# Side effects: 3007# None. 3008 3009proc tcltest::makeDirectory {name {directory ""}} { 3010 variable filesMade 3011 FillFilesExisted 3012 if {[llength [info level 0]] == 2} { 3013 set directory [temporaryDirectory] 3014 } 3015 set fullName [file join $directory $name] 3016 DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName" 3017 file mkdir $fullName 3018 if {[lsearch -exact $filesMade $fullName] == -1} { 3019 lappend filesMade $fullName 3020 } 3021 return $fullName 3022} 3023 3024# tcltest::removeDirectory -- 3025# 3026# Removes a named directory from the file system. 3027# 3028# Arguments: 3029# name Name of the directory to remove 3030# directory Directory from which to remove 3031# 3032# Results: 3033# return value from [file delete] 3034# 3035# Side effects: 3036# None 3037 3038proc tcltest::removeDirectory {name {directory ""}} { 3039 variable filesMade 3040 FillFilesExisted 3041 if {[llength [info level 0]] == 2} { 3042 set directory [temporaryDirectory] 3043 } 3044 set fullName [file join $directory $name] 3045 DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName" 3046 set idx [lsearch -exact $filesMade $fullName] 3047 set filesMade [lreplace $filesMade $idx $idx] 3048 if {$idx == -1} { 3049 DebugDo 1 { 3050 Warn "removeDirectory removing \"$fullName\":\n not created\ 3051 by makeDirectory" 3052 } 3053 } 3054 if {![file isdirectory $fullName]} { 3055 DebugDo 1 { 3056 Warn "removeDirectory removing \"$fullName\":\n not a directory" 3057 } 3058 } 3059 return [file delete -force $fullName] 3060} 3061 3062# tcltest::viewFile -- 3063# 3064# reads the content of a file and returns it 3065# 3066# Arguments: 3067# name of the file to read 3068# directory in which file is located 3069# 3070# Results: 3071# content of the named file 3072# 3073# Side effects: 3074# None. 3075 3076proc tcltest::viewFile {name {directory ""}} { 3077 FillFilesExisted 3078 if {[llength [info level 0]] == 2} { 3079 set directory [temporaryDirectory] 3080 } 3081 set fullName [file join $directory $name] 3082 set f [open $fullName] 3083 set data [read -nonewline $f] 3084 close $f 3085 return $data 3086} 3087 3088# tcltest::bytestring -- 3089# 3090# Construct a string that consists of the requested sequence of bytes, 3091# as opposed to a string of properly formed UTF-8 characters. 3092# This allows the tester to 3093# 1. Create denormalized or improperly formed strings to pass to C 3094# procedures that are supposed to accept strings with embedded NULL 3095# bytes. 3096# 2. Confirm that a string result has a certain pattern of bytes, for 3097# instance to confirm that "\xe0\0" in a Tcl script is stored 3098# internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". 3099# 3100# Generally, it's a bad idea to examine the bytes in a Tcl string or to 3101# construct improperly formed strings in this manner, because it involves 3102# exposing that Tcl uses UTF-8 internally. 3103# 3104# Arguments: 3105# string being converted 3106# 3107# Results: 3108# result fom encoding 3109# 3110# Side effects: 3111# None 3112 3113proc tcltest::bytestring {string} { 3114 return [encoding convertfrom identity $string] 3115} 3116 3117# tcltest::OpenFiles -- 3118# 3119# used in io tests, uses testchannel 3120# 3121# Arguments: 3122# None. 3123# 3124# Results: 3125# ??? 3126# 3127# Side effects: 3128# None. 3129 3130proc tcltest::OpenFiles {} { 3131 if {[catch {testchannel open} result]} { 3132 return {} 3133 } 3134 return $result 3135} 3136 3137# tcltest::LeakFiles -- 3138# 3139# used in io tests, uses testchannel 3140# 3141# Arguments: 3142# None. 3143# 3144# Results: 3145# ??? 3146# 3147# Side effects: 3148# None. 3149 3150proc tcltest::LeakFiles {old} { 3151 if {[catch {testchannel open} new]} { 3152 return {} 3153 } 3154 set leak {} 3155 foreach p $new { 3156 if {[lsearch $old $p] < 0} { 3157 lappend leak $p 3158 } 3159 } 3160 return $leak 3161} 3162 3163# 3164# Internationalization / ISO support procs -- dl 3165# 3166 3167# tcltest::SetIso8859_1_Locale -- 3168# 3169# used in cmdIL.test, uses testlocale 3170# 3171# Arguments: 3172# None. 3173# 3174# Results: 3175# None. 3176# 3177# Side effects: 3178# None. 3179 3180proc tcltest::SetIso8859_1_Locale {} { 3181 variable previousLocale 3182 variable isoLocale 3183 if {[info commands testlocale] != ""} { 3184 set previousLocale [testlocale ctype] 3185 testlocale ctype $isoLocale 3186 } 3187 return 3188} 3189 3190# tcltest::RestoreLocale -- 3191# 3192# used in cmdIL.test, uses testlocale 3193# 3194# Arguments: 3195# None. 3196# 3197# Results: 3198# None. 3199# 3200# Side effects: 3201# None. 3202 3203proc tcltest::RestoreLocale {} { 3204 variable previousLocale 3205 if {[info commands testlocale] != ""} { 3206 testlocale ctype $previousLocale 3207 } 3208 return 3209} 3210 3211# tcltest::threadReap -- 3212# 3213# Kill all threads except for the main thread. 3214# Do nothing if testthread is not defined. 3215# 3216# Arguments: 3217# none. 3218# 3219# Results: 3220# Returns the number of existing threads. 3221# 3222# Side Effects: 3223# none. 3224# 3225 3226proc tcltest::threadReap {} { 3227 if {[info commands testthread] != {}} { 3228 3229 # testthread built into tcltest 3230 3231 testthread errorproc ThreadNullError 3232 while {[llength [testthread names]] > 1} { 3233 foreach tid [testthread names] { 3234 if {$tid != [mainThread]} { 3235 catch { 3236 testthread send -async $tid {testthread exit} 3237 } 3238 } 3239 } 3240 ## Enter a bit a sleep to give the threads enough breathing 3241 ## room to kill themselves off, otherwise the end up with a 3242 ## massive queue of repeated events 3243 after 1 3244 } 3245 testthread errorproc ThreadError 3246 return [llength [testthread names]] 3247 } elseif {[info commands thread::id] != {}} { 3248 3249 # Thread extension 3250 3251 thread::errorproc ThreadNullError 3252 while {[llength [thread::names]] > 1} { 3253 foreach tid [thread::names] { 3254 if {$tid != [mainThread]} { 3255 catch {thread::send -async $tid {thread::exit}} 3256 } 3257 } 3258 ## Enter a bit a sleep to give the threads enough breathing 3259 ## room to kill themselves off, otherwise the end up with a 3260 ## massive queue of repeated events 3261 after 1 3262 } 3263 thread::errorproc ThreadError 3264 return [llength [thread::names]] 3265 } else { 3266 return 1 3267 } 3268 return 0 3269} 3270 3271# Initialize the constraints and set up command line arguments 3272namespace eval tcltest { 3273 # Define initializers for all the built-in contraint definitions 3274 DefineConstraintInitializers 3275 3276 # Set up the constraints in the testConstraints array to be lazily 3277 # initialized by a registered initializer, or by "false" if no 3278 # initializer is registered. 3279 trace variable testConstraints r [namespace code SafeFetch] 3280 3281 # Only initialize constraints at package load time if an 3282 # [initConstraintsHook] has been pre-defined. This is only 3283 # for compatibility support. The modern way to add a custom 3284 # test constraint is to just call the [testConstraint] command 3285 # straight away, without all this "hook" nonsense. 3286 if {[string equal [namespace current] \ 3287 [namespace qualifiers [namespace which initConstraintsHook]]]} { 3288 InitConstraints 3289 } else { 3290 proc initConstraintsHook {} {} 3291 } 3292 3293 # Define the standard match commands 3294 customMatch exact [list string equal] 3295 customMatch glob [list string match] 3296 customMatch regexp [list regexp --] 3297 3298 # If the TCLTEST_OPTIONS environment variable exists, configure 3299 # tcltest according to the option values it specifies. This has 3300 # the effect of resetting tcltest's default configuration. 3301 proc ConfigureFromEnvironment {} { 3302 upvar #0 env(TCLTEST_OPTIONS) options 3303 if {[catch {llength $options} msg]} { 3304 Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\ 3305 Tcl list: $msg" 3306 return 3307 } 3308 if {[llength $options] % 2} { 3309 Warn "invalid TCLTEST_OPTIONS: \"$options\":\n should be\ 3310 -option value ?-option value ...?" 3311 return 3312 } 3313 if {[catch {eval [linsert $options 0 Configure]} msg]} { 3314 Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg" 3315 return 3316 } 3317 } 3318 if {[info exists ::env(TCLTEST_OPTIONS)]} { 3319 ConfigureFromEnvironment 3320 } 3321 3322 proc LoadTimeCmdLineArgParsingRequired {} { 3323 set required false 3324 if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} { 3325 # The command line asks for -help, so give it (and exit) 3326 # right now. ([configure] does not process -help) 3327 set required true 3328 } 3329 foreach hook { PrintUsageInfoHook processCmdLineArgsHook 3330 processCmdLineArgsAddFlagsHook } { 3331 if {[string equal [namespace current] [namespace qualifiers \ 3332 [namespace which $hook]]]} { 3333 set required true 3334 } else { 3335 proc $hook args {} 3336 } 3337 } 3338 return $required 3339 } 3340 3341 # Only initialize configurable options from the command line arguments 3342 # at package load time if necessary for backward compatibility. This 3343 # lets the tcltest user call [configure] for themselves if they wish. 3344 # Traces are established for auto-configuration from the command line 3345 # if any configurable options are accessed before the user calls 3346 # [configure]. 3347 if {[LoadTimeCmdLineArgParsingRequired]} { 3348 ProcessCmdLineArgs 3349 } else { 3350 EstablishAutoConfigureTraces 3351 } 3352 3353 package provide [namespace tail [namespace current]] $Version 3354} 3355